packages feed

hasql-interpolate (empty) → 0.1.0.0

raw patch · 17 files changed

+1438/−0 lines, 17 filesdep +aesondep +arraydep +base

Dependencies added: aeson, array, base, bytestring, containers, haskell-src-meta, hasql, hasql-interpolate, megaparsec, mtl, scientific, tasty, tasty-hunit, template-haskell, text, time, transformers, uuid, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for src++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2021 Travis Staton++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hasql-interpolate.cabal view
@@ -0,0 +1,77 @@+cabal-version:      2.4+name:               hasql-interpolate+version:            0.1.0.0++author: Travis Staton <hello@travisstaton.com>+category: Hasql, Database, PostgreSQL+copyright: 2021, Travis Staton+extra-source-files: CHANGELOG.md+homepage: https://github.com/awkward-squad/hasql-interpolate+license-file: LICENSE+license: BSD-3-Clause+maintainer: Travis Staton <hello@travisstaton.com>, Mitchell Rosen+synopsis: QuasiQuoter that supports expression interpolation for hasql+description:++  @hasql-interpolate@ provides a sql QuasiQuoter for hasql that+  supports interpolation of haskell expressions and splicing of sql+  snippets. A number of type classes are also provided to reduce+  encoder/decoder boilerplate.++library+    exposed-modules:  Hasql.Interpolate+                      Hasql.Interpolate.Internal.TH++    other-modules:    Hasql.Interpolate.Internal.Json+                      Hasql.Interpolate.Internal.Encoder+                      Hasql.Interpolate.Internal.Decoder+                      Hasql.Interpolate.Internal.OneColumn+                      Hasql.Interpolate.Internal.OneRow+                      Hasql.Interpolate.Internal.RowsAffected+                      Hasql.Interpolate.Internal.Decoder.TH+                      Hasql.Interpolate.Internal.Sql+                      Hasql.Interpolate.Internal.CompositeValue+                      Hasql.Interpolate.Internal.EncodeRow+                      Hasql.Interpolate.Internal.EncodeRow.TH++    build-depends:    base >= 4.14 && < 5+                    , hasql ^>= 1.4+                    , haskell-src-meta ^>= 0.8+                    , template-haskell >= 2.14+                    , megaparsec >= 8.0.0+                    , text+                    , time+                    , uuid+                    , scientific+                    , aeson+                    , transformers+                    , mtl+                    , vector+                    , containers+                    , bytestring+                    , array++    hs-source-dirs:   lib+    default-language: Haskell2010+    ghc-options:+      -Wall+      -Wcompat+      -Widentities+      -Wincomplete-record-updates+      -Wincomplete-uni-patterns+      -Wredundant-constraints+      -Wpartial-fields+      -O2++test-suite unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  build-depends: base+               , hasql+               , hasql-interpolate+               , template-haskell+               , tasty+               , text+               , tasty-hunit+  hs-source-dirs: test+  default-language: Haskell2010
+ lib/Hasql/Interpolate.hs view
@@ -0,0 +1,75 @@+module Hasql.Interpolate+  ( -- * QuasiQuoters+    sql,+    Sql,++    -- * Interpolators+    interp,+    interpFoldl,+    interpWith,++    -- * Decoders+    DecodeValue (..),+    DecodeField (..),+    DecodeRow (..),+    DecodeResult (..),++    -- * Encoders+    EncodeValue (..),+    EncodeField,++    -- * Newtypes for decoding/encoding+    OneRow (..),+    OneColumn (..),+    RowsAffected (..),+    Json (..),+    Jsonb (..),+    AsJson (..),+    AsJsonb (..),+    CompositeValue (..),++    -- * toTable+    toTable,+    EncodeRow (..),+  )+where++import Control.Monad.Trans.State.Strict (evalState)+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Lazy (toStrict)+import Hasql.Decoders (Result, foldlRows)+import Hasql.Interpolate.Internal.CompositeValue+import Hasql.Interpolate.Internal.Decoder+import Hasql.Interpolate.Internal.EncodeRow+import Hasql.Interpolate.Internal.Encoder+import Hasql.Interpolate.Internal.Json+import Hasql.Interpolate.Internal.OneColumn+import Hasql.Interpolate.Internal.OneRow+import Hasql.Interpolate.Internal.RowsAffected+import Hasql.Interpolate.Internal.Sql+import Hasql.Interpolate.Internal.TH+import Hasql.Statement (Statement (..))++-- | Interpolate a 'Sql' into a 'Statement' using the 'DecodeResult'+-- type class to determine the appropriate decoder.+--+-- @+-- example :: Int64 -> Statement () [(Int64, Int64)]+-- example bonk = interp False [sql| select x, y from t where t.x > #{bonk} |]+-- @+interp ::+  DecodeResult b =>+  -- | 'True' if the 'Statement' should be prepared+  Bool ->+  Sql ->+  Statement () b+interp prepared = interpWith prepared decodeResult++-- | interpolate then consume with 'foldlRows'+interpFoldl :: DecodeRow a => Bool -> (b -> a -> b) -> b -> Sql -> Statement () b+interpFoldl prepared f z = interpWith prepared (foldlRows f z decodeRow)++-- | A more general version of 'interp' that allows for passing an+-- explicit decoder.+interpWith :: Bool -> Result b -> Sql -> Statement () b+interpWith prepare decoder (Sql bldr enc) = Statement (toStrict (toLazyByteString (evalState bldr 1))) enc decoder prepare
+ lib/Hasql/Interpolate/Internal/CompositeValue.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Hasql.Interpolate.Internal.CompositeValue+  ( CompositeValue (..),+  )+where++import Data.Coerce+import GHC.Generics+import Hasql.Decoders+import Hasql.Interpolate.Internal.Decoder++-- | Useful with @DerivingVia@ to get a 'DecodeValue' instance for any+-- product type by parsing it as a composite.+--+-- ==== __Example__+--+-- @+-- data Point = Point Int64 Int64+--   deriving stock (Generic)+--   deriving (DecodeValue) via CompositeValue Point+-- @+newtype CompositeValue a+  = CompositeValue a++instance (Generic a, GToComposite (Rep a)) => DecodeValue (CompositeValue a) where+  decodeValue = coerce @(Value a) (composite (to <$> gtoComposite))++class GToComposite a where+  gtoComposite :: Composite (a p)++instance GToComposite a => GToComposite (M1 t i a) where+  gtoComposite = M1 <$> gtoComposite++instance (GToComposite a, GToComposite b) => GToComposite (a :*: b) where+  gtoComposite = (:*:) <$> gtoComposite <*> gtoComposite++instance DecodeValue a => GToComposite (K1 i a) where+  gtoComposite = K1 <$> field decodeField
+ lib/Hasql/Interpolate/Internal/Decoder.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Hasql.Interpolate.Internal.Decoder+  ( -- * Decoding type classes+    DecodeValue (..),+    DecodeField (..),+    DecodeRow (..),+    DecodeResult (..),++    -- * Generics+    GDecodeRow (..),+  )+where++import Data.Int+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (Day, DiffTime, LocalTime, UTCTime)+import Data.UUID (UUID)+import Data.Vector (Vector)+import GHC.Generics+import Hasql.Decoders+import Hasql.Interpolate.Internal.Decoder.TH++-- | This type class determines which decoder we will apply to a query+-- field by the type of the result.+--+-- ==== __Example__+--+-- @+--+-- data ThreatLevel = None | Midnight+--+-- instance DecodeValue ThreatLevel where+--   decodeValue = enum \\case+--     "none"     -> Just None+--     "midnight" -> Just Midnight+--     _          -> Nothing+-- @+class DecodeValue a where+  decodeValue :: Value a++-- | You do not need to define instances for this class; The two+-- instances exported here cover all uses. The class only exists to+-- lift 'Value' to hasql's 'NullableOrNot' GADT.+class DecodeField a where+  decodeField :: NullableOrNot Value a++-- | Determine a row decoder from a Haskell type. Derivable with+-- generics for any product type.+--+-- ==== __Examples__+--+-- A manual instance:+--+-- @+-- data T = T Int64 Bool Text+--+-- instance DecodeRow T where+--   decodeRow = T+--     <$> column decodeField+--     <*> column decodeField+--     <*> column decodeField+-- @+--+-- A generic instance:+--+-- @+-- data T+--  = T Int64 Bool Text+--  deriving stock (Generic)+--  deriving anyclass (DecodeRow)+-- @+class DecodeRow a where+  decodeRow :: Row a+  default decodeRow :: (Generic a, GDecodeRow (Rep a)) => Row a+  decodeRow = to <$> gdecodeRow++class GDecodeRow a where+  gdecodeRow :: Row (a p)++-- | Determine a result decoder from a Haskell type.+class DecodeResult a where+  decodeResult :: Result a++instance GDecodeRow a => GDecodeRow (M1 t i a) where+  gdecodeRow = M1 <$> gdecodeRow++instance (GDecodeRow a, GDecodeRow b) => GDecodeRow (a :*: b) where+  gdecodeRow = (:*:) <$> gdecodeRow <*> gdecodeRow++instance DecodeField a => GDecodeRow (K1 i a) where+  gdecodeRow = K1 <$> column decodeField++-- | Parse a postgres @array@ using 'listArray'+instance DecodeField a => DecodeValue [a] where+  decodeValue = listArray decodeField++-- | Parse a postgres @array@ using 'vectorArray'+instance DecodeField a => DecodeValue (Vector a) where+  decodeValue = vectorArray decodeField++-- | Parse a postgres @bool@ using 'bool'+instance DecodeValue Bool where+  decodeValue = bool++-- | Parse a postgres @text@ using 'text'+instance DecodeValue Text where+  decodeValue = text++-- | Parse a postgres @int2@ using 'int2'+instance DecodeValue Int16 where+  decodeValue = int2++-- | Parse a postgres @int4@ using 'int4'+instance DecodeValue Int32 where+  decodeValue = int4++-- | Parse a postgres @int8@ using 'int8'+instance DecodeValue Int64 where+  decodeValue = int8++-- | Parse a postgres @float4@ using 'float4'+instance DecodeValue Float where+  decodeValue = float4++-- | Parse a postgres @float8@ using 'float8'+instance DecodeValue Double where+  decodeValue = float8++-- | Parse a postgres @char@ using 'char'+instance DecodeValue Char where+  decodeValue = char++-- | Parse a postgres @date@ using 'date'+instance DecodeValue Day where+  decodeValue = date++-- | Parse a postgres @timestamp@ using 'timestamp'+instance DecodeValue LocalTime where+  decodeValue = timestamp++-- | Parse a postgres @timestamptz@ using 'timestamptz'+instance DecodeValue UTCTime where+  decodeValue = timestamptz++-- | Parse a postgres @numeric@ using 'numeric'+instance DecodeValue Scientific where+  decodeValue = numeric++-- | Parse a postgres @interval@ using 'interval'+instance DecodeValue DiffTime where+  decodeValue = interval++-- | Parse a postgres @uuid@ using 'uuid'+instance DecodeValue UUID where+  decodeValue = uuid++-- | Overlappable instance for parsing non-nullable values+instance {-# OVERLAPPABLE #-} DecodeValue a => DecodeField a where+  decodeField = nonNullable decodeValue++-- | Instance for parsing nullable values+instance DecodeValue a => DecodeField (Maybe a) where+  decodeField = nullable decodeValue++-- | Parse any number of rows into a list ('rowList')+instance DecodeRow a => DecodeResult [a] where+  decodeResult = rowList decodeRow++-- | Parse any number of rows into a 'Vector' ('rowVector')+instance DecodeRow a => DecodeResult (Vector a) where+  decodeResult = rowVector decodeRow++-- | Parse zero or one rows, throw 'Hasql.Errors.UnexpectedAmountOfRows' otherwise. ('rowMaybe')+instance DecodeRow a => DecodeResult (Maybe a) where+  decodeResult = rowMaybe decodeRow++-- | Ignore the query response ('noResult')+instance DecodeResult () where+  decodeResult = noResult++$(traverse genDecodeRowInstance [2 .. 8])
+ lib/Hasql/Interpolate/Internal/Decoder/TH.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}++module Hasql.Interpolate.Internal.Decoder.TH+  ( genDecodeRowInstance,+  )+where++import Control.Monad+import Data.Foldable (foldl')+import Hasql.Decoders+import Language.Haskell.TH++-- | Generate a single 'Hasql.Interpolate.DecodeRow' instance for a+-- tuple of size @tupSize@+genDecodeRowInstance ::+  -- | tuple size+  Int ->+  Q Dec+genDecodeRowInstance tupSize+  | tupSize < 2 = fail "this is just for tuples, must specify a tuple size of 2 or greater"+  | otherwise = do+    tyVars <- replicateM tupSize (newName "x")+    context <- traverse (\x -> [t|$(conT (mkName "DecodeField")) $(varT x)|]) tyVars+    instanceHead <- [t|$(conT (mkName "DecodeRow")) $(pure $ foldl' AppT (TupleT tupSize) (map VarT tyVars))|]+    let tupSection = TupE (replicate tupSize Nothing)+        go b _a = do+          [e|$(b) <*> column decodeField|]++    instanceBodyExp <- foldl' go [e|$(pure tupSection) <$> column decodeField|] (tail tyVars)+    let instanceBody = FunD (mkName "decodeRow") [Clause [] (NormalB instanceBodyExp) []]+    pure (InstanceD Nothing context instanceHead [instanceBody])
+ lib/Hasql/Interpolate/Internal/EncodeRow.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Hasql.Interpolate.Internal.EncodeRow+  ( EncodeRow (..),+    GEncodeRow (..),+    toTable,+  )+where++import Control.Monad+import Data.Functor.Contravariant+import Data.List (intersperse)+import Data.Monoid+import GHC.Generics+import qualified Hasql.Encoders as E+import Hasql.Interpolate.Internal.EncodeRow.TH+import Hasql.Interpolate.Internal.Encoder+import Hasql.Interpolate.Internal.Sql+import Hasql.Interpolate.Internal.TH (addParam)++class EncodeRow a where+  -- | The continuation @(forall x. (a -> x -> x) -> x -> E.Params x+  -- -> Int -> r)@ is given cons @(a -> x -> x)@ and nil @(x)@ for some+  -- existential type @x@ and an encoder (@'E.Params' x@) for @x@. An+  -- Int is also given to tally up how many sql fields are in the+  -- unzipped structure.+  --+  -- ==== __Example__+  --+  -- Consider the following manually written instance:+  --+  -- @+  -- data Blerg = Blerg Int64 Bool Text Char+  --+  -- instance EncodeRow Blerg where+  --   unzipWithEncoder k = k cons nil enc 4+  --     where+  --       cons (Blerg a b c d) ~(as, bs, cs, ds) =+  --         (a : as, b : bs, c : cs, d : ds)+  --       nil = ([], [], [], [])+  --       enc =+  --              ((\(x, _, _, _) -> x) >$< param encodeField)+  --           <> ((\(_, x, _, _) -> x) >$< param encodeField)+  --           <> ((\(_, _, x, _) -> x) >$< param encodeField)+  --           <> ((\(_, _, _, x) -> x) >$< param encodeField)+  -- @+  --+  -- We chose @([Int64], [Bool], [Text], [Char])@ as our existential+  -- type. If we instead use the default instance based on+  -- 'GEncodeRow' then we would produce the same code as the+  -- instance below:+  --+  -- @+  -- instance EncodeRow Blerg where+  --   unzipWithEncoder k = k cons nil enc 4+  --     where+  --       cons (Blerg a b c d) ~(~(as, bs), ~(cs, ds)) =+  --         ((a : as, b : bs), (c : cs, d : ds))+  --       nil = (([], []), ([], []))+  --       enc =+  --              ((\((x, _),      _) -> x) >$< param encodeField)+  --           <> ((\((_, x),      _) -> x) >$< param encodeField)+  --           <> ((\(_     , (x, _)) -> x) >$< param encodeField)+  --           <> ((\(_     , (_, x)) -> x) >$< param encodeField)+  -- @+  --+  -- The notable difference being we don't produce a flat tuple, but+  -- instead produce a balanced tree of tuples isomorphic to the+  -- balanced tree of @':*:'@ from the generic 'Rep' of @Blerg@.+  unzipWithEncoder :: (forall x. (a -> x -> x) -> x -> E.Params x -> Int -> r) -> r+  default unzipWithEncoder ::+    (Generic a, GEncodeRow (Rep a)) =>+    (forall x. (a -> x -> x) -> x -> E.Params x -> Int -> r) ->+    r+  unzipWithEncoder k = gUnzipWithEncoder \cons nil enc fc ->+    k (cons . from) nil enc fc+  {-# INLINE unzipWithEncoder #-}++class GEncodeRow a where+  gUnzipWithEncoder :: (forall x. (a p -> x -> x) -> x -> E.Params x -> Int -> r) -> r++-- | 'toTable' takes some list of products into the corresponding+-- relation in sql. It is applying the @unnest@ based technique+-- described [in the hasql+-- documentation](https://hackage.haskell.org/package/hasql-1.4.5.1/docs/Hasql-Statement.html#g:2).+--+-- ==== __Example__+--+-- Here is a small example that takes a haskell list and inserts it+-- into a table @blerg@ which has columns @x@, @y@, and @z@ of type+-- @int8@, @boolean@, and @text@ respectively.+--+-- @+-- toTableExample :: [(Int64, Bool, Text)] -> Statement () ()+-- toTableExample rowsToInsert =+--   interp [sql| insert into blerg (x, y, z) select * from ^{toTable rowsToInsert} |]+-- @+--+-- This is driven by the 'EncodeRow' type class that has a+-- default implementation for product types that are an instance of+-- 'Generic'. So the following also works:+--+-- @+-- data Blerg+--   = Blerg Int64 Bool Text+--   deriving stock (Generic)+--   deriving anyclass (EncodeRow)+--+-- toTableExample :: [Blerg] -> Statement () ()+-- toTableExample blergs =+--   interp [sql| insert into blerg (x, y, z) select * from ^{toTable blergs} |]+-- @+toTable :: EncodeRow a => [a] -> Sql+toTable xs = unzipWithEncoder \cons nil enc i ->+  let unzippedEncoder = foldr cons nil xs >$ enc+      queryString = getAp $ pure "unnest(" <> (mconcat . intersperse ", " <$> Ap (replicateM i addParam)) <> pure ")"+   in Sql queryString unzippedEncoder+{-# INLINE toTable #-}++instance GEncodeRow x => GEncodeRow (M1 t i x) where+  gUnzipWithEncoder k = gUnzipWithEncoder \cons nil enc i ->+    k (\(M1 a) -> cons a) nil enc i+  {-# INLINE gUnzipWithEncoder #-}++instance (GEncodeRow a, GEncodeRow b) => GEncodeRow (a :*: b) where+  gUnzipWithEncoder k = gUnzipWithEncoder \consa nila enca ia -> gUnzipWithEncoder \consb nilb encb ib ->+    k+      ( \(a :*: b) ~(as, bs) ->+          (consa a as, consb b bs)+      )+      (nila, nilb)+      (contramap fst enca <> contramap snd encb)+      (ia + ib)+  {-# INLINE gUnzipWithEncoder #-}++instance EncodeField a => GEncodeRow (K1 i a) where+  gUnzipWithEncoder k =+    k (\(K1 a) b -> a : b) [] (E.param (E.nonNullable (E.foldableArray encodeField))) 1+  {-# INLINE gUnzipWithEncoder #-}++$(traverse genEncodeRowInstance [2 .. 8])
+ lib/Hasql/Interpolate/Internal/EncodeRow/TH.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Hasql.Interpolate.Internal.EncodeRow.TH+  ( genEncodeRowInstance,+  )+where++import Control.Monad+import Data.Foldable (foldl')+import Data.Functor.Contravariant+import qualified Hasql.Encoders as E+import Hasql.Interpolate.Internal.Encoder (EncodeField (..), EncodeValue (..))+import Language.Haskell.TH++-- | Generate a single 'Hasql.Interpolate.EncodeRow' instance for a+-- tuple of size @tupSize@+genEncodeRowInstance ::+  -- | tuple size+  Int ->+  Q Dec+genEncodeRowInstance tupSize+  | tupSize < 2 = fail "this is just for tuples, must specify a tuple size of 2 or greater"+  | otherwise = do+    tyVars <- replicateM tupSize (newName "x")+    context <- traverse (\x -> [t|EncodeValue $(varT x)|]) tyVars+    let unzipWithEncoderName = mkName "unzipWithEncoder"+    instanceHead <- [t|$(conT (mkName "EncodeRow")) $(pure $ foldl' AppT (TupleT tupSize) (map VarT tyVars))|]+    innerContName <- newName "k"+    cons <- [e|(:)|]+    kconsTailNames <- traverse (\_ -> newName "tail") tyVars+    let kconsPats :: [Pat]+        kconsPats =+          [ TupP (map VarP tyVars),+            TildeP (TupP (map VarP kconsTailNames))+          ]+        kconsTupBody :: [Exp]+        kconsTupBody =+          let vars = zipWith phi tyVars kconsTailNames+              phi headName tailName = foldl' AppE cons [VarE headName, VarE tailName]+           in vars+        kcons :: Exp+        kcons = LamE kconsPats (TupE (map Just kconsTupBody))+        knil :: Exp+        knil = TupE . map Just $ replicate tupSize (ListE [])+    kenc :: Exp <- do+      let listEncoder = [e|E.param (E.nonNullable (E.foldableArray encodeField))|]+          plucks = map (pluck tupSize) [0 .. tupSize - 1]+      encExps <- traverse (\getTupElem -> [e|contramap $getTupElem $listEncoder|]) plucks+      foldr (\a b -> [e|$(pure a) <> $(b)|]) [e|mempty|] encExps+    let kExp :: Exp+        kExp = foldl' AppE (VarE innerContName) [kcons, knil, kenc, LitE (IntegerL (fromIntegral tupSize))]+    let instanceBody = FunD unzipWithEncoderName [Clause [VarP innerContName] (NormalB kExp) []]+    pure (InstanceD Nothing context instanceHead [instanceBody])++pluck :: Int -> Int -> Q Exp+pluck 1 0 = [e|id|]+pluck tupSize idx = do+  matchName <- newName "match"+  let tupPat = TupP (map (\n -> if n == idx then VarP matchName else WildP) [0 .. tupSize - 1])+  pure $ LamE [tupPat] (VarE matchName)
+ lib/Hasql/Interpolate/Internal/Encoder.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Hasql.Interpolate.Internal.Encoder+  ( EncodeValue (..),+    EncodeField (..),+  )+where++import Data.Int+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (Day, DiffTime, LocalTime, UTCTime)+import Data.UUID (UUID)+import Data.Vector (Vector)+import Hasql.Encoders++-- | This type class determines which encoder we will apply to a field+-- by its type.+--+-- ==== __Example__+--+-- @+--+-- data ThreatLevel = None | Midnight+--+-- instance EncodeValue ThreatLevel where+--   encodeValue = enum \\case+--     None     -> "none"+--     Midnight -> "midnight"+-- @+class EncodeValue a where+  encodeValue :: Value a++-- | Encode a list as a postgres array using 'foldableArray'+instance EncodeField a => EncodeValue [a] where+  encodeValue = foldableArray encodeField++-- | Encode a 'Vector' as a postgres array using 'foldableArray'+instance EncodeField a => EncodeValue (Vector a) where+  encodeValue = foldableArray encodeField++-- | Encode a 'Bool' as a postgres @boolean@ using 'bool'+instance EncodeValue Bool where+  encodeValue = bool++-- | Encode a 'Text' as a postgres @text@ using 'text'+instance EncodeValue Text where+  encodeValue = text++-- | Encode a 'Int16' as a postgres @int2@ using 'int2'+instance EncodeValue Int16 where+  encodeValue = int2++-- | Encode a 'Int32' as a postgres @int4@ using 'int4'+instance EncodeValue Int32 where+  encodeValue = int4++-- | Encode a 'Int64' as a postgres @int8@ using 'int8'+instance EncodeValue Int64 where+  encodeValue = int8++-- | Encode a 'Float' as a postgres @float4@ using 'float4'+instance EncodeValue Float where+  encodeValue = float4++-- | Encode a 'Double' as a postgres @float8@ using 'float8'+instance EncodeValue Double where+  encodeValue = float8++-- | Encode a 'Char' as a postgres @char@ using 'char'+instance EncodeValue Char where+  encodeValue = char++-- | Encode a 'Day' as a postgres @date@ using 'date'+instance EncodeValue Day where+  encodeValue = date++-- | Encode a 'LocalTime' as a postgres @timestamp@ using 'timestamp'+instance EncodeValue LocalTime where+  encodeValue = timestamp++-- | Encode a 'UTCTime' as a postgres @timestamptz@ using 'timestamptz'+instance EncodeValue UTCTime where+  encodeValue = timestamptz++-- | Encode a 'Scientific' as a postgres @numeric@ using 'numeric'+instance EncodeValue Scientific where+  encodeValue = numeric++-- | Encode a 'DiffTime' as a postgres @interval@ using 'interval'+instance EncodeValue DiffTime where+  encodeValue = interval++-- | Encode a 'UUID' as a postgres @uuid@ using 'uuid'+instance EncodeValue UUID where+  encodeValue = uuid++-- | You do not need to define instances for this class; The two+-- instances exported here cover all uses. The class only exists to+-- lift 'Value' to hasql's 'NullableOrNot' GADT.+class EncodeField a where+  encodeField :: NullableOrNot Value a++-- | Overlappable instance for all non-nullable types.+instance {-# OVERLAPPABLE #-} EncodeValue a => EncodeField a where+  encodeField = nonNullable encodeValue++-- | Instance for all nullable types. 'Nothing' is encoded as @null@.+instance EncodeValue a => EncodeField (Maybe a) where+  encodeField = nullable encodeValue
+ lib/Hasql/Interpolate/Internal/Json.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Hasql.Interpolate.Internal.Json+  ( Json (..),+    Jsonb (..),+    AsJson (..),+    AsJsonb (..),+  )+where++import Data.Aeson+import qualified Data.Aeson as Aeson+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as BL+import Data.Coerce+import Data.Functor.Contravariant+import qualified Data.Text as T+import qualified Hasql.Decoders as D+import qualified Hasql.Encoders as E+import Hasql.Interpolate.Internal.Decoder+import Hasql.Interpolate.Internal.Encoder++-- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' /+-- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts+-- between a postgres json type and an Aeson 'Value'+newtype Jsonb = Jsonb Value++-- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' /+-- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts+-- between a postgres json type and an Aeson 'Value'+newtype Json = Json Value++-- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' /+-- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts+-- between a postgres json type and anything that is an instance of+-- 'FromJSON' / 'ToJSON'+newtype AsJson a = AsJson a++-- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' /+-- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts+-- between a postgres jsonb type and anything that is an instance of+-- 'FromJSON' / 'ToJSON'+newtype AsJsonb a = AsJsonb a++-- | Parse a postgres @jsonb@ using 'D.jsonb'+instance DecodeValue Jsonb where+  decodeValue = coerce D.jsonb++-- | Parse a postgres @json@ using 'D.json'+instance DecodeValue Json where+  decodeValue = coerce D.json++-- | Parse a postgres @json@ to anything that is an instance of+-- 'Aeson.FromJSON'+instance Aeson.FromJSON a => DecodeValue (AsJson a) where+  decodeValue = AsJson <$> D.jsonBytes (first T.pack . Aeson.eitherDecodeStrict)++-- | Parse a postgres @jsonb@ to anything that is an instance of+-- 'Aeson.FromJSON'+instance Aeson.FromJSON a => DecodeValue (AsJsonb a) where+  decodeValue = AsJsonb <$> D.jsonbBytes (first T.pack . Aeson.eitherDecodeStrict)++-- | Encode an Aeson 'Aeson.Value' to a postgres @json@ using 'E.json'+instance EncodeValue Json where+  encodeValue = coerce E.json++-- | Encode an Aeson 'Aeson.Value' to a postgres @jsonb@ using 'E.jsonb'+instance EncodeValue Jsonb where+  encodeValue = coerce E.jsonb++-- | Encode anything that is an instance of 'Aeson.ToJSON' to a postgres @json@+instance Aeson.ToJSON a => EncodeValue (AsJson a) where+  encodeValue = BL.toStrict . Aeson.encode . coerce @_ @a >$< E.jsonBytes++-- | Encode anything that is an instance of 'Aeson.ToJSON' to a postgres @jsonb@+instance Aeson.ToJSON a => EncodeValue (AsJsonb a) where+  encodeValue = BL.toStrict . Aeson.encode . coerce @_ @a >$< E.jsonbBytes
+ lib/Hasql/Interpolate/Internal/OneColumn.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Hasql.Interpolate.Internal.OneColumn+  ( OneColumn (..),+  )+where++import GHC.Generics (Generic)+import qualified Hasql.Decoders as D+import Hasql.Interpolate.Internal.Decoder++newtype OneColumn a = OneColumn+  { getOneColumn :: a+  }+  deriving stock (Show, Eq, Generic)++-- | Parse a single column row+instance DecodeField a => DecodeRow (OneColumn a) where+  decodeRow = OneColumn <$> D.column decodeField
+ lib/Hasql/Interpolate/Internal/OneRow.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Hasql.Interpolate.Internal.OneRow+  ( OneRow (..),+  )+where++import GHC.Generics (Generic)+import qualified Hasql.Decoders as D+import Hasql.Interpolate.Internal.Decoder++newtype OneRow a = OneRow+  { getOneRow :: a+  }+  deriving stock (Show, Eq, Generic)++-- | Parse a single row result, throw+-- 'Hasql.Errors.UnexpectedAmountOfRows'+-- otherwise. ('Hasql.Decoders.singleRow')+instance DecodeRow a => DecodeResult (OneRow a) where+  decodeResult = OneRow <$> D.singleRow decodeRow
+ lib/Hasql/Interpolate/Internal/RowsAffected.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Hasql.Interpolate.Internal.RowsAffected+  ( RowsAffected (..),+  )+where++import Data.Int+import GHC.Generics (Generic)+import qualified Hasql.Decoders as D+import Hasql.Interpolate.Internal.Decoder++newtype RowsAffected = RowsAffected+  { getRowsAffected :: Int64+  }+  deriving stock (Show, Eq, Generic)++-- | Parse the rows affected from the query result, as in an @insert@,+-- @update@, or @delete@ statement without a returning clause. ('D.rowsAffected')+instance DecodeResult RowsAffected where+  decodeResult = RowsAffected <$> D.rowsAffected
+ lib/Hasql/Interpolate/Internal/Sql.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasql.Interpolate.Internal.Sql+  ( Sql (..),+  )+where++import Control.Monad.Trans.State.Strict+import Data.ByteString.Builder+import Data.String (IsString (..))+import Hasql.Encoders++-- | A SQL string with interpolated expressions.+data Sql = Sql+  { -- | The sql string. It is stateful over an 'Int' in order to+    -- assign the postgresql parameter placeholders (e.g. @$1@, @$2@)+    sqlTxt :: State Int Builder,+    -- | The encoders associated with the sql string. Already applied+    -- to their parameters.+    encoder :: Params ()+  }++instance IsString Sql where+  fromString str = Sql (pure (stringUtf8 str)) mempty++instance Semigroup Sql where+  a <> b =+    Sql+      { sqlTxt =+          ( (<>) <$> sqlTxt a <*> sqlTxt b+          ),+        encoder = encoder a <> encoder b+      }+  {-# INLINE (<>) #-}++instance Monoid Sql where+  mempty =+    Sql+      { sqlTxt = pure mempty,+        encoder = mempty+      }+  {-# INLINE mempty #-}
+ lib/Hasql/Interpolate/Internal/TH.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Hasql.Interpolate.Internal.TH+  ( sql,+    addParam,+    parseSqlExpr,+    compileSqlExpr,+    SqlExpr (..),+    SqlBuilderExp (..),+    ParamEncoder (..),+    SpliceBind (..),+  )+where++import Control.Applicative+import Control.Monad.State.Strict+import Data.Array (listArray, (!))+import Data.ByteString.Builder (Builder, stringUtf8)+import Data.Char+import Data.Functor+import Data.Functor.Contravariant+import qualified Data.IntSet as IS+import Data.Monoid (Ap (..))+import Data.Void+import qualified Hasql.Encoders as E+import Hasql.Interpolate.Internal.Encoder (EncodeField (..))+import Hasql.Interpolate.Internal.Sql+import Language.Haskell.Meta (parseExp)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Megaparsec+  ( ParseErrorBundle,+    Parsec,+    anySingle,+    chunk,+    eof,+    notFollowedBy,+    runParser,+    single,+    takeWhileP,+    try,+  )++data SqlExpr = SqlExpr+  { sqlBuilderExp :: [SqlBuilderExp],+    paramEncoder :: [ParamEncoder],+    spliceBinds :: [SpliceBind],+    bindCount :: Int+  }+  deriving stock (Show, Eq)++data SqlBuilderExp+  = Sbe'Var Int+  | Sbe'Param+  | Sbe'Quote String+  | Sbe'Ident String+  | Sbe'DollarQuote String String+  | Sbe'Cquote String+  | Sbe'Sql String+  deriving stock (Show, Eq)++data ParamEncoder+  = Pe'Exp Exp+  | Pe'Var Int+  deriving stock (Show, Eq)++data SpliceBind = SpliceBind+  { sbBuilder :: Int,+    sbParamEncoder :: Int,+    sbExp :: Exp+  }+  deriving stock (Show, Eq)++dollar :: Builder+dollar = "$"++cquote :: Builder+cquote = "E'"++sq :: Builder+sq = "'"++dq :: Builder+dq = "\""++data ParserState = ParserState+  { ps'sqlBuilderExp :: [SqlBuilderExp] -> [SqlBuilderExp],+    ps'paramEncoder :: [ParamEncoder] -> [ParamEncoder],+    ps'spliceBinds :: [SpliceBind] -> [SpliceBind],+    ps'nextUnique :: Int+  }++type Parser a = StateT (ParserState) (Parsec Void String) a++sqlExprParser :: Parser ()+sqlExprParser = go+  where+    go =+      quoted+        <|> ident+        <|> dollarQuotes+        <|> cquoted+        <|> param+        <|> splice+        <|> comment+        <|> multilineComment+        <|> someSql+        <|> eof++    nextUnique :: Parser Int+    nextUnique = do+      st <- get+      let next = ps'nextUnique st+          !nextnext = next + 1+      put st {ps'nextUnique = nextnext}+      pure next++    appendSqlBuilderExp :: SqlBuilderExp -> Parser ()+    appendSqlBuilderExp x = do+      st <- get+      put st {ps'sqlBuilderExp = ps'sqlBuilderExp st . (x :)}++    appendEncoder :: ParamEncoder -> Parser ()+    appendEncoder x = do+      st <- get+      put st {ps'paramEncoder = ps'paramEncoder st . (x :)}++    addSpliceBinding :: Exp -> Parser ()+    addSpliceBinding x = do+      exprVar <- nextUnique+      paramVar <- nextUnique+      st <- get+      put+        st+          { ps'spliceBinds =+              ps'spliceBinds st+                . (SpliceBind {sbBuilder = exprVar, sbParamEncoder = paramVar, sbExp = x} :)+          }+      appendSqlBuilderExp (Sbe'Var exprVar)+      appendEncoder (Pe'Var paramVar)++    comment = do+      _ <- chunk "--"+      void $ takeWhileP (Just "comment") (/= '\n')+      go++    multilineComment = do+      multilineCommentBegin+      go++    multilineCommentBegin = do+      _ <- chunk "/*"+      multilineCommentEnd++    multilineCommentEnd = do+      void $ takeWhileP (Just "multiline comment") (\c -> c /= '*' && c /= '/')+      (multilineCommentBegin >> multilineCommentEnd) <|> void (chunk "*/")++    escapedContent name terminal escapeChar escapeParser =+      let loop sofar = do+            content <- takeWhileP (Just name) (\c -> c /= terminal && c /= escapeChar)+            notFollowedBy eof+            (try escapeParser >>= \esc -> loop (sofar . (content ++) . (esc ++)))+              <|> (single terminal $> sofar content)+       in loop id++    betwixt name initial terminal escapeChar escapeParser = do+      _ <- chunk initial+      escapedContent name terminal escapeChar escapeParser++    quoted = do+      content <- betwixt "single quotes" "'" '\'' '\'' (chunk "''")+      appendSqlBuilderExp (Sbe'Quote content)+      go++    cquoted = do+      content <- betwixt "C-style escape quote" "E'" '\'' '\\' do+        a <- single '\\'+        b <- anySingle+        pure [a, b]+      appendSqlBuilderExp (Sbe'Cquote content)+      go++    ident = do+      content <- betwixt "identifier" "\"" '"' '"' (chunk "\"\"")+      appendSqlBuilderExp (Sbe'Ident content)+      go++    dollarQuotes = do+      _ <- single '$'+      tag <- takeWhileP (Just "identifier") isAlphaNum+      _ <- single '$'+      let bonk sofar = do+            notFollowedBy eof+            c <- takeWhileP (Just "dollar quoted content") (/= '$')+            (parseEndQuote $> (sofar . (c ++))) <|> bonk (sofar . (c ++))+          parseEndQuote = do+            _ <- single '$'+            _ <- chunk tag+            void $ single '$'+      content <- ($ "") <$> bonk id+      appendSqlBuilderExp (Sbe'DollarQuote tag content)+      go++    param = do+      _ <- chunk "#{"+      content <- takeWhileP (Just "parameter") (/= '}')+      _ <- single '}'+      alpha <-+        case parseExp content of+          Left err -> fail err+          Right x -> pure x+      appendEncoder (Pe'Exp alpha)+      appendSqlBuilderExp Sbe'Param+      go++    splice = do+      _ <- chunk "^{"+      content <- takeWhileP (Just "splice") (/= '}')+      _ <- single '}'+      alpha <-+        case parseExp content of+          Left err -> fail err+          Right x -> pure x+      addSpliceBinding alpha+      go++    breakCharsIS = IS.fromList (map fromEnum breakChars)+    breakChars =+      [ '\'',+        'E',+        '"',+        '#',+        '^',+        '$',+        '-',+        '/'+      ]++    someSql = do+      s <- anySingle+      content <- takeWhileP (Just "sql") (\c -> IS.notMember (fromEnum c) breakCharsIS)+      appendSqlBuilderExp (Sbe'Sql (s : content))+      go++addParam :: State Int Builder+addParam = state \i ->+  let !i' = i + 1+   in (dollar <> stringUtf8 (show i), i')++parseSqlExpr :: String -> Either (ParseErrorBundle String Void) SqlExpr+parseSqlExpr str = do+  ps <- runParser (execStateT sqlExprParser (ParserState id id id 0)) "" str+  pure+    SqlExpr+      { sqlBuilderExp = ps'sqlBuilderExp ps [],+        paramEncoder = ps'paramEncoder ps [],+        spliceBinds = ps'spliceBinds ps [],+        bindCount = ps'nextUnique ps+      }++-- | QuasiQuoter that supports interpolation and splices. Produces a+-- 'Sql'.+--+-- @#{..}@ interpolates a haskell expression into a sql query.+--+-- @+-- example1 :: EncodeValue a => a -> Sql+-- example1 x = [sql| select \#{x} |]+-- @+--+-- @^{..}@ introduces a splice, which allows us to inject a sql+-- snippet along with the associated parameters into another sql+-- snippet.+--+-- @+-- example2 :: Sql+-- example2 = [sql| ^{example1 True} where true |]+-- @+sql :: QuasiQuoter+sql =+  QuasiQuoter+    { quoteExp = \str -> do+        case parseSqlExpr str of+          Left err -> fail (show err)+          Right sqlExpr -> compileSqlExpr sqlExpr,+      quotePat = undefined,+      quoteType = undefined,+      quoteDec = undefined+    }++compileSqlExpr :: SqlExpr -> Q Exp+compileSqlExpr (SqlExpr sqlBuilder enc spliceBindings bindCount) = do+  nameArr <- listArray (0, bindCount - 1) <$> replicateM bindCount (newName "x")+  let spliceDecs =+        map+          ( \SpliceBind {sbBuilder, sbParamEncoder, sbExp} ->+              ValD (ConP 'Sql (map VarP [nameArr ! sbBuilder, nameArr ! sbParamEncoder])) (NormalB sbExp) []+          )+          spliceBindings+  sqlBuilderExp <-+    let go a b = case a of+          Sbe'Var i -> [e|Ap $(varE (nameArr ! i)) <> $b|]+          Sbe'Param -> [e|Ap addParam <> $b|]+          Sbe'Quote content -> [e|pure (sq <> stringUtf8 content <> sq) <> $b|]+          Sbe'Ident content -> [e|pure (dq <> stringUtf8 content <> dq) <> $b|]+          Sbe'DollarQuote tag content -> [e|pure (dollar <> stringUtf8 tag <> dollar <> stringUtf8 content <> dollar <> stringUtf8 tag <> dollar) <> $b|]+          Sbe'Cquote content -> [e|pure (cquote <> content <> sq) <> $b|]+          Sbe'Sql content -> [e|pure (stringUtf8 content) <> $b|]+     in foldr go [e|pure mempty|] sqlBuilder+  encExp <-+    let go a b = case a of+          Pe'Exp x -> [e|$(pure x) >$ E.param encodeField <> $b|]+          Pe'Var x -> [e|$(varE (nameArr ! x)) <> $b|]+     in foldr go [e|mempty|] enc+  body <- [e|Sql (getAp $(pure sqlBuilderExp)) $(pure encExp)|]+  pure case spliceDecs of+    [] -> body+    _ -> LetE spliceDecs body
+ test/Main.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Exception+import Data.Int+import Data.Text (Text)+import GHC.Generics (Generic)+import qualified Hasql.Connection as Hasql+import Hasql.Decoders (column)+import Hasql.Interpolate+import Hasql.Interpolate.Internal.TH+import qualified Hasql.Session as Hasql+import Language.Haskell.TH+import Test.Tasty+import Test.Tasty.HUnit+import Prelude++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "Tests"+    [ parserTests,+      executionTests+    ]++parserTests :: TestTree+parserTests =+  testGroup+    "parser"+    [ testCase "quote" testParseQuotes,+      testCase "comment" testParseComment,+      testCase "param" testParseParam+    ]++executionTests :: TestTree+executionTests =+  testGroup+    "execution"+    [ testCase "basic" testBasic,+      testCase "composite test" testComposite,+      testCase "row" testRow,+      testCase "row generic" testRowGeneric+    ]++testParseQuotes :: IO ()+testParseQuotes = do+  let expected = SqlExpr expectedSqlExpr [] [] 0+      expectedSqlExpr =+        [ Sbe'Quote "#{bonk}",+          Sbe'Sql " ",+          Sbe'Quote "^{z''onk}",+          Sbe'Sql " ",+          Sbe'Ident "#{k\"\"onk}",+          Sbe'Sql " ",+          Sbe'DollarQuote "tag" "#{kiplonk}",+          Sbe'Sql " ",+          Sbe'Cquote "newline \\n escaped \\'string\\'"+        ]+  parseSqlExpr "'#{bonk}' '^{z''onk}' \"#{k\"\"onk}\" $tag$#{kiplonk}$tag$ E'newline \\n escaped \\'string\\''" @?= Right expected++testParseComment :: IO ()+testParseComment = do+  let expected = SqlExpr expectedSqlExpr [] [] 0+      expectedSqlExpr =+        [ Sbe'Sql "content ",+          Sbe'Sql "\nhello ",+          Sbe'Sql " world\n",+          Sbe'Sql " end\n"+        ]+      inputStr =+        unlines+          [ "content -- trailing comment",+            "hello /* comment */ world",+            "/* comment",+            "blerg /* nested comment */",+            "*/ end"+          ]+  parseSqlExpr inputStr @?= Right expected++testParseParam :: IO ()+testParseParam = do+  let expected =+        SqlExpr+          [Sbe'Param, Sbe'Sql " ", Sbe'Param]+          [Pe'Exp (VarE (mkName "x")), Pe'Exp (LitE (IntegerL 2))]+          []+          0+  parseSqlExpr "#{x} #{2}" @?= Right expected++testBasic :: IO ()+testBasic = do+  withLocalTransaction \conn -> do+    let relation :: [(Int64, Bool, Int64)]+        relation =+          [ (0, True, 5),+            (1, True, 6),+            (2, False, 7)+          ]+    createRes <- run conn [sql| create table hasql_interpolate_test(x int8, y boolean, z int8) |]+    createRes @?= ()+    RowsAffected insertRes <- run conn [sql| insert into hasql_interpolate_test (x,y,z) select * from ^{toTable relation} |]+    insertRes @?= 3+    selectRes <- run conn [sql| select x, y, z from hasql_interpolate_test where x > #{0 :: Int64} order by x |]+    selectRes @?= filter (\(x, _, _) -> x > 0) relation++testComposite :: IO ()+testComposite = do+  withLocalTransaction \conn -> do+    let expected = [Point 0 0, Point 1 1]+    res <- run conn [sql| select * from (values (row(0,0)), (row(1,1)) ) as t |]+    res @?= map OneColumn expected++data T = T Int64 Bool Text deriving stock (Eq, Show)++instance DecodeRow T where+  decodeRow =+    T+      <$> column decodeField+      <*> column decodeField+      <*> column decodeField++testRow :: IO ()+testRow = do+  withLocalTransaction \conn -> do+    let expected = [T 0 True "foo", T 1 False "bar"]+    res <- run conn [sql| select * from (values (0,true,'foo'), (1,false,'bar') ) as t |]+    res @?= expected++testRowGeneric :: IO ()+testRowGeneric = do+  withLocalTransaction \conn -> do+    let expected = [Point 0 0, Point 1 1]+    res <- run conn [sql| select * from (values (0,0), (1,1) ) as t |]+    res @?= expected++withLocalTransaction :: (Hasql.Connection -> IO a) -> IO a+withLocalTransaction k = bracket (either (fail . show) pure =<< Hasql.acquire "host=localhost") Hasql.release \conn -> do+  let beginTrans = do+        Hasql.run (Hasql.statement () (interp False [sql| begin |])) conn >>= \case+          Left err -> fail (show err)+          Right () -> pure ()+      rollbackTrans = do+        Hasql.run (Hasql.statement () (interp False [sql| rollback |])) conn >>= \case+          Left err -> fail (show err)+          Right () -> pure ()+  bracket beginTrans (\() -> rollbackTrans) \() -> k conn++run :: DecodeResult a => Hasql.Connection -> Sql -> IO a+run conn stmt = do+  Hasql.run (Hasql.statement () (interp False stmt)) conn >>= \case+    Left err -> assertFailure ("Hasql statement unexpectedly failed with error: " <> show err)+    Right x -> pure x++data Point = Point Int64 Int64+  deriving stock (Generic, Eq, Show)+  deriving (DecodeValue) via CompositeValue Point+  deriving anyclass (DecodeRow)