hasql-th 0.4.0.23 → 0.4.1

raw patch · 19 files changed

+1603/−1603 lines, 19 filesdep ~hasqlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hasql

API changes (from Hackage documentation)

Files

• hasql-th.cabal +4/−4
• library/Hasql/TH.hs +0/−279
• library/Hasql/TH/Construction/Exp.hs +0/−201
• library/Hasql/TH/Extraction/ChildExprList.hs +0/−611
• library/Hasql/TH/Extraction/Exp.hs +0/−112
• library/Hasql/TH/Extraction/InputTypeList.hs +0/−52
• library/Hasql/TH/Extraction/OutputTypeList.hs +0/−90
• library/Hasql/TH/Extraction/PlaceholderTypeMap.hs +0/−58
• library/Hasql/TH/Extraction/PrimitiveType.hs +0/−102
• library/Hasql/TH/Prelude.hs +0/−94
• src/library/Hasql/TH.hs +279/−0
• src/library/Hasql/TH/Construction/Exp.hs +201/−0
• src/library/Hasql/TH/Extraction/ChildExprList.hs +611/−0
• src/library/Hasql/TH/Extraction/Exp.hs +112/−0
• src/library/Hasql/TH/Extraction/InputTypeList.hs +52/−0
• src/library/Hasql/TH/Extraction/OutputTypeList.hs +90/−0
• src/library/Hasql/TH/Extraction/PlaceholderTypeMap.hs +58/−0
• src/library/Hasql/TH/Extraction/PrimitiveType.hs +102/−0
• src/library/Hasql/TH/Prelude.hs +94/−0

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-th-version: 0.4.0.23+version: 0.4.1 category: Hasql, Database, PostgreSQL, Template Haskell synopsis: Template Haskell utilities for Hasql description:@@ -21,10 +21,10 @@  source-repository head   type: git-  location: git://github.com/nikita-volkov/hasql-th.git+  location: https://github.com/nikita-volkov/hasql-th  library-  hs-source-dirs: library+  hs-source-dirs: src/library   default-extensions:     ApplicativeDo     Arrows@@ -83,7 +83,7 @@     containers >=0.6 && <0.8,     contravariant >=1.5.2 && <2,     foldl >=1.4.5 && <2,-    hasql >=1.4 && <1.10,+    hasql >=1.10 && <1.11,     postgresql-syntax >=0.4.1 && <0.5,     template-haskell >=2.8 && <3,     template-haskell-compat-v0208 >=0.1.9 && <2,

@@ -1,279 +0,0 @@-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:-    ---    --  >>> :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)))--    -- ** Row-parsing statements-    singletonStatement,-    maybeStatement,-    vectorStatement,-    foldStatement,--    -- ** Row-ignoring statements-    resultlessStatement,-    rowsAffectedStatement,--    -- * SQL ByteStrings--    -- |-    --  ByteString-producing quasiquoters.-    ---    --  For now they perform no compile-time checking.-    uncheckedSql,-    uncheckedSqlFile,-  )-where--import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Hasql.TH.Construction.Exp as Exp-import qualified Hasql.TH.Extraction.Exp as ExpExtraction-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--expParser :: (Text -> Either Text Exp) -> QuasiQuoter-expParser _parser =-  exp $ \_inputString -> either (fail . Text.unpack) return $ _parser $ fromString _inputString--expPreparableStmtAstParser :: (Ast.PreparableStmt -> Either Text Exp) -> QuasiQuoter-expPreparableStmtAstParser _parser =-  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---   |      ^--- ...-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)-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)-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-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) ()-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-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.-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|]-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

@@ -1,201 +0,0 @@--- |--- Expression construction.-module Hasql.TH.Construction.Exp where--import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Unsafe as ByteString-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 (sequence_)-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--byteString :: ByteString -> Exp-byteString x =-  appList-    (VarE 'unsafeDupablePerformIO)-    [ appList-        (VarE 'ByteString.unsafePackAddressLen)-        [ LitE (IntegerL (fromIntegral (ByteString.length x))),-          LitE (StringPrimL (ByteString.unpack x))-        ]-    ]--integral :: (Integral a) => a -> Exp-integral x = LitE (IntegerL (fromIntegral x))--list :: (a -> Exp) -> [a] -> Exp-list renderer x = ListE (map renderer x)--string :: String -> Exp-string x = LitE (StringL x)--char :: Char -> Exp-char x = LitE (CharL x)--sequence_ :: [Exp] -> Exp-sequence_ = foldl' andThen pureUnit--pureUnit :: Exp-pureUnit = AppE (VarE 'Prelude.pure) (TupE [])--andThen :: Exp -> Exp -> Exp-andThen exp1 exp2 = AppE (AppE (VarE '(*>)) exp1) exp2--tuple :: Int -> Exp-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---- |--- 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-  _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-              [Compat.specifiedPlainTV _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 ()------ >>> $(return (cozip (fmap (AppE (ConE 'Just) . LitE . IntegerL) [1,2,3]))) :: Maybe (Int, Int, Int)--- Just (1,2,3)-cozip :: [Exp] -> Exp-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-  [] -> AppE (VarE 'pure) (TupE [])---- |--- Lambda expression, which destructures 'Fold'.-foldLam :: (Exp -> Exp -> Exp -> Exp) -> Exp-foldLam _body =-  let _stepVarName = mkName "progress"-      _initVarName = mkName "start"-      _extractVarName = mkName "finish"-   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 =-  appList (ConE 'Statement.Statement) [_sql, _encoder, _decoder, ConE 'True]--noResultResultDecoder :: Exp-noResultResultDecoder = VarE 'Decoders.noResult--rowsAffectedResultDecoder :: Exp-rowsAffectedResultDecoder = VarE 'Decoders.rowsAffected--singleRowResultDecoder :: Exp -> Exp-singleRowResultDecoder = 'Decoders.singleRow & VarE & AppE--rowMaybeResultDecoder :: Exp -> Exp-rowMaybeResultDecoder = AppE (VarE 'Decoders.rowMaybe)--rowVectorResultDecoder :: Exp -> Exp-rowVectorResultDecoder = AppE (VarE 'Decoders.rowVector)--foldStatement :: Exp -> Exp -> Exp -> Exp-foldStatement _sql _encoder _rowDecoder =-  foldLam (\_step _init _extract -> statement _sql _encoder (foldResultDecoder _step _init _extract _rowDecoder))--foldResultDecoder :: Exp -> Exp -> Exp -> Exp -> Exp-foldResultDecoder _step _init _extract _rowDecoder =-  appList (VarE 'fmap) [_extract, appList (VarE 'Decoders.foldlRows) [_step, _init, _rowDecoder]]--unidimensionalParamEncoder :: Bool -> Exp -> Exp-unidimensionalParamEncoder nullable =-  applyParamToEncoder . applyNullabilityToEncoder nullable--multidimensionalParamEncoder :: Bool -> Int -> Bool -> Exp -> Exp-multidimensionalParamEncoder nullable dimensionality arrayNull =-  applyParamToEncoder-    . applyNullabilityToEncoder arrayNull-    . AppE (VarE 'Encoders.array)-    . applyArrayDimensionalityToEncoder dimensionality-    . applyNullabilityToEncoder nullable--applyParamToEncoder :: Exp -> Exp-applyParamToEncoder = AppE (VarE 'Encoders.param)--applyNullabilityToEncoder :: Bool -> Exp -> Exp-applyNullabilityToEncoder nullable = AppE (VarE (if nullable then 'Encoders.nullable else 'Encoders.nonNullable))--applyArrayDimensionalityToEncoder :: Int -> Exp -> Exp-applyArrayDimensionalityToEncoder levels =-  if levels > 0-    then AppE (AppE (VarE 'Encoders.dimension) (VarE 'Vector.foldl')) . applyArrayDimensionalityToEncoder (pred levels)-    else AppE (VarE 'Encoders.element)--rowDecoder :: [Exp] -> Exp-rowDecoder = cozip--unidimensionalColumnDecoder :: Bool -> Exp -> Exp-unidimensionalColumnDecoder nullable =-  applyColumnToDecoder . applyNullabilityToDecoder nullable--multidimensionalColumnDecoder :: Bool -> Int -> Bool -> Exp -> Exp-multidimensionalColumnDecoder nullable dimensionality arrayNull =-  applyColumnToDecoder-    . applyNullabilityToDecoder arrayNull-    . AppE (VarE 'Decoders.array)-    . applyArrayDimensionalityToDecoder dimensionality-    . applyNullabilityToDecoder nullable--applyColumnToDecoder :: Exp -> Exp-applyColumnToDecoder = AppE (VarE 'Decoders.column)--applyNullabilityToDecoder :: Bool -> Exp -> Exp-applyNullabilityToDecoder nullable = AppE (VarE (if nullable then 'Decoders.nullable else 'Decoders.nonNullable))--applyArrayDimensionalityToDecoder :: Int -> Exp -> Exp-applyArrayDimensionalityToDecoder levels =-  if levels > 0-    then AppE (AppE (VarE 'Decoders.dimension) (VarE 'Vector.replicateM)) . applyArrayDimensionalityToDecoder (pred levels)-    else AppE (VarE 'Decoders.element)

@@ -1,611 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--module Hasql.TH.Extraction.ChildExprList where--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-  AChildExpr a -> aChildExpr a-  BChildExpr a -> bChildExpr a-  CChildExpr a -> cChildExpr a--aChildExpr = \case-  CExprAExpr a -> cChildExpr a-  TypecastAExpr a b -> aExpr a <> typename b-  CollateAExpr a b -> aExpr a <> anyName b-  AtTimeZoneAExpr a b -> aExpr a <> aExpr b-  PlusAExpr a -> aExpr a-  MinusAExpr a -> aExpr a-  SymbolicBinOpAExpr a b c -> aExpr a <> symbolicExprBinOp b <> aExpr c-  PrefixQualOpAExpr a b -> qualOp a <> aExpr b-  SuffixQualOpAExpr a b -> aExpr a <> qualOp b-  AndAExpr a b -> aExpr a <> aExpr b-  OrAExpr a b -> aExpr a <> aExpr b-  NotAExpr a -> aExpr a-  VerbalExprBinOpAExpr a b c d e -> aExpr a <> verbalExprBinOp c <> aExpr d <> foldMap aExpr e-  ReversableOpAExpr a b c -> aExpr a <> aExprReversableOp c-  IsnullAExpr a -> aExpr a-  NotnullAExpr a -> aExpr a-  OverlapsAExpr a b -> row a <> row b-  SubqueryAExpr a b c d -> aExpr a <> subqueryOp b <> subType c <> either selectWithParens aExpr d-  UniqueAExpr a -> selectWithParens a-  DefaultAExpr -> []--bChildExpr = \case-  CExprBExpr a -> cChildExpr a-  TypecastBExpr a b -> bExpr a <> typename b-  PlusBExpr a -> bExpr a-  MinusBExpr a -> bExpr a-  SymbolicBinOpBExpr a b c -> bExpr a <> symbolicExprBinOp b <> bExpr c-  QualOpBExpr a b -> qualOp a <> bExpr b-  IsOpBExpr a b c -> bExpr a <> bExprIsOp c--cChildExpr = \case-  ColumnrefCExpr a -> columnref a-  AexprConstCExpr a -> aexprConst a-  ParamCExpr a b -> foldMap indirection b-  InParensCExpr a b -> aExpr a <> foldMap indirection b-  CaseCExpr a -> caseExpr a-  FuncCExpr a -> funcExpr a-  SelectWithParensCExpr a b -> selectWithParens a <> foldMap indirection b-  ExistsCExpr a -> selectWithParens a-  ArrayCExpr a -> either selectWithParens arrayExpr a-  ExplicitRowCExpr a -> explicitRow a-  ImplicitRowCExpr a -> implicitRow a-  GroupingCExpr a -> exprList a--preparableStmt = \case-  SelectPreparableStmt a -> selectStmt a-  InsertPreparableStmt a -> insertStmt a-  UpdatePreparableStmt a -> updateStmt a-  DeletePreparableStmt a -> deleteStmt a-  CallPreparableStmt a -> callStmt a---- * Call--callStmt (CallStmt a) = funcApplication a---- * Insert--insertStmt (InsertStmt a b c d e) =-  foldMap withClause a-    <> insertTarget b-    <> insertRest c-    <> foldMap onConflict d-    <> foldMap returningClause e--insertTarget (InsertTarget a b) = qualifiedName a <> colId b--insertRest = \case-  SelectInsertRest a b c -> foldMap insertColumnList a <> foldMap overrideKind b <> selectStmt c-  DefaultValuesInsertRest -> []--overrideKind _ = []--insertColumnList = foldMap insertColumnItem--insertColumnItem (InsertColumnItem a b) = colId a <> foldMap indirection b--onConflict (OnConflict a b) = foldMap confExpr a <> onConflictDo b--onConflictDo = \case-  UpdateOnConflictDo b c -> setClauseList b <> foldMap whereClause c-  NothingOnConflictDo -> []--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--setClauseList = foldMap setClause--setClause = \case-  TargetSetClause a b -> setTarget a <> aExpr b-  TargetListSetClause a b -> setTargetList a <> aExpr b--setTarget (SetTarget a b) = colId a <> foldMap indirection b--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--usingClause = fromList---- * Select--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--selectWithParens = \case-  NoParensSelectWithParens a -> selectNoParens a-  WithParensSelectWithParens a -> selectWithParens a--withClause (WithClause _ a) = foldMap commonTableExpr a--commonTableExpr (CommonTableExpr a b c d) = preparableStmt d--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-  LimitLimitClause a b -> selectLimitValue a <> exprList b-  FetchOnlyLimitClause a b c -> foldMap selectFetchFirstValue b--offsetClause = \case-  ExprOffsetClause a -> aExpr a-  FetchFirstOffsetClause a b -> selectFetchFirstValue a--selectFetchFirstValue = \case-  ExprSelectFetchFirstValue a -> cExpr a-  NumSelectFetchFirstValue _ _ -> []--selectLimitValue = \case-  ExprSelectLimitValue a -> aExpr a-  AllSelectLimitValue -> []--forLockingClause = \case-  ItemsForLockingClause a -> foldMap forLockingItem a-  ReadOnlyForLockingClause -> []--forLockingItem (ForLockingItem a b c) =-  foldMap (foldMap qualifiedName) b--selectClause = either simpleSelect selectWithParens--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-  ValuesSimpleSelect a -> valuesClause a-  TableSimpleSelect a -> relationExpr a-  BinSimpleSelect _ a _ b -> selectClause a <> selectClause b--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-  AliasedExprTargetEl a _ -> aExpr a-  ImplicitlyAliasedExprTargetEl a _ -> aExpr a-  ExprTargetEl a -> aExpr a-  AsteriskTargetEl -> []--intoClause = optTempTableName--fromClause = fromList--fromList = foldMap tableRef--whereClause = aExpr--whereOrCurrentClause = \case-  ExprWhereOrCurrentClause a -> aExpr a-  CursorWhereOrCurrentClause a -> cursorName a--groupClause = foldMap groupByItem--havingClause = aExpr--windowClause = foldMap windowDefinition--valuesClause = foldMap exprList--optTempTableName _ = []--groupByItem = \case-  ExprGroupByItem a -> aExpr a-  EmptyGroupingSetGroupByItem -> []-  RollupGroupByItem a -> exprList a-  CubeGroupByItem a -> exprList a-  GroupingSetsGroupByItem a -> foldMap groupByItem a--windowDefinition (WindowDefinition _ a) = windowSpecification a--windowSpecification (WindowSpecification _ a b c) = foldMap (foldMap aExpr) a <> foldMap sortClause b <> foldMap frameClause c--frameClause (FrameClause _ a _) = frameExtent a--frameExtent = \case-  SingularFrameExtent a -> frameBound a-  BetweenFrameExtent a b -> frameBound a <> frameBound b--frameBound = \case-  UnboundedPrecedingFrameBound -> []-  UnboundedFollowingFrameBound -> []-  CurrentRowFrameBound -> []-  PrecedingFrameBound a -> aExpr a-  FollowingFrameBound a -> aExpr a--sortClause = foldMap sortBy--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-  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-  SimpleRelationExpr a _ -> qualifiedName a-  OnlyRelationExpr a _ -> qualifiedName a--relationExprOptAlias (RelationExprOptAlias a b) = relationExpr a <> foldMap (colId . snd) b--tablesampleClause (TablesampleClause a b c) = funcName a <> exprList b <> foldMap repeatableClause c--repeatableClause = aExpr--funcTable = \case-  FuncExprFuncTable a b -> funcExprWindowless a <> optOrdinality b-  RowsFromFuncTable a b -> rowsfromList a <> optOrdinality b--rowsfromItem (RowsfromItem a b) = funcExprWindowless a <> foldMap colDefList b--rowsfromList = foldMap rowsfromItem--colDefList = tableFuncElementList--optOrdinality = const []--tableFuncElementList = foldMap tableFuncElement--tableFuncElement (TableFuncElement a b c) = colId a <> typename b <> foldMap collateClause c--collateClause = anyName--aliasClause = const []--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-  InParensJoinedTable a -> joinedTable a-  MethJoinedTable a b c -> joinMeth a <> tableRef b <> tableRef c--joinMeth = \case-  CrossJoinMeth -> []-  QualJoinMeth _ a -> joinQual a-  NaturalJoinMeth _ -> []--joinQual = \case-  UsingJoinQual _ -> []-  OnJoinQual a -> aExpr a--exprList = fmap AChildExpr . toList--aExpr = pure . AChildExpr--bExpr = pure . BChildExpr--cExpr = pure . CChildExpr--funcExpr = \case-  ApplicationFuncExpr a b c d -> funcApplication a <> foldMap withinGroupClause b <> foldMap filterClause c <> foldMap overClause d-  SubexprFuncExpr a -> funcExprCommonSubexpr a--funcExprWindowless = \case-  ApplicationFuncExprWindowless a -> funcApplication a-  CommonSubexprFuncExprWindowless a -> funcExprCommonSubexpr a--withinGroupClause = sortClause--filterClause a = aExpr a--overClause = \case-  WindowOverClause a -> windowSpecification a-  ColIdOverClause _ -> []--funcExprCommonSubexpr = \case-  CollationForFuncExprCommonSubexpr a -> aExpr a-  CurrentDateFuncExprCommonSubexpr -> []-  CurrentTimeFuncExprCommonSubexpr _ -> []-  CurrentTimestampFuncExprCommonSubexpr _ -> []-  LocalTimeFuncExprCommonSubexpr _ -> []-  LocalTimestampFuncExprCommonSubexpr _ -> []-  CurrentRoleFuncExprCommonSubexpr -> []-  CurrentUserFuncExprCommonSubexpr -> []-  SessionUserFuncExprCommonSubexpr -> []-  UserFuncExprCommonSubexpr -> []-  CurrentCatalogFuncExprCommonSubexpr -> []-  CurrentSchemaFuncExprCommonSubexpr -> []-  CastFuncExprCommonSubexpr a b -> aExpr a <> typename b-  ExtractFuncExprCommonSubexpr a -> foldMap extractList a-  OverlayFuncExprCommonSubexpr a -> overlayList a-  PositionFuncExprCommonSubexpr a -> foldMap positionList a-  SubstringFuncExprCommonSubexpr a -> foldMap substrList a-  TreatFuncExprCommonSubexpr a b -> aExpr a <> typename b-  TrimFuncExprCommonSubexpr a b -> foldMap trimModifier a <> trimList b-  NullIfFuncExprCommonSubexpr a b -> aExpr a <> aExpr b-  CoalesceFuncExprCommonSubexpr a -> exprList a-  GreatestFuncExprCommonSubexpr a -> exprList a-  LeastFuncExprCommonSubexpr a -> exprList a--extractList (ExtractList a b) = extractArg a <> aExpr b--extractArg _ = []--overlayList (OverlayList a b c d) = foldMap aExpr ([a, b, c] <> toList d)--positionList (PositionList a b) = bExpr a <> bExpr b--substrList = \case-  ExprSubstrList a b -> aExpr a <> substrListFromFor b-  ExprListSubstrList a -> exprList a--substrListFromFor = \case-  FromForSubstrListFromFor a b -> aExpr a <> aExpr b-  ForFromSubstrListFromFor a b -> aExpr a <> aExpr b-  FromSubstrListFromFor a -> aExpr a-  ForSubstrListFromFor a -> aExpr a--trimModifier _ = []--trimList = \case-  ExprFromExprListTrimList a b -> aExpr a <> exprList b-  FromExprListTrimList 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-  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-  ExprFuncArgExpr a -> aExpr a-  ColonEqualsFuncArgExpr _ a -> aExpr a-  EqualsGreaterFuncArgExpr _ a -> aExpr a--caseExpr (CaseExpr a b c) = foldMap aExpr a <> whenClauseList b <> foldMap aExpr c--whenClauseList = foldMap whenClause--arrayExpr = \case-  ExprListArrayExpr a -> exprList a-  ArrayExprListArrayExpr a -> arrayExprList a-  EmptyArrayExpr -> []--arrayExprList = foldMap arrayExpr--inExpr = \case-  SelectInExpr a -> selectWithParens a-  ExprListInExpr a -> exprList a---- * Operators--symbolicExprBinOp = \case-  MathSymbolicExprBinOp a -> mathOp a-  QualSymbolicExprBinOp a -> qualOp a--qualOp = \case-  OpQualOp a -> op a-  OperatorQualOp a -> anyOperator a--qualAllOp = \case-  AllQualAllOp a -> allOp a-  AnyQualAllOp a -> anyOperator a--verbalExprBinOp = const []--aExprReversableOp = \case-  NullAExprReversableOp -> []-  TrueAExprReversableOp -> []-  FalseAExprReversableOp -> []-  UnknownAExprReversableOp -> []-  DistinctFromAExprReversableOp a -> aExpr a-  OfAExprReversableOp a -> typeList a-  BetweenAExprReversableOp a b c -> bExpr b <> aExpr c-  BetweenSymmetricAExprReversableOp a b -> bExpr a <> aExpr b-  InAExprReversableOp a -> inExpr a-  DocumentAExprReversableOp -> []--subqueryOp = \case-  AllSubqueryOp a -> allOp a-  AnySubqueryOp a -> anyOperator a-  LikeSubqueryOp _ -> []-  IlikeSubqueryOp _ -> []--bExprIsOp = \case-  DistinctFromBExprIsOp a -> bExpr a-  OfBExprIsOp a -> typeList a-  DocumentBExprIsOp -> []--allOp = \case-  OpAllOp a -> op a-  MathAllOp a -> mathOp a--anyOperator = \case-  AllOpAnyOperator a -> allOp a-  QualifiedAnyOperator a b -> colId a <> anyOperator b--op = const []--mathOp = const []---- * Rows--row = \case-  ExplicitRowRow a -> explicitRow a-  ImplicitRowRow a -> implicitRow a--explicitRow = foldMap exprList--implicitRow (ImplicitRow a b) = exprList a <> aExpr b---- * Constants--aexprConst = \case-  IAexprConst _ -> []-  FAexprConst _ -> []-  SAexprConst _ -> []-  BAexprConst _ -> []-  XAexprConst _ -> []-  FuncAexprConst a b _ -> funcName a <> foldMap funcConstArgs b-  ConstTypenameAexprConst a _ -> constTypename a-  StringIntervalAexprConst _ a -> foldMap interval a-  IntIntervalAexprConst _ _ -> []-  BoolAexprConst _ -> []-  NullAexprConst -> []--funcConstArgs (FuncConstArgs a b) = foldMap funcArgExpr a <> foldMap sortClause b--constTypename = \case-  NumericConstTypename a -> numeric a-  ConstBitConstTypename a -> constBit a-  ConstCharacterConstTypename a -> constCharacter a-  ConstDatetimeConstTypename a -> constDatetime a--numeric = \case-  IntNumeric -> []-  IntegerNumeric -> []-  SmallintNumeric -> []-  BigintNumeric -> []-  RealNumeric -> []-  FloatNumeric _ -> []-  DoublePrecisionNumeric -> []-  DecimalNumeric a -> foldMap exprList a-  DecNumeric a -> foldMap exprList a-  NumericNumeric a -> foldMap exprList a-  BooleanNumeric -> []--bit (Bit _ a) = foldMap exprList a--constBit = bit--constCharacter (ConstCharacter _ _) = []--constDatetime _ = []--interval _ = []---- * Names--ident _ = []--colId = ident--name = colId--cursorName = name--anyName (AnyName a b) = colId a <> foldMap attrs b--columnref (Columnref a b) = colId a <> foldMap indirection b--funcName = \case-  TypeFuncName a -> typeFunctionName a-  IndirectedFuncName a b -> colId a <> indirection b--qualifiedName = \case-  SimpleQualifiedName _ -> []-  IndirectedQualifiedName _ a -> indirection a--indirection = foldMap indirectionEl--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-  GenericTypeSimpleTypename a -> genericType a-  NumericSimpleTypename a -> numeric a-  BitSimpleTypename a -> bit a-  CharacterSimpleTypename a -> character a-  ConstDatetimeSimpleTypename a -> constDatetime a-  ConstIntervalSimpleTypename a -> either (foldMap interval) (const []) a--arrayBounds _ = []--genericType (GenericType a b c) = typeFunctionName a <> foldMap attrs b <> foldMap typeModifiers c--typeFunctionName = ident--attrs = foldMap attrName--attrName _ = []--typeModifiers = exprList--character _ = []--subType _ = []---- * Indexes--indexParams = foldMap indexElem--indexElem (IndexElem a b c d e) = indexElemDef a <> foldMap anyName b <> foldMap anyName c--indexElemDef = \case-  IdIndexElemDef a -> colId a-  FuncIndexElemDef a -> funcExprWindowless a-  ExprIndexElemDef a -> aExpr a--ascDesc = const []--nullsOrder = const []

@@ -1,112 +0,0 @@-module Hasql.TH.Extraction.Exp where--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 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))--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)--paramsEncoder :: Ast.PreparableStmt -> Either Text Exp-paramsEncoder a = do-  b <- InputTypeList.preparableStmt a-  c <- traverse paramEncoder b-  return (Exp.contrazip c)--rowDecoder :: Ast.PreparableStmt -> Either Text Exp-rowDecoder a = do-  b <- OutputTypeList.preparableStmt a-  c <- traverse columnDecoder b-  return (Exp.cozip c)--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))--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))--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) =-  if a-    then Left "SETOF is not supported"-    else do-      e <- PrimitiveType.simpleTypename b-      case d of-        Nothing -> unidimensional e c-        Just (f, g) -> case f of-          Ast.BoundsTypenameArrayDimensions h -> multidimensional e c (length h) g-          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--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

@@ -1,52 +0,0 @@--- |--- 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 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 ..]-  return (IntMap.elems a)

@@ -1,90 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}---- |--- 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-  SelectPreparableStmt a -> selectStmt a-  InsertPreparableStmt a -> insertStmt a-  UpdatePreparableStmt a -> updateStmt a-  DeletePreparableStmt a -> deleteStmt a-  CallPreparableStmt a -> callStmt a---- * Call--callStmt (CallStmt a) =-  Right []---- * 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-  Left a -> selectNoParens a-  Right a -> selectWithParens a--selectNoParens (SelectNoParens _ a _ _ _) = selectClause a--selectWithParens = \case-  NoParensSelectWithParens a -> selectNoParens a-  WithParensSelectWithParens a -> selectWithParens a--selectClause = either simpleSelect selectWithParens--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"-  BinSimpleSelect _ a _ b -> do-    c <- selectClause a-    d <- selectClause b-    if c == d-      then return c-      else Left "Merged queries produce results of incompatible types"--targeting = \case-  NormalTargeting a -> targetList a-  AllTargeting a -> foldable targetList a-  DistinctTargeting _ b -> targetList b--targetList = foldable targetEl--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."--valuesClause = foldable (foldable aExpr)--aExpr = \case-  CExprAExpr a -> cExpr a-  TypecastAExpr _ a -> Right [a]-  a -> Left "Result expression is missing a typecast"--cExpr = \case-  InParensCExpr a Nothing -> aExpr a-  a -> Left "Result expression is missing a typecast"

@@ -1,58 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--module Hasql.TH.Extraction.PlaceholderTypeMap where--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--childExprList :: [ChildExpr] -> Either Text (IntMap Typename)-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"))--childExpr :: ChildExpr -> Either Text (IntMap Typename)-childExpr = \case-  AChildExpr a -> aExpr a-  BChildExpr a -> bExpr a-  CChildExpr a -> cExpr a--aExpr = \case-  CExprAExpr a -> cExpr a-  TypecastAExpr a b -> castedAExpr b a-  a -> childExprList (ChildExprList.aChildExpr a)--bExpr = \case-  CExprBExpr a -> cExpr a-  TypecastBExpr a b -> castedBExpr b a-  a -> childExprList (ChildExprList.bChildExpr a)--cExpr = \case-  ParamCExpr a _ -> Left ("Placeholder $" <> (fromString . show) a <> " misses an explicit typecast")-  a -> childExprList (ChildExprList.cChildExpr a)--castedAExpr a = \case-  CExprAExpr b -> castedCExpr a b-  TypecastAExpr b c -> castedAExpr c b-  b -> aExpr b--castedBExpr a = \case-  CExprBExpr b -> castedCExpr a b-  TypecastBExpr b c -> castedBExpr c b-  b -> bExpr b--castedCExpr a = \case-  ParamCExpr b _ -> Right (IntMap.singleton b a)-  InParensCExpr b _ -> castedAExpr a b-  b -> cExpr b

@@ -1,102 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--module Hasql.TH.Extraction.PrimitiveType where--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--simpleTypename = \case-  GenericTypeSimpleTypename a -> genericType a-  NumericSimpleTypename a -> numeric a-  BitSimpleTypename a -> bit a-  CharacterSimpleTypename a -> character a-  ConstDatetimeSimpleTypename a -> constDatetime a-  ConstIntervalSimpleTypename a -> Right IntervalPrimitiveType--genericType (GenericType a b c) = case b of-  Just _ -> Left "Type attributes are not supported"-  Nothing -> case c of-    Just _ -> Left "Type modifiers are not supported"-    Nothing -> ident a--numeric = \case-  IntNumeric -> Right Int4PrimitiveType-  IntegerNumeric -> Right Int4PrimitiveType-  SmallintNumeric -> Right Int2PrimitiveType-  BigintNumeric -> Right Int8PrimitiveType-  RealNumeric -> Right Float4PrimitiveType-  FloatNumeric a -> case a of-    Just _ -> Left "Modifier on FLOAT is not supported"-    Nothing -> Right Float4PrimitiveType-  DoublePrecisionNumeric -> Right Float8PrimitiveType-  DecimalNumeric a -> case a of-    Just _ -> Left "Modifiers on DECIMAL are not supported"-    Nothing -> Right NumericPrimitiveType-  DecNumeric a -> case a of-    Just _ -> Left "Modifiers on DEC are not supported"-    Nothing -> Right NumericPrimitiveType-  NumericNumeric a -> case a of-    Just _ -> Left "Modifiers on NUMERIC are not supported"-    Nothing -> Right NumericPrimitiveType-  BooleanNumeric -> Right BoolPrimitiveType--bit _ = Left "Bit codec is not supported"--character _ = Right CharPrimitiveType--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-      Just a -> a-      Nothing -> False--ident = \case-  QuotedIdent a -> name a-  UnquotedIdent a -> name a--name = \case-  "bool" -> Right BoolPrimitiveType-  "int2" -> Right Int2PrimitiveType-  "int4" -> Right Int4PrimitiveType-  "int8" -> Right Int8PrimitiveType-  "float4" -> Right Float4PrimitiveType-  "float8" -> Right Float8PrimitiveType-  "numeric" -> Right NumericPrimitiveType-  "char" -> Right CharPrimitiveType-  "text" -> Right TextPrimitiveType-  "bytea" -> Right ByteaPrimitiveType-  "date" -> Right DatePrimitiveType-  "timestamp" -> Right TimestampPrimitiveType-  "timestamptz" -> Right TimestamptzPrimitiveType-  "time" -> Right TimePrimitiveType-  "timetz" -> Right TimetzPrimitiveType-  "interval" -> Right IntervalPrimitiveType-  "uuid" -> Right UuidPrimitiveType-  "inet" -> Right InetPrimitiveType-  "json" -> Right JsonPrimitiveType-  "jsonb" -> Right JsonbPrimitiveType-  name -> Left ("No codec exists for type: " <> name)

@@ -1,94 +0,0 @@-module Hasql.TH.Prelude-  ( module Exports,-    showAsText,-    suffixRec,-  )-where--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.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-import Data.Data as Exports-import Data.Dynamic as Exports-import Data.Either as Exports-import Data.Fixed as Exports-import Data.Foldable as Exports-import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports hiding (unzip)-import Data.Functor.Contravariant as Exports-import Data.Functor.Contravariant.Divisible as Exports-import Data.Functor.Identity 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 (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 (First (..), Last (..), (<>))-import Data.Ord as Exports-import Data.Proxy as Exports-import Data.Ratio 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-import Data.Word as Exports-import Debug.Trace as Exports-import Foreign.ForeignPtr as Exports-import Foreign.Ptr as Exports-import Foreign.StablePtr as Exports-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 System.Environment as Exports-import System.Exit as Exports-import System.IO as Exports-import System.IO.Error as Exports-import System.IO.Unsafe as Exports-import System.Mem as Exports-import System.Mem.StableName as Exports-import System.Timeout as Exports-import Text.Printf as Exports (hPrintf, printf)-import Text.Read as Exports (Read (..), readEither, readMaybe)-import Unsafe.Coerce as Exports-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.-suffixRec :: (Monad m, Alternative m) => m a -> (a -> m a) -> m a-suffixRec base suffix = do-  _base <- base-  suffixRec (suffix _base) suffix <|> pure _base

@@ -0,0 +1,279 @@+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:+    --+    --  >>> :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)))++    -- ** Row-parsing statements+    singletonStatement,+    maybeStatement,+    vectorStatement,+    foldStatement,++    -- ** Row-ignoring statements+    resultlessStatement,+    rowsAffectedStatement,++    -- * SQL ByteStrings++    -- |+    --  ByteString-producing quasiquoters.+    --+    --  For now they perform no compile-time checking.+    uncheckedSql,+    uncheckedSqlFile,+  )+where++import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Hasql.TH.Construction.Exp as Exp+import qualified Hasql.TH.Extraction.Exp as ExpExtraction+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++expParser :: (Text -> Either Text Exp) -> QuasiQuoter+expParser _parser =+  exp $ \_inputString -> either (fail . Text.unpack) return $ _parser $ fromString _inputString++expPreparableStmtAstParser :: (Ast.PreparableStmt -> Either Text Exp) -> QuasiQuoter+expPreparableStmtAstParser _parser =+  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+--   |      ^+-- ...+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)+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)+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+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) ()+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+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.+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|]+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

@@ -0,0 +1,201 @@+-- |+-- Expression construction.+module Hasql.TH.Construction.Exp where++import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Unsafe as ByteString+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 (sequence_)+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++byteString :: ByteString -> Exp+byteString x =+  appList+    (VarE 'unsafeDupablePerformIO)+    [ appList+        (VarE 'ByteString.unsafePackAddressLen)+        [ LitE (IntegerL (fromIntegral (ByteString.length x))),+          LitE (StringPrimL (ByteString.unpack x))+        ]+    ]++integral :: (Integral a) => a -> Exp+integral x = LitE (IntegerL (fromIntegral x))++list :: (a -> Exp) -> [a] -> Exp+list renderer x = ListE (map renderer x)++string :: String -> Exp+string x = LitE (StringL x)++char :: Char -> Exp+char x = LitE (CharL x)++sequence_ :: [Exp] -> Exp+sequence_ = foldl' andThen pureUnit++pureUnit :: Exp+pureUnit = AppE (VarE 'Prelude.pure) (TupE [])++andThen :: Exp -> Exp -> Exp+andThen exp1 exp2 = AppE (AppE (VarE '(*>)) exp1) exp2++tuple :: Int -> Exp+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++-- |+-- 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+  _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+              [Compat.specifiedPlainTV _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 ()+--+-- >>> $(return (cozip (fmap (AppE (ConE 'Just) . LitE . IntegerL) [1,2,3]))) :: Maybe (Int, Int, Int)+-- Just (1,2,3)+cozip :: [Exp] -> Exp+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+  [] -> AppE (VarE 'pure) (TupE [])++-- |+-- Lambda expression, which destructures 'Fold'.+foldLam :: (Exp -> Exp -> Exp -> Exp) -> Exp+foldLam _body =+  let _stepVarName = mkName "progress"+      _initVarName = mkName "start"+      _extractVarName = mkName "finish"+   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 =+  appList (VarE 'Statement.preparable) [_sql, _encoder, _decoder]++noResultResultDecoder :: Exp+noResultResultDecoder = VarE 'Decoders.noResult++rowsAffectedResultDecoder :: Exp+rowsAffectedResultDecoder = VarE 'Decoders.rowsAffected++singleRowResultDecoder :: Exp -> Exp+singleRowResultDecoder = 'Decoders.singleRow & VarE & AppE++rowMaybeResultDecoder :: Exp -> Exp+rowMaybeResultDecoder = AppE (VarE 'Decoders.rowMaybe)++rowVectorResultDecoder :: Exp -> Exp+rowVectorResultDecoder = AppE (VarE 'Decoders.rowVector)++foldStatement :: Exp -> Exp -> Exp -> Exp+foldStatement _sql _encoder _rowDecoder =+  foldLam (\_step _init _extract -> statement _sql _encoder (foldResultDecoder _step _init _extract _rowDecoder))++foldResultDecoder :: Exp -> Exp -> Exp -> Exp -> Exp+foldResultDecoder _step _init _extract _rowDecoder =+  appList (VarE 'fmap) [_extract, appList (VarE 'Decoders.foldlRows) [_step, _init, _rowDecoder]]++unidimensionalParamEncoder :: Bool -> Exp -> Exp+unidimensionalParamEncoder nullable =+  applyParamToEncoder . applyNullabilityToEncoder nullable++multidimensionalParamEncoder :: Bool -> Int -> Bool -> Exp -> Exp+multidimensionalParamEncoder nullable dimensionality arrayNull =+  applyParamToEncoder+    . applyNullabilityToEncoder arrayNull+    . AppE (VarE 'Encoders.array)+    . applyArrayDimensionalityToEncoder dimensionality+    . applyNullabilityToEncoder nullable++applyParamToEncoder :: Exp -> Exp+applyParamToEncoder = AppE (VarE 'Encoders.param)++applyNullabilityToEncoder :: Bool -> Exp -> Exp+applyNullabilityToEncoder nullable = AppE (VarE (if nullable then 'Encoders.nullable else 'Encoders.nonNullable))++applyArrayDimensionalityToEncoder :: Int -> Exp -> Exp+applyArrayDimensionalityToEncoder levels =+  if levels > 0+    then AppE (AppE (VarE 'Encoders.dimension) (VarE 'Vector.foldl')) . applyArrayDimensionalityToEncoder (pred levels)+    else AppE (VarE 'Encoders.element)++rowDecoder :: [Exp] -> Exp+rowDecoder = cozip++unidimensionalColumnDecoder :: Bool -> Exp -> Exp+unidimensionalColumnDecoder nullable =+  applyColumnToDecoder . applyNullabilityToDecoder nullable++multidimensionalColumnDecoder :: Bool -> Int -> Bool -> Exp -> Exp+multidimensionalColumnDecoder nullable dimensionality arrayNull =+  applyColumnToDecoder+    . applyNullabilityToDecoder arrayNull+    . AppE (VarE 'Decoders.array)+    . applyArrayDimensionalityToDecoder dimensionality+    . applyNullabilityToDecoder nullable++applyColumnToDecoder :: Exp -> Exp+applyColumnToDecoder = AppE (VarE 'Decoders.column)++applyNullabilityToDecoder :: Bool -> Exp -> Exp+applyNullabilityToDecoder nullable = AppE (VarE (if nullable then 'Decoders.nullable else 'Decoders.nonNullable))++applyArrayDimensionalityToDecoder :: Int -> Exp -> Exp+applyArrayDimensionalityToDecoder levels =+  if levels > 0+    then AppE (AppE (VarE 'Decoders.dimension) (VarE 'Vector.replicateM)) . applyArrayDimensionalityToDecoder (pred levels)+    else AppE (VarE 'Decoders.element)

@@ -0,0 +1,611 @@+{-# OPTIONS_GHC -Wno-unused-binds -Wno-unused-imports -Wno-name-shadowing -Wno-incomplete-patterns -Wno-unused-matches -Wno-missing-methods -Wno-unused-record-wildcards -Wno-redundant-constraints -Wno-deprecations -Wno-missing-signatures #-}++module Hasql.TH.Extraction.ChildExprList where++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+  AChildExpr a -> aChildExpr a+  BChildExpr a -> bChildExpr a+  CChildExpr a -> cChildExpr a++aChildExpr = \case+  CExprAExpr a -> cChildExpr a+  TypecastAExpr a b -> aExpr a <> typename b+  CollateAExpr a b -> aExpr a <> anyName b+  AtTimeZoneAExpr a b -> aExpr a <> aExpr b+  PlusAExpr a -> aExpr a+  MinusAExpr a -> aExpr a+  SymbolicBinOpAExpr a b c -> aExpr a <> symbolicExprBinOp b <> aExpr c+  PrefixQualOpAExpr a b -> qualOp a <> aExpr b+  SuffixQualOpAExpr a b -> aExpr a <> qualOp b+  AndAExpr a b -> aExpr a <> aExpr b+  OrAExpr a b -> aExpr a <> aExpr b+  NotAExpr a -> aExpr a+  VerbalExprBinOpAExpr a b c d e -> aExpr a <> verbalExprBinOp c <> aExpr d <> foldMap aExpr e+  ReversableOpAExpr a b c -> aExpr a <> aExprReversableOp c+  IsnullAExpr a -> aExpr a+  NotnullAExpr a -> aExpr a+  OverlapsAExpr a b -> row a <> row b+  SubqueryAExpr a b c d -> aExpr a <> subqueryOp b <> subType c <> either selectWithParens aExpr d+  UniqueAExpr a -> selectWithParens a+  DefaultAExpr -> []++bChildExpr = \case+  CExprBExpr a -> cChildExpr a+  TypecastBExpr a b -> bExpr a <> typename b+  PlusBExpr a -> bExpr a+  MinusBExpr a -> bExpr a+  SymbolicBinOpBExpr a b c -> bExpr a <> symbolicExprBinOp b <> bExpr c+  QualOpBExpr a b -> qualOp a <> bExpr b+  IsOpBExpr a b c -> bExpr a <> bExprIsOp c++cChildExpr = \case+  ColumnrefCExpr a -> columnref a+  AexprConstCExpr a -> aexprConst a+  ParamCExpr a b -> foldMap indirection b+  InParensCExpr a b -> aExpr a <> foldMap indirection b+  CaseCExpr a -> caseExpr a+  FuncCExpr a -> funcExpr a+  SelectWithParensCExpr a b -> selectWithParens a <> foldMap indirection b+  ExistsCExpr a -> selectWithParens a+  ArrayCExpr a -> either selectWithParens arrayExpr a+  ExplicitRowCExpr a -> explicitRow a+  ImplicitRowCExpr a -> implicitRow a+  GroupingCExpr a -> exprList a++preparableStmt = \case+  SelectPreparableStmt a -> selectStmt a+  InsertPreparableStmt a -> insertStmt a+  UpdatePreparableStmt a -> updateStmt a+  DeletePreparableStmt a -> deleteStmt a+  CallPreparableStmt a -> callStmt a++-- * Call++callStmt (CallStmt a) = funcApplication a++-- * Insert++insertStmt (InsertStmt a b c d e) =+  foldMap withClause a+    <> insertTarget b+    <> insertRest c+    <> foldMap onConflict d+    <> foldMap returningClause e++insertTarget (InsertTarget a b) = qualifiedName a <> colId b++insertRest = \case+  SelectInsertRest a b c -> foldMap insertColumnList a <> foldMap overrideKind b <> selectStmt c+  DefaultValuesInsertRest -> []++overrideKind _ = []++insertColumnList = foldMap insertColumnItem++insertColumnItem (InsertColumnItem a b) = colId a <> foldMap indirection b++onConflict (OnConflict a b) = foldMap confExpr a <> onConflictDo b++onConflictDo = \case+  UpdateOnConflictDo b c -> setClauseList b <> foldMap whereClause c+  NothingOnConflictDo -> []++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++setClauseList = foldMap setClause++setClause = \case+  TargetSetClause a b -> setTarget a <> aExpr b+  TargetListSetClause a b -> setTargetList a <> aExpr b++setTarget (SetTarget a b) = colId a <> foldMap indirection b++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++usingClause = fromList++-- * Select++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++selectWithParens = \case+  NoParensSelectWithParens a -> selectNoParens a+  WithParensSelectWithParens a -> selectWithParens a++withClause (WithClause _ a) = foldMap commonTableExpr a++commonTableExpr (CommonTableExpr a b c d) = preparableStmt d++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+  LimitLimitClause a b -> selectLimitValue a <> exprList b+  FetchOnlyLimitClause a b c -> foldMap selectFetchFirstValue b++offsetClause = \case+  ExprOffsetClause a -> aExpr a+  FetchFirstOffsetClause a b -> selectFetchFirstValue a++selectFetchFirstValue = \case+  ExprSelectFetchFirstValue a -> cExpr a+  NumSelectFetchFirstValue _ _ -> []++selectLimitValue = \case+  ExprSelectLimitValue a -> aExpr a+  AllSelectLimitValue -> []++forLockingClause = \case+  ItemsForLockingClause a -> foldMap forLockingItem a+  ReadOnlyForLockingClause -> []++forLockingItem (ForLockingItem a b c) =+  foldMap (foldMap qualifiedName) b++selectClause = either simpleSelect selectWithParens++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+  ValuesSimpleSelect a -> valuesClause a+  TableSimpleSelect a -> relationExpr a+  BinSimpleSelect _ a _ b -> selectClause a <> selectClause b++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+  AliasedExprTargetEl a _ -> aExpr a+  ImplicitlyAliasedExprTargetEl a _ -> aExpr a+  ExprTargetEl a -> aExpr a+  AsteriskTargetEl -> []++intoClause = optTempTableName++fromClause = fromList++fromList = foldMap tableRef++whereClause = aExpr++whereOrCurrentClause = \case+  ExprWhereOrCurrentClause a -> aExpr a+  CursorWhereOrCurrentClause a -> cursorName a++groupClause = foldMap groupByItem++havingClause = aExpr++windowClause = foldMap windowDefinition++valuesClause = foldMap exprList++optTempTableName _ = []++groupByItem = \case+  ExprGroupByItem a -> aExpr a+  EmptyGroupingSetGroupByItem -> []+  RollupGroupByItem a -> exprList a+  CubeGroupByItem a -> exprList a+  GroupingSetsGroupByItem a -> foldMap groupByItem a++windowDefinition (WindowDefinition _ a) = windowSpecification a++windowSpecification (WindowSpecification _ a b c) = foldMap (foldMap aExpr) a <> foldMap sortClause b <> foldMap frameClause c++frameClause (FrameClause _ a _) = frameExtent a++frameExtent = \case+  SingularFrameExtent a -> frameBound a+  BetweenFrameExtent a b -> frameBound a <> frameBound b++frameBound = \case+  UnboundedPrecedingFrameBound -> []+  UnboundedFollowingFrameBound -> []+  CurrentRowFrameBound -> []+  PrecedingFrameBound a -> aExpr a+  FollowingFrameBound a -> aExpr a++sortClause = foldMap sortBy++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+  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+  SimpleRelationExpr a _ -> qualifiedName a+  OnlyRelationExpr a _ -> qualifiedName a++relationExprOptAlias (RelationExprOptAlias a b) = relationExpr a <> foldMap (colId . snd) b++tablesampleClause (TablesampleClause a b c) = funcName a <> exprList b <> foldMap repeatableClause c++repeatableClause = aExpr++funcTable = \case+  FuncExprFuncTable a b -> funcExprWindowless a <> optOrdinality b+  RowsFromFuncTable a b -> rowsfromList a <> optOrdinality b++rowsfromItem (RowsfromItem a b) = funcExprWindowless a <> foldMap colDefList b++rowsfromList = foldMap rowsfromItem++colDefList = tableFuncElementList++optOrdinality = const []++tableFuncElementList = foldMap tableFuncElement++tableFuncElement (TableFuncElement a b c) = colId a <> typename b <> foldMap collateClause c++collateClause = anyName++aliasClause = const []++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+  InParensJoinedTable a -> joinedTable a+  MethJoinedTable a b c -> joinMeth a <> tableRef b <> tableRef c++joinMeth = \case+  CrossJoinMeth -> []+  QualJoinMeth _ a -> joinQual a+  NaturalJoinMeth _ -> []++joinQual = \case+  UsingJoinQual _ -> []+  OnJoinQual a -> aExpr a++exprList = fmap AChildExpr . toList++aExpr = pure . AChildExpr++bExpr = pure . BChildExpr++cExpr = pure . CChildExpr++funcExpr = \case+  ApplicationFuncExpr a b c d -> funcApplication a <> foldMap withinGroupClause b <> foldMap filterClause c <> foldMap overClause d+  SubexprFuncExpr a -> funcExprCommonSubexpr a++funcExprWindowless = \case+  ApplicationFuncExprWindowless a -> funcApplication a+  CommonSubexprFuncExprWindowless a -> funcExprCommonSubexpr a++withinGroupClause = sortClause++filterClause a = aExpr a++overClause = \case+  WindowOverClause a -> windowSpecification a+  ColIdOverClause _ -> []++funcExprCommonSubexpr = \case+  CollationForFuncExprCommonSubexpr a -> aExpr a+  CurrentDateFuncExprCommonSubexpr -> []+  CurrentTimeFuncExprCommonSubexpr _ -> []+  CurrentTimestampFuncExprCommonSubexpr _ -> []+  LocalTimeFuncExprCommonSubexpr _ -> []+  LocalTimestampFuncExprCommonSubexpr _ -> []+  CurrentRoleFuncExprCommonSubexpr -> []+  CurrentUserFuncExprCommonSubexpr -> []+  SessionUserFuncExprCommonSubexpr -> []+  UserFuncExprCommonSubexpr -> []+  CurrentCatalogFuncExprCommonSubexpr -> []+  CurrentSchemaFuncExprCommonSubexpr -> []+  CastFuncExprCommonSubexpr a b -> aExpr a <> typename b+  ExtractFuncExprCommonSubexpr a -> foldMap extractList a+  OverlayFuncExprCommonSubexpr a -> overlayList a+  PositionFuncExprCommonSubexpr a -> foldMap positionList a+  SubstringFuncExprCommonSubexpr a -> foldMap substrList a+  TreatFuncExprCommonSubexpr a b -> aExpr a <> typename b+  TrimFuncExprCommonSubexpr a b -> foldMap trimModifier a <> trimList b+  NullIfFuncExprCommonSubexpr a b -> aExpr a <> aExpr b+  CoalesceFuncExprCommonSubexpr a -> exprList a+  GreatestFuncExprCommonSubexpr a -> exprList a+  LeastFuncExprCommonSubexpr a -> exprList a++extractList (ExtractList a b) = extractArg a <> aExpr b++extractArg _ = []++overlayList (OverlayList a b c d) = foldMap aExpr ([a, b, c] <> toList d)++positionList (PositionList a b) = bExpr a <> bExpr b++substrList = \case+  ExprSubstrList a b -> aExpr a <> substrListFromFor b+  ExprListSubstrList a -> exprList a++substrListFromFor = \case+  FromForSubstrListFromFor a b -> aExpr a <> aExpr b+  ForFromSubstrListFromFor a b -> aExpr a <> aExpr b+  FromSubstrListFromFor a -> aExpr a+  ForSubstrListFromFor a -> aExpr a++trimModifier _ = []++trimList = \case+  ExprFromExprListTrimList a b -> aExpr a <> exprList b+  FromExprListTrimList 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+  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+  ExprFuncArgExpr a -> aExpr a+  ColonEqualsFuncArgExpr _ a -> aExpr a+  EqualsGreaterFuncArgExpr _ a -> aExpr a++caseExpr (CaseExpr a b c) = foldMap aExpr a <> whenClauseList b <> foldMap aExpr c++whenClauseList = foldMap whenClause++arrayExpr = \case+  ExprListArrayExpr a -> exprList a+  ArrayExprListArrayExpr a -> arrayExprList a+  EmptyArrayExpr -> []++arrayExprList = foldMap arrayExpr++inExpr = \case+  SelectInExpr a -> selectWithParens a+  ExprListInExpr a -> exprList a++-- * Operators++symbolicExprBinOp = \case+  MathSymbolicExprBinOp a -> mathOp a+  QualSymbolicExprBinOp a -> qualOp a++qualOp = \case+  OpQualOp a -> op a+  OperatorQualOp a -> anyOperator a++qualAllOp = \case+  AllQualAllOp a -> allOp a+  AnyQualAllOp a -> anyOperator a++verbalExprBinOp = const []++aExprReversableOp = \case+  NullAExprReversableOp -> []+  TrueAExprReversableOp -> []+  FalseAExprReversableOp -> []+  UnknownAExprReversableOp -> []+  DistinctFromAExprReversableOp a -> aExpr a+  OfAExprReversableOp a -> typeList a+  BetweenAExprReversableOp a b c -> bExpr b <> aExpr c+  BetweenSymmetricAExprReversableOp a b -> bExpr a <> aExpr b+  InAExprReversableOp a -> inExpr a+  DocumentAExprReversableOp -> []++subqueryOp = \case+  AllSubqueryOp a -> allOp a+  AnySubqueryOp a -> anyOperator a+  LikeSubqueryOp _ -> []+  IlikeSubqueryOp _ -> []++bExprIsOp = \case+  DistinctFromBExprIsOp a -> bExpr a+  OfBExprIsOp a -> typeList a+  DocumentBExprIsOp -> []++allOp = \case+  OpAllOp a -> op a+  MathAllOp a -> mathOp a++anyOperator = \case+  AllOpAnyOperator a -> allOp a+  QualifiedAnyOperator a b -> colId a <> anyOperator b++op = const []++mathOp = const []++-- * Rows++row = \case+  ExplicitRowRow a -> explicitRow a+  ImplicitRowRow a -> implicitRow a++explicitRow = foldMap exprList++implicitRow (ImplicitRow a b) = exprList a <> aExpr b++-- * Constants++aexprConst = \case+  IAexprConst _ -> []+  FAexprConst _ -> []+  SAexprConst _ -> []+  BAexprConst _ -> []+  XAexprConst _ -> []+  FuncAexprConst a b _ -> funcName a <> foldMap funcConstArgs b+  ConstTypenameAexprConst a _ -> constTypename a+  StringIntervalAexprConst _ a -> foldMap interval a+  IntIntervalAexprConst _ _ -> []+  BoolAexprConst _ -> []+  NullAexprConst -> []++funcConstArgs (FuncConstArgs a b) = foldMap funcArgExpr a <> foldMap sortClause b++constTypename = \case+  NumericConstTypename a -> numeric a+  ConstBitConstTypename a -> constBit a+  ConstCharacterConstTypename a -> constCharacter a+  ConstDatetimeConstTypename a -> constDatetime a++numeric = \case+  IntNumeric -> []+  IntegerNumeric -> []+  SmallintNumeric -> []+  BigintNumeric -> []+  RealNumeric -> []+  FloatNumeric _ -> []+  DoublePrecisionNumeric -> []+  DecimalNumeric a -> foldMap exprList a+  DecNumeric a -> foldMap exprList a+  NumericNumeric a -> foldMap exprList a+  BooleanNumeric -> []++bit (Bit _ a) = foldMap exprList a++constBit = bit++constCharacter (ConstCharacter _ _) = []++constDatetime _ = []++interval _ = []++-- * Names++ident _ = []++colId = ident++name = colId++cursorName = name++anyName (AnyName a b) = colId a <> foldMap attrs b++columnref (Columnref a b) = colId a <> foldMap indirection b++funcName = \case+  TypeFuncName a -> typeFunctionName a+  IndirectedFuncName a b -> colId a <> indirection b++qualifiedName = \case+  SimpleQualifiedName _ -> []+  IndirectedQualifiedName _ a -> indirection a++indirection = foldMap indirectionEl++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+  GenericTypeSimpleTypename a -> genericType a+  NumericSimpleTypename a -> numeric a+  BitSimpleTypename a -> bit a+  CharacterSimpleTypename a -> character a+  ConstDatetimeSimpleTypename a -> constDatetime a+  ConstIntervalSimpleTypename a -> either (foldMap interval) (const []) a++arrayBounds _ = []++genericType (GenericType a b c) = typeFunctionName a <> foldMap attrs b <> foldMap typeModifiers c++typeFunctionName = ident++attrs = foldMap attrName++attrName _ = []++typeModifiers = exprList++character _ = []++subType _ = []++-- * Indexes++indexParams = foldMap indexElem++indexElem (IndexElem a b c d e) = indexElemDef a <> foldMap anyName b <> foldMap anyName c++indexElemDef = \case+  IdIndexElemDef a -> colId a+  FuncIndexElemDef a -> funcExprWindowless a+  ExprIndexElemDef a -> aExpr a++ascDesc = const []++nullsOrder = const []

@@ -0,0 +1,112 @@+module Hasql.TH.Extraction.Exp where++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 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))++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)++paramsEncoder :: Ast.PreparableStmt -> Either Text Exp+paramsEncoder a = do+  b <- InputTypeList.preparableStmt a+  c <- traverse paramEncoder b+  return (Exp.contrazip c)++rowDecoder :: Ast.PreparableStmt -> Either Text Exp+rowDecoder a = do+  b <- OutputTypeList.preparableStmt a+  c <- traverse columnDecoder b+  return (Exp.cozip c)++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))++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))++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) =+  if a+    then Left "SETOF is not supported"+    else do+      e <- PrimitiveType.simpleTypename b+      case d of+        Nothing -> unidimensional e c+        Just (f, g) -> case f of+          Ast.BoundsTypenameArrayDimensions h -> multidimensional e c (length h) g+          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++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

@@ -0,0 +1,52 @@+-- |+-- 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 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 ..]+  return (IntMap.elems a)

@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -Wno-unused-binds -Wno-unused-imports -Wno-name-shadowing -Wno-incomplete-patterns -Wno-unused-matches -Wno-missing-methods -Wno-unused-record-wildcards -Wno-redundant-constraints -Wno-deprecations -Wno-missing-signatures #-}++-- |+-- 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+  SelectPreparableStmt a -> selectStmt a+  InsertPreparableStmt a -> insertStmt a+  UpdatePreparableStmt a -> updateStmt a+  DeletePreparableStmt a -> deleteStmt a+  CallPreparableStmt a -> callStmt a++-- * Call++callStmt (CallStmt a) =+  Right []++-- * 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+  Left a -> selectNoParens a+  Right a -> selectWithParens a++selectNoParens (SelectNoParens _ a _ _ _) = selectClause a++selectWithParens = \case+  NoParensSelectWithParens a -> selectNoParens a+  WithParensSelectWithParens a -> selectWithParens a++selectClause = either simpleSelect selectWithParens++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"+  BinSimpleSelect _ a _ b -> do+    c <- selectClause a+    d <- selectClause b+    if c == d+      then return c+      else Left "Merged queries produce results of incompatible types"++targeting = \case+  NormalTargeting a -> targetList a+  AllTargeting a -> foldable targetList a+  DistinctTargeting _ b -> targetList b++targetList = foldable targetEl++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."++valuesClause = foldable (foldable aExpr)++aExpr = \case+  CExprAExpr a -> cExpr a+  TypecastAExpr _ a -> Right [a]+  a -> Left "Result expression is missing a typecast"++cExpr = \case+  InParensCExpr a Nothing -> aExpr a+  a -> Left "Result expression is missing a typecast"

@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Hasql.TH.Extraction.PlaceholderTypeMap where++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++childExprList :: [ChildExpr] -> Either Text (IntMap Typename)+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"))++childExpr :: ChildExpr -> Either Text (IntMap Typename)+childExpr = \case+  AChildExpr a -> aExpr a+  BChildExpr a -> bExpr a+  CChildExpr a -> cExpr a++aExpr = \case+  CExprAExpr a -> cExpr a+  TypecastAExpr a b -> castedAExpr b a+  a -> childExprList (ChildExprList.aChildExpr a)++bExpr = \case+  CExprBExpr a -> cExpr a+  TypecastBExpr a b -> castedBExpr b a+  a -> childExprList (ChildExprList.bChildExpr a)++cExpr = \case+  ParamCExpr a _ -> Left ("Placeholder $" <> (fromString . show) a <> " misses an explicit typecast")+  a -> childExprList (ChildExprList.cChildExpr a)++castedAExpr a = \case+  CExprAExpr b -> castedCExpr a b+  TypecastAExpr b c -> castedAExpr c b+  b -> aExpr b++castedBExpr a = \case+  CExprBExpr b -> castedCExpr a b+  TypecastBExpr b c -> castedBExpr c b+  b -> bExpr b++castedCExpr a = \case+  ParamCExpr b _ -> Right (IntMap.singleton b a)+  InParensCExpr b _ -> castedAExpr a b+  b -> cExpr b

@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -Wno-unused-binds -Wno-unused-imports -Wno-name-shadowing -Wno-incomplete-patterns -Wno-unused-matches -Wno-missing-methods -Wno-unused-record-wildcards -Wno-redundant-constraints -Wno-deprecations -Wno-missing-signatures #-}++module Hasql.TH.Extraction.PrimitiveType where++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++simpleTypename = \case+  GenericTypeSimpleTypename a -> genericType a+  NumericSimpleTypename a -> numeric a+  BitSimpleTypename a -> bit a+  CharacterSimpleTypename a -> character a+  ConstDatetimeSimpleTypename a -> constDatetime a+  ConstIntervalSimpleTypename a -> Right IntervalPrimitiveType++genericType (GenericType a b c) = case b of+  Just _ -> Left "Type attributes are not supported"+  Nothing -> case c of+    Just _ -> Left "Type modifiers are not supported"+    Nothing -> ident a++numeric = \case+  IntNumeric -> Right Int4PrimitiveType+  IntegerNumeric -> Right Int4PrimitiveType+  SmallintNumeric -> Right Int2PrimitiveType+  BigintNumeric -> Right Int8PrimitiveType+  RealNumeric -> Right Float4PrimitiveType+  FloatNumeric a -> case a of+    Just _ -> Left "Modifier on FLOAT is not supported"+    Nothing -> Right Float4PrimitiveType+  DoublePrecisionNumeric -> Right Float8PrimitiveType+  DecimalNumeric a -> case a of+    Just _ -> Left "Modifiers on DECIMAL are not supported"+    Nothing -> Right NumericPrimitiveType+  DecNumeric a -> case a of+    Just _ -> Left "Modifiers on DEC are not supported"+    Nothing -> Right NumericPrimitiveType+  NumericNumeric a -> case a of+    Just _ -> Left "Modifiers on NUMERIC are not supported"+    Nothing -> Right NumericPrimitiveType+  BooleanNumeric -> Right BoolPrimitiveType++bit _ = Left "Bit codec is not supported"++character _ = Right CharPrimitiveType++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+      Just a -> a+      Nothing -> False++ident = \case+  QuotedIdent a -> name a+  UnquotedIdent a -> name a++name = \case+  "bool" -> Right BoolPrimitiveType+  "int2" -> Right Int2PrimitiveType+  "int4" -> Right Int4PrimitiveType+  "int8" -> Right Int8PrimitiveType+  "float4" -> Right Float4PrimitiveType+  "float8" -> Right Float8PrimitiveType+  "numeric" -> Right NumericPrimitiveType+  "char" -> Right CharPrimitiveType+  "text" -> Right TextPrimitiveType+  "bytea" -> Right ByteaPrimitiveType+  "date" -> Right DatePrimitiveType+  "timestamp" -> Right TimestampPrimitiveType+  "timestamptz" -> Right TimestamptzPrimitiveType+  "time" -> Right TimePrimitiveType+  "timetz" -> Right TimetzPrimitiveType+  "interval" -> Right IntervalPrimitiveType+  "uuid" -> Right UuidPrimitiveType+  "inet" -> Right InetPrimitiveType+  "json" -> Right JsonPrimitiveType+  "jsonb" -> Right JsonbPrimitiveType+  name -> Left ("No codec exists for type: " <> name)

@@ -0,0 +1,94 @@+module Hasql.TH.Prelude+  ( module Exports,+    showAsText,+    suffixRec,+  )+where++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.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+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports hiding (unzip)+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports+import Data.Functor.Identity 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 (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 (First (..), Last (..), (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio 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+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+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 System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+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.+suffixRec :: (Monad m, Alternative m) => m a -> (a -> m a) -> m a+suffixRec base suffix = do+  _base <- base+  suffixRec (suffix _base) suffix <|> pure _base