├── cabal.project ├── .github └── workflows │ ├── format.yaml │ ├── on-push-to-master-or-pr.yaml │ ├── on-push-to-release.yaml │ └── check.yaml ├── LICENSE ├── library └── Hasql │ ├── TH │ ├── Extraction │ │ ├── PlaceholderTypeMap.hs │ │ ├── InputTypeList.hs │ │ ├── OutputTypeList.hs │ │ ├── PrimitiveType.hs │ │ ├── Exp.hs │ │ └── ChildExprList.hs │ ├── Prelude.hs │ └── Construction │ │ └── Exp.hs │ └── TH.hs ├── hasql-th.cabal └── README.md /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | allow-newer: 3 | , *:base 4 | , *:template-haskell 5 | , *:ghc-prim 6 | -------------------------------------------------------------------------------- /.github/workflows/format.yaml: -------------------------------------------------------------------------------- 1 | name: Format 2 | 3 | on: 4 | workflow_call: 5 | 6 | jobs: 7 | format: 8 | uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v3 9 | secrets: inherit 10 | -------------------------------------------------------------------------------- /.github/workflows/on-push-to-master-or-pr.yaml: -------------------------------------------------------------------------------- 1 | name: Compile, test and check the docs 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | 9 | jobs: 10 | 11 | format: 12 | uses: ./.github/workflows/format.yaml 13 | secrets: inherit 14 | 15 | check: 16 | uses: ./.github/workflows/check.yaml 17 | secrets: inherit 18 | -------------------------------------------------------------------------------- /.github/workflows/on-push-to-release.yaml: -------------------------------------------------------------------------------- 1 | name: Release the lib to Hackage 2 | 3 | on: 4 | push: 5 | branches: 6 | - supermajor 7 | - major 8 | - minor 9 | - patch 10 | 11 | concurrency: 12 | group: release 13 | cancel-in-progress: true 14 | 15 | jobs: 16 | 17 | format: 18 | uses: ./.github/workflows/format.yaml 19 | secrets: inherit 20 | 21 | check: 22 | uses: ./.github/workflows/check.yaml 23 | secrets: inherit 24 | 25 | release: 26 | needs: 27 | - format 28 | - check 29 | uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/release.yaml@v3 30 | secrets: inherit 31 | with: 32 | prefix-tag-with-v: false 33 | docs: true 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Nikita Volkov 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /.github/workflows/check.yaml: -------------------------------------------------------------------------------- 1 | name: Compile, test and check the docs 2 | 3 | on: 4 | workflow_call: 5 | 6 | jobs: 7 | 8 | check: 9 | 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | include: 14 | - ghc: 8.10.1 15 | ghc-options: "" 16 | ignore-haddock: true 17 | ignore-cabal-check: true 18 | - ghc: latest 19 | ignore-cabal-check: true 20 | 21 | runs-on: ubuntu-latest 22 | 23 | services: 24 | postgres: 25 | image: postgres 26 | env: 27 | POSTGRES_USER: postgres 28 | POSTGRES_DB: postgres 29 | POSTGRES_PASSWORD: postgres 30 | ports: 31 | - 5432:5432 32 | options: >- 33 | --health-cmd pg_isready 34 | --health-interval 10s 35 | --health-timeout 5s 36 | --health-retries 5 37 | 38 | steps: 39 | 40 | - uses: nikita-volkov/build-and-test-cabal-package.github-action@v1 41 | with: 42 | ghc: ${{matrix.ghc}} 43 | ghc-options: ${{matrix.ghc-options}} 44 | ignore-haddock: ${{matrix.ignore-haddock}} 45 | ignore-cabal-check: ${{matrix.ignore-cabal-check}} 46 | -------------------------------------------------------------------------------- /library/Hasql/TH/Extraction/PlaceholderTypeMap.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | module Hasql.TH.Extraction.PlaceholderTypeMap where 4 | 5 | import qualified Data.IntMap.Strict as IntMap 6 | import Hasql.TH.Extraction.ChildExprList (ChildExpr (..)) 7 | import qualified Hasql.TH.Extraction.ChildExprList as ChildExprList 8 | import Hasql.TH.Prelude hiding (union) 9 | import PostgresqlSyntax.Ast 10 | 11 | preparableStmt :: PreparableStmt -> Either Text (IntMap Typename) 12 | preparableStmt = childExprList . ChildExprList.preparableStmt 13 | 14 | childExprList :: [ChildExpr] -> Either Text (IntMap Typename) 15 | childExprList = foldM union IntMap.empty <=< traverse childExpr 16 | 17 | union :: IntMap Typename -> IntMap Typename -> Either Text (IntMap Typename) 18 | union a b = IntMap.mergeWithKey merge (fmap Right) (fmap Right) a b & sequence 19 | where 20 | merge index a b = 21 | if a == b 22 | then Just (Right a) 23 | else Just (Left ("Placeholder $" <> (fromString . show) index <> " has conflicting type annotations")) 24 | 25 | childExpr :: ChildExpr -> Either Text (IntMap Typename) 26 | childExpr = \case 27 | AChildExpr a -> aExpr a 28 | BChildExpr a -> bExpr a 29 | CChildExpr a -> cExpr a 30 | 31 | aExpr = \case 32 | CExprAExpr a -> cExpr a 33 | TypecastAExpr a b -> castedAExpr b a 34 | a -> childExprList (ChildExprList.aChildExpr a) 35 | 36 | bExpr = \case 37 | CExprBExpr a -> cExpr a 38 | TypecastBExpr a b -> castedBExpr b a 39 | a -> childExprList (ChildExprList.bChildExpr a) 40 | 41 | cExpr = \case 42 | ParamCExpr a _ -> Left ("Placeholder $" <> (fromString . show) a <> " misses an explicit typecast") 43 | a -> childExprList (ChildExprList.cChildExpr a) 44 | 45 | castedAExpr a = \case 46 | CExprAExpr b -> castedCExpr a b 47 | TypecastAExpr b c -> castedAExpr c b 48 | b -> aExpr b 49 | 50 | castedBExpr a = \case 51 | CExprBExpr b -> castedCExpr a b 52 | TypecastBExpr b c -> castedBExpr c b 53 | b -> bExpr b 54 | 55 | castedCExpr a = \case 56 | ParamCExpr b _ -> Right (IntMap.singleton b a) 57 | InParensCExpr b _ -> castedAExpr a b 58 | b -> cExpr b 59 | -------------------------------------------------------------------------------- /library/Hasql/TH/Extraction/InputTypeList.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- AST traversal extracting input types. 3 | module Hasql.TH.Extraction.InputTypeList where 4 | 5 | import qualified Data.IntMap.Strict as IntMap 6 | import qualified Hasql.TH.Extraction.PlaceholderTypeMap as PlaceholderTypeMap 7 | import Hasql.TH.Prelude 8 | import PostgresqlSyntax.Ast 9 | 10 | -- | 11 | -- >>> import qualified PostgresqlSyntax.Parsing as P 12 | -- >>> test = either fail (return . preparableStmt) . P.run P.preparableStmt 13 | -- 14 | -- >>> test "select $1 :: INT" 15 | -- Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing] 16 | -- 17 | -- >>> test "select $1 :: INT, a + $2 :: INTEGER" 18 | -- Right [Typename False (NumericSimpleTypename IntNumeric) False Nothing,Typename False (NumericSimpleTypename IntegerNumeric) False Nothing] 19 | -- 20 | -- >>> test "select $1 :: INT4" 21 | -- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing] 22 | -- 23 | -- >>> test "select $1 :: text[]?" 24 | -- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) False (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))] 25 | -- 26 | -- >>> test "select $1 :: text?[]?" 27 | -- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "text") Nothing Nothing)) True (Just (BoundsTypenameArrayDimensions (Nothing :| []),True))] 28 | -- 29 | -- >>> test "select $1" 30 | -- Left "Placeholder $1 misses an explicit typecast" 31 | -- 32 | -- >>> test "select $2 :: int4, $1 :: int4, $2 :: int4" 33 | -- Right [Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing,Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing] 34 | -- 35 | -- >>> test "select $1 :: int4, $1 :: text" 36 | -- Left "Placeholder $1 has conflicting type annotations" 37 | -- 38 | -- >>> test "select $2 :: int4, $2 :: text" 39 | -- Left "Placeholder $2 has conflicting type annotations" 40 | -- 41 | -- >>> test "select $3 :: int4, $1 :: int4" 42 | -- Left "You've missed placeholder $2" 43 | preparableStmt :: PreparableStmt -> Either Text [Typename] 44 | preparableStmt = placeholderTypeMap <=< PlaceholderTypeMap.preparableStmt 45 | 46 | placeholderTypeMap :: IntMap Typename -> Either Text [Typename] 47 | placeholderTypeMap a = do 48 | zipWithM 49 | (\a b -> if a == b then Right () else Left ("You've missed placeholder $" <> showAsText b)) 50 | (IntMap.keys a) 51 | [1 ..] 52 | return (IntMap.elems a) 53 | -------------------------------------------------------------------------------- /hasql-th.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: hasql-th 3 | version: 0.4.0.23 4 | category: Hasql, Database, PostgreSQL, Template Haskell 5 | synopsis: Template Haskell utilities for Hasql 6 | description: 7 | Extension-library for Hasql, 8 | bringing compile-time syntax checking, 9 | great simplification of declaration of statements and 10 | other TemplateHaskell-based utilities. 11 | 12 | For details please see . 13 | 14 | homepage: https://github.com/nikita-volkov/hasql-th 15 | bug-reports: https://github.com/nikita-volkov/hasql-th/issues 16 | author: Nikita Volkov 17 | maintainer: Nikita Volkov 18 | copyright: (c) 2015, Nikita Volkov 19 | license: MIT 20 | license-file: LICENSE 21 | 22 | source-repository head 23 | type: git 24 | location: git://github.com/nikita-volkov/hasql-th.git 25 | 26 | library 27 | hs-source-dirs: library 28 | default-extensions: 29 | ApplicativeDo 30 | Arrows 31 | BangPatterns 32 | ConstraintKinds 33 | DataKinds 34 | DefaultSignatures 35 | DeriveDataTypeable 36 | DeriveFoldable 37 | DeriveFunctor 38 | DeriveGeneric 39 | DeriveTraversable 40 | DuplicateRecordFields 41 | EmptyDataDecls 42 | FlexibleContexts 43 | FlexibleInstances 44 | FunctionalDependencies 45 | GADTs 46 | GeneralizedNewtypeDeriving 47 | LambdaCase 48 | LiberalTypeSynonyms 49 | MagicHash 50 | MultiParamTypeClasses 51 | MultiWayIf 52 | NoImplicitPrelude 53 | NoMonomorphismRestriction 54 | OverloadedStrings 55 | ParallelListComp 56 | PatternGuards 57 | QuasiQuotes 58 | RankNTypes 59 | RecordWildCards 60 | ScopedTypeVariables 61 | StandaloneDeriving 62 | TemplateHaskell 63 | TupleSections 64 | TypeFamilies 65 | TypeOperators 66 | UnboxedTuples 67 | 68 | default-language: Haskell2010 69 | exposed-modules: Hasql.TH 70 | other-modules: 71 | Hasql.TH.Construction.Exp 72 | Hasql.TH.Extraction.ChildExprList 73 | Hasql.TH.Extraction.Exp 74 | Hasql.TH.Extraction.InputTypeList 75 | Hasql.TH.Extraction.OutputTypeList 76 | Hasql.TH.Extraction.PlaceholderTypeMap 77 | Hasql.TH.Extraction.PrimitiveType 78 | Hasql.TH.Prelude 79 | 80 | build-depends: 81 | base >=4.11 && <5, 82 | bytestring >=0.10 && <0.13, 83 | containers >=0.6 && <0.8, 84 | contravariant >=1.5.2 && <2, 85 | foldl >=1.4.5 && <2, 86 | hasql >=1.4 && <1.10, 87 | postgresql-syntax >=0.4.1 && <0.5, 88 | template-haskell >=2.8 && <3, 89 | template-haskell-compat-v0208 >=0.1.9 && <2, 90 | text >=1 && <3, 91 | uuid >=1.3 && <2, 92 | vector >=0.12 && <0.14, 93 | -------------------------------------------------------------------------------- /library/Hasql/TH/Extraction/OutputTypeList.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | -- | 4 | -- AST traversal extracting output types. 5 | module Hasql.TH.Extraction.OutputTypeList where 6 | 7 | import Hasql.TH.Prelude 8 | import PostgresqlSyntax.Ast 9 | 10 | foldable :: (Foldable f) => (a -> Either Text [Typename]) -> f a -> Either Text [Typename] 11 | foldable fn = fmap join . traverse fn . toList 12 | 13 | preparableStmt = \case 14 | SelectPreparableStmt a -> selectStmt a 15 | InsertPreparableStmt a -> insertStmt a 16 | UpdatePreparableStmt a -> updateStmt a 17 | DeletePreparableStmt a -> deleteStmt a 18 | CallPreparableStmt a -> callStmt a 19 | 20 | -- * Call 21 | 22 | callStmt (CallStmt a) = 23 | Right [] 24 | 25 | -- * Insert 26 | 27 | insertStmt (InsertStmt a b c d e) = foldable returningClause e 28 | 29 | returningClause = targetList 30 | 31 | -- * Update 32 | 33 | updateStmt (UpdateStmt _ _ _ _ _ a) = foldable returningClause a 34 | 35 | -- * Delete 36 | 37 | deleteStmt (DeleteStmt _ _ _ _ a) = foldable returningClause a 38 | 39 | -- * Select 40 | 41 | selectStmt = \case 42 | Left a -> selectNoParens a 43 | Right a -> selectWithParens a 44 | 45 | selectNoParens (SelectNoParens _ a _ _ _) = selectClause a 46 | 47 | selectWithParens = \case 48 | NoParensSelectWithParens a -> selectNoParens a 49 | WithParensSelectWithParens a -> selectWithParens a 50 | 51 | selectClause = either simpleSelect selectWithParens 52 | 53 | simpleSelect = \case 54 | NormalSimpleSelect a _ _ _ _ _ _ -> foldable targeting a 55 | ValuesSimpleSelect a -> valuesClause a 56 | TableSimpleSelect _ -> Left "TABLE cannot be used as a final statement, since it's impossible to specify the output types" 57 | BinSimpleSelect _ a _ b -> do 58 | c <- selectClause a 59 | d <- selectClause b 60 | if c == d 61 | then return c 62 | else Left "Merged queries produce results of incompatible types" 63 | 64 | targeting = \case 65 | NormalTargeting a -> targetList a 66 | AllTargeting a -> foldable targetList a 67 | DistinctTargeting _ b -> targetList b 68 | 69 | targetList = foldable targetEl 70 | 71 | targetEl = \case 72 | AliasedExprTargetEl a _ -> aExpr a 73 | ImplicitlyAliasedExprTargetEl a _ -> aExpr a 74 | ExprTargetEl a -> aExpr a 75 | AsteriskTargetEl -> 76 | Left 77 | "Target of all fields is not allowed, \ 78 | \because it leaves the output types unspecified. \ 79 | \You have to be specific." 80 | 81 | valuesClause = foldable (foldable aExpr) 82 | 83 | aExpr = \case 84 | CExprAExpr a -> cExpr a 85 | TypecastAExpr _ a -> Right [a] 86 | a -> Left "Result expression is missing a typecast" 87 | 88 | cExpr = \case 89 | InParensCExpr a Nothing -> aExpr a 90 | a -> Left "Result expression is missing a typecast" 91 | -------------------------------------------------------------------------------- /library/Hasql/TH/Extraction/PrimitiveType.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | module Hasql.TH.Extraction.PrimitiveType where 4 | 5 | import Hasql.TH.Prelude hiding (bit, fromList, sortBy) 6 | import PostgresqlSyntax.Ast 7 | 8 | data PrimitiveType 9 | = BoolPrimitiveType 10 | | Int2PrimitiveType 11 | | Int4PrimitiveType 12 | | Int8PrimitiveType 13 | | Float4PrimitiveType 14 | | Float8PrimitiveType 15 | | NumericPrimitiveType 16 | | CharPrimitiveType 17 | | TextPrimitiveType 18 | | ByteaPrimitiveType 19 | | DatePrimitiveType 20 | | TimestampPrimitiveType 21 | | TimestamptzPrimitiveType 22 | | TimePrimitiveType 23 | | TimetzPrimitiveType 24 | | IntervalPrimitiveType 25 | | UuidPrimitiveType 26 | | InetPrimitiveType 27 | | JsonPrimitiveType 28 | | JsonbPrimitiveType 29 | 30 | simpleTypename = \case 31 | GenericTypeSimpleTypename a -> genericType a 32 | NumericSimpleTypename a -> numeric a 33 | BitSimpleTypename a -> bit a 34 | CharacterSimpleTypename a -> character a 35 | ConstDatetimeSimpleTypename a -> constDatetime a 36 | ConstIntervalSimpleTypename a -> Right IntervalPrimitiveType 37 | 38 | genericType (GenericType a b c) = case b of 39 | Just _ -> Left "Type attributes are not supported" 40 | Nothing -> case c of 41 | Just _ -> Left "Type modifiers are not supported" 42 | Nothing -> ident a 43 | 44 | numeric = \case 45 | IntNumeric -> Right Int4PrimitiveType 46 | IntegerNumeric -> Right Int4PrimitiveType 47 | SmallintNumeric -> Right Int2PrimitiveType 48 | BigintNumeric -> Right Int8PrimitiveType 49 | RealNumeric -> Right Float4PrimitiveType 50 | FloatNumeric a -> case a of 51 | Just _ -> Left "Modifier on FLOAT is not supported" 52 | Nothing -> Right Float4PrimitiveType 53 | DoublePrecisionNumeric -> Right Float8PrimitiveType 54 | DecimalNumeric a -> case a of 55 | Just _ -> Left "Modifiers on DECIMAL are not supported" 56 | Nothing -> Right NumericPrimitiveType 57 | DecNumeric a -> case a of 58 | Just _ -> Left "Modifiers on DEC are not supported" 59 | Nothing -> Right NumericPrimitiveType 60 | NumericNumeric a -> case a of 61 | Just _ -> Left "Modifiers on NUMERIC are not supported" 62 | Nothing -> Right NumericPrimitiveType 63 | BooleanNumeric -> Right BoolPrimitiveType 64 | 65 | bit _ = Left "Bit codec is not supported" 66 | 67 | character _ = Right CharPrimitiveType 68 | 69 | constDatetime = \case 70 | TimestampConstDatetime _ a -> if tz a then Right TimestamptzPrimitiveType else Right TimestampPrimitiveType 71 | TimeConstDatetime _ a -> if tz a then Right TimetzPrimitiveType else Right TimePrimitiveType 72 | where 73 | tz = \case 74 | Just a -> a 75 | Nothing -> False 76 | 77 | ident = \case 78 | QuotedIdent a -> name a 79 | UnquotedIdent a -> name a 80 | 81 | name = \case 82 | "bool" -> Right BoolPrimitiveType 83 | "int2" -> Right Int2PrimitiveType 84 | "int4" -> Right Int4PrimitiveType 85 | "int8" -> Right Int8PrimitiveType 86 | "float4" -> Right Float4PrimitiveType 87 | "float8" -> Right Float8PrimitiveType 88 | "numeric" -> Right NumericPrimitiveType 89 | "char" -> Right CharPrimitiveType 90 | "text" -> Right TextPrimitiveType 91 | "bytea" -> Right ByteaPrimitiveType 92 | "date" -> Right DatePrimitiveType 93 | "timestamp" -> Right TimestampPrimitiveType 94 | "timestamptz" -> Right TimestamptzPrimitiveType 95 | "time" -> Right TimePrimitiveType 96 | "timetz" -> Right TimetzPrimitiveType 97 | "interval" -> Right IntervalPrimitiveType 98 | "uuid" -> Right UuidPrimitiveType 99 | "inet" -> Right InetPrimitiveType 100 | "json" -> Right JsonPrimitiveType 101 | "jsonb" -> Right JsonbPrimitiveType 102 | name -> Left ("No codec exists for type: " <> name) 103 | -------------------------------------------------------------------------------- /library/Hasql/TH/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Hasql.TH.Prelude 2 | ( module Exports, 3 | showAsText, 4 | suffixRec, 5 | ) 6 | where 7 | 8 | import Control.Applicative as Exports 9 | import Control.Arrow as Exports hiding (first, second) 10 | import Control.Category as Exports 11 | import Control.Concurrent as Exports 12 | import Control.Exception as Exports 13 | import Control.Foldl as Exports (Fold (..)) 14 | import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) 15 | import Control.Monad.Fail as Exports 16 | import Control.Monad.Fix as Exports hiding (fix) 17 | import Control.Monad.IO.Class as Exports 18 | import Control.Monad.ST as Exports 19 | import Data.Bifunctor as Exports 20 | import Data.Bits as Exports 21 | import Data.Bool as Exports 22 | import Data.ByteString as Exports (ByteString) 23 | import Data.Char as Exports 24 | import Data.Coerce as Exports 25 | import Data.Complex as Exports 26 | import Data.Data as Exports 27 | import Data.Dynamic as Exports 28 | import Data.Either as Exports 29 | import Data.Fixed as Exports 30 | import Data.Foldable as Exports 31 | import Data.Function as Exports hiding (id, (.)) 32 | import Data.Functor as Exports hiding (unzip) 33 | import Data.Functor.Contravariant as Exports 34 | import Data.Functor.Contravariant.Divisible as Exports 35 | import Data.Functor.Identity as Exports 36 | import Data.IORef as Exports 37 | import Data.Int as Exports 38 | import Data.IntMap.Strict as Exports (IntMap) 39 | import Data.IntSet as Exports (IntSet) 40 | import Data.Ix as Exports 41 | import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) 42 | import Data.List.NonEmpty as Exports (NonEmpty (..)) 43 | import Data.Map.Strict as Exports (Map) 44 | import Data.Maybe as Exports 45 | import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) 46 | import Data.Ord as Exports 47 | import Data.Proxy as Exports 48 | import Data.Ratio as Exports 49 | import Data.STRef as Exports 50 | import Data.Semigroup as Exports 51 | import Data.Sequence as Exports (Seq) 52 | import Data.Set as Exports (Set) 53 | import Data.String as Exports 54 | import Data.Text as Exports (Text) 55 | import Data.Traversable as Exports 56 | import Data.Tuple as Exports 57 | import Data.UUID as Exports (UUID) 58 | import Data.Unique as Exports 59 | import Data.Version as Exports 60 | import Data.Void as Exports 61 | import Data.Word as Exports 62 | import Debug.Trace as Exports 63 | import Foreign.ForeignPtr as Exports 64 | import Foreign.Ptr as Exports 65 | import Foreign.StablePtr as Exports 66 | import Foreign.Storable as Exports hiding (alignment, sizeOf) 67 | import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) 68 | import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith) 69 | import GHC.Generics as Exports (Generic, Generic1) 70 | import GHC.IO.Exception as Exports 71 | import Numeric as Exports 72 | import System.Environment as Exports 73 | import System.Exit as Exports 74 | import System.IO as Exports 75 | import System.IO.Error as Exports 76 | import System.IO.Unsafe as Exports 77 | import System.Mem as Exports 78 | import System.Mem.StableName as Exports 79 | import System.Timeout as Exports 80 | import Text.Printf as Exports (hPrintf, printf) 81 | import Text.Read as Exports (Read (..), readEither, readMaybe) 82 | import Unsafe.Coerce as Exports 83 | import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) 84 | 85 | showAsText :: (Show a) => a -> Text 86 | showAsText = show >>> fromString 87 | 88 | -- | 89 | -- Compose a monad, which attempts to extend a value, based on the following input. 90 | -- It does that recursively until the suffix alternative fails. 91 | suffixRec :: (Monad m, Alternative m) => m a -> (a -> m a) -> m a 92 | suffixRec base suffix = do 93 | _base <- base 94 | suffixRec (suffix _base) suffix <|> pure _base 95 | -------------------------------------------------------------------------------- /library/Hasql/TH/Extraction/Exp.hs: -------------------------------------------------------------------------------- 1 | module Hasql.TH.Extraction.Exp where 2 | 3 | import qualified Hasql.Decoders as Decoders 4 | import qualified Hasql.Encoders as Encoders 5 | import qualified Hasql.TH.Construction.Exp as Exp 6 | import qualified Hasql.TH.Extraction.InputTypeList as InputTypeList 7 | import qualified Hasql.TH.Extraction.OutputTypeList as OutputTypeList 8 | import qualified Hasql.TH.Extraction.PrimitiveType as PrimitiveType 9 | import Hasql.TH.Prelude 10 | import Language.Haskell.TH 11 | import qualified PostgresqlSyntax.Ast as Ast 12 | import qualified PostgresqlSyntax.Rendering as Rendering 13 | 14 | undecodedStatement :: (Exp -> Exp) -> Ast.PreparableStmt -> Either Text Exp 15 | undecodedStatement _decoderProj _ast = 16 | let _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast 17 | in do 18 | _encoder <- paramsEncoder _ast 19 | _rowDecoder <- rowDecoder _ast 20 | return (Exp.statement _sql _encoder (_decoderProj _rowDecoder)) 21 | 22 | foldStatement :: Ast.PreparableStmt -> Either Text Exp 23 | foldStatement _ast = 24 | let _sql = (Exp.byteString . Rendering.toByteString . Rendering.preparableStmt) _ast 25 | in do 26 | _encoder <- paramsEncoder _ast 27 | _rowDecoder <- rowDecoder _ast 28 | return (Exp.foldStatement _sql _encoder _rowDecoder) 29 | 30 | paramsEncoder :: Ast.PreparableStmt -> Either Text Exp 31 | paramsEncoder a = do 32 | b <- InputTypeList.preparableStmt a 33 | c <- traverse paramEncoder b 34 | return (Exp.contrazip c) 35 | 36 | rowDecoder :: Ast.PreparableStmt -> Either Text Exp 37 | rowDecoder a = do 38 | b <- OutputTypeList.preparableStmt a 39 | c <- traverse columnDecoder b 40 | return (Exp.cozip c) 41 | 42 | paramEncoder :: Ast.Typename -> Either Text Exp 43 | paramEncoder = 44 | byTypename 45 | (\a b -> valueEncoder a & fmap (Exp.unidimensionalParamEncoder b)) 46 | (\a b c d -> valueEncoder a & fmap (Exp.multidimensionalParamEncoder b c d)) 47 | 48 | columnDecoder :: Ast.Typename -> Either Text Exp 49 | columnDecoder = 50 | byTypename 51 | (\a b -> valueDecoder a & fmap (Exp.unidimensionalColumnDecoder b)) 52 | (\a b c d -> valueDecoder a & fmap (Exp.multidimensionalColumnDecoder b c d)) 53 | 54 | byTypename :: (PrimitiveType.PrimitiveType -> Bool -> Either Text Exp) -> (PrimitiveType.PrimitiveType -> Bool -> Int -> Bool -> Either Text Exp) -> Ast.Typename -> Either Text Exp 55 | byTypename unidimensional multidimensional (Ast.Typename a b c d) = 56 | if a 57 | then Left "SETOF is not supported" 58 | else do 59 | e <- PrimitiveType.simpleTypename b 60 | case d of 61 | Nothing -> unidimensional e c 62 | Just (f, g) -> case f of 63 | Ast.BoundsTypenameArrayDimensions h -> multidimensional e c (length h) g 64 | Ast.ExplicitTypenameArrayDimensions _ -> multidimensional e c 1 g 65 | 66 | valueEncoder :: PrimitiveType.PrimitiveType -> Either Text Exp 67 | valueEncoder = 68 | Right . VarE . \case 69 | PrimitiveType.BoolPrimitiveType -> 'Encoders.bool 70 | PrimitiveType.Int2PrimitiveType -> 'Encoders.int2 71 | PrimitiveType.Int4PrimitiveType -> 'Encoders.int4 72 | PrimitiveType.Int8PrimitiveType -> 'Encoders.int8 73 | PrimitiveType.Float4PrimitiveType -> 'Encoders.float4 74 | PrimitiveType.Float8PrimitiveType -> 'Encoders.float8 75 | PrimitiveType.NumericPrimitiveType -> 'Encoders.numeric 76 | PrimitiveType.CharPrimitiveType -> 'Encoders.char 77 | PrimitiveType.TextPrimitiveType -> 'Encoders.text 78 | PrimitiveType.ByteaPrimitiveType -> 'Encoders.bytea 79 | PrimitiveType.DatePrimitiveType -> 'Encoders.date 80 | PrimitiveType.TimestampPrimitiveType -> 'Encoders.timestamp 81 | PrimitiveType.TimestamptzPrimitiveType -> 'Encoders.timestamptz 82 | PrimitiveType.TimePrimitiveType -> 'Encoders.time 83 | PrimitiveType.TimetzPrimitiveType -> 'Encoders.timetz 84 | PrimitiveType.IntervalPrimitiveType -> 'Encoders.interval 85 | PrimitiveType.UuidPrimitiveType -> 'Encoders.uuid 86 | PrimitiveType.InetPrimitiveType -> 'Encoders.inet 87 | PrimitiveType.JsonPrimitiveType -> 'Encoders.json 88 | PrimitiveType.JsonbPrimitiveType -> 'Encoders.jsonb 89 | 90 | valueDecoder :: PrimitiveType.PrimitiveType -> Either Text Exp 91 | valueDecoder = 92 | Right . VarE . \case 93 | PrimitiveType.BoolPrimitiveType -> 'Decoders.bool 94 | PrimitiveType.Int2PrimitiveType -> 'Decoders.int2 95 | PrimitiveType.Int4PrimitiveType -> 'Decoders.int4 96 | PrimitiveType.Int8PrimitiveType -> 'Decoders.int8 97 | PrimitiveType.Float4PrimitiveType -> 'Decoders.float4 98 | PrimitiveType.Float8PrimitiveType -> 'Decoders.float8 99 | PrimitiveType.NumericPrimitiveType -> 'Decoders.numeric 100 | PrimitiveType.CharPrimitiveType -> 'Decoders.char 101 | PrimitiveType.TextPrimitiveType -> 'Decoders.text 102 | PrimitiveType.ByteaPrimitiveType -> 'Decoders.bytea 103 | PrimitiveType.DatePrimitiveType -> 'Decoders.date 104 | PrimitiveType.TimestampPrimitiveType -> 'Decoders.timestamp 105 | PrimitiveType.TimestamptzPrimitiveType -> 'Decoders.timestamptz 106 | PrimitiveType.TimePrimitiveType -> 'Decoders.time 107 | PrimitiveType.TimetzPrimitiveType -> 'Decoders.timetz 108 | PrimitiveType.IntervalPrimitiveType -> 'Decoders.interval 109 | PrimitiveType.UuidPrimitiveType -> 'Decoders.uuid 110 | PrimitiveType.InetPrimitiveType -> 'Decoders.inet 111 | PrimitiveType.JsonPrimitiveType -> 'Decoders.json 112 | PrimitiveType.JsonbPrimitiveType -> 'Decoders.jsonb 113 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Summary 2 | 3 | An extension library for the ["hasql"](https://github.com/nikita-volkov/hasql) Postgres driver, bringing compile-time syntax checking of queries atop of a great simplification of declaration of statements. All the user needs to do is just specify SQL. 4 | 5 | Here's a brief example of how it works: 6 | 7 | ```haskell 8 | selectUserDetails :: Statement Int32 (Maybe (Text, Text, Maybe Text)) 9 | selectUserDetails = 10 | [maybeStatement| 11 | select name :: text, email :: text, phone :: text? 12 | from "user" 13 | where id = $1 :: int4 14 | |] 15 | ``` 16 | 17 | As you can see, it completely eliminates the need to deal with codecs. The quasiquoters directly produce `Statement`, which you can then [`dimap`](https://hackage.haskell.org/package/profunctors-5.5.1/docs/Data-Profunctor.html#v:dimap) over using its `Profunctor` instance to get to your domain types. 18 | 19 |
20 | Examples of mapping to custom types 21 | 22 | ```haskell 23 | newtype UserId = UserId Int32 24 | 25 | data UserDetails = UserDetails { 26 | _name :: Text, 27 | _email :: Text, 28 | _phone :: Maybe Text 29 | } 30 | 31 | selectUserDetails :: Statement UserId (Maybe UserDetails) 32 | selectUserDetails = 33 | dimap 34 | (\ (UserId a) -> a) 35 | (\ case 36 | Just (a, b, c) -> Just (UserDetails a b c) 37 | Nothing -> Nothing) 38 | [maybeStatement| 39 | select name :: text, email :: text, phone :: text? 40 | from "user" 41 | where id = $1 :: int4 42 | |] 43 | ``` 44 | 45 | Using some Haskell's advanced techniques and the ["tuple"](http://hackage.haskell.org/package/tuple) library we can reduce the boilerplate in the previous definition: 46 | 47 | ```haskell 48 | import Data.Tuple.Curry -- from the "tuple" library 49 | 50 | selectUserDetails :: Statement UserId (Maybe UserDetails) 51 | selectUserDetails = 52 | dimap coerce (fmap (uncurryN UserDetails)) 53 | [maybeStatement| 54 | select name :: text, email :: text, phone :: text? 55 | from "user" 56 | where id = $1 :: int4 57 | |] 58 | ``` 59 | 60 |
61 | 62 | # Status 63 | 64 | The library supports almost all of Postgresql syntax available for preparable statements. This includes Select, Insert, Update and Delete among others. The only thing that is not supported yet is some of its very rarely used XML-related features. 65 | 66 | ## Quality 67 | 68 | The parser and renderer get heavily tested using the following property: rendering a random AST then parsing it should produce the same AST. This pretty much covers most possible reasons for bugs in the library. 69 | 70 | # Implementation 71 | 72 | This library internally implements a port of the original Postgres SQL syntax parser. It might sound like an overkill, but there really were no better options. 73 | 74 | Unfortunately Postgres doesn't export it's own parser in any of its distributions, so there's no C-library to link to and wrap. 75 | 76 | Isolating the original C-code and including it in a Haskell project is also not an option, because it's heavily based on code generators and complex make-file instructions. Maintaining such a codebase also seems like a non-viable option. 77 | 78 | Fortunately the original parser is implemented using a declarative notation (the one which the mentioned code generators work with). It being declarative makes the process of porting to Haskell quite straight-forward. 79 | 80 | Also for the purposes of this library we need access to the full syntax tree for extracting data on placeholders and statement results. Quick and dirty hacks won't do. 81 | 82 | For these reasons it's been decided to port the original parser and AST as close as possible to Haskell using the "megaparsec" library. 83 | 84 | # Error messages 85 | 86 | The parser turns out to be actually better than the one in Postgres in terms of error-reporting. That's because of Haskell's superabilities in the area of parsing compared to C. The library uses the ["megaparsec"](http://hackage.haskell.org/package/megaparsec) library and the ["headed-megaparsec"](http://hackage.haskell.org/package/headed-megaparsec) extension for it. As the result of that, the error messages produced by this parser are more informative than the ones in Postgres. Following are a few examples. 87 | 88 | ## Error example 1 89 | 90 | Consider the following broken statement: 91 | 92 | ```sql 93 | select 1 from a where b >= 3 && b < 4 94 | ``` 95 | 96 | It is incorrect, because it uses `&&` instead of `and`. But here's what Postgres' original parser says about it: 97 | 98 | ``` 99 | ERROR: syntax error at or near "<" 100 | LINE 1: select 1 from a where b >= 3 && b < 4; 101 | ^ 102 | ``` 103 | 104 | Here's what "hasql-th" says: 105 | 106 | ``` 107 | | 108 | 2 | select 1 from a where b >= 3 && b < 4; 109 | | ^ 110 | unexpected '&' 111 | ``` 112 | 113 | ## Error example 2 114 | 115 | It's not obvious what is wrong in the following statement either: 116 | 117 | ```sql 118 | insert into user (name) values ($1) 119 | ``` 120 | 121 | The Postgres parser doesn't help much: 122 | 123 | ``` 124 | ERROR: syntax error at or near "user" 125 | LINE 1: insert into user (name) values ($1); 126 | ^ 127 | ``` 128 | 129 | Here's what "hasql-th" says though: 130 | 131 | ``` 132 | | 133 | 2 | insert into user (name) values ($1) 134 | | ^ 135 | Reserved keyword "user" used as an identifier. If that's what you intend, you have to wrap it in double quotes. 136 | ``` 137 | 138 | ## Error example 3 139 | 140 | It turns out that the original Postgres parser never produces any other messages than the opaque "syntax error at or near". "hasql-th" on the other hand is quite descriptive. E.g., here's how it gradually guides to insert the missing expected pieces. 141 | 142 | Input: 143 | 144 | ```haskell 145 | [resultlessStatement|insert into |] 146 | ``` 147 | 148 | Error: 149 | 150 | ``` 151 | | 152 | 1 | insert into 153 | | ^ 154 | unexpected end of input 155 | expecting identifier or white space 156 | ``` 157 | 158 | Input: 159 | 160 | ```haskell 161 | [resultlessStatement|insert into a |] 162 | ``` 163 | 164 | Error: 165 | 166 | ``` 167 | | 168 | 1 | insert into a 169 | | ^ 170 | unexpected end of input 171 | expecting "default", "overriding", "select", "values", '(', white space, or with clause 172 | ``` 173 | -------------------------------------------------------------------------------- /library/Hasql/TH/Construction/Exp.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Expression construction. 3 | module Hasql.TH.Construction.Exp where 4 | 5 | import qualified Data.ByteString as ByteString 6 | import qualified Data.ByteString.Unsafe as ByteString 7 | import qualified Data.Vector.Generic as Vector 8 | import qualified Hasql.Decoders as Decoders 9 | import qualified Hasql.Encoders as Encoders 10 | import qualified Hasql.Statement as Statement 11 | import Hasql.TH.Prelude hiding (sequence_) 12 | import qualified Hasql.TH.Prelude as Prelude 13 | import Language.Haskell.TH.Syntax 14 | import qualified TemplateHaskell.Compat.V0208 as Compat 15 | 16 | -- * Helpers 17 | 18 | appList :: Exp -> [Exp] -> Exp 19 | appList = foldl' AppE 20 | 21 | byteString :: ByteString -> Exp 22 | byteString x = 23 | appList 24 | (VarE 'unsafeDupablePerformIO) 25 | [ appList 26 | (VarE 'ByteString.unsafePackAddressLen) 27 | [ LitE (IntegerL (fromIntegral (ByteString.length x))), 28 | LitE (StringPrimL (ByteString.unpack x)) 29 | ] 30 | ] 31 | 32 | integral :: (Integral a) => a -> Exp 33 | integral x = LitE (IntegerL (fromIntegral x)) 34 | 35 | list :: (a -> Exp) -> [a] -> Exp 36 | list renderer x = ListE (map renderer x) 37 | 38 | string :: String -> Exp 39 | string x = LitE (StringL x) 40 | 41 | char :: Char -> Exp 42 | char x = LitE (CharL x) 43 | 44 | sequence_ :: [Exp] -> Exp 45 | sequence_ = foldl' andThen pureUnit 46 | 47 | pureUnit :: Exp 48 | pureUnit = AppE (VarE 'Prelude.pure) (TupE []) 49 | 50 | andThen :: Exp -> Exp -> Exp 51 | andThen exp1 exp2 = AppE (AppE (VarE '(*>)) exp1) exp2 52 | 53 | tuple :: Int -> Exp 54 | tuple = ConE . tupleDataName 55 | 56 | splitTupleAt :: Int -> Int -> Exp 57 | splitTupleAt arity position = 58 | let nameByIndex index = Name (OccName ('_' : show index)) NameS 59 | names = enumFromTo 0 (pred arity) & map nameByIndex 60 | pats = names & map VarP 61 | pat = TupP pats 62 | exps = names & map VarE 63 | body = splitAt position exps & \(a, b) -> Compat.tupE [Compat.tupE a, Compat.tupE b] 64 | in LamE [pat] body 65 | 66 | -- | 67 | -- Given a list of divisible functor expressions, 68 | -- constructs an expression, which composes them together into 69 | -- a single divisible functor, parameterized by a tuple of according arity. 70 | contrazip :: [Exp] -> Exp 71 | contrazip = \case 72 | _head : [] -> _head 73 | _head : _tail -> appList (VarE 'divide) [splitTupleAt (succ (length _tail)) 1, _head, contrazip _tail] 74 | [] -> 75 | SigE 76 | (VarE 'conquer) 77 | ( let _fName = mkName "f" 78 | _fVar = VarT _fName 79 | in ForallT 80 | [Compat.specifiedPlainTV _fName] 81 | [AppT (ConT ''Divisible) (VarT _fName)] 82 | (AppT (VarT _fName) (TupleT 0)) 83 | ) 84 | 85 | -- | 86 | -- Given a list of applicative functor expressions, 87 | -- constructs an expression, which composes them together into 88 | -- a single applicative functor, parameterized by a tuple of according arity. 89 | -- 90 | -- >>> $(return (cozip [])) :: Maybe () 91 | -- Just () 92 | -- 93 | -- >>> $(return (cozip (fmap (AppE (ConE 'Just) . LitE . IntegerL) [1,2,3]))) :: Maybe (Int, Int, Int) 94 | -- Just (1,2,3) 95 | cozip :: [Exp] -> Exp 96 | cozip = \case 97 | _head : [] -> _head 98 | _head : _tail -> 99 | let _length = length _tail + 1 100 | in foldl' 101 | (\a b -> AppE (AppE (VarE '(<*>)) a) b) 102 | (AppE (AppE (VarE 'fmap) (tuple _length)) _head) 103 | _tail 104 | [] -> AppE (VarE 'pure) (TupE []) 105 | 106 | -- | 107 | -- Lambda expression, which destructures 'Fold'. 108 | foldLam :: (Exp -> Exp -> Exp -> Exp) -> Exp 109 | foldLam _body = 110 | let _stepVarName = mkName "progress" 111 | _initVarName = mkName "start" 112 | _extractVarName = mkName "finish" 113 | in LamE 114 | [ Compat.conP 115 | 'Fold 116 | [ VarP _stepVarName, 117 | VarP _initVarName, 118 | VarP _extractVarName 119 | ] 120 | ] 121 | (_body (VarE _stepVarName) (VarE _initVarName) (VarE _extractVarName)) 122 | 123 | -- * Statement 124 | 125 | statement :: Exp -> Exp -> Exp -> Exp 126 | statement _sql _encoder _decoder = 127 | appList (ConE 'Statement.Statement) [_sql, _encoder, _decoder, ConE 'True] 128 | 129 | noResultResultDecoder :: Exp 130 | noResultResultDecoder = VarE 'Decoders.noResult 131 | 132 | rowsAffectedResultDecoder :: Exp 133 | rowsAffectedResultDecoder = VarE 'Decoders.rowsAffected 134 | 135 | singleRowResultDecoder :: Exp -> Exp 136 | singleRowResultDecoder = 'Decoders.singleRow & VarE & AppE 137 | 138 | rowMaybeResultDecoder :: Exp -> Exp 139 | rowMaybeResultDecoder = AppE (VarE 'Decoders.rowMaybe) 140 | 141 | rowVectorResultDecoder :: Exp -> Exp 142 | rowVectorResultDecoder = AppE (VarE 'Decoders.rowVector) 143 | 144 | foldStatement :: Exp -> Exp -> Exp -> Exp 145 | foldStatement _sql _encoder _rowDecoder = 146 | foldLam (\_step _init _extract -> statement _sql _encoder (foldResultDecoder _step _init _extract _rowDecoder)) 147 | 148 | foldResultDecoder :: Exp -> Exp -> Exp -> Exp -> Exp 149 | foldResultDecoder _step _init _extract _rowDecoder = 150 | appList (VarE 'fmap) [_extract, appList (VarE 'Decoders.foldlRows) [_step, _init, _rowDecoder]] 151 | 152 | unidimensionalParamEncoder :: Bool -> Exp -> Exp 153 | unidimensionalParamEncoder nullable = 154 | applyParamToEncoder . applyNullabilityToEncoder nullable 155 | 156 | multidimensionalParamEncoder :: Bool -> Int -> Bool -> Exp -> Exp 157 | multidimensionalParamEncoder nullable dimensionality arrayNull = 158 | applyParamToEncoder 159 | . applyNullabilityToEncoder arrayNull 160 | . AppE (VarE 'Encoders.array) 161 | . applyArrayDimensionalityToEncoder dimensionality 162 | . applyNullabilityToEncoder nullable 163 | 164 | applyParamToEncoder :: Exp -> Exp 165 | applyParamToEncoder = AppE (VarE 'Encoders.param) 166 | 167 | applyNullabilityToEncoder :: Bool -> Exp -> Exp 168 | applyNullabilityToEncoder nullable = AppE (VarE (if nullable then 'Encoders.nullable else 'Encoders.nonNullable)) 169 | 170 | applyArrayDimensionalityToEncoder :: Int -> Exp -> Exp 171 | applyArrayDimensionalityToEncoder levels = 172 | if levels > 0 173 | then AppE (AppE (VarE 'Encoders.dimension) (VarE 'Vector.foldl')) . applyArrayDimensionalityToEncoder (pred levels) 174 | else AppE (VarE 'Encoders.element) 175 | 176 | rowDecoder :: [Exp] -> Exp 177 | rowDecoder = cozip 178 | 179 | unidimensionalColumnDecoder :: Bool -> Exp -> Exp 180 | unidimensionalColumnDecoder nullable = 181 | applyColumnToDecoder . applyNullabilityToDecoder nullable 182 | 183 | multidimensionalColumnDecoder :: Bool -> Int -> Bool -> Exp -> Exp 184 | multidimensionalColumnDecoder nullable dimensionality arrayNull = 185 | applyColumnToDecoder 186 | . applyNullabilityToDecoder arrayNull 187 | . AppE (VarE 'Decoders.array) 188 | . applyArrayDimensionalityToDecoder dimensionality 189 | . applyNullabilityToDecoder nullable 190 | 191 | applyColumnToDecoder :: Exp -> Exp 192 | applyColumnToDecoder = AppE (VarE 'Decoders.column) 193 | 194 | applyNullabilityToDecoder :: Bool -> Exp -> Exp 195 | applyNullabilityToDecoder nullable = AppE (VarE (if nullable then 'Decoders.nullable else 'Decoders.nonNullable)) 196 | 197 | applyArrayDimensionalityToDecoder :: Int -> Exp -> Exp 198 | applyArrayDimensionalityToDecoder levels = 199 | if levels > 0 200 | then AppE (AppE (VarE 'Decoders.dimension) (VarE 'Vector.replicateM)) . applyArrayDimensionalityToDecoder (pred levels) 201 | else AppE (VarE 'Decoders.element) 202 | -------------------------------------------------------------------------------- /library/Hasql/TH.hs: -------------------------------------------------------------------------------- 1 | module Hasql.TH 2 | ( -- * Statements 3 | 4 | -- | 5 | -- Quasiquoters in this category produce Hasql `Statement`s, 6 | -- checking the correctness of SQL at compile-time. 7 | -- 8 | -- To extract the information about parameters and results of the statement, 9 | -- the quoter requires you to explicitly specify the Postgres types for placeholders and results. 10 | -- 11 | -- Here's an example of how to use it: 12 | -- 13 | -- >selectUserDetails :: Statement Int32 (Maybe (Text, Text, Maybe Text)) 14 | -- >selectUserDetails = 15 | -- > [maybeStatement| 16 | -- > select name :: text, email :: text, phone :: text? 17 | -- > from "user" 18 | -- > where id = $1 :: int4 19 | -- > |] 20 | -- 21 | -- As you can see, it completely eliminates the need to mess with codecs. 22 | -- The quasiquoters directly produce `Statement`, 23 | -- which you can then `Data.Profunctor.dimap` over using its `Data.Profunctor.Profunctor` instance to get to your domain types. 24 | -- 25 | -- == Type mappings 26 | -- 27 | -- === Primitives 28 | -- 29 | -- Following is a list of supported Postgres types and their according types on the Haskell end. 30 | -- 31 | -- - @bool@ - `Bool` 32 | -- - @int2@ - `Int16` 33 | -- - @int4@ - `Int32` 34 | -- - @int8@ - `Int64` 35 | -- - @float4@ - `Float` 36 | -- - @float8@ - `Double` 37 | -- - @numeric@ - `Data.Scientific.Scientific` 38 | -- - @char@ - `Char` 39 | -- - @text@ - `Data.Text.Text` 40 | -- - @bytea@ - `Data.ByteString.ByteString` 41 | -- - @date@ - `Data.Time.Day` 42 | -- - @timestamp@ - `Data.Time.LocalTime` 43 | -- - @timestamptz@ - `Data.Time.UTCTime` 44 | -- - @time@ - `Data.Time.TimeOfDay` 45 | -- - @timetz@ - @(`Data.Time.TimeOfDay`, `Data.Time.TimeZone`)@ 46 | -- - @interval@ - `Data.Time.DiffTime` 47 | -- - @uuid@ - `Data.UUID.UUID` 48 | -- - @inet@ - @(`Network.IP.Addr.NetAddr` `Network.IP.Addr.IP`)@ 49 | -- - @json@ - `Data.Aeson.Value` 50 | -- - @jsonb@ - `Data.Aeson.Value` 51 | -- 52 | -- === Arrays 53 | -- 54 | -- Array mappings are also supported. 55 | -- They are specified according to Postgres syntax: by appending one or more @[]@ to the primitive type, 56 | -- depending on how many dimensions the array has. 57 | -- On the Haskell end array is mapped to generic `Data.Vector.Generic.Vector`, 58 | -- allowing you to choose which particular vector implementation to map to. 59 | -- 60 | -- === Nulls 61 | -- 62 | -- As you might have noticed in the example, 63 | -- we introduce one change to the Postgres syntax in the way 64 | -- the typesignatures are parsed: 65 | -- we interpret question-marks in them as specification of nullability. 66 | -- Here's more examples of that: 67 | -- 68 | -- >>> :t [singletonStatement| select a :: int4? |] 69 | -- ... 70 | -- :: Statement () (Maybe Int32) 71 | -- 72 | -- You can use it to specify the nullability of array elements: 73 | -- 74 | -- >>> :t [singletonStatement| select a :: int4?[] |] 75 | -- ... 76 | -- :: Data.Vector.Generic.Base.Vector v (Maybe Int32) => 77 | -- Statement () (v (Maybe Int32)) 78 | -- 79 | -- And of arrays themselves: 80 | -- 81 | -- >>> :t [singletonStatement| select a :: int4?[]? |] 82 | -- ... 83 | -- :: Data.Vector.Generic.Base.Vector v (Maybe Int32) => 84 | -- Statement () (Maybe (v (Maybe Int32))) 85 | 86 | -- ** Row-parsing statements 87 | singletonStatement, 88 | maybeStatement, 89 | vectorStatement, 90 | foldStatement, 91 | 92 | -- ** Row-ignoring statements 93 | resultlessStatement, 94 | rowsAffectedStatement, 95 | 96 | -- * SQL ByteStrings 97 | 98 | -- | 99 | -- ByteString-producing quasiquoters. 100 | -- 101 | -- For now they perform no compile-time checking. 102 | uncheckedSql, 103 | uncheckedSqlFile, 104 | ) 105 | where 106 | 107 | import qualified Data.Text as Text 108 | import qualified Data.Text.Encoding as Text 109 | import qualified Hasql.TH.Construction.Exp as Exp 110 | import qualified Hasql.TH.Extraction.Exp as ExpExtraction 111 | import Hasql.TH.Prelude hiding (exp) 112 | import Language.Haskell.TH.Quote 113 | import Language.Haskell.TH.Syntax 114 | import qualified PostgresqlSyntax.Ast as Ast 115 | import qualified PostgresqlSyntax.Parsing as Parsing 116 | 117 | -- * Helpers 118 | 119 | exp :: (String -> Q Exp) -> QuasiQuoter 120 | exp = 121 | let _unsupported _ = fail "Unsupported" 122 | in \_exp -> QuasiQuoter _exp _unsupported _unsupported _unsupported 123 | 124 | expParser :: (Text -> Either Text Exp) -> QuasiQuoter 125 | expParser _parser = 126 | exp $ \_inputString -> either (fail . Text.unpack) return $ _parser $ fromString _inputString 127 | 128 | expPreparableStmtAstParser :: (Ast.PreparableStmt -> Either Text Exp) -> QuasiQuoter 129 | expPreparableStmtAstParser _parser = 130 | expParser $ \_input -> do 131 | _ast <- first fromString $ Parsing.run (Parsing.atEnd Parsing.preparableStmt) _input 132 | _parser _ast 133 | 134 | -- * Statement 135 | 136 | -- | 137 | -- @ 138 | -- :: `Statement` params row 139 | -- @ 140 | -- 141 | -- Statement producing exactly one result row. 142 | -- 143 | -- Will cause the running session to fail with the 144 | -- `Hasql.Session.UnexpectedAmountOfRows` error if it's any other. 145 | -- 146 | -- === __Examples__ 147 | -- 148 | -- >>> :t [singletonStatement|select 1 :: int2|] 149 | -- ... :: Statement () Int16 150 | -- 151 | -- >>> :{ 152 | -- :t [singletonStatement| 153 | -- insert into "user" (email, name) 154 | -- values ($1 :: text, $2 :: text) 155 | -- returning id :: int4 156 | -- |] 157 | -- :} 158 | -- ... 159 | -- ... :: Statement (Text, Text) Int32 160 | -- 161 | -- Incorrect SQL: 162 | -- 163 | -- >>> :t [singletonStatement|elect 1|] 164 | -- ... 165 | -- | 166 | -- 1 | elect 1 167 | -- | ^ 168 | -- ... 169 | singletonStatement :: QuasiQuoter 170 | singletonStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.singleRowResultDecoder) 171 | 172 | -- | 173 | -- @ 174 | -- :: `Statement` params (Maybe row) 175 | -- @ 176 | -- 177 | -- Statement producing one row or none. 178 | -- 179 | -- === __Examples__ 180 | -- 181 | -- >>> :t [maybeStatement|select 1 :: int2|] 182 | -- ... :: Statement () (Maybe Int16) 183 | maybeStatement :: QuasiQuoter 184 | maybeStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.rowMaybeResultDecoder) 185 | 186 | -- | 187 | -- @ 188 | -- :: `Statement` params (`Vector` row) 189 | -- @ 190 | -- 191 | -- Statement producing a vector of rows. 192 | -- 193 | -- === __Examples__ 194 | -- 195 | -- >>> :t [vectorStatement|select 1 :: int2|] 196 | -- ... :: Statement () (Vector Int16) 197 | vectorStatement :: QuasiQuoter 198 | vectorStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement Exp.rowVectorResultDecoder) 199 | 200 | -- | 201 | -- @ 202 | -- :: `Fold` row folding -> `Statement` params folding 203 | -- @ 204 | -- 205 | -- Function from `Fold` over rows to a statement producing the result of folding. 206 | -- Use this when you need to aggregate rows customly. 207 | -- 208 | -- === __Examples__ 209 | -- 210 | -- >>> :t [foldStatement|select 1 :: int2|] 211 | -- ... :: Fold Int16 b -> Statement () b 212 | foldStatement :: QuasiQuoter 213 | foldStatement = expPreparableStmtAstParser ExpExtraction.foldStatement 214 | 215 | -- | 216 | -- @ 217 | -- :: `Statement` params () 218 | -- @ 219 | -- 220 | -- Statement producing no results. 221 | -- 222 | -- === __Examples__ 223 | -- 224 | -- >>> :t [resultlessStatement|insert into "user" (name, email) values ($1 :: text, $2 :: text)|] 225 | -- ... 226 | -- ... :: Statement (Text, Text) () 227 | resultlessStatement :: QuasiQuoter 228 | resultlessStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement (const Exp.noResultResultDecoder)) 229 | 230 | -- | 231 | -- @ 232 | -- :: `Statement` params Int64 233 | -- @ 234 | -- 235 | -- Statement counting the rows it affects. 236 | -- 237 | -- === __Examples__ 238 | -- 239 | -- >>> :t [rowsAffectedStatement|delete from "user" where password is null|] 240 | -- ... 241 | -- ... :: Statement () Int64 242 | rowsAffectedStatement :: QuasiQuoter 243 | rowsAffectedStatement = expPreparableStmtAstParser (ExpExtraction.undecodedStatement (const Exp.rowsAffectedResultDecoder)) 244 | 245 | -- * SQL ByteStrings 246 | 247 | -- | 248 | -- Quoter of a multiline Unicode SQL string, 249 | -- which gets converted into a format ready to be used for declaration of statements. 250 | uncheckedSql :: QuasiQuoter 251 | uncheckedSql = exp $ return . Exp.byteString . Text.encodeUtf8 . fromString 252 | 253 | -- | 254 | -- Read an SQL-file, containing multiple statements, 255 | -- and produce an expression of type `ByteString`. 256 | -- 257 | -- Allows to store plain SQL in external files and read it at compile time. 258 | -- 259 | -- E.g., 260 | -- 261 | -- >migration1 :: Hasql.Session.Session () 262 | -- >migration1 = Hasql.Session.sql [uncheckedSqlFile|migrations/1.sql|] 263 | uncheckedSqlFile :: QuasiQuoter 264 | uncheckedSqlFile = quoteFile uncheckedSql 265 | 266 | -- * Tests 267 | 268 | -- $ 269 | -- >>> :t [maybeStatement| select (password = $2 :: bytea) :: bool, id :: int4 from "user" where "email" = $1 :: text |] 270 | -- ... 271 | -- ... Statement (Text, ByteString) (Maybe (Bool, Int32)) 272 | -- 273 | -- >>> :t [maybeStatement| select id :: int4 from application where pub_key = $1 :: uuid and sec_key_pt1 = $2 :: int8 and sec_key_pt2 = $3 :: int8 |] 274 | -- ... 275 | -- ... Statement (UUID, Int64, Int64) (Maybe Int32) 276 | -- 277 | -- >>> :t [singletonStatement| select 1 :: int4 from a left join b on b.id = a.id |] 278 | -- ... 279 | -- ... Statement () Int32 280 | -------------------------------------------------------------------------------- /library/Hasql/TH/Extraction/ChildExprList.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | module Hasql.TH.Extraction.ChildExprList where 4 | 5 | import Hasql.TH.Prelude hiding (bit, fromList, sortBy) 6 | import PostgresqlSyntax.Ast 7 | 8 | -- * Types 9 | 10 | data ChildExpr = AChildExpr AExpr | BChildExpr BExpr | CChildExpr CExpr 11 | deriving (Show, Eq, Ord) 12 | 13 | -- | 14 | -- Dives one level of recursion. 15 | childExpr = \case 16 | AChildExpr a -> aChildExpr a 17 | BChildExpr a -> bChildExpr a 18 | CChildExpr a -> cChildExpr a 19 | 20 | aChildExpr = \case 21 | CExprAExpr a -> cChildExpr a 22 | TypecastAExpr a b -> aExpr a <> typename b 23 | CollateAExpr a b -> aExpr a <> anyName b 24 | AtTimeZoneAExpr a b -> aExpr a <> aExpr b 25 | PlusAExpr a -> aExpr a 26 | MinusAExpr a -> aExpr a 27 | SymbolicBinOpAExpr a b c -> aExpr a <> symbolicExprBinOp b <> aExpr c 28 | PrefixQualOpAExpr a b -> qualOp a <> aExpr b 29 | SuffixQualOpAExpr a b -> aExpr a <> qualOp b 30 | AndAExpr a b -> aExpr a <> aExpr b 31 | OrAExpr a b -> aExpr a <> aExpr b 32 | NotAExpr a -> aExpr a 33 | VerbalExprBinOpAExpr a b c d e -> aExpr a <> verbalExprBinOp c <> aExpr d <> foldMap aExpr e 34 | ReversableOpAExpr a b c -> aExpr a <> aExprReversableOp c 35 | IsnullAExpr a -> aExpr a 36 | NotnullAExpr a -> aExpr a 37 | OverlapsAExpr a b -> row a <> row b 38 | SubqueryAExpr a b c d -> aExpr a <> subqueryOp b <> subType c <> either selectWithParens aExpr d 39 | UniqueAExpr a -> selectWithParens a 40 | DefaultAExpr -> [] 41 | 42 | bChildExpr = \case 43 | CExprBExpr a -> cChildExpr a 44 | TypecastBExpr a b -> bExpr a <> typename b 45 | PlusBExpr a -> bExpr a 46 | MinusBExpr a -> bExpr a 47 | SymbolicBinOpBExpr a b c -> bExpr a <> symbolicExprBinOp b <> bExpr c 48 | QualOpBExpr a b -> qualOp a <> bExpr b 49 | IsOpBExpr a b c -> bExpr a <> bExprIsOp c 50 | 51 | cChildExpr = \case 52 | ColumnrefCExpr a -> columnref a 53 | AexprConstCExpr a -> aexprConst a 54 | ParamCExpr a b -> foldMap indirection b 55 | InParensCExpr a b -> aExpr a <> foldMap indirection b 56 | CaseCExpr a -> caseExpr a 57 | FuncCExpr a -> funcExpr a 58 | SelectWithParensCExpr a b -> selectWithParens a <> foldMap indirection b 59 | ExistsCExpr a -> selectWithParens a 60 | ArrayCExpr a -> either selectWithParens arrayExpr a 61 | ExplicitRowCExpr a -> explicitRow a 62 | ImplicitRowCExpr a -> implicitRow a 63 | GroupingCExpr a -> exprList a 64 | 65 | preparableStmt = \case 66 | SelectPreparableStmt a -> selectStmt a 67 | InsertPreparableStmt a -> insertStmt a 68 | UpdatePreparableStmt a -> updateStmt a 69 | DeletePreparableStmt a -> deleteStmt a 70 | CallPreparableStmt a -> callStmt a 71 | 72 | -- * Call 73 | 74 | callStmt (CallStmt a) = funcApplication a 75 | 76 | -- * Insert 77 | 78 | insertStmt (InsertStmt a b c d e) = 79 | foldMap withClause a 80 | <> insertTarget b 81 | <> insertRest c 82 | <> foldMap onConflict d 83 | <> foldMap returningClause e 84 | 85 | insertTarget (InsertTarget a b) = qualifiedName a <> colId b 86 | 87 | insertRest = \case 88 | SelectInsertRest a b c -> foldMap insertColumnList a <> foldMap overrideKind b <> selectStmt c 89 | DefaultValuesInsertRest -> [] 90 | 91 | overrideKind _ = [] 92 | 93 | insertColumnList = foldMap insertColumnItem 94 | 95 | insertColumnItem (InsertColumnItem a b) = colId a <> foldMap indirection b 96 | 97 | onConflict (OnConflict a b) = foldMap confExpr a <> onConflictDo b 98 | 99 | onConflictDo = \case 100 | UpdateOnConflictDo b c -> setClauseList b <> foldMap whereClause c 101 | NothingOnConflictDo -> [] 102 | 103 | confExpr = \case 104 | WhereConfExpr a b -> indexParams a <> foldMap whereClause b 105 | ConstraintConfExpr a -> name a 106 | 107 | returningClause = targetList 108 | 109 | -- * Update 110 | 111 | updateStmt (UpdateStmt a b c d e f) = 112 | foldMap withClause a 113 | <> relationExprOptAlias b 114 | <> setClauseList c 115 | <> foldMap fromClause d 116 | <> foldMap whereOrCurrentClause e 117 | <> foldMap returningClause f 118 | 119 | setClauseList = foldMap setClause 120 | 121 | setClause = \case 122 | TargetSetClause a b -> setTarget a <> aExpr b 123 | TargetListSetClause a b -> setTargetList a <> aExpr b 124 | 125 | setTarget (SetTarget a b) = colId a <> foldMap indirection b 126 | 127 | setTargetList = foldMap setTarget 128 | 129 | -- * Delete 130 | 131 | deleteStmt (DeleteStmt a b c d e) = 132 | foldMap withClause a 133 | <> relationExprOptAlias b 134 | <> foldMap usingClause c 135 | <> foldMap whereOrCurrentClause d 136 | <> foldMap returningClause e 137 | 138 | usingClause = fromList 139 | 140 | -- * Select 141 | 142 | selectStmt = \case 143 | Left a -> selectNoParens a 144 | Right a -> selectWithParens a 145 | 146 | selectNoParens (SelectNoParens a b c d e) = 147 | foldMap withClause a 148 | <> selectClause b 149 | <> foldMap sortClause c 150 | <> foldMap selectLimit d 151 | <> foldMap forLockingClause e 152 | 153 | selectWithParens = \case 154 | NoParensSelectWithParens a -> selectNoParens a 155 | WithParensSelectWithParens a -> selectWithParens a 156 | 157 | withClause (WithClause _ a) = foldMap commonTableExpr a 158 | 159 | commonTableExpr (CommonTableExpr a b c d) = preparableStmt d 160 | 161 | selectLimit = \case 162 | LimitOffsetSelectLimit a b -> limitClause a <> offsetClause b 163 | OffsetLimitSelectLimit a b -> offsetClause a <> limitClause b 164 | LimitSelectLimit a -> limitClause a 165 | OffsetSelectLimit a -> offsetClause a 166 | 167 | limitClause = \case 168 | LimitLimitClause a b -> selectLimitValue a <> exprList b 169 | FetchOnlyLimitClause a b c -> foldMap selectFetchFirstValue b 170 | 171 | offsetClause = \case 172 | ExprOffsetClause a -> aExpr a 173 | FetchFirstOffsetClause a b -> selectFetchFirstValue a 174 | 175 | selectFetchFirstValue = \case 176 | ExprSelectFetchFirstValue a -> cExpr a 177 | NumSelectFetchFirstValue _ _ -> [] 178 | 179 | selectLimitValue = \case 180 | ExprSelectLimitValue a -> aExpr a 181 | AllSelectLimitValue -> [] 182 | 183 | forLockingClause = \case 184 | ItemsForLockingClause a -> foldMap forLockingItem a 185 | ReadOnlyForLockingClause -> [] 186 | 187 | forLockingItem (ForLockingItem a b c) = 188 | foldMap (foldMap qualifiedName) b 189 | 190 | selectClause = either simpleSelect selectWithParens 191 | 192 | simpleSelect = \case 193 | NormalSimpleSelect a b c d e f g -> 194 | foldMap targeting a 195 | <> foldMap intoClause b 196 | <> foldMap fromClause c 197 | <> foldMap whereClause d 198 | <> foldMap groupClause e 199 | <> foldMap havingClause f 200 | <> foldMap windowClause g 201 | ValuesSimpleSelect a -> valuesClause a 202 | TableSimpleSelect a -> relationExpr a 203 | BinSimpleSelect _ a _ b -> selectClause a <> selectClause b 204 | 205 | targeting = \case 206 | NormalTargeting a -> foldMap targetEl a 207 | AllTargeting a -> foldMap (foldMap targetEl) a 208 | DistinctTargeting a b -> foldMap exprList a <> foldMap targetEl b 209 | 210 | targetList = foldMap targetEl 211 | 212 | targetEl = \case 213 | AliasedExprTargetEl a _ -> aExpr a 214 | ImplicitlyAliasedExprTargetEl a _ -> aExpr a 215 | ExprTargetEl a -> aExpr a 216 | AsteriskTargetEl -> [] 217 | 218 | intoClause = optTempTableName 219 | 220 | fromClause = fromList 221 | 222 | fromList = foldMap tableRef 223 | 224 | whereClause = aExpr 225 | 226 | whereOrCurrentClause = \case 227 | ExprWhereOrCurrentClause a -> aExpr a 228 | CursorWhereOrCurrentClause a -> cursorName a 229 | 230 | groupClause = foldMap groupByItem 231 | 232 | havingClause = aExpr 233 | 234 | windowClause = foldMap windowDefinition 235 | 236 | valuesClause = foldMap exprList 237 | 238 | optTempTableName _ = [] 239 | 240 | groupByItem = \case 241 | ExprGroupByItem a -> aExpr a 242 | EmptyGroupingSetGroupByItem -> [] 243 | RollupGroupByItem a -> exprList a 244 | CubeGroupByItem a -> exprList a 245 | GroupingSetsGroupByItem a -> foldMap groupByItem a 246 | 247 | windowDefinition (WindowDefinition _ a) = windowSpecification a 248 | 249 | windowSpecification (WindowSpecification _ a b c) = foldMap (foldMap aExpr) a <> foldMap sortClause b <> foldMap frameClause c 250 | 251 | frameClause (FrameClause _ a _) = frameExtent a 252 | 253 | frameExtent = \case 254 | SingularFrameExtent a -> frameBound a 255 | BetweenFrameExtent a b -> frameBound a <> frameBound b 256 | 257 | frameBound = \case 258 | UnboundedPrecedingFrameBound -> [] 259 | UnboundedFollowingFrameBound -> [] 260 | CurrentRowFrameBound -> [] 261 | PrecedingFrameBound a -> aExpr a 262 | FollowingFrameBound a -> aExpr a 263 | 264 | sortClause = foldMap sortBy 265 | 266 | sortBy = \case 267 | UsingSortBy a b c -> aExpr a <> qualAllOp b <> foldMap nullsOrder c 268 | AscDescSortBy a b c -> aExpr a <> foldMap ascDesc b <> foldMap nullsOrder c 269 | 270 | -- * Table refs 271 | 272 | tableRef = \case 273 | RelationExprTableRef a b c -> relationExpr a <> foldMap aliasClause b <> foldMap tablesampleClause c 274 | FuncTableRef a b c -> funcTable b <> foldMap funcAliasClause c 275 | SelectTableRef _ a _ -> selectWithParens a 276 | JoinTableRef a _ -> joinedTable a 277 | 278 | relationExpr = \case 279 | SimpleRelationExpr a _ -> qualifiedName a 280 | OnlyRelationExpr a _ -> qualifiedName a 281 | 282 | relationExprOptAlias (RelationExprOptAlias a b) = relationExpr a <> foldMap (colId . snd) b 283 | 284 | tablesampleClause (TablesampleClause a b c) = funcName a <> exprList b <> foldMap repeatableClause c 285 | 286 | repeatableClause = aExpr 287 | 288 | funcTable = \case 289 | FuncExprFuncTable a b -> funcExprWindowless a <> optOrdinality b 290 | RowsFromFuncTable a b -> rowsfromList a <> optOrdinality b 291 | 292 | rowsfromItem (RowsfromItem a b) = funcExprWindowless a <> foldMap colDefList b 293 | 294 | rowsfromList = foldMap rowsfromItem 295 | 296 | colDefList = tableFuncElementList 297 | 298 | optOrdinality = const [] 299 | 300 | tableFuncElementList = foldMap tableFuncElement 301 | 302 | tableFuncElement (TableFuncElement a b c) = colId a <> typename b <> foldMap collateClause c 303 | 304 | collateClause = anyName 305 | 306 | aliasClause = const [] 307 | 308 | funcAliasClause = \case 309 | AliasFuncAliasClause a -> aliasClause a 310 | AsFuncAliasClause a -> tableFuncElementList a 311 | AsColIdFuncAliasClause a b -> colId a <> tableFuncElementList b 312 | ColIdFuncAliasClause a b -> colId a <> tableFuncElementList b 313 | 314 | joinedTable = \case 315 | InParensJoinedTable a -> joinedTable a 316 | MethJoinedTable a b c -> joinMeth a <> tableRef b <> tableRef c 317 | 318 | joinMeth = \case 319 | CrossJoinMeth -> [] 320 | QualJoinMeth _ a -> joinQual a 321 | NaturalJoinMeth _ -> [] 322 | 323 | joinQual = \case 324 | UsingJoinQual _ -> [] 325 | OnJoinQual a -> aExpr a 326 | 327 | exprList = fmap AChildExpr . toList 328 | 329 | aExpr = pure . AChildExpr 330 | 331 | bExpr = pure . BChildExpr 332 | 333 | cExpr = pure . CChildExpr 334 | 335 | funcExpr = \case 336 | ApplicationFuncExpr a b c d -> funcApplication a <> foldMap withinGroupClause b <> foldMap filterClause c <> foldMap overClause d 337 | SubexprFuncExpr a -> funcExprCommonSubexpr a 338 | 339 | funcExprWindowless = \case 340 | ApplicationFuncExprWindowless a -> funcApplication a 341 | CommonSubexprFuncExprWindowless a -> funcExprCommonSubexpr a 342 | 343 | withinGroupClause = sortClause 344 | 345 | filterClause a = aExpr a 346 | 347 | overClause = \case 348 | WindowOverClause a -> windowSpecification a 349 | ColIdOverClause _ -> [] 350 | 351 | funcExprCommonSubexpr = \case 352 | CollationForFuncExprCommonSubexpr a -> aExpr a 353 | CurrentDateFuncExprCommonSubexpr -> [] 354 | CurrentTimeFuncExprCommonSubexpr _ -> [] 355 | CurrentTimestampFuncExprCommonSubexpr _ -> [] 356 | LocalTimeFuncExprCommonSubexpr _ -> [] 357 | LocalTimestampFuncExprCommonSubexpr _ -> [] 358 | CurrentRoleFuncExprCommonSubexpr -> [] 359 | CurrentUserFuncExprCommonSubexpr -> [] 360 | SessionUserFuncExprCommonSubexpr -> [] 361 | UserFuncExprCommonSubexpr -> [] 362 | CurrentCatalogFuncExprCommonSubexpr -> [] 363 | CurrentSchemaFuncExprCommonSubexpr -> [] 364 | CastFuncExprCommonSubexpr a b -> aExpr a <> typename b 365 | ExtractFuncExprCommonSubexpr a -> foldMap extractList a 366 | OverlayFuncExprCommonSubexpr a -> overlayList a 367 | PositionFuncExprCommonSubexpr a -> foldMap positionList a 368 | SubstringFuncExprCommonSubexpr a -> foldMap substrList a 369 | TreatFuncExprCommonSubexpr a b -> aExpr a <> typename b 370 | TrimFuncExprCommonSubexpr a b -> foldMap trimModifier a <> trimList b 371 | NullIfFuncExprCommonSubexpr a b -> aExpr a <> aExpr b 372 | CoalesceFuncExprCommonSubexpr a -> exprList a 373 | GreatestFuncExprCommonSubexpr a -> exprList a 374 | LeastFuncExprCommonSubexpr a -> exprList a 375 | 376 | extractList (ExtractList a b) = extractArg a <> aExpr b 377 | 378 | extractArg _ = [] 379 | 380 | overlayList (OverlayList a b c d) = foldMap aExpr ([a, b, c] <> toList d) 381 | 382 | positionList (PositionList a b) = bExpr a <> bExpr b 383 | 384 | substrList = \case 385 | ExprSubstrList a b -> aExpr a <> substrListFromFor b 386 | ExprListSubstrList a -> exprList a 387 | 388 | substrListFromFor = \case 389 | FromForSubstrListFromFor a b -> aExpr a <> aExpr b 390 | ForFromSubstrListFromFor a b -> aExpr a <> aExpr b 391 | FromSubstrListFromFor a -> aExpr a 392 | ForSubstrListFromFor a -> aExpr a 393 | 394 | trimModifier _ = [] 395 | 396 | trimList = \case 397 | ExprFromExprListTrimList a b -> aExpr a <> exprList b 398 | FromExprListTrimList a -> exprList a 399 | ExprListTrimList a -> exprList a 400 | 401 | whenClause (WhenClause a b) = aExpr a <> aExpr b 402 | 403 | funcApplication (FuncApplication a b) = funcName a <> foldMap funcApplicationParams b 404 | 405 | funcApplicationParams = \case 406 | NormalFuncApplicationParams _ a b -> foldMap funcArgExpr a <> foldMap (foldMap sortBy) b 407 | VariadicFuncApplicationParams a b c -> foldMap (foldMap funcArgExpr) a <> funcArgExpr b <> foldMap (foldMap sortBy) c 408 | StarFuncApplicationParams -> [] 409 | 410 | funcArgExpr = \case 411 | ExprFuncArgExpr a -> aExpr a 412 | ColonEqualsFuncArgExpr _ a -> aExpr a 413 | EqualsGreaterFuncArgExpr _ a -> aExpr a 414 | 415 | caseExpr (CaseExpr a b c) = foldMap aExpr a <> whenClauseList b <> foldMap aExpr c 416 | 417 | whenClauseList = foldMap whenClause 418 | 419 | arrayExpr = \case 420 | ExprListArrayExpr a -> exprList a 421 | ArrayExprListArrayExpr a -> arrayExprList a 422 | EmptyArrayExpr -> [] 423 | 424 | arrayExprList = foldMap arrayExpr 425 | 426 | inExpr = \case 427 | SelectInExpr a -> selectWithParens a 428 | ExprListInExpr a -> exprList a 429 | 430 | -- * Operators 431 | 432 | symbolicExprBinOp = \case 433 | MathSymbolicExprBinOp a -> mathOp a 434 | QualSymbolicExprBinOp a -> qualOp a 435 | 436 | qualOp = \case 437 | OpQualOp a -> op a 438 | OperatorQualOp a -> anyOperator a 439 | 440 | qualAllOp = \case 441 | AllQualAllOp a -> allOp a 442 | AnyQualAllOp a -> anyOperator a 443 | 444 | verbalExprBinOp = const [] 445 | 446 | aExprReversableOp = \case 447 | NullAExprReversableOp -> [] 448 | TrueAExprReversableOp -> [] 449 | FalseAExprReversableOp -> [] 450 | UnknownAExprReversableOp -> [] 451 | DistinctFromAExprReversableOp a -> aExpr a 452 | OfAExprReversableOp a -> typeList a 453 | BetweenAExprReversableOp a b c -> bExpr b <> aExpr c 454 | BetweenSymmetricAExprReversableOp a b -> bExpr a <> aExpr b 455 | InAExprReversableOp a -> inExpr a 456 | DocumentAExprReversableOp -> [] 457 | 458 | subqueryOp = \case 459 | AllSubqueryOp a -> allOp a 460 | AnySubqueryOp a -> anyOperator a 461 | LikeSubqueryOp _ -> [] 462 | IlikeSubqueryOp _ -> [] 463 | 464 | bExprIsOp = \case 465 | DistinctFromBExprIsOp a -> bExpr a 466 | OfBExprIsOp a -> typeList a 467 | DocumentBExprIsOp -> [] 468 | 469 | allOp = \case 470 | OpAllOp a -> op a 471 | MathAllOp a -> mathOp a 472 | 473 | anyOperator = \case 474 | AllOpAnyOperator a -> allOp a 475 | QualifiedAnyOperator a b -> colId a <> anyOperator b 476 | 477 | op = const [] 478 | 479 | mathOp = const [] 480 | 481 | -- * Rows 482 | 483 | row = \case 484 | ExplicitRowRow a -> explicitRow a 485 | ImplicitRowRow a -> implicitRow a 486 | 487 | explicitRow = foldMap exprList 488 | 489 | implicitRow (ImplicitRow a b) = exprList a <> aExpr b 490 | 491 | -- * Constants 492 | 493 | aexprConst = \case 494 | IAexprConst _ -> [] 495 | FAexprConst _ -> [] 496 | SAexprConst _ -> [] 497 | BAexprConst _ -> [] 498 | XAexprConst _ -> [] 499 | FuncAexprConst a b _ -> funcName a <> foldMap funcConstArgs b 500 | ConstTypenameAexprConst a _ -> constTypename a 501 | StringIntervalAexprConst _ a -> foldMap interval a 502 | IntIntervalAexprConst _ _ -> [] 503 | BoolAexprConst _ -> [] 504 | NullAexprConst -> [] 505 | 506 | funcConstArgs (FuncConstArgs a b) = foldMap funcArgExpr a <> foldMap sortClause b 507 | 508 | constTypename = \case 509 | NumericConstTypename a -> numeric a 510 | ConstBitConstTypename a -> constBit a 511 | ConstCharacterConstTypename a -> constCharacter a 512 | ConstDatetimeConstTypename a -> constDatetime a 513 | 514 | numeric = \case 515 | IntNumeric -> [] 516 | IntegerNumeric -> [] 517 | SmallintNumeric -> [] 518 | BigintNumeric -> [] 519 | RealNumeric -> [] 520 | FloatNumeric _ -> [] 521 | DoublePrecisionNumeric -> [] 522 | DecimalNumeric a -> foldMap exprList a 523 | DecNumeric a -> foldMap exprList a 524 | NumericNumeric a -> foldMap exprList a 525 | BooleanNumeric -> [] 526 | 527 | bit (Bit _ a) = foldMap exprList a 528 | 529 | constBit = bit 530 | 531 | constCharacter (ConstCharacter _ _) = [] 532 | 533 | constDatetime _ = [] 534 | 535 | interval _ = [] 536 | 537 | -- * Names 538 | 539 | ident _ = [] 540 | 541 | colId = ident 542 | 543 | name = colId 544 | 545 | cursorName = name 546 | 547 | anyName (AnyName a b) = colId a <> foldMap attrs b 548 | 549 | columnref (Columnref a b) = colId a <> foldMap indirection b 550 | 551 | funcName = \case 552 | TypeFuncName a -> typeFunctionName a 553 | IndirectedFuncName a b -> colId a <> indirection b 554 | 555 | qualifiedName = \case 556 | SimpleQualifiedName _ -> [] 557 | IndirectedQualifiedName _ a -> indirection a 558 | 559 | indirection = foldMap indirectionEl 560 | 561 | indirectionEl = \case 562 | AttrNameIndirectionEl _ -> [] 563 | AllIndirectionEl -> [] 564 | ExprIndirectionEl a -> aExpr a 565 | SliceIndirectionEl a b -> exprList a <> exprList b 566 | 567 | -- * Types 568 | 569 | typeList = foldMap typename 570 | 571 | typename (Typename a b c d) = 572 | simpleTypename b 573 | 574 | simpleTypename = \case 575 | GenericTypeSimpleTypename a -> genericType a 576 | NumericSimpleTypename a -> numeric a 577 | BitSimpleTypename a -> bit a 578 | CharacterSimpleTypename a -> character a 579 | ConstDatetimeSimpleTypename a -> constDatetime a 580 | ConstIntervalSimpleTypename a -> either (foldMap interval) (const []) a 581 | 582 | arrayBounds _ = [] 583 | 584 | genericType (GenericType a b c) = typeFunctionName a <> foldMap attrs b <> foldMap typeModifiers c 585 | 586 | typeFunctionName = ident 587 | 588 | attrs = foldMap attrName 589 | 590 | attrName _ = [] 591 | 592 | typeModifiers = exprList 593 | 594 | character _ = [] 595 | 596 | subType _ = [] 597 | 598 | -- * Indexes 599 | 600 | indexParams = foldMap indexElem 601 | 602 | indexElem (IndexElem a b c d e) = indexElemDef a <> foldMap anyName b <> foldMap anyName c 603 | 604 | indexElemDef = \case 605 | IdIndexElemDef a -> colId a 606 | FuncIndexElemDef a -> funcExprWindowless a 607 | ExprIndexElemDef a -> aExpr a 608 | 609 | ascDesc = const [] 610 | 611 | nullsOrder = const [] 612 | --------------------------------------------------------------------------------