hasql-th 0.4.0.7 → 0.4.0.8
raw patch · 26 files changed
+1279/−7840 lines, 26 filesdep +postgresql-syntaxdep −case-insensitivedep −fast-builderdep −hashabledep ~basedep ~bytestringdep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: postgresql-syntax
Dependencies removed: case-insensitive, fast-builder, hashable, headed-megaparsec, hedgehog, megaparsec, parser-combinators, selective, text-builder, tuple-th, unordered-containers
Dependency ranges changed: base, bytestring, containers, contravariant, foldl, hasql, template-haskell, text, uuid, vector
API changes (from Hackage documentation)
Files
- hasql-th.cabal +9/−69
- library/Hasql/TH.hs +21/−13
- library/Hasql/TH/Construction/Exp.hs +204/−0
- library/Hasql/TH/Exp.hs +0/−238
- library/Hasql/TH/Extraction/ChildExprList.hs +635/−0
- library/Hasql/TH/Extraction/Exp.hs +111/−0
- library/Hasql/TH/Extraction/InputTypeList.hs +53/−0
- library/Hasql/TH/Extraction/OutputTypeList.hs +90/−0
- library/Hasql/TH/Extraction/PlaceholderTypeMap.hs +55/−0
- library/Hasql/TH/Extraction/PrimitiveType.hs +101/−0
- library/Hasql/TH/Extras/HeadedMegaparsec.hs +0/−125
- library/Hasql/TH/Extras/NonEmpty.hs +0/−33
- library/Hasql/TH/Prelude.hs +0/−17
- library/Hasql/TH/Syntax/Ast.hs +0/−2052
- library/Hasql/TH/Syntax/Extraction.hs +0/−104
- library/Hasql/TH/Syntax/HashSet.hs +0/−70
- library/Hasql/TH/Syntax/Parsing.hs +0/−2229
- library/Hasql/TH/Syntax/Predicate.hs +0/−69
- library/Hasql/TH/Syntax/Projections/ChildExprList.hs +0/−638
- library/Hasql/TH/Syntax/Projections/InputTypeList.hs +0/−47
- library/Hasql/TH/Syntax/Projections/OutputTypeList.hs +0/−94
- library/Hasql/TH/Syntax/Projections/PlaceholderTypeMap.hs +0/−55
- library/Hasql/TH/Syntax/Rendering.hs +0/−958
- library/Hasql/TH/Syntax/Validator.hs +0/−48
- test/Main.hs +0/−54
- test/Main/Gen.hs +0/−927
hasql-th.cabal view
@@ -1,5 +1,5 @@ name: hasql-th-version: 0.4.0.7+version: 0.4.0.8 category: Hasql, Database, PostgreSQL, Template Haskell synopsis: Template Haskell utilities for Hasql description:@@ -30,84 +30,24 @@ exposed-modules: Hasql.TH other-modules:- Hasql.TH.Exp- Hasql.TH.Extras.HeadedMegaparsec- Hasql.TH.Extras.NonEmpty+ Hasql.TH.Construction.Exp+ Hasql.TH.Extraction.ChildExprList+ Hasql.TH.Extraction.Exp+ Hasql.TH.Extraction.InputTypeList+ Hasql.TH.Extraction.OutputTypeList+ Hasql.TH.Extraction.PlaceholderTypeMap+ Hasql.TH.Extraction.PrimitiveType 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: 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.4 && <0.5,+ postgresql-syntax >=0.3 && <0.4, template-haskell >=2.8 && <3, template-haskell-compat-v0208 >=0.1.2 && <2, text >=1 && <2,- text-builder >=0.6.6.1 && <0.7,- 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
@@ -107,10 +107,12 @@ import Data.Vector (Vector) import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote-import qualified Hasql.TH.Exp as Exp-import qualified Hasql.TH.Syntax.Extraction as Extraction+import qualified Hasql.TH.Construction.Exp as Exp+import qualified Hasql.TH.Extraction.Exp as ExpExtraction import qualified Data.Text as Text import qualified Data.Text.Encoding as Text+import qualified PostgresqlSyntax.Ast as Ast+import qualified PostgresqlSyntax.Parsing as Parsing -- * Helpers@@ -121,11 +123,18 @@ _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)+expParser :: (Text -> Either Text Exp) -> QuasiQuoter+expParser _parser =+ exp $ \ _inputString -> either (fail . Text.unpack) return $ _parser $ fromString _inputString +expPreparableStmtAstParser :: (Ast.PreparableStmt -> Either Text Exp) -> QuasiQuoter+expPreparableStmtAstParser _parser =+ expParser $ \ _input -> do+ _ast <- first fromString $ Parsing.run (Parsing.atEnd Parsing.preparableStmt) _input+ _parser _ast --- * Statements++-- * Statement ------------------------- {-|@@ -159,12 +168,11 @@ ... | 1 | elect 1- | ^^^^^^-unexpected "elect "+ | ^ ... -} singletonStatement :: QuasiQuoter-singletonStatement = statementExp Exp.singletonStatement Extraction.statement+singletonStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.singleRowResultDecoder) {-| @@@ -179,7 +187,7 @@ ... :: Statement () (Maybe Int16) -} maybeStatement :: QuasiQuoter-maybeStatement = statementExp Exp.maybeStatement Extraction.statement+maybeStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.rowMaybeResultDecoder) {-| @@@ -194,7 +202,7 @@ ... :: Statement () (Vector Int16) -} vectorStatement :: QuasiQuoter-vectorStatement = statementExp Exp.vectorStatement Extraction.statement+vectorStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.rowVectorResultDecoder) {-| @@@ -210,7 +218,7 @@ ... :: Fold Int16 b -> Statement () b -} foldStatement :: QuasiQuoter-foldStatement = statementExp Exp.foldStatement Extraction.statement+foldStatement = expPreparableStmtAstParser ExpExtraction.foldStatement {-| @@@ -226,7 +234,7 @@ ... :: Statement (Text, Text) () -} resultlessStatement :: QuasiQuoter-resultlessStatement = statementExp Exp.resultlessStatement Extraction.rowlessStatement+resultlessStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement (const Exp.noResultResultDecoder)) {-| @@@ -242,7 +250,7 @@ ... :: Statement () Int64 -} rowsAffectedStatement :: QuasiQuoter-rowsAffectedStatement = statementExp Exp.rowsAffectedStatement Extraction.rowlessStatement+rowsAffectedStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement (const Exp.rowsAffectedResultDecoder)) -- * SQL ByteStrings
+ library/Hasql/TH/Construction/Exp.hs view
@@ -0,0 +1,204 @@+{-|+Expression construction.+-}+module Hasql.TH.Construction.Exp where++import Hasql.TH.Prelude hiding (sequence_, string, list)+import Language.Haskell.TH.Syntax+import qualified Hasql.TH.Prelude as Prelude+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Statement as Statement+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Unsafe as ByteString+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Vector.Generic as Vector+import qualified TemplateHaskell.Compat.V0208 as Compat+++-- * Helpers+-------------------------++appList :: Exp -> [Exp] -> Exp+appList = foldl' AppE ++byteString :: ByteString -> Exp+byteString x =+ appList+ (VarE 'unsafeDupablePerformIO)+ [+ appList+ (VarE 'ByteString.unsafePackAddressLen)+ [+ LitE (IntegerL (fromIntegral (ByteString.length x))),+ LitE (StringPrimL (ByteString.unpack x))+ ]+ ]++integral :: Integral a => a -> Exp+integral x = LitE (IntegerL (fromIntegral x))++list :: (a -> Exp) -> [a] -> Exp+list renderer x = ListE (map renderer x)++string :: String -> Exp+string x = LitE (StringL x)++char :: Char -> Exp+char x = LitE (CharL x)++sequence_ :: [Exp] -> Exp+sequence_ = foldl' andThen pureUnit++pureUnit :: Exp+pureUnit = AppE (VarE 'Prelude.pure) (TupE [])++andThen :: Exp -> Exp -> Exp+andThen exp1 exp2 = AppE (AppE (VarE '(*>)) exp1) exp2++tuple :: Int -> Exp+tuple = ConE . tupleDataName++splitTupleAt :: Int -> Int -> Exp+splitTupleAt arity position = let+ nameByIndex index = Name (OccName ('_' : show index)) NameS+ names = enumFromTo 0 (pred arity) & map nameByIndex+ pats = names & map VarP+ pat = TupP pats+ exps = names & map VarE+ body = splitAt position exps & \ (a, b) -> Compat.tupE [Compat.tupE a, Compat.tupE b]+ in LamE [pat] body++{-|+Given a list of divisible functor expressions,+constructs an expression, which composes them together into+a single divisible functor, parameterized by a tuple of according arity.+-}+contrazip :: [Exp] -> Exp+contrazip = \ case+ _head : [] -> _head+ _head : _tail -> appList (VarE 'divide) [splitTupleAt (succ (length _tail)) 1, _head, contrazip _tail]+ [] -> SigE (VarE 'conquer)+ (let+ _fName = mkName "f"+ _fVar = VarT _fName+ in ForallT [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 [])++{-|+Lambda expression, which destructures 'Fold'.+-}+foldLam :: (Exp -> Exp -> Exp -> Exp) -> Exp+foldLam _body = let+ _stepVarName = mkName "step"+ _initVarName = mkName "init"+ _extractVarName = mkName "extract"+ in+ LamE+ [+ ConP 'Fold+ [+ VarP _stepVarName,+ VarP _initVarName,+ VarP _extractVarName+ ]+ ]+ (_body (VarE _stepVarName) (VarE _initVarName) (VarE _extractVarName))+++-- * Statement+-------------------------++statement :: Exp -> Exp -> Exp -> Exp+statement _sql _encoder _decoder =+ appList (ConE 'Statement.Statement) [_sql, _encoder, _decoder, ConE 'True]++noResultResultDecoder :: Exp+noResultResultDecoder = VarE 'Decoders.noResult++rowsAffectedResultDecoder :: Exp+rowsAffectedResultDecoder = VarE 'Decoders.rowsAffected++singleRowResultDecoder :: Exp -> Exp+singleRowResultDecoder = 'Decoders.singleRow & VarE & AppE++rowMaybeResultDecoder :: Exp -> Exp+rowMaybeResultDecoder = AppE (VarE 'Decoders.rowMaybe)++rowVectorResultDecoder :: Exp -> Exp+rowVectorResultDecoder = AppE (VarE 'Decoders.rowVector)++foldStatement :: Exp -> Exp -> Exp -> Exp+foldStatement _sql _encoder _rowDecoder =+ foldLam (\ _step _init _extract -> statement _sql _encoder (foldResultDecoder _step _init _extract _rowDecoder))++foldResultDecoder :: Exp -> Exp -> Exp -> Exp -> Exp+foldResultDecoder _step _init _extract _rowDecoder =+ appList (VarE 'fmap) [_extract, appList (VarE 'Decoders.foldlRows) [_step, _init, _rowDecoder]]++unidimensionalParamEncoder :: Bool -> Exp -> Exp+unidimensionalParamEncoder nullable =+ applyParamToEncoder . applyNullabilityToEncoder nullable++multidimensionalParamEncoder :: Bool -> Int -> Bool -> Exp -> Exp+multidimensionalParamEncoder nullable dimensionality arrayNull =+ applyParamToEncoder . applyNullabilityToEncoder arrayNull . AppE (VarE 'Encoders.array) .+ applyArrayDimensionalityToEncoder dimensionality . applyNullabilityToEncoder nullable++applyParamToEncoder :: Exp -> Exp+applyParamToEncoder = AppE (VarE 'Encoders.param)++applyNullabilityToEncoder :: Bool -> Exp -> Exp+applyNullabilityToEncoder nullable = AppE (VarE (if nullable then 'Encoders.nullable else 'Encoders.nonNullable))++applyArrayDimensionalityToEncoder :: Int -> Exp -> Exp+applyArrayDimensionalityToEncoder levels =+ if levels > 0+ then AppE (AppE (VarE 'Encoders.dimension) (VarE 'Vector.foldl')) . applyArrayDimensionalityToEncoder (pred levels)+ else AppE (VarE 'Encoders.element)++rowDecoder :: [Exp] -> Exp+rowDecoder = cozip++unidimensionalColumnDecoder :: Bool -> Exp -> Exp+unidimensionalColumnDecoder nullable =+ applyColumnToDecoder . applyNullabilityToDecoder nullable++multidimensionalColumnDecoder :: Bool -> Int -> Bool -> Exp -> Exp+multidimensionalColumnDecoder nullable dimensionality arrayNull =+ applyColumnToDecoder . applyNullabilityToDecoder arrayNull . AppE (VarE 'Decoders.array) .+ applyArrayDimensionalityToDecoder dimensionality . applyNullabilityToDecoder nullable++applyColumnToDecoder :: Exp -> Exp+applyColumnToDecoder = AppE (VarE 'Decoders.column)++applyNullabilityToDecoder :: Bool -> Exp -> Exp+applyNullabilityToDecoder nullable = AppE (VarE (if nullable then 'Decoders.nullable else 'Decoders.nonNullable))++applyArrayDimensionalityToDecoder :: Int -> Exp -> Exp+applyArrayDimensionalityToDecoder levels =+ if levels > 0+ then AppE (AppE (VarE 'Decoders.dimension) (VarE 'Vector.replicateM)) . applyArrayDimensionalityToDecoder (pred levels)+ else AppE (VarE 'Decoders.element)
− library/Hasql/TH/Exp.hs
@@ -1,238 +0,0 @@-module Hasql.TH.Exp where--import Hasql.TH.Prelude hiding (sequence_, string, list)-import Language.Haskell.TH.Syntax-import qualified Hasql.TH.Prelude as Prelude-import qualified Hasql.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 TemplateHaskell.Compat.V0208 as Compat----- * Helpers----------------------------appList :: Exp -> [Exp] -> Exp-appList = foldl' AppE --byteString :: ByteString -> Exp-byteString x =- appList- (VarE 'unsafeDupablePerformIO)- [- appList- (VarE 'ByteString.unsafePackAddressLen)- [- LitE (IntegerL (fromIntegral (ByteString.length x))),- LitE (StringPrimL (ByteString.unpack x))- ]- ]--integral :: Integral a => a -> Exp-integral x = LitE (IntegerL (fromIntegral x))--list :: (a -> Exp) -> [a] -> Exp-list renderer x = ListE (map renderer x)--string :: String -> Exp-string x = LitE (StringL x)--char :: Char -> Exp-char x = LitE (CharL x)--sequence_ :: [Exp] -> Exp-sequence_ = foldl' andThen pureUnit--pureUnit :: Exp-pureUnit = AppE (VarE 'Prelude.pure) (TupE [])--andThen :: Exp -> Exp -> Exp-andThen exp1 exp2 = AppE (AppE (VarE '(*>)) exp1) exp2--tuple :: Int -> Exp-tuple = ConE . tupleDataName--splitTupleAt :: Int -> Int -> Exp-splitTupleAt arity position = let- nameByIndex index = Name (OccName ('_' : show index)) NameS- names = enumFromTo 0 (pred arity) & map nameByIndex- pats = names & map VarP- pat = TupP pats- exps = names & map VarE- body = splitAt position exps & \ (a, b) -> Compat.tupE [Compat.tupE a, Compat.tupE b]- in LamE [pat] body--{-|-Given a list of divisible functor expressions,-constructs an expression, which composes them together into-a single divisible functor, parameterized by a tuple of according arity.--}-contrazip :: [Exp] -> Exp-contrazip = \ case- _head : [] -> _head- _head : _tail -> appList (VarE 'divide) [splitTupleAt (succ (length _tail)) 1, _head, contrazip _tail]- [] -> SigE (VarE 'conquer)- (let- _fName = mkName "f"- _fVar = VarT _fName- in ForallT [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 'Vector.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/Extraction/ChildExprList.hs view
@@ -0,0 +1,635 @@+module Hasql.TH.Extraction.ChildExprList where++import Hasql.TH.Prelude hiding (sortBy, bit, fromList)+import PostgresqlSyntax.Ast+++-- * Types+-------------------------++data ChildExpr = AChildExpr AExpr | BChildExpr BExpr | CChildExpr CExpr+ deriving (Show, Eq, Ord)+++-- *+-------------------------++{-|+Dives one level of recursion.+-}+childExpr = \ case+ AChildExpr a -> aChildExpr a+ BChildExpr a -> bChildExpr a+ CChildExpr a -> cChildExpr a++aChildExpr = \ case+ CExprAExpr a -> cChildExpr a+ TypecastAExpr a b -> aExpr a <> typename b+ CollateAExpr a b -> aExpr a <> anyName b+ AtTimeZoneAExpr a b -> aExpr a <> aExpr b+ PlusAExpr a -> aExpr a+ MinusAExpr a -> aExpr a+ SymbolicBinOpAExpr a b c -> aExpr a <> symbolicExprBinOp b <> aExpr c+ PrefixQualOpAExpr a b -> qualOp a <> aExpr b+ SuffixQualOpAExpr a b -> aExpr a <> qualOp b+ AndAExpr a b -> aExpr a <> aExpr b+ OrAExpr a b -> aExpr a <> aExpr b+ NotAExpr a -> aExpr a+ VerbalExprBinOpAExpr a b c d e -> aExpr a <> verbalExprBinOp c <> aExpr d <> foldMap aExpr e+ ReversableOpAExpr a b c -> aExpr a <> aExprReversableOp c+ IsnullAExpr a -> aExpr a+ NotnullAExpr a -> aExpr a+ OverlapsAExpr a b -> row a <> row b+ SubqueryAExpr a b c d -> aExpr a <> subqueryOp b <> subType c <> either selectWithParens aExpr d+ UniqueAExpr a -> selectWithParens a+ DefaultAExpr -> []++bChildExpr = \ case+ CExprBExpr a -> cChildExpr a+ TypecastBExpr a b -> bExpr a <> typename b+ PlusBExpr a -> bExpr a+ MinusBExpr a -> bExpr a+ SymbolicBinOpBExpr a b c -> bExpr a <> symbolicExprBinOp b <> bExpr c+ QualOpBExpr a b -> qualOp a <> bExpr b+ IsOpBExpr a b c -> bExpr a <> bExprIsOp c++cChildExpr = \ case+ ColumnrefCExpr a -> columnref a+ AexprConstCExpr a -> aexprConst a+ ParamCExpr a b -> foldMap indirection b+ InParensCExpr a b -> aExpr a <> foldMap indirection b+ CaseCExpr a -> caseExpr a+ FuncCExpr a -> funcExpr a+ SelectWithParensCExpr a b -> selectWithParens a <> foldMap indirection b+ ExistsCExpr a -> selectWithParens a+ ArrayCExpr a -> either selectWithParens arrayExpr a+ ExplicitRowCExpr a -> explicitRow a+ ImplicitRowCExpr a -> implicitRow a+ GroupingCExpr a -> exprList a+++-- *+-------------------------++preparableStmt = \ case+ SelectPreparableStmt a -> selectStmt a+ InsertPreparableStmt a -> insertStmt a+ UpdatePreparableStmt a -> updateStmt a+ DeletePreparableStmt a -> deleteStmt a+++-- * Insert+-------------------------++insertStmt (InsertStmt a b c d e) =+ foldMap withClause a <>+ insertTarget b <>+ insertRest c <>+ foldMap onConflict d <>+ foldMap returningClause e++insertTarget (InsertTarget a b) = qualifiedName a <> colId b++insertRest = \ case+ SelectInsertRest a b c -> foldMap insertColumnList a <> foldMap overrideKind b <> selectStmt c+ DefaultValuesInsertRest -> []++overrideKind _ = []++insertColumnList = foldMap insertColumnItem++insertColumnItem (InsertColumnItem a b) = colId a <> foldMap indirection b++onConflict (OnConflict a b) = foldMap confExpr a <> onConflictDo b++onConflictDo = \ case+ UpdateOnConflictDo b c -> setClauseList b <> foldMap whereClause c+ NothingOnConflictDo -> []++confExpr = \ case+ WhereConfExpr a b -> indexParams a <> foldMap whereClause b+ ConstraintConfExpr a -> name a++returningClause = targetList+++-- * Update+-------------------------++updateStmt (UpdateStmt a b c d e f) =+ foldMap withClause a <>+ relationExprOptAlias b <>+ setClauseList c <>+ foldMap fromClause d <>+ foldMap whereOrCurrentClause e <>+ foldMap returningClause f++setClauseList = foldMap setClause++setClause = \ case+ TargetSetClause a b -> setTarget a <> aExpr b+ TargetListSetClause a b -> setTargetList a <> aExpr b++setTarget (SetTarget a b) = colId a <> foldMap indirection b++setTargetList = foldMap setTarget+++-- * Delete+-------------------------++deleteStmt (DeleteStmt a b c d e) =+ foldMap withClause a <>+ relationExprOptAlias b <>+ foldMap usingClause c <>+ foldMap whereOrCurrentClause d <>+ foldMap returningClause e++usingClause = fromList+++-- * Select+-------------------------++selectStmt = \ case+ Left a -> selectNoParens a+ Right a -> selectWithParens a++selectNoParens (SelectNoParens a b c d e) =+ foldMap withClause a <>+ selectClause b <>+ foldMap sortClause c <>+ foldMap selectLimit d <>+ foldMap forLockingClause e++selectWithParens = \ case+ NoParensSelectWithParens a -> selectNoParens a+ WithParensSelectWithParens a -> selectWithParens a++withClause (WithClause _ a) = foldMap commonTableExpr a++commonTableExpr (CommonTableExpr a b c d) = preparableStmt d++selectLimit = \ case+ LimitOffsetSelectLimit a b -> limitClause a <> offsetClause b+ OffsetLimitSelectLimit a b -> offsetClause a <> limitClause b+ LimitSelectLimit a -> limitClause a+ OffsetSelectLimit a -> offsetClause a++limitClause = \ case+ LimitLimitClause a b -> selectLimitValue a <> exprList b+ FetchOnlyLimitClause a b c -> foldMap selectFetchFirstValue b++offsetClause = \ case+ ExprOffsetClause a -> aExpr a+ FetchFirstOffsetClause a b -> selectFetchFirstValue a++selectFetchFirstValue = \ case+ ExprSelectFetchFirstValue a -> cExpr a+ NumSelectFetchFirstValue _ _ -> []++selectLimitValue = \ case+ ExprSelectLimitValue a -> aExpr a+ AllSelectLimitValue -> []++forLockingClause = \ case+ ItemsForLockingClause a -> foldMap forLockingItem a+ ReadOnlyForLockingClause -> []++forLockingItem (ForLockingItem a b c) =+ foldMap (foldMap qualifiedName) b++selectClause = either simpleSelect selectWithParens++simpleSelect = \ case+ NormalSimpleSelect a b c d e f g ->+ foldMap targeting a <> foldMap intoClause b <> foldMap fromClause c <>+ foldMap whereClause d <> foldMap groupClause e <> foldMap havingClause f <>+ foldMap windowClause g+ ValuesSimpleSelect a -> valuesClause a+ TableSimpleSelect a -> relationExpr a+ BinSimpleSelect _ a _ b -> selectClause a <> selectClause b++targeting = \ case+ NormalTargeting a -> foldMap targetEl a+ AllTargeting a -> foldMap (foldMap targetEl) a+ DistinctTargeting a b -> foldMap exprList a <> foldMap targetEl b++targetList = foldMap targetEl++targetEl = \ case+ AliasedExprTargetEl a _ -> aExpr a+ ImplicitlyAliasedExprTargetEl a _ -> aExpr a+ ExprTargetEl a -> aExpr a+ AsteriskTargetEl -> []++intoClause = optTempTableName++fromClause = fromList++fromList = foldMap tableRef++whereClause = aExpr++whereOrCurrentClause = \ case+ ExprWhereOrCurrentClause a -> aExpr a+ CursorWhereOrCurrentClause a -> cursorName a++groupClause = foldMap groupByItem++havingClause = aExpr++windowClause = foldMap windowDefinition++valuesClause = foldMap exprList++optTempTableName _ = []++groupByItem = \ case+ ExprGroupByItem a -> aExpr a+ EmptyGroupingSetGroupByItem -> []+ RollupGroupByItem a -> exprList a+ CubeGroupByItem a -> exprList a+ GroupingSetsGroupByItem a -> foldMap groupByItem a++windowDefinition (WindowDefinition _ a) = windowSpecification a++windowSpecification (WindowSpecification _ a b c) = foldMap (foldMap aExpr) a <> foldMap sortClause b <> foldMap frameClause c++frameClause (FrameClause _ a _) = frameExtent a++frameExtent = \ case+ SingularFrameExtent a -> frameBound a+ BetweenFrameExtent a b -> frameBound a <> frameBound b++frameBound = \ case+ UnboundedPrecedingFrameBound -> []+ UnboundedFollowingFrameBound -> []+ CurrentRowFrameBound -> []+ PrecedingFrameBound a -> aExpr a+ FollowingFrameBound a -> aExpr a++sortClause = foldMap sortBy++sortBy = \ case+ UsingSortBy a b c -> aExpr a <> qualAllOp b <> foldMap nullsOrder c+ AscDescSortBy a b c -> aExpr a <> foldMap ascDesc b <> foldMap nullsOrder c+++-- * Table refs+-------------------------++tableRef = \ case+ RelationExprTableRef a b c -> relationExpr a <> foldMap aliasClause b <> foldMap tablesampleClause c+ FuncTableRef a b c -> funcTable b <> foldMap funcAliasClause c+ SelectTableRef _ a _ -> selectWithParens a+ JoinTableRef a _ -> joinedTable a++relationExpr = \ case+ SimpleRelationExpr a _ -> qualifiedName a+ OnlyRelationExpr a _ -> qualifiedName a++relationExprOptAlias (RelationExprOptAlias a b) = relationExpr a <> foldMap (colId . snd) b++tablesampleClause (TablesampleClause a b c) = funcName a <> exprList b <> foldMap repeatableClause c++repeatableClause = aExpr++funcTable = \ case+ FuncExprFuncTable a b -> funcExprWindowless a <> optOrdinality b+ RowsFromFuncTable a b -> rowsfromList a <> optOrdinality b++rowsfromItem (RowsfromItem a b) = funcExprWindowless a <> foldMap colDefList b++rowsfromList = foldMap rowsfromItem++colDefList = tableFuncElementList++optOrdinality = const []++tableFuncElementList = foldMap tableFuncElement++tableFuncElement (TableFuncElement a b c) = colId a <> typename b <> foldMap collateClause c++collateClause = anyName++aliasClause = const []++funcAliasClause = \ case+ AliasFuncAliasClause a -> aliasClause a+ AsFuncAliasClause a -> tableFuncElementList a+ AsColIdFuncAliasClause a b -> colId a <> tableFuncElementList b+ ColIdFuncAliasClause a b -> colId a <> tableFuncElementList b++joinedTable = \ case+ InParensJoinedTable a -> joinedTable a+ MethJoinedTable a b c -> joinMeth a <> tableRef b <> tableRef c++joinMeth = \ case+ CrossJoinMeth -> []+ QualJoinMeth _ a -> joinQual a+ NaturalJoinMeth _ -> []++joinQual = \ case+ UsingJoinQual _ -> []+ OnJoinQual a -> aExpr a+++-- *+-------------------------++exprList = fmap AChildExpr . toList++aExpr = pure . AChildExpr+bExpr = pure . BChildExpr+cExpr = pure . CChildExpr++funcExpr = \ case+ ApplicationFuncExpr a b c d -> funcApplication a <> foldMap withinGroupClause b <> foldMap filterClause c <> foldMap overClause d+ SubexprFuncExpr a -> funcExprCommonSubexpr a++funcExprWindowless = \ case+ ApplicationFuncExprWindowless a -> funcApplication a+ CommonSubexprFuncExprWindowless a -> funcExprCommonSubexpr a++withinGroupClause = sortClause++filterClause a = aExpr a++overClause = \ case+ WindowOverClause a -> windowSpecification a+ ColIdOverClause _ -> []++funcExprCommonSubexpr = \ case+ CollationForFuncExprCommonSubexpr a -> aExpr a+ CurrentDateFuncExprCommonSubexpr -> []+ CurrentTimeFuncExprCommonSubexpr _ -> []+ CurrentTimestampFuncExprCommonSubexpr _ -> []+ LocalTimeFuncExprCommonSubexpr _ -> []+ LocalTimestampFuncExprCommonSubexpr _ -> []+ CurrentRoleFuncExprCommonSubexpr -> []+ CurrentUserFuncExprCommonSubexpr -> []+ SessionUserFuncExprCommonSubexpr -> []+ UserFuncExprCommonSubexpr -> []+ CurrentCatalogFuncExprCommonSubexpr -> []+ CurrentSchemaFuncExprCommonSubexpr -> []+ CastFuncExprCommonSubexpr a b -> aExpr a <> typename b+ ExtractFuncExprCommonSubexpr a -> foldMap extractList a+ OverlayFuncExprCommonSubexpr a -> overlayList a+ PositionFuncExprCommonSubexpr a -> foldMap positionList a+ SubstringFuncExprCommonSubexpr a -> foldMap substrList a+ TreatFuncExprCommonSubexpr a b -> aExpr a <> typename b+ TrimFuncExprCommonSubexpr a b -> foldMap trimModifier a <> trimList b+ NullIfFuncExprCommonSubexpr a b -> aExpr a <> aExpr b+ CoalesceFuncExprCommonSubexpr a -> exprList a+ GreatestFuncExprCommonSubexpr a -> exprList a+ LeastFuncExprCommonSubexpr a -> exprList a++extractList (ExtractList a b) = extractArg a <> aExpr b++extractArg _ = []++overlayList (OverlayList a b c d) = foldMap aExpr ([a, b, c] <> toList d)++positionList (PositionList a b) = bExpr a <> bExpr b++substrList = \ case+ ExprSubstrList a b -> aExpr a <> substrListFromFor b+ ExprListSubstrList a -> exprList a++substrListFromFor = \ case+ FromForSubstrListFromFor a b -> aExpr a <> aExpr b+ ForFromSubstrListFromFor a b -> aExpr a <> aExpr b+ FromSubstrListFromFor a -> aExpr a+ ForSubstrListFromFor a -> aExpr a++trimModifier _ = []++trimList = \ case+ ExprFromExprListTrimList a b -> aExpr a <> exprList b+ FromExprListTrimList a -> exprList a+ ExprListTrimList a -> exprList a ++whenClause (WhenClause a b) = aExpr a <> aExpr b++funcApplication (FuncApplication a b) = funcName a <> foldMap funcApplicationParams b++funcApplicationParams = \ case+ NormalFuncApplicationParams _ a b -> foldMap funcArgExpr a <> foldMap (foldMap sortBy) b+ VariadicFuncApplicationParams a b c -> foldMap (foldMap funcArgExpr) a <> funcArgExpr b <> foldMap (foldMap sortBy) c+ StarFuncApplicationParams -> []++funcArgExpr = \ case+ ExprFuncArgExpr a -> aExpr a+ ColonEqualsFuncArgExpr _ a -> aExpr a+ EqualsGreaterFuncArgExpr _ a -> aExpr a++caseExpr (CaseExpr a b c) = foldMap aExpr a <> whenClauseList b <> foldMap aExpr c++whenClauseList = foldMap whenClause++arrayExpr = \ case+ ExprListArrayExpr a -> exprList a+ ArrayExprListArrayExpr a -> arrayExprList a+ EmptyArrayExpr -> []++arrayExprList = foldMap arrayExpr++inExpr = \ case+ SelectInExpr a -> selectWithParens a+ ExprListInExpr a -> exprList a+++-- * Operators+-------------------------++symbolicExprBinOp = \ case+ MathSymbolicExprBinOp a -> mathOp a+ QualSymbolicExprBinOp a -> qualOp a++qualOp = \ case+ OpQualOp a -> op a+ OperatorQualOp a -> anyOperator a++qualAllOp = \ case+ AllQualAllOp a -> allOp a+ AnyQualAllOp a -> anyOperator a++verbalExprBinOp = const []++aExprReversableOp = \ case+ NullAExprReversableOp -> []+ TrueAExprReversableOp -> []+ FalseAExprReversableOp -> []+ UnknownAExprReversableOp -> []+ DistinctFromAExprReversableOp a -> aExpr a+ OfAExprReversableOp a -> typeList a+ BetweenAExprReversableOp a b c -> bExpr b <> aExpr c+ BetweenSymmetricAExprReversableOp a b -> bExpr a <> aExpr b+ InAExprReversableOp a -> inExpr a+ DocumentAExprReversableOp -> []++subqueryOp = \ case+ AllSubqueryOp a -> allOp a+ AnySubqueryOp a -> anyOperator a+ LikeSubqueryOp _ -> []+ IlikeSubqueryOp _ -> []++bExprIsOp = \ case+ DistinctFromBExprIsOp a -> bExpr a+ OfBExprIsOp a -> typeList a+ DocumentBExprIsOp -> []++allOp = \ case+ OpAllOp a -> op a+ MathAllOp a -> mathOp a++anyOperator = \ case+ AllOpAnyOperator a -> allOp a+ QualifiedAnyOperator a b -> colId a <> anyOperator b++op = const []++mathOp = const []+++-- * Rows+-------------------------++row = \ case+ ExplicitRowRow a -> explicitRow a+ ImplicitRowRow a -> implicitRow a++explicitRow = foldMap exprList++implicitRow (ImplicitRow a b) = exprList a <> aExpr b+++-- * Constants+-------------------------++aexprConst = \ case+ IAexprConst _ -> []+ FAexprConst _ -> []+ SAexprConst _ -> []+ BAexprConst _ -> []+ XAexprConst _ -> []+ FuncAexprConst a b _ -> funcName a <> foldMap funcConstArgs b+ ConstTypenameAexprConst a _ -> constTypename a+ StringIntervalAexprConst _ a -> foldMap interval a+ IntIntervalAexprConst _ _ -> []+ BoolAexprConst _ -> []+ NullAexprConst -> []++funcConstArgs (FuncConstArgs a b) = foldMap funcArgExpr a <> foldMap sortClause b++constTypename = \ case+ NumericConstTypename a -> numeric a+ ConstBitConstTypename a -> constBit a+ ConstCharacterConstTypename a -> constCharacter a+ ConstDatetimeConstTypename a -> constDatetime a++numeric = \ case+ IntNumeric -> []+ IntegerNumeric -> []+ SmallintNumeric -> []+ BigintNumeric -> []+ RealNumeric -> []+ FloatNumeric _ -> []+ DoublePrecisionNumeric -> []+ DecimalNumeric a -> foldMap exprList a+ DecNumeric a -> foldMap exprList a+ NumericNumeric a -> foldMap exprList a+ BooleanNumeric -> []++bit (Bit _ a) = foldMap exprList a++constBit = bit++constCharacter (ConstCharacter _ _) = []++constDatetime _ = []++interval _ = []+++-- * Names+-------------------------++ident _ = []++colId = ident++name = colId++cursorName = name++anyName (AnyName a b) = colId a <> foldMap attrs b++columnref (Columnref a b) = colId a <> foldMap indirection b++funcName = \ case+ TypeFuncName a -> typeFunctionName a+ IndirectedFuncName a b -> colId a <> indirection b++qualifiedName = \ case+ SimpleQualifiedName _ -> []+ IndirectedQualifiedName _ a -> indirection a++indirection = foldMap indirectionEl++indirectionEl = \ case+ AttrNameIndirectionEl _ -> []+ AllIndirectionEl -> []+ ExprIndirectionEl a -> aExpr a+ SliceIndirectionEl a b -> exprList a <> exprList b+++-- * Types+-------------------------++typeList = foldMap typename++typename (Typename a b c d) =+ simpleTypename b++simpleTypename = \ case+ GenericTypeSimpleTypename a -> genericType a+ NumericSimpleTypename a -> numeric a+ BitSimpleTypename a -> bit a+ CharacterSimpleTypename a -> character a+ ConstDatetimeSimpleTypename a -> constDatetime a+ ConstIntervalSimpleTypename a -> either (foldMap interval) (const []) a++arrayBounds _ = []++genericType (GenericType a b c) = typeFunctionName a <> foldMap attrs b <> foldMap typeModifiers c++typeFunctionName = ident++attrs = foldMap attrName++attrName _ = []++typeModifiers = exprList++character _ = []++subType _ = []+++-- * Indexes+-------------------------++indexParams = foldMap indexElem++indexElem (IndexElem a b c d e) = indexElemDef a <> foldMap anyName b <> foldMap anyName c++indexElemDef = \ case+ IdIndexElemDef a -> colId a+ FuncIndexElemDef a -> funcExprWindowless a+ ExprIndexElemDef a -> aExpr a++ascDesc = const []++nullsOrder = const []
+ library/Hasql/TH/Extraction/Exp.hs view
@@ -0,0 +1,111 @@+module Hasql.TH.Extraction.Exp where++import Hasql.TH.Prelude+import Language.Haskell.TH+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Decoders as Decoders+import qualified Hasql.TH.Extraction.InputTypeList as InputTypeList+import qualified Hasql.TH.Extraction.OutputTypeList as OutputTypeList+import qualified Hasql.TH.Extraction.PrimitiveType as PrimitiveType+import qualified Hasql.TH.Construction.Exp as Exp+import qualified PostgresqlSyntax.Ast as Ast+import qualified PostgresqlSyntax.Rendering as Rendering+++undecodedStatement :: (Exp -> Exp) -> Ast.PreparableStmt -> Either Text Exp+undecodedStatement _decoderProj _ast = let+ _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast+ in do+ _encoder <- paramsEncoder _ast+ _rowDecoder <- rowDecoder _ast+ return (Exp.statement _sql _encoder (_decoderProj _rowDecoder))++foldStatement :: Ast.PreparableStmt -> Either Text Exp+foldStatement _ast = let+ _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast+ in do+ _encoder <- paramsEncoder _ast+ _rowDecoder <- rowDecoder _ast+ return (Exp.foldStatement _sql _encoder _rowDecoder)++paramsEncoder :: Ast.PreparableStmt -> Either Text Exp+paramsEncoder a = do+ b <- InputTypeList.preparableStmt a+ c <- traverse paramEncoder b+ return (Exp.contrazip c)++rowDecoder :: Ast.PreparableStmt -> Either Text Exp+rowDecoder a = do+ b <- OutputTypeList.preparableStmt a+ c <- traverse columnDecoder b+ return (Exp.cozip c)++paramEncoder :: Ast.Typename -> Either Text Exp+paramEncoder =+ byTypename+ (\ a b -> valueEncoder a & fmap (Exp.unidimensionalParamEncoder b))+ (\ a b c d -> valueEncoder a & fmap (Exp.multidimensionalParamEncoder b c d))++columnDecoder :: Ast.Typename -> Either Text Exp+columnDecoder =+ byTypename+ (\ a b -> valueDecoder a & fmap (Exp.unidimensionalColumnDecoder b))+ (\ a b c d -> valueDecoder a & fmap (Exp.multidimensionalColumnDecoder b c d))++byTypename :: (PrimitiveType.PrimitiveType -> Bool -> Either Text Exp) -> (PrimitiveType.PrimitiveType -> Bool -> Int -> Bool -> Either Text Exp) -> Ast.Typename -> Either Text Exp+byTypename unidimensional multidimensional (Ast.Typename a b c d) =+ if a+ then Left "SETOF is not supported"+ else do+ e <- PrimitiveType.simpleTypename b+ case d of+ Nothing -> unidimensional e c+ Just (f, g) -> case f of+ Ast.BoundsTypenameArrayDimensions h -> multidimensional e c (length h) g+ Ast.ExplicitTypenameArrayDimensions _ -> multidimensional e c 1 g++valueEncoder :: PrimitiveType.PrimitiveType -> Either Text Exp+valueEncoder = Right . VarE . \ case+ PrimitiveType.BoolPrimitiveType -> 'Encoders.bool+ PrimitiveType.Int2PrimitiveType -> 'Encoders.int2+ PrimitiveType.Int4PrimitiveType -> 'Encoders.int4+ PrimitiveType.Int8PrimitiveType -> 'Encoders.int8+ PrimitiveType.Float4PrimitiveType -> 'Encoders.float4+ PrimitiveType.Float8PrimitiveType -> 'Encoders.float8+ PrimitiveType.NumericPrimitiveType -> 'Encoders.numeric+ PrimitiveType.CharPrimitiveType -> 'Encoders.char+ PrimitiveType.TextPrimitiveType -> 'Encoders.text+ PrimitiveType.ByteaPrimitiveType -> 'Encoders.bytea+ PrimitiveType.DatePrimitiveType -> 'Encoders.date+ PrimitiveType.TimestampPrimitiveType -> 'Encoders.timestamp+ PrimitiveType.TimestamptzPrimitiveType -> 'Encoders.timestamptz+ PrimitiveType.TimePrimitiveType -> 'Encoders.time+ PrimitiveType.TimetzPrimitiveType -> 'Encoders.timetz+ PrimitiveType.IntervalPrimitiveType -> 'Encoders.interval+ PrimitiveType.UuidPrimitiveType -> 'Encoders.uuid+ PrimitiveType.InetPrimitiveType -> 'Encoders.inet+ PrimitiveType.JsonPrimitiveType -> 'Encoders.json+ PrimitiveType.JsonbPrimitiveType -> 'Encoders.jsonb++valueDecoder :: PrimitiveType.PrimitiveType -> Either Text Exp+valueDecoder = Right . VarE . \ case+ PrimitiveType.BoolPrimitiveType -> 'Decoders.bool+ PrimitiveType.Int2PrimitiveType -> 'Decoders.int2+ PrimitiveType.Int4PrimitiveType -> 'Decoders.int4+ PrimitiveType.Int8PrimitiveType -> 'Decoders.int8+ PrimitiveType.Float4PrimitiveType -> 'Decoders.float4+ PrimitiveType.Float8PrimitiveType -> 'Decoders.float8+ PrimitiveType.NumericPrimitiveType -> 'Decoders.numeric+ PrimitiveType.CharPrimitiveType -> 'Decoders.char+ PrimitiveType.TextPrimitiveType -> 'Decoders.text+ PrimitiveType.ByteaPrimitiveType -> 'Decoders.bytea+ PrimitiveType.DatePrimitiveType -> 'Decoders.date+ PrimitiveType.TimestampPrimitiveType -> 'Decoders.timestamp+ PrimitiveType.TimestamptzPrimitiveType -> 'Decoders.timestamptz+ PrimitiveType.TimePrimitiveType -> 'Decoders.time+ PrimitiveType.TimetzPrimitiveType -> 'Decoders.timetz+ PrimitiveType.IntervalPrimitiveType -> 'Decoders.interval+ PrimitiveType.UuidPrimitiveType -> 'Decoders.uuid+ PrimitiveType.InetPrimitiveType -> 'Decoders.inet+ PrimitiveType.JsonPrimitiveType -> 'Decoders.json+ PrimitiveType.JsonbPrimitiveType -> 'Decoders.jsonb
+ library/Hasql/TH/Extraction/InputTypeList.hs view
@@ -0,0 +1,53 @@+{-|+AST traversal extracting input types.+-}+module Hasql.TH.Extraction.InputTypeList where++import Hasql.TH.Prelude+import PostgresqlSyntax.Ast+import qualified Hasql.TH.Extraction.PlaceholderTypeMap as PlaceholderTypeMap+import qualified Data.IntMap.Strict as IntMap++{-|+>>> import qualified PostgresqlSyntax.Parsing as P+>>> test = either fail (return . preparableStmt) . P.run P.preparableStmt++>>> test "select $1 :: INT"+Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing]++>>> test "select $1 :: INT, a + $2 :: INTEGER"+Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing,Typename False (NumericSimpleTypename IntegerNumeric) False Nothing]++>>> test "select $1 :: INT4"+Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing]++>>> test "select $1 :: text[]?"+Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) False (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))]++>>> test "select $1 :: text?[]?"+Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) True (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))]++>>> test "select $1"+Left "Placeholder $1 misses an explicit typecast"++>>> test "select $2 :: int4, $1 :: int4, $2 :: int4"+Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing,Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing]++>>> test "select $1 :: int4, $1 :: text"+Left "Placeholder $1 has conflicting type annotations"++>>> test "select $2 :: int4, $2 :: text"+Left "Placeholder $2 has conflicting type annotations"++>>> test "select $3 :: int4, $1 :: int4"+Left "You've missed placeholder $2"++-}+preparableStmt :: PreparableStmt -> Either Text [Typename]+preparableStmt = placeholderTypeMap <=< PlaceholderTypeMap.preparableStmt++placeholderTypeMap :: IntMap Typename -> Either Text [Typename]+placeholderTypeMap a = do+ zipWithM (\ a b -> if a == b then Right () else Left ("You've missed placeholder $" <> showAsText b))+ (IntMap.keys a) [1..]+ return (IntMap.elems a)
+ library/Hasql/TH/Extraction/OutputTypeList.hs view
@@ -0,0 +1,90 @@+{-|+AST traversal extracting output types.+-}+module Hasql.TH.Extraction.OutputTypeList where++import Hasql.TH.Prelude+import PostgresqlSyntax.Ast+++foldable :: Foldable f => (a -> Either Text [Typename]) -> f a -> Either Text [Typename]+foldable fn = fmap join . traverse fn . toList++preparableStmt = \ case+ SelectPreparableStmt a -> selectStmt a+ InsertPreparableStmt a -> insertStmt a+ UpdatePreparableStmt a -> updateStmt a+ DeletePreparableStmt a -> deleteStmt a+++-- * 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/Extraction/PlaceholderTypeMap.hs view
@@ -0,0 +1,55 @@+module Hasql.TH.Extraction.PlaceholderTypeMap where++import Hasql.TH.Prelude hiding (union)+import PostgresqlSyntax.Ast+import Hasql.TH.Extraction.ChildExprList (ChildExpr(..))+import qualified Data.IntMap.Strict as IntMap+import qualified Hasql.TH.Extraction.ChildExprList as ChildExprList+++preparableStmt :: PreparableStmt -> Either Text (IntMap Typename)+preparableStmt = childExprList . ChildExprList.preparableStmt++childExprList :: [ChildExpr] -> Either Text (IntMap Typename)+childExprList = foldM union IntMap.empty <=< traverse childExpr++union :: IntMap Typename -> IntMap Typename -> Either Text (IntMap Typename)+union a b = IntMap.mergeWithKey merge (fmap Right) (fmap Right) a b & sequence where+ merge index a b = if a == b+ then Just (Right a)+ else Just (Left ("Placeholder $" <> (fromString . show) index <> " has conflicting type annotations"))++childExpr :: ChildExpr -> Either Text (IntMap Typename)+childExpr = \ case+ AChildExpr a -> aExpr a+ BChildExpr a -> bExpr a+ CChildExpr a -> cExpr a++aExpr = \ case+ CExprAExpr a -> cExpr a+ TypecastAExpr a b -> castedAExpr b a+ a -> childExprList (ChildExprList.aChildExpr a)++bExpr = \ case+ CExprBExpr a -> cExpr a+ TypecastBExpr a b -> castedBExpr b a+ a -> childExprList (ChildExprList.bChildExpr a)++cExpr = \ case+ ParamCExpr a _ -> Left ("Placeholder $" <> (fromString . show) a <> " misses an explicit typecast")+ a -> childExprList (ChildExprList.cChildExpr a)++castedAExpr a = \ case+ CExprAExpr b -> castedCExpr a b+ TypecastAExpr b c -> castedAExpr c b+ b -> aExpr b++castedBExpr a = \ case+ CExprBExpr b -> castedCExpr a b+ TypecastBExpr b c -> castedBExpr c b+ b -> bExpr b++castedCExpr a = \ case+ ParamCExpr b _ -> Right (IntMap.singleton b a)+ InParensCExpr b _ -> castedAExpr a b+ b -> cExpr b
+ library/Hasql/TH/Extraction/PrimitiveType.hs view
@@ -0,0 +1,101 @@+module Hasql.TH.Extraction.PrimitiveType where++import Hasql.TH.Prelude hiding (sortBy, bit, fromList)+import PostgresqlSyntax.Ast+++data PrimitiveType =+ BoolPrimitiveType |+ Int2PrimitiveType |+ Int4PrimitiveType |+ Int8PrimitiveType |+ Float4PrimitiveType |+ Float8PrimitiveType |+ NumericPrimitiveType |+ CharPrimitiveType |+ TextPrimitiveType |+ ByteaPrimitiveType |+ DatePrimitiveType |+ TimestampPrimitiveType |+ TimestamptzPrimitiveType |+ TimePrimitiveType |+ TimetzPrimitiveType |+ IntervalPrimitiveType |+ UuidPrimitiveType |+ InetPrimitiveType |+ JsonPrimitiveType |+ JsonbPrimitiveType++simpleTypename = \ case+ GenericTypeSimpleTypename a -> genericType a+ NumericSimpleTypename a -> numeric a+ BitSimpleTypename a -> bit a+ CharacterSimpleTypename a -> character a+ ConstDatetimeSimpleTypename a -> constDatetime a+ ConstIntervalSimpleTypename a -> Right IntervalPrimitiveType++genericType (GenericType a b c) = case b of+ Just _ -> Left "Type attributes are not supported"+ Nothing -> case c of+ Just _ -> Left "Type modifiers are not supported"+ Nothing -> ident a++numeric = \ case+ IntNumeric -> Right Int4PrimitiveType+ IntegerNumeric -> Right Int4PrimitiveType+ SmallintNumeric -> Right Int2PrimitiveType+ BigintNumeric -> Right Int8PrimitiveType+ RealNumeric -> Right Float4PrimitiveType+ FloatNumeric a -> case a of+ Just _ -> Left "Modifier on FLOAT is not supported"+ Nothing -> Right Float4PrimitiveType+ DoublePrecisionNumeric -> Right Float8PrimitiveType+ DecimalNumeric a -> case a of+ Just _ -> Left "Modifiers on DECIMAL are not supported"+ Nothing -> Right NumericPrimitiveType+ DecNumeric a -> case a of+ Just _ -> Left "Modifiers on DEC are not supported"+ Nothing -> Right NumericPrimitiveType+ NumericNumeric a -> case a of+ Just _ -> Left "Modifiers on NUMERIC are not supported"+ Nothing -> Right NumericPrimitiveType+ BooleanNumeric -> Right BoolPrimitiveType++bit _ = Left "Bit codec is not supported"++character _ = Right TextPrimitiveType++constDatetime = \ case+ TimestampConstDatetime _ a -> if tz a then Right TimestamptzPrimitiveType else Right TimestampPrimitiveType+ TimeConstDatetime _ a -> if tz a then Right TimetzPrimitiveType else Right TimePrimitiveType+ where+ tz = \ case+ Just a -> a+ Nothing -> False++ident = \ case+ QuotedIdent a -> name a+ UnquotedIdent a -> name a++name = \ case+ "bool" -> Right BoolPrimitiveType+ "int2" -> Right Int2PrimitiveType+ "int4" -> Right Int4PrimitiveType+ "int8" -> Right Int8PrimitiveType+ "float4" -> Right Float4PrimitiveType+ "float8" -> Right Float8PrimitiveType+ "numeric" -> Right NumericPrimitiveType+ "char" -> Right CharPrimitiveType+ "text" -> Right TextPrimitiveType+ "bytea" -> Right ByteaPrimitiveType+ "date" -> Right DatePrimitiveType+ "timestamp" -> Right TimestampPrimitiveType+ "timestamptz" -> Right TimestamptzPrimitiveType+ "time" -> Right TimePrimitiveType+ "timetz" -> Right TimetzPrimitiveType+ "interval" -> Right IntervalPrimitiveType+ "uuid" -> Right UuidPrimitiveType+ "inet" -> Right InetPrimitiveType+ "json" -> Right JsonPrimitiveType+ "jsonb" -> Right JsonbPrimitiveType+ name -> Left ("No codec exists for type: " <> name)
− library/Hasql/TH/Extras/HeadedMegaparsec.hs
@@ -1,125 +0,0 @@-{-|-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
@@ -1,33 +0,0 @@-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
@@ -81,10 +81,6 @@ ------------------------- import Data.Functor.Contravariant.Divisible as Exports --- selective---------------------------import Control.Selective as Exports- -- bytestring ------------------------- import Data.ByteString as Exports (ByteString)@@ -101,15 +97,6 @@ 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(..))@@ -117,10 +104,6 @@ -- uuid ------------------------- import Data.UUID as Exports (UUID)---- case-insensitive---------------------------import Data.CaseInsensitive as Exports (CI, FoldCase) showAsText :: Show a => a -> Text
− library/Hasql/TH/Syntax/Ast.hs
@@ -1,2052 +0,0 @@-{-|-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
@@ -1,104 +0,0 @@-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- 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- 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
@@ -1,70 +0,0 @@-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
@@ -1,2229 +0,0 @@-{-|--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 on (a.i = b.i)"-JoinTableRef (MethJoinedTable (QualJoinMeth...---}-tableRef =- label "table reference" $ - do- _tr <- nonTrailingTableRef- recur _tr- where- recur _tr =- asum [- do- _tr2 <- wrapToHead (space1 *> trailingTableRef _tr)- endHead- recur _tr2- ,- 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 =- head >>= tail- where- head =- asum [- do- _tr <- wrapToHead nonTrailingTableRef- space1- trailingJoinedTable _tr- ,- inParensJoinedTable- ]- tail _jt =- asum [- do- _jt2 <- wrapToHead (space1 *> trailingJoinedTable (JoinTableRef _jt Nothing))- endHead- tail _jt2- ,- pure _jt- ]--{-- | '(' 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 <- nonTrailingTableRef- 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 <- nonTrailingTableRef- 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 <- typecastTypenameBaseIdent- 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)--{-|-A custom derivation from definition of SimpleTypename,-wrapping up to a merger of "type_function_name" and "ConstInterval" and "ConstDatetime".-->>> testParser typecastTypenameBaseIdent "bool"-UnquotedIdent "bool"-->>> testParser typecastTypenameBaseIdent "int2"-UnquotedIdent "int2"-->>> testParser typecastTypenameBaseIdent "int4"-UnquotedIdent "int4"-->>> testParser typecastTypenameBaseIdent "int8"-UnquotedIdent "int8"-->>> testParser typecastTypenameBaseIdent "float4"-UnquotedIdent "float4"-->>> testParser typecastTypenameBaseIdent "float8"-UnquotedIdent "float8"-->>> testParser typecastTypenameBaseIdent "numeric"-UnquotedIdent "numeric"-->>> testParser typecastTypenameBaseIdent "char"-UnquotedIdent "char"-->>> testParser typecastTypenameBaseIdent "text"-UnquotedIdent "text"-->>> testParser typecastTypenameBaseIdent "bytea"-UnquotedIdent "bytea"-->>> testParser typecastTypenameBaseIdent "date"-UnquotedIdent "date"-->>> testParser typecastTypenameBaseIdent "timestamp"-UnquotedIdent "timestamp"-->>> testParser typecastTypenameBaseIdent "timestamptz"-UnquotedIdent "timestamptz"-->>> testParser typecastTypenameBaseIdent "time"-UnquotedIdent "time"-->>> testParser typecastTypenameBaseIdent "timetz"-UnquotedIdent "timetz"-->>> testParser typecastTypenameBaseIdent "interval"-UnquotedIdent "interval"-->>> testParser typecastTypenameBaseIdent "uuid"-UnquotedIdent "uuid"-->>> testParser typecastTypenameBaseIdent "inet"-UnquotedIdent "inet"-->>> testParser typecastTypenameBaseIdent "json"-UnquotedIdent "json"-->>> testParser typecastTypenameBaseIdent "jsonb"-UnquotedIdent "jsonb"--}-typecastTypenameBaseIdent =- ident <|>- keywordNameFromSet set- where- set =- HashSet.unreservedKeyword <> HashSet.typeFuncNameKeyword <>- -- From defs of "ConstInterval", "ConstDatetime" and others from "SimpleTypename":- HashSet.fromList ["interval", "timestamp", "time", "numeric", "char"]----- * 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
@@ -1,69 +0,0 @@-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
@@ -1,638 +0,0 @@-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
@@ -1,47 +0,0 @@-{-|-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
@@ -1,94 +0,0 @@-{-|-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
@@ -1,55 +0,0 @@-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
@@ -1,958 +0,0 @@-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
@@ -1,48 +0,0 @@-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
@@ -1,54 +0,0 @@-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 "Bug-fixes" $ let- parsesFine testName sql =- (,) (testName <> " parses fine") $ property $ test $ do- footnote (Text.unpack sql)- case Parsing.run Parsing.preparableStmt sql of- Left err -> do- footnote err- failure- Right _ -> success- in [- parsesFine "Multiple inner joins"- "select i :: int8 from auth.user as u\n\- \inner join edgenode.usere_provider as p\n\- \on u.id = p.user_id\n\- \inner join edgenode.provider_branch as b\n\- \on b.provider_fk = p.provider_id"- ]- ,- 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
@@ -1,927 +0,0 @@-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 <*> tableRef <*> choice [relationExprTableRef, selectTableRef, funcTableRef]- ]--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,- UniqueAExpr <$> selectWithParens- ]--nonSuffixOpAExpr = recursive choice [- CExprAExpr <$> cExpr,- pure DefaultAExpr- ] [- TypecastAExpr <$> prefixAExpr <*> typecastTypename,- CollateAExpr <$> prefixAExpr <*> anyName,- AtTimeZoneAExpr <$> prefixAExpr <*> nonSuffixOpAExpr,- PlusAExpr <$> nonSuffixOpAExpr,- MinusAExpr <$> nonSuffixOpAExpr,- SymbolicBinOpAExpr <$> prefixAExpr <*> symbolicExprBinOp <*> nonSuffixOpAExpr,- PrefixQualOpAExpr <$> qualOp <*> nonSuffixOpAExpr,- AndAExpr <$> prefixAExpr <*> nonSuffixOpAExpr,- OrAExpr <$> prefixAExpr <*> nonSuffixOpAExpr,- NotAExpr <$> nonSuffixOpAExpr,- VerbalExprBinOpAExpr <$> prefixAExpr <*> bool <*> verbalExprBinOp <*> prefixAExpr <*> maybe nonSuffixOpAExpr,- IsnullAExpr <$> prefixAExpr,- NotnullAExpr <$> prefixAExpr,- 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 <$> NoParensSelectWithParens <$> selectNoParens,- 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