{-# LANGUAGE MagicHash #-}
-- | Binary encodings of individual SQL Server scalar types.
--
-- These are the leaf encoders/decoders shared by "Hmssql.Tds.TypeInfo",
-- "Hmssql.Decoding" and "Hmssql.Encoding".
module Hmssql.Tds.Primitives
  ( -- * Reading values in place
    ValueReader

    -- * Writing a value
  , runPutSized

    -- * money / smallmoney
  , E4
  , Money (..)
  , putMoney4, putMoney8
  , readMoney, moneyUnits
  , money4Problem, money8Problem

    -- * datetime / smalldatetime (legacy)
  , putDateTime4, putDateTime8
  , readDateTime4With, readDateTime8With

    -- * date / time / datetime2 / datetimeoffset (TDS 7.3+)
  , Scale
  , DateTimeOffset (..)
  , dateTimeOffsetToZonedTime
  , zonedTimeToDateTimeOffset
  , scaleProblem
  , timeLength
  , putDate
  , putTime
  , putDateTime2
  , putDateTimeOffset
  , readDate, readTime, readDateTime2, readDateTimeOffset
  , readDateWith, readTimeWith, readDateTime2With, readDateTimeOffsetWith
  , localTimeOf, utcTimeOf, picosecondsToTimeOfDay

    -- * decimal / numeric
  , Precision
  , precisionToLength
  , putDecimal
  , readDecimal
  , readDecimalWith

    -- * uniqueidentifier
  , putGuid
  , readGuid

    -- * collation
  , Collation (..)
  , collationAt, putCollation

    -- * UCS-2 strings
  , decodeUtf16LE
  , putUcs2
  , putBVarChar
  , putUsVarChar
  , ucs2Length
  ) where

import Control.Monad (when)
import Data.Binary.Put (Put)
import qualified Data.Binary.Put as Put
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder.Extra as BB
import qualified Data.ByteString.Lazy as LB
import Data.Decimal (Decimal, DecimalRaw (..), roundTo)
import Data.Fixed (Fixed (..), HasResolution (..))
import Data.Int (Int16, Int32, Int64)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import Data.Time
import Data.UUID.Types (UUID)
import qualified Data.UUID.Types as UUID
import Data.Word (Word32, Word64, Word8)

import Hmssql.Internal.Derived
import Hmssql.Tds.Bytes
import qualified Hmssql.Tds.Utf16 as Utf16

------------------------------------------------------------------------------
-- Reading values in place

-- | A conversion of one whole value, given exactly its bytes; where they lay
-- in the packets is the parser's concern.  They may be a slice of a receive
-- buffer, so a reader must copy any it keeps.
type ValueReader a = B.ByteString -> Either String a


-- | Report the actual and expected lengths of a scalar value.
invalidLength :: String -> String -> Int -> Either String a
invalidLength :: forall a. [Char] -> [Char] -> Int -> Either [Char] a
invalidLength [Char]
name [Char]
expected Int
len = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": invalid length " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
len [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expected [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
{-# NOINLINE invalidLength #-}

------------------------------------------------------------------------------
-- Writing a value

-- | The bytes of a short 'Put' of (at most, or it is slower) @n@ bytes, in
-- a buffer of that size: how a parameter's value is encoded by the @put*@
-- functions below.  binary's own 'Put.runPut' starts with a 4 KiB buffer,
-- a large object of its own, and 'LB.toStrict' then copies the few bytes
-- out of it: about 100 ns and 4 KiB per value.
runPutSized :: Int -> Put -> B.ByteString
runPutSized :: Int -> Put -> ByteString
runPutSized Int
n = LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString)
-> (Put -> LazyByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllocationStrategy -> LazyByteString -> Builder -> LazyByteString
BB.toLazyByteStringWith (Int -> Int -> AllocationStrategy
BB.untrimmedStrategy Int
n Int
n) LazyByteString
LB.empty (Builder -> LazyByteString)
-> (Put -> Builder) -> Put -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> Builder
forall a. PutM a -> Builder
Put.execPut

------------------------------------------------------------------------------
-- money

-- | Resolution of 1/10000, matching @money@ and @smallmoney@.
data E4

instance HasResolution E4 where
  resolution :: forall (p :: * -> *). p E4 -> Integer
resolution p E4
_ = Integer
10000

-- | A @money@ or @smallmoney@ value: a fixed-point number with four
-- decimal places, exactly as the server stores it.
newtype Money = Money (Fixed E4)
  deriving newtype (Money -> Money -> Bool
(Money -> Money -> Bool) -> (Money -> Money -> Bool) -> Eq Money
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Money -> Money -> Bool
== :: Money -> Money -> Bool
$c/= :: Money -> Money -> Bool
/= :: Money -> Money -> Bool
Eq, Eq Money
Eq Money =>
(Money -> Money -> Ordering)
-> (Money -> Money -> Bool)
-> (Money -> Money -> Bool)
-> (Money -> Money -> Bool)
-> (Money -> Money -> Bool)
-> (Money -> Money -> Money)
-> (Money -> Money -> Money)
-> Ord Money
Money -> Money -> Bool
Money -> Money -> Ordering
Money -> Money -> Money
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Money -> Money -> Ordering
compare :: Money -> Money -> Ordering
$c< :: Money -> Money -> Bool
< :: Money -> Money -> Bool
$c<= :: Money -> Money -> Bool
<= :: Money -> Money -> Bool
$c> :: Money -> Money -> Bool
> :: Money -> Money -> Bool
$c>= :: Money -> Money -> Bool
>= :: Money -> Money -> Bool
$cmax :: Money -> Money -> Money
max :: Money -> Money -> Money
$cmin :: Money -> Money -> Money
min :: Money -> Money -> Money
Ord, Integer -> Money
Money -> Money
Money -> Money -> Money
(Money -> Money -> Money)
-> (Money -> Money -> Money)
-> (Money -> Money -> Money)
-> (Money -> Money)
-> (Money -> Money)
-> (Money -> Money)
-> (Integer -> Money)
-> Num Money
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Money -> Money -> Money
+ :: Money -> Money -> Money
$c- :: Money -> Money -> Money
- :: Money -> Money -> Money
$c* :: Money -> Money -> Money
* :: Money -> Money -> Money
$cnegate :: Money -> Money
negate :: Money -> Money
$cabs :: Money -> Money
abs :: Money -> Money
$csignum :: Money -> Money
signum :: Money -> Money
$cfromInteger :: Integer -> Money
fromInteger :: Integer -> Money
Num, Num Money
Num Money =>
(Money -> Money -> Money)
-> (Money -> Money) -> (Rational -> Money) -> Fractional Money
Rational -> Money
Money -> Money
Money -> Money -> Money
forall a.
Num a =>
(a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
$c/ :: Money -> Money -> Money
/ :: Money -> Money -> Money
$crecip :: Money -> Money
recip :: Money -> Money
$cfromRational :: Rational -> Money
fromRational :: Rational -> Money
Fractional, Num Money
Ord Money
(Num Money, Ord Money) => (Money -> Rational) -> Real Money
Money -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: Money -> Rational
toRational :: Money -> Rational
Real, Fractional Money
Real Money
(Real Money, Fractional Money) =>
(forall b. Integral b => Money -> (b, Money))
-> (forall b. Integral b => Money -> b)
-> (forall b. Integral b => Money -> b)
-> (forall b. Integral b => Money -> b)
-> (forall b. Integral b => Money -> b)
-> RealFrac Money
forall b. Integral b => Money -> b
forall b. Integral b => Money -> (b, Money)
forall a.
(Real a, Fractional a) =>
(forall b. Integral b => a -> (b, a))
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> RealFrac a
$cproperFraction :: forall b. Integral b => Money -> (b, Money)
properFraction :: forall b. Integral b => Money -> (b, Money)
$ctruncate :: forall b. Integral b => Money -> b
truncate :: forall b. Integral b => Money -> b
$cround :: forall b. Integral b => Money -> b
round :: forall b. Integral b => Money -> b
$cceiling :: forall b. Integral b => Money -> b
ceiling :: forall b. Integral b => Money -> b
$cfloor :: forall b. Integral b => Money -> b
floor :: forall b. Integral b => Money -> b
RealFrac)

instance Show Money where
  showsPrec :: Int -> Money -> [Char] -> [Char]
showsPrec Int
p (Money Fixed E4
a) = Int -> Addr# -> Fixed E4 -> [Char] -> [Char]
forall a. Show a => Int -> Addr# -> a -> [Char] -> [Char]
showCon1 Int
p Addr#
"Money"# Fixed E4
a
  {-# OPAQUE showsPrec #-}

-- | @smallmoney@ (4 bytes) or @money@ (8 bytes), by the value's length.  A
-- @money@ value is two little-endian DWORDs, the high half first.
readMoney :: ValueReader Money
readMoney :: ValueReader Money
readMoney ByteString
bs = case ByteString -> Int
B.length ByteString
bs of
  Int
4 -> Money -> Either [Char] Money
forall a b. b -> Either a b
Right (Money -> Either [Char] Money) -> Money -> Either [Char] Money
forall a b. (a -> b) -> a -> b
$! Fixed E4 -> Money
Money (Integer -> Fixed E4
forall k (a :: k). Integer -> Fixed a
MkFixed (Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int -> Int32
int32LeAt ByteString
bs Int
0)))
  Int
8 ->
    let hi :: Int32
hi = ByteString -> Int -> Int32
int32LeAt ByteString
bs Int
0
        lo :: Word32
lo = ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
4
        i :: Int64
i = (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
hi Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32) Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.|. Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
lo :: Int64
     in Money -> Either [Char] Money
forall a b. b -> Either a b
Right (Money -> Either [Char] Money) -> Money -> Either [Char] Money
forall a b. (a -> b) -> a -> b
$! Fixed E4 -> Money
Money (Integer -> Fixed E4
forall k (a :: k). Integer -> Fixed a
MkFixed (Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
i))
  Int
_ -> [Char] -> Either [Char] Money
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Money) -> [Char] -> Either [Char] Money
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid money length " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int
B.length ByteString
bs)

-- | A @money@ or @smallmoney@ value as its count of 1\/10000ths.
moneyUnits :: ValueReader Int64
moneyUnits :: ValueReader Int64
moneyUnits ByteString
bs = case ByteString -> Int
B.length ByteString
bs of
  Int
4 -> Int64 -> Either [Char] Int64
forall a b. b -> Either a b
Right (Int64 -> Either [Char] Int64) -> Int64 -> Either [Char] Int64
forall a b. (a -> b) -> a -> b
$! Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Int32
int32LeAt ByteString
bs Int
0)
  Int
8 -> Int64 -> Either [Char] Int64
forall a b. b -> Either a b
Right (Int64 -> Either [Char] Int64) -> Int64 -> Either [Char] Int64
forall a b. (a -> b) -> a -> b
$! (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Int32
int32LeAt ByteString
bs Int
0) Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32) Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.|. Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
4)
  Int
_ -> [Char] -> Either [Char] Int64
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Int64) -> [Char] -> Either [Char] Int64
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid money length " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int
B.length ByteString
bs)

-- | Why a 'Money' value doesn't fit in @money@ (a signed 64-bit count of
-- 1\/10000ths: -922,337,203,685,477.5808 through 922,337,203,685,477.5807),
-- if it doesn't.  'Money' itself is unbounded.
money8Problem :: Money -> Maybe String
money8Problem :: Money -> Maybe [Char]
money8Problem = [Char] -> Int64 -> Int64 -> Money -> Maybe [Char]
forall n. Integral n => [Char] -> n -> n -> Money -> Maybe [Char]
moneyRangeProblem [Char]
"money" (Int64
forall a. Bounded a => a
minBound :: Int64) Int64
forall a. Bounded a => a
maxBound

-- | Likewise for @smallmoney@ (-214,748.3648 through 214,748.3647).
money4Problem :: Money -> Maybe String
money4Problem :: Money -> Maybe [Char]
money4Problem = [Char] -> Int32 -> Int32 -> Money -> Maybe [Char]
forall n. Integral n => [Char] -> n -> n -> Money -> Maybe [Char]
moneyRangeProblem [Char]
"smallmoney" (Int32
forall a. Bounded a => a
minBound :: Int32) Int32
forall a. Bounded a => a
maxBound

moneyRangeProblem :: Integral n => String -> n -> n -> Money -> Maybe String
moneyRangeProblem :: forall n. Integral n => [Char] -> n -> n -> Money -> Maybe [Char]
moneyRangeProblem [Char]
name n
lo n
hi m :: Money
m@(Money (MkFixed Integer
i))
  | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< n -> Integer
forall a. Integral a => a -> Integer
toInteger n
lo Bool -> Bool -> Bool
|| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> n -> Integer
forall a. Integral a => a -> Integer
toInteger n
hi = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
      [Char]
"value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Money -> [Char]
forall a. Show a => a -> [Char]
show Money
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is out of range for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ("
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Money -> [Char]
forall a. Show a => a -> [Char]
show (Fixed E4 -> Money
Money (Integer -> Fixed E4
forall k (a :: k). Integer -> Fixed a
MkFixed (n -> Integer
forall a. Integral a => a -> Integer
toInteger n
lo))) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" through " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Money -> [Char]
forall a. Show a => a -> [Char]
show (Fixed E4 -> Money
Money (Integer -> Fixed E4
forall k (a :: k). Integer -> Fixed a
MkFixed (n -> Integer
forall a. Integral a => a -> Integer
toInteger n
hi))) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing

-- | Fails (with 'error') outside the @smallmoney@ range ('money4Problem').
putMoney4 :: Money -> Put
putMoney4 :: Money -> Put
putMoney4 m :: Money
m@(Money (MkFixed Integer
i)) = case Money -> Maybe [Char]
money4Problem Money
m of
  Just [Char]
p -> [Char] -> Put
forall a. HasCallStack => [Char] -> a
error ([Char]
"putMoney4: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p)
  Maybe [Char]
Nothing -> Int32 -> Put
Put.putInt32le (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)

-- | Fails (with 'error') outside the @money@ range ('money8Problem') rather
-- than sending the value modulo 2^64.
putMoney8 :: Money -> Put
putMoney8 :: Money -> Put
putMoney8 m :: Money
m@(Money (MkFixed Integer
i)) = do
  ([Char] -> PutM (ZonkAny 0)) -> Maybe [Char] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
p -> [Char] -> PutM (ZonkAny 0)
forall a. HasCallStack => [Char] -> a
error ([Char]
"putMoney8: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p)) (Money -> Maybe [Char]
money8Problem Money
m)
  let i64 :: Int64
i64 = Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Int64
  Int32 -> Put
Put.putInt32le (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
i64 Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
i64 Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. Int64
0xFFFFFFFF)

------------------------------------------------------------------------------
-- Rounding and range checks shared by the date/time encoders
--
-- Every encoder rounds to the nearest unit of its type (half up), as SQL
-- Server does when converting to a lower precision, and checks the type's
-- range:
--
-- * Types with a date part carry into the next day (23:59:59.9999999 at
--   scale 0 is midnight of the next day).  A value on the type's last day
--   that rounds past its maximum is clamped to the maximum, as SQL Server
--   does when converting @datetime2(7)@ to @datetime2(0)@ or @datetime@.
--   Values outside the type's range are rejected with a 'Left'.
-- * @time@ has no next day, so a value that rounds to 24:00:00 is clamped to
--   the last unit of the day (23:59:59 at scale 0), again as the server does.
-- * A leap second (second 60 of 'TimeOfDay', or a 'UTCTime' day time of
--   86400 s or more) counts as the following second: it carries into the
--   next day, or clamps for @time@.

-- | A clock resolution and range: @clockUnits@ units per @clockPer@
-- picoseconds, counted from midnight of @clockEpoch@, valid from midnight of
-- @clockMinDay@ to the last unit of @clockMaxDay@.
data Clock = Clock
  { Clock -> [Char]
clockType :: String
  , Clock -> Integer
clockUnits :: !Integer
  , Clock -> Integer
clockPer :: !Integer
  , Clock -> Day
clockEpoch :: !Day
  , Clock -> Day
clockMinDay :: !Day
  , Clock -> Day
clockMaxDay :: !Day
  }

picosPerDay :: Integer
picosPerDay :: Integer
picosPerDay = Integer
86400 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1_000_000_000_000

clockUnitsPerDay :: Clock -> Integer
clockUnitsPerDay :: Clock -> Integer
clockUnitsPerDay Clock
c = Integer
picosPerDay Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Clock -> Integer
clockUnits Clock
c Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Clock -> Integer
clockPer Clock
c

-- | Round picoseconds to the clock's units, half up.
clockRound :: Clock -> Integer -> Integer
clockRound :: Clock -> Integer -> Integer
clockRound Clock
c Integer
ps = (Integer
ps Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Clock -> Integer
clockUnits Clock
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Clock -> Integer
clockPer Clock
c Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Clock -> Integer
clockPer Clock
c

-- | For a scale from 0 through 7 ('scaleProblem'): @clockPer@ is
-- @10 ^ (12 - s)@, a unit finer than any SQL Server type for 8 through 12
-- and an exception (negative exponent) from 13 on.
scaleClock :: String -> Scale -> Clock
scaleClock :: [Char] -> Word8 -> Clock
scaleClock [Char]
name Word8
s = [Char] -> Integer -> Integer -> Day -> Day -> Day -> Clock
Clock [Char]
name Integer
1 (Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
s :: Int)) Day
epoch0001 Day
epoch0001 Day
lastDay

dateTimeClock :: Clock
dateTimeClock :: Clock
dateTimeClock = [Char] -> Integer -> Integer -> Day -> Day -> Day -> Clock
Clock [Char]
"datetime" Integer
300 Integer
1_000_000_000_000 Day
epoch1900 (Integer -> Int -> Int -> Day
fromGregorian Integer
1753 Int
1 Int
1) Day
lastDay

smallDateTimeClock :: Clock
smallDateTimeClock :: Clock
smallDateTimeClock = [Char] -> Integer -> Integer -> Day -> Day -> Day -> Clock
Clock [Char]
"smalldatetime" Integer
1 (Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1_000_000_000_000) Day
epoch1900 Day
epoch1900 (Integer -> Int -> Int -> Day
fromGregorian Integer
2079 Int
6 Int
6)

lastDay :: Day
lastDay :: Day
lastDay = Integer -> Int -> Int -> Day
fromGregorian Integer
9999 Int
12 Int
31

-- | Picoseconds since midnight.  Rejects fields out of range; a leap second
-- (second 60) gives 86400 s or more.
timeOfDayPicoseconds :: TimeOfDay -> Either String Integer
timeOfDayPicoseconds :: TimeOfDay -> Either [Char] Integer
timeOfDayPicoseconds tod :: TimeOfDay
tod@(TimeOfDay Int
h Int
m Pico
s)
  | Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
23 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
59 Bool -> Bool -> Bool
|| Pico
s Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
< Pico
0 Bool -> Bool -> Bool
|| Pico
s Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
>= Pico
61 = [Char] -> Either [Char] Integer
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Integer)
-> [Char] -> Either [Char] Integer
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid time of day " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TimeOfDay -> [Char]
forall a. Show a => a -> [Char]
show TimeOfDay
tod
  | Bool
otherwise = Integer -> Either [Char] Integer
forall a b. b -> Either a b
Right (Integer -> Either [Char] Integer)
-> Integer -> Either [Char] Integer
forall a b. (a -> b) -> a -> b
$ DiffTime -> Integer
diffTimeToPicoseconds (TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
tod)

outOfRange :: Clock -> String -> Either String a
outOfRange :: forall a. Clock -> [Char] -> Either [Char] a
outOfRange Clock
c [Char]
what = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a b. (a -> b) -> a -> b
$
  Clock -> [Char]
clockType Clock
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
what [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is out of range (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Day -> [Char]
showGregorian (Clock -> Day
clockMinDay Clock
c)
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" through " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Day -> [Char]
showGregorian (Clock -> Day
clockMaxDay Clock
c) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

-- | Units since the clock's epoch, rounded and range-checked.  @shift@ (in
-- units) is added to get a second value that must also be in range (the local
-- time of a @datetimeoffset@); @shiftDay@ is that value's unrounded day.
clockValue :: Clock -> Integer -> Day -> LocalTime -> Either String Integer
clockValue :: Clock -> Integer -> Day -> LocalTime -> Either [Char] Integer
clockValue Clock
c Integer
shift Day
shiftDay lt :: LocalTime
lt@(LocalTime Day
day TimeOfDay
tod) = do
  ps <- TimeOfDay -> Either [Char] Integer
timeOfDayPicoseconds TimeOfDay
tod
  let perDay = Clock -> Integer
clockUnitsPerDay Clock
c
      lo = Day -> Day -> Integer
diffDays (Clock -> Day
clockMinDay Clock
c) (Clock -> Day
clockEpoch Clock
c) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
perDay
      hi = (Day -> Day -> Integer
diffDays (Clock -> Day
clockMaxDay Clock
c) (Clock -> Day
clockEpoch Clock
c) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
perDay Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
      u = Day -> Day -> Integer
diffDays Day
day (Clock -> Day
clockEpoch Clock
c) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
perDay Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Clock -> Integer -> Integer
clockRound Clock
c Integer
ps
  if | day > clockMaxDay c || shiftDay > clockMaxDay c -> outOfRange c (show lt)
     | u < lo || u + shift < lo -> outOfRange c (show lt)
     | otherwise -> Right $ minimum [u, hi, hi - shift]

------------------------------------------------------------------------------
-- datetime / smalldatetime

epoch1900 :: Day
epoch1900 :: Day
epoch1900 = Integer -> Int -> Int -> Day
fromGregorian Integer
1900 Int
1 Int
1

-- | The modified Julian day number of 1900-01-01.
mjd1900 :: Int
mjd1900 :: Int
mjd1900 = Int
15020

-- | @smalldatetime@, passing the day and the picoseconds since midnight to
-- the function ('localTimeOf', 'utcTimeOf').
readDateTime4With :: (Day -> Int64 -> a) -> ValueReader a
readDateTime4With :: forall a. (Day -> Int64 -> a) -> ValueReader a
readDateTime4With Day -> Int64 -> a
k ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
4 = [Char] -> [Char] -> Int -> Either [Char] a
forall a. [Char] -> [Char] -> Int -> Either [Char] a
invalidLength [Char]
"smalldatetime" [Char]
"4 bytes" (ByteString -> Int
B.length ByteString
bs)
  | Word16
mins Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word16
1440 = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a b. (a -> b) -> a -> b
$ [Char]
"smalldatetime: invalid minute count " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
mins
  | Bool
otherwise = a -> Either [Char] a
forall a b. b -> Either a b
Right (a -> Either [Char] a) -> a -> Either [Char] a
forall a b. (a -> b) -> a -> b
$! Day -> Int64 -> a
k (Int -> Day
dayOf (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
days Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mjd1900)) (Word16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
mins Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
60_000_000_000_000)
  where
    days :: Word16
days = ByteString -> Int -> Word16
word16LeAt ByteString
bs Int
0
    mins :: Word16
mins = ByteString -> Int -> Word16
word16LeAt ByteString
bs Int
2
{-# INLINE readDateTime4With #-}

-- | @datetime@, passing the day and the picoseconds since midnight (rounded
-- down) to the function.
readDateTime8With :: (Day -> Int64 -> a) -> ValueReader a
readDateTime8With :: forall a. (Day -> Int64 -> a) -> ValueReader a
readDateTime8With Day -> Int64 -> a
k ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
8 = [Char] -> [Char] -> Int -> Either [Char] a
forall a. [Char] -> [Char] -> Int -> Either [Char] a
invalidLength [Char]
"datetime" [Char]
"8 bytes" (ByteString -> Int
B.length ByteString
bs)
  | Word32
ticks Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
300 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
86400 = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a b. (a -> b) -> a -> b
$ [Char]
"datetime: invalid tick count " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
ticks
  -- 1753-01-01 through 9999-12-31
  | Int32
days Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< -Int32
53690 Bool -> Bool -> Bool
|| Int32
days Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
2958463 = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a b. (a -> b) -> a -> b
$ [Char]
"datetime: invalid day count " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int32 -> [Char]
forall a. Show a => a -> [Char]
show Int32
days
  | Bool
otherwise = a -> Either [Char] a
forall a b. b -> Either a b
Right (a -> Either [Char] a) -> a -> Either [Char] a
forall a b. (a -> b) -> a -> b
$! Day -> Int64 -> a
k (Int -> Day
dayOf (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
days Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mjd1900)) Int64
ps
  where
    days :: Int32
days = ByteString -> Int -> Int32
int32LeAt ByteString
bs Int
0
    ticks :: Word32
ticks = ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
4
    -- ticks * 10^12 / 300 overflows 64 bits; the seconds and the rest don't.
    (Int64
secs, Int64
rest) = Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ticks Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
300 :: (Int64, Int64)
    ps :: Int64
ps = Int64
secs Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1_000_000_000_000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
rest Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1_000_000_000_000 Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`quot` Int64
300
{-# INLINE readDateTime8With #-}

-- | Rounds to the nearest minute (1900-01-01 through 2079-06-06).
putDateTime4 :: LocalTime -> Either String Put
putDateTime4 :: LocalTime -> Either [Char] Put
putDateTime4 LocalTime
lt = do
  u <- Clock -> Integer -> Day -> LocalTime -> Either [Char] Integer
clockValue Clock
smallDateTimeClock Integer
0 Day
epoch1900 LocalTime
lt
  let (days, mins) = u `divMod` 1440
  pure $ Put.putWord16le (fromIntegral days) >> Put.putWord16le (fromIntegral mins)

-- | Rounds to the nearest 1/300 s (1753-01-01 through 9999-12-31).
putDateTime8 :: LocalTime -> Either String Put
putDateTime8 :: LocalTime -> Either [Char] Put
putDateTime8 LocalTime
lt = do
  u <- Clock -> Integer -> Day -> LocalTime -> Either [Char] Integer
clockValue Clock
dateTimeClock Integer
0 Day
epoch1900 LocalTime
lt
  let (days, ticks) = u `divMod` clockUnitsPerDay dateTimeClock
  pure $ Put.putInt32le (fromIntegral days) >> Put.putWord32le (fromIntegral ticks)

------------------------------------------------------------------------------
-- date / time / datetime2 / datetimeoffset

type Scale = Word8

-- | A @datetimeoffset@ value: an instant plus the UTC offset it was recorded with.
data DateTimeOffset = DateTimeOffset
  { DateTimeOffset -> UTCTime
dtoUtcTime :: !UTCTime
    -- ^ The instant.
  , DateTimeOffset -> Int16
dtoOffsetMinutes :: !Int16
    -- ^ The offset from UTC the value was recorded with, in minutes; the
    -- local clock time is the instant plus this.
  }
  deriving stock (Eq DateTimeOffset
Eq DateTimeOffset =>
(DateTimeOffset -> DateTimeOffset -> Ordering)
-> (DateTimeOffset -> DateTimeOffset -> Bool)
-> (DateTimeOffset -> DateTimeOffset -> Bool)
-> (DateTimeOffset -> DateTimeOffset -> Bool)
-> (DateTimeOffset -> DateTimeOffset -> Bool)
-> (DateTimeOffset -> DateTimeOffset -> DateTimeOffset)
-> (DateTimeOffset -> DateTimeOffset -> DateTimeOffset)
-> Ord DateTimeOffset
DateTimeOffset -> DateTimeOffset -> Bool
DateTimeOffset -> DateTimeOffset -> Ordering
DateTimeOffset -> DateTimeOffset -> DateTimeOffset
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DateTimeOffset -> DateTimeOffset -> Ordering
compare :: DateTimeOffset -> DateTimeOffset -> Ordering
$c< :: DateTimeOffset -> DateTimeOffset -> Bool
< :: DateTimeOffset -> DateTimeOffset -> Bool
$c<= :: DateTimeOffset -> DateTimeOffset -> Bool
<= :: DateTimeOffset -> DateTimeOffset -> Bool
$c> :: DateTimeOffset -> DateTimeOffset -> Bool
> :: DateTimeOffset -> DateTimeOffset -> Bool
$c>= :: DateTimeOffset -> DateTimeOffset -> Bool
>= :: DateTimeOffset -> DateTimeOffset -> Bool
$cmax :: DateTimeOffset -> DateTimeOffset -> DateTimeOffset
max :: DateTimeOffset -> DateTimeOffset -> DateTimeOffset
$cmin :: DateTimeOffset -> DateTimeOffset -> DateTimeOffset
min :: DateTimeOffset -> DateTimeOffset -> DateTimeOffset
Ord)

instance Show DateTimeOffset where
  showsPrec :: Int -> DateTimeOffset -> [Char] -> [Char]
showsPrec Int
p (DateTimeOffset UTCTime
a Int16
b) =
    Int -> Addr# -> [Field] -> [Char] -> [Char]
showRecord Int
p Addr#
"DateTimeOffset"# [Addr#
"dtoUtcTime"# Addr# -> UTCTime -> Field
forall a. Show a => Addr# -> a -> Field
:= UTCTime
a, Addr#
"dtoOffsetMinutes"# Addr# -> Int16 -> Field
forall a. Show a => Addr# -> a -> Field
:= Int16
b]
  {-# OPAQUE showsPrec #-}

instance Eq DateTimeOffset where
  DateTimeOffset UTCTime
a Int16
b == :: DateTimeOffset -> DateTimeOffset -> Bool
== DateTimeOffset UTCTime
a' Int16
b' = UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
eq UTCTime
a UTCTime
a' Bool -> Bool -> Bool
&& Int16
b Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
== Int16
b'
  {-# OPAQUE (==) #-}

-- | The same instant as a 'ZonedTime' in the value's offset.
dateTimeOffsetToZonedTime :: DateTimeOffset -> ZonedTime
dateTimeOffsetToZonedTime :: DateTimeOffset -> ZonedTime
dateTimeOffsetToZonedTime (DateTimeOffset UTCTime
utc Int16
mins) =
  TimeZone -> UTCTime -> ZonedTime
utcToZonedTime (Int -> TimeZone
minutesToTimeZone (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
mins)) UTCTime
utc

-- | An offset beyond the range of 'Int16' is clamped to it rather than
-- wrapped (so it stays outside the ±14:00 a @datetimeoffset@ allows, and
-- 'putDateTimeOffset' rejects it).
zonedTimeToDateTimeOffset :: ZonedTime -> DateTimeOffset
zonedTimeToDateTimeOffset :: ZonedTime -> DateTimeOffset
zonedTimeToDateTimeOffset ZonedTime
zt =
  UTCTime -> Int16 -> DateTimeOffset
DateTimeOffset (ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
zt) (Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
lo (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
hi Int
mins)))
  where
    mins :: Int
mins = TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
zt)
    lo :: Int
lo = Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16
forall a. Bounded a => a
minBound :: Int16)
    hi :: Int
hi = Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16
forall a. Bounded a => a
maxBound :: Int16)

epoch0001 :: Day
epoch0001 :: Day
epoch0001 = Integer -> Int -> Int -> Day
fromGregorian Integer
1 Int
1 Int
1

-- | Why a @time@, @datetime2@ or @datetimeoffset@ (named) can't have this
-- scale, if it can't: MS-TDS 2.2.5.4.2 allows 0 through 7.  Every
-- exported function here that takes a scale checks it with this.
scaleProblem :: String -> Scale -> Maybe String
scaleProblem :: [Char] -> Word8 -> Maybe [Char]
scaleProblem [Char]
name Word8
s
  | Word8
s Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
7 = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" scale " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (0 through 7)"
  | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing

checkScale :: String -> Scale -> Either String ()
checkScale :: [Char] -> Word8 -> Either [Char] ()
checkScale [Char]
name Word8
s = Either [Char] ()
-> ([Char] -> Either [Char] ()) -> Maybe [Char] -> Either [Char] ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either [Char] ()
forall a b. b -> Either a b
Right ()) [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char] -> Word8 -> Maybe [Char]
scaleProblem [Char]
name Word8
s)

-- | Number of bytes used for the time portion at a given scale (5 for any
-- scale above 4, including invalid ones: see 'scaleProblem').
timeLength :: Scale -> Int
timeLength :: Word8 -> Int
timeLength Word8
s
  | Word8
s Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
2 = Int
3
  | Word8
s Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
4 = Int
4
  | Bool
otherwise = Int
5

putUIntLE :: Int -> Word64 -> Put
putUIntLE :: Int -> Word64 -> Put
putUIntLE Int
n Word64
v = (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int
i -> Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

-- | @date@: 3-byte count of days since 0001-01-01.
readDate :: ValueReader Day
readDate :: ValueReader Day
readDate = (Day -> Day) -> ValueReader Day
forall a. (Day -> a) -> ValueReader a
readDateWith Day -> Day
forall a. a -> a
id
{-# INLINE readDate #-}

-- | @date@, passing the day to the function.
readDateWith :: (Day -> a) -> ValueReader a
readDateWith :: forall a. (Day -> a) -> ValueReader a
readDateWith Day -> a
k ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
3 = [Char] -> [Char] -> Int -> Either [Char] a
forall a. [Char] -> [Char] -> Int -> Either [Char] a
invalidLength [Char]
"date" [Char]
"3 bytes" (ByteString -> Int
B.length ByteString
bs)
  | Bool
otherwise = do
      !d <- ByteString -> Int -> Either [Char] Day
dateAt ByteString
bs Int
0
      Right $! k d
{-# INLINE readDateWith #-}

-- | The 3-byte day count at the offset.
dateAt :: B.ByteString -> Int -> Either String Day
dateAt :: ByteString -> Int -> Either [Char] Day
dateAt ByteString
bs Int
off
  -- 9999-12-31
  | Word64
d Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
3_652_058 = [Char] -> Either [Char] Day
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Day) -> [Char] -> Either [Char] Day
forall a b. (a -> b) -> a -> b
$ [Char]
"date: invalid day count " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
d
  | Bool
otherwise = Day -> Either [Char] Day
forall a b. b -> Either a b
Right (Day -> Either [Char] Day) -> Day -> Either [Char] Day
forall a b. (a -> b) -> a -> b
$! Int -> Day
dayOf (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mjd0001)
  where
    d :: Word64
d = Int -> ByteString -> Int -> Word64
wordLeAt Int
3 ByteString
bs Int
off
{-# INLINE dateAt #-}

-- | The modified Julian day number of 0001-01-01.
mjd0001 :: Int
mjd0001 :: Int
mjd0001 = -Int
678575

-- | A day from its modified Julian day number.
dayOf :: Int -> Day
dayOf :: Int -> Day
dayOf Int
n = Integer -> Day
ModifiedJulianDay (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n)
{-# INLINE dayOf #-}

-- | Picoseconds per unit at a scale from 0 through 7: @10 ^ (12 - s)@.
picosPerUnit :: Scale -> Int64
picosPerUnit :: Word8 -> Int64
picosPerUnit = \case
  Word8
0 -> Int64
1_000_000_000_000
  Word8
1 -> Int64
100_000_000_000
  Word8
2 -> Int64
10_000_000_000
  Word8
3 -> Int64
1_000_000_000
  Word8
4 -> Int64
100_000_000
  Word8
5 -> Int64
10_000_000
  Word8
6 -> Int64
1_000_000
  Word8
_ -> Int64
100_000

-- | Units per day at a scale from 0 through 7: @86400 * 10 ^ s@.
unitsPerDay :: Scale -> Word64
unitsPerDay :: Word8 -> Word64
unitsPerDay = \case
  Word8
0 -> Word64
86_400
  Word8
1 -> Word64
864_000
  Word8
2 -> Word64
8_640_000
  Word8
3 -> Word64
86_400_000
  Word8
4 -> Word64
864_000_000
  Word8
5 -> Word64
8_640_000_000
  Word8
6 -> Word64
86_400_000_000
  Word8
_ -> Word64
864_000_000_000

-- | The time units (of a scale already checked) at the offset, as
-- picoseconds since midnight.
timeAt :: Scale -> B.ByteString -> Int -> Either String Int64
timeAt :: Word8 -> ByteString -> Int -> Either [Char] Int64
timeAt Word8
scale ByteString
bs Int
off
  | Word64
units Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8 -> Word64
unitsPerDay Word8
scale = [Char] -> Either [Char] Int64
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Int64) -> [Char] -> Either [Char] Int64
forall a b. (a -> b) -> a -> b
$ [Char]
"time: invalid unit count " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
units
  | Bool
otherwise = Int64 -> Either [Char] Int64
forall a b. b -> Either a b
Right (Int64 -> Either [Char] Int64) -> Int64 -> Either [Char] Int64
forall a b. (a -> b) -> a -> b
$! Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
units Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Word8 -> Int64
picosPerUnit Word8
scale
  where
    units :: Word64
units = Int -> ByteString -> Int -> Word64
wordLeAt (Word8 -> Int
timeLength Word8
scale) ByteString
bs Int
off
{-# INLINE timeAt #-}

-- | A time of day from picoseconds since midnight (less than a day).
picosecondsToTimeOfDay :: Int64 -> TimeOfDay
picosecondsToTimeOfDay :: Int64 -> TimeOfDay
picosecondsToTimeOfDay Int64
ps =
  let (Int64
h, Int64
r) = Int64
ps Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
3_600_000_000_000_000
      (Int64
m, Int64
s) = Int64
r Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
60_000_000_000_000
      !h' :: Int
h' = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
h
      !m' :: Int
m' = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
m
      !s' :: Fixed a
s' = Integer -> Fixed a
forall k (a :: k). Integer -> Fixed a
MkFixed (Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
s)
   in Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h' Int
m' Pico
forall {a}. Fixed a
s'
{-# INLINE picosecondsToTimeOfDay #-}

-- | A 'LocalTime', evaluated, from a day and picoseconds since midnight.
localTimeOf :: Day -> Int64 -> LocalTime
localTimeOf :: Day -> Int64 -> LocalTime
localTimeOf !Day
day Int64
ps = let !tod :: TimeOfDay
tod = Int64 -> TimeOfDay
picosecondsToTimeOfDay Int64
ps in Day -> TimeOfDay -> LocalTime
LocalTime Day
day TimeOfDay
tod
{-# INLINE localTimeOf #-}

-- | A 'UTCTime', evaluated, from a day and picoseconds since midnight.
utcTimeOf :: Day -> Int64 -> UTCTime
utcTimeOf :: Day -> Int64 -> UTCTime
utcTimeOf !Day
day Int64
ps = let !dt :: DiffTime
dt = Integer -> DiffTime
picosecondsToDiffTime (Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
ps) in Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
dt
{-# INLINE utcTimeOf #-}

scaledLength :: String -> Scale -> Int -> Int -> Either String a
scaledLength :: forall a. [Char] -> Word8 -> Int -> Int -> Either [Char] a
scaledLength [Char]
name Word8
scale Int
expected = [Char] -> [Char] -> Int -> Either [Char] a
forall a. [Char] -> [Char] -> Int -> Either [Char] a
invalidLength [Char]
name (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
expected [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes at scale " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
scale)
{-# NOINLINE scaledLength #-}

-- | 0001-01-01 through 9999-12-31.
putDate :: Day -> Either String Put
putDate :: Day -> Either [Char] Put
putDate Day
d
  | Day
d Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
< Day
epoch0001 Bool -> Bool -> Bool
|| Day
d Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
> Day
lastDay = Clock -> [Char] -> Either [Char] Put
forall a. Clock -> [Char] -> Either [Char] a
outOfRange ([Char] -> Word8 -> Clock
scaleClock [Char]
"date" Word8
0) (Day -> [Char]
showGregorian Day
d)
  | Bool
otherwise = Put -> Either [Char] Put
forall a b. b -> Either a b
Right (Put -> Either [Char] Put) -> Put -> Either [Char] Put
forall a b. (a -> b) -> a -> b
$ Int -> Word64 -> Put
putUIntLE Int
3 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Integer
diffDays Day
d Day
epoch0001)

-- | @time(scale)@: a count of units of 10^-scale seconds since midnight.
readTime :: Scale -> ValueReader TimeOfDay
-- Written with its arguments, so that the INLINE reader below inlines here, which
-- it doesn't into an unsaturated call; and with the bang, so that GHC doesn't
-- eta-reduce the definition back to that call.
readTime :: Word8 -> ValueReader TimeOfDay
readTime Word8
scale !ByteString
bs = (Int64 -> TimeOfDay) -> Word8 -> ValueReader TimeOfDay
forall a. (Int64 -> a) -> Word8 -> ValueReader a
readTimeWith Int64 -> TimeOfDay
picosecondsToTimeOfDay Word8
scale ByteString
bs

-- | @time(scale)@, passing the picoseconds since midnight to the function.
readTimeWith :: (Int64 -> a) -> Scale -> ValueReader a
readTimeWith :: forall a. (Int64 -> a) -> Word8 -> ValueReader a
readTimeWith Int64 -> a
k Word8
scale ByteString
bs
  | Just [Char]
p <- [Char] -> Word8 -> Maybe [Char]
scaleProblem [Char]
"time" Word8
scale = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left [Char]
p
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n = [Char] -> Word8 -> Int -> Int -> Either [Char] a
forall a. [Char] -> Word8 -> Int -> Int -> Either [Char] a
scaledLength [Char]
"time" Word8
scale Int
n (ByteString -> Int
B.length ByteString
bs)
  | Bool
otherwise = do
      !ps <- Word8 -> ByteString -> Int -> Either [Char] Int64
timeAt Word8
scale ByteString
bs Int
0
      Right $! k ps
  where
    n :: Int
n = Word8 -> Int
timeLength Word8
scale
{-# INLINE readTimeWith #-}

-- | Rounds to the nearest unit, but never past 23:59:59.(9...) at the scale.
putTime :: Scale -> TimeOfDay -> Either String Put
putTime :: Word8 -> TimeOfDay -> Either [Char] Put
putTime Word8
scale TimeOfDay
tod = do
  [Char] -> Word8 -> Either [Char] ()
checkScale [Char]
"time" Word8
scale
  ps <- TimeOfDay -> Either [Char] Integer
timeOfDayPicoseconds TimeOfDay
tod
  let c = [Char] -> Word8 -> Clock
scaleClock [Char]
"time" Word8
scale
      units = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (Clock -> Integer -> Integer
clockRound Clock
c Integer
ps) (Clock -> Integer
clockUnitsPerDay Clock
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
  pure $ putUIntLE (timeLength scale) (fromIntegral units)

-- | @datetime2(scale)@: the time units, then the date.
readDateTime2 :: Scale -> ValueReader LocalTime
readDateTime2 :: Word8 -> ValueReader LocalTime
readDateTime2 = (Day -> Int64 -> LocalTime) -> Word8 -> ValueReader LocalTime
forall a. (Day -> Int64 -> a) -> Word8 -> ValueReader a
readDateTime2With Day -> Int64 -> LocalTime
localTimeOf
{-# INLINE readDateTime2 #-}

-- | @datetime2(scale)@, passing the day and the picoseconds since midnight
-- to the function.
readDateTime2With :: (Day -> Int64 -> a) -> Scale -> ValueReader a
readDateTime2With :: forall a. (Day -> Int64 -> a) -> Word8 -> ValueReader a
readDateTime2With Day -> Int64 -> a
k Word8
scale ByteString
bs
  | Just [Char]
p <- [Char] -> Word8 -> Maybe [Char]
scaleProblem [Char]
"datetime2" Word8
scale = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left [Char]
p
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 = [Char] -> Word8 -> Int -> Int -> Either [Char] a
forall a. [Char] -> Word8 -> Int -> Int -> Either [Char] a
scaledLength [Char]
"datetime2" Word8
scale (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (ByteString -> Int
B.length ByteString
bs)
  | Bool
otherwise = do
      !ps <- Word8 -> ByteString -> Int -> Either [Char] Int64
timeAt Word8
scale ByteString
bs Int
0
      !day <- dateAt bs (n)
      Right $! k day ps
  where
    n :: Int
n = Word8 -> Int
timeLength Word8
scale
{-# INLINE readDateTime2With #-}

-- | Units since 0001-01-01 split into the time and date fields.
putScaledUnits :: Scale -> Integer -> Put
putScaledUnits :: Word8 -> Integer -> Put
putScaledUnits Word8
scale Integer
u = do
  let (Integer
days, Integer
units) = Integer
u Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Clock -> Integer
clockUnitsPerDay ([Char] -> Word8 -> Clock
scaleClock [Char]
"" Word8
scale)
  Int -> Word64 -> Put
putUIntLE (Word8 -> Int
timeLength Word8
scale) (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
units)
  Int -> Word64 -> Put
putUIntLE Int
3 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
days)

-- | Rounds to the nearest unit, carrying into the next day.
putDateTime2 :: Scale -> LocalTime -> Either String Put
putDateTime2 :: Word8 -> LocalTime -> Either [Char] Put
putDateTime2 Word8
scale LocalTime
lt = [Char] -> Word8 -> Either [Char] ()
checkScale [Char]
"datetime2" Word8
scale Either [Char] () -> Either [Char] Put -> Either [Char] Put
forall a b. Either [Char] a -> Either [Char] b -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Integer -> Put
putScaledUnits Word8
scale (Integer -> Put) -> Either [Char] Integer -> Either [Char] Put
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> Integer -> Day -> LocalTime -> Either [Char] Integer
clockValue ([Char] -> Word8 -> Clock
scaleClock [Char]
"datetime2" Word8
scale) Integer
0 Day
epoch0001 LocalTime
lt

-- | @datetimeoffset(scale)@: the time units and the date, both in UTC, then
-- the offset as a signed count of minutes.
readDateTimeOffset :: Scale -> ValueReader DateTimeOffset
-- With its arguments and the bang, as 'readTime' has them.
readDateTimeOffset :: Word8 -> ValueReader DateTimeOffset
readDateTimeOffset Word8
scale !ByteString
bs = (Day -> Int64 -> Int16 -> DateTimeOffset)
-> Word8 -> ValueReader DateTimeOffset
forall a. (Day -> Int64 -> Int16 -> a) -> Word8 -> ValueReader a
readDateTimeOffsetWith (\Day
day Int64
ps Int16
mins -> UTCTime -> Int16 -> DateTimeOffset
DateTimeOffset (Day -> Int64 -> UTCTime
utcTimeOf Day
day Int64
ps) Int16
mins) Word8
scale ByteString
bs

-- | @datetimeoffset(scale)@, passing the UTC day, the picoseconds since UTC
-- midnight and the offset in minutes to the function.  The value is checked
-- as 'readDateTimeOffset' checks it: the offset within ±14:00, and the local
-- date within 0001-01-01 through 9999-12-31.
readDateTimeOffsetWith :: (Day -> Int64 -> Int16 -> a) -> Scale -> ValueReader a
readDateTimeOffsetWith :: forall a. (Day -> Int64 -> Int16 -> a) -> Word8 -> ValueReader a
readDateTimeOffsetWith Day -> Int64 -> Int16 -> a
k Word8
scale ByteString
bs
  | Just [Char]
p <- [Char] -> Word8 -> Maybe [Char]
scaleProblem [Char]
"datetimeoffset" Word8
scale = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left [Char]
p
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5 = [Char] -> Word8 -> Int -> Int -> Either [Char] a
forall a. [Char] -> Word8 -> Int -> Int -> Either [Char] a
scaledLength [Char]
"datetimeoffset" Word8
scale (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5) (ByteString -> Int
B.length ByteString
bs)
  | Bool
otherwise = do
      !ps <- Word8 -> ByteString -> Int -> Either [Char] Int64
timeAt Word8
scale ByteString
bs Int
0
      !day <- dateAt bs (n)
      let mins = ByteString -> Int -> Int16
int16LeAt ByteString
bs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
      when (mins < -840 || mins > 840) $
        Left $ "datetimeoffset: invalid offset minute count " ++ show mins
      let localPs = Int64
ps Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
mins Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
60_000_000_000_000
          -- 'dateAt' has kept the day within SQL Server's range, and the offset
          -- moves it by at most one day, so the local day fits an 'Int' on a
          -- 32-bit target too.  In 'Integer' the same check allocated 16 bytes
          -- per value (GHC 9.12.4, 2026-11-04).
          localDay = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Day -> Integer
toModifiedJulianDay Day
day) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
localPs Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
86_400_000_000_000_000) :: Int
      when (localDay < mjd0001 || localDay > mjd0001 + 3_652_058) $
        Left "datetimeoffset: local date outside 0001-01-01 through 9999-12-31"
      Right $! k day ps mins
  where
    n :: Int
n = Word8 -> Int
timeLength Word8
scale
{-# INLINE readDateTimeOffsetWith #-}

-- | Rounds like 'putDateTime2'.  The offset must be within ±14:00, and both
-- the UTC and the local time must be in range.
putDateTimeOffset :: Scale -> DateTimeOffset -> Either String Put
putDateTimeOffset :: Word8 -> DateTimeOffset -> Either [Char] Put
putDateTimeOffset Word8
scale dto :: DateTimeOffset
dto@(DateTimeOffset t :: UTCTime
t@(UTCTime Day
day DiffTime
dt) Int16
mins)
  | Just [Char]
p <- [Char] -> Word8 -> Maybe [Char]
scaleProblem [Char]
"datetimeoffset" Word8
scale = [Char] -> Either [Char] Put
forall a b. a -> Either a b
Left [Char]
p
  | Int16
mins Int16 -> Int16 -> Bool
forall a. Ord a => a -> a -> Bool
< -Int16
840 Bool -> Bool -> Bool
|| Int16
mins Int16 -> Int16 -> Bool
forall a. Ord a => a -> a -> Bool
> Int16
840 = [Char] -> Either [Char] Put
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Put) -> [Char] -> Either [Char] Put
forall a b. (a -> b) -> a -> b
$ [Char]
"datetimeoffset value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DateTimeOffset -> [Char]
forall a. Show a => a -> [Char]
show DateTimeOffset
dto [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": the UTC offset must be between -14:00 and +14:00"
  | DiffTime
dt DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
0 Bool -> Bool -> Bool
|| DiffTime
dt DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
86401 = [Char] -> Either [Char] Put
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Put) -> [Char] -> Either [Char] Put
forall a b. (a -> b) -> a -> b
$ [Char]
"datetimeoffset value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DateTimeOffset -> [Char]
forall a. Show a => a -> [Char]
show DateTimeOffset
dto [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": invalid time of day"
  | Bool
otherwise = do
      let c :: Clock
c = [Char] -> Word8 -> Clock
scaleClock [Char]
"datetimeoffset" Word8
scale
          shift :: Integer
shift = Int16 -> Integer
forall a. Integral a => a -> Integer
toInteger Int16
mins Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Clock -> Integer
clockUnitsPerDay Clock
c Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
86400
          local :: LocalTime
local = TimeZone -> UTCTime -> LocalTime
utcToLocalTime (Int -> TimeZone
minutesToTimeZone (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
mins)) UTCTime
t
      u <- ([Char] -> Either [Char] Integer)
-> (Integer -> Either [Char] Integer)
-> Either [Char] Integer
-> Either [Char] Integer
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either [Char] Integer -> [Char] -> Either [Char] Integer
forall a b. a -> b -> a
const ([Char] -> Either [Char] Integer
forall a b. a -> Either a b
Left [Char]
rangeErr)) Integer -> Either [Char] Integer
forall a b. b -> Either a b
Right (Either [Char] Integer -> Either [Char] Integer)
-> Either [Char] Integer -> Either [Char] Integer
forall a b. (a -> b) -> a -> b
$
        Clock -> Integer -> Day -> LocalTime -> Either [Char] Integer
clockValue Clock
c Integer
shift (LocalTime -> Day
localDay LocalTime
local) (Day -> TimeOfDay -> LocalTime
LocalTime Day
day (DiffTime -> TimeOfDay
timeToTimeOfDay DiffTime
dt))
      pure $ putScaledUnits scale u >> Put.putInt16le mins
  where
    rangeErr :: [Char]
rangeErr =
      [Char]
"datetimeoffset value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ZonedTime -> [Char]
forall a. Show a => a -> [Char]
show (DateTimeOffset -> ZonedTime
dateTimeOffsetToZonedTime DateTimeOffset
dto) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (UTC " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UTCTime -> [Char]
forall a. Show a => a -> [Char]
show UTCTime
t
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") is out of range: the UTC and local times must be within 0001-01-01 through 9999-12-31"

------------------------------------------------------------------------------
-- decimal / numeric

type Precision = Word8

-- | Length of the magnitude (excluding the sign byte) for a given precision.
precisionToLength :: Precision -> Int
precisionToLength :: Word8 -> Int
precisionToLength Word8
p
  | Word8
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
9 = Int
4
  | Word8
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
19 = Int
8
  | Word8
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
28 = Int
12
  | Bool
otherwise = Int
16

decimalLengthError :: Int -> String
decimalLengthError :: Int -> [Char]
decimalLengthError Int
len = [Char]
"decimal: invalid length " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
len [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (5, 9, 13 or 17 bytes)"

-- | @decimal@ and @numeric@: a sign byte (0 negative, 1 positive) followed by
-- a little-endian unsigned magnitude of 4, 8, 12 or 16 bytes (MS-TDS
-- 2.2.5.5.1.3).  The magnitude is usually 'precisionToLength' bytes, but SQL
-- Server doesn't always send that: a @decimal(10,0)@ zero read from a table
-- has 4, and a @decimal(1,0)@ in a @sql_variant@ has 16.  So any of the four
-- lengths is accepted, as SqlClient accepts them, and the value is checked
-- against the precision instead.  Another length, another sign byte, or a
-- magnitude with more digits than the precision allows is a 'Left'.
readDecimal :: Precision -> Scale -> ValueReader Decimal
-- A magnitude that fits in 64 bits is checked against the precision as a
-- 'Word64' and becomes an 'Integer' once.
readDecimal :: Word8 -> Word8 -> ValueReader Decimal
readDecimal Word8
precision Word8
scale ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
5 Bool -> Bool -> Bool
&& (ByteString -> Int
B.length ByteString
bs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
9 Bool -> Bool -> Bool
&& (ByteString -> Int
B.length ByteString
bs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
13 Bool -> Bool -> Bool
&& (ByteString -> Int
B.length ByteString
bs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
17 = [Char] -> Either [Char] Decimal
forall a b. a -> Either a b
Left (Int -> [Char]
decimalLengthError (ByteString -> Int
B.length ByteString
bs))
  | Word8
sign Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
1 = [Char] -> Either [Char] Decimal
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Decimal)
-> [Char] -> Either [Char] Decimal
forall a b. (a -> b) -> a -> b
$ [Char]
"decimal: invalid sign byte " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
sign
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 = Word64 -> Either [Char] Decimal
small (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
1))
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 = Word64 -> Either [Char] Decimal
small (ByteString -> Int -> Word64
word64LeAt ByteString
bs Int
1)
  | Word64
hi Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = Word64 -> Either [Char] Decimal
small Word64
lo
  | Bool
otherwise = Integer -> Either [Char] Decimal
big ((Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
hi Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
64) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
lo)
  where
    sign :: Word8
sign = ByteString -> Int -> Word8
word8At ByteString
bs Int
0
    lo :: Word64
lo = ByteString -> Int -> Word64
word64LeAt ByteString
bs Int
1
    hi :: Word64
hi | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
13 = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
9)
       | Bool
otherwise = ByteString -> Int -> Word64
word64LeAt ByteString
bs Int
9
    -- Below 2^64, so fewer than 20 digits: only a precision below 20 can
    -- be exceeded.
    small :: Word64 -> Either String Decimal
    small :: Word64 -> Either [Char] Decimal
small Word64
m
      | Word8
precision Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
20 Bool -> Bool -> Bool
&& Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8 -> Word64
word64PowerOfTen Word8
precision = Integer -> Either [Char] Decimal
forall {a} {b}. Show a => a -> Either [Char] b
tooMany (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
m)
      | Bool
otherwise = Integer -> Either [Char] Decimal
forall {i} {a}. Num i => i -> Either a (DecimalRaw i)
value (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
m)
    big :: Integer -> Either [Char] Decimal
big Integer
m
      | Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8 -> Integer
powerOfTen Word8
precision = Integer -> Either [Char] Decimal
forall {a} {b}. Show a => a -> Either [Char] b
tooMany Integer
m
      | Bool
otherwise = Integer -> Either [Char] Decimal
forall {i} {a}. Num i => i -> Either a (DecimalRaw i)
value Integer
m
    value :: i -> Either a (DecimalRaw i)
value i
m = DecimalRaw i -> Either a (DecimalRaw i)
forall a b. b -> Either a b
Right (DecimalRaw i -> Either a (DecimalRaw i))
-> DecimalRaw i -> Either a (DecimalRaw i)
forall a b. (a -> b) -> a -> b
$! Word8 -> i -> DecimalRaw i
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
scale (if Word8
sign Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 then i -> i
forall a. Num a => a -> a
negate i
m else i
m)
    tooMany :: a -> Either [Char] b
tooMany a
m = [Char] -> Either [Char] b
forall a b. a -> Either a b
Left ([Char] -> Either [Char] b) -> [Char] -> Either [Char] b
forall a b. (a -> b) -> a -> b
$ [Char]
"decimal: magnitude " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" has more than " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
precision [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" digits"

-- | @decimal@ and @numeric@, checked as 'readDecimal' checks them, passing the
-- value's parts to the function: whether it is negative, the high and low 64 bits
-- of its magnitude, and the scale.  A zero is never negative, though the wire can
-- carry one.
readDecimalWith :: (Bool -> Word64 -> Word64 -> Scale -> a) -> Precision -> Scale -> ValueReader a
readDecimalWith :: forall a.
(Bool -> Word64 -> Word64 -> Word8 -> a)
-> Word8 -> Word8 -> ValueReader a
readDecimalWith Bool -> Word64 -> Word64 -> Word8 -> a
k Word8
precision Word8
scale ByteString
bs
  | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
5 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
9 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
13 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
17 = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left (Int -> [Char]
decimalLengthError Int
len)
  | Word8
sign Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
1 = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a b. (a -> b) -> a -> b
$ [Char]
"decimal: invalid sign byte " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
sign
  | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 = Word64 -> Either [Char] a
small (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
1))
  | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 = Word64 -> Either [Char] a
small (ByteString -> Int -> Word64
word64LeAt ByteString
bs Int
1)
  | Word64
hi Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = Word64 -> Either [Char] a
small Word64
lo
  | (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
hi Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
64) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
lo Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8 -> Integer
powerOfTen Word8
precision =
      [Char] -> Either [Char] a
forall a b. a -> Either a b
Left (Word8 -> Integer -> [Char]
decimalDigitsError Word8
precision ((Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
hi Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
64) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
lo))
  | Bool
otherwise = a -> Either [Char] a
forall a b. b -> Either a b
Right (a -> Either [Char] a) -> a -> Either [Char] a
forall a b. (a -> b) -> a -> b
$! Bool -> Word64 -> Word64 -> Word8 -> a
k (Word8
sign Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) Word64
hi Word64
lo Word8
scale
  where
    len :: Int
len = ByteString -> Int
B.length ByteString
bs
    sign :: Word8
sign = ByteString -> Int -> Word8
word8At ByteString
bs Int
0
    lo :: Word64
lo = ByteString -> Int -> Word64
word64LeAt ByteString
bs Int
1
    hi :: Word64
hi | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
13 = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
9)
       | Bool
otherwise = ByteString -> Int -> Word64
word64LeAt ByteString
bs Int
9
    small :: Word64 -> Either [Char] a
small Word64
m
      | Word8
precision Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
20 Bool -> Bool -> Bool
&& Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8 -> Word64
word64PowerOfTen Word8
precision = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left (Word8 -> Integer -> [Char]
decimalDigitsError Word8
precision (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
m))
      | Bool
otherwise = a -> Either [Char] a
forall a b. b -> Either a b
Right (a -> Either [Char] a) -> a -> Either [Char] a
forall a b. (a -> b) -> a -> b
$! Bool -> Word64 -> Word64 -> Word8 -> a
k (Word8
sign Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 Bool -> Bool -> Bool
&& Word64
m Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0) Word64
0 Word64
m Word8
scale
{-# INLINE readDecimalWith #-}

-- Out of line, so that a copy of 'readDecimalWith' doesn't hold the message.
decimalDigitsError :: Precision -> Integer -> String
decimalDigitsError :: Word8 -> Integer -> [Char]
decimalDigitsError Word8
precision Integer
m = [Char]
"decimal: magnitude " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" has more than " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
precision [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" digits"
{-# NOINLINE decimalDigitsError #-}

-- | @10 ^ p@ for @p@ from 0 through 19.
word64PowerOfTen :: Precision -> Word64
word64PowerOfTen :: Word8 -> Word64
word64PowerOfTen = \case
  Word8
0 -> Word64
1
  Word8
1 -> Word64
10
  Word8
2 -> Word64
100
  Word8
3 -> Word64
1_000
  Word8
4 -> Word64
10_000
  Word8
5 -> Word64
100_000
  Word8
6 -> Word64
1_000_000
  Word8
7 -> Word64
10_000_000
  Word8
8 -> Word64
100_000_000
  Word8
9 -> Word64
1_000_000_000
  Word8
10 -> Word64
10_000_000_000
  Word8
11 -> Word64
100_000_000_000
  Word8
12 -> Word64
1_000_000_000_000
  Word8
13 -> Word64
10_000_000_000_000
  Word8
14 -> Word64
100_000_000_000_000
  Word8
15 -> Word64
1_000_000_000_000_000
  Word8
16 -> Word64
10_000_000_000_000_000
  Word8
17 -> Word64
100_000_000_000_000_000
  Word8
18 -> Word64
1_000_000_000_000_000_000
  Word8
_ -> Word64
10_000_000_000_000_000_000

-- | @10 ^ p@, from a table for the precisions SQL Server allows.
-- The decimal reader checks every value against it; computing it each time with
-- @(^)@ (about 1.5 KB of allocation for @10 ^ 38@) it made reading rows of
-- an @int@, an @nvarchar(50)@ and a @decimal@ a third slower.
powerOfTen :: Precision -> Integer
powerOfTen :: Word8 -> Integer
powerOfTen Word8
p
  | Word8
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
38 = Seq Integer -> Int -> Integer
forall a. Seq a -> Int -> a
Seq.index Seq Integer
powersOfTen (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p)
  | Bool
otherwise = Integer
10 Integer -> Word8 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Word8
p
{-# INLINE powerOfTen #-}

powersOfTen :: Seq.Seq Integer
powersOfTen :: Seq Integer
powersOfTen = [Integer] -> Seq Integer
forall a. [a] -> Seq a
Seq.fromList (Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take Int
39 ((Integer -> Integer) -> Integer -> [Integer]
forall a. (a -> a) -> a -> [a]
iterate (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10) Integer
1))
{-# NOINLINE powersOfTen #-}

-- | A decimal at the precision and scale, rounded to the scale: the sign byte
-- and 'precisionToLength' bytes of magnitude.
putDecimal :: Precision -> Scale -> Decimal -> Put
putDecimal :: Word8 -> Word8 -> Decimal -> Put
putDecimal Word8
precision Word8
scale Decimal
value = do
  let Decimal Word8
_ Integer
mantissa = Word8 -> Decimal -> Decimal
forall i. Integral i => Word8 -> DecimalRaw i -> DecimalRaw i
roundTo Word8
scale Decimal
value
  Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ if Integer
mantissa Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Word8
0 else Word8
1
  let n :: Int
n = Word8 -> Int
precisionToLength Word8
precision
  (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int
i -> Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word8) -> Integer -> Word8
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer
forall a. Num a => a -> a
abs Integer
mantissa Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xFF) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

------------------------------------------------------------------------------
-- uniqueidentifier

-- | @uniqueidentifier@.  The first three groups are little-endian on the
-- wire, unlike RFC 4122.
readGuid :: ValueReader UUID
readGuid :: ValueReader UUID
readGuid ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
16 = [Char] -> [Char] -> Int -> Either [Char] UUID
forall a. [Char] -> [Char] -> Int -> Either [Char] a
invalidLength [Char]
"uniqueidentifier" [Char]
"16 bytes" (ByteString -> Int
B.length ByteString
bs)
  | Bool
otherwise = UUID -> Either [Char] UUID
forall a b. b -> Either a b
Right (UUID -> Either [Char] UUID) -> UUID -> Either [Char] UUID
forall a b. (a -> b) -> a -> b
$! Word64 -> Word64 -> UUID
UUID.fromWords64 Word64
hi (ByteString -> Int -> Word64
word64BeAt ByteString
bs Int
8)
  where
    hi :: Word64
hi = (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
0) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word16
word16LeAt ByteString
bs Int
4) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
           Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word16
word16LeAt ByteString
bs Int
6) :: Word64

-- | The layout of 'readGuid', written.
putGuid :: UUID -> Put
putGuid :: UUID -> Put
putGuid UUID
u = do
  let (Word64
hi, Word64
lo) = UUID -> (Word64, Word64)
UUID.toWords64 UUID
u
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
hi Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
  Word16 -> Put
Put.putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
hi Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
  Word16 -> Put
Put.putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
hi
  Word64 -> Put
Put.putWord64be Word64
lo

------------------------------------------------------------------------------
-- collation

-- | MS-TDS 2.2.5.1.2 Collation Rule Definition. Kept opaque: the LCID,
-- flags and version share a DWORD, followed by the sort ID byte.
data Collation = Collation
  { Collation -> Word32
collationInfo :: !Word32
  , Collation -> Word8
collationSortId :: !Word8
  }

instance Show Collation where
  showsPrec :: Int -> Collation -> [Char] -> [Char]
showsPrec Int
p (Collation Word32
a Word8
b) =
    Int -> Addr# -> [Field] -> [Char] -> [Char]
showRecord Int
p Addr#
"Collation"# [Addr#
"collationInfo"# Addr# -> Word32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word32
a, Addr#
"collationSortId"# Addr# -> Word8 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word8
b]
  {-# OPAQUE showsPrec #-}

instance Eq Collation where
  Collation Word32
a Word8
b == :: Collation -> Collation -> Bool
== Collation Word32
a' Word8
b' = Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
a' Bool -> Bool -> Bool
&& Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
b'
  {-# OPAQUE (==) #-}

-- | The five bytes of a collation at an offset.
collationAt :: B.ByteString -> Int -> Collation
collationAt :: ByteString -> Int -> Collation
collationAt ByteString
bs Int
off = Word32 -> Word8 -> Collation
Collation (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
off) (ByteString -> Int -> Word8
word8At ByteString
bs (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4))

-- | The five bytes of a collation.
putCollation :: Collation -> Put
putCollation :: Collation -> Put
putCollation (Collation Word32
info Word8
sortId) = Word32 -> Put
Put.putWord32le Word32
info Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
Put.putWord8 Word8
sortId

------------------------------------------------------------------------------
-- strings

-- | Decode UTF-16LE text from the server, never failing.
--
-- SQL Server stores and sends UCS-2 code units without validating them, so
-- a value can hold unpaired surrogates (@NCHAR(0xD800)@, a reversed pair, a
-- high surrogate cut off at the end of a string).  Following the Unicode
-- Standard's recommended practice (\"U+FFFD Substitution of Maximal
-- Subparts\", ch. 3), each ill-formed code unit becomes exactly one U+FFFD
-- and every well-formed scalar value decodes unchanged.  A trailing odd
-- byte (a truncated code unit) also becomes one U+FFFD.
--
-- @text@'s own 'T.decodeUtf16LE' throws on such input, and its
-- 'T.decodeUtf16LEWith' resynchronizes byte by byte, emitting one U+FFFD
-- per byte and then misreading the following units.
--
-- One pass writing UTF-8 into the 'Text' array, eight ASCII units at a
-- time ("Hmssql.Tds.Utf16").
decodeUtf16LE :: B.ByteString -> Text
decodeUtf16LE :: ByteString -> Text
decodeUtf16LE = ByteString -> Text
Utf16.decodeUtf16LE
{-# INLINE decodeUtf16LE #-}

-- | Write text as UTF-16LE without a length prefix.
putUcs2 :: Text -> Put
putUcs2 :: Text -> Put
putUcs2 = ByteString -> Put
Put.putByteString (ByteString -> Put) -> (Text -> ByteString) -> Text -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Utf16.encodeUtf16LE

-- | B_VARCHAR: one-byte character count followed by UCS-2 text.
-- Fails (with 'error') for text of more than 255 UTF-16 code units, which
-- the length byte can't count; check with 'ucs2Length' first.
putBVarChar :: Text -> Put
putBVarChar :: Text -> Put
putBVarChar Text
t = do
  let bs :: ByteString
bs = Text -> ByteString
Utf16.encodeUtf16LE Text
t
      n :: Int
n = ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFF) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    [Char] -> Put
forall a. HasCallStack => [Char] -> a
error ([Char] -> Put) -> [Char] -> Put
forall a b. (a -> b) -> a -> b
$ [Char]
"putBVarChar: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" UTF-16 code units do not fit in a B_VARCHAR (at most 255)"
  Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
  ByteString -> Put
Put.putByteString ByteString
bs

-- | US_VARCHAR: two-byte character count followed by UCS-2 text.
-- Fails (with 'error') for text of more than 65535 UTF-16 code units.
putUsVarChar :: Text -> Put
putUsVarChar :: Text -> Put
putUsVarChar Text
t = do
  let bs :: ByteString
bs = Text -> ByteString
Utf16.encodeUtf16LE Text
t
      n :: Int
n = ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFFFF) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    [Char] -> Put
forall a. HasCallStack => [Char] -> a
error ([Char] -> Put) -> [Char] -> Put
forall a b. (a -> b) -> a -> b
$ [Char]
"putUsVarChar: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" UTF-16 code units do not fit in a US_VARCHAR (at most 65535)"
  Word16 -> Put
Put.putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
  ByteString -> Put
Put.putByteString ByteString
bs

-- | The length of text in UTF-16 code units, which is what B_VARCHAR and
-- US_VARCHAR count (a character outside the BMP is two).
ucs2Length :: Text -> Int
ucs2Length :: Text -> Int
ucs2Length = Text -> Int
Utf16.utf16Length