packages feed

hasql-th 0.4.0.10 → 0.4.0.11

raw patch · 10 files changed

+587/−666 lines, 10 filesdep ~template-haskell-compat-v0208PVP ok

version bump matches the API change (PVP)

Dependency ranges changed: template-haskell-compat-v0208

API changes (from Hackage documentation)

Files

hasql-th.cabal view
@@ -1,5 +1,5 @@ name: hasql-th-version: 0.4.0.10+version: 0.4.0.11 category: Hasql, Database, PostgreSQL, Template Haskell synopsis: Template Haskell utilities for Hasql description:@@ -47,7 +47,7 @@     hasql >=1.4 && <1.6,     postgresql-syntax >=0.4 && <0.5,     template-haskell >=2.8 && <3,-    template-haskell-compat-v0208 >=0.1.2 && <2,+    template-haskell-compat-v0208 >=0.1.7 && <2,     text >=1 && <3,     uuid >=1.3 && <2,     vector >=0.12 && <0.13
library/Hasql/TH.hs view
@@ -1,296 +1,281 @@ module Hasql.TH-(-  -- * Statements-  {-|-  Quasiquoters in this category produce Hasql `Statement`s,-  checking the correctness of SQL at compile-time.-  -  To extract the information about parameters and results of the statement,-  the quoter requires you to explicitly specify the Postgres types for placeholders and results.-  -  Here's an example of how to use it:--  >selectUserDetails :: Statement Int32 (Maybe (Text, Text, Maybe Text))-  >selectUserDetails =-  >  [maybeStatement|-  >    select name :: text, email :: text, phone :: text?-  >    from "user"-  >    where id = $1 :: int4-  >    |]-  -  As you can see, it completely eliminates the need to mess with codecs.-  The quasiquoters directly produce `Statement`,-  which you can then `Data.Profunctor.dimap` over using its `Data.Profunctor.Profunctor` instance to get to your domain types.-  -  == Type mappings-  -  === Primitives-  -  Following is a list of supported Postgres types and their according types on the Haskell end.--  - @bool@ - `Bool`-  - @int2@ - `Int16`-  - @int4@ - `Int32`-  - @int8@ - `Int64`-  - @float4@ - `Float`-  - @float8@ - `Double`-  - @numeric@ - `Data.Scientific.Scientific`-  - @char@ - `Char`-  - @text@ - `Data.Text.Text`-  - @bytea@ - `Data.ByteString.ByteString`-  - @date@ - `Data.Time.Day`-  - @timestamp@ - `Data.Time.LocalTime`-  - @timestamptz@ - `Data.Time.UTCTime`-  - @time@ - `Data.Time.TimeOfDay`-  - @timetz@ - @(`Data.Time.TimeOfDay`, `Data.Time.TimeZone`)@-  - @interval@ - `Data.Time.DiffTime`-  - @uuid@ - `Data.UUID.UUID`-  - @inet@ - @(`Network.IP.Addr.NetAddr` `Network.IP.Addr.IP`)@-  - @json@ - `Data.Aeson.Value`-  - @jsonb@ - `Data.Aeson.Value`-  -  === Arrays--  Array mappings are also supported.-  They are specified according to Postgres syntax: by appending one or more @[]@ to the primitive type,-  depending on how many dimensions the array has.-  On the Haskell end array is mapped to generic `Data.Vector.Generic.Vector`,-  allowing you to choose which particular vector implementation to map to.--  === Nulls--  As you might have noticed in the example,-  we introduce one change to the Postgres syntax in the way-  the typesignatures are parsed:-  we interpret question-marks in them as specification of nullability.-  Here's more examples of that:+  ( -- * Statements -  >>> :t [singletonStatement| select a :: int4? |]-  ...-    :: Statement () (Maybe Int32)-  -  You can use it to specify the nullability of array elements:+    -- |+    --  Quasiquoters in this category produce Hasql `Statement`s,+    --  checking the correctness of SQL at compile-time.+    --+    --  To extract the information about parameters and results of the statement,+    --  the quoter requires you to explicitly specify the Postgres types for placeholders and results.+    --+    --  Here's an example of how to use it:+    --+    --  >selectUserDetails :: Statement Int32 (Maybe (Text, Text, Maybe Text))+    --  >selectUserDetails =+    --  >  [maybeStatement|+    --  >    select name :: text, email :: text, phone :: text?+    --  >    from "user"+    --  >    where id = $1 :: int4+    --  >    |]+    --+    --  As you can see, it completely eliminates the need to mess with codecs.+    --  The quasiquoters directly produce `Statement`,+    --  which you can then `Data.Profunctor.dimap` over using its `Data.Profunctor.Profunctor` instance to get to your domain types.+    --+    --  == Type mappings+    --+    --  === Primitives+    --+    --  Following is a list of supported Postgres types and their according types on the Haskell end.+    --+    --  - @bool@ - `Bool`+    --  - @int2@ - `Int16`+    --  - @int4@ - `Int32`+    --  - @int8@ - `Int64`+    --  - @float4@ - `Float`+    --  - @float8@ - `Double`+    --  - @numeric@ - `Data.Scientific.Scientific`+    --  - @char@ - `Char`+    --  - @text@ - `Data.Text.Text`+    --  - @bytea@ - `Data.ByteString.ByteString`+    --  - @date@ - `Data.Time.Day`+    --  - @timestamp@ - `Data.Time.LocalTime`+    --  - @timestamptz@ - `Data.Time.UTCTime`+    --  - @time@ - `Data.Time.TimeOfDay`+    --  - @timetz@ - @(`Data.Time.TimeOfDay`, `Data.Time.TimeZone`)@+    --  - @interval@ - `Data.Time.DiffTime`+    --  - @uuid@ - `Data.UUID.UUID`+    --  - @inet@ - @(`Network.IP.Addr.NetAddr` `Network.IP.Addr.IP`)@+    --  - @json@ - `Data.Aeson.Value`+    --  - @jsonb@ - `Data.Aeson.Value`+    --+    --  === Arrays+    --+    --  Array mappings are also supported.+    --  They are specified according to Postgres syntax: by appending one or more @[]@ to the primitive type,+    --  depending on how many dimensions the array has.+    --  On the Haskell end array is mapped to generic `Data.Vector.Generic.Vector`,+    --  allowing you to choose which particular vector implementation to map to.+    --+    --  === Nulls+    --+    --  As you might have noticed in the example,+    --  we introduce one change to the Postgres syntax in the way+    --  the typesignatures are parsed:+    --  we interpret question-marks in them as specification of nullability.+    --  Here's more examples of that:+    --+    --  >>> :t [singletonStatement| select a :: int4? |]+    --  ...+    --    :: Statement () (Maybe Int32)+    --+    --  You can use it to specify the nullability of array elements:+    --+    --  >>> :t [singletonStatement| select a :: int4?[] |]+    --  ...+    --    :: Data.Vector.Generic.Base.Vector v (Maybe Int32) =>+    --       Statement () (v (Maybe Int32))+    --+    --  And of arrays themselves:+    --+    --  >>> :t [singletonStatement| select a :: int4?[]? |]+    --  ...+    --    :: Data.Vector.Generic.Base.Vector v (Maybe Int32) =>+    --       Statement () (Maybe (v (Maybe Int32))) -  >>> :t [singletonStatement| select a :: int4?[] |]-  ...-    :: Data.Vector.Generic.Base.Vector v (Maybe Int32) =>-       Statement () (v (Maybe Int32))+    -- ** Row-parsing statements+    singletonStatement,+    maybeStatement,+    vectorStatement,+    foldStatement, -  And of arrays themselves:+    -- ** Row-ignoring statements+    resultlessStatement,+    rowsAffectedStatement, -  >>> :t [singletonStatement| select a :: int4?[]? |]-  ...-    :: Data.Vector.Generic.Base.Vector v (Maybe Int32) =>-       Statement () (Maybe (v (Maybe Int32)))-  -}-  -- ** Row-parsing statements-  singletonStatement,-  maybeStatement,-  vectorStatement,-  foldStatement,-  -- ** Row-ignoring statements-  resultlessStatement,-  rowsAffectedStatement,-  -- * SQL ByteStrings-  {-|-  ByteString-producing quasiquoters.+    -- * SQL ByteStrings -  For now they perform no compile-time checking.-  -}-  uncheckedSql,-  uncheckedSqlFile,-)+    -- |+    --  ByteString-producing quasiquoters.+    --+    --  For now they perform no compile-time checking.+    uncheckedSql,+    uncheckedSqlFile,+  ) where -import Hasql.TH.Prelude hiding (exp)-import Hasql.Statement (Statement)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text import Data.Vector (Vector)-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote+import Hasql.Statement (Statement) import qualified Hasql.TH.Construction.Exp as Exp import qualified Hasql.TH.Extraction.Exp as ExpExtraction-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text+import Hasql.TH.Prelude hiding (exp)+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax import qualified PostgresqlSyntax.Ast as Ast import qualified PostgresqlSyntax.Parsing as Parsing - -- * Helpers--------------------------  exp :: (String -> Q Exp) -> QuasiQuoter-exp = let-  _unsupported _ = fail "Unsupported"-  in \ _exp -> QuasiQuoter _exp _unsupported _unsupported _unsupported+exp =+  let _unsupported _ = fail "Unsupported"+   in \_exp -> QuasiQuoter _exp _unsupported _unsupported _unsupported  expParser :: (Text -> Either Text Exp) -> QuasiQuoter expParser _parser =-  exp $ \ _inputString -> either (fail . Text.unpack) return $ _parser $ fromString _inputString+  exp $ \_inputString -> either (fail . Text.unpack) return $ _parser $ fromString _inputString  expPreparableStmtAstParser :: (Ast.PreparableStmt -> Either Text Exp) -> QuasiQuoter expPreparableStmtAstParser _parser =-  expParser $ \ _input -> do+  expParser $ \_input -> do     _ast <- first fromString $ Parsing.run (Parsing.atEnd Parsing.preparableStmt) _input     _parser _ast - -- * Statement-------------------------- -{-|-@-:: `Statement` params row-@--Statement producing exactly one result row.--Will cause the running session to fail with the-`Hasql.Session.UnexpectedAmountOfRows` error if it's any other.--=== __Examples__-->>> :t [singletonStatement|select 1 :: int2|]-... :: Statement () Int16-->>> :{-  :t [singletonStatement|-       insert into "user" (email, name)-       values ($1 :: text, $2 :: text)-       returning id :: int4-       |]-:}-...-... :: Statement (Text, Text) Int32--Incorrect SQL:-->>> :t [singletonStatement|elect 1|]-...-  |-1 | elect 1-  |      ^-...--}+-- |+-- @+-- :: `Statement` params row+-- @+--+-- Statement producing exactly one result row.+--+-- Will cause the running session to fail with the+-- `Hasql.Session.UnexpectedAmountOfRows` error if it's any other.+--+-- === __Examples__+--+-- >>> :t [singletonStatement|select 1 :: int2|]+-- ... :: Statement () Int16+--+-- >>> :{+--   :t [singletonStatement|+--        insert into "user" (email, name)+--        values ($1 :: text, $2 :: text)+--        returning id :: int4+--        |]+-- :}+-- ...+-- ... :: Statement (Text, Text) Int32+--+-- Incorrect SQL:+--+-- >>> :t [singletonStatement|elect 1|]+-- ...+--   |+-- 1 | elect 1+--   |      ^+-- ... singletonStatement :: QuasiQuoter singletonStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.singleRowResultDecoder) -{-|-@-:: `Statement` params (Maybe row)-@--Statement producing one row or none.--=== __Examples__-->>> :t [maybeStatement|select 1 :: int2|]-... :: Statement () (Maybe Int16)--}+-- |+-- @+-- :: `Statement` params (Maybe row)+-- @+--+-- Statement producing one row or none.+--+-- === __Examples__+--+-- >>> :t [maybeStatement|select 1 :: int2|]+-- ... :: Statement () (Maybe Int16) maybeStatement :: QuasiQuoter maybeStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.rowMaybeResultDecoder) -{-|-@-:: `Statement` params (`Vector` row)-@--Statement producing a vector of rows.--=== __Examples__-->>> :t [vectorStatement|select 1 :: int2|]-... :: Statement () (Vector Int16)--}+-- |+-- @+-- :: `Statement` params (`Vector` row)+-- @+--+-- Statement producing a vector of rows.+--+-- === __Examples__+--+-- >>> :t [vectorStatement|select 1 :: int2|]+-- ... :: Statement () (Vector Int16) vectorStatement :: QuasiQuoter vectorStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.rowVectorResultDecoder) -{-|-@-:: `Fold` row folding -> `Statement` params folding-@--Function from `Fold` over rows to a statement producing the result of folding.-Use this when you need to aggregate rows customly.--=== __Examples__-->>> :t [foldStatement|select 1 :: int2|]-... :: Fold Int16 b -> Statement () b--}+-- |+-- @+-- :: `Fold` row folding -> `Statement` params folding+-- @+--+-- Function from `Fold` over rows to a statement producing the result of folding.+-- Use this when you need to aggregate rows customly.+--+-- === __Examples__+--+-- >>> :t [foldStatement|select 1 :: int2|]+-- ... :: Fold Int16 b -> Statement () b foldStatement :: QuasiQuoter foldStatement = expPreparableStmtAstParser ExpExtraction.foldStatement -{-|-@-:: `Statement` params ()-@--Statement producing no results.--=== __Examples__-->>> :t [resultlessStatement|insert into "user" (name, email) values ($1 :: text, $2 :: text)|]-...-... :: Statement (Text, Text) ()--}+-- |+-- @+-- :: `Statement` params ()+-- @+--+-- Statement producing no results.+--+-- === __Examples__+--+-- >>> :t [resultlessStatement|insert into "user" (name, email) values ($1 :: text, $2 :: text)|]+-- ...+-- ... :: Statement (Text, Text) () resultlessStatement :: QuasiQuoter resultlessStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement (const Exp.noResultResultDecoder)) -{-|-@-:: `Statement` params Int64-@--Statement counting the rows it affects.--=== __Examples__-->>> :t [rowsAffectedStatement|delete from "user" where password is null|]-...-... :: Statement () Int64--}+-- |+-- @+-- :: `Statement` params Int64+-- @+--+-- Statement counting the rows it affects.+--+-- === __Examples__+--+-- >>> :t [rowsAffectedStatement|delete from "user" where password is null|]+-- ...+-- ... :: Statement () Int64 rowsAffectedStatement :: QuasiQuoter rowsAffectedStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement (const Exp.rowsAffectedResultDecoder)) - -- * SQL ByteStrings-------------------------- -{-|-Quoter of a multiline Unicode SQL string,-which gets converted into a format ready to be used for declaration of statements.--}+-- |+-- Quoter of a multiline Unicode SQL string,+-- which gets converted into a format ready to be used for declaration of statements. uncheckedSql :: QuasiQuoter uncheckedSql = exp $ return . Exp.byteString . Text.encodeUtf8 . fromString -{-|-Read an SQL-file, containing multiple statements,-and produce an expression of type `ByteString`.--Allows to store plain SQL in external files and read it at compile time.--E.g.,-->migration1 :: Hasql.Session.Session ()->migration1 = Hasql.Session.sql [uncheckedSqlFile|migrations/1.sql|]--}+-- |+-- Read an SQL-file, containing multiple statements,+-- and produce an expression of type `ByteString`.+--+-- Allows to store plain SQL in external files and read it at compile time.+--+-- E.g.,+--+-- >migration1 :: Hasql.Session.Session ()+-- >migration1 = Hasql.Session.sql [uncheckedSqlFile|migrations/1.sql|] uncheckedSqlFile :: QuasiQuoter uncheckedSqlFile = quoteFile uncheckedSql - -- * Tests-------------------------- -{- $->>> :t [maybeStatement| select (password = $2 :: bytea) :: bool, id :: int4 from "user" where "email" = $1 :: text |]-...-... Statement (Text, ByteString) (Maybe (Bool, Int32))-->>> :t [maybeStatement| select id :: int4 from application where pub_key = $1 :: uuid and sec_key_pt1 = $2 :: int8 and sec_key_pt2 = $3 :: int8 |]-...-... Statement (UUID, Int64, Int64) (Maybe Int32)-->>> :t [singletonStatement| select 1 :: int4 from a left join b on b.id = a.id |]-...-... Statement () Int32--}+-- $+-- >>> :t [maybeStatement| select (password = $2 :: bytea) :: bool, id :: int4 from "user" where "email" = $1 :: text |]+-- ...+-- ... Statement (Text, ByteString) (Maybe (Bool, Int32))+--+-- >>> :t [maybeStatement| select id :: int4 from application where pub_key = $1 :: uuid and sec_key_pt1 = $2 :: int8 and sec_key_pt2 = $3 :: int8 |]+-- ...+-- ... Statement (UUID, Int64, Int64) (Maybe Int32)+--+-- >>> :t [singletonStatement| select 1 :: int4 from a left join b on b.id = a.id |]+-- ...+-- ... Statement () Int32
library/Hasql/TH/Construction/Exp.hs view
@@ -1,36 +1,31 @@-{-|-Expression construction.--}+-- |+-- Expression construction. module Hasql.TH.Construction.Exp where -import Hasql.TH.Prelude hiding (sequence_, string, list)-import Language.Haskell.TH.Syntax-import qualified Hasql.TH.Prelude as Prelude-import qualified Hasql.Encoders as Encoders-import qualified Hasql.Decoders as Decoders-import qualified Hasql.Statement as Statement import qualified Data.ByteString as ByteString import qualified Data.ByteString.Unsafe as ByteString import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Vector.Generic as Vector+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Statement as Statement+import Hasql.TH.Prelude hiding (list, sequence_, string)+import qualified Hasql.TH.Prelude as Prelude+import Language.Haskell.TH.Syntax import qualified TemplateHaskell.Compat.V0208 as Compat - -- * Helpers--------------------------  appList :: Exp -> [Exp] -> Exp-appList = foldl' AppE +appList = foldl' AppE  byteString :: ByteString -> Exp byteString x =   appList     (VarE 'unsafeDupablePerformIO)-    [-      appList+    [ appList         (VarE 'ByteString.unsafePackAddressLen)-        [-          LitE (IntegerL (fromIntegral (ByteString.length x))),+        [ LitE (IntegerL (fromIntegral (ByteString.length x))),           LitE (StringPrimL (ByteString.unpack x))         ]     ]@@ -60,76 +55,73 @@ tuple = ConE . tupleDataName  splitTupleAt :: Int -> Int -> Exp-splitTupleAt arity position = let-  nameByIndex index = Name (OccName ('_' : show index)) NameS-  names = enumFromTo 0 (pred arity) & map nameByIndex-  pats = names & map VarP-  pat = TupP pats-  exps = names & map VarE-  body = splitAt position exps & \ (a, b) -> Compat.tupE [Compat.tupE a, Compat.tupE b]-  in LamE [pat] body+splitTupleAt arity position =+  let nameByIndex index = Name (OccName ('_' : show index)) NameS+      names = enumFromTo 0 (pred arity) & map nameByIndex+      pats = names & map VarP+      pat = TupP pats+      exps = names & map VarE+      body = splitAt position exps & \(a, b) -> Compat.tupE [Compat.tupE a, Compat.tupE b]+   in LamE [pat] body -{-|-Given a list of divisible functor expressions,-constructs an expression, which composes them together into-a single divisible functor, parameterized by a tuple of according arity.--}+-- |+-- Given a list of divisible functor expressions,+-- constructs an expression, which composes them together into+-- a single divisible functor, parameterized by a tuple of according arity. contrazip :: [Exp] -> Exp-contrazip = \ case+contrazip = \case   _head : [] -> _head   _head : _tail -> appList (VarE 'divide) [splitTupleAt (succ (length _tail)) 1, _head, contrazip _tail]-  [] -> SigE (VarE 'conquer)-    (let-      _fName = mkName "f"-      _fVar = VarT _fName-      in ForallT [PlainTV _fName] [AppT (ConT ''Divisible) (VarT _fName)]-          (AppT (VarT _fName) (TupleT 0)))--{-|-Given a list of applicative functor expressions,-constructs an expression, which composes them together into-a single applicative functor, parameterized by a tuple of according arity.-->>> $(return (cozip [])) :: Maybe ()-Just ()+  [] ->+    SigE+      (VarE 'conquer)+      ( let _fName = mkName "f"+            _fVar = VarT _fName+         in ForallT+              [Compat.specifiedPlainTV _fName]+              [AppT (ConT ''Divisible) (VarT _fName)]+              (AppT (VarT _fName) (TupleT 0))+      ) ->>> $(return (cozip (fmap (AppE (ConE 'Just) . LitE . IntegerL) [1,2,3]))) :: Maybe (Int, Int, Int)-Just (1,2,3)--}+-- |+-- Given a list of applicative functor expressions,+-- constructs an expression, which composes them together into+-- a single applicative functor, parameterized by a tuple of according arity.+--+-- >>> $(return (cozip [])) :: Maybe ()+-- Just ()+--+-- >>> $(return (cozip (fmap (AppE (ConE 'Just) . LitE . IntegerL) [1,2,3]))) :: Maybe (Int, Int, Int)+-- Just (1,2,3) cozip :: [Exp] -> Exp-cozip = \ case+cozip = \case   _head : [] -> _head-  _head : _tail -> let-    _length = length _tail + 1-    in-      foldl' (\ a b -> AppE (AppE (VarE '(<*>)) a) b)-        (AppE (AppE (VarE 'fmap) (tuple _length)) _head)-        _tail+  _head : _tail ->+    let _length = length _tail + 1+     in foldl'+          (\a b -> AppE (AppE (VarE '(<*>)) a) b)+          (AppE (AppE (VarE 'fmap) (tuple _length)) _head)+          _tail   [] -> AppE (VarE 'pure) (TupE []) -{-|-Lambda expression, which destructures 'Fold'.--}+-- |+-- Lambda expression, which destructures 'Fold'. foldLam :: (Exp -> Exp -> Exp -> Exp) -> Exp-foldLam _body = let-  _stepVarName = mkName "step"-  _initVarName = mkName "init"-  _extractVarName = mkName "extract"-  in-    LamE-      [-        ConP 'Fold-          [-            VarP _stepVarName,-            VarP _initVarName,-            VarP _extractVarName-          ]-      ]-      (_body (VarE _stepVarName) (VarE _initVarName) (VarE _extractVarName))-+foldLam _body =+  let _stepVarName = mkName "step"+      _initVarName = mkName "init"+      _extractVarName = mkName "extract"+   in LamE+        [ Compat.conp+            'Fold+            [ VarP _stepVarName,+              VarP _initVarName,+              VarP _extractVarName+            ]+        ]+        (_body (VarE _stepVarName) (VarE _initVarName) (VarE _extractVarName))  -- * Statement--------------------------  statement :: Exp -> Exp -> Exp -> Exp statement _sql _encoder _decoder =@@ -152,7 +144,7 @@  foldStatement :: Exp -> Exp -> Exp -> Exp foldStatement _sql _encoder _rowDecoder =-  foldLam (\ _step _init _extract -> statement _sql _encoder (foldResultDecoder _step _init _extract _rowDecoder))+  foldLam (\_step _init _extract -> statement _sql _encoder (foldResultDecoder _step _init _extract _rowDecoder))  foldResultDecoder :: Exp -> Exp -> Exp -> Exp -> Exp foldResultDecoder _step _init _extract _rowDecoder =@@ -164,8 +156,9 @@  multidimensionalParamEncoder :: Bool -> Int -> Bool -> Exp -> Exp multidimensionalParamEncoder nullable dimensionality arrayNull =-  applyParamToEncoder . applyNullabilityToEncoder arrayNull . AppE (VarE 'Encoders.array) .-  applyArrayDimensionalityToEncoder dimensionality . applyNullabilityToEncoder nullable+  applyParamToEncoder . applyNullabilityToEncoder arrayNull . AppE (VarE 'Encoders.array)+    . applyArrayDimensionalityToEncoder dimensionality+    . applyNullabilityToEncoder nullable  applyParamToEncoder :: Exp -> Exp applyParamToEncoder = AppE (VarE 'Encoders.param)@@ -188,8 +181,9 @@  multidimensionalColumnDecoder :: Bool -> Int -> Bool -> Exp -> Exp multidimensionalColumnDecoder nullable dimensionality arrayNull =-  applyColumnToDecoder . applyNullabilityToDecoder arrayNull . AppE (VarE 'Decoders.array) .-  applyArrayDimensionalityToDecoder dimensionality . applyNullabilityToDecoder nullable+  applyColumnToDecoder . applyNullabilityToDecoder arrayNull . AppE (VarE 'Decoders.array)+    . applyArrayDimensionalityToDecoder dimensionality+    . applyNullabilityToDecoder nullable  applyColumnToDecoder :: Exp -> Exp applyColumnToDecoder = AppE (VarE 'Decoders.column)
library/Hasql/TH/Extraction/ChildExprList.hs view
@@ -1,28 +1,23 @@ module Hasql.TH.Extraction.ChildExprList where -import Hasql.TH.Prelude hiding (sortBy, bit, fromList)+import Hasql.TH.Prelude hiding (bit, fromList, sortBy) import PostgresqlSyntax.Ast - -- * Types--------------------------  data ChildExpr = AChildExpr AExpr | BChildExpr BExpr | CChildExpr CExpr   deriving (Show, Eq, Ord) - -- *-------------------------- -{-|-Dives one level of recursion.--}-childExpr = \ case+-- |+-- Dives one level of recursion.+childExpr = \case   AChildExpr a -> aChildExpr a   BChildExpr a -> bChildExpr a   CChildExpr a -> cChildExpr a -aChildExpr = \ case+aChildExpr = \case   CExprAExpr a -> cChildExpr a   TypecastAExpr a b -> aExpr a <> typename b   CollateAExpr a b -> aExpr a <> anyName b@@ -44,7 +39,7 @@   UniqueAExpr a -> selectWithParens a   DefaultAExpr -> [] -bChildExpr = \ case+bChildExpr = \case   CExprBExpr a -> cChildExpr a   TypecastBExpr a b -> bExpr a <> typename b   PlusBExpr a -> bExpr a@@ -53,7 +48,7 @@   QualOpBExpr a b -> qualOp a <> bExpr b   IsOpBExpr a b c -> bExpr a <> bExprIsOp c -cChildExpr = \ case+cChildExpr = \case   ColumnrefCExpr a -> columnref a   AexprConstCExpr a -> aexprConst a   ParamCExpr a b -> foldMap indirection b@@ -67,30 +62,26 @@   ImplicitRowCExpr a -> implicitRow a   GroupingCExpr a -> exprList a - -- *-------------------------- -preparableStmt = \ case+preparableStmt = \case   SelectPreparableStmt a -> selectStmt a   InsertPreparableStmt a -> insertStmt a   UpdatePreparableStmt a -> updateStmt a   DeletePreparableStmt a -> deleteStmt a - -- * Insert--------------------------  insertStmt (InsertStmt a b c d e) =-  foldMap withClause a <>-  insertTarget b <>-  insertRest c <>-  foldMap onConflict d <>-  foldMap returningClause e+  foldMap withClause a+    <> insertTarget b+    <> insertRest c+    <> foldMap onConflict d+    <> foldMap returningClause e  insertTarget (InsertTarget a b) = qualifiedName a <> colId b -insertRest = \ case+insertRest = \case   SelectInsertRest a b c -> foldMap insertColumnList a <> foldMap overrideKind b <> selectStmt c   DefaultValuesInsertRest -> [] @@ -102,31 +93,29 @@  onConflict (OnConflict a b) = foldMap confExpr a <> onConflictDo b -onConflictDo = \ case+onConflictDo = \case   UpdateOnConflictDo b c -> setClauseList b <> foldMap whereClause c   NothingOnConflictDo -> [] -confExpr = \ case+confExpr = \case   WhereConfExpr a b -> indexParams a <> foldMap whereClause b   ConstraintConfExpr a -> name a  returningClause = targetList - -- * Update--------------------------  updateStmt (UpdateStmt a b c d e f) =-  foldMap withClause a <>-  relationExprOptAlias b <>-  setClauseList c <>-  foldMap fromClause d <>-  foldMap whereOrCurrentClause e <>-  foldMap returningClause f+  foldMap withClause a+    <> relationExprOptAlias b+    <> setClauseList c+    <> foldMap fromClause d+    <> foldMap whereOrCurrentClause e+    <> foldMap returningClause f  setClauseList = foldMap setClause -setClause = \ case+setClause = \case   TargetSetClause a b -> setTarget a <> aExpr b   TargetListSetClause a b -> setTargetList a <> aExpr b @@ -134,35 +123,31 @@  setTargetList = foldMap setTarget - -- * Delete--------------------------  deleteStmt (DeleteStmt a b c d e) =-  foldMap withClause a <>-  relationExprOptAlias b <>-  foldMap usingClause c <>-  foldMap whereOrCurrentClause d <>-  foldMap returningClause e+  foldMap withClause a+    <> relationExprOptAlias b+    <> foldMap usingClause c+    <> foldMap whereOrCurrentClause d+    <> foldMap returningClause e  usingClause = fromList - -- * Select-------------------------- -selectStmt = \ case+selectStmt = \case   Left a -> selectNoParens a   Right a -> selectWithParens a  selectNoParens (SelectNoParens a b c d e) =-  foldMap withClause a <>-  selectClause b <>-  foldMap sortClause c <>-  foldMap selectLimit d <>-  foldMap forLockingClause e+  foldMap withClause a+    <> selectClause b+    <> foldMap sortClause c+    <> foldMap selectLimit d+    <> foldMap forLockingClause e -selectWithParens = \ case+selectWithParens = \case   NoParensSelectWithParens a -> selectNoParens a   WithParensSelectWithParens a -> selectWithParens a @@ -170,29 +155,29 @@  commonTableExpr (CommonTableExpr a b c d) = preparableStmt d -selectLimit = \ case+selectLimit = \case   LimitOffsetSelectLimit a b -> limitClause a <> offsetClause b   OffsetLimitSelectLimit a b -> offsetClause a <> limitClause b   LimitSelectLimit a -> limitClause a   OffsetSelectLimit a -> offsetClause a -limitClause = \ case+limitClause = \case   LimitLimitClause a b -> selectLimitValue a <> exprList b   FetchOnlyLimitClause a b c -> foldMap selectFetchFirstValue b -offsetClause = \ case+offsetClause = \case   ExprOffsetClause a -> aExpr a   FetchFirstOffsetClause a b -> selectFetchFirstValue a -selectFetchFirstValue = \ case+selectFetchFirstValue = \case   ExprSelectFetchFirstValue a -> cExpr a   NumSelectFetchFirstValue _ _ -> [] -selectLimitValue = \ case+selectLimitValue = \case   ExprSelectLimitValue a -> aExpr a   AllSelectLimitValue -> [] -forLockingClause = \ case+forLockingClause = \case   ItemsForLockingClause a -> foldMap forLockingItem a   ReadOnlyForLockingClause -> [] @@ -201,23 +186,25 @@  selectClause = either simpleSelect selectWithParens -simpleSelect = \ case+simpleSelect = \case   NormalSimpleSelect a b c d e f g ->-    foldMap targeting a <> foldMap intoClause b <> foldMap fromClause c <>-    foldMap whereClause d <> foldMap groupClause e <> foldMap havingClause f <>-    foldMap windowClause g+    foldMap targeting a <> foldMap intoClause b <> foldMap fromClause c+      <> foldMap whereClause d+      <> foldMap groupClause e+      <> foldMap havingClause f+      <> foldMap windowClause g   ValuesSimpleSelect a -> valuesClause a   TableSimpleSelect a -> relationExpr a   BinSimpleSelect _ a _ b -> selectClause a <> selectClause b -targeting = \ case+targeting = \case   NormalTargeting a -> foldMap targetEl a   AllTargeting a -> foldMap (foldMap targetEl) a   DistinctTargeting a b -> foldMap exprList a <> foldMap targetEl b  targetList = foldMap targetEl -targetEl = \ case+targetEl = \case   AliasedExprTargetEl a _ -> aExpr a   ImplicitlyAliasedExprTargetEl a _ -> aExpr a   ExprTargetEl a -> aExpr a@@ -231,7 +218,7 @@  whereClause = aExpr -whereOrCurrentClause = \ case+whereOrCurrentClause = \case   ExprWhereOrCurrentClause a -> aExpr a   CursorWhereOrCurrentClause a -> cursorName a @@ -245,7 +232,7 @@  optTempTableName _ = [] -groupByItem = \ case+groupByItem = \case   ExprGroupByItem a -> aExpr a   EmptyGroupingSetGroupByItem -> []   RollupGroupByItem a -> exprList a@@ -258,11 +245,11 @@  frameClause (FrameClause _ a _) = frameExtent a -frameExtent = \ case+frameExtent = \case   SingularFrameExtent a -> frameBound a   BetweenFrameExtent a b -> frameBound a <> frameBound b -frameBound = \ case+frameBound = \case   UnboundedPrecedingFrameBound -> []   UnboundedFollowingFrameBound -> []   CurrentRowFrameBound -> []@@ -271,21 +258,19 @@  sortClause = foldMap sortBy -sortBy = \ case+sortBy = \case   UsingSortBy a b c -> aExpr a <> qualAllOp b <> foldMap nullsOrder c   AscDescSortBy a b c -> aExpr a <> foldMap ascDesc b <> foldMap nullsOrder c - -- * Table refs-------------------------- -tableRef = \ case+tableRef = \case   RelationExprTableRef a b c -> relationExpr a <> foldMap aliasClause b <> foldMap tablesampleClause c   FuncTableRef a b c -> funcTable b <> foldMap funcAliasClause c   SelectTableRef _ a _ -> selectWithParens a   JoinTableRef a _ -> joinedTable a -relationExpr = \ case+relationExpr = \case   SimpleRelationExpr a _ -> qualifiedName a   OnlyRelationExpr a _ -> qualifiedName a @@ -295,7 +280,7 @@  repeatableClause = aExpr -funcTable = \ case+funcTable = \case   FuncExprFuncTable a b -> funcExprWindowless a <> optOrdinality b   RowsFromFuncTable a b -> rowsfromList a <> optOrdinality b @@ -315,40 +300,40 @@  aliasClause = const [] -funcAliasClause = \ case+funcAliasClause = \case   AliasFuncAliasClause a -> aliasClause a   AsFuncAliasClause a -> tableFuncElementList a   AsColIdFuncAliasClause a b -> colId a <> tableFuncElementList b   ColIdFuncAliasClause a b -> colId a <> tableFuncElementList b -joinedTable = \ case+joinedTable = \case   InParensJoinedTable a -> joinedTable a   MethJoinedTable a b c -> joinMeth a <> tableRef b <> tableRef c -joinMeth = \ case+joinMeth = \case   CrossJoinMeth -> []   QualJoinMeth _ a -> joinQual a   NaturalJoinMeth _ -> [] -joinQual = \ case+joinQual = \case   UsingJoinQual _ -> []   OnJoinQual a -> aExpr a - -- *--------------------------  exprList = fmap AChildExpr . toList  aExpr = pure . AChildExpr+ bExpr = pure . BChildExpr+ cExpr = pure . CChildExpr -funcExpr = \ case+funcExpr = \case   ApplicationFuncExpr a b c d -> funcApplication a <> foldMap withinGroupClause b <> foldMap filterClause c <> foldMap overClause d   SubexprFuncExpr a -> funcExprCommonSubexpr a -funcExprWindowless = \ case+funcExprWindowless = \case   ApplicationFuncExprWindowless a -> funcApplication a   CommonSubexprFuncExprWindowless a -> funcExprCommonSubexpr a @@ -356,11 +341,11 @@  filterClause a = aExpr a -overClause = \ case+overClause = \case   WindowOverClause a -> windowSpecification a   ColIdOverClause _ -> [] -funcExprCommonSubexpr = \ case+funcExprCommonSubexpr = \case   CollationForFuncExprCommonSubexpr a -> aExpr a   CurrentDateFuncExprCommonSubexpr -> []   CurrentTimeFuncExprCommonSubexpr _ -> []@@ -393,11 +378,11 @@  positionList (PositionList a b) = bExpr a <> bExpr b -substrList = \ case+substrList = \case   ExprSubstrList a b -> aExpr a <> substrListFromFor b   ExprListSubstrList a -> exprList a -substrListFromFor = \ case+substrListFromFor = \case   FromForSubstrListFromFor a b -> aExpr a <> aExpr b   ForFromSubstrListFromFor a b -> aExpr a <> aExpr b   FromSubstrListFromFor a -> aExpr a@@ -405,21 +390,21 @@  trimModifier _ = [] -trimList = \ case+trimList = \case   ExprFromExprListTrimList a b -> aExpr a <> exprList b   FromExprListTrimList a -> exprList a-  ExprListTrimList a -> exprList a  +  ExprListTrimList a -> exprList a  whenClause (WhenClause a b) = aExpr a <> aExpr b  funcApplication (FuncApplication a b) = funcName a <> foldMap funcApplicationParams b -funcApplicationParams = \ case+funcApplicationParams = \case   NormalFuncApplicationParams _ a b -> foldMap funcArgExpr a <> foldMap (foldMap sortBy) b   VariadicFuncApplicationParams a b c -> foldMap (foldMap funcArgExpr) a <> funcArgExpr b <> foldMap (foldMap sortBy) c   StarFuncApplicationParams -> [] -funcArgExpr = \ case+funcArgExpr = \case   ExprFuncArgExpr a -> aExpr a   ColonEqualsFuncArgExpr _ a -> aExpr a   EqualsGreaterFuncArgExpr _ a -> aExpr a@@ -428,36 +413,34 @@  whenClauseList = foldMap whenClause -arrayExpr = \ case+arrayExpr = \case   ExprListArrayExpr a -> exprList a   ArrayExprListArrayExpr a -> arrayExprList a   EmptyArrayExpr -> []  arrayExprList = foldMap arrayExpr -inExpr = \ case+inExpr = \case   SelectInExpr a -> selectWithParens a   ExprListInExpr a -> exprList a - -- * Operators-------------------------- -symbolicExprBinOp = \ case+symbolicExprBinOp = \case   MathSymbolicExprBinOp a -> mathOp a   QualSymbolicExprBinOp a -> qualOp a -qualOp = \ case+qualOp = \case   OpQualOp a -> op a   OperatorQualOp a -> anyOperator a -qualAllOp = \ case+qualAllOp = \case   AllQualAllOp a -> allOp a   AnyQualAllOp a -> anyOperator a  verbalExprBinOp = const [] -aExprReversableOp = \ case+aExprReversableOp = \case   NullAExprReversableOp -> []   TrueAExprReversableOp -> []   FalseAExprReversableOp -> []@@ -469,22 +452,22 @@   InAExprReversableOp a -> inExpr a   DocumentAExprReversableOp -> [] -subqueryOp = \ case+subqueryOp = \case   AllSubqueryOp a -> allOp a   AnySubqueryOp a -> anyOperator a   LikeSubqueryOp _ -> []   IlikeSubqueryOp _ -> [] -bExprIsOp = \ case+bExprIsOp = \case   DistinctFromBExprIsOp a -> bExpr a   OfBExprIsOp a -> typeList a   DocumentBExprIsOp -> [] -allOp = \ case+allOp = \case   OpAllOp a -> op a   MathAllOp a -> mathOp a -anyOperator = \ case+anyOperator = \case   AllOpAnyOperator a -> allOp a   QualifiedAnyOperator a b -> colId a <> anyOperator b @@ -492,11 +475,9 @@  mathOp = const [] - -- * Rows-------------------------- -row = \ case+row = \case   ExplicitRowRow a -> explicitRow a   ImplicitRowRow a -> implicitRow a @@ -504,11 +485,9 @@  implicitRow (ImplicitRow a b) = exprList a <> aExpr b - -- * Constants-------------------------- -aexprConst = \ case+aexprConst = \case   IAexprConst _ -> []   FAexprConst _ -> []   SAexprConst _ -> []@@ -523,13 +502,13 @@  funcConstArgs (FuncConstArgs a b) = foldMap funcArgExpr a <> foldMap sortClause b -constTypename = \ case+constTypename = \case   NumericConstTypename a -> numeric a   ConstBitConstTypename a -> constBit a   ConstCharacterConstTypename a -> constCharacter a   ConstDatetimeConstTypename a -> constDatetime a -numeric = \ case+numeric = \case   IntNumeric -> []   IntegerNumeric -> []   SmallintNumeric -> []@@ -552,9 +531,7 @@  interval _ = [] - -- * Names--------------------------  ident _ = [] @@ -568,32 +545,30 @@  columnref (Columnref a b) = colId a <> foldMap indirection b -funcName = \ case+funcName = \case   TypeFuncName a -> typeFunctionName a   IndirectedFuncName a b -> colId a <> indirection b -qualifiedName = \ case+qualifiedName = \case   SimpleQualifiedName _ -> []   IndirectedQualifiedName _ a -> indirection a  indirection = foldMap indirectionEl -indirectionEl = \ case+indirectionEl = \case   AttrNameIndirectionEl _ -> []   AllIndirectionEl -> []   ExprIndirectionEl a -> aExpr a   SliceIndirectionEl a b -> exprList a <> exprList b - -- * Types--------------------------  typeList = foldMap typename  typename (Typename a b c d) =   simpleTypename b -simpleTypename = \ case+simpleTypename = \case   GenericTypeSimpleTypename a -> genericType a   NumericSimpleTypename a -> numeric a   BitSimpleTypename a -> bit a@@ -617,15 +592,13 @@  subType _ = [] - -- * Indexes--------------------------  indexParams = foldMap indexElem  indexElem (IndexElem a b c d e) = indexElemDef a <> foldMap anyName b <> foldMap anyName c -indexElemDef = \ case+indexElemDef = \case   IdIndexElemDef a -> colId a   FuncIndexElemDef a -> funcExprWindowless a   ExprIndexElemDef a -> aExpr a
library/Hasql/TH/Extraction/Exp.hs view
@@ -1,32 +1,31 @@ module Hasql.TH.Extraction.Exp where -import Hasql.TH.Prelude-import Language.Haskell.TH-import qualified Hasql.Encoders as Encoders import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders+import qualified Hasql.TH.Construction.Exp as Exp import qualified Hasql.TH.Extraction.InputTypeList as InputTypeList import qualified Hasql.TH.Extraction.OutputTypeList as OutputTypeList import qualified Hasql.TH.Extraction.PrimitiveType as PrimitiveType-import qualified Hasql.TH.Construction.Exp as Exp+import Hasql.TH.Prelude+import Language.Haskell.TH import qualified PostgresqlSyntax.Ast as Ast import qualified PostgresqlSyntax.Rendering as Rendering - undecodedStatement :: (Exp -> Exp) -> Ast.PreparableStmt -> Either Text Exp-undecodedStatement _decoderProj _ast = let-  _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast-  in do-    _encoder <- paramsEncoder _ast-    _rowDecoder <- rowDecoder _ast-    return (Exp.statement _sql _encoder (_decoderProj _rowDecoder))+undecodedStatement _decoderProj _ast =+  let _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast+   in do+        _encoder <- paramsEncoder _ast+        _rowDecoder <- rowDecoder _ast+        return (Exp.statement _sql _encoder (_decoderProj _rowDecoder))  foldStatement :: Ast.PreparableStmt -> Either Text Exp-foldStatement _ast = let-  _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast-  in do-    _encoder <- paramsEncoder _ast-    _rowDecoder <- rowDecoder _ast-    return (Exp.foldStatement _sql _encoder _rowDecoder)+foldStatement _ast =+  let _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast+   in do+        _encoder <- paramsEncoder _ast+        _rowDecoder <- rowDecoder _ast+        return (Exp.foldStatement _sql _encoder _rowDecoder)  paramsEncoder :: Ast.PreparableStmt -> Either Text Exp paramsEncoder a = do@@ -43,14 +42,14 @@ paramEncoder :: Ast.Typename -> Either Text Exp paramEncoder =   byTypename-    (\ a b -> valueEncoder a & fmap (Exp.unidimensionalParamEncoder b))-    (\ a b c d -> valueEncoder a & fmap (Exp.multidimensionalParamEncoder b c d))+    (\a b -> valueEncoder a & fmap (Exp.unidimensionalParamEncoder b))+    (\a b c d -> valueEncoder a & fmap (Exp.multidimensionalParamEncoder b c d))  columnDecoder :: Ast.Typename -> Either Text Exp columnDecoder =   byTypename-    (\ a b -> valueDecoder a & fmap (Exp.unidimensionalColumnDecoder b))-    (\ a b c d -> valueDecoder a & fmap (Exp.multidimensionalColumnDecoder b c d))+    (\a b -> valueDecoder a & fmap (Exp.unidimensionalColumnDecoder b))+    (\a b c d -> valueDecoder a & fmap (Exp.multidimensionalColumnDecoder b c d))  byTypename :: (PrimitiveType.PrimitiveType -> Bool -> Either Text Exp) -> (PrimitiveType.PrimitiveType -> Bool -> Int -> Bool -> Either Text Exp) -> Ast.Typename -> Either Text Exp byTypename unidimensional multidimensional (Ast.Typename a b c d) =@@ -65,47 +64,49 @@           Ast.ExplicitTypenameArrayDimensions _ -> multidimensional e c 1 g  valueEncoder :: PrimitiveType.PrimitiveType -> Either Text Exp-valueEncoder = Right . VarE . \ case-  PrimitiveType.BoolPrimitiveType -> 'Encoders.bool-  PrimitiveType.Int2PrimitiveType -> 'Encoders.int2-  PrimitiveType.Int4PrimitiveType -> 'Encoders.int4-  PrimitiveType.Int8PrimitiveType -> 'Encoders.int8-  PrimitiveType.Float4PrimitiveType -> 'Encoders.float4-  PrimitiveType.Float8PrimitiveType -> 'Encoders.float8-  PrimitiveType.NumericPrimitiveType -> 'Encoders.numeric-  PrimitiveType.CharPrimitiveType -> 'Encoders.char-  PrimitiveType.TextPrimitiveType -> 'Encoders.text-  PrimitiveType.ByteaPrimitiveType -> 'Encoders.bytea-  PrimitiveType.DatePrimitiveType -> 'Encoders.date-  PrimitiveType.TimestampPrimitiveType -> 'Encoders.timestamp-  PrimitiveType.TimestamptzPrimitiveType -> 'Encoders.timestamptz-  PrimitiveType.TimePrimitiveType -> 'Encoders.time-  PrimitiveType.TimetzPrimitiveType -> 'Encoders.timetz-  PrimitiveType.IntervalPrimitiveType -> 'Encoders.interval-  PrimitiveType.UuidPrimitiveType -> 'Encoders.uuid-  PrimitiveType.InetPrimitiveType -> 'Encoders.inet-  PrimitiveType.JsonPrimitiveType -> 'Encoders.json-  PrimitiveType.JsonbPrimitiveType -> 'Encoders.jsonb+valueEncoder =+  Right . VarE . \case+    PrimitiveType.BoolPrimitiveType -> 'Encoders.bool+    PrimitiveType.Int2PrimitiveType -> 'Encoders.int2+    PrimitiveType.Int4PrimitiveType -> 'Encoders.int4+    PrimitiveType.Int8PrimitiveType -> 'Encoders.int8+    PrimitiveType.Float4PrimitiveType -> 'Encoders.float4+    PrimitiveType.Float8PrimitiveType -> 'Encoders.float8+    PrimitiveType.NumericPrimitiveType -> 'Encoders.numeric+    PrimitiveType.CharPrimitiveType -> 'Encoders.char+    PrimitiveType.TextPrimitiveType -> 'Encoders.text+    PrimitiveType.ByteaPrimitiveType -> 'Encoders.bytea+    PrimitiveType.DatePrimitiveType -> 'Encoders.date+    PrimitiveType.TimestampPrimitiveType -> 'Encoders.timestamp+    PrimitiveType.TimestamptzPrimitiveType -> 'Encoders.timestamptz+    PrimitiveType.TimePrimitiveType -> 'Encoders.time+    PrimitiveType.TimetzPrimitiveType -> 'Encoders.timetz+    PrimitiveType.IntervalPrimitiveType -> 'Encoders.interval+    PrimitiveType.UuidPrimitiveType -> 'Encoders.uuid+    PrimitiveType.InetPrimitiveType -> 'Encoders.inet+    PrimitiveType.JsonPrimitiveType -> 'Encoders.json+    PrimitiveType.JsonbPrimitiveType -> 'Encoders.jsonb  valueDecoder :: PrimitiveType.PrimitiveType -> Either Text Exp-valueDecoder = Right . VarE . \ case-  PrimitiveType.BoolPrimitiveType -> 'Decoders.bool-  PrimitiveType.Int2PrimitiveType -> 'Decoders.int2-  PrimitiveType.Int4PrimitiveType -> 'Decoders.int4-  PrimitiveType.Int8PrimitiveType -> 'Decoders.int8-  PrimitiveType.Float4PrimitiveType -> 'Decoders.float4-  PrimitiveType.Float8PrimitiveType -> 'Decoders.float8-  PrimitiveType.NumericPrimitiveType -> 'Decoders.numeric-  PrimitiveType.CharPrimitiveType -> 'Decoders.char-  PrimitiveType.TextPrimitiveType -> 'Decoders.text-  PrimitiveType.ByteaPrimitiveType -> 'Decoders.bytea-  PrimitiveType.DatePrimitiveType -> 'Decoders.date-  PrimitiveType.TimestampPrimitiveType -> 'Decoders.timestamp-  PrimitiveType.TimestamptzPrimitiveType -> 'Decoders.timestamptz-  PrimitiveType.TimePrimitiveType -> 'Decoders.time-  PrimitiveType.TimetzPrimitiveType -> 'Decoders.timetz-  PrimitiveType.IntervalPrimitiveType -> 'Decoders.interval-  PrimitiveType.UuidPrimitiveType -> 'Decoders.uuid-  PrimitiveType.InetPrimitiveType -> 'Decoders.inet-  PrimitiveType.JsonPrimitiveType -> 'Decoders.json-  PrimitiveType.JsonbPrimitiveType -> 'Decoders.jsonb+valueDecoder =+  Right . VarE . \case+    PrimitiveType.BoolPrimitiveType -> 'Decoders.bool+    PrimitiveType.Int2PrimitiveType -> 'Decoders.int2+    PrimitiveType.Int4PrimitiveType -> 'Decoders.int4+    PrimitiveType.Int8PrimitiveType -> 'Decoders.int8+    PrimitiveType.Float4PrimitiveType -> 'Decoders.float4+    PrimitiveType.Float8PrimitiveType -> 'Decoders.float8+    PrimitiveType.NumericPrimitiveType -> 'Decoders.numeric+    PrimitiveType.CharPrimitiveType -> 'Decoders.char+    PrimitiveType.TextPrimitiveType -> 'Decoders.text+    PrimitiveType.ByteaPrimitiveType -> 'Decoders.bytea+    PrimitiveType.DatePrimitiveType -> 'Decoders.date+    PrimitiveType.TimestampPrimitiveType -> 'Decoders.timestamp+    PrimitiveType.TimestamptzPrimitiveType -> 'Decoders.timestamptz+    PrimitiveType.TimePrimitiveType -> 'Decoders.time+    PrimitiveType.TimetzPrimitiveType -> 'Decoders.timetz+    PrimitiveType.IntervalPrimitiveType -> 'Decoders.interval+    PrimitiveType.UuidPrimitiveType -> 'Decoders.uuid+    PrimitiveType.InetPrimitiveType -> 'Decoders.inet+    PrimitiveType.JsonPrimitiveType -> 'Decoders.json+    PrimitiveType.JsonbPrimitiveType -> 'Decoders.jsonb
library/Hasql/TH/Extraction/InputTypeList.hs view
@@ -1,53 +1,52 @@-{-|-AST traversal extracting input types.--}+-- |+-- AST traversal extracting input types. module Hasql.TH.Extraction.InputTypeList where +import qualified Data.IntMap.Strict as IntMap+import qualified Hasql.TH.Extraction.PlaceholderTypeMap as PlaceholderTypeMap import Hasql.TH.Prelude import PostgresqlSyntax.Ast-import qualified Hasql.TH.Extraction.PlaceholderTypeMap as PlaceholderTypeMap-import qualified Data.IntMap.Strict as IntMap -{-|->>> import qualified PostgresqlSyntax.Parsing as P->>> test = either fail (return . preparableStmt) . P.run P.preparableStmt-->>> test "select $1 :: INT"-Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing]-->>> test "select $1 :: INT, a + $2 :: INTEGER"-Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing,Typename False (NumericSimpleTypename IntegerNumeric) False Nothing]-->>> test "select $1 :: INT4"-Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing]-->>> test "select $1 :: text[]?"-Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) False (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))]-->>> test "select $1 :: text?[]?"-Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) True (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))]-->>> test "select $1"-Left "Placeholder $1 misses an explicit typecast"-->>> test "select $2 :: int4, $1 :: int4, $2 :: int4"-Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing,Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing]-->>> test "select $1 :: int4, $1 :: text"-Left "Placeholder $1 has conflicting type annotations"-->>> test "select $2 :: int4, $2 :: text"-Left "Placeholder $2 has conflicting type annotations"-->>> test "select $3 :: int4, $1 :: int4"-Left "You've missed placeholder $2"---}+-- |+-- >>> import qualified PostgresqlSyntax.Parsing as P+-- >>> test = either fail (return . preparableStmt) . P.run P.preparableStmt+--+-- >>> test "select $1 :: INT"+-- Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing]+--+-- >>> test "select $1 :: INT, a + $2 :: INTEGER"+-- Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing,Typename False (NumericSimpleTypename IntegerNumeric) False Nothing]+--+-- >>> test "select $1 :: INT4"+-- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing]+--+-- >>> test "select $1 :: text[]?"+-- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) False (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))]+--+-- >>> test "select $1 :: text?[]?"+-- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) True (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))]+--+-- >>> test "select $1"+-- Left "Placeholder $1 misses an explicit typecast"+--+-- >>> test "select $2 :: int4, $1 :: int4, $2 :: int4"+-- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing,Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing]+--+-- >>> test "select $1 :: int4, $1 :: text"+-- Left "Placeholder $1 has conflicting type annotations"+--+-- >>> test "select $2 :: int4, $2 :: text"+-- Left "Placeholder $2 has conflicting type annotations"+--+-- >>> test "select $3 :: int4, $1 :: int4"+-- Left "You've missed placeholder $2" preparableStmt :: PreparableStmt -> Either Text [Typename] preparableStmt = placeholderTypeMap <=< PlaceholderTypeMap.preparableStmt  placeholderTypeMap :: IntMap Typename -> Either Text [Typename] placeholderTypeMap a = do-  zipWithM (\ a b -> if a == b then Right () else Left ("You've missed placeholder $" <> showAsText b))-    (IntMap.keys a) [1..]+  zipWithM+    (\a b -> if a == b then Right () else Left ("You've missed placeholder $" <> showAsText b))+    (IntMap.keys a)+    [1 ..]   return (IntMap.elems a)
library/Hasql/TH/Extraction/OutputTypeList.hs view
@@ -1,58 +1,48 @@-{-|-AST traversal extracting output types.--}+-- |+-- AST traversal extracting output types. module Hasql.TH.Extraction.OutputTypeList where  import Hasql.TH.Prelude import PostgresqlSyntax.Ast - foldable :: Foldable f => (a -> Either Text [Typename]) -> f a -> Either Text [Typename] foldable fn = fmap join . traverse fn . toList -preparableStmt = \ case+preparableStmt = \case   SelectPreparableStmt a -> selectStmt a   InsertPreparableStmt a -> insertStmt a   UpdatePreparableStmt a -> updateStmt a   DeletePreparableStmt a -> deleteStmt a - -- * Insert--------------------------  insertStmt (InsertStmt a b c d e) = foldable returningClause e  returningClause = targetList - -- * Update--------------------------  updateStmt (UpdateStmt _ _ _ _ _ a) = foldable returningClause a - -- * Delete--------------------------  deleteStmt (DeleteStmt _ _ _ _ a) = foldable returningClause a - -- * Select-------------------------- -selectStmt = \ case+selectStmt = \case   Left a -> selectNoParens a   Right a -> selectWithParens a  selectNoParens (SelectNoParens _ a _ _ _) = selectClause a -selectWithParens = \ case+selectWithParens = \case   NoParensSelectWithParens a -> selectNoParens a   WithParensSelectWithParens a -> selectWithParens a  selectClause = either simpleSelect selectWithParens -simpleSelect = \ case+simpleSelect = \case   NormalSimpleSelect a _ _ _ _ _ _ -> foldable targeting a   ValuesSimpleSelect a -> valuesClause a   TableSimpleSelect _ -> Left "TABLE cannot be used as a final statement, since it's impossible to specify the output types"@@ -63,28 +53,30 @@       then return c       else Left "Merged queries produce results of incompatible types" -targeting = \ case+targeting = \case   NormalTargeting a -> targetList a   AllTargeting a -> foldable targetList a   DistinctTargeting _ b -> targetList b  targetList = foldable targetEl -targetEl = \ case+targetEl = \case   AliasedExprTargetEl a _ -> aExpr a   ImplicitlyAliasedExprTargetEl a _ -> aExpr a   ExprTargetEl a -> aExpr a-  AsteriskTargetEl -> Left "Target of all fields is not allowed, \-    \because it leaves the output types unspecified. \-    \You have to be specific."+  AsteriskTargetEl ->+    Left+      "Target of all fields is not allowed, \+      \because it leaves the output types unspecified. \+      \You have to be specific."  valuesClause = foldable (foldable aExpr) -aExpr = \ case+aExpr = \case   CExprAExpr a -> cExpr a   TypecastAExpr _ a -> Right [a]   a -> Left "Result expression is missing a typecast" -cExpr = \ case+cExpr = \case   InParensCExpr a Nothing -> aExpr a   a -> Left "Result expression is missing a typecast"
library/Hasql/TH/Extraction/PlaceholderTypeMap.hs view
@@ -1,11 +1,10 @@ module Hasql.TH.Extraction.PlaceholderTypeMap where -import Hasql.TH.Prelude hiding (union)-import PostgresqlSyntax.Ast-import Hasql.TH.Extraction.ChildExprList (ChildExpr(..)) import qualified Data.IntMap.Strict as IntMap+import Hasql.TH.Extraction.ChildExprList (ChildExpr (..)) import qualified Hasql.TH.Extraction.ChildExprList as ChildExprList-+import Hasql.TH.Prelude hiding (union)+import PostgresqlSyntax.Ast  preparableStmt :: PreparableStmt -> Either Text (IntMap Typename) preparableStmt = childExprList . ChildExprList.preparableStmt@@ -14,42 +13,44 @@ childExprList = foldM union IntMap.empty <=< traverse childExpr  union :: IntMap Typename -> IntMap Typename -> Either Text (IntMap Typename)-union a b = IntMap.mergeWithKey merge (fmap Right) (fmap Right) a b & sequence where-  merge index a b = if a == b-    then Just (Right a)-    else Just (Left ("Placeholder $" <> (fromString . show) index <> " has conflicting type annotations"))+union a b = IntMap.mergeWithKey merge (fmap Right) (fmap Right) a b & sequence+  where+    merge index a b =+      if a == b+        then Just (Right a)+        else Just (Left ("Placeholder $" <> (fromString . show) index <> " has conflicting type annotations"))  childExpr :: ChildExpr -> Either Text (IntMap Typename)-childExpr = \ case+childExpr = \case   AChildExpr a -> aExpr a   BChildExpr a -> bExpr a   CChildExpr a -> cExpr a -aExpr = \ case+aExpr = \case   CExprAExpr a -> cExpr a   TypecastAExpr a b -> castedAExpr b a   a -> childExprList (ChildExprList.aChildExpr a) -bExpr = \ case+bExpr = \case   CExprBExpr a -> cExpr a   TypecastBExpr a b -> castedBExpr b a   a -> childExprList (ChildExprList.bChildExpr a) -cExpr = \ case+cExpr = \case   ParamCExpr a _ -> Left ("Placeholder $" <> (fromString . show) a <> " misses an explicit typecast")   a -> childExprList (ChildExprList.cChildExpr a) -castedAExpr a = \ case+castedAExpr a = \case   CExprAExpr b -> castedCExpr a b   TypecastAExpr b c -> castedAExpr c b   b -> aExpr b -castedBExpr a = \ case+castedBExpr a = \case   CExprBExpr b -> castedCExpr a b   TypecastBExpr b c -> castedBExpr c b   b -> bExpr b -castedCExpr a = \ case+castedCExpr a = \case   ParamCExpr b _ -> Right (IntMap.singleton b a)   InParensCExpr b _ -> castedAExpr a b   b -> cExpr b
library/Hasql/TH/Extraction/PrimitiveType.hs view
@@ -1,32 +1,31 @@ module Hasql.TH.Extraction.PrimitiveType where -import Hasql.TH.Prelude hiding (sortBy, bit, fromList)+import Hasql.TH.Prelude hiding (bit, fromList, sortBy) import PostgresqlSyntax.Ast --data PrimitiveType =-  BoolPrimitiveType |-  Int2PrimitiveType |-  Int4PrimitiveType |-  Int8PrimitiveType |-  Float4PrimitiveType |-  Float8PrimitiveType |-  NumericPrimitiveType |-  CharPrimitiveType |-  TextPrimitiveType |-  ByteaPrimitiveType |-  DatePrimitiveType |-  TimestampPrimitiveType |-  TimestamptzPrimitiveType |-  TimePrimitiveType |-  TimetzPrimitiveType |-  IntervalPrimitiveType |-  UuidPrimitiveType |-  InetPrimitiveType |-  JsonPrimitiveType |-  JsonbPrimitiveType+data PrimitiveType+  = BoolPrimitiveType+  | Int2PrimitiveType+  | Int4PrimitiveType+  | Int8PrimitiveType+  | Float4PrimitiveType+  | Float8PrimitiveType+  | NumericPrimitiveType+  | CharPrimitiveType+  | TextPrimitiveType+  | ByteaPrimitiveType+  | DatePrimitiveType+  | TimestampPrimitiveType+  | TimestamptzPrimitiveType+  | TimePrimitiveType+  | TimetzPrimitiveType+  | IntervalPrimitiveType+  | UuidPrimitiveType+  | InetPrimitiveType+  | JsonPrimitiveType+  | JsonbPrimitiveType -simpleTypename = \ case+simpleTypename = \case   GenericTypeSimpleTypename a -> genericType a   NumericSimpleTypename a -> numeric a   BitSimpleTypename a -> bit a@@ -40,7 +39,7 @@     Just _ -> Left "Type modifiers are not supported"     Nothing -> ident a -numeric = \ case+numeric = \case   IntNumeric -> Right Int4PrimitiveType   IntegerNumeric -> Right Int4PrimitiveType   SmallintNumeric -> Right Int2PrimitiveType@@ -65,19 +64,19 @@  character _ = Right TextPrimitiveType -constDatetime = \ case+constDatetime = \case   TimestampConstDatetime _ a -> if tz a then Right TimestamptzPrimitiveType else Right TimestampPrimitiveType   TimeConstDatetime _ a -> if tz a then Right TimetzPrimitiveType else Right TimePrimitiveType   where-    tz = \ case+    tz = \case       Just a -> a       Nothing -> False -ident = \ case+ident = \case   QuotedIdent a -> name a   UnquotedIdent a -> name a -name = \ case+name = \case   "bool" -> Right BoolPrimitiveType   "int2" -> Right Int2PrimitiveType   "int4" -> Right Int4PrimitiveType
library/Hasql/TH/Prelude.hs view
@@ -1,26 +1,25 @@ module Hasql.TH.Prelude-( -  module Exports,-  showAsText,-  suffixRec,-)+  ( module Exports,+    showAsText,+    suffixRec,+  ) where --- base-------------------------- import Control.Applicative as Exports import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class as Exports+import Control.Foldl as Exports (Fold (..))+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports import Data.Bifunctor as Exports import Data.Bits as Exports import Data.Bool as Exports+import Data.ByteString as Exports (ByteString) import Data.Char as Exports import Data.Coerce as Exports import Data.Complex as Exports@@ -32,22 +31,30 @@ import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports import Data.Functor.Identity as Exports-import Data.Int as Exports import Data.IORef as Exports+import Data.Int as Exports+import Data.IntMap.Strict as Exports (IntMap)+import Data.IntSet as Exports (IntSet) import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..))+import Data.Map.Strict as Exports (Map) import Data.Maybe as Exports-import Data.Monoid as Exports hiding (Last(..), First(..), (<>))+import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) import Data.Ord as Exports import Data.Proxy as Exports import Data.Ratio as Exports-import Data.Semigroup as Exports import Data.STRef as Exports+import Data.Semigroup as Exports+import Data.Sequence as Exports (Seq)+import Data.Set as Exports (Set) import Data.String as Exports+import Data.Text as Exports (Text) import Data.Traversable as Exports import Data.Tuple as Exports+import Data.UUID as Exports (UUID) import Data.Unique as Exports import Data.Version as Exports import Data.Void as Exports@@ -56,13 +63,12 @@ import Foreign.ForeignPtr as Exports import Foreign.Ptr as Exports import Foreign.StablePtr as Exports-import Foreign.Storable as Exports hiding (sizeOf, alignment)-import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(fromList, Item))+import Foreign.Storable as Exports hiding (alignment, sizeOf)+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic, Generic1) import GHC.IO.Exception as Exports import Numeric as Exports-import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports@@ -72,47 +78,18 @@ import System.Mem.StableName as Exports import System.Timeout as Exports import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports---- contravariant---------------------------import Data.Functor.Contravariant.Divisible as Exports---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- text---------------------------import Data.Text as Exports (Text)---- containers---------------------------import Data.IntMap.Strict as Exports (IntMap)-import Data.IntSet as Exports (IntSet)-import Data.Map.Strict as Exports (Map)-import Data.Sequence as Exports (Seq)-import Data.Set as Exports (Set)---- foldl---------------------------import Control.Foldl as Exports (Fold(..))---- uuid---------------------------import Data.UUID as Exports (UUID)-+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))  showAsText :: Show a => a -> Text showAsText = show >>> fromString -{-|-Compose a monad, which attempts to extend a value, based on the following input.-It does that recursively until the suffix alternative fails.--}+-- |+-- Compose a monad, which attempts to extend a value, based on the following input.+-- It does that recursively until the suffix alternative fails. suffixRec :: (Monad m, Alternative m) => m a -> (a -> m a) -> m a suffixRec base suffix = do   _base <- base