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