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