{-# LANGUAGE ExistentialQuantification #-}
-- | Turning Haskell values into parameters.
--
-- 'ToSqlField' encodes one value as one parameter, with a fixed wire type
-- per Haskell type ("Hmssql.Types" has the table); 'ToSqlRow' encodes a
-- value as a list of parameters: a tuple, a record with a derived
-- instance, a list, 'Only', or 'NamedParams'.  A new 'ToSqlField'
-- instance is usually 'contramap' over an existing encoder; one that
-- must choose the wire type itself builds a 'FieldEncoder', or the
-- caller sends a 'RawParam'.  A large value can be read as it is sent, rather
-- than held in memory; see "Hmssql.Encoding#g:streaming".
module Hmssql.Encoding
  ( -- * Field encoders
    FieldEncoder (..)
  , ToSqlField (fieldEncoder)
  , RawParam (..)
  , SqlParam (..)
  , EncodedParam

    -- * Sending a large value #streaming#
    -- | A parameter is normally encoded into memory before it is sent.  'binaryStream'
    -- and 'textStream' instead read the value as it is sent, so a value of any size can
    -- come from a file or a socket without being held in memory:
    --
    -- > import qualified Data.ByteString as B
    -- > import Control.Monad (unless)
    -- > import Streaming (lift)
    -- > import qualified Streaming.Prelude as S
    -- > import System.IO (IOMode (..), withBinaryFile)
    -- >
    -- > fileSource :: FilePath -> Source B.ByteString
    -- > fileSource path = Source $ \use -> withBinaryFile path ReadMode (use . chunks)
    -- >   where
    -- >     chunks h = do
    -- >       chunk <- lift (B.hGetSome h 65536)
    -- >       unless (B.null chunk) (S.yield chunk >> chunks h)
    -- >
    -- > insertDocument :: Connection -> FilePath -> IO Int64
    -- > insertDocument conn path = execute conn $
    -- >   "INSERT INTO dbo.documents (payload) VALUES (" <> param (binaryStream (fileSource path)) <> ")"
    --
    -- A 'Source' opens what it needs when sending starts and closes it when sending ends,
    -- so a 'Hmssql.Query.Query' built on this one can be sent again.  'sourceOf' wraps a
    -- stream you already have, which can be sent only once.  These rules come with it:
    --
    -- * A source must not make a request on its own connection, which throws
    --   'Hmssql.Errors.ReentrantSource'.  On a MARS connection it may read a stream that
    --   was opened earlier.
    -- * If a source throws, the request is abandoned, the exception reaches the caller,
    --   and the connection stays usable.
    -- * An output parameter can't be streamed.
    --
    -- A lazy 'LB.ByteString' or 'LT.Text' parameter is read as it is sent too, without
    -- any of this.  To stream a large value in a result instead, see
    -- "Hmssql.Decoding#g:streaming".
  , ParamValue (..), Source (..), sourceOf, sourceIO
  , StreamParam (..), binaryStream, textStream, streamAs, lazyAs

    -- * Row encoders
  , RowEncoder (..)
  , ToSqlRow (..)
  , divideRow
  , singleParam
  , genericToSqlRow

    -- * Named parameters
  , NamedParam
  , NamedParams (..)
  ) where

import Data.Binary.Put (Put)
import Data.Bits (shiftR)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Lazy as LB
import Data.Decimal (Decimal, DecimalRaw (..))
import Data.Functor.Contravariant (Contravariant (..))
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Time
import Data.Tuple.Only (Only (..))
import Data.UUID.Types (UUID)
import Data.Word (Word64, Word8)
import Foreign.Storable (pokeByteOff)
import GHC.Float (castDoubleToWord64, castFloatToWord32)
import GHC.Generics

import Hmssql.Tds.Parameter
import qualified Streaming.Prelude as S
import Hmssql.SqlValue (SqlValue (..))
import Hmssql.Tds.Context
import Hmssql.Tds.Primitives
import Hmssql.Tds.TypeInfo
import qualified Hmssql.Tds.Utf16 as Utf16

-- | A parameter's wire type and value.
type EncodedParam = (TypeInfo, ParamValue)

-- | How a value of a type becomes one parameter: its wire type and bytes,
-- or why it can't be sent (what the query functions throw as
-- 'Hmssql.Errors.EncodeError').  The 'TdsContext' is the connection's,
-- for an encoding that depends on the negotiated protocol.
data FieldEncoder a = FieldEncoder
  { forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam :: TdsContext -> a -> Either String EncodedParam
  , forall a. FieldEncoder a -> TdsContext -> TypeInfo
nullParamType :: TdsContext -> TypeInfo
    -- ^ The type to declare when the value is NULL (@Nothing@ of the
    -- 'Maybe' instance).
  }

-- | An encoder of @b@ from an encoder of @a@ and a conversion: how most
-- 'ToSqlField' instances for a newtype or an enumeration are written.
--
-- > import Data.Functor.Contravariant (contramap)
-- >
-- > instance ToSqlField Status where
-- >   fieldEncoder = contramap statusText fieldEncoder
instance Contravariant FieldEncoder where
  contramap :: forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
contramap a' -> a
f (FieldEncoder TdsContext -> a -> Either String EncodedParam
enc TdsContext -> TypeInfo
nt) = (TdsContext -> a' -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder a'
forall a.
(TdsContext -> a -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder a
FieldEncoder (\TdsContext
ctx -> TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx (a -> Either String EncodedParam)
-> (a' -> a) -> a' -> Either String EncodedParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f) TdsContext -> TypeInfo
nt

-- | Types that can be sent as one parameter, through 'Hmssql.Query.param'
-- or as a field of a 'ToSqlRow' value.  The usual Haskell types have
-- instances, and "Hmssql.Types" has the table of which SQL type each is
-- sent as.  An instance of your own defines 'fieldEncoder', usually with
-- 'Data.Functor.Contravariant.contramap' over a built-in type's encoder.
class ToSqlField a where
  fieldEncoder :: FieldEncoder a
  -- Not exported: how a derived 'ToSqlRow' instance holds a strict field of this
  -- type.  The 'Int32', 'Int64' and 'Double' instances hold it unpacked, and every
  -- other instance, including the ones applications write, keeps the default.
  fieldParam :: a -> FieldParams -> FieldParams
  fieldParam = FieldEncoder a -> a -> FieldParams -> FieldParams
forall a. FieldEncoder a -> a -> FieldParams -> FieldParams
FieldParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder
  {-# INLINE fieldParam #-}

instance ToSqlField a => ToSqlField (Maybe a) where
  fieldEncoder :: FieldEncoder (Maybe a)
fieldEncoder = FieldEncoder a -> FieldEncoder (Maybe a)
forall a. FieldEncoder a -> FieldEncoder (Maybe a)
maybeEncoder FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder

-- Out of line, and OPAQUE so that a use isn't a worker's result boxed again: inlined,
-- each module that sent a @Maybe Int32@ built its own encoder for it, and the derived
-- 'ToSqlRow' instances of code-size.sh --quick were 29,437 bytes of object code
-- instead of 28,965.  Encoding a parameter is then an unknown call of the inner
-- encoder, once per parameter.
maybeEncoder :: FieldEncoder a -> FieldEncoder (Maybe a)
maybeEncoder :: forall a. FieldEncoder a -> FieldEncoder (Maybe a)
maybeEncoder FieldEncoder a
inner = FieldEncoder
  { encodeParam :: TdsContext -> Maybe a -> Either String EncodedParam
encodeParam = \TdsContext
ctx -> \case
      Maybe a
Nothing -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (FieldEncoder a -> TdsContext -> TypeInfo
forall a. FieldEncoder a -> TdsContext -> TypeInfo
nullParamType FieldEncoder a
inner TdsContext
ctx, RawBytes -> ParamValue
ParamBytes RawBytes
forall a. Maybe a
Nothing)
      Just a
a -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
inner TdsContext
ctx a
a
  , nullParamType :: TdsContext -> TypeInfo
nullParamType = FieldEncoder a -> TdsContext -> TypeInfo
forall a. FieldEncoder a -> TdsContext -> TypeInfo
nullParamType FieldEncoder a
inner
  }
{-# OPAQUE maybeEncoder #-}

-- | Send a value with an explicit wire type.
newtype RawParam = RawParam (TypeInfo, RawBytes)

instance ToSqlField RawParam where
  fieldEncoder :: FieldEncoder RawParam
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> RawParam -> Either String EncodedParam
encodeParam = \TdsContext
_ (RawParam (TypeInfo
ti, RawBytes
bytes)) -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
ti, RawBytes -> ParamValue
ParamBytes RawBytes
bytes)
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
untypedNull
    }

-- | Any value with a 'ToSqlField' instance, so a parameter list can mix types.
data SqlParam = forall a. ToSqlField a => SqlParam a

instance ToSqlField SqlParam where
  fieldEncoder :: FieldEncoder SqlParam
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> SqlParam -> Either String EncodedParam
encodeParam = \TdsContext
ctx (SqlParam a
a) -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx a
a
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
untypedNull
    }

defaultCollation :: Collation
defaultCollation :: Collation
defaultCollation = Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0

-- | The type declared for a NULL whose SQL type isn't known: 'SqlNull', and
-- the NULL of 'Text', 'SqlParam' and 'RawParam' (so @Nothing :: Maybe Text@).
--
-- It is @nvarchar(max)@, so an expression typed by the parameter, such as
-- @ISNULL(\@p, col)@ with an @nvarchar(max)@ @col@, is not truncated.  The
-- server converts it implicitly to most column and operand types, but not
-- to @binary@, @varbinary@ or @image@ (declare those NULLs typed, e.g.
-- @Nothing :: Maybe ByteString@), and not to @sql_variant@: a NULL bound to
-- a @sql_variant@ column or parameter fails with error 206 (operand type
-- clash).  Bind a typed NULL there instead, e.g. @Nothing :: Maybe Int32@,
-- or @RawParam (TISqlVariant 8016, Nothing)@.
untypedNull :: TypeInfo
untypedNull :: TypeInfo
untypedNull = Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength Collation
defaultCollation

-- | A little-endian integer type of @n@ bytes, written directly.
intType :: Integral a => TypeInfo -> Int -> FieldEncoder a
intType :: forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType TypeInfo
ti Int
n = FieldEncoder
  { encodeParam :: TdsContext -> a -> Either String EncodedParam
encodeParam = \TdsContext
_ a
a -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
ti, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Int -> Word64 -> ByteString
littleEndian Int
n (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a))))
  , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
ti
  }
{-# INLINE intType #-}

-- | The low @n@ bytes of @w@, little-endian.
littleEndian :: Int -> Word64 -> B.ByteString
littleEndian :: Int -> Word64 -> ByteString
littleEndian Int
n Word64
w = Int -> (Ptr Word8 -> IO ()) -> ByteString
BI.unsafeCreate Int
n ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p ->
  let go :: Int -> t -> IO ()
go Int
i t
x
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
p Int
i (t -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
x :: Word8) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> t -> IO ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (t
x t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
   in Int -> Word64 -> IO ()
forall {t}. (Integral t, Bits t) => Int -> t -> IO ()
go Int
0 Word64
w

-- | A type whose values are always @n@ bytes long.
fixedType :: TypeInfo -> Int -> (a -> Put) -> FieldEncoder a
fixedType :: forall a. TypeInfo -> Int -> (a -> Put) -> FieldEncoder a
fixedType TypeInfo
ti Int
n a -> Put
put = FieldEncoder
  { encodeParam :: TdsContext -> a -> Either String EncodedParam
encodeParam = \TdsContext
_ a
a -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
ti, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Int -> Put -> ByteString
runPutSized Int
n (a -> Put
put a
a))))
  , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
ti
  }

-- | Like 'fixedType', for encoders that reject some values.
checkedType :: TypeInfo -> Int -> (a -> Either String Put) -> FieldEncoder a
checkedType :: forall a.
TypeInfo -> Int -> (a -> Either String Put) -> FieldEncoder a
checkedType TypeInfo
ti Int
n a -> Either String Put
put = FieldEncoder
  { encodeParam :: TdsContext -> a -> Either String EncodedParam
encodeParam = \TdsContext
_ a
a -> (\Put
pt -> (TypeInfo
ti, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Int -> Put -> ByteString
runPutSized Int
n Put
pt)))) (Put -> EncodedParam)
-> Either String Put -> Either String EncodedParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Either String Put
put a
a
  , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
ti
  }

instance ToSqlField Bool where
  fieldEncoder :: FieldEncoder Bool
fieldEncoder = (Bool -> Int) -> FieldEncoder Int -> FieldEncoder Bool
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Bool -> Int
forall a. Enum a => a -> Int
fromEnum (TypeInfo -> Int -> FieldEncoder Int
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType TypeInfo
TIBitN Int
1)

-- | @smallint@: @tinyint@ is unsigned, so it can't hold negative values.
instance ToSqlField Int8 where fieldEncoder :: FieldEncoder Int8
fieldEncoder = TypeInfo -> Int -> FieldEncoder Int8
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIIntN Word8
2) Int
2
-- | @tinyint@.
instance ToSqlField Word8 where fieldEncoder :: FieldEncoder Word8
fieldEncoder = TypeInfo -> Int -> FieldEncoder Word8
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIIntN Word8
1) Int
1
instance ToSqlField Int16 where fieldEncoder :: FieldEncoder Int16
fieldEncoder = TypeInfo -> Int -> FieldEncoder Int16
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIIntN Word8
2) Int
2
instance ToSqlField Int32 where
  fieldEncoder :: FieldEncoder Int32
fieldEncoder = TypeInfo -> Int -> FieldEncoder Int32
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIIntN Word8
4) Int
4
  fieldParam :: Int32 -> FieldParams -> FieldParams
fieldParam = Int32 -> FieldParams -> FieldParams
Int32Param
  {-# INLINE fieldParam #-}
instance ToSqlField Int64 where
  fieldEncoder :: FieldEncoder Int64
fieldEncoder = TypeInfo -> Int -> FieldEncoder Int64
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIIntN Word8
8) Int
8
  fieldParam :: Int64 -> FieldParams -> FieldParams
fieldParam = Int64 -> FieldParams -> FieldParams
Int64Param
  {-# INLINE fieldParam #-}
instance ToSqlField Int where fieldEncoder :: FieldEncoder Int
fieldEncoder = TypeInfo -> Int -> FieldEncoder Int
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIIntN Word8
8) Int
8

-- | @bigint@, or @decimal(38,0)@ beyond its range; values of 39 or more
-- digits are rejected.
instance ToSqlField Integer where
  fieldEncoder :: FieldEncoder Integer
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> Integer -> Either String EncodedParam
encodeParam = \TdsContext
_ Integer
i -> if
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound @Int64) Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound @Int64) ->
            EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word8 -> TypeInfo
TIIntN Word8
8, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Int -> Word64 -> ByteString
littleEndian Int
8 (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
i))))
        | Integer -> Integer
forall a. Num a => a -> a
abs Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
38 :: Int) ->
            EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word8 -> Word8 -> TypeInfo
TIDecimalN Word8
38 Word8
0, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Int -> Put -> ByteString
runPutSized Int
17 (Word8 -> Word8 -> Decimal -> Put
putDecimal Word8
38 Word8
0 (Word8 -> Integer -> Decimal
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
0 Integer
i)))))
        | Bool
otherwise ->
            String -> Either String EncodedParam
forall a b. a -> Either a b
Left (String -> Either String EncodedParam)
-> String -> Either String EncodedParam
forall a b. (a -> b) -> a -> b
$ String
"Integer value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not fit in decimal(38,0)"
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const (Word8 -> TypeInfo
TIIntN Word8
8)
    }

instance ToSqlField Double where
  fieldEncoder :: FieldEncoder Double
fieldEncoder = (Double -> Word64) -> FieldEncoder Word64 -> FieldEncoder Double
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Double -> Word64
castDoubleToWord64 (TypeInfo -> Int -> FieldEncoder Word64
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIFltN Word8
8) Int
8)
  fieldParam :: Double -> FieldParams -> FieldParams
fieldParam = Double -> FieldParams -> FieldParams
DoubleParam
  {-# INLINE fieldParam #-}
instance ToSqlField Float where fieldEncoder :: FieldEncoder Float
fieldEncoder = (Float -> Word32) -> FieldEncoder Word32 -> FieldEncoder Float
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Float -> Word32
castFloatToWord32 (TypeInfo -> Int -> FieldEncoder Word32
forall a. Integral a => TypeInfo -> Int -> FieldEncoder a
intType (Word8 -> TypeInfo
TIFltN Word8
4) Int
4)

-- | @decimal(p,s)@ with the value's own scale @s@ and just enough precision
-- @p@ for its digits (so 0.001 is @decimal(3,3)@, 1000000 @decimal(7,0)@).
-- Values needing more than 38 digits, or a scale above 38, are rejected.
instance ToSqlField Decimal where
  fieldEncoder :: FieldEncoder Decimal
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> Decimal -> Either String EncodedParam
encodeParam = \TdsContext
_ d :: Decimal
d@(Decimal Word8
scale Integer
mantissa) ->
        let digits :: Int
digits = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Integer -> String
forall a. Show a => a -> String
show (Integer -> Integer
forall a. Num a => a -> a
abs Integer
mantissa))
            precision :: Int
precision = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
digits (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
scale)
         in if
              | Word8
scale Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
38 ->
                  String -> Either String EncodedParam
forall a b. a -> Either a b
Left (String -> Either String EncodedParam)
-> String -> Either String EncodedParam
forall a b. (a -> b) -> a -> b
$ String
"decimal value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Decimal -> String
forall a. Show a => a -> String
show Decimal
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
scale
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" decimal places; SQL Server allows at most 38"
              | Int
precision Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
38 ->
                  String -> Either String EncodedParam
forall a b. a -> Either a b
Left (String -> Either String EncodedParam)
-> String -> Either String EncodedParam
forall a b. (a -> b) -> a -> b
$ String
"decimal value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Decimal -> String
forall a. Show a => a -> String
show Decimal
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
precision
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" digits; SQL Server allows at most 38"
              | Bool
otherwise ->
                  let p :: Word8
p = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
precision
                   in EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word8 -> Word8 -> TypeInfo
TIDecimalN Word8
p Word8
scale, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Int -> Put -> ByteString
runPutSized Int
17 (Word8 -> Word8 -> Decimal -> Put
putDecimal Word8
p Word8
scale Decimal
d))))
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const (Word8 -> Word8 -> TypeInfo
TIDecimalN Word8
38 Word8
10)
    }

-- | @money@; values outside its range (±922,337,203,685,477.58) are rejected.
instance ToSqlField Money where
  fieldEncoder :: FieldEncoder Money
fieldEncoder = TypeInfo
-> Int -> (Money -> Either String Put) -> FieldEncoder Money
forall a.
TypeInfo -> Int -> (a -> Either String Put) -> FieldEncoder a
checkedType (Word8 -> TypeInfo
TIMoneyN Word8
8) Int
8 (\Money
m -> Either String Put
-> (String -> Either String Put)
-> Maybe String
-> Either String Put
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Put -> Either String Put
forall a b. b -> Either a b
Right (Money -> Put
putMoney8 Money
m)) String -> Either String Put
forall a b. a -> Either a b
Left (Money -> Maybe String
money8Problem Money
m))
instance ToSqlField UUID where fieldEncoder :: FieldEncoder UUID
fieldEncoder = TypeInfo -> Int -> (UUID -> Put) -> FieldEncoder UUID
forall a. TypeInfo -> Int -> (a -> Put) -> FieldEncoder a
fixedType TypeInfo
TIGuid Int
16 UUID -> Put
putGuid

-- | Any length of string.  A value of up to 4000 UTF-16 code units is declared
-- @nvarchar(4000)@, and a longer one or a NULL ('Nothing') is declared
-- @nvarchar(max)@.  "Hmssql.Types" says when the difference matters.
instance ToSqlField Text where
  fieldEncoder :: FieldEncoder Text
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> Text -> Either String EncodedParam
encodeParam = \TdsContext
_ Text
t ->
        let bs :: ByteString
bs = Text -> ByteString
Utf16.encodeUtf16LE Text
t
            len :: Word16
len = if ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8000 then Word16
maxLength else Word16
8000
         in EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> Collation -> TypeInfo
TINVarChar Word16
len Collation
defaultCollation, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just ByteString
bs))
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
untypedNull
    }

-- | Declared as 'Text' is, by the same rule.  A value too long for
-- @nvarchar(4000)@ is forced as it is sent, so it needn't all be in memory.  A
-- shorter one is forced before sending.  Choosing the declaration forces the
-- value as far as its 4001st code unit or its end.
instance ToSqlField LT.Text where
  fieldEncoder :: FieldEncoder Text
fieldEncoder = (TdsContext -> Text -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder Text
forall a.
(TdsContext -> a -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder a
FieldEncoder TdsContext -> Text -> Either String EncodedParam
forall {p} {a}. p -> Text -> Either a EncodedParam
encode (TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
untypedNull)
    where
      -- Walking whole chunks forces exactly the input the limit allows.  A
      -- chunk is strict and already in memory, so measuring one past the
      -- budget costs no laziness, and the next chunk is forced only when this
      -- one fit.
      encode :: p -> Text -> Either a EncodedParam
encode p
_ Text
text
        | Int -> [Text] -> Bool
fits Int
4000 (Text -> [Text]
LT.toChunks Text
text) = EncodedParam -> Either a EncodedParam
forall a b. b -> Either a b
Right (Word16 -> Collation -> TypeInfo
TINVarChar Word16
8000 Collation
defaultCollation,
            RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Text -> ByteString
Utf16.encodeUtf16LE (Text -> Text
LT.toStrict Text
text))))
        | Bool
otherwise = EncodedParam -> Either a EncodedParam
forall a b. b -> Either a b
Right (Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength Collation
defaultCollation,
            ByteString -> ParamValue
ParamLazy ([ByteString] -> ByteString
LB.fromChunks ((Text -> [ByteString]) -> [Text] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [ByteString]
utf16Chunks (Text -> [Text]
LT.toChunks Text
text))))
      fits :: Int -> [Text] -> Bool
fits Int
_ [] = Bool
True
      fits Int
left (Text
chunk : [Text]
rest) =
        let units :: Int
units = Text -> Int
Utf16.utf16Length (Int -> Text -> Text
T.take (Int
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
chunk)
         in Int
units Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
left Bool -> Bool -> Bool
&& Int -> [Text] -> Bool
fits (Int
left Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
units) [Text]
rest
instance {-# OVERLAPPING #-} ToSqlField String where fieldEncoder :: FieldEncoder String
fieldEncoder = (String -> Text) -> FieldEncoder Text -> FieldEncoder String
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap String -> Text
T.pack FieldEncoder Text
forall a. ToSqlField a => FieldEncoder a
fieldEncoder

-- | Any length of bytes.  A value of up to 8000 bytes is declared
-- @varbinary(8000)@, and a longer one or a NULL ('Nothing') is declared
-- @varbinary(max)@.  "Hmssql.Types" says when the difference matters.
instance ToSqlField B.ByteString where
  fieldEncoder :: FieldEncoder ByteString
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> ByteString -> Either String EncodedParam
encodeParam = \TdsContext
_ ByteString
bs ->
        let len :: Word16
len = if ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8000 then Word16
maxLength else Word16
8000
         in EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> TypeInfo
TIBigVarBinary Word16
len, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just ByteString
bs))
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const (Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength)
    }

-- | Declared as a strict 'B.ByteString' is, by the same rule.  A value too long
-- for @varbinary(8000)@ is forced as it is sent, so it needn't all be in memory.
-- A shorter one is forced before sending.  Choosing the declaration forces the
-- value as far as its 8001st byte or its end.
instance ToSqlField LB.ByteString where
  fieldEncoder :: FieldEncoder ByteString
fieldEncoder = (TdsContext -> ByteString -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder ByteString
forall a.
(TdsContext -> a -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder a
FieldEncoder (\TdsContext
_ ByteString
bytes -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (ByteString -> EncodedParam
lazyBinary ByteString
bytes)) (TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const (Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength))
    where
      lazyBinary :: ByteString -> EncodedParam
lazyBinary ByteString
bytes
        | ByteString -> Bool
LB.null (Int64 -> ByteString -> ByteString
LB.drop Int64
8000 ByteString
bytes) = (Word16 -> TypeInfo
TIBigVarBinary Word16
8000, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (ByteString -> ByteString
LB.toStrict ByteString
bytes)))
        | Bool
otherwise = (Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength, ByteString -> ParamValue
ParamLazy ByteString
bytes)

-- | @datetime2(7)@, rounded to 100 ns (carrying into the next day; a leap
-- second counts as the following second).  Years 1 through 9999.
instance ToSqlField LocalTime where fieldEncoder :: FieldEncoder LocalTime
fieldEncoder = TypeInfo
-> Int
-> (LocalTime -> Either String Put)
-> FieldEncoder LocalTime
forall a.
TypeInfo -> Int -> (a -> Either String Put) -> FieldEncoder a
checkedType (Word8 -> TypeInfo
TIDateTime2N Word8
7) Int
8 (Word8 -> LocalTime -> Either String Put
putDateTime2 Word8
7)

-- | @datetime2(7)@ holding the UTC clock time (zoneless).
instance ToSqlField UTCTime where
  fieldEncoder :: FieldEncoder UTCTime
fieldEncoder = (UTCTime -> LocalTime)
-> FieldEncoder LocalTime -> FieldEncoder UTCTime
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap UTCTime -> LocalTime
toLocal FieldEncoder LocalTime
forall a. ToSqlField a => FieldEncoder a
fieldEncoder
    where
      -- time's negative-clock conversion narrows the hours to Int. Split
      -- whole days first so a huge clock cannot wrap before the date check.
      -- Keep positive clocks on the existing path, including leap seconds.
      toLocal :: UTCTime -> LocalTime
toLocal t :: UTCTime
t@(UTCTime Day
day DiffTime
clock)
        | DiffTime
clock DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
0 =
            let (Integer
days, Integer
within) = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
clock Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
86400000000000000
             in Day -> TimeOfDay -> LocalTime
LocalTime (Integer -> Day -> Day
addDays Integer
days Day
day) (DiffTime -> TimeOfDay
timeToTimeOfDay (Integer -> DiffTime
picosecondsToDiffTime Integer
within))
        | Bool
otherwise = TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc UTCTime
t

-- | @datetimeoffset(7)@, rounded like 'LocalTime'.  The offset must be within
-- ±14:00 and both the UTC and the local time within years 1 through 9999.
instance ToSqlField DateTimeOffset where fieldEncoder :: FieldEncoder DateTimeOffset
fieldEncoder = TypeInfo
-> Int
-> (DateTimeOffset -> Either String Put)
-> FieldEncoder DateTimeOffset
forall a.
TypeInfo -> Int -> (a -> Either String Put) -> FieldEncoder a
checkedType (Word8 -> TypeInfo
TIDateTimeOffsetN Word8
7) Int
10 (Word8 -> DateTimeOffset -> Either String Put
putDateTimeOffset Word8
7)
-- | As 'DateTimeOffset'.  The offset is checked before it is narrowed to the
-- wire's 16-bit minute count.
instance ToSqlField ZonedTime where
  fieldEncoder :: FieldEncoder ZonedTime
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> ZonedTime -> Either String EncodedParam
encodeParam = \TdsContext
ctx ZonedTime
zt ->
        let mins :: Int
mins = TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
zt)
         in if Int
mins Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< -Int
840 Bool -> Bool -> Bool
|| Int
mins Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
840
              then String -> Either String EncodedParam
forall a b. a -> Either a b
Left (String -> Either String EncodedParam)
-> String -> Either String EncodedParam
forall a b. (a -> b) -> a -> b
$ String
"datetimeoffset value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ZonedTime -> String
forall a. Show a => a -> String
show ZonedTime
zt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": the UTC offset must be between -14:00 and +14:00"
              else FieldEncoder DateTimeOffset
-> TdsContext -> DateTimeOffset -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder DateTimeOffset
dto TdsContext
ctx (ZonedTime -> DateTimeOffset
zonedTimeToDateTimeOffset ZonedTime
zt)
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = FieldEncoder DateTimeOffset -> TdsContext -> TypeInfo
forall a. FieldEncoder a -> TdsContext -> TypeInfo
nullParamType FieldEncoder DateTimeOffset
dto
    }
    where
      dto :: FieldEncoder DateTimeOffset
dto = forall a. ToSqlField a => FieldEncoder a
fieldEncoder @DateTimeOffset

-- | @date@, years 1 through 9999.
instance ToSqlField Day where fieldEncoder :: FieldEncoder Day
fieldEncoder = TypeInfo -> Int -> (Day -> Either String Put) -> FieldEncoder Day
forall a.
TypeInfo -> Int -> (a -> Either String Put) -> FieldEncoder a
checkedType TypeInfo
TIDateN Int
3 Day -> Either String Put
putDate

-- | @time(7)@, rounded to 100 ns but never past 23:59:59.9999999 (there is no
-- next day to carry into; a leap second also becomes 23:59:59.9999999).
instance ToSqlField TimeOfDay where fieldEncoder :: FieldEncoder TimeOfDay
fieldEncoder = TypeInfo
-> Int
-> (TimeOfDay -> Either String Put)
-> FieldEncoder TimeOfDay
forall a.
TypeInfo -> Int -> (a -> Either String Put) -> FieldEncoder a
checkedType (Word8 -> TypeInfo
TITimeN Word8
7) Int
5 (Word8 -> TimeOfDay -> Either String Put
putTime Word8
7)

-- | Each constructor is sent as the wire type 'Hmssql.Decoding.FromSqlField' 'SqlValue'
-- decodes it from, so @SELECT \@p1@ returns the same 'SqlValue': 'SqlXml' as
-- @xml@ (UTF-16 with a byte order mark, no schema collection), 'SqlText' as
-- @nvarchar@, and so on.  'SqlNull' is an @nvarchar(max)@ NULL, which
-- the server won't convert to @sql_variant@ (error 206).
instance ToSqlField SqlValue where
  fieldEncoder :: FieldEncoder SqlValue
fieldEncoder = FieldEncoder
    { encodeParam :: TdsContext -> SqlValue -> Either String EncodedParam
encodeParam = \TdsContext
ctx -> \case
        SqlValue
SqlNull -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
untypedNull, RawBytes -> ParamValue
ParamBytes RawBytes
forall a. Maybe a
Nothing)
        SqlBool Bool
b -> TdsContext -> Bool -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Bool
b
        SqlWord8 Word8
i -> TdsContext -> Word8 -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Word8
i
        SqlInt16 Int16
i -> TdsContext -> Int16 -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Int16
i
        SqlInt32 Int32
i -> TdsContext -> Int32 -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Int32
i
        SqlInt64 Int64
i -> TdsContext -> Int64 -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Int64
i
        SqlFloat Float
f -> TdsContext -> Float -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Float
f
        SqlDouble Double
d -> TdsContext -> Double -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Double
d
        SqlDecimal Decimal
d -> TdsContext -> Decimal -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Decimal
d
        SqlMoney Money
m -> TdsContext -> Money -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Money
m
        SqlGuid UUID
g -> TdsContext -> UUID -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx UUID
g
        SqlDateTime LocalTime
t -> TdsContext -> LocalTime -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx LocalTime
t
        SqlDate Day
d -> TdsContext -> Day -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Day
d
        SqlTime TimeOfDay
t -> TdsContext -> TimeOfDay -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx TimeOfDay
t
        SqlDateTimeOffset DateTimeOffset
d -> TdsContext -> DateTimeOffset -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx DateTimeOffset
d
        SqlText Text
t -> TdsContext -> Text -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx Text
t
        SqlBinary ByteString
b -> TdsContext -> ByteString -> Either String EncodedParam
forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx ByteString
b
        -- The server detects an xml value's encoding from its bytes (XML
        -- 1.0 appendix F), so a UTF-16 document not starting with @<@ (text
        -- only, e.g. @"a"@) needs the byte order mark to be read as UTF-16.
        SqlXml Text
t -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Maybe XmlSchema -> TypeInfo
TIXml Maybe XmlSchema
forall a. Maybe a
Nothing, RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (ByteString
"\xFF\xFE" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
Utf16.encodeUtf16LE Text
t)))
    , nullParamType :: TdsContext -> TypeInfo
nullParamType = TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
untypedNull
    }
    where
      enc :: forall a. ToSqlField a => TdsContext -> a -> Either String EncodedParam
      enc :: forall a.
ToSqlField a =>
TdsContext -> a -> Either String EncodedParam
enc = FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder

------------------------------------------------------------------------------
-- Row encoders

-- | Produces each parameter with its name (@""@ means positional, @\@pN@
-- by position among the positional ones; otherwise the name with its
-- leading @\@@) and its encoding for a connection.  The parameters, their
-- number and their names never depend on the connection; only the encoded
-- values may.
newtype RowEncoder a = RowEncoder
  { forall a.
RowEncoder a
-> a -> [(Text, TdsContext -> Either String EncodedParam)]
encodeParams :: a -> [(Text, TdsContext -> Either String EncodedParam)]
  }

-- | An encoder of @b@ from an encoder of @a@ and a conversion.
instance Contravariant RowEncoder where
  contramap :: forall a' a. (a' -> a) -> RowEncoder a -> RowEncoder a'
contramap a' -> a
f (RowEncoder a -> [(Text, TdsContext -> Either String EncodedParam)]
enc) = (a' -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a'
forall a.
(a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
RowEncoder (a -> [(Text, TdsContext -> Either String EncodedParam)]
enc (a -> [(Text, TdsContext -> Either String EncodedParam)])
-> (a' -> a)
-> a'
-> [(Text, TdsContext -> Either String EncodedParam)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

-- | Combine two encoders over a product: the parameters of the first, then
-- those of the second.  For a 'ToSqlRow' written by hand, e.g. a record
-- with a field that is sent as two parameters.
divideRow :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divideRow :: forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divideRow a -> (b, c)
split (RowEncoder b -> [(Text, TdsContext -> Either String EncodedParam)]
eb) (RowEncoder c -> [(Text, TdsContext -> Either String EncodedParam)]
ec) = (a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
forall a.
(a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
RowEncoder ((a -> [(Text, TdsContext -> Either String EncodedParam)])
 -> RowEncoder a)
-> (a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
forall a b. (a -> b) -> a -> b
$ \a
a ->
  let (b
b, c
c) = a -> (b, c)
split a
a in b -> [(Text, TdsContext -> Either String EncodedParam)]
eb b
b [(Text, TdsContext -> Either String EncodedParam)]
-> [(Text, TdsContext -> Either String EncodedParam)]
-> [(Text, TdsContext -> Either String EncodedParam)]
forall a. [a] -> [a] -> [a]
++ c -> [(Text, TdsContext -> Either String EncodedParam)]
ec c
c

-- | A row of one positional parameter.
singleParam :: FieldEncoder a -> RowEncoder a
singleParam :: forall a. FieldEncoder a -> RowEncoder a
singleParam (FieldEncoder TdsContext -> a -> Either String EncodedParam
enc TdsContext -> TypeInfo
_) = (a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
forall a.
(a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
RowEncoder ((a -> [(Text, TdsContext -> Either String EncodedParam)])
 -> RowEncoder a)
-> (a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
forall a b. (a -> b) -> a -> b
$ \a
a -> [(Text
"", \TdsContext
ctx -> TdsContext -> a -> Either String EncodedParam
enc TdsContext
ctx a
a)]

-- | Types that can be sent as a list of parameters: the @\@p1@, @\@p2@,
-- ... of 'Hmssql.Query.mkQuery', or a row of 'Hmssql.Query.executeMany' or
-- 'Hmssql.BulkCopy.bulkInsert'.  Derive it for a record whose fields are
-- 'ToSqlField' types, one parameter per field in order:
--
-- > data NewCustomer = NewCustomer { newName :: Text, newBirthDate :: Maybe Day }
-- >   deriving stock (Generic)
-- >   deriving anyclass (ToSqlRow)
--
-- Tuples of up to ten fields, @()@, 'Only', a list of one 'ToSqlField'
-- type, a list of 'SqlParam' to mix types, and 'NamedParams' have
-- instances.
class ToSqlRow a where
  rowEncoder :: RowEncoder a
  default rowEncoder :: (Generic a, GRowEncoder (Rep a)) => RowEncoder a
  rowEncoder = RowEncoder a
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance ToSqlRow () where
  rowEncoder :: RowEncoder ()
rowEncoder = (() -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder ()
forall a.
(a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
RowEncoder ([(Text, TdsContext -> Either String EncodedParam)]
-> () -> [(Text, TdsContext -> Either String EncodedParam)]
forall a b. a -> b -> a
const [])

instance ToSqlField a => ToSqlRow (Only a) where
  rowEncoder :: RowEncoder (Only a)
rowEncoder = RowEncoder (Only a)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

-- | Any number of parameters of the same type.
instance ToSqlField a => ToSqlRow [a] where
  rowEncoder :: RowEncoder [a]
rowEncoder = ([a] -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder [a]
forall a.
(a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
RowEncoder (([a] -> [(Text, TdsContext -> Either String EncodedParam)])
 -> RowEncoder [a])
-> ([a] -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder [a]
forall a b. (a -> b) -> a -> b
$ (a -> (Text, TdsContext -> Either String EncodedParam))
-> [a] -> [(Text, TdsContext -> Either String EncodedParam)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
a -> (Text
"", \TdsContext
ctx -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx a
a))

-- | A parameter's name and its value.
type NamedParam = (Text, SqlParam)

-- | Parameters that the SQL text refers to by name.  The leading @\@@ is
-- optional.  A name must be a T-SQL variable name, and not of the form
-- @\@pN@, which is reserved for the positional parameters; the query
-- functions check both before sending anything.  Bulk copy matches the
-- names, with that one @\@@ removed, against the table's columns
-- ("Hmssql.BulkCopy").
--
-- > mkQuery "UPDATE dbo.customer SET email = @email WHERE id = @id"
-- >   (NamedParams [("email", SqlParam newEmail), ("id", SqlParam customerId)])
newtype NamedParams = NamedParams [NamedParam]

instance ToSqlRow NamedParams where
  rowEncoder :: RowEncoder NamedParams
rowEncoder = (NamedParams -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder NamedParams
forall a.
(a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
RowEncoder ((NamedParams
  -> [(Text, TdsContext -> Either String EncodedParam)])
 -> RowEncoder NamedParams)
-> (NamedParams
    -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder NamedParams
forall a b. (a -> b) -> a -> b
$ \(NamedParams [NamedParam]
ps) -> (NamedParam -> (Text, TdsContext -> Either String EncodedParam))
-> [NamedParam]
-> [(Text, TdsContext -> Either String EncodedParam)]
forall a b. (a -> b) -> [a] -> [b]
map NamedParam -> (Text, TdsContext -> Either String EncodedParam)
encodeNamed [NamedParam]
ps
    where
      encodeNamed :: NamedParam -> (Text, TdsContext -> Either String EncodedParam)
encodeNamed (Text
name, SqlParam a
a)
        | Text -> Bool
T.null Text
name = (Text
"@", Either String EncodedParam
-> TdsContext -> Either String EncodedParam
forall a b. a -> b -> a
const (String -> Either String EncodedParam
forall a b. a -> Either a b
Left String
"empty parameter name"))
        | Bool
otherwise = (Text -> Text
withAt Text
name, \TdsContext
ctx -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx a
a)
      withAt :: Text -> Text
withAt Text
n
        | Text
"@" Text -> Text -> Bool
`T.isPrefixOf` Text
n = Text
n
        | Bool
otherwise = Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n

-- The tuples are encoded as records are, so that a call site such as
-- @mkQuery text (a, b, c)@ allocates a 'FieldParams' rather than having a closure
-- of its own for each parameter.
instance (ToSqlField a, ToSqlField b) => ToSqlRow (a, b) where
  rowEncoder :: RowEncoder (a, b)
rowEncoder = RowEncoder (a, b)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c) => ToSqlRow (a, b, c) where
  rowEncoder :: RowEncoder (a, b, c)
rowEncoder = RowEncoder (a, b, c)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d) => ToSqlRow (a, b, c, d) where
  rowEncoder :: RowEncoder (a, b, c, d)
rowEncoder = RowEncoder (a, b, c, d)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e) => ToSqlRow (a, b, c, d, e) where
  rowEncoder :: RowEncoder (a, b, c, d, e)
rowEncoder = RowEncoder (a, b, c, d, e)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e, ToSqlField f) => ToSqlRow (a, b, c, d, e, f) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f)
rowEncoder = RowEncoder (a, b, c, d, e, f)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e, ToSqlField f, ToSqlField g) => ToSqlRow (a, b, c, d, e, f, g) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g)
rowEncoder = RowEncoder (a, b, c, d, e, f, g)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e, ToSqlField f, ToSqlField g, ToSqlField h) => ToSqlRow (a, b, c, d, e, f, g, h) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g, h)
rowEncoder = RowEncoder (a, b, c, d, e, f, g, h)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e, ToSqlField f, ToSqlField g, ToSqlField h, ToSqlField i) => ToSqlRow (a, b, c, d, e, f, g, h, i) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g, h, i)
rowEncoder = RowEncoder (a, b, c, d, e, f, g, h, i)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e, ToSqlField f, ToSqlField g, ToSqlField h, ToSqlField i, ToSqlField j) => ToSqlRow (a, b, c, d, e, f, g, h, i, j) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g, h, i, j)
rowEncoder = RowEncoder (a, b, c, d, e, f, g, h, i, j)
forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow

-- | The encoder a derived 'ToSqlRow' instance uses: one positional
-- parameter per field of a record (or product constructor), in order.
genericToSqlRow :: forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow :: forall a. (Generic a, GRowEncoder (Rep a)) => RowEncoder a
genericToSqlRow = (a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
forall a.
(a -> [(Text, TdsContext -> Either String EncodedParam)])
-> RowEncoder a
RowEncoder (\a
a -> FieldParams -> [(Text, TdsContext -> Either String EncodedParam)]
fieldEntries (Rep a (ZonkAny 0) -> FieldParams -> FieldParams
forall x. Rep a x -> FieldParams -> FieldParams
forall (f :: * -> *) x.
GRowEncoder f =>
f x -> FieldParams -> FieldParams
gFieldParams (a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
a) FieldParams
NoFieldParams))
{-# INLINE genericToSqlRow #-}

-- The object code of a record's encoder only takes the record apart and
-- allocates its 'FieldParams': per field, one constructor holding the type's
-- static 'FieldEncoder', the value and the rest.  The names, the closures and
-- the encoding itself are in 'fieldEntries', once for every record.  Built from
-- 'divideRow' and 'singleParam', each field had a closure of its own with its
-- type's encoding inlined into it, and a thunk that took the field out of a
-- lazily built 'Rep' tree, log2 n cases deep.  In the 50-record program of
-- scripts/code-size.sh that was 583,373 bytes of ToSqlRow instances, 491 per
-- field, in 4.3 s; this is 84,285 bytes, 71 per field, in 1.4 s.
--
-- A strict 'Int32', 'Int64' or 'Double' field of a record is held in a constructor
-- of its own, unpacked, which saves the encoder's word and the box that GHC
-- otherwise rebuilds around an unpacked record field.  The 50-record program
-- went from 83,813 to 74,061 bytes, and a row of five numeric fields allocates
-- 2,296 bytes in place of 2,576, for 13,728 bytes of library code in the hidden
-- class method and the three cases of 'fieldEntries' (GHC 9.12.4, 2026-11-04).
-- One shared constructor for the three types saved 224 bytes of that and cost
-- 32 bytes per field, so the cases stay separate.  Every other type, and every
-- lazy field, goes through 'FieldParam'.

-- | Values, each with the encoder of its type.
data FieldParams
  = forall a. FieldParam (FieldEncoder a) a FieldParams
  | Int32Param {-# UNPACK #-} !Int32 FieldParams
  | Int64Param {-# UNPACK #-} !Int64 FieldParams
  | DoubleParam {-# UNPACK #-} !Double FieldParams
  | NoFieldParams

-- | Positional parameters of the values.
fieldEntries :: FieldParams -> [(Text, TdsContext -> Either String EncodedParam)]
fieldEntries :: FieldParams -> [(Text, TdsContext -> Either String EncodedParam)]
fieldEntries = \case
  -- The spine is built at once, as every consumer walks all of it: a thunk
  -- for the rest was 3 words more per field.
  FieldParam FieldEncoder a
fe a
a FieldParams
rest -> let !entries :: [(Text, TdsContext -> Either String EncodedParam)]
entries = FieldParams -> [(Text, TdsContext -> Either String EncodedParam)]
fieldEntries FieldParams
rest in (Text
"", \TdsContext
ctx -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
fe TdsContext
ctx a
a) (Text, TdsContext -> Either String EncodedParam)
-> [(Text, TdsContext -> Either String EncodedParam)]
-> [(Text, TdsContext -> Either String EncodedParam)]
forall a. a -> [a] -> [a]
: [(Text, TdsContext -> Either String EncodedParam)]
entries
  Int32Param Int32
a FieldParams
rest -> let !entries :: [(Text, TdsContext -> Either String EncodedParam)]
entries = FieldParams -> [(Text, TdsContext -> Either String EncodedParam)]
fieldEntries FieldParams
rest in (Text
"", \TdsContext
ctx -> FieldEncoder Int32
-> TdsContext -> Int32 -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder Int32
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx Int32
a) (Text, TdsContext -> Either String EncodedParam)
-> [(Text, TdsContext -> Either String EncodedParam)]
-> [(Text, TdsContext -> Either String EncodedParam)]
forall a. a -> [a] -> [a]
: [(Text, TdsContext -> Either String EncodedParam)]
entries
  Int64Param Int64
a FieldParams
rest -> let !entries :: [(Text, TdsContext -> Either String EncodedParam)]
entries = FieldParams -> [(Text, TdsContext -> Either String EncodedParam)]
fieldEntries FieldParams
rest in (Text
"", \TdsContext
ctx -> FieldEncoder Int64
-> TdsContext -> Int64 -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder Int64
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx Int64
a) (Text, TdsContext -> Either String EncodedParam)
-> [(Text, TdsContext -> Either String EncodedParam)]
-> [(Text, TdsContext -> Either String EncodedParam)]
forall a. a -> [a] -> [a]
: [(Text, TdsContext -> Either String EncodedParam)]
entries
  DoubleParam Double
a FieldParams
rest -> let !entries :: [(Text, TdsContext -> Either String EncodedParam)]
entries = FieldParams -> [(Text, TdsContext -> Either String EncodedParam)]
fieldEntries FieldParams
rest in (Text
"", \TdsContext
ctx -> FieldEncoder Double
-> TdsContext -> Double -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder Double
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx Double
a) (Text, TdsContext -> Either String EncodedParam)
-> [(Text, TdsContext -> Either String EncodedParam)]
-> [(Text, TdsContext -> Either String EncodedParam)]
forall a. a -> [a] -> [a]
: [(Text, TdsContext -> Either String EncodedParam)]
entries
  FieldParams
NoFieldParams -> []
{-# NOINLINE fieldEntries #-}

class GRowEncoder f where
  -- | The fields, in order, before the rest.
  gFieldParams :: f x -> FieldParams -> FieldParams

instance (GRowEncoder f, GRowEncoder g) => GRowEncoder (f :*: g) where
  gFieldParams :: forall x. (:*:) f g x -> FieldParams -> FieldParams
gFieldParams (f x
a :*: g x
b) FieldParams
rest = f x -> FieldParams -> FieldParams
forall x. f x -> FieldParams -> FieldParams
forall (f :: * -> *) x.
GRowEncoder f =>
f x -> FieldParams -> FieldParams
gFieldParams f x
a (g x -> FieldParams -> FieldParams
forall x. g x -> FieldParams -> FieldParams
forall (f :: * -> *) x.
GRowEncoder f =>
f x -> FieldParams -> FieldParams
gFieldParams g x
b FieldParams
rest)
  {-# INLINE gFieldParams #-}

instance {-# OVERLAPPABLE #-} GRowEncoder f => GRowEncoder (M1 i c f) where
  gFieldParams :: forall x. M1 i c f x -> FieldParams -> FieldParams
gFieldParams (M1 f x
a) = f x -> FieldParams -> FieldParams
forall x. f x -> FieldParams -> FieldParams
forall (f :: * -> *) x.
GRowEncoder f =>
f x -> FieldParams -> FieldParams
gFieldParams f x
a
  {-# INLINE gFieldParams #-}

-- A record of one field is only newtype wrappers in its generic representation,
-- so walking its parameters (to count them, or to render the SQL) never forced
-- the record, even when the field is strict.  The unpacked constructors would
-- force it, so a record of one field keeps 'FieldParam'.
instance {-# OVERLAPPING #-} ToSqlField a => GRowEncoder (M1 C constructor (M1 S metadata (K1 i a))) where
  gFieldParams :: forall x.
M1 C constructor (M1 S metadata (K1 i a)) x
-> FieldParams -> FieldParams
gFieldParams (M1 (M1 (K1 a
a))) = FieldEncoder a -> a -> FieldParams -> FieldParams
forall a. FieldEncoder a -> a -> FieldParams -> FieldParams
FieldParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder a
a
  {-# INLINE gFieldParams #-}

-- Only a field its constructor already forces may be held unpacked, because
-- building the 'FieldParams' then forces nothing that was not forced before, and
-- counting the parameters or rendering the SQL must not evaluate a lazy field.
-- The selector's strictness is static, so a derived encoder has one of the two
-- branches and not the case.
instance {-# OVERLAPPING #-} (Selector metadata, ToSqlField a) => GRowEncoder (M1 S metadata (K1 i a)) where
  gFieldParams :: forall x. M1 S metadata (K1 i a) x -> FieldParams -> FieldParams
gFieldParams selector :: M1 S metadata (K1 i a) x
selector@(M1 (K1 a
a)) = case M1 S metadata (K1 i a) x -> DecidedStrictness
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> DecidedStrictness
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t metadata f a -> DecidedStrictness
selDecidedStrictness M1 S metadata (K1 i a) x
selector of
    DecidedStrictness
DecidedLazy -> FieldEncoder a -> a -> FieldParams -> FieldParams
forall a. FieldEncoder a -> a -> FieldParams -> FieldParams
FieldParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder a
a
    DecidedStrictness
_ -> a -> FieldParams -> FieldParams
forall a. ToSqlField a => a -> FieldParams -> FieldParams
fieldParam a
a
  {-# INLINE gFieldParams #-}

-- A field without selector metadata promises no strictness.
instance ToSqlField a => GRowEncoder (K1 i a) where
  gFieldParams :: forall x. K1 i a x -> FieldParams -> FieldParams
gFieldParams (K1 a
a) = FieldEncoder a -> a -> FieldParams -> FieldParams
forall a. FieldEncoder a -> a -> FieldParams -> FieldParams
FieldParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder a
a
  {-# INLINE gFieldParams #-}

-- | A parameter read as it is sent, so a large value needn't be in memory.  Its
-- type is a @(max)@ type or @xml@; any other is an 'Hmssql.Errors.EncodeError'
-- before anything is sent.
data StreamParam = StreamParam !TypeInfo !ParamValue

instance ToSqlField StreamParam where
  fieldEncoder :: FieldEncoder StreamParam
fieldEncoder = (TdsContext -> StreamParam -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder StreamParam
forall a.
(TdsContext -> a -> Either String EncodedParam)
-> (TdsContext -> TypeInfo) -> FieldEncoder a
FieldEncoder
    (\TdsContext
_ (StreamParam TypeInfo
ti ParamValue
value) -> Either String EncodedParam
-> (String -> Either String EncodedParam)
-> Maybe String
-> Either String EncodedParam
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
ti, ParamValue
value)) String -> Either String EncodedParam
forall a b. a -> Either a b
Left (TypeInfo -> ParamValue -> Maybe String
paramValueProblem TypeInfo
ti ParamValue
value))
    (TypeInfo -> TdsContext -> TypeInfo
forall a b. a -> b -> a
const TypeInfo
untypedNull)

-- | A @varbinary(max)@ parameter, read from the source as it is sent.
binaryStream :: Source B.ByteString -> StreamParam
binaryStream :: Source ByteString -> StreamParam
binaryStream = TypeInfo -> Source ByteString -> StreamParam
streamAs (Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength)

-- | An @nvarchar(max)@ parameter, read from the source as it is sent.
textStream :: Source Text -> StreamParam
textStream :: Source Text -> StreamParam
textStream (Source forall r. (Stream (Of Text) IO () -> IO r) -> IO r
source) = TypeInfo -> Source ByteString -> StreamParam
streamAs (Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength Collation
defaultCollation) (Source ByteString -> StreamParam)
-> Source ByteString -> StreamParam
forall a b. (a -> b) -> a -> b
$
  (forall r. (Stream (Of ByteString) IO () -> IO r) -> IO r)
-> Source ByteString
forall a.
(forall r. (Stream (Of a) IO () -> IO r) -> IO r) -> Source a
Source (\Stream (Of ByteString) IO () -> IO r
use -> (Stream (Of Text) IO () -> IO r) -> IO r
forall r. (Stream (Of Text) IO () -> IO r) -> IO r
source (Stream (Of ByteString) IO () -> IO r
use (Stream (Of ByteString) IO () -> IO r)
-> (Stream (Of Text) IO () -> Stream (Of ByteString) IO ())
-> Stream (Of Text) IO ()
-> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Stream (Of Text) IO ()
stream -> Stream (Of Text) IO ()
-> (Text -> Stream (Of ByteString) IO ())
-> Stream (Of ByteString) IO ()
forall (m :: * -> *) (f :: * -> *) a r x.
(Monad m, Functor f) =>
Stream (Of a) m r -> (a -> Stream f m x) -> Stream f m r
S.for Stream (Of Text) IO ()
stream ([ByteString] -> Stream (Of ByteString) IO ()
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f a -> Stream (Of a) m ()
S.each ([ByteString] -> Stream (Of ByteString) IO ())
-> (Text -> [ByteString]) -> Text -> Stream (Of ByteString) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [ByteString]
utf16Chunks))))

-- | The text in UTF-16LE, a bounded piece at a time, so that one large 'Text'
-- doesn't need all of its encoding in memory.  The split is by character, so
-- no piece ends inside a surrogate pair.
utf16Chunks :: Text -> [B.ByteString]
utf16Chunks :: Text -> [ByteString]
utf16Chunks Text
text
  | Text -> Bool
T.null Text
text = []
  | Bool
otherwise = let (Text
here, Text
rest) = Int -> Text -> (Text, Text)
T.splitAt Int
2048 Text
text in Text -> ByteString
Utf16.encodeUtf16LE Text
here ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Text -> [ByteString]
utf16Chunks Text
rest

-- | A parameter of the given @(max)@ or @xml@ type, read from the source as it
-- is sent.  The bytes are the caller's to encode for that type.  For UTF-16,
-- their total must be an even number of bytes.
streamAs :: TypeInfo -> Source B.ByteString -> StreamParam
streamAs :: TypeInfo -> Source ByteString -> StreamParam
streamAs TypeInfo
ti = TypeInfo -> ParamValue -> StreamParam
StreamParam TypeInfo
ti (ParamValue -> StreamParam)
-> (Source ByteString -> ParamValue)
-> Source ByteString
-> StreamParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Source ByteString -> ParamValue
ParamStream

-- | 'streamAs' for lazy bytes, forced as they are sent.
lazyAs :: TypeInfo -> LB.ByteString -> StreamParam
lazyAs :: TypeInfo -> ByteString -> StreamParam
lazyAs TypeInfo
ti = TypeInfo -> ParamValue -> StreamParam
StreamParam TypeInfo
ti (ParamValue -> StreamParam)
-> (ByteString -> ParamValue) -> ByteString -> StreamParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ParamValue
ParamLazy