hasql-th 0.2.1 → 0.3
raw patch · 20 files changed
+8058/−111 lines, 20 filesdep +basedep +case-insensitivedep +containersdep −base-preludedep ~bytestringdep ~template-haskelldep ~textPVP ok
version bump matches the API change (PVP)
Dependencies added: base, case-insensitive, containers, contravariant, fast-builder, foldl, hashable, hasql, headed-megaparsec, hedgehog, megaparsec, parser-combinators, selective, text-builder, tuple-th, unordered-containers, uuid, vector
Dependencies removed: base-prelude
Dependency ranges changed: bytestring, template-haskell, text
API changes (from Hackage documentation)
- Hasql.TH: readFileAsSQL :: String -> Q Exp
+ Hasql.TH: foldStatement :: QuasiQuoter
+ Hasql.TH: maybeStatement :: QuasiQuoter
+ Hasql.TH: resultlessStatement :: QuasiQuoter
+ Hasql.TH: rowsAffectedStatement :: QuasiQuoter
+ Hasql.TH: singletonStatement :: QuasiQuoter
+ Hasql.TH: uncheckedSql :: QuasiQuoter
+ Hasql.TH: uncheckedSqlFile :: QuasiQuoter
+ Hasql.TH: vectorStatement :: QuasiQuoter
Files
- hasql-th.cabal +104/−49
- library/Hasql/TH.hs +205/−22
- library/Hasql/TH/Exp.hs +231/−0
- library/Hasql/TH/Extras/HeadedMegaparsec.hs +125/−0
- library/Hasql/TH/Extras/NonEmpty.hs +33/−0
- library/Hasql/TH/Prelude.hs +120/−2
- library/Hasql/TH/Renderers.hs +0/−38
- library/Hasql/TH/Syntax/Ast.hs +2052/−0
- library/Hasql/TH/Syntax/Extraction.hs +106/−0
- library/Hasql/TH/Syntax/HashSet.hs +70/−0
- library/Hasql/TH/Syntax/Parsing.hs +2136/−0
- library/Hasql/TH/Syntax/Predicate.hs +69/−0
- library/Hasql/TH/Syntax/Projections/ChildExprList.hs +638/−0
- library/Hasql/TH/Syntax/Projections/InputTypeList.hs +47/−0
- library/Hasql/TH/Syntax/Projections/OutputTypeList.hs +94/−0
- library/Hasql/TH/Syntax/Projections/PlaceholderTypeMap.hs +55/−0
- library/Hasql/TH/Syntax/Rendering.hs +958/−0
- library/Hasql/TH/Syntax/Validator.hs +48/−0
- test/Main.hs +36/−0
- test/Main/Gen.hs +931/−0
hasql-th.cabal view
@@ -1,56 +1,111 @@-name:- hasql-th-version:- 0.2.1-category:- Hasql, Database, PostgreSQL, Template Haskell-synopsis:- Template Haskell utilities for Hasql-homepage:- https://github.com/nikita-volkov/hasql-th -bug-reports:- https://github.com/nikita-volkov/hasql-th/issues -author:- Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:- Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:- (c) 2015, Nikita Volkov-license:- MIT-license-file:- LICENSE-build-type:- Simple-cabal-version:- >=1.10-+name: hasql-th+version: 0.3+category: Hasql, Database, PostgreSQL, Template Haskell+synopsis: Template Haskell utilities for Hasql+description:+ Extension-library for Hasql,+ bringing compile-time syntax checking,+ great simplification of declaration of statements and+ other TemplateHaskell-based utilities.+homepage: https://github.com/nikita-volkov/hasql-th+bug-reports: https://github.com/nikita-volkov/hasql-th/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2015, Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10 source-repository head- type:- git- location:- git://github.com/nikita-volkov/hasql-th.git-+ type: git+ location: git://github.com/nikita-volkov/hasql-th.git library- hs-source-dirs:- library- ghc-options:- default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010- other-modules:- Hasql.TH.Prelude- Hasql.TH.Renderers+ hs-source-dirs: library+ default-extensions: ApplicativeDo, Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language: Haskell2010 exposed-modules: Hasql.TH+ other-modules:+ Hasql.TH.Exp+ Hasql.TH.Extras.HeadedMegaparsec+ Hasql.TH.Extras.NonEmpty+ Hasql.TH.Prelude+ Hasql.TH.Syntax.Ast+ Hasql.TH.Syntax.HashSet+ Hasql.TH.Syntax.Extraction+ Hasql.TH.Syntax.Parsing+ Hasql.TH.Syntax.Predicate+ Hasql.TH.Syntax.Projections.ChildExprList+ Hasql.TH.Syntax.Projections.InputTypeList+ Hasql.TH.Syntax.Projections.OutputTypeList+ Hasql.TH.Syntax.Projections.PlaceholderTypeMap+ Hasql.TH.Syntax.Rendering+ Hasql.TH.Syntax.Validator build-depends:- -- template-haskell:- template-haskell >= 2.8 && < 3,- -- data:- bytestring >= 0.10 && < 0.11,- text >= 1 && < 2,- -- general:- base-prelude >= 0.1.19 && < 2+ base >=4.11 && <5,+ bytestring >=0.10 && <0.11,+ case-insensitive >=1.2 && <2,+ containers >=0.6 && <0.7,+ contravariant >=1.5.2 && <2,+ fast-builder >=0.1.2 && <0.2,+ foldl >=1.4.5 && <2,+ hashable >=1.2 && <2,+ hasql >=1.4 && <1.5,+ headed-megaparsec >=0.1 && <0.2,+ megaparsec >=7 && <9,+ parser-combinators >=1.1 && <1.3,+ selective >=0.3 && <0.4,+ template-haskell >=2.8 && <3,+ text >=1 && <2,+ text-builder >=0.6.6.1 && <0.7,+ tuple-th >=0.2.5 && <0.3,+ unordered-containers >=0.2.10 && <0.3,+ uuid >=1.3 && <2,+ vector >=0.12 && <0.13++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test, library+ default-extensions: ApplicativeDo, Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language: Haskell2010+ main-is: Main.hs+ other-modules:+ Hasql.TH.Extras.HeadedMegaparsec+ Hasql.TH.Extras.NonEmpty+ Hasql.TH.Prelude+ Hasql.TH.Syntax.Ast+ Hasql.TH.Syntax.HashSet+ Hasql.TH.Syntax.Extraction+ Hasql.TH.Syntax.Parsing+ Hasql.TH.Syntax.Predicate+ Hasql.TH.Syntax.Projections.ChildExprList+ Hasql.TH.Syntax.Projections.InputTypeList+ Hasql.TH.Syntax.Projections.OutputTypeList+ Hasql.TH.Syntax.Projections.PlaceholderTypeMap+ Hasql.TH.Syntax.Rendering+ Hasql.TH.Syntax.Validator+ Main.Gen+ build-depends:+ base,+ bytestring,+ case-insensitive,+ containers,+ contravariant,+ fast-builder,+ foldl,+ hashable,+ hasql,+ headed-megaparsec,+ hedgehog >=1.0.1 && <2,+ megaparsec,+ parser-combinators,+ selective,+ template-haskell,+ text,+ text-builder,+ tuple-th,+ unordered-containers,+ uuid,+ vector
library/Hasql/TH.hs view
@@ -1,31 +1,214 @@ module Hasql.TH (- readFileAsSQL,+ -- * 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+ > |]+ + === Nullability++ 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 Int32 =>+ Statement () (Maybe (v 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 Hasql.TH.Prelude+import Hasql.TH.Prelude hiding (exp)+import Hasql.Statement (Statement)+import Data.Vector (Vector) import Language.Haskell.TH.Syntax-import qualified Hasql.TH.Renderers as Renderers-import qualified Data.ByteString+import Language.Haskell.TH.Quote+import qualified Hasql.TH.Exp as Exp+import qualified Hasql.TH.Syntax.Extraction as Extraction+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text --- |--- 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 $(Hasql.TH.readFileAsSQL "sql/migration-1.sql")--- -readFileAsSQL :: String -> Q Exp-readFileAsSQL =- fmap Renderers.byteStringExp . readFileAsBytes+-- * Helpers+------------------------- -readFileAsBytes :: String -> Q ByteString-readFileAsBytes =- (*>) <$> addDependentFile <*> runIO . Data.ByteString.readFile+exp :: (String -> Q Exp) -> QuasiQuoter+exp = let+ _unsupported _ = fail "Unsupported"+ in \ _exp -> QuasiQuoter _exp _unsupported _unsupported _unsupported++statementExp :: (Extraction.Statement -> Exp) -> (Text -> Either Text Extraction.Statement) -> QuasiQuoter+statementExp _exp _extract = exp (either (fail . Text.unpack) (return . _exp) . _extract . fromString)+++-- * Statements+-------------------------++{-|+Statement producing exactly one result row.++Will raise `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+ | ^^^^^^+unexpected "elect "+...+-}+singletonStatement :: QuasiQuoter+singletonStatement = statementExp Exp.singletonStatement Extraction.statement++{-|+Statement producing one row or none.++>>> :t [maybeStatement|select 1 :: int2|]+... :: Statement () (Maybe Int16)+-}+maybeStatement :: QuasiQuoter+maybeStatement = statementExp Exp.maybeStatement Extraction.statement++{-|+Statement producing a vector of rows.++>>> :t [vectorStatement|select 1 :: int2|]+... :: Statement () (Vector Int16)+-}+vectorStatement :: QuasiQuoter+vectorStatement = statementExp Exp.vectorStatement Extraction.statement++{-|+Function from `Fold` over rows to a statement producing the result of folding.+Use this when you need to aggregate rows customly.++>>> :t [foldStatement|select 1 :: int2|]+... :: Fold Int16 b -> Statement () b+-}+foldStatement :: QuasiQuoter+foldStatement = statementExp Exp.foldStatement Extraction.statement++{-|+Statement producing no results.++>>> :t [resultlessStatement|insert into "user" (name, email) values ($1 :: text, $2 :: text)|]+...+... :: Statement (Text, Text) ()+-}+resultlessStatement :: QuasiQuoter+resultlessStatement = statementExp Exp.resultlessStatement Extraction.rowlessStatement++{-|+Statement counting the rows it affects.++>>> :t [rowsAffectedStatement|delete from "user" where password is null|]+...+... :: Statement () Int64+-}+rowsAffectedStatement :: QuasiQuoter+rowsAffectedStatement = statementExp Exp.rowsAffectedStatement Extraction.rowlessStatement+++-- * 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+-}
+ library/Hasql/TH/Exp.hs view
@@ -0,0 +1,231 @@+module Hasql.TH.Exp where++import Hasql.TH.Prelude hiding (sequence_, string, list)+import Language.Haskell.TH+import qualified Hasql.TH.Prelude as Prelude+import qualified Hasql.TH.Syntax.Extraction as Extraction+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Statement as Statement+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Unsafe as ByteString+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Vector.Generic as Vector+import qualified TupleTH+++-- * 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 = unsafePerformIO $ runQ $ TupleTH.splitTupleAt arity position++{-|+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 [PlainTV _fName] [AppT (ConT ''Divisible) (VarT _fName)]+ (AppT (VarT _fName) (TupleT 0)))++{-|+Given a list of applicative functor expressions,+constructs an expression, which composes them together into+a single applicative functor, parameterized by a tuple of according arity.++>>> $(return (cozip [])) :: Maybe ()+Just ()++>>> $(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 [])+++-- * Statement+-------------------------++statement :: ([Extraction.Decoder] -> Exp) -> Extraction.Statement -> Exp+statement _decodersExp (Extraction.Statement _sql _encoders _decoders) =+ appList+ (ConE 'Statement.Statement)+ [+ byteString _sql,+ encoderList _encoders,+ _decodersExp _decoders,+ ConE 'True+ ]++resultlessStatement :: Extraction.Statement -> Exp+resultlessStatement = statement (const (VarE 'Decoders.noResult))++rowsAffectedStatement :: Extraction.Statement -> Exp+rowsAffectedStatement = statement (const (VarE 'Decoders.rowsAffected))++rowStatement :: Name -> Extraction.Statement -> Exp+rowStatement _rowDecoderName = statement (\ _decoders -> AppE (VarE _rowDecoderName) (decoderList _decoders))++{-|+>>> test = either (fail . show) (return . singletonStatement) . Extraction.statement++>>> :t $(test "select 1 :: int4")+$(test "select 1 :: int4") :: Statement.Statement () Int32++>>> :t $(test "select 1 :: int4, b :: text")+$(test "select 1 :: int4, b :: text")+ :: Statement.Statement () (Int32, Text)++>>> :t $(test "select $2 :: int4, $1 :: text")+$(test "select $2 :: int4, $1 :: text")+ :: Statement.Statement (Text, Int32) (Int32, Text)+-}+singletonStatement :: Extraction.Statement -> Exp+singletonStatement = rowStatement 'Decoders.singleRow++{-|+>>> test = either (fail . show) (return . maybeStatement) . Extraction.statement++>>> :t $(test "select 1 :: int4")+$(test "select 1 :: int4") :: Statement.Statement () (Maybe Int32)+-}+maybeStatement :: Extraction.Statement -> Exp+maybeStatement = rowStatement 'Decoders.rowMaybe++{-|+>>> test = either (fail . show) (return . vectorStatement) . Extraction.statement++>>> :t $(test "select 1 :: int4")+$(test "select 1 :: int4")+ :: Statement.Statement () (Data.Vector.Vector Int32)+-}+vectorStatement :: Extraction.Statement -> Exp+vectorStatement = rowStatement 'Decoders.rowVector++{-|+>>> test = either (fail . show) (return . foldStatement) . Extraction.statement++>>> :t $(test "select 1 :: int4")+$(test "select 1 :: int4")+ :: Fold Int32 b -> Statement.Statement () b+-}+foldStatement :: Extraction.Statement -> Exp+foldStatement _statement = let+ _stepVarName = mkName "step"+ _initVarName = mkName "init"+ _extractVarName = mkName "extract"+ in+ LamE+ [+ ConP 'Fold+ [+ VarP _stepVarName,+ VarP _initVarName,+ VarP _extractVarName+ ]+ ]+ (+ statement+ (\ _decoders ->+ AppE+ (AppE (VarE 'fmap) (VarE _extractVarName))+ (AppE+ (AppE+ (AppE (VarE 'Decoders.foldlRows) (VarE _stepVarName))+ (VarE _initVarName))+ (decoderList _decoders)))+ _statement+ )++{-|+Encoder of a product of parameters.+-}+encoderList :: [Extraction.Encoder] -> Exp+encoderList = contrazip . fmap encoder++encoder :: Extraction.Encoder -> Exp+encoder = let+ applyParam = AppE (VarE 'Encoders.param)+ applyArray levels = AppE (VarE 'Encoders.array) . applyArrayDimensionality levels+ applyArrayDimensionality levels =+ if levels > 0+ then AppE (AppE (VarE 'Encoders.dimension) (VarE 'foldl')) . applyArrayDimensionality (pred levels)+ else AppE (VarE 'Encoders.element)+ applyNullability nullable = AppE (VarE (if nullable then 'Encoders.nullable else 'Encoders.nonNullable))+ in \ (Extraction.Encoder valueEncoderName valueNull dimensionality arrayNull) ->+ if dimensionality > 0+ then VarE valueEncoderName & applyNullability valueNull & applyArray dimensionality & applyNullability arrayNull & applyParam+ else VarE valueEncoderName & applyNullability valueNull & applyParam++decoderList :: [Extraction.Decoder] -> Exp+decoderList = cozip . fmap decoder++decoder :: Extraction.Decoder -> Exp+decoder = let+ applyColumn = AppE (VarE 'Decoders.column)+ applyArray levels = AppE (VarE 'Decoders.array) . applyArrayDimensionality levels+ applyArrayDimensionality levels =+ if levels > 0+ then AppE (AppE (VarE 'Decoders.dimension) (VarE 'Vector.replicateM)) . applyArrayDimensionality (pred levels)+ else AppE (VarE 'Decoders.element)+ applyNullability nullable = AppE (VarE (if nullable then 'Decoders.nullable else 'Decoders.nonNullable))+ in \ (Extraction.Decoder valueDecoderName valueNull dimensionality arrayNull) ->+ if dimensionality > 0+ then VarE valueDecoderName & applyNullability valueNull & applyArray dimensionality & applyNullability arrayNull & applyColumn+ else VarE valueDecoderName & applyNullability valueNull & applyColumn
+ library/Hasql/TH/Extras/HeadedMegaparsec.hs view
@@ -0,0 +1,125 @@+{-|+Generic helpers for HeadedMegaparsec.+-}+module Hasql.TH.Extras.HeadedMegaparsec where++import Hasql.TH.Prelude hiding (expr, try, option, some, many, sortBy, filter, head, tail, bit)+import HeadedMegaparsec hiding (string)+import Control.Applicative.Combinators hiding (some)+import Control.Applicative.Combinators.NonEmpty+import Text.Megaparsec (Stream, Parsec)+import qualified Text.Megaparsec as Megaparsec+import qualified Text.Megaparsec.Char as MegaparsecChar+import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer+import qualified Data.Text as Text+import qualified Text.Builder as TextBuilder+++{- $setup+>>> testParser parser = either putStr print . run parser+-}+++-- * Executors+-------------------------++run :: (Ord err, Stream strm, Megaparsec.ShowErrorComponent err) => HeadedParsec err strm a -> strm -> Either String a+run p = first Megaparsec.errorBundlePretty . Megaparsec.runParser (toParsec p <* Megaparsec.eof) ""+++-- * Primitives+-------------------------++{-|+Lifted megaparsec\'s `Megaparsec.eof`.+-}+eof :: (Ord err, Stream strm) => HeadedParsec err strm ()+eof = parse Megaparsec.eof++{-|+Lifted megaparsec\'s `Megaparsec.space`.+-}+space :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm ()+space = parse MegaparsecChar.space++{-|+Lifted megaparsec\'s `Megaparsec.space1`.+-}+space1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm ()+space1 = parse MegaparsecChar.space1++{-|+Lifted megaparsec\'s `Megaparsec.char`.+-}+char :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char+char a = parse (MegaparsecChar.char a)++{-|+Lifted megaparsec\'s `Megaparsec.char'`.+-}+char' :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char+char' a = parse (MegaparsecChar.char' a)++{-|+Lifted megaparsec\'s `Megaparsec.string`.+-}+string :: (Ord err, Stream strm) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm)+string = parse . MegaparsecChar.string++{-|+Lifted megaparsec\'s `Megaparsec.string'`.+-}+string' :: (Ord err, Stream strm, FoldCase (Megaparsec.Tokens strm)) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm)+string' = parse . MegaparsecChar.string'++{-|+Lifted megaparsec\'s `Megaparsec.takeWhileP`.+-}+takeWhileP :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm)+takeWhileP label predicate = parse (Megaparsec.takeWhileP label predicate)++{-|+Lifted megaparsec\'s `Megaparsec.takeWhile1P`.+-}+takeWhile1P :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm)+takeWhile1P label predicate = parse (Megaparsec.takeWhile1P label predicate)++satisfy :: (Ord err, Stream strm) => (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Token strm)+satisfy = parse . Megaparsec.satisfy++decimal :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, Integral decimal) => HeadedParsec err strm decimal+decimal = parse MegaparsecLexer.decimal++float :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, RealFloat float) => HeadedParsec err strm float+float = parse MegaparsecLexer.float+++-- * Combinators+-------------------------++sep1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separtor -> HeadedParsec err strm a -> HeadedParsec err strm (NonEmpty a)+sep1 _separator _parser = do+ _head <- _parser+ endHead+ _tail <- many $ _separator *> _parser+ return (_head :| _tail)++sepEnd1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separator -> HeadedParsec err strm end -> HeadedParsec err strm el -> HeadedParsec err strm (NonEmpty el, end)+sepEnd1 sepP endP elP = do+ headEl <- elP+ let+ loop !list = do+ sepP+ asum [+ do+ end <- endP+ return (headEl :| reverse list, end)+ ,+ do+ el <- elP+ loop (el : list)+ ]+ in loop []++notFollowedBy :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm ()+notFollowedBy a = parse (Megaparsec.notFollowedBy (toParsec a))
+ library/Hasql/TH/Extras/NonEmpty.hs view
@@ -0,0 +1,33 @@+module Hasql.TH.Extras.NonEmpty where++import Hasql.TH.Prelude hiding (reverse, head, tail, init, last, cons, uncons, fromList)+import Data.List.NonEmpty+++{-|+>>> intersperseFoldMap ", " id (fromList ["a"])+"a"++>>> intersperseFoldMap ", " id (fromList ["a", "b", "c"])+"a, b, c"+-}+intersperseFoldMap :: Monoid m => m -> (a -> m) -> NonEmpty a -> m+intersperseFoldMap a b (c :| d) = b c <> foldMap (mappend a . b) d++unsnoc :: NonEmpty a -> (Maybe (NonEmpty a), a)+unsnoc = let+ build1 = \ case+ a :| b -> build2 a b+ build2 a = \ case+ b : c -> build3 b (a :| []) c+ _ -> (Nothing, a)+ build3 a b = \ case+ c : d -> build3 c (cons a b) d+ _ -> (Just (reverse b), a)+ in build1++consAndUnsnoc :: a -> NonEmpty a -> (NonEmpty a, a)+consAndUnsnoc a b = case unsnoc b of+ (c, d) -> case c of+ Just e -> (cons a e, d)+ Nothing -> (pure a, d)
library/Hasql/TH/Prelude.hs view
@@ -1,14 +1,90 @@ module Hasql.TH.Prelude ( module Exports,+ showAsText,+ suffixRec, ) where +-- base+-------------------------+import Control.Applicative as Exports+import Control.Arrow as Exports hiding (first, second)+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.IO.Class as Exports+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+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+import Data.Functor.Contravariant as Exports+import Data.Functor.Identity as Exports+import Data.Int as Exports+import Data.IORef as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Last(..), First(..), (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.Semigroup as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+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 (sizeOf, alignment)+import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(fromList, Item))+import GHC.Generics as Exports (Generic, Generic1)+import GHC.IO.Exception as Exports+import Numeric as Exports+import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+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.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (printf, hPrintf)+import Text.Read as Exports (Read(..), readMaybe, readEither)+import Unsafe.Coerce as Exports --- base-prelude+-- contravariant --------------------------import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)+import Data.Functor.Contravariant.Divisible as Exports +-- selective+-------------------------+import Control.Selective as Exports+ -- bytestring ------------------------- import Data.ByteString as Exports (ByteString)@@ -16,3 +92,45 @@ -- text ------------------------- import Data.Text as Exports (Text)++-- containers+-------------------------+import Data.IntMap.Strict as Exports (IntMap)+import Data.IntSet as Exports (IntSet)+import Data.Map.Strict as Exports (Map)+import Data.Sequence as Exports (Seq)+import Data.Set as Exports (Set)++-- unordered-containers+-------------------------+import Data.HashSet as Exports (HashSet)+import Data.HashMap.Strict as Exports (HashMap)++-- hashable+-------------------------+import Data.Hashable as Exports (Hashable)++-- foldl+-------------------------+import Control.Foldl as Exports (Fold(..))++-- uuid+-------------------------+import Data.UUID as Exports (UUID)++-- case-insensitive+-------------------------+import Data.CaseInsensitive as Exports (CI, FoldCase)+++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
− library/Hasql/TH/Renderers.hs
@@ -1,38 +0,0 @@-module Hasql.TH.Renderers where--import Hasql.TH.Prelude-import Language.Haskell.TH-import qualified Data.ByteString as ByteString---byteStringExp :: ByteString -> Exp-byteStringExp x =- AppE (VarE 'ByteString.pack) (listExp integralExp (ByteString.unpack x))--integralExp :: Integral a => a -> Exp-integralExp x =- LitE (IntegerL (fromIntegral x))--listExp :: (a -> Exp) -> [a] -> Exp-listExp renderer x =- ListE (map renderer x)--stringExp :: String -> Exp-stringExp x =- LitE (StringL x)--charExp :: Char -> Exp-charExp x =- LitE (CharL x)--sequenceExp_ :: [Exp] -> Exp-sequenceExp_ =- foldl' andThenExp pureExp_--pureExp_ :: Exp-pureExp_ =- AppE (VarE 'pure) (TupE [])--andThenExp :: Exp -> Exp -> Exp-andThenExp exp1 exp2 =- AppE (AppE (VarE '(*>)) exp1) exp2
+ library/Hasql/TH/Syntax/Ast.hs view
@@ -0,0 +1,2052 @@+{-|+Names for nodes mostly resemble the according definitions in the @gram.y@+original Postgres parser file, except for the cases where we can optimize on that.++For reasoning see the docs of the parsing module of this project.+-}+module Hasql.TH.Syntax.Ast where++import Hasql.TH.Prelude hiding (Order, Op)+++-- * Statement+-------------------------++{-+PreparableStmt:+ | SelectStmt+ | InsertStmt+ | UpdateStmt+ | DeleteStmt+-}+data PreparableStmt = + SelectPreparableStmt SelectStmt |+ InsertPreparableStmt InsertStmt |+ UpdatePreparableStmt UpdateStmt |+ DeletePreparableStmt DeleteStmt+ deriving (Show, Generic, Eq, Ord)+++-- * Insert+-------------------------++{-+InsertStmt:+ | opt_with_clause INSERT INTO insert_target insert_rest+ opt_on_conflict returning_clause+-}+data InsertStmt = InsertStmt (Maybe WithClause) InsertTarget InsertRest (Maybe OnConflict) (Maybe ReturningClause)+ deriving (Show, Generic, Eq, Ord)++{-+insert_target:+ | qualified_name+ | qualified_name AS ColId+-}+data InsertTarget = InsertTarget QualifiedName (Maybe ColId)+ deriving (Show, Generic, Eq, Ord)++{-+insert_rest:+ | SelectStmt+ | OVERRIDING override_kind VALUE_P SelectStmt+ | '(' insert_column_list ')' SelectStmt+ | '(' insert_column_list ')' OVERRIDING override_kind VALUE_P SelectStmt+ | DEFAULT VALUES+-}+data InsertRest =+ SelectInsertRest (Maybe InsertColumnList) (Maybe OverrideKind) SelectStmt |+ DefaultValuesInsertRest+ deriving (Show, Generic, Eq, Ord)++{-+override_kind:+ | USER+ | SYSTEM_P+-}+data OverrideKind = UserOverrideKind | SystemOverrideKind+ deriving (Show, Generic, Eq, Ord, Enum, Bounded)++{-+insert_column_list:+ | insert_column_item+ | insert_column_list ',' insert_column_item+-}+type InsertColumnList = NonEmpty InsertColumnItem++{-+insert_column_item:+ | ColId opt_indirection+-}+data InsertColumnItem = InsertColumnItem ColId (Maybe Indirection)+ deriving (Show, Generic, Eq, Ord)++{-+opt_on_conflict:+ | ON CONFLICT opt_conf_expr DO UPDATE SET set_clause_list where_clause+ | ON CONFLICT opt_conf_expr DO NOTHING+ | EMPTY+-}+data OnConflict = OnConflict (Maybe ConfExpr) OnConflictDo+ deriving (Show, Generic, Eq, Ord)++{-+opt_on_conflict:+ | ON CONFLICT opt_conf_expr DO UPDATE SET set_clause_list where_clause+ | ON CONFLICT opt_conf_expr DO NOTHING+ | EMPTY+-}+data OnConflictDo =+ UpdateOnConflictDo SetClauseList (Maybe WhereClause) |+ NothingOnConflictDo+ deriving (Show, Generic, Eq, Ord)++{-+opt_conf_expr:+ | '(' index_params ')' where_clause+ | ON CONSTRAINT name+ | EMPTY+-}+data ConfExpr =+ WhereConfExpr IndexParams (Maybe WhereClause) |+ ConstraintConfExpr Name+ deriving (Show, Generic, Eq, Ord)++{-+returning_clause:+ | RETURNING target_list+ | EMPTY+-}+type ReturningClause = TargetList+++-- * Update+-------------------------++{-+UpdateStmt:+ | opt_with_clause UPDATE relation_expr_opt_alias+ SET set_clause_list+ from_clause+ where_or_current_clause+ returning_clause+-}+data UpdateStmt = UpdateStmt (Maybe WithClause) RelationExprOptAlias SetClauseList (Maybe FromClause) (Maybe WhereOrCurrentClause) (Maybe ReturningClause)+ deriving (Show, Generic, Eq, Ord)++{-+set_clause_list:+ | set_clause+ | set_clause_list ',' set_clause+-}+type SetClauseList = NonEmpty SetClause++{-+set_clause:+ | set_target '=' a_expr+ | '(' set_target_list ')' '=' a_expr+-}+data SetClause =+ TargetSetClause SetTarget AExpr |+ TargetListSetClause SetTargetList AExpr+ deriving (Show, Generic, Eq, Ord)++{-+set_target:+ | ColId opt_indirection+-}+data SetTarget = SetTarget ColId (Maybe Indirection)+ deriving (Show, Generic, Eq, Ord)++{-+set_target_list:+ | set_target+ | set_target_list ',' set_target+-}+type SetTargetList = NonEmpty SetTarget+++-- * Delete+-------------------------++{-+DeleteStmt:+ | opt_with_clause DELETE_P FROM relation_expr_opt_alias+ using_clause where_or_current_clause returning_clause+-}+data DeleteStmt = DeleteStmt (Maybe WithClause) RelationExprOptAlias (Maybe UsingClause) (Maybe WhereOrCurrentClause) (Maybe ReturningClause)+ deriving (Show, Generic, Eq, Ord)++{-+using_clause:+ | USING from_list+ | EMPTY+-}+type UsingClause = FromList+++-- * Select+-------------------------++{-+SelectStmt:+ | select_no_parens+ | select_with_parens+-}+type SelectStmt = Either SelectNoParens SelectWithParens++{-+select_with_parens:+ | '(' select_no_parens ')'+ | '(' select_with_parens ')'+-}+data SelectWithParens =+ NoParensSelectWithParens SelectNoParens |+ WithParensSelectWithParens SelectWithParens+ deriving (Show, Generic, Eq, Ord)++{-|+Covers the following cases:++@+select_no_parens:+ | simple_select+ | select_clause sort_clause+ | select_clause opt_sort_clause for_locking_clause opt_select_limit+ | select_clause opt_sort_clause select_limit opt_for_locking_clause+ | with_clause select_clause+ | with_clause select_clause sort_clause+ | with_clause select_clause opt_sort_clause for_locking_clause opt_select_limit+ | with_clause select_clause opt_sort_clause select_limit opt_for_locking_clause+@+-}+data SelectNoParens =+ SelectNoParens (Maybe WithClause) SelectClause (Maybe SortClause) (Maybe SelectLimit) (Maybe ForLockingClause)+ deriving (Show, Generic, Eq, Ord)++{-|+@+select_clause:+ | simple_select+ | select_with_parens+@+-}+type SelectClause = Either SimpleSelect SelectWithParens++{-+simple_select:+ | SELECT opt_all_clause opt_target_list+ into_clause from_clause where_clause+ group_clause having_clause window_clause+ | SELECT distinct_clause target_list+ into_clause from_clause where_clause+ group_clause having_clause window_clause+ | values_clause+ | TABLE relation_expr+ | select_clause UNION all_or_distinct select_clause+ | select_clause INTERSECT all_or_distinct select_clause+ | select_clause EXCEPT all_or_distinct select_clause+-}+data SimpleSelect =+ NormalSimpleSelect (Maybe Targeting) (Maybe IntoClause) (Maybe FromClause) (Maybe WhereClause) (Maybe GroupClause) (Maybe HavingClause) (Maybe WindowClause) |+ ValuesSimpleSelect ValuesClause |+ TableSimpleSelect RelationExpr |+ BinSimpleSelect SelectBinOp SelectClause (Maybe Bool) SelectClause+ deriving (Show, Generic, Eq, Ord)++{-|+Covers these parts of spec:++@+simple_select:+ | SELECT opt_all_clause opt_target_list+ into_clause from_clause where_clause+ group_clause having_clause window_clause+ | SELECT distinct_clause target_list+ into_clause from_clause where_clause+ group_clause having_clause window_clause++distinct_clause:+ | DISTINCT+ | DISTINCT ON '(' expr_list ')'+@+-}+data Targeting =+ NormalTargeting TargetList |+ AllTargeting (Maybe TargetList) |+ DistinctTargeting (Maybe ExprList) TargetList+ deriving (Show, Generic, Eq, Ord)++{-+target_list:+ | target_el+ | target_list ',' target_el+-}+type TargetList = NonEmpty TargetEl++{-+target_el:+ | a_expr AS ColLabel+ | a_expr IDENT+ | a_expr+ | '*'+-}+data TargetEl =+ AliasedExprTargetEl AExpr Ident |+ ImplicitlyAliasedExprTargetEl AExpr Ident |+ ExprTargetEl AExpr |+ AsteriskTargetEl+ deriving (Show, Generic, Eq, Ord)++{-+ | select_clause UNION all_or_distinct select_clause+ | select_clause INTERSECT all_or_distinct select_clause+ | select_clause EXCEPT all_or_distinct select_clause+-}+data SelectBinOp = UnionSelectBinOp | IntersectSelectBinOp | ExceptSelectBinOp+ deriving (Show, Generic, Eq, Ord)++{-+with_clause:+ | WITH cte_list+ | WITH_LA cte_list+ | WITH RECURSIVE cte_list+-}+data WithClause = WithClause Bool (NonEmpty CommonTableExpr)+ deriving (Show, Generic, Eq, Ord)++{-+common_table_expr:+ | name opt_name_list AS opt_materialized '(' PreparableStmt ')'+opt_materialized:+ | MATERIALIZED+ | NOT MATERIALIZED+ | EMPTY+-}+data CommonTableExpr = CommonTableExpr Ident (Maybe (NonEmpty Ident)) (Maybe Bool) PreparableStmt+ deriving (Show, Generic, Eq, Ord)++type IntoClause = OptTempTableName++{-+OptTempTableName:+ | TEMPORARY opt_table qualified_name+ | TEMP opt_table qualified_name+ | LOCAL TEMPORARY opt_table qualified_name+ | LOCAL TEMP opt_table qualified_name+ | GLOBAL TEMPORARY opt_table qualified_name+ | GLOBAL TEMP opt_table qualified_name+ | UNLOGGED opt_table qualified_name+ | TABLE qualified_name+ | qualified_name+-}+data OptTempTableName =+ TemporaryOptTempTableName Bool QualifiedName |+ TempOptTempTableName Bool QualifiedName |+ LocalTemporaryOptTempTableName Bool QualifiedName |+ LocalTempOptTempTableName Bool QualifiedName |+ GlobalTemporaryOptTempTableName Bool QualifiedName |+ GlobalTempOptTempTableName Bool QualifiedName |+ UnloggedOptTempTableName Bool QualifiedName |+ TableOptTempTableName QualifiedName |+ QualifedOptTempTableName QualifiedName+ deriving (Show, Generic, Eq, Ord)++type FromClause = NonEmpty TableRef++type GroupClause = NonEmpty GroupByItem++{-+group_by_item:+ | a_expr+ | empty_grouping_set+ | cube_clause+ | rollup_clause+ | grouping_sets_clause+empty_grouping_set:+ | '(' ')'+rollup_clause:+ | ROLLUP '(' expr_list ')'+cube_clause:+ | CUBE '(' expr_list ')'+grouping_sets_clause:+ | GROUPING SETS '(' group_by_list ')'+-}+data GroupByItem =+ ExprGroupByItem AExpr |+ EmptyGroupingSetGroupByItem |+ RollupGroupByItem ExprList |+ CubeGroupByItem ExprList |+ GroupingSetsGroupByItem (NonEmpty GroupByItem)+ deriving (Show, Generic, Eq, Ord)++{-|+@+having_clause:+ | HAVING a_expr+ | EMPTY+@+-}+type HavingClause = AExpr++{-|+@+window_clause:+ | WINDOW window_definition_list+ | EMPTY++window_definition_list:+ | window_definition+ | window_definition_list ',' window_definition+@+-}+type WindowClause = NonEmpty WindowDefinition++{-|+@+window_definition:+ | ColId AS window_specification+@+-}+data WindowDefinition = WindowDefinition Ident WindowSpecification+ deriving (Show, Generic, Eq, Ord)++{-|+@+window_specification:+ | '(' opt_existing_window_name opt_partition_clause+ opt_sort_clause opt_frame_clause ')'++opt_existing_window_name:+ | ColId+ | EMPTY++opt_partition_clause:+ | PARTITION BY expr_list+ | EMPTY+@+-}+data WindowSpecification = WindowSpecification (Maybe ExistingWindowName) (Maybe PartitionClause) (Maybe SortClause) (Maybe FrameClause)+ deriving (Show, Generic, Eq, Ord)++type ExistingWindowName = ColId++type PartitionClause = ExprList++{-+opt_frame_clause:+ | RANGE frame_extent opt_window_exclusion_clause+ | ROWS frame_extent opt_window_exclusion_clause+ | GROUPS frame_extent opt_window_exclusion_clause+ | EMPTY+-}+data FrameClause = FrameClause FrameClauseMode FrameExtent (Maybe WindowExclusionClause)+ deriving (Show, Generic, Eq, Ord)++{-+opt_frame_clause:+ | RANGE frame_extent opt_window_exclusion_clause+ | ROWS frame_extent opt_window_exclusion_clause+ | GROUPS frame_extent opt_window_exclusion_clause+ | EMPTY+-}+data FrameClauseMode = RangeFrameClauseMode | RowsFrameClauseMode | GroupsFrameClauseMode+ deriving (Show, Generic, Eq, Ord)++{-+frame_extent:+ | frame_bound+ | BETWEEN frame_bound AND frame_bound+-}+data FrameExtent = SingularFrameExtent FrameBound | BetweenFrameExtent FrameBound FrameBound+ deriving (Show, Generic, Eq, Ord)++{-+frame_bound:+ | UNBOUNDED PRECEDING+ | UNBOUNDED FOLLOWING+ | CURRENT_P ROW+ | a_expr PRECEDING+ | a_expr FOLLOWING+-}+data FrameBound =+ UnboundedPrecedingFrameBound |+ UnboundedFollowingFrameBound |+ CurrentRowFrameBound |+ PrecedingFrameBound AExpr |+ FollowingFrameBound AExpr+ deriving (Show, Generic, Eq, Ord)++{-+opt_window_exclusion_clause:+ | EXCLUDE CURRENT_P ROW+ | EXCLUDE GROUP_P+ | EXCLUDE TIES+ | EXCLUDE NO OTHERS+ | EMPTY+-}+data WindowExclusionClause =+ CurrentRowWindowExclusionClause |+ GroupWindowExclusionClause |+ TiesWindowExclusionClause |+ NoOthersWindowExclusionClause+ deriving (Show, Generic, Eq, Ord)++{-+values_clause:+ | VALUES '(' expr_list ')'+ | values_clause ',' '(' expr_list ')'+-}+type ValuesClause = NonEmpty ExprList++{-|++sort_clause:+ | ORDER BY sortby_list++sortby_list:+ | sortby+ | sortby_list ',' sortby++-}+type SortClause = NonEmpty SortBy++{-+sortby:+ | a_expr USING qual_all_Op opt_nulls_order+ | a_expr opt_asc_desc opt_nulls_order+-}+data SortBy =+ UsingSortBy AExpr QualAllOp (Maybe NullsOrder) |+ AscDescSortBy AExpr (Maybe AscDesc) (Maybe NullsOrder)+ deriving (Show, Generic, Eq, Ord)++{-+select_limit:+ | limit_clause offset_clause+ | offset_clause limit_clause+ | limit_clause+ | offset_clause+-}+data SelectLimit =+ LimitOffsetSelectLimit LimitClause OffsetClause |+ OffsetLimitSelectLimit OffsetClause LimitClause |+ LimitSelectLimit LimitClause |+ OffsetSelectLimit OffsetClause+ deriving (Show, Generic, Eq, Ord)++{-+limit_clause:+ | LIMIT select_limit_value+ | LIMIT select_limit_value ',' select_offset_value+ | FETCH first_or_next select_fetch_first_value row_or_rows ONLY+ | FETCH first_or_next row_or_rows ONLY+select_offset_value:+ | a_expr+first_or_next:+ | FIRST_P+ | NEXT+row_or_rows:+ | ROW+ | ROWS+-}+data LimitClause =+ LimitLimitClause SelectLimitValue (Maybe AExpr) |+ FetchOnlyLimitClause Bool (Maybe SelectFetchFirstValue) Bool+ deriving (Show, Generic, Eq, Ord)++{-+select_fetch_first_value:+ | c_expr+ | '+' I_or_F_const+ | '-' I_or_F_const+-}+data SelectFetchFirstValue =+ ExprSelectFetchFirstValue CExpr |+ NumSelectFetchFirstValue Bool (Either Int64 Double)+ deriving (Show, Generic, Eq, Ord)++{-+select_limit_value:+ | a_expr+ | ALL+-}+data SelectLimitValue =+ ExprSelectLimitValue AExpr |+ AllSelectLimitValue+ deriving (Show, Generic, Eq, Ord)++{-+offset_clause:+ | OFFSET select_offset_value+ | OFFSET select_fetch_first_value row_or_rows+select_offset_value:+ | a_expr+row_or_rows:+ | ROW+ | ROWS+-}+data OffsetClause =+ ExprOffsetClause AExpr |+ FetchFirstOffsetClause SelectFetchFirstValue Bool+ deriving (Show, Generic, Eq, Ord)+++-- * For Locking+-------------------------++{-+for_locking_clause:+ | for_locking_items+ | FOR READ ONLY+for_locking_items:+ | for_locking_item+ | for_locking_items for_locking_item+-}+data ForLockingClause =+ ItemsForLockingClause (NonEmpty ForLockingItem) |+ ReadOnlyForLockingClause+ deriving (Show, Generic, Eq, Ord)++{-+for_locking_item:+ | for_locking_strength locked_rels_list opt_nowait_or_skip+locked_rels_list:+ | OF qualified_name_list+ | EMPTY+opt_nowait_or_skip:+ | NOWAIT+ | SKIP LOCKED+ | EMPTY+-}+data ForLockingItem = ForLockingItem ForLockingStrength (Maybe (NonEmpty QualifiedName)) (Maybe Bool)+ deriving (Show, Generic, Eq, Ord)++{-+for_locking_strength:+ | FOR UPDATE+ | FOR NO KEY UPDATE+ | FOR SHARE+ | FOR KEY SHARE+-}+data ForLockingStrength =+ UpdateForLockingStrength |+ NoKeyUpdateForLockingStrength |+ ShareForLockingStrength |+ KeyForLockingStrength+ deriving (Show, Generic, Eq, Ord)+++-- * Table references and joining+-------------------------++{-+from_list:+ | table_ref+ | from_list ',' table_ref+-}+type FromList = NonEmpty TableRef++{-+| relation_expr opt_alias_clause+| relation_expr opt_alias_clause tablesample_clause+| func_table func_alias_clause+| LATERAL_P func_table func_alias_clause+| xmltable opt_alias_clause+| LATERAL_P xmltable opt_alias_clause+| select_with_parens opt_alias_clause+| LATERAL_P select_with_parens opt_alias_clause+| joined_table+| '(' joined_table ')' alias_clause++TODO: Add xmltable+-}+data TableRef =+ {-+ | relation_expr opt_alias_clause+ | relation_expr opt_alias_clause tablesample_clause+ -}+ RelationExprTableRef RelationExpr (Maybe AliasClause) (Maybe TablesampleClause) |+ {-+ | func_table func_alias_clause+ | LATERAL_P func_table func_alias_clause+ -}+ FuncTableRef Bool FuncTable (Maybe FuncAliasClause) |+ {-+ | select_with_parens opt_alias_clause+ | LATERAL_P select_with_parens opt_alias_clause+ -}+ SelectTableRef Bool SelectWithParens (Maybe AliasClause) |+ {-+ | joined_table+ | '(' joined_table ')' alias_clause+ -}+ JoinTableRef JoinedTable (Maybe AliasClause)+ deriving (Show, Generic, Eq, Ord)++{-+| qualified_name+| qualified_name '*'+| ONLY qualified_name+| ONLY '(' qualified_name ')'+-}+data RelationExpr =+ SimpleRelationExpr QualifiedName Bool |+ OnlyRelationExpr QualifiedName Bool+ deriving (Show, Generic, Eq, Ord)++{-+relation_expr_opt_alias:+ | relation_expr+ | relation_expr ColId+ | relation_expr AS ColId+-}+data RelationExprOptAlias = RelationExprOptAlias RelationExpr (Maybe (Bool, ColId))+ deriving (Show, Generic, Eq, Ord)++{-+tablesample_clause:+ | TABLESAMPLE func_name '(' expr_list ')' opt_repeatable_clause+-}+data TablesampleClause = TablesampleClause FuncName ExprList (Maybe RepeatableClause)+ deriving (Show, Generic, Eq, Ord)++{-+opt_repeatable_clause:+ | REPEATABLE '(' a_expr ')'+ | EMPTY+-}+type RepeatableClause = AExpr++{-+func_table:+ | func_expr_windowless opt_ordinality+ | ROWS FROM '(' rowsfrom_list ')' opt_ordinality+-}+data FuncTable =+ FuncExprFuncTable FuncExprWindowless OptOrdinality |+ RowsFromFuncTable RowsfromList OptOrdinality+ deriving (Show, Generic, Eq, Ord)++{-+rowsfrom_item:+ | func_expr_windowless opt_col_def_list+-}+data RowsfromItem = RowsfromItem FuncExprWindowless (Maybe ColDefList)+ deriving (Show, Generic, Eq, Ord)++{-+rowsfrom_list:+ | rowsfrom_item+ | rowsfrom_list ',' rowsfrom_item+-}+type RowsfromList = NonEmpty RowsfromItem++{-+opt_col_def_list:+ | AS '(' TableFuncElementList ')'+ | EMPTY+-}+type ColDefList = TableFuncElementList++{-+opt_ordinality:+ | WITH_LA ORDINALITY+ | EMPTY+-}+type OptOrdinality = Bool++{-+TableFuncElementList:+ | TableFuncElement+ | TableFuncElementList ',' TableFuncElement+-}+type TableFuncElementList = NonEmpty TableFuncElement++{-+TableFuncElement:+ | ColId Typename opt_collate_clause+-}+data TableFuncElement = TableFuncElement ColId Typename (Maybe CollateClause)+ deriving (Show, Generic, Eq, Ord)++{-+opt_collate_clause:+ | COLLATE any_name+ | EMPTY+-}+type CollateClause = AnyName++{-+alias_clause:+ | AS ColId '(' name_list ')'+ | AS ColId+ | ColId '(' name_list ')'+ | ColId+-}+data AliasClause = AliasClause Bool ColId (Maybe NameList)+ deriving (Show, Generic, Eq, Ord)++{-+func_alias_clause:+ | alias_clause+ | AS '(' TableFuncElementList ')'+ | AS ColId '(' TableFuncElementList ')'+ | ColId '(' TableFuncElementList ')'+ | EMPTY+-}+data FuncAliasClause =+ AliasFuncAliasClause AliasClause |+ AsFuncAliasClause TableFuncElementList |+ AsColIdFuncAliasClause ColId TableFuncElementList |+ ColIdFuncAliasClause ColId TableFuncElementList+ deriving (Show, Generic, Eq, Ord)++{-+| '(' joined_table ')'+| table_ref CROSS JOIN table_ref+| table_ref join_type JOIN table_ref join_qual+| table_ref JOIN table_ref join_qual+| table_ref NATURAL join_type JOIN table_ref+| table_ref NATURAL JOIN table_ref++The options are covered by the `JoinMeth` type.+-}+data JoinedTable =+ InParensJoinedTable JoinedTable |+ MethJoinedTable JoinMeth TableRef TableRef+ deriving (Show, Generic, Eq, Ord)++{-+| table_ref CROSS JOIN table_ref+| table_ref join_type JOIN table_ref join_qual+| table_ref JOIN table_ref join_qual+| table_ref NATURAL join_type JOIN table_ref+| table_ref NATURAL JOIN table_ref+-}+data JoinMeth =+ CrossJoinMeth |+ QualJoinMeth (Maybe JoinType) JoinQual |+ NaturalJoinMeth (Maybe JoinType)+ deriving (Show, Generic, Eq, Ord)++{-+| FULL join_outer+| LEFT join_outer+| RIGHT join_outer+| INNER_P+-}+data JoinType =+ FullJoinType Bool |+ LeftJoinType Bool |+ RightJoinType Bool |+ InnerJoinType+ deriving (Show, Generic, Eq, Ord)++{-+join_qual:+ | USING '(' name_list ')'+ | ON a_expr+-}+data JoinQual =+ UsingJoinQual (NonEmpty Ident) |+ OnJoinQual AExpr+ deriving (Show, Generic, Eq, Ord)+++-- * Where+-------------------------++type WhereClause = AExpr++{-+| WHERE a_expr+| WHERE CURRENT_P OF cursor_name+| /*EMPTY*/+-}+data WhereOrCurrentClause = + ExprWhereOrCurrentClause AExpr |+ CursorWhereOrCurrentClause CursorName+ deriving (Show, Generic, Eq, Ord)+++-- * Expression+-------------------------++type ExprList = NonEmpty AExpr++{-+a_expr:+ | c_expr+ | a_expr TYPECAST Typename+ | a_expr COLLATE any_name+ | a_expr AT TIME ZONE a_expr+ | '+' a_expr+ | '-' a_expr+ | a_expr '+' a_expr+ | a_expr '-' a_expr+ | a_expr '*' a_expr+ | a_expr '/' a_expr+ | a_expr '%' a_expr+ | a_expr '^' a_expr+ | a_expr '<' a_expr+ | a_expr '>' a_expr+ | a_expr '=' a_expr+ | a_expr LESS_EQUALS a_expr+ | a_expr GREATER_EQUALS a_expr+ | a_expr NOT_EQUALS a_expr+ | a_expr qual_Op a_expr+ | qual_Op a_expr+ | a_expr qual_Op+ | a_expr AND a_expr+ | a_expr OR a_expr+ | NOT a_expr+ | NOT_LA a_expr+ | a_expr LIKE a_expr+ | a_expr LIKE a_expr ESCAPE a_expr+ | a_expr NOT_LA LIKE a_expr+ | a_expr NOT_LA LIKE a_expr ESCAPE a_expr+ | a_expr ILIKE a_expr+ | a_expr ILIKE a_expr ESCAPE a_expr+ | a_expr NOT_LA ILIKE a_expr+ | a_expr NOT_LA ILIKE a_expr ESCAPE a_expr+ | a_expr SIMILAR TO a_expr+ | a_expr SIMILAR TO a_expr ESCAPE a_expr+ | a_expr NOT_LA SIMILAR TO a_expr+ | a_expr NOT_LA SIMILAR TO a_expr ESCAPE a_expr+ | a_expr IS NULL_P+ | a_expr ISNULL+ | a_expr IS NOT NULL_P+ | a_expr NOTNULL+ | row OVERLAPS row+ | a_expr IS TRUE_P+ | a_expr IS NOT TRUE_P+ | a_expr IS FALSE_P+ | a_expr IS NOT FALSE_P+ | a_expr IS UNKNOWN+ | a_expr IS NOT UNKNOWN+ | a_expr IS DISTINCT FROM a_expr+ | a_expr IS NOT DISTINCT FROM a_expr+ | a_expr IS OF '(' type_list ')'+ | a_expr IS NOT OF '(' type_list ')'+ | a_expr BETWEEN opt_asymmetric b_expr AND a_expr+ | a_expr NOT_LA BETWEEN opt_asymmetric b_expr AND a_expr+ | a_expr BETWEEN SYMMETRIC b_expr AND a_expr+ | a_expr NOT_LA BETWEEN SYMMETRIC b_expr AND a_expr+ | a_expr IN_P in_expr+ | a_expr NOT_LA IN_P in_expr+ | a_expr subquery_Op sub_type select_with_parens+ | a_expr subquery_Op sub_type '(' a_expr ')'+ | UNIQUE select_with_parens+ | a_expr IS DOCUMENT_P+ | a_expr IS NOT DOCUMENT_P+ | DEFAULT+-}+data AExpr =+ CExprAExpr CExpr |+ TypecastAExpr AExpr TypecastTypename |+ CollateAExpr AExpr AnyName |+ AtTimeZoneAExpr AExpr AExpr |+ PlusAExpr AExpr |+ MinusAExpr AExpr |+ SymbolicBinOpAExpr AExpr SymbolicExprBinOp AExpr |+ PrefixQualOpAExpr QualOp AExpr |+ SuffixQualOpAExpr AExpr QualOp |+ AndAExpr AExpr AExpr |+ OrAExpr AExpr AExpr |+ NotAExpr AExpr |+ VerbalExprBinOpAExpr AExpr Bool VerbalExprBinOp AExpr (Maybe AExpr) |+ ReversableOpAExpr AExpr Bool AExprReversableOp |+ IsnullAExpr AExpr |+ NotnullAExpr AExpr |+ OverlapsAExpr Row Row |+ SubqueryAExpr AExpr SubqueryOp SubType (Either SelectWithParens AExpr) |+ UniqueAExpr SelectWithParens |+ DefaultAExpr+ deriving (Show, Generic, Eq, Ord)++{-+b_expr:+ | c_expr+ | b_expr TYPECAST Typename+ | '+' b_expr+ | '-' b_expr+ | b_expr '+' b_expr+ | b_expr '-' b_expr+ | b_expr '*' b_expr+ | b_expr '/' b_expr+ | b_expr '%' b_expr+ | b_expr '^' b_expr+ | b_expr '<' b_expr+ | b_expr '>' b_expr+ | b_expr '=' b_expr+ | b_expr LESS_EQUALS b_expr+ | b_expr GREATER_EQUALS b_expr+ | b_expr NOT_EQUALS b_expr+ | b_expr qual_Op b_expr+ | qual_Op b_expr+ | b_expr qual_Op+ | b_expr IS DISTINCT FROM b_expr+ | b_expr IS NOT DISTINCT FROM b_expr+ | b_expr IS OF '(' type_list ')'+ | b_expr IS NOT OF '(' type_list ')'+ | b_expr IS DOCUMENT_P+ | b_expr IS NOT DOCUMENT_P+-}+data BExpr =+ CExprBExpr CExpr |+ TypecastBExpr BExpr TypecastTypename |+ PlusBExpr BExpr |+ MinusBExpr BExpr |+ SymbolicBinOpBExpr BExpr SymbolicExprBinOp BExpr |+ QualOpBExpr QualOp BExpr |+ IsOpBExpr BExpr Bool BExprIsOp+ deriving (Show, Generic, Eq, Ord)++{-+c_expr:+ | columnref+ | AexprConst+ | PARAM opt_indirection+ | '(' a_expr ')' opt_indirection+ | case_expr+ | func_expr+ | select_with_parens+ | select_with_parens indirection+ | EXISTS select_with_parens+ | ARRAY select_with_parens+ | ARRAY array_expr+ | explicit_row+ | implicit_row+ | GROUPING '(' expr_list ')'+-}+data CExpr =+ ColumnrefCExpr Columnref |+ AexprConstCExpr AexprConst |+ ParamCExpr Int (Maybe Indirection) |+ InParensCExpr AExpr (Maybe Indirection) |+ CaseCExpr CaseExpr |+ FuncCExpr FuncExpr |+ SelectWithParensCExpr SelectWithParens (Maybe Indirection) |+ ExistsCExpr SelectWithParens |+ ArrayCExpr (Either SelectWithParens ArrayExpr) |+ ExplicitRowCExpr ExplicitRow |+ ImplicitRowCExpr ImplicitRow |+ GroupingCExpr ExprList+ deriving (Show, Generic, Eq, Ord)++-- **+-------------------------++{-+in_expr:+ | select_with_parens+ | '(' expr_list ')'+-}+data InExpr =+ SelectInExpr SelectWithParens |+ ExprListInExpr ExprList+ deriving (Show, Generic, Eq, Ord)++{-+sub_type:+ | ANY+ | SOME+ | ALL+-}+data SubType = AnySubType | SomeSubType | AllSubType+ deriving (Show, Generic, Eq, Ord, Enum, Bounded)++{-+array_expr:+ | '[' expr_list ']'+ | '[' array_expr_list ']'+ | '[' ']'+-}+data ArrayExpr =+ ExprListArrayExpr ExprList |+ ArrayExprListArrayExpr ArrayExprList |+ EmptyArrayExpr+ deriving (Show, Generic, Eq, Ord)++{-+array_expr_list:+ | array_expr+ | array_expr_list ',' array_expr+-}+type ArrayExprList = NonEmpty ArrayExpr++{-+row:+ | ROW '(' expr_list ')'+ | ROW '(' ')'+ | '(' expr_list ',' a_expr ')'+-}+data Row =+ ExplicitRowRow ExplicitRow |+ ImplicitRowRow ImplicitRow+ deriving (Show, Generic, Eq, Ord)++{-+explicit_row:+ | ROW '(' expr_list ')'+ | ROW '(' ')'+-}+type ExplicitRow = Maybe ExprList++{-+implicit_row:+ | '(' expr_list ',' a_expr ')'+-}+data ImplicitRow = ImplicitRow ExprList AExpr+ deriving (Show, Generic, Eq, Ord)++{-+func_expr:+ | func_application within_group_clause filter_clause over_clause+ | func_expr_common_subexpr+-}+data FuncExpr =+ ApplicationFuncExpr FuncApplication (Maybe WithinGroupClause) (Maybe FilterClause) (Maybe OverClause) |+ SubexprFuncExpr FuncExprCommonSubexpr+ deriving (Show, Generic, Eq, Ord)++{-+func_expr_windowless:+ | func_application+ | func_expr_common_subexpr+-}+data FuncExprWindowless =+ ApplicationFuncExprWindowless FuncApplication |+ CommonSubexprFuncExprWindowless FuncExprCommonSubexpr+ deriving (Show, Generic, Eq, Ord)++{-+within_group_clause:+ | WITHIN GROUP_P '(' sort_clause ')'+ | EMPTY+-}+type WithinGroupClause = SortClause++{-+filter_clause:+ | FILTER '(' WHERE a_expr ')'+ | EMPTY+-}+type FilterClause = AExpr++{-+over_clause:+ | OVER window_specification+ | OVER ColId+ | EMPTY+-}+data OverClause =+ WindowOverClause WindowSpecification |+ ColIdOverClause ColId+ deriving (Show, Generic, Eq, Ord)++{-+func_expr_common_subexpr:+ | COLLATION FOR '(' a_expr ')'+ | CURRENT_DATE+ | CURRENT_TIME+ | CURRENT_TIME '(' Iconst ')'+ | CURRENT_TIMESTAMP+ | CURRENT_TIMESTAMP '(' Iconst ')'+ | LOCALTIME+ | LOCALTIME '(' Iconst ')'+ | LOCALTIMESTAMP+ | LOCALTIMESTAMP '(' Iconst ')'+ | CURRENT_ROLE+ | CURRENT_USER+ | SESSION_USER+ | USER+ | CURRENT_CATALOG+ | CURRENT_SCHEMA+ | CAST '(' a_expr AS Typename ')'+ | EXTRACT '(' extract_list ')'+ | OVERLAY '(' overlay_list ')'+ | POSITION '(' position_list ')'+ | SUBSTRING '(' substr_list ')'+ | TREAT '(' a_expr AS Typename ')'+ | TRIM '(' BOTH trim_list ')'+ | TRIM '(' LEADING trim_list ')'+ | TRIM '(' TRAILING trim_list ')'+ | TRIM '(' trim_list ')'+ | NULLIF '(' a_expr ',' a_expr ')'+ | COALESCE '(' expr_list ')'+ | GREATEST '(' expr_list ')'+ | LEAST '(' expr_list ')'+ | XMLCONCAT '(' expr_list ')'+ | XMLELEMENT '(' NAME_P ColLabel ')'+ | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ')'+ | XMLELEMENT '(' NAME_P ColLabel ',' expr_list ')'+ | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ',' expr_list ')'+ | XMLEXISTS '(' c_expr xmlexists_argument ')'+ | XMLFOREST '(' xml_attribute_list ')'+ | XMLPARSE '(' document_or_content a_expr xml_whitespace_option ')'+ | XMLPI '(' NAME_P ColLabel ')'+ | XMLPI '(' NAME_P ColLabel ',' a_expr ')'+ | XMLROOT '(' a_expr ',' xml_root_version opt_xml_root_standalone ')'+ | XMLSERIALIZE '(' document_or_content a_expr AS SimpleTypename ')'++TODO: Implement the XML cases+-}+data FuncExprCommonSubexpr =+ CollationForFuncExprCommonSubexpr AExpr |+ CurrentDateFuncExprCommonSubexpr |+ CurrentTimeFuncExprCommonSubexpr (Maybe Int64) |+ CurrentTimestampFuncExprCommonSubexpr (Maybe Int64) |+ LocalTimeFuncExprCommonSubexpr (Maybe Int64) |+ LocalTimestampFuncExprCommonSubexpr (Maybe Int64) |+ CurrentRoleFuncExprCommonSubexpr |+ CurrentUserFuncExprCommonSubexpr |+ SessionUserFuncExprCommonSubexpr |+ UserFuncExprCommonSubexpr |+ CurrentCatalogFuncExprCommonSubexpr |+ CurrentSchemaFuncExprCommonSubexpr |+ CastFuncExprCommonSubexpr AExpr Typename |+ ExtractFuncExprCommonSubexpr (Maybe ExtractList) |+ OverlayFuncExprCommonSubexpr OverlayList |+ PositionFuncExprCommonSubexpr (Maybe PositionList) |+ SubstringFuncExprCommonSubexpr (Maybe SubstrList) |+ TreatFuncExprCommonSubexpr AExpr Typename |+ TrimFuncExprCommonSubexpr (Maybe TrimModifier) TrimList |+ NullIfFuncExprCommonSubexpr AExpr AExpr |+ CoalesceFuncExprCommonSubexpr ExprList |+ GreatestFuncExprCommonSubexpr ExprList |+ LeastFuncExprCommonSubexpr ExprList+ deriving (Show, Generic, Eq, Ord)++{-+extract_list:+ | extract_arg FROM a_expr+ | EMPTY+-}+data ExtractList = ExtractList ExtractArg AExpr+ deriving (Show, Generic, Eq, Ord)++{-+extract_arg:+ | IDENT+ | YEAR_P+ | MONTH_P+ | DAY_P+ | HOUR_P+ | MINUTE_P+ | SECOND_P+ | Sconst+-}+data ExtractArg =+ IdentExtractArg Ident |+ YearExtractArg |+ MonthExtractArg |+ DayExtractArg |+ HourExtractArg |+ MinuteExtractArg |+ SecondExtractArg |+ SconstExtractArg Sconst+ deriving (Show, Generic, Eq, Ord)++{-+overlay_list:+ | a_expr overlay_placing substr_from substr_for+ | a_expr overlay_placing substr_from+-}+data OverlayList = OverlayList AExpr OverlayPlacing SubstrFrom (Maybe SubstrFor)+ deriving (Show, Generic, Eq, Ord)++{-+overlay_placing:+ | PLACING a_expr+-}+type OverlayPlacing = AExpr++{-+position_list:+ | b_expr IN_P b_expr+ | EMPTY+-}+data PositionList = PositionList BExpr BExpr+ deriving (Show, Generic, Eq, Ord)++{-+substr_list:+ | a_expr substr_from substr_for+ | a_expr substr_for substr_from+ | a_expr substr_from+ | a_expr substr_for+ | expr_list+ | EMPTY+-}+data SubstrList =+ ExprSubstrList AExpr SubstrListFromFor |+ ExprListSubstrList ExprList+ deriving (Show, Generic, Eq, Ord)++{-+ | a_expr substr_from substr_for+ | a_expr substr_for substr_from+ | a_expr substr_from+ | a_expr substr_for+-}+data SubstrListFromFor =+ FromForSubstrListFromFor SubstrFrom SubstrFor |+ ForFromSubstrListFromFor SubstrFor SubstrFrom |+ FromSubstrListFromFor SubstrFrom |+ ForSubstrListFromFor SubstrFor+ deriving (Show, Generic, Eq, Ord)++{-+substr_from:+ | FROM a_expr+-}+type SubstrFrom = AExpr++{-+substr_for:+ | FOR a_expr+-}+type SubstrFor = AExpr++{-+ | TRIM '(' BOTH trim_list ')'+ | TRIM '(' LEADING trim_list ')'+ | TRIM '(' TRAILING trim_list ')'+-}+data TrimModifier = BothTrimModifier | LeadingTrimModifier | TrailingTrimModifier+ deriving (Show, Generic, Eq, Ord, Enum, Bounded)++{-+trim_list:+ | a_expr FROM expr_list+ | FROM expr_list+ | expr_list+-}+data TrimList =+ ExprFromExprListTrimList AExpr ExprList |+ FromExprListTrimList ExprList |+ ExprListTrimList ExprList+ deriving (Show, Generic, Eq, Ord)++{-+case_expr:+ | CASE case_arg when_clause_list case_default END_P+-}+data CaseExpr = CaseExpr (Maybe CaseArg) WhenClauseList (Maybe CaseDefault)+ deriving (Show, Generic, Eq, Ord)++{-+case_arg:+ | a_expr+ | EMPTY+-}+type CaseArg = AExpr++{-+when_clause_list:+ | when_clause+ | when_clause_list when_clause+-}+type WhenClauseList = NonEmpty WhenClause++{-+case_default:+ | ELSE a_expr+ | EMPTY+-}+type CaseDefault = AExpr++{-+when_clause:+ | WHEN a_expr THEN a_expr+-}+data WhenClause = WhenClause AExpr AExpr+ deriving (Show, Generic, Eq, Ord)++{-+func_application:+ | func_name '(' ')'+ | func_name '(' func_arg_list opt_sort_clause ')'+ | func_name '(' VARIADIC func_arg_expr opt_sort_clause ')'+ | func_name '(' func_arg_list ',' VARIADIC func_arg_expr opt_sort_clause ')'+ | func_name '(' ALL func_arg_list opt_sort_clause ')'+ | func_name '(' DISTINCT func_arg_list opt_sort_clause ')'+ | func_name '(' '*' ')'+-}+data FuncApplication = FuncApplication FuncName (Maybe FuncApplicationParams)+ deriving (Show, Generic, Eq, Ord)++{-+func_application:+ | func_name '(' ')'+ | func_name '(' func_arg_list opt_sort_clause ')'+ | func_name '(' VARIADIC func_arg_expr opt_sort_clause ')'+ | func_name '(' func_arg_list ',' VARIADIC func_arg_expr opt_sort_clause ')'+ | func_name '(' ALL func_arg_list opt_sort_clause ')'+ | func_name '(' DISTINCT func_arg_list opt_sort_clause ')'+ | func_name '(' '*' ')'+-}+data FuncApplicationParams =+ NormalFuncApplicationParams (Maybe Bool) (NonEmpty FuncArgExpr) (Maybe SortClause) |+ VariadicFuncApplicationParams (Maybe (NonEmpty FuncArgExpr)) FuncArgExpr (Maybe SortClause) |+ StarFuncApplicationParams+ deriving (Show, Generic, Eq, Ord)++data FuncArgExpr =+ ExprFuncArgExpr AExpr |+ ColonEqualsFuncArgExpr Ident AExpr |+ EqualsGreaterFuncArgExpr Ident AExpr+ deriving (Show, Generic, Eq, Ord)+++-- * Constants+-------------------------++type Sconst = Text+type Iconst = Int64+type Fconst = Double+type Bconst = Text+type Xconst = Text++{-|+AexprConst:+ | Iconst+ | FCONST+ | Sconst+ | BCONST+ | XCONST+ | func_name Sconst+ | func_name '(' func_arg_list opt_sort_clause ')' Sconst+ | ConstTypename Sconst+ | ConstInterval Sconst opt_interval+ | ConstInterval '(' Iconst ')' Sconst+ | TRUE_P+ | FALSE_P+ | NULL_P+-}+data AexprConst =+ IAexprConst Iconst |+ FAexprConst Fconst |+ SAexprConst Sconst |+ BAexprConst Bconst |+ XAexprConst Xconst |+ FuncAexprConst FuncName (Maybe FuncConstArgs) Sconst |+ ConstTypenameAexprConst ConstTypename Sconst |+ StringIntervalAexprConst Sconst (Maybe Interval) |+ IntIntervalAexprConst Iconst Sconst |+ BoolAexprConst Bool |+ NullAexprConst+ deriving (Show, Generic, Eq, Ord)++{-+ | func_name '(' func_arg_list opt_sort_clause ')' Sconst+-}+data FuncConstArgs = FuncConstArgs (NonEmpty FuncArgExpr) (Maybe SortClause)+ deriving (Show, Generic, Eq, Ord)++{-+ConstTypename:+ | Numeric+ | ConstBit+ | ConstCharacter+ | ConstDatetime+-}+data ConstTypename =+ NumericConstTypename Numeric |+ ConstBitConstTypename ConstBit |+ ConstCharacterConstTypename ConstCharacter |+ ConstDatetimeConstTypename ConstDatetime+ deriving (Show, Generic, Eq, Ord)++{-+Numeric:+ | INT_P+ | INTEGER+ | SMALLINT+ | BIGINT+ | REAL+ | FLOAT_P opt_float+ | DOUBLE_P PRECISION+ | DECIMAL_P opt_type_modifiers+ | DEC opt_type_modifiers+ | NUMERIC opt_type_modifiers+ | BOOLEAN_P+opt_float:+ | '(' Iconst ')'+ | EMPTY+opt_type_modifiers:+ | '(' expr_list ')'+ | EMPTY+-}+data Numeric =+ IntNumeric |+ IntegerNumeric |+ SmallintNumeric |+ BigintNumeric |+ RealNumeric |+ FloatNumeric (Maybe Int64) |+ DoublePrecisionNumeric |+ DecimalNumeric (Maybe TypeModifiers) |+ DecNumeric (Maybe TypeModifiers) |+ NumericNumeric (Maybe TypeModifiers) |+ BooleanNumeric+ deriving (Show, Generic, Eq, Ord)++{-+Bit:+ | BitWithLength+ | BitWithoutLength+ConstBit:+ | BitWithLength+ | BitWithoutLength+BitWithLength:+ | BIT opt_varying '(' expr_list ')'+BitWithoutLength:+ | BIT opt_varying+-}+data Bit = Bit OptVarying (Maybe ExprList)+ deriving (Show, Generic, Eq, Ord)++type ConstBit = Bit++{-+opt_varying:+ | VARYING+ | EMPTY+-}+type OptVarying = Bool++{-+Character:+ | CharacterWithLength+ | CharacterWithoutLength+ConstCharacter:+ | CharacterWithLength+ | CharacterWithoutLength+CharacterWithLength:+ | character '(' Iconst ')'+CharacterWithoutLength:+ | character+-}+data ConstCharacter = ConstCharacter Character (Maybe Int64)+ deriving (Show, Generic, Eq, Ord)++{-+character:+ | CHARACTER opt_varying+ | CHAR_P opt_varying+ | VARCHAR+ | NATIONAL CHARACTER opt_varying+ | NATIONAL CHAR_P opt_varying+ | NCHAR opt_varying+-}+data Character =+ CharacterCharacter OptVarying |+ CharCharacter OptVarying |+ VarcharCharacter |+ NationalCharacterCharacter OptVarying |+ NationalCharCharacter OptVarying |+ NcharCharacter OptVarying+ deriving (Show, Generic, Eq, Ord)++{-+ConstDatetime:+ | TIMESTAMP '(' Iconst ')' opt_timezone+ | TIMESTAMP opt_timezone+ | TIME '(' Iconst ')' opt_timezone+ | TIME opt_timezone+-}+data ConstDatetime =+ TimestampConstDatetime (Maybe Int64) (Maybe Timezone) |+ TimeConstDatetime (Maybe Int64) (Maybe Timezone)+ deriving (Show, Generic, Eq, Ord)++{-+opt_timezone:+ | WITH_LA TIME ZONE+ | WITHOUT TIME ZONE+ | EMPTY+-}+type Timezone = Bool++{-+opt_interval:+ | YEAR_P+ | MONTH_P+ | DAY_P+ | HOUR_P+ | MINUTE_P+ | interval_second+ | YEAR_P TO MONTH_P+ | DAY_P TO HOUR_P+ | DAY_P TO MINUTE_P+ | DAY_P TO interval_second+ | HOUR_P TO MINUTE_P+ | HOUR_P TO interval_second+ | MINUTE_P TO interval_second+ | EMPTY+-}+data Interval =+ YearInterval | MonthInterval | DayInterval | HourInterval | MinuteInterval |+ SecondInterval IntervalSecond |+ YearToMonthInterval |+ DayToHourInterval |+ DayToMinuteInterval |+ DayToSecondInterval IntervalSecond |+ HourToMinuteInterval |+ HourToSecondInterval IntervalSecond |+ MinuteToSecondInterval IntervalSecond+ deriving (Show, Generic, Eq, Ord)++{-+interval_second:+ | SECOND_P+ | SECOND_P '(' Iconst ')'+-}+type IntervalSecond = Maybe Int64+++-- * Names & References+-------------------------++{-+IDENT+-}+data Ident = QuotedIdent Text | UnquotedIdent Text+ deriving (Show, Generic, Eq, Ord)++{-+ColId:+ | IDENT+ | unreserved_keyword+ | col_name_keyword+-}+type ColId = Ident++{-+ColLabel:+ | IDENT+ | unreserved_keyword+ | col_name_keyword+ | type_func_name_keyword+ | reserved_keyword+-}+type ColLabel = Ident++{-+name:+ | ColId+-}+type Name = ColId++{-+name_list:+ | name+ | name_list ',' name+-}+type NameList = NonEmpty Name++{-+cursor_name:+ | name+-}+type CursorName = Name++{-+columnref:+ | ColId+ | ColId indirection+-}+data Columnref = Columnref ColId (Maybe Indirection)+ deriving (Show, Generic, Eq, Ord)++{-+any_name:+ | ColId+ | ColId attrs+-}+data AnyName = AnyName ColId (Maybe Attrs)+ deriving (Show, Generic, Eq, Ord)++{-+func_name:+ | type_function_name+ | ColId indirection+-}+data FuncName =+ TypeFuncName TypeFunctionName |+ IndirectedFuncName ColId Indirection+ deriving (Show, Generic, Eq, Ord)++{-+type_function_name:+ | IDENT+ | unreserved_keyword+ | type_func_name_keyword+-}+type TypeFunctionName = Ident++{-+columnref:+ | ColId+ | ColId indirection+qualified_name:+ | ColId+ | ColId indirection+-}+data QualifiedName =+ SimpleQualifiedName Ident |+ IndirectedQualifiedName Ident Indirection+ deriving (Show, Generic, Eq, Ord)++{-+indirection:+ | indirection_el+ | indirection indirection_el+-}+type Indirection = NonEmpty IndirectionEl++{-+indirection_el:+ | '.' attr_name+ | '.' '*'+ | '[' a_expr ']'+ | '[' opt_slice_bound ':' opt_slice_bound ']'+opt_slice_bound:+ | a_expr+ | EMPTY+-}+data IndirectionEl =+ AttrNameIndirectionEl Ident |+ AllIndirectionEl |+ ExprIndirectionEl AExpr |+ SliceIndirectionEl (Maybe AExpr) (Maybe AExpr)+ deriving (Show, Generic, Eq, Ord)+++-- * Types+-------------------------++{-|+The only custom extension required for+support of nullability markers in typecasted types.++Consists of:++- Value/element type name+- Value/element nullability marker+- Array dimensions amount+- Array nullability marker+-}+data TypecastTypename = TypecastTypename Ident Bool Int Bool+ deriving (Show, Generic, Eq, Ord)++{-+Typename:+ | SimpleTypename opt_array_bounds+ | SETOF SimpleTypename opt_array_bounds+ | SimpleTypename ARRAY '[' Iconst ']'+ | SETOF SimpleTypename ARRAY '[' Iconst ']'+ | SimpleTypename ARRAY+ | SETOF SimpleTypename ARRAY+-}+data Typename =+ ArrayBoundsTypename Bool SimpleTypename (Maybe ArrayBounds) |+ ArrayDimTypename Bool SimpleTypename (Maybe Iconst)+ deriving (Show, Generic, Eq, Ord)++{-+opt_array_bounds:+ | opt_array_bounds '[' ']'+ | opt_array_bounds '[' Iconst ']'+ | EMPTY+-}+type ArrayBounds = NonEmpty (Maybe Iconst)++{-+SimpleTypename:+ | GenericType+ | Numeric+ | Bit+ | Character+ | ConstDatetime+ | ConstInterval opt_interval+ | ConstInterval '(' Iconst ')'+ConstInterval:+ | INTERVAL+-}+data SimpleTypename =+ GenericTypeSimpleTypename GenericType |+ NumericSimpleTypename Numeric |+ BitSimpleTypename Bit |+ CharacterSimpleTypename Character |+ ConstDatetimeSimpleTypename ConstDatetime |+ ConstIntervalSimpleTypename (Either (Maybe Interval) Iconst)+ deriving (Show, Generic, Eq, Ord)++{-+GenericType:+ | type_function_name opt_type_modifiers+ | type_function_name attrs opt_type_modifiers+-}+data GenericType = GenericType TypeFunctionName (Maybe Attrs) (Maybe TypeModifiers)+ deriving (Show, Generic, Eq, Ord)++{-+attrs:+ | '.' attr_name+ | attrs '.' attr_name+-}+type Attrs = NonEmpty AttrName++{-+attr_name:+ | ColLabel+-}+type AttrName = ColLabel++{-+opt_type_modifiers:+ | '(' expr_list ')'+ | EMPTY+-}+type TypeModifiers = ExprList++{-+type_list:+ | Typename+ | type_list ',' Typename+-}+type TypeList = NonEmpty Typename+++-- * Operators+-------------------------++{-+qual_Op:+ | Op+ | OPERATOR '(' any_operator ')'+-}+data QualOp =+ OpQualOp Op |+ OperatorQualOp AnyOperator+ deriving (Show, Generic, Eq, Ord)++{-+qual_all_Op:+ | all_Op+ | OPERATOR '(' any_operator ')'+-}+data QualAllOp =+ AllQualAllOp AllOp |+ AnyQualAllOp AnyOperator+ deriving (Show, Generic, Eq, Ord)++{-+The operator name is a sequence of up to NAMEDATALEN-1 (63 by default) +characters from the following list:+++ - * / < > = ~ ! @ # % ^ & | ` ?++There are a few restrictions on your choice of name:+-- and /* cannot appear anywhere in an operator name, +since they will be taken as the start of a comment.++A multicharacter operator name cannot end in + or -, +unless the name also contains at least one of these characters:++~ ! @ # % ^ & | ` ?++For example, @- is an allowed operator name, but *- is not. +This restriction allows PostgreSQL to parse SQL-compliant +commands without requiring spaces between tokens.+The use of => as an operator name is deprecated. +It may be disallowed altogether in a future release.++The operator != is mapped to <> on input, +so these two names are always equivalent.+-}+type Op = Text++{-+any_operator:+ | all_Op+ | ColId '.' any_operator+-}+data AnyOperator =+ AllOpAnyOperator AllOp |+ QualifiedAnyOperator ColId AnyOperator+ deriving (Show, Generic, Eq, Ord)++{-+all_Op:+ | Op+ | MathOp+-}+data AllOp =+ OpAllOp Op |+ MathAllOp MathOp+ deriving (Show, Generic, Eq, Ord)++{-+MathOp:+ | '+'+ | '-'+ | '*'+ | '/'+ | '%'+ | '^'+ | '<'+ | '>'+ | '='+ | LESS_EQUALS+ | GREATER_EQUALS+ | NOT_EQUALS+-}+data MathOp =+ PlusMathOp |+ MinusMathOp |+ AsteriskMathOp |+ SlashMathOp |+ PercentMathOp |+ ArrowUpMathOp |+ ArrowLeftMathOp |+ ArrowRightMathOp |+ EqualsMathOp |+ LessEqualsMathOp |+ GreaterEqualsMathOp |+ ArrowLeftArrowRightMathOp |+ ExclamationEqualsMathOp+ deriving (Show, Generic, Eq, Ord, Enum, Bounded)++data SymbolicExprBinOp =+ MathSymbolicExprBinOp MathOp |+ QualSymbolicExprBinOp QualOp+ deriving (Show, Generic, Eq, Ord)++data VerbalExprBinOp =+ LikeVerbalExprBinOp |+ IlikeVerbalExprBinOp |+ SimilarToVerbalExprBinOp+ deriving (Show, Generic, Eq, Ord, Enum, Bounded)++{-+ | a_expr IS NULL_P+ | a_expr IS TRUE_P+ | a_expr IS FALSE_P+ | a_expr IS UNKNOWN+ | a_expr IS DISTINCT FROM a_expr+ | a_expr IS OF '(' type_list ')'+ | a_expr BETWEEN opt_asymmetric b_expr AND a_expr+ | a_expr BETWEEN SYMMETRIC b_expr AND a_expr+ | a_expr IN_P in_expr+ | a_expr IS DOCUMENT_P+-}+data AExprReversableOp =+ NullAExprReversableOp |+ TrueAExprReversableOp |+ FalseAExprReversableOp |+ UnknownAExprReversableOp |+ DistinctFromAExprReversableOp AExpr |+ OfAExprReversableOp TypeList |+ BetweenAExprReversableOp Bool BExpr AExpr |+ BetweenSymmetricAExprReversableOp BExpr AExpr |+ InAExprReversableOp InExpr |+ DocumentAExprReversableOp+ deriving (Show, Generic, Eq, Ord)++{-+ | b_expr IS DISTINCT FROM b_expr+ | b_expr IS NOT DISTINCT FROM b_expr+ | b_expr IS OF '(' type_list ')'+ | b_expr IS NOT OF '(' type_list ')'+ | b_expr IS DOCUMENT_P+ | b_expr IS NOT DOCUMENT_P+-}+data BExprIsOp =+ DistinctFromBExprIsOp BExpr |+ OfBExprIsOp TypeList |+ DocumentBExprIsOp+ deriving (Show, Generic, Eq, Ord)++{-+subquery_Op:+ | all_Op+ | OPERATOR '(' any_operator ')'+ | LIKE+ | NOT_LA LIKE+ | ILIKE+ | NOT_LA ILIKE+-}+data SubqueryOp =+ AllSubqueryOp AllOp |+ AnySubqueryOp AnyOperator |+ LikeSubqueryOp Bool |+ IlikeSubqueryOp Bool+ deriving (Show, Generic, Eq, Ord)+++-- * Indexes+-------------------------++{-+index_params:+ | index_elem+ | index_params ',' index_elem+-}+type IndexParams = NonEmpty IndexElem++{-+index_elem:+ | ColId opt_collate opt_class opt_asc_desc opt_nulls_order+ | func_expr_windowless opt_collate opt_class opt_asc_desc opt_nulls_order+ | '(' a_expr ')' opt_collate opt_class opt_asc_desc opt_nulls_order+-}+data IndexElem = IndexElem IndexElemDef (Maybe Collate) (Maybe Class) (Maybe AscDesc) (Maybe NullsOrder)+ deriving (Show, Generic, Eq, Ord)++{-+ | ColId opt_collate opt_class opt_asc_desc opt_nulls_order+ | func_expr_windowless opt_collate opt_class opt_asc_desc opt_nulls_order+ | '(' a_expr ')' opt_collate opt_class opt_asc_desc opt_nulls_order+-}+data IndexElemDef =+ IdIndexElemDef ColId |+ FuncIndexElemDef FuncExprWindowless |+ ExprIndexElemDef AExpr+ deriving (Show, Generic, Eq, Ord)++{-+opt_collate:+ | COLLATE any_name+ | EMPTY+-}+type Collate = AnyName++{-+opt_class:+ | any_name+ | EMPTY+-}+type Class = AnyName++{-+opt_asc_desc:+ | ASC+ | DESC+ | EMPTY+-}+data AscDesc = AscAscDesc | DescAscDesc+ deriving (Show, Generic, Eq, Ord, Enum, Bounded)++{-+opt_nulls_order:+ | NULLS_LA FIRST_P+ | NULLS_LA LAST_P+ | EMPTY+-}+data NullsOrder = FirstNullsOrder | LastNullsOrder+ deriving (Show, Generic, Eq, Ord, Enum, Bounded)
+ library/Hasql/TH/Syntax/Extraction.hs view
@@ -0,0 +1,106 @@+module Hasql.TH.Syntax.Extraction where++import Hasql.TH.Prelude+import Hasql.TH.Syntax.Ast+import qualified Language.Haskell.TH as TH+import qualified Hasql.TH.Syntax.Parsing as Parsing+import qualified Hasql.TH.Syntax.Projections.InputTypeList as InputTypeList+import qualified Hasql.TH.Syntax.Projections.OutputTypeList as OutputTypeList+import qualified Hasql.TH.Syntax.Rendering as Rendering+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Decoders as Decoders+++data Statement = Statement ByteString [Encoder] [Decoder]++data Encoder = Encoder TH.Name Bool Int Bool++data Decoder = Decoder TH.Name Bool Int Bool++statement :: Text -> Either Text Statement+statement _quote = do+ _preparableStmt <- ast _quote+ _inputTypeList <- InputTypeList.preparableStmt _preparableStmt+ _outputTypeList <- OutputTypeList.preparableStmt _preparableStmt+ _encoderList <- traverse encoder _inputTypeList+ _decoderList <- traverse decoder _outputTypeList+ let _sql = Rendering.toByteString (Rendering.preparableStmt _preparableStmt)+ return (Statement _sql _encoderList _decoderList)++rowlessStatement :: Text -> Either Text Statement+rowlessStatement _quote = do+ _preparableStmt <- ast _quote+ _inputTypeList <- InputTypeList.preparableStmt _preparableStmt+ _encoderList <- traverse encoder _inputTypeList+ let _sql = Rendering.toByteString (Rendering.preparableStmt _preparableStmt)+ return (Statement _sql _encoderList [])++ast :: Text -> Either Text PreparableStmt+ast = first fromString . Parsing.run (Parsing.quasiQuote Parsing.preparableStmt)++encoder :: TypecastTypename -> Either Text Encoder+encoder (TypecastTypename _name _nullable _dimensions _arrayNullable) =do+ _identText <- identText _name+ encoderName _identText <&> \ _name' ->+ Encoder _name' _nullable _dimensions _arrayNullable++encoderName :: Text -> Either Text TH.Name+encoderName = \ case+ "bool" -> Right 'Encoders.bool+ "int2" -> Right 'Encoders.int2+ "int4" -> Right 'Encoders.int4+ "int8" -> Right 'Encoders.int8+ "float4" -> Right 'Encoders.float4+ "float8" -> Right 'Encoders.float8+ "numeric" -> Right 'Encoders.numeric+ "char" -> Right 'Encoders.char+ "text" -> Right 'Encoders.text+ "bytea" -> Right 'Encoders.bytea+ "date" -> Right 'Encoders.date+ "timestamp" -> Right 'Encoders.timestamp+ "timestamptz" -> Right 'Encoders.timestamptz+ "time" -> Right 'Encoders.time+ "timetz" -> Right 'Encoders.timetz+ "interval" -> Right 'Encoders.interval+ "uuid" -> Right 'Encoders.uuid+ "inet" -> Right 'Encoders.inet+ "json" -> Right 'Encoders.json+ "jsonb" -> Right 'Encoders.jsonb+ "enum" -> Right 'Encoders.enum+ name -> Left ("No value encoder exists for type: " <> name)++decoder :: TypecastTypename -> Either Text Decoder+decoder (TypecastTypename _name _nullable _dimensions _arrayNullable) = do+ _identText <- identText _name+ decoderName _identText <&> \ _name' ->+ Decoder _name' _nullable _dimensions _arrayNullable++decoderName :: Text -> Either Text TH.Name+decoderName = \ case+ "bool" -> Right 'Decoders.bool+ "int2" -> Right 'Decoders.int2+ "int4" -> Right 'Decoders.int4+ "int8" -> Right 'Decoders.int8+ "float4" -> Right 'Decoders.float4+ "float8" -> Right 'Decoders.float8+ "numeric" -> Right 'Decoders.numeric+ "char" -> Right 'Decoders.char+ "text" -> Right 'Decoders.text+ "bytea" -> Right 'Decoders.bytea+ "date" -> Right 'Decoders.date+ "timestamp" -> Right 'Decoders.timestamp+ "timestamptz" -> Right 'Decoders.timestamptz+ "time" -> Right 'Decoders.time+ "timetz" -> Right 'Decoders.timetz+ "interval" -> Right 'Decoders.interval+ "uuid" -> Right 'Decoders.uuid+ "inet" -> Right 'Decoders.inet+ "json" -> Right 'Decoders.json+ "jsonb" -> Right 'Decoders.jsonb+ "enum" -> Right 'Decoders.enum+ name -> Left ("No value decoder exists for type: " <> name)++identText :: Ident -> Either Text Text+identText = \ case+ QuotedIdent a -> Right a+ UnquotedIdent a -> Right a
+ library/Hasql/TH/Syntax/HashSet.hs view
@@ -0,0 +1,70 @@+module Hasql.TH.Syntax.HashSet where++import Hasql.TH.Prelude hiding (expression, fromList, toList)+import Data.HashSet+import qualified Data.Text as Text+++{-# NOINLINE keyword #-}+keyword :: HashSet Text+keyword = unreservedKeyword <> colNameKeyword <> typeFuncNameKeyword <> reservedKeyword++{-# NOINLINE unreservedKeyword #-}+unreservedKeyword :: HashSet Text+unreservedKeyword = fromList ["abort", "absolute", "access", "action", "add", "admin", "after", "aggregate", "also", "alter", "always", "assertion", "assignment", "at", "attach", "attribute", "backward", "before", "begin", "by", "cache", "call", "called", "cascade", "cascaded", "catalog", "chain", "characteristics", "checkpoint", "class", "close", "cluster", "columns", "comment", "comments", "commit", "committed", "configuration", "conflict", "connection", "constraints", "content", "continue", "conversion", "copy", "cost", "csv", "cube", "current", "cursor", "cycle", "data", "database", "day", "deallocate", "declare", "defaults", "deferred", "definer", "delete", "delimiter", "delimiters", "depends", "detach", "dictionary", "disable", "discard", "document", "domain", "double", "drop", "each", "enable", "encoding", "encrypted", "enum", "escape", "event", "exclude", "excluding", "exclusive", "execute", "explain", "extension", "external", "family", "filter", "first", "following", "force", "forward", "function", "functions", "generated", "global", "granted", "groups", "handler", "header", "hold", "hour", "identity", "if", "immediate", "immutable", "implicit", "import", "include", "including", "increment", "index", "indexes", "inherit", "inherits", "inline", "input", "insensitive", "insert", "instead", "invoker", "isolation", "key", "label", "language", "large", "last", "leakproof", "level", "listen", "load", "local", "location", "lock", "locked", "logged", "mapping", "match", "materialized", "maxvalue", "method", "minute", "minvalue", "mode", "month", "move", "name", "names", "new", "next", "no", "nothing", "notify", "nowait", "nulls", "object", "of", "off", "oids", "old", "operator", "option", "options", "ordinality", "others", "over", "overriding", "owned", "owner", "parallel", "parser", "partial", "partition", "passing", "password", "plans", "policy", "preceding", "prepare", "prepared", "preserve", "prior", "privileges", "procedural", "procedure", "procedures", "program", "publication", "quote", "range", "read", "reassign", "recheck", "recursive", "ref", "referencing", "refresh", "reindex", "relative", "release", "rename", "repeatable", "replace", "replica", "reset", "restart", "restrict", "returns", "revoke", "role", "rollback", "rollup", "routine", "routines", "rows", "rule", "savepoint", "schema", "schemas", "scroll", "search", "second", "security", "sequence", "sequences", "serializable", "server", "session", "set", "sets", "share", "show", "simple", "skip", "snapshot", "sql", "stable", "standalone", "start", "statement", "statistics", "stdin", "stdout", "storage", "stored", "strict", "strip", "subscription", "support", "sysid", "system", "tables", "tablespace", "temp", "template", "temporary", "text", "ties", "transaction", "transform", "trigger", "truncate", "trusted", "type", "types", "unbounded", "uncommitted", "unencrypted", "unknown", "unlisten", "unlogged", "until", "update", "vacuum", "valid", "validate", "validator", "value", "varying", "version", "view", "views", "volatile", "whitespace", "within", "without", "work", "wrapper", "write", "xml", "year", "yes", "zone"]++{-# NOINLINE colNameKeyword #-}+colNameKeyword :: HashSet Text+colNameKeyword = fromList ["between", "bigint", "bit", "boolean", "char", "character", "coalesce", "dec", "decimal", "exists", "extract", "float", "greatest", "grouping", "inout", "int", "integer", "interval", "least", "national", "nchar", "none", "nullif", "numeric", "out", "overlay", "position", "precision", "real", "row", "setof", "smallint", "substring", "time", "timestamp", "treat", "trim", "values", "varchar", "xmlattributes", "xmlconcat", "xmlelement", "xmlexists", "xmlforest", "xmlnamespaces", "xmlparse", "xmlpi", "xmlroot", "xmlserialize", "xmltable"]++{-# NOINLINE typeFuncNameKeyword #-}+typeFuncNameKeyword :: HashSet Text+typeFuncNameKeyword = fromList ["authorization", "binary", "collation", "concurrently", "cross", "current_schema", "freeze", "full", "ilike", "inner", "is", "isnull", "join", "left", "like", "natural", "notnull", "outer", "overlaps", "right", "similar", "tablesample", "verbose"]++{-# NOINLINE reservedKeyword #-}+reservedKeyword :: HashSet Text+reservedKeyword = fromList ["all", "analyse", "analyze", "and", "any", "array", "as", "asc", "asymmetric", "both", "case", "cast", "check", "collate", "column", "constraint", "create", "current_catalog", "current_date", "current_role", "current_time", "current_timestamp", "current_user", "default", "deferrable", "desc", "distinct", "do", "else", "end", "except", "false", "fetch", "for", "foreign", "from", "grant", "group", "having", "in", "initially", "intersect", "into", "lateral", "leading", "limit", "localtime", "localtimestamp", "not", "null", "offset", "on", "only", "or", "order", "placing", "primary", "references", "returning", "select", "session_user", "some", "symmetric", "table", "then", "to", "trailing", "true", "union", "unique", "user", "using", "variadic", "when", "where", "window", "with"]++{-# NOINLINE symbolicBinOp #-}+symbolicBinOp :: HashSet Text+symbolicBinOp = fromList ["+", "-", "*", "/", "%", "^", "<", ">", "=", "<=", ">=", "<>", "~~", "~~*", "!~~", "!~~*", "~", "~*", "!~", "!~*"]++{-# NOINLINE lexicalBinOp #-}+lexicalBinOp :: HashSet Text+lexicalBinOp = fromList ["and", "or"]++{-# NOINLINE symbolicBinOpChars #-}+symbolicBinOpChars :: HashSet Char+symbolicBinOpChars = symbolicBinOp & toList & mconcat & Text.unpack & fromList++{-# NOINLINE hexDigitChars #-}+hexDigitChars :: HashSet Char+hexDigitChars = fromList "0123456789abcdefABCDEF"++{-# NOINLINE colId #-}+colId = unions [unreservedKeyword, colNameKeyword]++{-# NOINLINE typeFunctionName #-}+typeFunctionName = unions [unreservedKeyword, typeFuncNameKeyword]++{-# NOINLINE opChars #-}+opChars = fromList "+-*/<>=~!@#%^&|`?"++{-# NOINLINE prohibitionLiftingOpChars #-}+prohibitionLiftingOpChars = fromList "~!@#%^&|`?"++{-|+As per the following comment from the original scanner definition:++/*+ * Likewise, if what we have left is two chars, and+ * those match the tokens ">=", "<=", "=>", "<>" or+ * "!=", then we must return the appropriate token+ * rather than the generic Op.+ */+-}+{-# NOINLINE nonOp #-}+nonOp = fromList [">=", "<=", "=>", "<>", "!="] <> mathOp++{-# NOINLINE mathOp #-}+mathOp = fromList ["<>", ">=", "!=", "<=", "+", "-", "*", "/", "%", "^", "<", ">", "="]
+ library/Hasql/TH/Syntax/Parsing.hs view
@@ -0,0 +1,2136 @@+{-|++Our parsing strategy is to port the original Postgres parser as closely as possible.++We're using the @gram.y@ Postgres source file, which is the closest thing we have+to a Postgres syntax spec. Here's a link to it:+https://github.com/postgres/postgres/blob/master/src/backend/parser/gram.y.++Here's the essence of how the original parser is implemented, citing from+[PostgreSQL Wiki](https://wiki.postgresql.org/wiki/Developer_FAQ):++ scan.l defines the lexer, i.e. the algorithm that splits a string+ (containing an SQL statement) into a stream of tokens.+ A token is usually a single word+ (i.e., doesn't contain spaces but is delimited by spaces), + but can also be a whole single or double-quoted string for example. + The lexer is basically defined in terms of regular expressions + which describe the different token types.++ gram.y defines the grammar (the syntactical structure) of SQL statements,+ using the tokens generated by the lexer as basic building blocks.+ The grammar is defined in BNF notation.+ BNF resembles regular expressions but works on the level of tokens, not characters.+ Also, patterns (called rules or productions in BNF) are named, and may be recursive,+ i.e. use themselves as sub-patterns.++-}+module Hasql.TH.Syntax.Parsing where++import Hasql.TH.Prelude hiding (expr, try, option, some, many, sortBy, filter, head, tail, bit, fromList)+import HeadedMegaparsec hiding (string)+import Control.Applicative.Combinators hiding (some)+import Control.Applicative.Combinators.NonEmpty+import Hasql.TH.Extras.HeadedMegaparsec hiding (run)+import Hasql.TH.Syntax.Ast+import Text.Megaparsec (Stream, Parsec)+import qualified Hasql.TH.Extras.HeadedMegaparsec as Extras+import qualified Hasql.TH.Extras.NonEmpty as NonEmpty+import qualified Text.Megaparsec as Megaparsec+import qualified Text.Megaparsec.Char as MegaparsecChar+import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer+import qualified Hasql.TH.Syntax.HashSet as HashSet+import qualified Hasql.TH.Syntax.Predicate as Predicate+import qualified Hasql.TH.Syntax.Validator as Validator+import qualified Data.Text as Text+import qualified Data.List.NonEmpty as NonEmpty+import qualified Text.Builder as TextBuilder+import qualified Data.HashSet as HashSet+++{- $setup+>>> testParser parser = either putStr print . run parser+-}+++type Parser = HeadedParsec Void Text+++-- * Executors+-------------------------++run :: Parser a -> Text -> Either String a+run = Extras.run+++-- * Helpers+-------------------------++commaSeparator :: Parser ()+commaSeparator = space *> char ',' *> endHead *> space++dotSeparator :: Parser ()+dotSeparator = space *> char '.' *> endHead *> space++inBrackets :: Parser a -> Parser a+inBrackets p = char '[' *> space *> p <* endHead <* space <* char ']'++inBracketsCont :: Parser a -> Parser (Parser a)+inBracketsCont p = char '[' *> endHead *> pure (space *> p <* endHead <* space <* char ']')++inParens :: Parser a -> Parser a+inParens p = char '(' *> space *> p <* endHead <* space <* char ')'++inParensCont :: Parser a -> Parser (Parser a)+inParensCont p = char '(' *> endHead *> pure (space *> p <* endHead <* space <* char ')')++inParensWithLabel :: (label -> content -> result) -> Parser label -> Parser content -> Parser result+inParensWithLabel _result _labelParser _contentParser = do+ _label <- wrapToHead _labelParser+ space+ char '('+ endHead+ space+ _content <- _contentParser+ space+ char ')'+ pure (_result _label _content)++inParensWithClause :: Parser clause -> Parser content -> Parser content+inParensWithClause = inParensWithLabel (const id)++trueIfPresent :: Parser a -> Parser Bool+trueIfPresent p = option False (True <$ p)++{-|+>>> testParser (quotedString '\'') "'abc''d'"+"abc'd"+-}+quotedString :: Char -> Parser Text+quotedString q = do+ char q+ endHead+ _tail <- parse $ let+ collectChunks !bdr = do+ chunk <- Megaparsec.takeWhileP Nothing (/= q)+ let bdr' = bdr <> TextBuilder.text chunk+ Megaparsec.try (consumeEscapedQuote bdr') <|> finish bdr'+ consumeEscapedQuote bdr = do+ MegaparsecChar.char q+ MegaparsecChar.char q+ collectChunks (bdr <> TextBuilder.char q)+ finish bdr = do+ MegaparsecChar.char q+ return (TextBuilder.run bdr)+ in collectChunks mempty+ return _tail++quasiQuote :: Parser a -> Parser a+quasiQuote p = space *> p <* endHead <* space <* eof+++-- * PreparableStmt+-------------------------++preparableStmt =+ SelectPreparableStmt <$> selectStmt <|>+ InsertPreparableStmt <$> insertStmt <|>+ UpdatePreparableStmt <$> updateStmt <|>+ DeletePreparableStmt <$> deleteStmt+++-- * Insert+-------------------------++insertStmt = do+ a <- optional (wrapToHead withClause <* space1)+ string' "insert"+ space1+ endHead+ string' "into"+ space1+ b <- insertTarget+ space1+ c <- insertRest+ d <- optional (space1 *> onConflict)+ e <- optional (space1 *> returningClause)+ return (InsertStmt a b c d e)++insertTarget = do+ a <- qualifiedName+ endHead+ b <- optional (space1 *> string' "as" *> space1 *> endHead *> colId)+ return (InsertTarget a b)++insertRest = asum [+ DefaultValuesInsertRest <$ (string' "default" *> space1 *> endHead *> string' "values")+ ,+ do+ a <- optional (inParens insertColumnList <* space1)+ b <- optional $ do+ string' "overriding"+ space1+ endHead+ b <- overrideKind+ space1+ string' "value"+ space1+ return b+ c <- selectStmt+ return (SelectInsertRest a b c)+ ]++overrideKind = asum [+ UserOverrideKind <$ string' "user",+ SystemOverrideKind <$ string' "system"+ ]++insertColumnList = sep1 commaSeparator insertColumnItem++insertColumnItem = do+ a <- colId+ endHead+ b <- optional (space1 *> indirection)+ return (InsertColumnItem a b)++onConflict = do+ string' "on"+ space1+ string' "conflict"+ space1+ endHead+ a <- optional (confExpr <* space1)+ string' "do"+ space1+ b <- onConflictDo+ return (OnConflict a b)++confExpr = asum [+ WhereConfExpr <$> inParens indexParams <*> optional (space *> whereClause)+ ,+ ConstraintConfExpr <$> (string' "on" *> space1 *> string' "constraint" *> space1 *> endHead *> name)+ ]++onConflictDo = asum [+ NothingOnConflictDo <$ string' "nothing"+ ,+ do+ string' "update"+ space1+ endHead+ string' "set"+ space1+ a <- setClauseList+ b <- optional (space1 *> whereClause)+ return (UpdateOnConflictDo a b)+ ]++returningClause = do+ string' "returning"+ space1+ endHead+ targetList+++-- * Update+-------------------------++updateStmt = do+ a <- optional (wrapToHead withClause <* space1)+ string' "update"+ space1+ endHead+ b <- relationExprOptAlias ["set"]+ space1+ string' "set"+ space1+ c <- setClauseList+ d <- optional (space1 *> fromClause)+ e <- optional (space1 *> whereOrCurrentClause)+ f <- optional (space1 *> returningClause)+ return (UpdateStmt a b c d e f)++setClauseList = sep1 commaSeparator setClause++setClause = asum [+ do+ a <- inParens setTargetList + space+ char '='+ space+ b <- aExpr+ return (TargetListSetClause a b)+ ,+ do+ a <- setTarget + space+ char '='+ space+ b <- aExpr+ return (TargetSetClause a b)+ ]++setTarget = do+ a <- colId+ endHead+ b <- optional (space1 *> indirection)+ return (SetTarget a b)++setTargetList = sep1 commaSeparator setTarget+++-- * Delete+-------------------------++deleteStmt = do+ a <- optional (wrapToHead withClause <* space1)+ string' "delete"+ space1+ endHead+ string' "from"+ space1+ b <- relationExprOptAlias ["using", "where", "returning"]+ c <- optional (space1 *> usingClause)+ d <- optional (space1 *> whereOrCurrentClause)+ e <- optional (space1 *> returningClause)+ return (DeleteStmt a b c d e)++usingClause = do+ string' "using"+ space1+ fromList+++-- * Select+-------------------------++{-|+>>> test = testParser selectStmt++>>> test "select id from as"+...+ |+1 | select id from as+ | ^+Reserved keyword "as" used as an identifier. If that's what you intend, you have to wrap it in double quotes.+-}+selectStmt = Left <$> selectNoParens <|> Right <$> selectWithParens++selectWithParens = inParens (WithParensSelectWithParens <$> selectWithParens <|> NoParensSelectWithParens <$> selectNoParens)++selectNoParens = withSelectNoParens <|> simpleSelectNoParens++sharedSelectNoParens _with = do+ _select <- selectClause+ _sort <- optional (space1 *> sortClause)+ _limit <- optional (space1 *> selectLimit)+ _forLocking <- optional (space1 *> forLockingClause)+ return (SelectNoParens _with _select _sort _limit _forLocking)++{-|+The one that doesn't start with \"WITH\".+-}+{-+ | simple_select+ | select_clause sort_clause+ | select_clause opt_sort_clause for_locking_clause opt_select_limit+ | select_clause opt_sort_clause select_limit opt_for_locking_clause+-}+simpleSelectNoParens = sharedSelectNoParens Nothing++withSelectNoParens = do+ _with <- wrapToHead withClause+ space1+ sharedSelectNoParens (Just _with)++selectClause = suffixRec base suffix where+ base = asum [+ Right <$> selectWithParens,+ Left <$> baseSimpleSelect+ ]+ suffix a = Left <$> extensionSimpleSelect a++baseSimpleSelect = asum [+ do+ string' "select"+ notFollowedBy $ satisfy $ isAlphaNum+ endHead+ _targeting <- optional (space1 *> targeting)+ _intoClause <- optional (space1 *> string' "into" *> endHead *> space1 *> optTempTableName)+ _fromClause <- optional (space1 *> fromClause)+ _whereClause <- optional (space1 *> whereClause)+ _groupClause <- optional (space1 *> keyphrase "group by" *> endHead *> space1 *> sep1 commaSeparator groupByItem)+ _havingClause <- optional (space1 *> string' "having" *> endHead *> space1 *> aExpr)+ _windowClause <- optional (space1 *> string' "window" *> endHead *> space1 *> sep1 commaSeparator windowDefinition)+ return (NormalSimpleSelect _targeting _intoClause _fromClause _whereClause _groupClause _havingClause _windowClause)+ ,+ do+ string' "table"+ space1+ endHead+ TableSimpleSelect <$> relationExpr+ ,+ ValuesSimpleSelect <$> valuesClause+ ]++extensionSimpleSelect _headSelectClause = do+ _op <- space1 *> selectBinOp <* space1+ endHead+ _allOrDistinct <- optional (allOrDistinct <* space1)+ _selectClause <- selectClause+ return (BinSimpleSelect _op _headSelectClause _allOrDistinct _selectClause)+ +allOrDistinct = string' "all" $> False <|> string' "distinct" $> True++selectBinOp = asum [+ string' "union" $> UnionSelectBinOp,+ string' "intersect" $> IntersectSelectBinOp,+ string' "except" $> ExceptSelectBinOp+ ]++valuesClause = do+ string' "values"+ space+ sep1 commaSeparator $ do+ char '('+ endHead+ space+ _a <- sep1 commaSeparator aExpr+ space+ char ')'+ return _a++withClause = label "with clause" $ do+ string' "with"+ space1+ endHead+ _recursive <- option False (True <$ string' "recursive" <* space1)+ _cteList <- sep1 commaSeparator commonTableExpr+ return (WithClause _recursive _cteList)++commonTableExpr = label "common table expression" $ do+ _name <- colId <* space <* endHead+ _nameList <- optional (inParens (sep1 commaSeparator colId) <* space1)+ string' "as"+ space1+ _materialized <- optional (materialized <* space1)+ _stmt <- inParens preparableStmt+ return (CommonTableExpr _name _nameList _materialized _stmt)++materialized =+ True <$ string' "materialized" <|>+ False <$ keyphrase "not materialized"++targeting = distinct <|> allWithTargetList <|> all <|> normal where+ normal = NormalTargeting <$> targetList+ allWithTargetList = do+ string' "all"+ space1+ AllTargeting <$> Just <$> targetList+ all = string' "all" $> AllTargeting Nothing+ distinct = do+ string' "distinct"+ space1+ endHead+ _optOn <- optional (onExpressionsClause <* space1)+ _targetList <- targetList+ return (DistinctTargeting _optOn _targetList)++targetList = sep1 commaSeparator targetEl++{-|+>>> testParser targetEl "a.b as c"+AliasedExprTargetEl (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") (Just (AttrNameIndirectionEl (UnquotedIdent "b") :| []))))) (UnquotedIdent "c")+-}+targetEl = label "target" $ asum [+ do+ _expr <- aExpr+ asum [+ do+ space1+ asum [+ AliasedExprTargetEl _expr <$> (string' "as" *> space1 *> endHead *> colLabel)+ ,+ ImplicitlyAliasedExprTargetEl _expr <$> ident+ ]+ ,+ pure (ExprTargetEl _expr)+ ]+ ,+ AsteriskTargetEl <$ char '*'+ ]++onExpressionsClause = do+ string' "on"+ space1+ endHead+ inParens (sep1 commaSeparator aExpr)+++-- * Into clause details+-------------------------++{-+OptTempTableName:+ | TEMPORARY opt_table qualified_name+ | TEMP opt_table qualified_name+ | LOCAL TEMPORARY opt_table qualified_name+ | LOCAL TEMP opt_table qualified_name+ | GLOBAL TEMPORARY opt_table qualified_name+ | GLOBAL TEMP opt_table qualified_name+ | UNLOGGED opt_table qualified_name+ | TABLE qualified_name+ | qualified_name+-}+optTempTableName = asum [+ do+ a <- asum [+ TemporaryOptTempTableName <$ string' "temporary" <* space1,+ TempOptTempTableName <$ string' "temp" <* space1,+ LocalTemporaryOptTempTableName <$ string' "local temporary" <* space1,+ LocalTempOptTempTableName <$ string' "local temp" <* space1,+ GlobalTemporaryOptTempTableName <$ string' "global temporary" <* space1,+ GlobalTempOptTempTableName <$ string' "global temp" <* space1,+ UnloggedOptTempTableName <$ string' "unlogged" <* space1+ ]+ b <- option False (True <$ string' "table" <* space1)+ c <- qualifiedName+ return (a b c)+ ,+ do+ string' "table"+ space1+ endHead+ TableOptTempTableName <$> qualifiedName+ ,+ QualifedOptTempTableName <$> qualifiedName+ ]+++-- * Group by details+-------------------------++groupByItem = asum [+ EmptyGroupingSetGroupByItem <$ (char '(' *> space *> char ')'),+ RollupGroupByItem <$> (string' "rollup" *> endHead *> space *> inParens (sep1 commaSeparator aExpr)),+ CubeGroupByItem <$> (string' "cube" *> endHead *> space *> inParens (sep1 commaSeparator aExpr)),+ GroupingSetsGroupByItem <$> (keyphrase "grouping sets" *> endHead *> space *> inParens (sep1 commaSeparator groupByItem)),+ ExprGroupByItem <$> aExpr+ ]+++-- * Window clause details+-------------------------++windowDefinition = WindowDefinition <$> (colId <* space1 <* string' "as" <* space1 <* endHead) <*> windowSpecification++{-+window_specification:+ | '(' opt_existing_window_name opt_partition_clause+ opt_sort_clause opt_frame_clause ')'+-}+windowSpecification = inParens $ asum [+ do+ a <- frameClause+ return (WindowSpecification Nothing Nothing Nothing (Just a))+ ,+ do+ a <- sortClause+ b <- optional (space1 *> frameClause)+ return (WindowSpecification Nothing Nothing (Just a) b)+ ,+ do+ a <- partitionByClause+ b <- optional (space1 *> sortClause)+ c <- optional (space1 *> frameClause)+ return (WindowSpecification Nothing (Just a) b c)+ ,+ do+ a <- colId+ b <- optional (space1 *> partitionByClause)+ c <- optional (space1 *> sortClause)+ d <- optional (space1 *> frameClause)+ return (WindowSpecification (Just a) b c d)+ ,+ pure (WindowSpecification Nothing Nothing Nothing Nothing)+ ]++partitionByClause = keyphrase "partition by" *> space1 *> endHead *> sep1 commaSeparator aExpr++{-+opt_frame_clause:+ | RANGE frame_extent opt_window_exclusion_clause+ | ROWS frame_extent opt_window_exclusion_clause+ | GROUPS frame_extent opt_window_exclusion_clause+ | EMPTY+-}+frameClause = do+ a <- frameClauseMode <* space1 <* endHead+ b <- frameExtent+ c <- optional (space1 *> windowExclusionClause)+ return (FrameClause a b c)++frameClauseMode = asum [+ RangeFrameClauseMode <$ string' "range",+ RowsFrameClauseMode <$ string' "rows",+ GroupsFrameClauseMode <$ string' "groups"+ ]++frameExtent =+ BetweenFrameExtent <$> (string' "between" *> space1 *> endHead *> frameBound <* space1 <* string' "and" <* space1) <*> frameBound <|>+ SingularFrameExtent <$> frameBound++{-+ | UNBOUNDED PRECEDING+ | UNBOUNDED FOLLOWING+ | CURRENT_P ROW+ | a_expr PRECEDING+ | a_expr FOLLOWING+-}+frameBound =+ UnboundedPrecedingFrameBound <$ keyphrase "unbounded preceding" <|>+ UnboundedFollowingFrameBound <$ keyphrase "unbounded following" <|>+ CurrentRowFrameBound <$ keyphrase "current row" <|>+ do+ a <- aExpr+ space1+ PrecedingFrameBound a <$ string' "preceding" <|> FollowingFrameBound a <$ string' "following"++windowExclusionClause =+ CurrentRowWindowExclusionClause <$ keyphrase "exclude current row" <|>+ GroupWindowExclusionClause <$ keyphrase "exclude group" <|>+ TiesWindowExclusionClause <$ keyphrase "exclude ties" <|>+ NoOthersWindowExclusionClause <$ keyphrase "exclude no others"+++-- * Table refs+-------------------------++fromList = sep1 commaSeparator tableRef++fromClause = string' "from" *> endHead *> space1 *> fromList++{-|+>>> testParser tableRef "a left join b "+...+expecting "on", "using", or white space++>>> testParser tableRef "a left join b on (a.i = b.i)"+JoinTableRef (MethJoinedTable (QualJoinMeth...++-}+tableRef = label "table reference" $ do+ _tr <- nonTrailingTableRef+ (space1 *> trailingTableRef _tr) <|> pure _tr++nonTrailingTableRef = asum [+ lateralTableRef <|>+ wrapToHead nonLateralTableRef <|>+ relationExprTableRef <|>+ joinedTableWithAliasTableRef <|>+ inParensJoinedTableTableRef+ ]+ where+ + {-+ | relation_expr opt_alias_clause+ | relation_expr opt_alias_clause tablesample_clause+ -}+ relationExprTableRef = do+ _relationExpr <- relationExpr+ endHead+ _optAliasClause <- optional (space1 *> aliasClause)+ _optTablesampleClause <- optional (space1 *> tablesampleClause)+ return (RelationExprTableRef _relationExpr _optAliasClause _optTablesampleClause)++ {-+ | LATERAL_P func_table func_alias_clause+ | LATERAL_P xmltable opt_alias_clause+ | LATERAL_P select_with_parens opt_alias_clause+ TODO: add xmltable+ -}+ lateralTableRef = do+ string' "lateral"+ space1+ endHead+ lateralableTableRef True++ nonLateralTableRef = lateralableTableRef False++ lateralableTableRef _lateral = asum [+ do+ a <- funcTable+ b <- optional (space1 *> funcAliasClause)+ return (FuncTableRef _lateral a b)+ ,+ do+ _select <- selectWithParens+ _optAliasClause <- optional $ space1 *> aliasClause+ return (SelectTableRef _lateral _select _optAliasClause)+ ]++ inParensJoinedTableTableRef = JoinTableRef <$> inParensJoinedTable <*> pure Nothing++ joinedTableWithAliasTableRef = do+ _joinedTable <- wrapToHead (inParens joinedTable)+ space1+ _alias <- aliasClause+ return (JoinTableRef _joinedTable (Just _alias))++trailingTableRef _tableRef =+ JoinTableRef <$> trailingJoinedTable _tableRef <*> pure Nothing++relationExpr =+ label "relation expression" $+ asum+ [+ do+ string' "only"+ space1+ _name <- qualifiedName+ return (OnlyRelationExpr _name False) + ,+ inParensWithClause (string' "only") qualifiedName <&> \ a -> OnlyRelationExpr a True+ ,+ do+ _name <- qualifiedName+ _asterisk <- asum+ [+ True <$ (space1 *> char '*'),+ pure False+ ]+ return (SimpleRelationExpr _name _asterisk)+ ]++relationExprOptAlias reservedKeywords = do+ a <- relationExpr+ b <- optional $ do+ space1+ b <- trueIfPresent (string' "as" *> space1)+ c <- filteredColId reservedKeywords+ return (b, c)+ return (RelationExprOptAlias a b)++tablesampleClause = do+ string' "tablesample"+ space1+ endHead+ a <- funcName+ space+ b <- inParens exprList+ c <- optional (space *> repeatableClause)+ return (TablesampleClause a b c)++repeatableClause = do+ string' "repeatable"+ space+ inParens (endHead *> aExpr)++funcTable = asum [+ do+ string' "rows"+ space1+ string' "from"+ space+ a <- inParens (endHead *> rowsfromList)+ b <- trueIfPresent (space *> optOrdinality)+ return (RowsFromFuncTable a b)+ ,+ do+ a <- funcExprWindowless+ b <- trueIfPresent (space1 *> optOrdinality)+ return (FuncExprFuncTable a b)+ ]++rowsfromItem = do+ a <- funcExprWindowless+ endHead+ b <- optional (space1 *> colDefList)+ return (RowsfromItem a b)++rowsfromList = sep1 commaSeparator rowsfromItem++colDefList = string' "as" *> space *> inParens (endHead *> tableFuncElementList)++optOrdinality = string' "with" *> space1 *> string' "ordinality"++tableFuncElementList = sep1 commaSeparator tableFuncElement++tableFuncElement = do+ a <- wrapToHead colId+ space1+ b <- typename+ c <- optional (space1 *> collateClause)+ return (TableFuncElement a b c)++collateClause = string' "collate" *> space1 *> endHead *> anyName++funcAliasClause = asum [+ do+ string' "as"+ asum [+ do+ space+ inParens $ do+ endHead+ AsFuncAliasClause <$> tableFuncElementList+ ,+ do+ space1+ a <- colId+ asum [+ do+ space+ inParens $ do+ endHead+ asum [+ AsColIdFuncAliasClause a <$> wrapToHead tableFuncElementList,+ AliasFuncAliasClause <$> AliasClause True a <$> Just <$> nameList+ ]+ ,+ pure (AliasFuncAliasClause (AliasClause True a Nothing))+ ]+ ]+ ,+ do+ a <- colId+ asum [+ do+ space+ inParens $ do+ endHead+ asum [+ ColIdFuncAliasClause a <$> wrapToHead tableFuncElementList,+ AliasFuncAliasClause <$> AliasClause False a <$> Just <$> nameList+ ]+ ,+ pure (AliasFuncAliasClause (AliasClause False a Nothing))+ ]+ ]++joinedTable =+ asum [+ do+ _tr1 <- wrapToHead nonTrailingTableRef+ space1+ trailingJoinedTable _tr1+ ,+ inParensJoinedTable+ ]++{-+ | '(' joined_table ')'+-}+inParensJoinedTable = InParensJoinedTable <$> inParens joinedTable++{-+ | table_ref CROSS JOIN table_ref+ | table_ref join_type JOIN table_ref join_qual+ | table_ref JOIN table_ref join_qual+ | table_ref NATURAL join_type JOIN table_ref+ | table_ref NATURAL JOIN table_ref+-}+trailingJoinedTable _tr1 = asum [+ do+ keyphrase "cross join"+ endHead+ space1+ _tr2 <- tableRef+ return (MethJoinedTable CrossJoinMeth _tr1 _tr2)+ ,+ do+ _jt <- joinTypedJoin+ endHead+ space1+ _tr2 <- tableRef+ space1+ _jq <- joinQual+ return (MethJoinedTable (QualJoinMeth _jt _jq) _tr1 _tr2)+ ,+ do+ string' "natural"+ endHead+ space1+ _jt <- joinTypedJoin+ space1+ _tr2 <- tableRef+ return (MethJoinedTable (NaturalJoinMeth _jt) _tr1 _tr2)+ ]+ where+ joinTypedJoin =+ Just <$> (joinType <* endHead <* space1 <* string' "join") <|>+ Nothing <$ string' "join"++joinType = asum [+ do+ string' "full"+ endHead+ _outer <- outerAfterSpace+ return (FullJoinType _outer)+ ,+ do+ string' "left"+ endHead+ _outer <- outerAfterSpace+ return (LeftJoinType _outer)+ ,+ do+ string' "right"+ endHead+ _outer <- outerAfterSpace+ return (RightJoinType _outer)+ ,+ string' "inner" $> InnerJoinType+ ]+ where+ outerAfterSpace = (space1 *> string' "outer") $> True <|> pure False++joinQual = asum [+ string' "using" *> space1 *> inParens (sep1 commaSeparator colId) <&> UsingJoinQual+ ,+ string' "on" *> space1 *> aExpr <&> OnJoinQual+ ]++aliasClause = do+ (_as, _alias) <- (True,) <$> (string' "as" *> space1 *> endHead *> colId) <|> (False,) <$> colId+ _columnAliases <- optional (space1 *> inParens (sep1 commaSeparator colId))+ return (AliasClause _as _alias _columnAliases)+++-- * Where+-------------------------++whereClause = string' "where" *> space1 *> endHead *> aExpr++whereOrCurrentClause = do+ string' "where"+ space1+ endHead+ asum [+ do+ string' "current"+ space1+ string' "of"+ space1+ endHead+ a <- cursorName+ return (CursorWhereOrCurrentClause a)+ ,+ ExprWhereOrCurrentClause <$> aExpr+ ]+++-- * Sorting+-------------------------++sortClause = do+ keyphrase "order by"+ endHead+ space1+ a <- sep1 commaSeparator sortBy+ return a++sortBy = do+ a <- filteredAExpr ["using", "asc", "desc", "nulls"]+ asum [+ do+ space1+ string' "using"+ space1+ endHead+ b <- qualAllOp+ c <- optional (space1 *> nullsOrder)+ return (UsingSortBy a b c)+ ,+ do+ b <- optional (space1 *> ascDesc)+ c <- optional (space1 *> nullsOrder)+ return (AscDescSortBy a b c)+ ]+++-- * Expressions+-------------------------++exprList = sep1 commaSeparator aExpr++exprListInParens = inParens exprList++{-|+Notice that the tree constructed by this parser does not reflect+the precedence order of Postgres.+For the purposes of this library it simply doesn't matter,+so we're not bothering with that.++Composite on the right:+>>> testParser aExpr "a = b :: int4"+SymbolicBinOpAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") Nothing))) (MathSymbolicExprBinOp EqualsMathOp) (TypecastAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "b") Nothing))) (TypecastTypename (UnquotedIdent "int4") False 0 False))++Composite on the left:+>>> testParser aExpr "a = b :: int4 and c"+SymbolicBinOpAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") Nothing))) (MathSymbolicExprBinOp EqualsMathOp) (AndAExpr (TypecastAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "b") Nothing))) (TypecastTypename (UnquotedIdent "int4") False 0 False)) (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "c") Nothing))))+-}+aExpr = customizedAExpr cExpr++filteredAExpr = customizedAExpr . customizedCExpr . filteredColumnref++customizedAExpr cExpr = suffixRec base suffix where+ aExpr = customizedAExpr cExpr+ base = asum [+ DefaultAExpr <$ string' "default",+ UniqueAExpr <$> (string' "unique" *> space1 *> selectWithParens),+ OverlapsAExpr <$> wrapToHead row <*> (space1 *> string' "overlaps" *> space1 *> endHead *> row),+ qualOpExpr aExpr PrefixQualOpAExpr,+ PlusAExpr <$> plusedExpr aExpr,+ MinusAExpr <$> minusedExpr aExpr,+ NotAExpr <$> (string' "not" *> space1 *> aExpr),+ CExprAExpr <$> cExpr+ ]+ suffix a = asum [+ do+ space1+ b <- wrapToHead subqueryOp+ space1+ c <- wrapToHead subType+ space+ d <- Left <$> wrapToHead selectWithParens <|> Right <$> inParens aExpr+ return (SubqueryAExpr a b c d)+ ,+ typecastExpr a TypecastAExpr+ ,+ CollateAExpr a <$> (space1 *> string' "collate" *> space1 *> endHead *> anyName)+ ,+ AtTimeZoneAExpr a <$> (space1 *> keyphrase "at time zone" *> space1 *> endHead *> aExpr)+ ,+ symbolicBinOpExpr a aExpr SymbolicBinOpAExpr+ ,+ SuffixQualOpAExpr a <$> (space *> qualOp)+ ,+ AndAExpr a <$> (space1 *> string' "and" *> space1 *> endHead *> aExpr)+ ,+ OrAExpr a <$> (space1 *> string' "or" *> space1 *> endHead *> aExpr)+ ,+ do+ space1+ b <- trueIfPresent (string' "not" *> space1)+ c <- asum [+ LikeVerbalExprBinOp <$ string' "like",+ IlikeVerbalExprBinOp <$ string' "ilike",+ SimilarToVerbalExprBinOp <$ keyphrase "similar to"+ ]+ space1+ endHead+ d <- aExpr+ e <- optional (space1 *> string' "escape" *> space1 *> endHead *> aExpr)+ return (VerbalExprBinOpAExpr a b c d e)+ ,+ do+ space1+ string' "is"+ space1+ endHead+ b <- trueIfPresent (string' "not" *> space1)+ c <- asum [+ NullAExprReversableOp <$ string' "null",+ TrueAExprReversableOp <$ string' "true",+ FalseAExprReversableOp <$ string' "false",+ UnknownAExprReversableOp <$ string' "unknown",+ DistinctFromAExprReversableOp <$> (string' "distinct" *> space1 *> string' "from" *> space1 *> endHead *> aExpr),+ OfAExprReversableOp <$> (string' "of" *> space1 *> endHead *> inParens typeList),+ DocumentAExprReversableOp <$ string' "document"+ ]+ return (ReversableOpAExpr a b c)+ ,+ do+ space1+ b <- trueIfPresent (string' "not" *> space1)+ string' "between"+ space1+ endHead+ c <- asum [+ BetweenSymmetricAExprReversableOp <$ (string' "symmetric" *> space1),+ BetweenAExprReversableOp True <$ (string' "asymmetric" *> space1),+ pure (BetweenAExprReversableOp False)+ ]+ d <- bExpr+ space1+ string' "and"+ space1+ e <- aExpr+ return (ReversableOpAExpr a b (c d e))+ ,+ do+ space1+ b <- trueIfPresent (string' "not" *> space1)+ string' "in"+ space+ c <- InAExprReversableOp <$> inExpr+ return (ReversableOpAExpr a b c)+ ,+ IsnullAExpr a <$ (space1 *> string' "isnull")+ ,+ NotnullAExpr a <$ (space1 *> string' "notnull")+ ]++bExpr = customizedBExpr cExpr++customizedBExpr cExpr = suffixRec base suffix where+ aExpr = customizedAExpr cExpr+ bExpr = customizedBExpr cExpr+ base = asum [+ qualOpExpr bExpr QualOpBExpr,+ PlusBExpr <$> plusedExpr bExpr,+ MinusBExpr <$> minusedExpr bExpr,+ CExprBExpr <$> cExpr+ ]+ suffix a = asum [+ typecastExpr a TypecastBExpr,+ symbolicBinOpExpr a bExpr SymbolicBinOpBExpr,+ do+ space1+ string' "is"+ space1+ endHead+ b <- trueIfPresent (string' "not" *> space1)+ c <- asum [+ DistinctFromBExprIsOp <$> (keyphrase "distinct from" *> space1 *> endHead *> bExpr),+ OfBExprIsOp <$> (string' "of" *> space1 *> endHead *> inParens typeList),+ DocumentBExprIsOp <$ string' "document"+ ]+ return (IsOpBExpr a b c)+ ]++cExpr = customizedCExpr columnref++customizedCExpr columnref = asum [+ ParamCExpr <$> (char '$' *> decimal <* endHead) <*> optional (space *> indirection)+ ,+ CaseCExpr <$> caseExpr+ ,+ ImplicitRowCExpr <$> implicitRow+ ,+ ExplicitRowCExpr <$> explicitRow+ ,+ inParensWithClause (string' "grouping") (GroupingCExpr <$> sep1 commaSeparator aExpr)+ ,+ string' "exists" *> space *> (ExistsCExpr <$> selectWithParens)+ ,+ do+ string' "array"+ space+ join $ asum [+ fmap (fmap (ArrayCExpr . Right)) arrayExprCont,+ fmap (fmap (ArrayCExpr . Left) . pure) selectWithParens+ ]+ ,+ do+ a <- wrapToHead selectWithParens+ endHead+ b <- optional (space *> indirection)+ return (SelectWithParensCExpr a b)+ ,+ InParensCExpr <$> (inParens aExpr <* endHead) <*> optional (space *> indirection)+ ,+ AexprConstCExpr <$> wrapToHead aexprConst+ ,+ FuncCExpr <$> funcExpr+ ,+ ColumnrefCExpr <$> columnref+ ]+++-- *+-------------------------++subqueryOp = asum [+ AnySubqueryOp <$> (string' "operator" *> space *> endHead *> inParens anyOperator)+ ,+ do+ a <- trueIfPresent (string' "not" *> space1)+ LikeSubqueryOp a <$ string' "like" <|> IlikeSubqueryOp a <$ string' "ilike"+ ,+ AllSubqueryOp <$> allOp+ ]++subType = asum [+ AnySubType <$ string' "any",+ SomeSubType <$ string' "some",+ AllSubType <$ string' "all"+ ]++inExpr = SelectInExpr <$> wrapToHead selectWithParens <|> ExprListInExpr <$> inParens exprList++symbolicBinOpExpr _a _bParser _constr = do+ _binOp <- label "binary operator" (space *> wrapToHead symbolicExprBinOp <* space)+ _b <- _bParser+ return (_constr _a _binOp _b)++typecastExpr _prefix _constr = do+ space+ string "::"+ endHead+ space+ _type <- typecastTypename+ return (_constr _prefix _type)++plusedExpr expr = char '+' *> space *> expr++minusedExpr expr = char '-' *> space *> expr++qualOpExpr expr constr = constr <$> wrapToHead qualOp <*> (space *> expr)++row = ExplicitRowRow <$> explicitRow <|> ImplicitRowRow <$> implicitRow++explicitRow = string' "row" *> space *> inParens (optional exprList)++implicitRow = inParens $ do+ a <- wrapToHead aExpr+ commaSeparator+ b <- exprList+ return $ case NonEmpty.consAndUnsnoc a b of+ (c, d) -> ImplicitRow c d++arrayExprCont = inBracketsCont $ asum [+ ArrayExprListArrayExpr <$> sep1 commaSeparator (join arrayExprCont),+ ExprListArrayExpr <$> exprList,+ pure EmptyArrayExpr+ ]++caseExpr = label "case expression" $ do+ string' "case"+ space1+ endHead+ _arg <- optional (aExpr <* space1)+ _whenClauses <- sep1 space1 whenClause+ space1+ _default <- optional elseClause+ string' "end"+ pure $ CaseExpr _arg _whenClauses _default++whenClause = do+ string' "when"+ space1+ endHead+ _a <- aExpr+ space1+ string' "then"+ space1+ _b <- aExpr+ return (WhenClause _a _b)++elseClause = do+ string' "else"+ space1+ endHead+ a <- aExpr+ space1+ return a++funcExpr = asum [+ SubexprFuncExpr <$> funcExprCommonSubexpr,+ do+ a <- funcApplication+ endHead+ b <- optional (space1 *> withinGroupClause)+ c <- optional (space1 *> filterClause)+ d <- optional (space1 *> overClause)+ return (ApplicationFuncExpr a b c d)+ ]++funcExprWindowless = asum [+ CommonSubexprFuncExprWindowless <$> funcExprCommonSubexpr,+ ApplicationFuncExprWindowless <$> funcApplication+ ]++withinGroupClause = do+ keyphrase "within group"+ endHead+ space+ inParens sortClause++filterClause = do+ string' "filter"+ endHead+ space+ inParens (string' "where" *> space1 *> aExpr)++overClause = do+ string' "over"+ space1+ endHead+ asum [+ WindowOverClause <$> windowSpecification,+ ColIdOverClause <$> colId+ ]++funcExprCommonSubexpr = asum [+ CollationForFuncExprCommonSubexpr <$> (inParensWithClause (keyphrase "collation for") aExpr)+ ,+ CurrentDateFuncExprCommonSubexpr <$ string' "current_date"+ ,+ CurrentTimestampFuncExprCommonSubexpr <$> labeledIconst "current_timestamp"+ ,+ CurrentTimeFuncExprCommonSubexpr <$> labeledIconst "current_time"+ ,+ LocalTimestampFuncExprCommonSubexpr <$> labeledIconst "localtimestamp"+ ,+ LocalTimeFuncExprCommonSubexpr <$> labeledIconst "localtime"+ ,+ CurrentRoleFuncExprCommonSubexpr <$ string' "current_role"+ ,+ CurrentUserFuncExprCommonSubexpr <$ string' "current_user"+ ,+ SessionUserFuncExprCommonSubexpr <$ string' "session_user"+ ,+ UserFuncExprCommonSubexpr <$ string' "user"+ ,+ CurrentCatalogFuncExprCommonSubexpr <$ string' "current_catalog"+ ,+ CurrentSchemaFuncExprCommonSubexpr <$ string' "current_schema"+ ,+ inParensWithClause (string' "cast") (CastFuncExprCommonSubexpr <$> aExpr <*> (space1 *> string' "as" *> space1 *> typename))+ ,+ inParensWithClause (string' "extract") (ExtractFuncExprCommonSubexpr <$> optional extractList)+ ,+ inParensWithClause (string' "overlay") (OverlayFuncExprCommonSubexpr <$> overlayList)+ ,+ inParensWithClause (string' "position") (PositionFuncExprCommonSubexpr <$> optional positionList)+ ,+ inParensWithClause (string' "substring") (SubstringFuncExprCommonSubexpr <$> optional substrList)+ ,+ inParensWithClause (string' "treat") (TreatFuncExprCommonSubexpr <$> aExpr <*> (space1 *> string' "as" *> space1 *> typename))+ ,+ inParensWithClause (string' "trim") (TrimFuncExprCommonSubexpr <$> optional (trimModifier <* space1) <*> trimList)+ ,+ inParensWithClause (string' "nullif") (NullIfFuncExprCommonSubexpr <$> aExpr <*> (commaSeparator *> aExpr))+ ,+ inParensWithClause (string' "coalesce") (CoalesceFuncExprCommonSubexpr <$> exprList)+ ,+ inParensWithClause (string' "greatest") (GreatestFuncExprCommonSubexpr <$> exprList)+ ,+ inParensWithClause (string' "least") (LeastFuncExprCommonSubexpr <$> exprList)+ ]+ where+ labeledIconst _label = string' _label *> endHead *> optional (space *> inParens iconst)++extractList = ExtractList <$> extractArg <*> (space1 *> string' "FROM" *> space1 *> aExpr)++extractArg = asum [+ YearExtractArg <$ string' "year",+ MonthExtractArg <$ string' "month",+ DayExtractArg <$ string' "day",+ HourExtractArg <$ string' "hour",+ MinuteExtractArg <$ string' "minute",+ SecondExtractArg <$ string' "second",+ SconstExtractArg <$> sconst,+ IdentExtractArg <$> ident+ ]++overlayList = do+ a <- aExpr+ space1+ b <- overlayPlacing+ space1+ c <- substrFrom+ d <- optional (space1 *> substrFor)+ return (OverlayList a b c d)++overlayPlacing = string' "placing" *> space1 *> endHead *> aExpr++positionList = PositionList <$> bExpr <*> (space1 *> string' "IN" *> space1 *> bExpr)++substrList = asum [+ ExprSubstrList <$> wrapToHead aExpr <*> (space1 *> substrListFromFor),+ ExprListSubstrList <$> exprList+ ]++substrListFromFor = asum [+ do+ a <- substrFrom+ asum [+ do+ b <- space1 *> substrFor+ return (FromForSubstrListFromFor a b)+ ,+ return (FromSubstrListFromFor a)+ ]+ ,+ do+ a <- substrFor+ asum [+ do+ b <- space1 *> substrFrom+ return (ForFromSubstrListFromFor a b)+ ,+ return (ForSubstrListFromFor a)+ ]+ ]++substrFrom = string' "from" *> space1 *> endHead *> aExpr++substrFor = string' "for" *> space1 *> endHead *> aExpr++trimModifier =+ BothTrimModifier <$ string' "both" <|>+ LeadingTrimModifier <$ string' "leading" <|>+ TrailingTrimModifier <$ string' "trailing"++trimList = asum [+ ExprFromExprListTrimList <$> wrapToHead aExpr <*> (space1 *> string' "from" *> space1 *> endHead *> exprList)+ ,+ FromExprListTrimList <$> (string' "from" *> space1 *> endHead *> exprList)+ ,+ ExprListTrimList <$> exprList+ ]++funcApplication = inParensWithLabel FuncApplication funcName (optional funcApplicationParams)++funcApplicationParams =+ asum+ [+ starFuncApplicationParams,+ listVariadicFuncApplicationParams,+ singleVariadicFuncApplicationParams,+ normalFuncApplicationParams+ ]++normalFuncApplicationParams = do+ _optAllOrDistinct <- optional (allOrDistinct <* space1)+ _argList <- sep1 commaSeparator funcArgExpr+ endHead+ _optSortClause <- optional (space1 *> sortClause)+ return (NormalFuncApplicationParams _optAllOrDistinct _argList _optSortClause)++singleVariadicFuncApplicationParams = do+ string' "variadic"+ space1+ endHead+ _arg <- funcArgExpr+ _optSortClause <- optional (space1 *> sortClause)+ return (VariadicFuncApplicationParams Nothing _arg _optSortClause)++listVariadicFuncApplicationParams = do+ (_argList, _) <- wrapToHead $ sepEnd1 commaSeparator (string' "variadic" <* space1) funcArgExpr+ endHead+ _arg <- funcArgExpr+ _optSortClause <- optional (space1 *> sortClause)+ return (VariadicFuncApplicationParams (Just _argList) _arg _optSortClause)++starFuncApplicationParams = space *> char '*' *> endHead *> space $> StarFuncApplicationParams++{-+func_arg_expr:+ | a_expr+ | param_name COLON_EQUALS a_expr+ | param_name EQUALS_GREATER a_expr+param_name:+ | type_function_name+-}+funcArgExpr = asum [+ do+ a <- wrapToHead typeFunctionName+ space+ asum [+ do+ string ":="+ endHead+ b <- space *> aExpr+ return (ColonEqualsFuncArgExpr a b)+ ,+ do+ string "=>"+ endHead+ b <- space *> aExpr+ return (EqualsGreaterFuncArgExpr a b)+ ]+ ,+ ExprFuncArgExpr <$> aExpr+ ]+++-- * Ops+-------------------------++symbolicExprBinOp =+ QualSymbolicExprBinOp <$> qualOp <|>+ MathSymbolicExprBinOp <$> mathOp++lexicalExprBinOp = asum $ fmap keyphrase $ ["and", "or", "is distinct from", "is not distinct from"]++qualOp = asum [+ OpQualOp <$> op,+ OperatorQualOp <$> inParensWithClause (string' "operator") anyOperator+ ]++qualAllOp = asum [+ AnyQualAllOp <$> (string' "operator" *> space *> inParens (endHead *> anyOperator)),+ AllQualAllOp <$> allOp+ ]++op = do+ a <- takeWhile1P Nothing Predicate.opChar+ case Validator.op a of+ Nothing -> return a+ Just err -> fail (Text.unpack err)++anyOperator = asum [+ AllOpAnyOperator <$> allOp,+ QualifiedAnyOperator <$> colId <*> (space *> char '.' *> space *> anyOperator)+ ]++allOp = asum [+ OpAllOp <$> op,+ MathAllOp <$> mathOp+ ]++mathOp = asum [+ ArrowLeftArrowRightMathOp <$ string' "<>",+ GreaterEqualsMathOp <$ string' ">=",+ ExclamationEqualsMathOp <$ string' "!=",+ LessEqualsMathOp <$ string' "<=",+ PlusMathOp <$ char '+',+ MinusMathOp <$ char '-',+ AsteriskMathOp <$ char '*',+ SlashMathOp <$ char '/',+ PercentMathOp <$ char '%',+ ArrowUpMathOp <$ char '^',+ ArrowLeftMathOp <$ char '<',+ ArrowRightMathOp <$ char '>',+ EqualsMathOp <$ char '='+ ]+++-- * Constants+-------------------------++{-|+>>> testParser aexprConst "32948023849023"+IAexprConst 32948023849023++>>> testParser aexprConst "'abc''de'"+SAexprConst "abc'de"++>>> testParser aexprConst "23.43234"+FAexprConst 23.43234++>>> testParser aexprConst "32423423.324324872"+FAexprConst 3.2423423324324872e7++>>> testParser aexprConst "NULL"+NullAexprConst+-}+{-+AexprConst: Iconst+ | FCONST+ | Sconst+ | BCONST+ | XCONST+ | func_name Sconst+ | func_name '(' func_arg_list opt_sort_clause ')' Sconst+ | ConstTypename Sconst+ | ConstInterval Sconst opt_interval+ | ConstInterval '(' Iconst ')' Sconst+ | TRUE_P+ | FALSE_P+ | NULL_P+-}+aexprConst = asum [+ do+ string' "interval"+ space1+ endHead+ a <- asum [+ do+ a <- sconst+ endHead+ b <- optional (space1 *> interval)+ return (StringIntervalAexprConst a b)+ ,+ do+ a <- inParens iconst+ space1+ endHead+ b <- sconst+ return (IntIntervalAexprConst a b)+ ]+ return a+ ,+ do+ a <- constTypename+ space1+ endHead+ b <- sconst+ return (ConstTypenameAexprConst a b)+ ,+ BoolAexprConst True <$ string' "true"+ ,+ BoolAexprConst False <$ string' "false"+ ,+ NullAexprConst <$ string' "null" <* parse (Megaparsec.notFollowedBy MegaparsecChar.alphaNumChar)+ ,+ either IAexprConst FAexprConst <$> iconstOrFconst+ ,+ SAexprConst <$> sconst+ ,+ label "bit literal" $ do+ string' "b'"+ endHead+ a <- takeWhile1P (Just "0 or 1") (\ b -> b == '0' || b == '1')+ char '\''+ return (BAexprConst a)+ ,+ label "hex literal" $ do+ string' "x'"+ endHead+ a <- takeWhile1P (Just "Hex digit") (Predicate.inSet HashSet.hexDigitChars)+ char '\''+ return (XAexprConst a)+ ,+ wrapToHead $ do+ a <- funcName+ space+ char '('+ space+ b <- sep1 commaSeparator funcArgExpr+ c <- optional (space1 *> sortClause)+ space+ char ')'+ space1+ d <- sconst+ return (FuncAexprConst a (Just (FuncConstArgs b c)) d)+ ,+ FuncAexprConst <$> (wrapToHead funcName <* space1) <*> pure Nothing <*> sconst+ ]++iconstOrFconst = Right <$> fconst <|> Left <$> iconst++iconst = decimal++fconst = float++sconst = quotedString '\''++constTypename = asum [+ NumericConstTypename <$> numeric,+ ConstBitConstTypename <$> constBit,+ ConstCharacterConstTypename <$> constCharacter,+ ConstDatetimeConstTypename <$> constDatetime+ ]++numeric = asum [+ IntegerNumeric <$ string' "integer",+ IntNumeric <$ string' "int",+ SmallintNumeric <$ string' "smallint",+ BigintNumeric <$ string' "bigint",+ RealNumeric <$ string' "real",+ FloatNumeric <$> (string' "float" *> endHead *> optional (space *> inParens iconst)),+ DoublePrecisionNumeric <$ keyphrase "double precision",+ DecimalNumeric <$> (string' "decimal" *> endHead *> optional (space *> exprListInParens)),+ DecNumeric <$> (string' "dec" *> endHead *> optional (space *> exprListInParens)),+ NumericNumeric <$> (string' "numeric" *> endHead *> optional (space *> exprListInParens)),+ BooleanNumeric <$ string' "boolean"+ ]++bit = do+ string' "bit"+ a <- option False (True <$ space1 <* string' "varying")+ b <- optional (space1 *> exprListInParens)+ return (Bit a b)++constBit = bit++constCharacter = ConstCharacter <$> (character <* endHead) <*> optional (space *> inParens iconst)++character = asum [+ CharacterCharacter <$> (string' "character" *> optVaryingAfterSpace),+ CharCharacter <$> (string' "char" *> optVaryingAfterSpace),+ VarcharCharacter <$ string' "varchar",+ NationalCharacterCharacter <$> (keyphrase "national character" *> optVaryingAfterSpace),+ NationalCharCharacter <$> (keyphrase "national char" *> optVaryingAfterSpace),+ NcharCharacter <$> (string' "nchar" *> optVaryingAfterSpace)+ ]+ where+ optVaryingAfterSpace = True <$ space1 <* string' "varying" <|> pure False++{-+ConstDatetime:+ | TIMESTAMP '(' Iconst ')' opt_timezone+ | TIMESTAMP opt_timezone+ | TIME '(' Iconst ')' opt_timezone+ | TIME opt_timezone+-}+constDatetime = asum [+ do+ string' "timestamp"+ a <- optional (space1 *> inParens iconst)+ b <- optional (space1 *> timezone)+ return (TimestampConstDatetime a b)+ ,+ do+ string' "time"+ a <- optional (space1 *> inParens iconst)+ b <- optional (space1 *> timezone)+ return (TimeConstDatetime a b)+ ]++timezone = asum [+ False <$ keyphrase "with time zone",+ True <$ keyphrase "without time zone"+ ]++interval = asum [+ YearToMonthInterval <$ keyphrase "year to month",+ DayToHourInterval <$ keyphrase "day to hour",+ DayToMinuteInterval <$ keyphrase "day to minute",+ DayToSecondInterval <$> (keyphrase "day to" *> space1 *> endHead *> intervalSecond),+ HourToMinuteInterval <$ keyphrase "hour to minute",+ HourToSecondInterval <$> (keyphrase "hour to" *> space1 *> endHead *> intervalSecond),+ MinuteToSecondInterval <$> (keyphrase "minute to" *> space1 *> endHead *> intervalSecond),+ YearInterval <$ string' "year",+ MonthInterval <$ string' "month",+ DayInterval <$ string' "day",+ HourInterval <$ string' "hour",+ MinuteInterval <$ string' "minute",+ SecondInterval <$> intervalSecond+ ]++intervalSecond = do+ string' "second"+ a <- optional (space *> inParens iconst)+ return a+++-- * Types+-------------------------++{-|+>>> testParser typecastTypename "int4"+TypecastTypename (UnquotedIdent "int4") False 0 False++>>> testParser typecastTypename "int4?"+TypecastTypename (UnquotedIdent "int4") True 0 False++>>> testParser typecastTypename "int4[]"+TypecastTypename (UnquotedIdent "int4") False 1 False++>>> testParser typecastTypename "int4[ ] []"+TypecastTypename (UnquotedIdent "int4") False 2 False++>>> testParser typecastTypename "int4[][]?"+TypecastTypename (UnquotedIdent "int4") False 2 True++>>> testParser typecastTypename "int4?[][]"+TypecastTypename (UnquotedIdent "int4") True 2 False+-}+typecastTypename = label "type" $ do+ _baseName <- typeFunctionName+ endHead+ _baseNullable <- option False (True <$ space <* char '?')+ _arrayLevels <- fmap length $ many $ space *> char '[' *> endHead *> space *> char ']'+ _arrayNullable <- option False (True <$ space <* char '?')+ return (TypecastTypename _baseName _baseNullable _arrayLevels _arrayNullable)+++-- * Clauses+-------------------------++{-+select_limit:+ | limit_clause offset_clause+ | offset_clause limit_clause+ | limit_clause+ | offset_clause+-}+selectLimit =+ asum+ [+ do+ _a <- limitClause+ LimitOffsetSelectLimit _a <$> (space1 *> offsetClause) <|> pure (LimitSelectLimit _a)+ ,+ do+ _a <- offsetClause+ OffsetLimitSelectLimit _a <$> (space1 *> limitClause) <|> pure (OffsetSelectLimit _a)+ ]++{-+limit_clause:+ | LIMIT select_limit_value+ | LIMIT select_limit_value ',' select_offset_value+ | FETCH first_or_next select_fetch_first_value row_or_rows ONLY+ | FETCH first_or_next row_or_rows ONLY+-}+limitClause =+ (do+ string' "limit"+ endHead+ space1+ _a <- selectLimitValue+ _b <- optional $ do+ commaSeparator+ aExpr+ return (LimitLimitClause _a _b)+ ) <|>+ (do+ string' "fetch"+ endHead+ space1+ _a <- firstOrNext+ space1+ asum [+ do+ _b <- rowOrRows+ space1+ string' "only"+ return (FetchOnlyLimitClause _a Nothing _b)+ ,+ do+ _b <- selectFetchFirstValue+ space1+ _c <- rowOrRows+ space1+ string' "only"+ return (FetchOnlyLimitClause _a (Just _b) _c)+ ]+ )++offsetClause = do+ string' "offset"+ endHead+ space1+ offsetClauseParams++offsetClauseParams =+ FetchFirstOffsetClause <$> wrapToHead selectFetchFirstValue <*> (space1 *> rowOrRows) <|>+ ExprOffsetClause <$> aExpr++{-+select_limit_value:+ | a_expr+ | ALL+-}+selectLimitValue =+ AllSelectLimitValue <$ string' "all" <|>+ ExprSelectLimitValue <$> aExpr++rowOrRows =+ True <$ string' "rows" <|>+ False <$ string' "row"++firstOrNext =+ False <$ string' "first" <|>+ True <$ string' "next"++selectFetchFirstValue =+ ExprSelectFetchFirstValue <$> cExpr <|>+ NumSelectFetchFirstValue <$> (plusOrMinus <* endHead <* space) <*> iconstOrFconst++plusOrMinus = False <$ char '+' <|> True <$ char '-'+++-- * For Locking+-------------------------++{-+for_locking_clause:+ | for_locking_items+ | FOR READ ONLY+for_locking_items:+ | for_locking_item+ | for_locking_items for_locking_item+-}+forLockingClause = readOnly <|> items where+ readOnly = ReadOnlyForLockingClause <$ keyphrase "for read only"+ items = ItemsForLockingClause <$> sep1 space1 forLockingItem++{-+for_locking_item:+ | for_locking_strength locked_rels_list opt_nowait_or_skip+locked_rels_list:+ | OF qualified_name_list+ | EMPTY+opt_nowait_or_skip:+ | NOWAIT+ | SKIP LOCKED+ | EMPTY+-}+forLockingItem = do+ _strength <- forLockingStrength+ _rels <- optional $ space1 *> string' "of" *> space1 *> endHead *> sep1 commaSeparator qualifiedName+ _nowaitOrSkip <- optional (space1 *> nowaitOrSkip)+ return (ForLockingItem _strength _rels _nowaitOrSkip)++{-+for_locking_strength:+ | FOR UPDATE+ | FOR NO KEY UPDATE+ | FOR SHARE+ | FOR KEY SHARE+-}+forLockingStrength =+ UpdateForLockingStrength <$ keyphrase "for update" <|>+ NoKeyUpdateForLockingStrength <$ keyphrase "for no key update" <|>+ ShareForLockingStrength <$ keyphrase "for share" <|>+ KeyForLockingStrength <$ keyphrase "for key share"++nowaitOrSkip = False <$ string' "nowait" <|> True <$ keyphrase "skip locked"+++-- * References & Names+-------------------------++quotedName = filter (const "Empty name") (not . Text.null) (quotedString '"') & fmap QuotedIdent++{-+ident_start [A-Za-z\200-\377_]+ident_cont [A-Za-z\200-\377_0-9\$]+identifier {ident_start}{ident_cont}*+-}+ident = quotedName <|> keywordNameByPredicate (not . Predicate.keyword)++{-+ColId:+ | IDENT+ | unreserved_keyword+ | col_name_keyword+-}+{-# NOINLINE colId #-}+colId = label "identifier" $+ ident <|> keywordNameFromSet (HashSet.unreservedKeyword <> HashSet.colNameKeyword)++{-# NOINLINE filteredColId #-}+filteredColId = let+ _originalSet = HashSet.unreservedKeyword <> HashSet.colNameKeyword+ _filteredSet = foldr HashSet.delete _originalSet+ in \ _reservedKeywords -> label "identifier" $ ident <|> keywordNameFromSet (_filteredSet _reservedKeywords)++{-+ColLabel:+ | IDENT+ | unreserved_keyword+ | col_name_keyword+ | type_func_name_keyword+ | reserved_keyword+-}+colLabel = label "column label" $+ ident <|> keywordNameFromSet HashSet.keyword++{-|+>>> testParser qualifiedName "a.b"+IndirectedQualifiedName (UnquotedIdent "a") (AttrNameIndirectionEl (UnquotedIdent "b") :| [])++>>> testParser qualifiedName "a.-"+...+expecting '*', column label, or white space+-}+{-+qualified_name:+ | ColId+ | ColId indirection+-}+qualifiedName =+ IndirectedQualifiedName <$> wrapToHead colId <*> (space *> indirection) <|>+ SimpleQualifiedName <$> colId++columnref = customizedColumnref colId++filteredColumnref _keywords = customizedColumnref (filteredColId _keywords)++customizedColumnref colId = do+ a <- wrapToHead colId+ endHead+ b <- optional (space *> indirection)+ return (Columnref a b)++anyName = customizedAnyName colId++filteredAnyName _keywords = customizedAnyName (filteredColId _keywords)++customizedAnyName colId = do+ a <- wrapToHead colId+ endHead+ b <- optional (space *> attrs)+ return (AnyName a b)++name = colId++nameList = sep1 commaSeparator name++cursorName = name++{-+func_name:+ | type_function_name+ | ColId indirection+-}+funcName =+ IndirectedFuncName <$> wrapToHead colId <*> (space *> indirection) <|>+ TypeFuncName <$> typeFunctionName++{-+type_function_name:+ | IDENT+ | unreserved_keyword+ | type_func_name_keyword+-}+typeFunctionName =+ ident <|>+ keywordNameFromSet (HashSet.unreservedKeyword <> HashSet.typeFuncNameKeyword)++{-+indirection:+ | indirection_el+ | indirection indirection_el+-}+indirection = some indirectionEl++{-+indirection_el:+ | '.' attr_name+ | '.' '*'+ | '[' a_expr ']'+ | '[' opt_slice_bound ':' opt_slice_bound ']'+opt_slice_bound:+ | a_expr+ | EMPTY+-}+indirectionEl =+ asum+ [+ do+ char '.'+ endHead+ space+ AllIndirectionEl <$ char '*' <|> AttrNameIndirectionEl <$> attrName+ ,+ do+ char '['+ endHead+ space+ _a <- asum [+ do+ char ':'+ endHead+ space+ _b <- optional aExpr+ return (SliceIndirectionEl Nothing _b)+ ,+ do+ _a <- aExpr+ asum [+ do+ space+ char ':'+ space+ _b <- optional aExpr+ return (SliceIndirectionEl (Just _a) _b)+ ,+ return (ExprIndirectionEl _a)+ ]+ ]+ space+ char ']'+ return _a+ ]++{-+attr_name:+ | ColLabel+-}+attrName = colLabel++keywordNameFromSet _set = keywordNameByPredicate (Predicate.inSet _set)++keywordNameByPredicate _predicate =+ fmap UnquotedIdent $+ filter+ (\ a -> "Reserved keyword " <> show a <> " used as an identifier. If that's what you intend, you have to wrap it in double quotes.")+ _predicate+ keyword++keyword = parse $ Megaparsec.label "keyword" $ do+ _firstChar <- Megaparsec.satisfy Predicate.firstIdentifierChar+ _remainder <- Megaparsec.takeWhileP Nothing Predicate.notFirstIdentifierChar+ return (Text.toLower (Text.cons _firstChar _remainder))++{-|+Consume a keyphrase, ignoring case and types of spaces between words.+-}+keyphrase a = Text.words a & fmap (void . MegaparsecChar.string') & intersperse MegaparsecChar.space1 & sequence_ & fmap (const (Text.toUpper a)) & Megaparsec.label (show a) & parse+++-- * Typename+-------------------------++typeList = sep1 commaSeparator typename++typename =+ do+ a <- option False (string' "SETOF" *> space1 $> True)+ b <- simpleTypename+ endHead+ asum [+ do+ space1+ string' "ARRAY"+ c <- optional (space *> inBrackets iconst)+ return (ArrayDimTypename a b c)+ ,+ do+ c <- optional (space1 *> arrayBounds)+ return (ArrayBoundsTypename a b c)+ ]++arrayBounds = sep1 space (inBrackets (optional iconst))++simpleTypename = asum [+ do+ string' "interval"+ endHead+ asum [+ ConstIntervalSimpleTypename <$> Right <$> (space *> inParens iconst),+ ConstIntervalSimpleTypename <$> Left <$> optional (space *> interval)+ ],+ NumericSimpleTypename <$> numeric,+ BitSimpleTypename <$> bit,+ CharacterSimpleTypename <$> character,+ ConstDatetimeSimpleTypename <$> constDatetime,+ GenericTypeSimpleTypename <$> genericType+ ]++genericType = do+ a <- typeFunctionName+ endHead+ b <- optional (space *> attrs)+ c <- optional (space1 *> typeModifiers)+ return (GenericType a b c)++attrs = some (char '.' *> endHead *> space *> attrName)++typeModifiers = inParens exprList+++-- * Indexes+-------------------------++indexParams = sep1 commaSeparator indexElem++indexElem = IndexElem <$>+ (indexElemDef <* endHead) <*>+ optional (space1 *> collate) <*>+ optional (space1 *> class_) <*>+ optional (space1 *> ascDesc) <*>+ optional (space1 *> nullsOrder)++indexElemDef =+ ExprIndexElemDef <$> inParens aExpr <|>+ FuncIndexElemDef <$> funcExprWindowless <|>+ IdIndexElemDef <$> colId ++collate = string' "collate" *> space1 *> endHead *> anyName++class_ = filteredAnyName ["asc", "desc", "nulls"]++ascDesc = string' "asc" $> AscAscDesc <|> string' "desc" $> DescAscDesc++nullsOrder = string' "nulls" *> space1 *> endHead *> (FirstNullsOrder <$ string' "first" <|> LastNullsOrder <$ string' "last")
+ library/Hasql/TH/Syntax/Predicate.hs view
@@ -0,0 +1,69 @@+module Hasql.TH.Syntax.Predicate where++import Hasql.TH.Prelude hiding (expression)+import qualified Data.HashSet as HashSet+import qualified Hasql.TH.Syntax.HashSet as HashSet+++-- * Generic+-------------------------++{-|+>>> test = oneOf [(==3), (==7), (==3), (==5)]+>>> test 1+False++>>> test 3+True++>>> test 5+True+-}+oneOf :: [a -> Bool] -> a -> Bool+oneOf = foldr (\ a b c -> a c || b c) (const False)++inSet :: (Eq a, Hashable a) => HashSet a -> a -> Bool+inSet = flip HashSet.member+++-- *+-------------------------++{-+ident_start [A-Za-z\200-\377_]+-}+firstIdentifierChar :: Char -> Bool+firstIdentifierChar x = isAlpha x || x == '_' || x >= '\200' && x <= '\377'++{-+ident_cont [A-Za-z\200-\377_0-9\$]+-}+notFirstIdentifierChar :: Char -> Bool+notFirstIdentifierChar x = isAlphaNum x || x == '_' || x == '$' || x >= '\200' && x <= '\377'++keyword :: Text -> Bool+keyword = inSet HashSet.keyword++unreservedKeyword :: Text -> Bool+unreservedKeyword = inSet HashSet.unreservedKeyword++colNameKeyword :: Text -> Bool+colNameKeyword = inSet HashSet.colNameKeyword++typeFuncNameKeyword :: Text -> Bool+typeFuncNameKeyword = inSet HashSet.typeFuncNameKeyword++reservedKeyword :: Text -> Bool+reservedKeyword = inSet HashSet.reservedKeyword++symbolicBinOpChar :: Char -> Bool+symbolicBinOpChar = inSet HashSet.symbolicBinOpChars++-- ** Op chars+-------------------------++opChar = inSet HashSet.opChars++prohibitedOpChar a = a == '+' || a == '-'++prohibitionLiftingOpChar = inSet HashSet.prohibitionLiftingOpChars
+ library/Hasql/TH/Syntax/Projections/ChildExprList.hs view
@@ -0,0 +1,638 @@+module Hasql.TH.Syntax.Projections.ChildExprList where++import Hasql.TH.Prelude hiding (sortBy, bit, fromList)+import Hasql.TH.Syntax.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 <> typecastTypename 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 <> typecastTypename 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+++-- * 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++typecastTypename _ = []++typename = \ case+ ArrayBoundsTypename _ a b -> simpleTypename a <> arrayBounds b+ ArrayDimTypename _ a _ -> simpleTypename a++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 []
+ library/Hasql/TH/Syntax/Projections/InputTypeList.hs view
@@ -0,0 +1,47 @@+{-|+AST traversal extracting input types.+-}+module Hasql.TH.Syntax.Projections.InputTypeList where++import Hasql.TH.Prelude+import Hasql.TH.Syntax.Ast+import qualified Hasql.TH.Syntax.Projections.PlaceholderTypeMap as PlaceholderTypeMap+import qualified Data.IntMap.Strict as IntMap++{-|+>>> import qualified Hasql.TH.Syntax.Parsing as P+>>> test = either fail (return . preparableStmt) . P.run P.preparableStmt++>>> test "select $1 :: INT4"+Right [TypecastTypename (UnquotedIdent "int4") False 0 False]++>>> test "select $1 :: int4, a + $2 :: text[]?"+Right [TypecastTypename (UnquotedIdent "int4") False 0 False,TypecastTypename (UnquotedIdent "text") False 1 True]++>>> test "select $1 :: int4, a + $2 :: text?[]?"+Right [TypecastTypename (UnquotedIdent "int4") False 0 False,TypecastTypename (UnquotedIdent "text") True 1 True]++>>> test "select $1"+Left "Placeholder $1 misses an explicit typecast"++>>> test "select $2 :: int4, $1 :: int4, $2 :: int4"+Right [TypecastTypename (UnquotedIdent "int4") False 0 False,TypecastTypename (UnquotedIdent "int4") False 0 False]++>>> 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 [TypecastTypename]+preparableStmt = placeholderTypeMap <=< PlaceholderTypeMap.preparableStmt++placeholderTypeMap :: IntMap TypecastTypename -> Either Text [TypecastTypename]+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)
+ library/Hasql/TH/Syntax/Projections/OutputTypeList.hs view
@@ -0,0 +1,94 @@+{-|+AST traversal extracting output types.+-}+module Hasql.TH.Syntax.Projections.OutputTypeList where++import Hasql.TH.Prelude+import Hasql.TH.Syntax.Ast++{- $setup+>>> import qualified Hasql.TH.Syntax.Parsing as P+>>> parse parser = either (error . show) id . Text.Megaparsec.parse parser ""+-}++foldable :: Foldable f => (a -> Either Text [TypecastTypename]) -> f a -> Either Text [TypecastTypename]+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+++-- * 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"
+ library/Hasql/TH/Syntax/Projections/PlaceholderTypeMap.hs view
@@ -0,0 +1,55 @@+module Hasql.TH.Syntax.Projections.PlaceholderTypeMap where++import Hasql.TH.Prelude hiding (union)+import Hasql.TH.Syntax.Ast+import Hasql.TH.Syntax.Projections.ChildExprList (ChildExpr(..))+import qualified Data.IntMap.Strict as IntMap+import qualified Hasql.TH.Syntax.Projections.ChildExprList as ChildExprList+++preparableStmt :: PreparableStmt -> Either Text (IntMap TypecastTypename)+preparableStmt = childExprList . ChildExprList.preparableStmt++childExprList :: [ChildExpr] -> Either Text (IntMap TypecastTypename)+childExprList = foldM union IntMap.empty <=< traverse childExpr++union :: IntMap TypecastTypename -> IntMap TypecastTypename -> Either Text (IntMap TypecastTypename)+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 TypecastTypename)+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
+ library/Hasql/TH/Syntax/Rendering.hs view
@@ -0,0 +1,958 @@+module Hasql.TH.Syntax.Rendering where++import Hasql.TH.Prelude hiding (aExpr, try, option, many, sortBy, bit, fromList)+import Hasql.TH.Syntax.Ast+import Data.ByteString.FastBuilder+import qualified Hasql.TH.Extras.NonEmpty as NonEmpty+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.ByteString.Builder as BsBuilder+import qualified Data.ByteString.Lazy as LazyBs+++-- * Execution+-------------------------++toByteString :: Builder -> ByteString+toByteString = toStrictByteString++toText :: Builder -> Text+toText = Text.decodeUtf8 . toByteString+++-- * Helpers+-------------------------++text :: Text -> Builder+text = stringUtf8 . Text.unpack++commaNonEmpty :: (a -> Builder) -> NonEmpty a -> Builder+commaNonEmpty = NonEmpty.intersperseFoldMap ", "++spaceNonEmpty :: (a -> Builder) -> NonEmpty a -> Builder+spaceNonEmpty = NonEmpty.intersperseFoldMap " "++lexemes :: [Builder] -> Builder+lexemes = mconcat . intersperse " "++optLexemes :: [Maybe Builder] -> Builder+optLexemes = lexemes . catMaybes++inParens :: Builder -> Builder+inParens a = "(" <> a <> ")"++inBrackets :: Builder -> Builder+inBrackets a = "[" <> a <> "]"++prefixMaybe :: (a -> Builder) -> Maybe a -> Builder+prefixMaybe a = foldMap (flip mappend " " . a)++suffixMaybe :: (a -> Builder) -> Maybe a -> Builder+suffixMaybe a = foldMap (mappend " " . a)+++-- * Statements+-------------------------++preparableStmt = \ case+ SelectPreparableStmt a -> selectStmt a+ InsertPreparableStmt a -> insertStmt a+ UpdatePreparableStmt a -> updateStmt a+ DeletePreparableStmt a -> deleteStmt a+++-- * Insert+-------------------------++insertStmt (InsertStmt a b c d e) =+ prefixMaybe withClause a <>+ "INSERT INTO " <>+ insertTarget b <> " " <> insertRest c <>+ suffixMaybe onConflict d <>+ suffixMaybe returningClause e++insertTarget (InsertTarget a b) =+ qualifiedName a <> foldMap (mappend " AS " . colId) b++insertRest = \ case+ SelectInsertRest a b c ->+ optLexemes [+ fmap (inParens . insertColumnList) a,+ fmap insertRestOverriding b,+ Just (selectStmt c)+ ]+ DefaultValuesInsertRest -> "DEFAULT VALUES"++insertRestOverriding a = "OVERRIDING " <> overrideKind a <> " VALUE"++overrideKind = \ case+ UserOverrideKind -> "USER"+ SystemOverrideKind -> "SYSTEM"++insertColumnList = commaNonEmpty insertColumnItem++insertColumnItem (InsertColumnItem a b) = colId a <> suffixMaybe indirection b++onConflict (OnConflict a b) = "ON CONFLICT" <> suffixMaybe confExpr a <> " DO " <> onConflictDo b++onConflictDo = \ case+ UpdateOnConflictDo a b -> "UPDATE SET " <> setClauseList a <> suffixMaybe whereClause b+ NothingOnConflictDo -> "NOTHING"++confExpr = \ case+ WhereConfExpr a b -> inParens (indexParams a) <> suffixMaybe whereClause b+ ConstraintConfExpr a -> "ON CONSTRAINT " <> name a++returningClause = mappend "RETURNING " . targetList+++-- * Update+-------------------------++updateStmt (UpdateStmt a b c d e f) =+ prefixMaybe withClause a <>+ "UPDATE " <> relationExprOptAlias b <> " " <>+ "SET " <> setClauseList c <>+ suffixMaybe fromClause d <>+ suffixMaybe whereOrCurrentClause e <>+ suffixMaybe returningClause f++setClauseList = commaNonEmpty setClause++setClause = \ case+ TargetSetClause a b -> setTarget a <> " = " <> aExpr b+ TargetListSetClause a b -> inParens (setTargetList a) <> " = " <> aExpr b++setTarget (SetTarget a b) = colId a <> suffixMaybe indirection b++setTargetList = commaNonEmpty setTarget+++-- * Delete+-------------------------++deleteStmt (DeleteStmt a b c d e) =+ prefixMaybe withClause a <>+ "DELETE FROM " <> relationExprOptAlias b <>+ suffixMaybe usingClause c <>+ suffixMaybe whereOrCurrentClause d <>+ suffixMaybe returningClause e++usingClause = mappend "USING " . fromList+++-- * Select+-------------------------++selectStmt = \ case+ Left a -> selectNoParens a+ Right a -> selectWithParens a++selectNoParens (SelectNoParens a b c d e) =+ optLexemes+ [+ fmap withClause a,+ Just (selectClause b),+ fmap sortClause c,+ fmap selectLimit d,+ fmap forLockingClause e+ ]++selectWithParens = inParens . \ case+ NoParensSelectWithParens a -> selectNoParens a+ WithParensSelectWithParens a -> selectWithParens a++withClause (WithClause a b) =+ "WITH " <> bool "" "RECURSIVE " a <> commaNonEmpty commonTableExpr b++commonTableExpr (CommonTableExpr a b c d) =+ optLexemes+ [+ Just (ident a),+ fmap (inParens . commaNonEmpty ident) b,+ Just "AS",+ fmap materialization c,+ Just (inParens (preparableStmt d))+ ]++materialization = bool "NOT MATERIALIZED" "MATERIALIZED"++selectLimit = \ case+ LimitOffsetSelectLimit a b -> lexemes [limitClause a, offsetClause b]+ OffsetLimitSelectLimit a b -> lexemes [offsetClause a, limitClause b]+ LimitSelectLimit a -> limitClause a+ OffsetSelectLimit a -> offsetClause a++limitClause = \ case+ LimitLimitClause a b -> "LIMIT " <> selectLimitValue a <> foldMap (mappend ", " . aExpr) b+ FetchOnlyLimitClause a b c ->+ optLexemes+ [+ Just "FETCH",+ Just (firstOrNext a),+ fmap selectFetchFirstValue b,+ Just (rowOrRows c),+ Just "ONLY"+ ]++firstOrNext = bool "FIRST" "NEXT"++rowOrRows = bool "ROW" "ROWS"++selectFetchFirstValue = \ case+ ExprSelectFetchFirstValue a -> cExpr a+ NumSelectFetchFirstValue a b -> bool "+" "-" a <> intOrFloat b++intOrFloat = either int64Dec doubleDec++selectLimitValue = \ case+ ExprSelectLimitValue a -> aExpr a+ AllSelectLimitValue -> "ALL"++offsetClause = \ case+ ExprOffsetClause a -> "OFFSET " <> aExpr a+ FetchFirstOffsetClause a b -> "OFFSET " <> selectFetchFirstValue a <> " " <> rowOrRows b++forLockingClause = \ case+ ItemsForLockingClause a -> spaceNonEmpty forLockingItem a+ ReadOnlyForLockingClause -> "FOR READ ONLY"++forLockingItem (ForLockingItem a b c) =+ optLexemes+ [+ Just (forLockingStrength a),+ fmap lockedRelsList b,+ fmap nowaitOrSkip c+ ]++forLockingStrength = \ case+ UpdateForLockingStrength -> "FOR UPDATE"+ NoKeyUpdateForLockingStrength -> "FOR NO KEY UPDATE"+ ShareForLockingStrength -> "FOR SHARE"+ KeyForLockingStrength -> "FOR KEY SHARE"++lockedRelsList a = "OF " <> commaNonEmpty qualifiedName a++nowaitOrSkip = bool "NOWAIT" "SKIP LOCKED"++selectClause = either simpleSelect selectWithParens++simpleSelect = \ case+ NormalSimpleSelect a b c d e f g ->+ optLexemes+ [+ Just "SELECT",+ fmap targeting a,+ fmap intoClause b,+ fmap fromClause c,+ fmap whereClause d,+ fmap groupClause e,+ fmap havingClause f,+ fmap windowClause g+ ]+ ValuesSimpleSelect a -> valuesClause a+ TableSimpleSelect a -> "TABLE " <> relationExpr a+ BinSimpleSelect a b c d -> selectClause b <> " " <> selectBinOp a <> foldMap (mappend " ". allOrDistinct) c <> " " <> selectClause d++selectBinOp = \ case+ UnionSelectBinOp -> "UNION"+ IntersectSelectBinOp -> "INTERSECT"+ ExceptSelectBinOp -> "EXCEPT"++targeting = \ case+ NormalTargeting a -> targetList a+ AllTargeting a -> "ALL" <> suffixMaybe targetList a+ DistinctTargeting a b -> "DISTINCT" <> suffixMaybe onExpressionsClause a <> " " <> commaNonEmpty targetEl b++targetList = commaNonEmpty targetEl++onExpressionsClause a = "ON (" <> commaNonEmpty aExpr a <> ")"++targetEl = \ case+ AliasedExprTargetEl a b -> aExpr a <> " AS " <> ident b+ ImplicitlyAliasedExprTargetEl a b -> aExpr a <> " " <> ident b+ ExprTargetEl a -> aExpr a+ AsteriskTargetEl -> "*"+++-- * Select Into+-------------------------++intoClause a = "INTO " <> optTempTableName a++optTempTableName = \ case+ TemporaryOptTempTableName a b -> optLexemes [Just "TEMPORARY", bool Nothing (Just "TABLE") a, Just (qualifiedName b)]+ TempOptTempTableName a b -> optLexemes [Just "TEMP", bool Nothing (Just "TABLE") a, Just (qualifiedName b)]+ LocalTemporaryOptTempTableName a b -> optLexemes [Just "LOCAL TEMPORARY", bool Nothing (Just "TABLE") a, Just (qualifiedName b)]+ LocalTempOptTempTableName a b -> optLexemes [Just "LOCAL TEMP", bool Nothing (Just "TABLE") a, Just (qualifiedName b)]+ GlobalTemporaryOptTempTableName a b -> optLexemes [Just "GLOBAL TEMPORARY", bool Nothing (Just "TABLE") a, Just (qualifiedName b)]+ GlobalTempOptTempTableName a b -> optLexemes [Just "GLOBAL TEMP", bool Nothing (Just "TABLE") a, Just (qualifiedName b)]+ UnloggedOptTempTableName a b -> optLexemes [Just "UNLOGGED", bool Nothing (Just "TABLE") a, Just (qualifiedName b)]+ TableOptTempTableName a -> "TABLE " <> qualifiedName a+ QualifedOptTempTableName a -> qualifiedName a+++-- * From+-------------------------++fromClause a = "FROM " <> fromList a++fromList = commaNonEmpty tableRef++tableRef = \ case+ RelationExprTableRef a b c ->+ optLexemes [+ Just (relationExpr a),+ fmap aliasClause b,+ fmap tablesampleClause c+ ]+ FuncTableRef a b c ->+ optLexemes [+ if a then Just "LATERAL" else Nothing,+ Just (funcTable b),+ fmap funcAliasClause c+ ]+ SelectTableRef a b c ->+ optLexemes [+ if a then Just "LATERAL" else Nothing,+ Just (selectWithParens b),+ fmap aliasClause c+ ]+ JoinTableRef a b -> case b of+ Just c -> inParens (joinedTable a) <> " " <> aliasClause c+ Nothing -> joinedTable a++relationExpr = \ case+ SimpleRelationExpr a b -> qualifiedName a <> bool "" " *" b+ OnlyRelationExpr a b -> "ONLY " <> bool qualifiedName (inParens . qualifiedName) b a++relationExprOptAlias (RelationExprOptAlias a b) = relationExpr a <> suffixMaybe optAlias b++optAlias (a, b) = bool "" "AS " a <> colId b++tablesampleClause (TablesampleClause a b c) =+ "TABLESAMPLE " <> funcName a <> " (" <> exprList b <> ")" <> suffixMaybe repeatableClause c++repeatableClause a = "REPEATABLE (" <> aExpr a <> ")"++funcTable = \ case+ FuncExprFuncTable a b -> funcExprWindownless a <> bool "" " WITH ORDINALITY" b+ RowsFromFuncTable a b -> "ROWS FROM (" <> rowsfromList a <> ")" <> bool "" " WITH ORDINALITY" b++rowsfromItem (RowsfromItem a b) = funcExprWindownless a <> suffixMaybe colDefList b++rowsfromList = commaNonEmpty rowsfromItem++colDefList a = "AS (" <> tableFuncElementList a <> ")"++tableFuncElementList = commaNonEmpty tableFuncElement++tableFuncElement (TableFuncElement a b c) = colId a <> " " <> typename b <> suffixMaybe collateClause c++collateClause a = "COLLATE " <> anyName a++aliasClause (AliasClause a b c) =+ optLexemes+ [+ if a then Just "AS" else Nothing,+ Just (ident b),+ fmap (inParens . commaNonEmpty ident) c+ ]++funcAliasClause = \ case+ AliasFuncAliasClause a -> aliasClause a+ AsFuncAliasClause a -> "AS (" <> tableFuncElementList a <> ")"+ AsColIdFuncAliasClause a b -> "AS " <> colId a <> " (" <> tableFuncElementList b <> ")"+ ColIdFuncAliasClause a b -> colId a <> " (" <> tableFuncElementList b <> ")"++joinedTable = \ case+ InParensJoinedTable a -> inParens (joinedTable a)+ MethJoinedTable a b c -> case a of+ CrossJoinMeth -> tableRef b <> " CROSS JOIN " <> tableRef c+ QualJoinMeth d e -> tableRef b <> suffixMaybe joinType d <> " JOIN " <> tableRef c <> " " <> joinQual e+ NaturalJoinMeth d -> tableRef b <> " NATURAL" <> suffixMaybe joinType d <> " JOIN " <> tableRef c++joinType = \ case+ FullJoinType a -> "FULL" <> if a then " OUTER" else ""+ LeftJoinType a -> "LEFT" <> if a then " OUTER" else ""+ RightJoinType a -> "RIGHT" <> if a then " OUTER" else ""+ InnerJoinType -> "INNER"++joinQual = \ case+ UsingJoinQual a -> "USING (" <> commaNonEmpty ident a <> ")" + OnJoinQual a -> "ON " <> aExpr a+++-- * Where+-------------------------++whereClause a = "WHERE " <> aExpr a++whereOrCurrentClause = \ case+ ExprWhereOrCurrentClause a -> "WHERE " <> aExpr a+ CursorWhereOrCurrentClause a -> "WHERE CURRENT OF " <> cursorName a+++-- * Group By+-------------------------++groupClause a = "GROUP BY " <> commaNonEmpty groupByItem a++groupByItem = \ case+ ExprGroupByItem a -> aExpr a+ EmptyGroupingSetGroupByItem -> "()"+ RollupGroupByItem a -> "ROLLUP (" <> commaNonEmpty aExpr a <> ")"+ CubeGroupByItem a -> "CUBE (" <> commaNonEmpty aExpr a <> ")"+ GroupingSetsGroupByItem a -> "GROUPING SETS (" <> commaNonEmpty groupByItem a <> ")"+++-- * Having+-------------------------++havingClause a = "HAVING " <> aExpr a+++-- * Window+-------------------------++windowClause a = "WINDOW " <> commaNonEmpty windowDefinition a++windowDefinition (WindowDefinition a b) = ident a <> " AS " <> windowSpecification b++windowSpecification (WindowSpecification a b c d) =+ inParens $ optLexemes+ [+ fmap ident a,+ fmap partitionClause b,+ fmap sortClause c,+ fmap frameClause d+ ]++partitionClause a = "PARTITION BY " <> commaNonEmpty aExpr a++frameClause (FrameClause a b c) =+ optLexemes+ [+ Just (frameClauseMode a),+ Just (frameExtent b),+ fmap windowExclusionCause c+ ]++frameClauseMode = \ case+ RangeFrameClauseMode -> "RANGE"+ RowsFrameClauseMode -> "ROWS"+ GroupsFrameClauseMode -> "GROUPS"++frameExtent = \ case+ SingularFrameExtent a -> frameBound a+ BetweenFrameExtent a b -> "BETWEEN " <> frameBound a <> " AND " <> frameBound b++frameBound = \ case+ UnboundedPrecedingFrameBound -> "UNBOUNDED PRECEDING"+ UnboundedFollowingFrameBound -> "UNBOUNDED FOLLOWING"+ CurrentRowFrameBound -> "CURRENT ROW"+ PrecedingFrameBound a -> aExpr a <> " PRECEDING"+ FollowingFrameBound a -> aExpr a <> " FOLLOWING"++windowExclusionCause = \ case+ CurrentRowWindowExclusionClause -> "EXCLUDE CURRENT ROW"+ GroupWindowExclusionClause -> "EXCLUDE GROUP"+ TiesWindowExclusionClause -> "EXCLUDE TIES"+ NoOthersWindowExclusionClause -> "EXCLUDE NO OTHERS"+++-- * Order By+-------------------------++sortClause a = "ORDER BY " <> commaNonEmpty sortBy a++sortBy = \ case+ UsingSortBy a b c -> aExpr a <> " USING " <> qualAllOp b <> suffixMaybe nullsOrder c+ AscDescSortBy a b c -> aExpr a <> suffixMaybe ascDesc b <> suffixMaybe nullsOrder c+++-- * Values+-------------------------++valuesClause a = "VALUES " <> commaNonEmpty (inParens . commaNonEmpty aExpr) a+++-- * Exprs+-------------------------++exprList = commaNonEmpty aExpr++aExpr = \ case+ CExprAExpr a -> cExpr a+ TypecastAExpr a b -> aExpr a <> " :: " <> typecastTypename b+ CollateAExpr a b -> aExpr a <> " COLLATE " <> anyName b+ AtTimeZoneAExpr a b -> aExpr a <> " AT TIME ZONE " <> 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 <> " AND " <> aExpr b+ OrAExpr a b -> aExpr a <> " OR " <> aExpr b+ NotAExpr a -> "NOT " <> aExpr a+ VerbalExprBinOpAExpr a b c d e -> aExpr a <> " " <> verbalExprBinOp b c <> " " <> aExpr d <> foldMap (mappend " ESCAPE " . aExpr) e+ ReversableOpAExpr a b c -> aExpr a <> " " <> aExprReversableOp b c+ IsnullAExpr a -> aExpr a <> " ISNULL"+ NotnullAExpr a -> aExpr a <> " NOTNULL"+ OverlapsAExpr a b -> row a <> " OVERLAPS " <> row b+ SubqueryAExpr a b c d -> aExpr a <> " " <> subqueryOp b <> " " <> subType c <> " " <> either selectWithParens (inParens . aExpr) d+ UniqueAExpr a -> "UNIQUE " <> selectWithParens a+ DefaultAExpr -> "DEFAULT"++bExpr = \ case+ CExprBExpr a -> cExpr a+ TypecastBExpr a b -> bExpr a <> " :: " <> typecastTypename 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 b c++cExpr = \ case+ ColumnrefCExpr a -> columnref a+ AexprConstCExpr a -> aexprConst a+ ParamCExpr a b -> "$" <> intDec a <> foldMap indirection b+ InParensCExpr a b -> inParens (aExpr a) <> foldMap indirection b+ CaseCExpr a -> caseExpr a+ FuncCExpr a -> funcExpr a+ SelectWithParensCExpr a b -> selectWithParens a <> foldMap indirection b+ ExistsCExpr a -> "EXISTS " <> selectWithParens a+ ArrayCExpr a -> "ARRAY " <> either selectWithParens arrayExpr a+ ExplicitRowCExpr a -> explicitRow a+ ImplicitRowCExpr a -> implicitRow a+ GroupingCExpr a -> "GROUPING " <> inParens (exprList a)+++-- * Ops+-------------------------++aExprReversableOp a = \ case+ NullAExprReversableOp -> bool "IS " "IS NOT " a <> "NULL"+ TrueAExprReversableOp -> bool "IS " "IS NOT " a <> "TRUE"+ FalseAExprReversableOp -> bool "IS " "IS NOT " a <> "FALSE"+ UnknownAExprReversableOp -> bool "IS " "IS NOT " a <> "UNKNOWN"+ DistinctFromAExprReversableOp b -> bool "IS " "IS NOT " a <> "DISTINCT FROM " <> aExpr b+ OfAExprReversableOp b -> bool "IS " "IS NOT " a <> "OF " <> inParens (typeList b)+ BetweenAExprReversableOp b c d -> bool "" "NOT " a <> bool "BETWEEN " "BETWEEN ASYMMETRIC " b <> bExpr c <> " AND " <> aExpr d+ BetweenSymmetricAExprReversableOp b c -> bool "" "NOT " a <> "BETWEEN SYMMETRIC " <> bExpr b <> " AND " <> aExpr c+ InAExprReversableOp b -> bool "" "NOT " a <> "IN " <> inExpr b+ DocumentAExprReversableOp -> bool "IS " "IS NOT " a <> "DOCUMENT"++verbalExprBinOp a = mappend (bool "" "NOT " a) . \ case+ LikeVerbalExprBinOp -> "LIKE"+ IlikeVerbalExprBinOp -> "ILIKE"+ SimilarToVerbalExprBinOp -> "SIMILAR TO"++subqueryOp = \ case+ AllSubqueryOp a -> allOp a+ AnySubqueryOp a -> "OPERATOR " <> inParens (anyOperator a)+ LikeSubqueryOp a -> bool "" "NOT " a <> "LIKE"+ IlikeSubqueryOp a -> bool "" "NOT " a <> "ILIKE"++bExprIsOp a = mappend (bool "IS " "IS NOT " a) . \ case+ DistinctFromBExprIsOp b -> "DISTINCT FROM " <> bExpr b+ OfBExprIsOp a -> "OF " <> inParens (typeList a)+ DocumentBExprIsOp -> "DOCUMENT"++symbolicExprBinOp = \ case+ MathSymbolicExprBinOp a -> mathOp a+ QualSymbolicExprBinOp a -> qualOp a++qualOp = \ case+ OpQualOp a -> op a+ OperatorQualOp a -> "OPERATOR (" <> anyOperator a <> ")"++qualAllOp = \ case+ AllQualAllOp a -> allOp a+ AnyQualAllOp a -> "OPERATOR (" <> anyOperator a <> ")"++op = text++anyOperator = \ case+ AllOpAnyOperator a -> allOp a+ QualifiedAnyOperator a b -> colId a <> "." <> anyOperator b++allOp = \ case+ OpAllOp a -> op a+ MathAllOp a -> mathOp a++mathOp = \ case+ PlusMathOp -> char7 '+'+ MinusMathOp -> char7 '-'+ AsteriskMathOp -> char7 '*'+ SlashMathOp -> char7 '/'+ PercentMathOp -> char7 '%'+ ArrowUpMathOp -> char7 '^'+ ArrowLeftMathOp -> char7 '<'+ ArrowRightMathOp -> char7 '>'+ EqualsMathOp -> char7 '='+ LessEqualsMathOp -> "<="+ GreaterEqualsMathOp -> ">="+ ArrowLeftArrowRightMathOp -> "<>"+ ExclamationEqualsMathOp -> "!="+++-- *+-------------------------++inExpr = \ case+ SelectInExpr a -> selectWithParens a+ ExprListInExpr a -> inParens (exprList a)++caseExpr (CaseExpr a b c) = optLexemes [+ Just "CASE",+ fmap aExpr a,+ Just (spaceNonEmpty whenClause b),+ fmap caseDefault c,+ Just "END"+ ]++whenClause (WhenClause a b) = "WHEN " <> aExpr a <> " THEN " <> aExpr b++caseDefault a = "ELSE " <> aExpr a++arrayExpr = inBrackets . \ case+ ExprListArrayExpr a -> exprList a+ ArrayExprListArrayExpr a -> arrayExprList a+ EmptyArrayExpr -> mempty++arrayExprList = commaNonEmpty arrayExpr++row = \ case+ ExplicitRowRow a -> explicitRow a+ ImplicitRowRow a -> implicitRow a++explicitRow a = "ROW " <> inParens (foldMap exprList a)++implicitRow (ImplicitRow a b) = inParens (exprList a <> ", " <> aExpr b)++funcApplication (FuncApplication a b) =+ funcName a <> "(" <> foldMap funcApplicationParams b <> ")"++funcApplicationParams = \ case+ NormalFuncApplicationParams a b c ->+ optLexemes+ [+ fmap allOrDistinct a,+ Just (commaNonEmpty funcArgExpr b),+ fmap sortClause c+ ]+ VariadicFuncApplicationParams a b c ->+ optLexemes+ [+ fmap (flip mappend "," . commaNonEmpty funcArgExpr) a,+ Just "VARIADIC",+ Just (funcArgExpr b),+ fmap sortClause c+ ]+ StarFuncApplicationParams -> "*"++allOrDistinct = \ case+ False -> "ALL"+ True -> "DISTINCT"++funcArgExpr = \ case+ ExprFuncArgExpr a -> aExpr a+ ColonEqualsFuncArgExpr a b -> ident a <> " := " <> aExpr b+ EqualsGreaterFuncArgExpr a b -> ident a <> " => " <> aExpr b++-- ** Func Expr+-------------------------++funcExpr = \ case+ ApplicationFuncExpr a b c d -> optLexemes [+ Just (funcApplication a),+ fmap withinGroupClause b,+ fmap filterClause c,+ fmap overClause d+ ]+ SubexprFuncExpr a -> funcExprCommonSubexpr a++funcExprWindownless = \ case+ ApplicationFuncExprWindowless a -> funcApplication a+ CommonSubexprFuncExprWindowless a -> funcExprCommonSubexpr a++withinGroupClause a = "WITHIN GROUP (" <> sortClause a <> ")"++filterClause a = "FILTER (WHERE " <> aExpr a <> ")"++overClause = \ case+ WindowOverClause a -> "OVER " <> windowSpecification a+ ColIdOverClause a -> "OVER " <> colId a++funcExprCommonSubexpr = \ case+ CollationForFuncExprCommonSubexpr a -> "COLLATION FOR (" <> aExpr a <> ")"+ CurrentDateFuncExprCommonSubexpr -> "CURRENT_DATE"+ CurrentTimeFuncExprCommonSubexpr a -> "CURRENT_TIME" <> suffixMaybe (inParens . iconst) a+ CurrentTimestampFuncExprCommonSubexpr a -> "CURRENT_TIMESTAMP" <> suffixMaybe (inParens . iconst) a+ LocalTimeFuncExprCommonSubexpr a -> "LOCALTIME" <> suffixMaybe (inParens . iconst) a+ LocalTimestampFuncExprCommonSubexpr a -> "LOCALTIMESTAMP" <> suffixMaybe (inParens . iconst) a+ CurrentRoleFuncExprCommonSubexpr -> "CURRENT_ROLE"+ CurrentUserFuncExprCommonSubexpr -> "CURRENT_USER"+ SessionUserFuncExprCommonSubexpr -> "SESSION_USER"+ UserFuncExprCommonSubexpr -> "USER"+ CurrentCatalogFuncExprCommonSubexpr -> "CURRENT_CATALOG"+ CurrentSchemaFuncExprCommonSubexpr -> "CURRENT_SCHEMA"+ CastFuncExprCommonSubexpr a b -> "CAST (" <> aExpr a <> " AS " <> typename b <> ")"+ ExtractFuncExprCommonSubexpr a -> "EXTRACT (" <> foldMap extractList a <> ")"+ OverlayFuncExprCommonSubexpr a -> "OVERLAY (" <> overlayList a <> ")"+ PositionFuncExprCommonSubexpr a -> "POSITION (" <> foldMap positionList a <> ")"+ SubstringFuncExprCommonSubexpr a -> "SUBSTRING (" <> foldMap substrList a <> ")"+ TreatFuncExprCommonSubexpr a b -> "TREAT (" <> aExpr a <> " AS " <> typename b <> ")"+ TrimFuncExprCommonSubexpr a b -> "TRIM (" <> prefixMaybe trimModifier a <> trimList b <> ")"+ NullIfFuncExprCommonSubexpr a b -> "NULLIF (" <> aExpr a <> ", " <> aExpr b <> ")"+ CoalesceFuncExprCommonSubexpr a -> "COALESCE (" <> exprList a <> ")"+ GreatestFuncExprCommonSubexpr a -> "GREATEST (" <> exprList a <> ")"+ LeastFuncExprCommonSubexpr a -> "LEAST (" <> exprList a <> ")"++extractList (ExtractList a b) = extractArg a <> " FROM " <> aExpr b++extractArg = \ case+ IdentExtractArg a -> ident a+ YearExtractArg -> "YEAR"+ MonthExtractArg -> "MONTH"+ DayExtractArg -> "DAY"+ HourExtractArg -> "HOUR"+ MinuteExtractArg -> "MINUTE"+ SecondExtractArg -> "SECOND"+ SconstExtractArg a -> sconst a++overlayList (OverlayList a b c d) = aExpr a <> " " <> overlayPlacing b <> " " <> substrFrom c <> suffixMaybe substrFor d++overlayPlacing a = "PLACING " <> aExpr a++positionList (PositionList a b) = bExpr a <> " IN " <> bExpr b++substrList = \ case+ ExprSubstrList a b -> aExpr a <> " " <> substrListFromFor b+ ExprListSubstrList a -> exprList a++substrListFromFor = \ case+ FromForSubstrListFromFor a b -> substrFrom a <> " " <> substrFor b+ ForFromSubstrListFromFor a b -> substrFor a <> " " <> substrFrom b+ FromSubstrListFromFor a -> substrFrom a+ ForSubstrListFromFor a -> substrFor a++substrFrom a = "FROM " <> aExpr a++substrFor a = "FOR " <> aExpr a++trimModifier = \ case+ BothTrimModifier -> "BOTH"+ LeadingTrimModifier -> "LEADING"+ TrailingTrimModifier -> "TRAILING"++trimList = \ case+ ExprFromExprListTrimList a b -> aExpr a <> " FROM " <> exprList b+ FromExprListTrimList a -> "FROM " <> exprList a+ ExprListTrimList a -> exprList a+++-- * AexprConsts+-------------------------++aexprConst = \ case+ IAexprConst a -> iconst a+ FAexprConst a -> fconst a+ SAexprConst a -> sconst a+ BAexprConst a -> "B'" <> text a <> "'"+ XAexprConst a -> "X'" <> text a <> "'"+ FuncAexprConst a b c -> funcName a <> foldMap (inParens . funcAexprConstArgList) b <> " " <> sconst c+ ConstTypenameAexprConst a b -> constTypename a <> " " <> sconst b+ StringIntervalAexprConst a b -> "INTERVAL " <> sconst a <> suffixMaybe interval b+ IntIntervalAexprConst a b -> "INTERVAL " <> inParens (int64Dec a) <> " " <> sconst b+ BoolAexprConst a -> if a then "TRUE" else "FALSE"+ NullAexprConst -> "NULL"++iconst = int64Dec++fconst = doubleDec++sconst a = "'" <> text (Text.replace "'" "''" a) <> "'"++funcAexprConstArgList (FuncConstArgs a b) = commaNonEmpty funcArgExpr a <> suffixMaybe sortClause b++constTypename = \ case+ NumericConstTypename a -> numeric a+ ConstBitConstTypename a -> constBit a+ ConstCharacterConstTypename a -> constCharacter a+ ConstDatetimeConstTypename a -> constDatetime a++numeric = \ case+ IntNumeric -> "INT"+ IntegerNumeric -> "INTEGER"+ SmallintNumeric -> "SMALLINT"+ BigintNumeric -> "BIGINT"+ RealNumeric -> "REAL"+ FloatNumeric a -> "FLOAT" <> suffixMaybe (inParens . int64Dec) a+ DoublePrecisionNumeric -> "DOUBLE PRECISION"+ DecimalNumeric a -> "DECIMAL" <> suffixMaybe (inParens . commaNonEmpty aExpr) a+ DecNumeric a -> "DEC" <> suffixMaybe (inParens . commaNonEmpty aExpr )a+ NumericNumeric a -> "NUMERIC" <> suffixMaybe (inParens . commaNonEmpty aExpr) a+ BooleanNumeric -> "BOOLEAN"++bit (Bit a b) = optLexemes [+ Just "BIT",+ bool Nothing (Just "VARYING") a,+ fmap (inParens . commaNonEmpty aExpr) b+ ]++constBit = bit++constCharacter (ConstCharacter a b) = character a <> suffixMaybe (inParens . int64Dec) b++character = \ case+ CharacterCharacter a -> "CHARACTER" <> bool "" " VARYING" a+ CharCharacter a -> "CHAR" <> bool "" " VARYING" a+ VarcharCharacter -> "VARCHAR"+ NationalCharacterCharacter a -> "NATIONAL CHARACTER" <> bool "" " VARYING" a+ NationalCharCharacter a -> "NATIONAL CHAR" <> bool "" " VARYING" a+ NcharCharacter a -> "NCHAR" <> bool "" " VARYING" a++constDatetime = \ case+ TimestampConstDatetime a b -> optLexemes [+ Just "TIMESTAMP",+ fmap (inParens . int64Dec) a,+ fmap timezone b+ ]+ TimeConstDatetime a b -> optLexemes [+ Just "TIME",+ fmap (inParens . int64Dec) a,+ fmap timezone b+ ]++timezone = \ case+ False -> "WITH TIME ZONE"+ True -> "WITHOUT TIME ZONE"++interval = \ case+ YearInterval -> "YEAR"+ MonthInterval -> "MONTH"+ DayInterval -> "DAY"+ HourInterval -> "HOUR"+ MinuteInterval -> "MINUTE"+ SecondInterval a -> intervalSecond a+ YearToMonthInterval -> "YEAR TO MONTH"+ DayToHourInterval -> "DAY TO HOUR"+ DayToMinuteInterval -> "DAY TO MINUTE"+ DayToSecondInterval a -> "DAY TO " <> intervalSecond a+ HourToMinuteInterval -> "HOUR TO MINUTE"+ HourToSecondInterval a -> "HOUR TO " <> intervalSecond a+ MinuteToSecondInterval a -> "MINUTE TO " <> intervalSecond a++intervalSecond = \ case+ Nothing -> "SECOND" + Just a -> "SECOND " <> inParens (int64Dec a)+++-- * Names and refs+-------------------------++columnref (Columnref a b) = colId a <> foldMap indirection b++ident = \ case+ QuotedIdent a -> char7 '"' <> text (Text.replace "\"" "\"\"" a) <> char7 '"'+ UnquotedIdent a -> text a++qualifiedName = \ case+ SimpleQualifiedName a -> ident a+ IndirectedQualifiedName a b -> ident a <> indirection b++indirection = foldMap indirectionEl++indirectionEl = \ case+ AttrNameIndirectionEl a -> "." <> ident a+ AllIndirectionEl -> ".*"+ ExprIndirectionEl a -> "[" <> aExpr a <> "]"+ SliceIndirectionEl a b -> "[" <> foldMap aExpr a <> ":" <> foldMap aExpr b <> "]"++colId = ident++name = colId++cursorName = name++colLabel = ident++attrName = colLabel++typeFunctionName = ident++funcName = \ case+ TypeFuncName a -> typeFunctionName a+ IndirectedFuncName a b -> colId a <> indirection b++anyName (AnyName a b) = colId a <> foldMap attrs b+++-- * Types+-------------------------++typecastTypename (TypecastTypename a _ b _) =+ ident a <>+ fold (replicate b "[]")++typename = \ case+ ArrayBoundsTypename a b c ->+ bool "" "SETOF " a <> simpleTypename b <> suffixMaybe arrayBounds c+ ArrayDimTypename a b c ->+ bool "" "SETOF " a <> simpleTypename b <> " ARRAY" <> foldMap (inBrackets . iconst) c++arrayBounds = spaceNonEmpty (inBrackets . foldMap iconst)++simpleTypename = \ case+ GenericTypeSimpleTypename a -> genericType a+ NumericSimpleTypename a -> numeric a+ BitSimpleTypename a -> bit a+ CharacterSimpleTypename a -> character a+ ConstDatetimeSimpleTypename a -> constDatetime a+ ConstIntervalSimpleTypename a -> "INTERVAL" <> either (suffixMaybe interval) (mappend " " . inParens . iconst) a++genericType (GenericType a b c) = typeFunctionName a <> foldMap attrs b <> suffixMaybe typeModifiers c++attrs = foldMap (mappend "." . attrName)++typeModifiers = inParens . exprList++typeList = commaNonEmpty typename++subType = \ case+ AnySubType -> "ANY"+ SomeSubType -> "SOME"+ AllSubType -> "ALL"+++-- * Indexes+-------------------------++indexParams = commaNonEmpty indexElem++indexElem (IndexElem a b c d e) =+ indexElemDef a <>+ suffixMaybe collate b <>+ suffixMaybe class_ c <>+ suffixMaybe ascDesc d <>+ suffixMaybe nullsOrder e++indexElemDef = \ case+ IdIndexElemDef a -> colId a+ FuncIndexElemDef a -> funcExprWindownless a+ ExprIndexElemDef a -> inParens (aExpr a)++collate = mappend "COLLATE " . anyName++class_ = anyName++ascDesc = \ case+ AscAscDesc -> "ASC"+ DescAscDesc -> "DESC"++nullsOrder = \ case+ FirstNullsOrder -> "NULLS FIRST"+ LastNullsOrder -> "NULLS LAST"
+ library/Hasql/TH/Syntax/Validator.hs view
@@ -0,0 +1,48 @@+module Hasql.TH.Syntax.Validator where++import Hasql.TH.Prelude hiding (expression)+import qualified Data.HashSet as HashSet+import qualified Data.Text as Text+import qualified Hasql.TH.Syntax.HashSet as HashSet+import qualified Hasql.TH.Syntax.Predicate as Predicate+++{-+The operator name is a sequence of up to NAMEDATALEN-1 (63 by default) +characters from the following list:+++ - * / < > = ~ ! @ # % ^ & | ` ?++There are a few restrictions on your choice of name:+-- and /* cannot appear anywhere in an operator name, +since they will be taken as the start of a comment.++A multicharacter operator name cannot end in + or -, +unless the name also contains at least one of these characters:++~ ! @ # % ^ & | ` ?++For example, @- is an allowed operator name, but *- is not. +This restriction allows PostgreSQL to parse SQL-compliant +commands without requiring spaces between tokens.+The use of => as an operator name is deprecated. +It may be disallowed altogether in a future release.++The operator != is mapped to <> on input, +so these two names are always equivalent.+-}+op :: Text -> Maybe Text+op a =+ if Text.null a+ then Just ("Operator is empty")+ else if Text.isInfixOf "--" a+ then Just ("Operator contains a prohibited \"--\" sequence: " <> a)+ else if Text.isInfixOf "/*" a+ then Just ("Operator contains a prohibited \"/*\" sequence: " <> a)+ else if Predicate.inSet HashSet.nonOp a+ then Just ("Operator is not generic: " <> a)+ else if Text.find Predicate.prohibitionLiftingOpChar a & isJust+ then Nothing+ else if Predicate.prohibitedOpChar (Text.last a)+ then Just ("Operator ends with a prohibited char: " <> a)+ else Nothing
+ test/Main.hs view
@@ -0,0 +1,36 @@+module Main where++import Hasql.TH.Prelude+import Hedgehog+import Hedgehog.Main+import qualified Main.Gen as Gen+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Hasql.TH.Syntax.Ast as Ast+import qualified Hasql.TH.Syntax.Parsing as Parsing+import qualified Hasql.TH.Syntax.Rendering as Rendering+import qualified Data.Text as Text+++main = defaultMain [+ checkParallel $ Group "Parsing a rendered AST produces the same AST" $ let+ p _name _amount _gen _parser _renderer =+ (,) _name $ withDiscards (fromIntegral _amount * 200) $ withTests _amount $ property $ do+ ast <- forAll _gen+ let+ sql = Rendering.toText (_renderer ast)+ in do+ footnote ("SQL: " <> Text.unpack sql)+ case Parsing.run _parser sql of+ Left err -> do+ footnote err+ failure+ Right ast' -> ast === ast'+ in [+ p "tableRef" 10000 Gen.tableRef Parsing.tableRef Rendering.tableRef+ ,+ p "aExpr" 100000 Gen.aExpr Parsing.aExpr Rendering.aExpr+ ,+ p "preparableStmt" 35000 Gen.preparableStmt Parsing.preparableStmt Rendering.preparableStmt+ ]+ ]
+ test/Main/Gen.hs view
@@ -0,0 +1,931 @@+module Main.Gen where++import Hasql.TH.Prelude hiding (maybe, bool, sortBy, filter, bit, fromList)+import Hasql.TH.Syntax.Ast+import Hedgehog (Gen, MonadGen)+import Hedgehog.Gen+import qualified Hedgehog.Range as Range+import qualified Data.Text as Text+import qualified Data.HashSet as HashSet+import qualified Data.List as List+import qualified Hasql.TH.Syntax.HashSet as HashSet+import qualified Hasql.TH.Syntax.Predicate as Predicate+import qualified Hasql.TH.Syntax.Validator as Validator++++-- * Generic+-------------------------++inSet _set = filter (flip HashSet.member _set)++notInSet _set = filter (not . flip HashSet.member _set)+++-- * Statements+-------------------------++preparableStmt = choice [+ SelectPreparableStmt <$> selectStmt,+ InsertPreparableStmt <$> insertStmt,+ UpdatePreparableStmt <$> updateStmt,+ DeletePreparableStmt <$> deleteStmt+ ]+++-- * Insert+-------------------------++insertStmt = InsertStmt <$> maybe withClause <*> insertTarget <*> insertRest <*> maybe onConflict <*> maybe returningClause++insertTarget = InsertTarget <$> qualifiedName <*> maybe colId++insertRest = choice [+ SelectInsertRest <$> maybe insertColumnList <*> maybe overrideKind <*> selectStmt,+ pure DefaultValuesInsertRest+ ]++overrideKind = enumBounded++insertColumnList = nonEmpty (Range.exponential 1 7) insertColumnItem++insertColumnItem = InsertColumnItem <$> colId <*> maybe indirection++onConflict = OnConflict <$> maybe confExpr <*> onConflictDo++onConflictDo = choice [+ UpdateOnConflictDo <$> setClauseList <*> maybe whereClause,+ pure NothingOnConflictDo+ ]++confExpr = choice [+ WhereConfExpr <$> indexParams <*> maybe whereClause,+ ConstraintConfExpr <$> name+ ]++returningClause = targetList+++-- * Update+-------------------------++updateStmt = UpdateStmt <$> maybe withClause <*> relationExprOptAlias <*> setClauseList <*> maybe fromClause <*> maybe whereOrCurrentClause <*> maybe returningClause++setClauseList = nonEmpty (Range.exponential 1 10) setClause++setClause = choice [+ TargetSetClause <$> setTarget <*> aExpr,+ TargetListSetClause <$> setTargetList <*> aExpr+ ]++setTarget = SetTarget <$> colId <*> maybe indirection++setTargetList = nonEmpty (Range.exponential 1 10) setTarget+++-- * Delete+-------------------------++deleteStmt = DeleteStmt <$> maybe withClause <*> relationExprOptAlias <*> maybe usingClause <*> maybe whereOrCurrentClause <*> maybe returningClause++usingClause = fromList+++-- * Select+-------------------------++selectStmt = Left <$> selectNoParens++-- ** selectNoParens+-------------------------++selectNoParens = frequency [+ (90, SelectNoParens <$> maybe withClause <*> (Left <$> simpleSelect) <*> maybe sortClause <*> maybe selectLimit <*> maybe forLockingClause)+ ,+ (10, SelectNoParens <$> fmap Just withClause <*> selectClause <*> fmap Just sortClause <*> fmap Just selectLimit <*> fmap Just forLockingClause)+ ]++terminalSelectNoParens = + SelectNoParens <$> pure Nothing <*> (Left <$> terminalSimpleSelect) <*> pure Nothing <*> pure Nothing <*> pure Nothing++-- ** selectWithParens+-------------------------++selectWithParens = sized $ \ _size -> if _size <= 1+ then discard+ else frequency [+ (95, NoParensSelectWithParens <$> selectNoParens)+ ,+ (5, WithParensSelectWithParens <$> selectWithParens)+ ]++terminalSelectWithParens = NoParensSelectWithParens <$> terminalSelectNoParens++-- ** selectClause+-------------------------++selectClause = choice [+ Left <$> simpleSelect,+ Right <$> small selectWithParens+ ]++nonTrailingSelectClause = Left <$> nonTrailingSimpleSelect++-- ** simpleSelect+-------------------------++simpleSelect = choice [+ normalSimpleSelect,+ tableSimpleSelect,+ valuesSimpleSelect,+ small nonTrailingSelectClause >>= binSimpleSelect+ ]++nonTrailingSimpleSelect = choice [normalSimpleSelect, valuesSimpleSelect, tableSimpleSelect]++normalSimpleSelect = NormalSimpleSelect <$> maybe targeting <*> maybe intoClause <*> maybe fromClause <*> maybe whereClause <*> maybe groupClause <*> maybe havingClause <*> maybe windowClause++tableSimpleSelect = TableSimpleSelect <$> relationExpr++valuesSimpleSelect = ValuesSimpleSelect <$> valuesClause++binSimpleSelect _leftSelect = + BinSimpleSelect <$> selectBinOp <*> pure _leftSelect <*> maybe allOrDistinct <*> small selectClause++terminalSimpleSelect = pure (NormalSimpleSelect Nothing Nothing Nothing Nothing Nothing Nothing Nothing)+++-- * Targeting+-------------------------++targeting = choice [+ NormalTargeting <$> targetList,+ AllTargeting <$> maybe targetList,+ DistinctTargeting <$> maybe (nonEmpty (Range.exponential 1 8) aExpr) <*> targetList+ ]++targetList = nonEmpty (Range.exponential 1 8) targetEl++targetEl = choice [+ pure AsteriskTargetEl,+ AliasedExprTargetEl <$> aExpr <*> colLabel,+ ImplicitlyAliasedExprTargetEl <$> prefixAExpr <*> ident,+ ExprTargetEl <$> aExpr+ ]+++-- * BinSimpleSelect+-------------------------++selectBinOp = element [UnionSelectBinOp, IntersectSelectBinOp, ExceptSelectBinOp]+++-- * With Clause+-------------------------++withClause = WithClause <$> bool <*> nonEmpty (Range.exponential 1 7) commonTableExpr++commonTableExpr = CommonTableExpr <$> name <*> maybe (nonEmpty (Range.exponential 1 8) name) <*> maybe bool <*> small preparableStmt+++-- * Into Clause+-------------------------++intoClause = optTempTableName++optTempTableName = choice [+ TemporaryOptTempTableName <$> bool <*> qualifiedName,+ TempOptTempTableName <$> bool <*> qualifiedName,+ LocalTemporaryOptTempTableName <$> bool <*> qualifiedName,+ LocalTempOptTempTableName <$> bool <*> qualifiedName,+ GlobalTemporaryOptTempTableName <$> bool <*> qualifiedName,+ GlobalTempOptTempTableName <$> bool <*> qualifiedName,+ UnloggedOptTempTableName <$> bool <*> qualifiedName,+ TableOptTempTableName <$> qualifiedName,+ QualifedOptTempTableName <$> qualifiedName+ ]+++-- * From Clause+-------------------------++fromList = nonEmpty (Range.exponential 1 8) tableRef++fromClause = fromList++tableRef = choice [relationExprTableRef, selectTableRef, joinTableRef]++relationExprTableRef = RelationExprTableRef <$> relationExpr <*> maybe aliasClause <*> maybe tablesampleClause++funcTableRef = FuncTableRef <$> bool <*> funcTable <*> maybe funcAliasClause++selectTableRef = SelectTableRef <$> bool <*> small selectWithParens <*> maybe aliasClause++joinTableRef = JoinTableRef <$> joinedTable <*> maybe aliasClause++relationExpr = choice [+ SimpleRelationExpr <$> qualifiedName <*> bool,+ OnlyRelationExpr <$> qualifiedName <*> bool+ ]++relationExprOptAlias = RelationExprOptAlias <$> relationExpr <*> maybe ((,) <$> bool <*> colId)++tablesampleClause = TablesampleClause <$> funcName <*> exprList <*> maybe repeatableClause++repeatableClause = aExpr++funcTable = choice [+ FuncExprFuncTable <$> funcExprWindowless <*> optOrdinality,+ RowsFromFuncTable <$> rowsfromList <*> optOrdinality+ ]++rowsfromItem = RowsfromItem <$> funcExprWindowless <*> maybe colDefList++rowsfromList = nonEmpty (Range.exponential 1 8) rowsfromItem++colDefList = tableFuncElementList++optOrdinality = bool++tableFuncElementList = nonEmpty (Range.exponential 1 7) tableFuncElement++tableFuncElement = TableFuncElement <$> colId <*> typename <*> maybe collateClause++collateClause = anyName++aliasClause = AliasClause <$> bool <*> name <*> maybe (nonEmpty (Range.exponential 1 8) name)++funcAliasClause = choice [+ AliasFuncAliasClause <$> aliasClause,+ AsFuncAliasClause <$> tableFuncElementList,+ AsColIdFuncAliasClause <$> colId <*> tableFuncElementList,+ ColIdFuncAliasClause <$> colId <*> tableFuncElementList+ ]++joinedTable = frequency [+ (5,) $ InParensJoinedTable <$> joinedTable,+ (95,) $ MethJoinedTable <$> joinMeth <*> choice [relationExprTableRef, selectTableRef, funcTableRef] <*> tableRef+ ]++joinMeth = choice [+ pure CrossJoinMeth,+ QualJoinMeth <$> maybe joinType <*> joinQual,+ NaturalJoinMeth <$> maybe joinType+ ]++joinType = choice [+ FullJoinType <$> bool,+ LeftJoinType <$> bool,+ RightJoinType <$> bool,+ pure InnerJoinType+ ]++joinQual = choice [+ UsingJoinQual <$> nonEmpty (Range.exponential 1 8) name,+ OnJoinQual <$> aExpr+ ]+++-- * Group Clause+-------------------------++groupClause = nonEmpty (Range.exponential 1 8) groupByItem++groupByItem = choice [+ ExprGroupByItem <$> aExpr,+ pure EmptyGroupingSetGroupByItem,+ RollupGroupByItem <$> nonEmpty (Range.exponential 1 8) aExpr,+ CubeGroupByItem <$> nonEmpty (Range.exponential 1 8) aExpr,+ GroupingSetsGroupByItem <$> nonEmpty (Range.exponential 1 3) groupByItem+ ]+++-- * Having Clause+-------------------------++havingClause = aExpr+++-- * Where Clause+-------------------------++whereClause = aExpr++whereOrCurrentClause = choice [+ ExprWhereOrCurrentClause <$> aExpr,+ CursorWhereOrCurrentClause <$> cursorName+ ]+++-- * Window Clause+-------------------------++windowClause = nonEmpty (Range.exponential 1 8) windowDefinition++windowDefinition = WindowDefinition <$> name <*> windowSpecification++windowSpecification = WindowSpecification <$> maybe name <*> maybe (nonEmpty (Range.exponential 1 8) nonSuffixOpAExpr) <*> maybe sortClause <*> maybe frameClause++frameClause = FrameClause <$> frameClauseMode <*> frameExtent <*> maybe windowExclusionClause++frameClauseMode = element [RangeFrameClauseMode, RowsFrameClauseMode, GroupsFrameClauseMode]++frameExtent = choice [+ SingularFrameExtent <$> frameBound,+ BetweenFrameExtent <$> frameBound <*> frameBound+ ]++frameBound = choice [+ pure UnboundedPrecedingFrameBound,+ pure UnboundedFollowingFrameBound,+ pure CurrentRowFrameBound,+ PrecedingFrameBound <$> prefixAExpr,+ FollowingFrameBound <$> prefixAExpr+ ]++windowExclusionClause = element [CurrentRowWindowExclusionClause, GroupWindowExclusionClause, TiesWindowExclusionClause, NoOthersWindowExclusionClause]+++-- * Values Clause+-------------------------++valuesClause = nonEmpty (Range.exponential 1 8) (nonEmpty (Range.exponential 1 8) aExpr)+++-- * Sort Clause+-------------------------++sortClause = nonEmpty (Range.exponential 1 8) sortBy++sortBy = choice [+ UsingSortBy <$> nonSuffixOpAExpr <*> qualAllOp <*> maybe nullsOrder,+ AscDescSortBy <$> nonSuffixOpAExpr <*> maybe ascDesc <*> maybe nullsOrder+ ]+++-- * All or distinct+-------------------------++allOrDistinct = bool+++-- * Limit+-------------------------++selectLimit = choice [+ LimitOffsetSelectLimit <$> limitClause <*> offsetClause,+ OffsetLimitSelectLimit <$> offsetClause <*> limitClause,+ LimitSelectLimit <$> limitClause,+ OffsetSelectLimit <$> offsetClause+ ]++limitClause = choice [+ LimitLimitClause <$> selectLimitValue <*> maybe aExpr,+ FetchOnlyLimitClause <$> bool <*> maybe selectFetchFirstValue <*> bool+ ]++selectFetchFirstValue = choice [+ ExprSelectFetchFirstValue <$> cExpr,+ NumSelectFetchFirstValue <$> bool <*> iconstOrFconst+ ]++selectLimitValue = choice [+ ExprSelectLimitValue <$> aExpr,+ pure AllSelectLimitValue+ ]++offsetClause = choice [+ ExprOffsetClause <$> aExpr,+ FetchFirstOffsetClause <$> selectFetchFirstValue <*> bool+ ]+++-- * For Locking+-------------------------++forLockingClause = choice [+ ItemsForLockingClause <$> nonEmpty (Range.exponential 1 8) forLockingItem,+ pure ReadOnlyForLockingClause+ ]++forLockingItem = ForLockingItem <$> forLockingStrength <*> maybe (nonEmpty (Range.exponential 1 8) qualifiedName) <*> maybe bool++forLockingStrength = element [+ UpdateForLockingStrength,+ NoKeyUpdateForLockingStrength,+ ShareForLockingStrength,+ KeyForLockingStrength+ ]+++-- * Expressions+-------------------------++exprList = nonEmpty (Range.exponential 1 7) aExpr++aExpr = recursive choice [+ CExprAExpr <$> cExpr,+ pure DefaultAExpr+ ] [+ TypecastAExpr <$> prefixAExpr <*> typecastTypename,+ CollateAExpr <$> prefixAExpr <*> anyName,+ AtTimeZoneAExpr <$> prefixAExpr <*> aExpr,+ PlusAExpr <$> aExpr,+ MinusAExpr <$> aExpr,+ SymbolicBinOpAExpr <$> prefixAExpr <*> symbolicExprBinOp <*> aExpr,+ PrefixQualOpAExpr <$> qualOp <*> aExpr,+ SuffixQualOpAExpr <$> prefixAExpr <*> qualOp,+ AndAExpr <$> prefixAExpr <*> aExpr,+ OrAExpr <$> prefixAExpr <*> aExpr,+ NotAExpr <$> aExpr,+ VerbalExprBinOpAExpr <$> prefixAExpr <*> bool <*> verbalExprBinOp <*> prefixAExpr <*> maybe aExpr,+ ReversableOpAExpr <$> prefixAExpr <*> bool <*> aExprReversableOp,+ IsnullAExpr <$> prefixAExpr,+ NotnullAExpr <$> prefixAExpr,+ OverlapsAExpr <$> row <*> row,+ SubqueryAExpr <$> prefixAExpr <*> subqueryOp <*> subType <*> choice [Left <$> selectWithParens, Right <$> nonSelectAExpr],+ UniqueAExpr <$> selectWithParens+ ]++prefixAExpr = choice [+ CExprAExpr <$> cExpr,+ pure DefaultAExpr,+ OverlapsAExpr <$> row <*> row,+ UniqueAExpr <$> selectWithParens+ ]++nonSuffixOpAExpr = recursive choice [+ CExprAExpr <$> cExpr,+ pure DefaultAExpr+ ] [+ TypecastAExpr <$> prefixAExpr <*> typecastTypename,+ CollateAExpr <$> prefixAExpr <*> anyName,+ AtTimeZoneAExpr <$> prefixAExpr <*> aExpr,+ PlusAExpr <$> aExpr,+ MinusAExpr <$> aExpr,+ SymbolicBinOpAExpr <$> prefixAExpr <*> symbolicExprBinOp <*> aExpr,+ PrefixQualOpAExpr <$> qualOp <*> aExpr,+ AndAExpr <$> prefixAExpr <*> aExpr,+ OrAExpr <$> prefixAExpr <*> aExpr,+ NotAExpr <$> aExpr,+ VerbalExprBinOpAExpr <$> prefixAExpr <*> bool <*> verbalExprBinOp <*> prefixAExpr <*> maybe aExpr,+ ReversableOpAExpr <$> prefixAExpr <*> bool <*> aExprReversableOp,+ IsnullAExpr <$> prefixAExpr,+ NotnullAExpr <$> prefixAExpr,+ OverlapsAExpr <$> row <*> row,+ SubqueryAExpr <$> prefixAExpr <*> subqueryOp <*> subType <*> choice [Left <$> selectWithParens, Right <$> nonSelectAExpr],+ UniqueAExpr <$> selectWithParens+ ]++nonSelectAExpr = choice [+ TypecastAExpr <$> prefixAExpr <*> typecastTypename,+ CollateAExpr <$> prefixAExpr <*> anyName,+ AtTimeZoneAExpr <$> prefixAExpr <*> aExpr,+ PlusAExpr <$> aExpr,+ MinusAExpr <$> aExpr,+ SymbolicBinOpAExpr <$> prefixAExpr <*> symbolicExprBinOp <*> aExpr,+ PrefixQualOpAExpr <$> qualOp <*> aExpr,+ SuffixQualOpAExpr <$> prefixAExpr <*> qualOp,+ AndAExpr <$> prefixAExpr <*> aExpr,+ OrAExpr <$> prefixAExpr <*> aExpr,+ NotAExpr <$> aExpr,+ VerbalExprBinOpAExpr <$> prefixAExpr <*> bool <*> verbalExprBinOp <*> prefixAExpr <*> maybe aExpr,+ ReversableOpAExpr <$> prefixAExpr <*> bool <*> aExprReversableOp,+ IsnullAExpr <$> prefixAExpr,+ NotnullAExpr <$> prefixAExpr,+ OverlapsAExpr <$> row <*> row,+ SubqueryAExpr <$> prefixAExpr <*> subqueryOp <*> subType <*> choice [Left <$> selectWithParens, Right <$> nonSelectAExpr],+ UniqueAExpr <$> selectWithParens+ ]++bExpr = recursive choice [+ CExprBExpr <$> cExpr+ ] [+ TypecastBExpr <$> prefixBExpr <*> typecastTypename,+ PlusBExpr <$> bExpr,+ MinusBExpr <$> bExpr,+ SymbolicBinOpBExpr <$> prefixBExpr <*> symbolicExprBinOp <*> bExpr,+ QualOpBExpr <$> qualOp <*> bExpr,+ IsOpBExpr <$> prefixBExpr <*> bool <*> bExprIsOp+ ]++prefixBExpr = choice [+ CExprBExpr <$> cExpr+ ]++cExpr = recursive choice [+ ColumnrefCExpr <$> columnref+ ] [+ AexprConstCExpr <$> aexprConst,+ ParamCExpr <$> integral (Range.linear 1 19) <*> maybe indirection,+ InParensCExpr <$> nonSelectAExpr <*> maybe indirection,+ CaseCExpr <$> caseExpr,+ FuncCExpr <$> funcExpr,+ SelectWithParensCExpr <$> selectWithParens <*> maybe indirection,+ ExistsCExpr <$> selectWithParens,+ ArrayCExpr <$> choice [Left <$> selectWithParens, Right <$> arrayExpr],+ ExplicitRowCExpr <$> explicitRow,+ ImplicitRowCExpr <$> implicitRow,+ GroupingCExpr <$> exprList+ ]++-- **+-------------------------++caseExpr = CaseExpr <$> maybe aExpr <*> whenClauseList <*> maybe aExpr++whenClauseList = nonEmpty (Range.exponential 1 7) whenClause++whenClause = WhenClause <$> small aExpr <*> small aExpr++inExpr = choice [+ SelectInExpr <$> selectWithParens,+ ExprListInExpr <$> exprList+ ]++arrayExpr = small $ choice [+ ExprListArrayExpr <$> exprList,+ ArrayExprListArrayExpr <$> arrayExprList,+ pure EmptyArrayExpr+ ]++arrayExprList = nonEmpty (Range.exponential 1 4) arrayExpr++row = choice [+ ExplicitRowRow <$> explicitRow,+ ImplicitRowRow <$> implicitRow+ ]++explicitRow = maybe exprList++implicitRow = ImplicitRow <$> exprList <*> aExpr++-- ** FuncExpr+-------------------------++funcExpr = choice [+ ApplicationFuncExpr <$> funcApplication <*> maybe withinGroupClause <*> maybe filterClause <*> maybe overClause,+ SubexprFuncExpr <$> funcExprCommonSubexpr+ ]++funcExprWindowless = choice [+ ApplicationFuncExprWindowless <$> funcApplication,+ CommonSubexprFuncExprWindowless <$> funcExprCommonSubexpr+ ]++funcApplication = FuncApplication <$> funcName <*> maybe funcApplicationParams++funcApplicationParams = choice [+ NormalFuncApplicationParams <$> maybe allOrDistinct <*> nonEmpty (Range.exponential 1 8) funcArgExpr <*> maybe sortClause,+ VariadicFuncApplicationParams <$> maybe (nonEmpty (Range.exponential 1 8) funcArgExpr) <*> funcArgExpr <*> maybe sortClause,+ pure StarFuncApplicationParams+ ]++funcArgExpr = choice [+ ExprFuncArgExpr <$> small aExpr,+ ColonEqualsFuncArgExpr <$> name <*> small aExpr,+ EqualsGreaterFuncArgExpr <$> name <*> small aExpr+ ]++withinGroupClause = sortClause++filterClause = aExpr++overClause = choice [WindowOverClause <$> windowSpecification, ColIdOverClause <$> colId]++funcExprCommonSubexpr = choice [+ CollationForFuncExprCommonSubexpr <$> aExpr,+ pure CurrentDateFuncExprCommonSubexpr,+ CurrentTimeFuncExprCommonSubexpr <$> maybe iconst,+ CurrentTimestampFuncExprCommonSubexpr <$> maybe iconst,+ LocalTimeFuncExprCommonSubexpr <$> maybe iconst,+ LocalTimestampFuncExprCommonSubexpr <$> maybe iconst,+ pure CurrentRoleFuncExprCommonSubexpr,+ pure CurrentUserFuncExprCommonSubexpr,+ pure SessionUserFuncExprCommonSubexpr,+ pure UserFuncExprCommonSubexpr,+ pure CurrentCatalogFuncExprCommonSubexpr,+ pure CurrentSchemaFuncExprCommonSubexpr,+ CastFuncExprCommonSubexpr <$> aExpr <*> typename,+ ExtractFuncExprCommonSubexpr <$> maybe extractList,+ OverlayFuncExprCommonSubexpr <$> overlayList,+ PositionFuncExprCommonSubexpr <$> maybe positionList,+ SubstringFuncExprCommonSubexpr <$> maybe substrList,+ TreatFuncExprCommonSubexpr <$> aExpr <*> typename,+ TrimFuncExprCommonSubexpr <$> maybe trimModifier <*> trimList,+ NullIfFuncExprCommonSubexpr <$> aExpr <*> aExpr,+ CoalesceFuncExprCommonSubexpr <$> exprList,+ GreatestFuncExprCommonSubexpr <$> exprList,+ LeastFuncExprCommonSubexpr <$> exprList+ ]++extractList = ExtractList <$> extractArg <*> aExpr++extractArg = choice [+ IdentExtractArg <$> ident,+ pure YearExtractArg,+ pure MonthExtractArg,+ pure DayExtractArg,+ pure HourExtractArg,+ pure MinuteExtractArg,+ pure SecondExtractArg,+ SconstExtractArg <$> sconst+ ]++overlayList = OverlayList <$> aExpr <*> overlayPlacing <*> substrFrom <*> maybe substrFor++overlayPlacing = aExpr++positionList = PositionList <$> bExpr <*> bExpr++substrList = choice [+ ExprSubstrList <$> aExpr <*> substrListFromFor,+ ExprListSubstrList <$> exprList+ ]++substrListFromFor = choice [+ FromForSubstrListFromFor <$> substrFrom <*> substrFor,+ ForFromSubstrListFromFor <$> substrFor <*> substrFrom,+ FromSubstrListFromFor <$> substrFrom,+ ForSubstrListFromFor <$> substrFor+ ]++substrFrom = aExpr++substrFor = aExpr++trimModifier = enumBounded++trimList = choice [+ ExprFromExprListTrimList <$> aExpr <*> exprList,+ FromExprListTrimList <$> exprList,+ ExprListTrimList <$> exprList+ ]+++-- * Operators+-------------------------++qualOp = choice [OpQualOp <$> op, OperatorQualOp <$> anyOperator]++qualAllOp = choice [+ AllQualAllOp <$> allOp,+ AnyQualAllOp <$> anyOperator+ ]++op = do+ a <- text (Range.exponential 1 7) (element "+-*/<>=~!@#%^&|`?")+ case Validator.op a of+ Nothing -> return a+ _ -> discard++anyOperator = recursive choice [+ AllOpAnyOperator <$> allOp+ ] [+ QualifiedAnyOperator <$> colId <*> anyOperator+ ]++allOp = choice [OpAllOp <$> op, MathAllOp <$> mathOp]++mathOp = enumBounded++symbolicExprBinOp = choice [+ MathSymbolicExprBinOp <$> mathOp,+ QualSymbolicExprBinOp <$> qualOp+ ]++binOp = element (toList HashSet.symbolicBinOp <> ["AND", "OR", "IS DISTINCT FROM", "IS NOT DISTINCT FROM"])++verbalExprBinOp = enumBounded++aExprReversableOp = choice [+ pure NullAExprReversableOp,+ pure TrueAExprReversableOp,+ pure FalseAExprReversableOp,+ pure UnknownAExprReversableOp,+ DistinctFromAExprReversableOp <$> aExpr,+ OfAExprReversableOp <$> typeList,+ BetweenAExprReversableOp <$> bool <*> bExpr <*> aExpr,+ BetweenSymmetricAExprReversableOp <$> bExpr <*> aExpr,+ InAExprReversableOp <$> inExpr,+ pure DocumentAExprReversableOp+ ]++bExprIsOp = choice [+ DistinctFromBExprIsOp <$> bExpr,+ OfBExprIsOp <$> typeList,+ pure DocumentBExprIsOp+ ]++subqueryOp = choice [+ AllSubqueryOp <$> allOp,+ AnySubqueryOp <$> anyOperator,+ LikeSubqueryOp <$> bool,+ IlikeSubqueryOp <$> bool+ ]+++-- * Constants+-------------------------++aexprConst = choice [+ IAexprConst <$> iconst,+ FAexprConst <$> fconst,+ SAexprConst <$> sconst,+ BAexprConst <$> text (Range.exponential 1 100) (element "01"),+ XAexprConst <$> text (Range.exponential 1 100) (element "0123456789abcdefABCDEF"),+ FuncAexprConst <$> funcName <*> maybe funcConstArgs <*> sconst,+ ConstTypenameAexprConst <$> constTypename <*> sconst,+ StringIntervalAexprConst <$> sconst <*> maybe interval,+ IntIntervalAexprConst <$> integral (Range.exponential 0 2309482309483029) <*> sconst,+ BoolAexprConst <$> bool,+ pure NullAexprConst+ ]++funcConstArgs = FuncConstArgs <$> nonEmpty (Range.exponential 1 7) funcArgExpr <*> maybe sortClause++constTypename = choice [+ NumericConstTypename <$> numeric,+ ConstBitConstTypename <$> constBit,+ ConstCharacterConstTypename <$> constCharacter,+ ConstDatetimeConstTypename <$> constDatetime+ ]++numeric = choice [+ pure IntNumeric,+ pure IntegerNumeric,+ pure SmallintNumeric,+ pure BigintNumeric,+ pure RealNumeric,+ FloatNumeric <$> maybe iconst,+ pure DoublePrecisionNumeric,+ DecimalNumeric <$> maybe (nonEmpty (Range.exponential 1 7) (small aExpr)),+ DecNumeric <$> maybe (nonEmpty (Range.exponential 1 7) (small aExpr)),+ NumericNumeric <$> maybe (nonEmpty (Range.exponential 1 7) (small aExpr)),+ pure BooleanNumeric+ ]++bit = Bit <$> bool <*> maybe (nonEmpty (Range.exponential 1 7) (small aExpr))++constBit = bit++constCharacter = ConstCharacter <$> character <*> maybe iconst++character = choice [+ CharacterCharacter <$> bool,+ CharCharacter <$> bool,+ pure VarcharCharacter,+ NationalCharacterCharacter <$> bool,+ NationalCharCharacter <$> bool,+ NcharCharacter <$> bool+ ]++constDatetime = choice [+ TimestampConstDatetime <$> maybe iconst <*> maybe bool,+ TimeConstDatetime <$> maybe iconst <*> maybe bool+ ]++interval = choice [+ pure YearInterval,+ pure MonthInterval,+ pure DayInterval,+ pure HourInterval,+ pure MinuteInterval,+ SecondInterval <$> intervalSecond,+ pure YearToMonthInterval,+ pure DayToHourInterval,+ pure DayToMinuteInterval,+ DayToSecondInterval <$> intervalSecond,+ pure HourToMinuteInterval,+ HourToSecondInterval <$> intervalSecond,+ MinuteToSecondInterval <$> intervalSecond+ ]++intervalSecond = maybe iconst++sconst = text (Range.exponential 0 1000) unicode++iconstOrFconst = choice [Left <$> iconst <|> Right <$> fconst]++fconst = realFrac_ (Range.exponentialFloat 0 309457394857984375983475943)++iconst = integral (Range.exponential 0 maxBound)+++-- * Types+-------------------------++typecastTypename = TypecastTypename <$> typeName <*> nullable <*> arrayDimensionsAmount <*> nullable++nullable = pure False++arrayDimensionsAmount = int (Range.exponential 0 4)++-- ** Typename+-------------------------++typename = choice [+ ArrayBoundsTypename <$> bool <*> simpleTypename <*> maybe arrayBounds,+ ArrayDimTypename <$> bool <*> simpleTypename <*> maybe iconst+ ]++arrayBounds = nonEmpty (Range.exponential 1 4) (maybe iconst)++simpleTypename = choice [+ GenericTypeSimpleTypename <$> genericType,+ NumericSimpleTypename <$> numeric,+ BitSimpleTypename <$> bit,+ CharacterSimpleTypename <$> character,+ ConstDatetimeSimpleTypename <$> constDatetime,+ ConstIntervalSimpleTypename <$> choice [Left <$> maybe interval, Right <$> iconst]+ ]++genericType = GenericType <$> typeFunctionName <*> maybe attrs <*> maybe typeModifiers++attrs = nonEmpty (Range.exponential 1 10) attrName++typeModifiers = exprList++typeList = nonEmpty (Range.exponential 1 7) typename++subType = enumBounded+++-- * Names+-------------------------++columnref = Columnref <$> colId <*> maybe indirection++keywordNotInSet = \ set -> notInSet set $ do+ a <- element startList+ b <- text (Range.linear 1 29) (element contList)+ return (Text.cons a b)+ where+ startList = "abcdefghijklmnopqrstuvwxyz_" <> List.filter isLower (enumFromTo '\200' '\377')+ contList = startList <> "0123456789$"++ident = identWithSet mempty++typeName = identWithSet HashSet.typeFunctionName++name = identWithSet HashSet.colId++cursorName = name++identWithSet set = frequency [+ (95,) $ UnquotedIdent <$> (keywordNotInSet . HashSet.difference HashSet.keyword) set,+ (5,) $ QuotedIdent <$> text (Range.linear 1 30) quotedChar+ ]++qualifiedName = choice [+ SimpleQualifiedName <$> name,+ IndirectedQualifiedName <$> name <*> indirection+ ]++indirection = nonEmpty (Range.linear 1 3) indirectionEl++indirectionEl = choice [+ AttrNameIndirectionEl <$> name,+ pure AllIndirectionEl,+ ExprIndirectionEl <$> (small aExpr),+ SliceIndirectionEl <$> maybe (small aExpr) <*> maybe (small aExpr)+ ]++quotedChar = filter (not . isControl) unicode++colId = name++colLabel = name++attrName = colLabel++typeFunctionName = name++funcName = choice [+ TypeFuncName <$> typeFunctionName,+ IndirectedFuncName <$> colId <*> indirection+ ]++anyName = AnyName <$> colId <*> maybe attrs+++-- * Indexes+-------------------------++indexParams = nonEmpty (Range.exponential 1 5) indexElem++indexElem = IndexElem <$> indexElemDef <*> maybe collate <*> maybe class_ <*> maybe ascDesc <*> maybe nullsOrder++indexElemDef = choice [+ IdIndexElemDef <$> colId,+ FuncIndexElemDef <$> funcExprWindowless,+ ExprIndexElemDef <$> aExpr+ ]++collate = anyName++class_ = anyName++ascDesc = enumBounded++nullsOrder = enumBounded