preql 0.3 → 0.4
raw patch · 31 files changed
+5520/−472 lines, 31 filesdep +containersdep +generic-randomdep +hedgehogdep −freedep ~aesondep ~arraydep ~base
Dependencies added: containers, generic-random, hedgehog, syb, tasty-hedgehog, vector-sized
Dependencies removed: free
Dependency ranges changed: aeson, array, base, binary-parser, bytestring, bytestring-strict-builder, contravariant, mtl, postgresql-binary, postgresql-libpq, scientific, tasty, tasty-hunit, template-haskell, text, th-lift-instances, time, transformers, uuid, vector
Files
- CHANGELOG.md +6/−0
- preql.cabal +68/−46
- src/Preql.hs +5/−3
- src/Preql/Effect.hs +23/−18
- src/Preql/FromSql.hs +7/−0
- src/Preql/FromSql/Class.hs +59/−0
- src/Preql/FromSql/Instances.hs +157/−0
- src/Preql/FromSql/TH.hs +58/−0
- src/Preql/Imports.hs +3/−1
- src/Preql/QuasiQuoter/Common.hs +35/−0
- src/Preql/QuasiQuoter/Raw/Lex.x +6/−5
- src/Preql/QuasiQuoter/Raw/TH.hs +19/−48
- src/Preql/QuasiQuoter/Syntax/Lex.x +344/−0
- src/Preql/QuasiQuoter/Syntax/Name.hs +28/−0
- src/Preql/QuasiQuoter/Syntax/Params.hs +54/−0
- src/Preql/QuasiQuoter/Syntax/Parser.y +2832/−0
- src/Preql/QuasiQuoter/Syntax/Printer.hs +395/−0
- src/Preql/QuasiQuoter/Syntax/Syntax.hs +292/−0
- src/Preql/QuasiQuoter/Syntax/TH.hs +89/−0
- src/Preql/Wire.hs +7/−4
- src/Preql/Wire/Decode.hs +39/−0
- src/Preql/Wire/FromSql.hs +0/−209
- src/Preql/Wire/Internal.hs +29/−16
- src/Preql/Wire/Query.hs +26/−20
- src/Preql/Wire/Tuples.hs +5/−24
- test/Test.hs +75/−41
- test/Test/Syntax/Generators.hs +291/−0
- test/Test/Syntax/Parser.hs +375/−0
- test/Test/Syntax/Printer.hs +91/−0
- test/Test/Syntax/RoundTrip.hs +56/−0
- test/Test/Wire.hs +46/−37
CHANGELOG.md view
@@ -1,3 +1,9 @@+# 0.4 (2021-01-07)++- `select` quasiquoter that validates syntax+- tag number of columns consumed in `RowDecoder` type+- when decoder & number of returned columns are both known, ensure they match+ # 0.3 (2020-06-18) - lookup types by name when OID is not known statically
preql.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.33.1.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 9ee4ad1565dfa854b29bb325c372b2238843844d5c1f93696d018675540809e9+-- hash: 879f97b745bc46aaf20841fb18d7111d51a84fb4a3194c782f7e99c972a8ead3 name: preql-version: 0.3+version: 0.4 synopsis: safe PostgreSQL queries using Quasiquoters description: Before you Post(gres)QL, preql. .@@ -42,12 +42,24 @@ Preql Preql.Effect Preql.Effect.Internal+ Preql.FromSql+ Preql.FromSql.Class+ Preql.FromSql.Instances+ Preql.FromSql.TH Preql.Imports+ Preql.QuasiQuoter.Common Preql.QuasiQuoter.Raw.Lex Preql.QuasiQuoter.Raw.TH+ Preql.QuasiQuoter.Syntax.Lex+ Preql.QuasiQuoter.Syntax.Name+ Preql.QuasiQuoter.Syntax.Params+ Preql.QuasiQuoter.Syntax.Parser+ Preql.QuasiQuoter.Syntax.Printer+ Preql.QuasiQuoter.Syntax.Syntax+ Preql.QuasiQuoter.Syntax.TH Preql.Wire+ Preql.Wire.Decode Preql.Wire.Errors- Preql.Wire.FromSql Preql.Wire.Internal Preql.Wire.Orphans Preql.Wire.Query@@ -60,66 +72,76 @@ Paths_preql hs-source-dirs: src- default-extensions: OverloadedStrings+ default-extensions: OverloadedStrings DataKinds build-tools: alex , happy build-depends:- aeson >=1.3.1 && <1.6- , array >=0.5.2 && <0.6- , base >=4.11 && <4.15- , binary-parser >=0.5.5 && <0.6- , bytestring >=0.10.8 && <0.11- , bytestring-strict-builder >=0.4.5 && <0.5- , contravariant >=1.4.1 && <1.6- , free >=5.0.2 && <5.2- , mtl >=2.2.2 && <2.3- , postgresql-binary >=0.12.1 && <0.13- , postgresql-libpq >=0.9.4 && <0.10- , scientific >=0.3.6 && <0.4- , template-haskell >=2.13.0 && <2.17- , text >=1.2.3 && <1.3- , th-lift-instances >=0.1.11 && <0.2- , time >=1.8.0 && <1.10- , transformers >=0.5.5 && <0.6- , uuid >=1.3.13 && <1.4- , vector >=0.12.0 && <0.13+ aeson >=1.4.7.1 && <1.5.6+ , array >=0.5.4.0 && <0.5.5+ , base >=4.13.0.0 && <4.15+ , binary-parser >=0.5.6 && <0.6+ , bytestring >=0.10.10.0 && <0.10.13+ , bytestring-strict-builder >=0.4.5.3 && <0.4.6+ , contravariant >=1.5.2 && <1.5.4+ , mtl >=2.2.2 && <2.2.3+ , postgresql-binary >=0.12.2 && <0.12.4+ , postgresql-libpq >=0.9.4.2 && <0.9.5+ , scientific >=0.3.6.2 && <0.3.7+ , syb >=0.7.1 && <0.7.2+ , template-haskell >=2.15.0.0 && <2.17+ , text >=1.2.3.2 && <1.2.5+ , th-lift-instances >=0.1.17 && <0.1.19+ , time >=1.9.3 && <1.9.4+ , transformers >=0.5.6.2 && <0.5.7+ , uuid >=1.3.13 && <1.3.14+ , vector >=0.12.1.2 && <0.12.2+ , vector-sized >=1.4.1 && <1.4.4 default-language: Haskell2010 test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs other-modules:+ Test.Syntax.Generators+ Test.Syntax.Parser+ Test.Syntax.Printer+ Test.Syntax.RoundTrip Test.Wire Test.Wire.Enum Paths_preql hs-source-dirs: test- default-extensions: OverloadedStrings+ default-extensions: OverloadedStrings DataKinds build-tools: alex , happy build-depends:- aeson >=1.3.1 && <1.6- , array >=0.5.2 && <0.6- , base >=4.11 && <4.15- , binary-parser >=0.5.5 && <0.6- , bytestring >=0.10.8 && <0.11- , bytestring-strict-builder >=0.4.5 && <0.5- , contravariant >=1.4.1 && <1.6- , free >=5.0.2 && <5.2- , mtl >=2.2.2 && <2.3- , postgresql-binary >=0.12.1 && <0.13- , postgresql-libpq >=0.9.4 && <0.10+ aeson >=1.4.7.1 && <1.5.6+ , array >=0.5.4.0 && <0.5.5+ , base >=4.13.0.0 && <4.15+ , binary-parser >=0.5.6 && <0.6+ , bytestring >=0.10.10.0 && <0.10.13+ , bytestring-strict-builder >=0.4.5.3 && <0.4.6+ , containers >=0.6.2.1+ , contravariant >=1.5.2 && <1.5.4+ , generic-random <1.3.1+ , hedgehog >=1.0.3+ , mtl >=2.2.2 && <2.2.3+ , postgresql-binary >=0.12.2 && <0.12.4+ , postgresql-libpq >=0.9.4.2 && <0.9.5 , preql- , scientific >=0.3.6 && <0.4- , tasty >=1.1 && <1.4- , tasty-hunit >=0.10 && <0.11- , template-haskell >=2.13.0 && <2.17- , text >=1.2.3 && <1.3- , th-lift-instances >=0.1.11 && <0.2- , time >=1.8.0 && <1.10- , transformers >=0.5.5 && <0.6- , uuid >=1.3.13 && <1.4- , vector >=0.12.0 && <0.13+ , scientific >=0.3.6.2 && <0.3.7+ , syb >=0.7.1 && <0.7.2+ , tasty >=1.2.3 && <1.4.1+ , tasty-hedgehog >=1.0+ , tasty-hunit >=0.10.0 && <0.10.1+ , template-haskell >=2.15.0.0 && <2.17+ , text >=1.2.3.2 && <1.2.5+ , th-lift-instances >=0.1.17 && <0.1.19+ , time >=1.9.3 && <1.9.4+ , transformers >=0.5.6.2 && <0.5.7+ , uuid >=1.3.13 && <1.3.14+ , vector >=0.12.1.2 && <0.12.2+ , vector-sized >=1.4.1 && <1.4.4 default-language: Haskell2010
src/Preql.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+-- | Description: Import this to start module Preql (- SQL(..), sql+ SQL(..), SqlQuery(..), sql, select, validSql , Transaction, Query -- * functions for writing SQL instances , runTransactionIO@@ -14,6 +15,7 @@ , module Preql.Wire ) where -import Preql.Wire-import Preql.QuasiQuoter.Raw.TH (sql) import Preql.Effect+import Preql.QuasiQuoter.Raw.TH (sql)+import Preql.QuasiQuoter.Syntax.TH (select, validSql)+import Preql.Wire
src/Preql/Effect.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-} --- | SQL Effect class, basically capturing some way of accessing a database.+-- | Description: SQL & SqlQuery classes+--+-- Effect class, expressing that a database connection is available or+-- can be acquired, and transactions run. module Preql.Effect ( module Preql.Effect, Transaction@@ -21,10 +25,11 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT) import Database.PostgreSQL.LibPQ (Connection)-import qualified Control.Monad.Trans.State.Lazy as SL-import qualified Control.Monad.Trans.State.Strict as SS+import GHC.TypeNats import qualified Control.Monad.Trans.RWS.Lazy as L import qualified Control.Monad.Trans.RWS.Strict as S+import qualified Control.Monad.Trans.State.Lazy as SL+import qualified Control.Monad.Trans.State.Strict as SS import qualified Preql.Wire.Query as W @@ -50,12 +55,14 @@ withConnection :: (Connection -> m a) -> m a -- | Run a query on the specified 'Connection'- queryOn :: (ToSql p, FromSql r) => Connection -> (Query, p) -> m (Vector r)- default queryOn :: (ToSql p, FromSql r, MonadIO m) => Connection -> (Query, p) -> m (Vector r)+ queryOn :: (ToSql p, FromSql r, KnownNat (Width r)) =>+ Connection -> (Query (Width r), p) -> m (Vector r)+ default queryOn :: (ToSql p, FromSql r, KnownNat (Width r), MonadIO m) =>+ Connection -> (Query (Width r), p) -> m (Vector r) queryOn conn (q, p) = liftIO $ either throwIO pure =<< W.query conn q p - queryOn_ :: ToSql p => Connection -> (Query, p) -> m ()- default queryOn_ :: (ToSql p, MonadIO m) => Connection -> (Query, p) -> m ()+ queryOn_ :: ToSql p => Connection -> (Query 0, p) -> m ()+ default queryOn_ :: (ToSql p, MonadIO m) => Connection -> (Query 0, p) -> m () queryOn_ conn (q, p) = liftIO $ either throwIO pure =<< W.query_ conn q p -- | Run a Transaction with full Serializable isolation.@@ -71,11 +78,11 @@ -- implies a @SqlQuery@ instance. class Monad m => SqlQuery (m :: * -> *) where -- | Run a parameterized query that returns data. The tuple argument is typically provided by- -- the 'sql' Quasiquoter.- query :: (ToSql p, FromSql r) => (Query, p) -> m (Vector r)+ -- one of the Quasiquoters: 'Preql.sql' or 'Preql.select'+ query :: (ToSql p, FromSql r, KnownNat (Width r)) => (Query (Width r), p) -> m (Vector r) -- | Run a parameterized query that does not return data.- query_ :: ToSql p => (Query, p) -> m ()+ query_ :: ToSql p => (Query 0, p) -> m () -- | Most larger applications will define an instance; this one is suitable to test out the library. instance SQL (ReaderT Connection IO) where@@ -93,12 +100,10 @@ either throwIO pure =<< W.begin conn level e_a <- runReaderT (runExceptT m) conn void $ case e_a of- Left _ -> W.rollback conn+ Left _ -> W.rollback conn Right _ -> W.commit conn return e_a --- | The same @query@ methods can be used within a @Transaction@.--- Nested @Transactions@ are implemented using savepoints. instance SqlQuery Transaction where query (q, p) = Transaction (ExceptT (ReaderT (\conn -> W.query conn q p))) query_ (q, p) = Transaction (ExceptT (ReaderT (\conn -> W.query_ conn q p)))
+ src/Preql/FromSql.hs view
@@ -0,0 +1,7 @@+-- | re-export Preql.FromSql.*++module Preql.FromSql (module X) where++import Preql.FromSql.Class as X+import Preql.FromSql.Instances as X+import Preql.FromSql.TH as X
+ src/Preql/FromSql/Class.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeFamilies #-}++module Preql.FromSql.Class where++import Preql.Wire.Errors+import Preql.Wire.Internal++import Control.Monad.Except+import Control.Monad.Trans.State+import GHC.TypeNats+import qualified BinaryParser as BP+import qualified Data.Vector.Sized as VS+import qualified Database.PostgreSQL.LibPQ as PQ++-- | A @FieldDecoder@ for a type @a@ consists of an OID indicating the+-- Postgres type which can be decoded, and a parser from the binary+-- representation of that type to the Haskell representation.+data FieldDecoder a = FieldDecoder PgType (BP.BinaryParser a)+ deriving Functor++class FromSqlField a where+ fromSqlField :: FieldDecoder a++-- | A type which can be decoded from a SQL row. Note that this+-- includes the canonical order of fields.+--+-- The default (empty) instance works for any type with a+-- 'FromSqlField' instance+class FromSql a where+ -- | The number of columns read in decoding this type.+ type Width a :: Nat+ type Width a = 1+ fromSql :: RowDecoder (Width a) a+ default fromSql :: (FromSqlField a, Width a ~ 1) => RowDecoder (Width a) a+ fromSql = notNull fromSqlField++-- | Construct a decoder for a single non-nullable column.+notNull :: FieldDecoder a -> RowDecoder 1 a+notNull (FieldDecoder oid parser) = RowDecoder (VS.singleton oid) $ do+ m_bs <- getNextValue+ case m_bs of+ Nothing -> throwLocated UnexpectedNull+ Just bs -> either (throwLocated . ParseFailure) pure (BP.run parser bs)++-- | Construct a decoder for a single nullable column.+nullable :: FieldDecoder a -> RowDecoder 1 (Maybe a)+nullable (FieldDecoder oid parser) = RowDecoder (VS.singleton oid) $ do+ m_bs <- getNextValue+ case m_bs of+ Nothing -> return Nothing+ Just bs -> either (throwLocated . ParseFailure) (pure . Just) (BP.run parser bs)++throwLocated :: UnlocatedFieldError -> InternalDecoder a+throwLocated fieldError = do+ DecoderState{row = PQ.Row r, column = PQ.Col c} <- get+ throwError (FieldError (fromIntegral r) (fromIntegral c) fieldError)
+ src/Preql/FromSql/Instances.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}++module Preql.FromSql.Instances where++import Preql.FromSql.Class+import Preql.FromSql.TH+import Preql.Wire.Errors+import Preql.Wire.Internal (applyDecoder)+import Preql.Wire.Types++import Data.Int+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.UUID (UUID)+import GHC.TypeNats+import Preql.Imports+import qualified BinaryParser as BP+import qualified Data.Aeson as JSON+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified PostgreSQL.Binary.Decoding as PGB+import qualified Preql.Wire.TypeInfo.Static as OID++instance FromSqlField Bool where+ fromSqlField = FieldDecoder (Oid OID.boolOid) PGB.bool+instance FromSql Bool++instance FromSqlField Int16 where+ fromSqlField = FieldDecoder (Oid OID.int2Oid) PGB.int+instance FromSql Int16++instance FromSqlField Int32 where+ fromSqlField = FieldDecoder (Oid OID.int4Oid) PGB.int+instance FromSql Int32++instance FromSqlField Int64 where+ fromSqlField = FieldDecoder (Oid OID.int8Oid) PGB.int+instance FromSql Int64++instance FromSqlField Float where+ fromSqlField = FieldDecoder (Oid OID.float4Oid) PGB.float4+instance FromSql Float++instance FromSqlField Double where+ fromSqlField = FieldDecoder (Oid OID.float8Oid) PGB.float8+instance FromSql Double++-- TODO does Postgres have a single-char type? Does it always return bpchar?+-- instance FromSqlField Char where+-- fromSqlField = FieldDecoder (Oid OID.charOid) PGB.char+-- instance FromSql Char++instance FromSqlField String where+ fromSqlField = FieldDecoder (Oid OID.textOid) (T.unpack <$> PGB.text_strict)+instance FromSql String++instance FromSqlField Text where+ fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_strict+instance FromSql Text++instance FromSqlField TL.Text where+ fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_lazy+instance FromSql TL.Text++-- | If you want to encode some more specific Haskell type via JSON,+-- it is more efficient to use 'Data.Aeson.encode' and+-- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this+-- instance.+instance FromSqlField ByteString where+ fromSqlField = FieldDecoder (Oid OID.byteaOid) (BS.copy <$> BP.remainders)+instance FromSql ByteString++instance FromSqlField BSL.ByteString where+ fromSqlField = FieldDecoder (Oid OID.byteaOid) (BSL.fromStrict . BS.copy <$> BP.remainders)+instance FromSql BSL.ByteString++-- TODO check for integer_datetimes setting+instance FromSqlField UTCTime where+ fromSqlField = FieldDecoder (Oid OID.timestamptzOid) PGB.timestamptz_int+instance FromSql UTCTime++instance FromSqlField Day where+ fromSqlField = FieldDecoder (Oid OID.dateOid) PGB.date+instance FromSql Day++instance FromSqlField TimeOfDay where+ fromSqlField = FieldDecoder (Oid OID.timeOid) PGB.time_int+instance FromSql TimeOfDay++instance FromSqlField TimeTZ where+ fromSqlField = FieldDecoder (Oid OID.timetzOid) (uncurry TimeTZ <$> PGB.timetz_int)+instance FromSql TimeTZ++instance FromSqlField UUID where+ fromSqlField = FieldDecoder (Oid OID.uuidOid) PGB.uuid+instance FromSql UUID++instance FromSqlField PQ.Oid where+ fromSqlField = PQ.Oid <$> FieldDecoder (Oid OID.oidOid) PGB.int+instance FromSql PQ.Oid++-- | If you want to encode some more specific Haskell type via JSON,+-- it is more efficient to use 'fromSqlJsonField' rather than this+-- instance.+instance FromSqlField JSON.Value where+ fromSqlField = FieldDecoder (Oid OID.jsonbOid) PGB.jsonb_ast+instance FromSql JSON.Value++fromSqlJsonField :: JSON.FromJSON a => FieldDecoder a+fromSqlJsonField = FieldDecoder (Oid OID.jsonbOid)+ (PGB.jsonb_bytes (first T.pack . JSON.eitherDecode . BSL.fromStrict))++-- Overlappable so applications can write Maybe for multi-field domain types+instance {-# OVERLAPPABLE #-} FromSqlField a => FromSql (Maybe a) where+ fromSql = nullable fromSqlField++instance (FromSql a, FromSql b) => FromSql (a, b) where+ type Width (a, b) = Width a + Width b+ fromSql = ((,) <$> fromSql) `applyDecoder` fromSql++instance (FromSql a, FromSql b, FromSql c) => FromSql (a, b, c) where+ type Width (a, b, c) = (Width a + Width b) + Width c+ fromSql = ((,,) <$> fromSql) `applyDecoder` fromSql `applyDecoder` fromSql++-- The instances below all follow the pattern laid out by the tuple+-- instances above. The ones above are written out without the macro+-- to illustrate the pattern.++$(deriveFromSqlTuple 4)+$(deriveFromSqlTuple 5)+$(deriveFromSqlTuple 6)+$(deriveFromSqlTuple 7)+$(deriveFromSqlTuple 8)+$(deriveFromSqlTuple 9)+$(deriveFromSqlTuple 10)+$(deriveFromSqlTuple 11)+$(deriveFromSqlTuple 12)+$(deriveFromSqlTuple 13)+$(deriveFromSqlTuple 14)+$(deriveFromSqlTuple 15)+$(deriveFromSqlTuple 16)+$(deriveFromSqlTuple 17)+$(deriveFromSqlTuple 18)+$(deriveFromSqlTuple 19)+$(deriveFromSqlTuple 20)+$(deriveFromSqlTuple 21)+$(deriveFromSqlTuple 22)+$(deriveFromSqlTuple 23)+$(deriveFromSqlTuple 24)+$(deriveFromSqlTuple 25)
+ src/Preql/FromSql/TH.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Construct FromSql instances++module Preql.FromSql.TH where++import Preql.FromSql.Class+import Preql.QuasiQuoter.Common (alphabet)+import Preql.Wire.Internal++import GHC.TypeNats+import Language.Haskell.TH++deriveFromSqlTuple :: Int -> Q [Dec]+deriveFromSqlTuple n = do+ names <- traverse newName (take n alphabet)+ let tuple = foldl AppT (TupleT n) (map VarT names)+ return [fromSqlDecl names tuple (tupleDataName n) n]++deriveFromSql :: Name -> Q [Dec]+deriveFromSql tyName = do+ info <- reify tyName+ case info of+ TyConI (DataD _cxt typeN binders _kind constructors _deriving) ->+ let+ tyVars = map tyVarName binders+ targetTy = foldl AppT (VarT typeN) (map VarT tyVars)+ (conN, fieldCount) = case constructors of+ [NormalC con elems] -> (con, length elems)+ [RecC con fields] -> (con, length fields)+ [InfixC _ con _] -> (con, 2)+ [_] -> error "deriveFromSql does not handle GADTs or constructors with class constraints"+ _ -> error "deriveFromSql does not handle sum types"+ in return [fromSqlDecl tyVars targetTy conN fieldCount]+ _ -> error ("deriveFromSql only handles type names, got: " ++ show tyName)++tyVarName :: TyVarBndr -> Name+tyVarName = \case+ PlainTV name -> name+ KindedTV name _k -> name+++fromSqlDecl :: [Name] -> Type -> Name -> Int -> Dec+fromSqlDecl tyVars targetTy constructor fieldCount =+ InstanceD Nothing context instanceHead [TySynInstD width, method] where+ context = [ ConT ''FromSql `AppT` VarT n | n <- tyVars ]+ instanceHead = ConT ''FromSql `AppT` targetTy+ width = TySynEqn Nothing+ (ConT ''Width `AppT` targetTy)+ (foldl (\a b -> ConT ''(+) `AppT` a `AppT` b) (LitT (NumTyLit 0))+ [ ConT ''Width `AppT` VarT n | n <- tyVars ])+ method = ValD+ (VarP 'fromSql)+ (NormalB (foldl+ (\rowDecoder field -> InfixE (Just rowDecoder) (VarE 'applyDecoder) (Just field))+ (VarE 'pureDecoder `AppE` ConE constructor)+ (replicate fieldCount (VarE 'fromSql))))+ [] -- no where clause on the fromSql definition
src/Preql/Imports.hs view
@@ -10,9 +10,11 @@ import Control.Applicative as X import Control.Exception as X (Exception)-import Control.Monad.IO.Class as X (liftIO, MonadIO)+import Control.Monad as X+import Control.Monad.IO.Class as X (MonadIO, liftIO) import Data.Bifunctor as X import Data.ByteString (ByteString)+import Data.Foldable as X import Data.Functor as X import Data.Maybe as X (catMaybes, fromMaybe) import Data.Text (Text)
+ src/Preql/QuasiQuoter/Common.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+-- | Description: Functions for defining quasiquoters+-- used in both the SQL-validating quasiquoter and the simple non-validating QQ.++module Preql.QuasiQuoter.Common where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++-- | A list of n Names beginning with the given character+cNames :: Char -> Int -> Q [Name]+cNames c n = traverse newName (replicate n (c : ""))++tupleOrSingle :: [Name] -> Exp+tupleOrSingle names = case names of+ [name] -> VarE name+ vs -> tupleE $ map VarE vs++expressionOnly :: String -> (String -> Q Exp) -> QuasiQuoter+expressionOnly name qq = QuasiQuoter+ { quoteExp = qq+ , quotePat = \_ -> error $ "qq " ++ name ++ " cannot be used in pattern context"+ , quoteType = \_ -> error $ "qq " ++ name ++ " cannot be used in type context"+ , quoteDec = \_ -> error $ "qq " ++ name ++ " cannot be used in declaration context"+ }++alphabet :: [String]+alphabet = cycle (map (:"") ['a'..'z'])++tupleE :: [Exp] -> Exp+#if MIN_VERSION_template_haskell(2,16,0)+tupleE = TupE . map Just+#else+tupleE = TupE+#endif
src/Preql/QuasiQuoter/Raw/Lex.x view
@@ -1,4 +1,5 @@ {+-- | Description: Parse antiquotes without validating SQL syntax module Preql.QuasiQuoter.Raw.Lex where import Prelude hiding (LT, GT, lex)@@ -67,7 +68,7 @@ AlexEOF -> alexEOF AlexError (p, _, _, s) -> alexError' p ("lexical error at character '" ++ take 1 s ++ "'")- AlexSkip inp' len -> do+ AlexSkip inp' _len -> do alexSetInput inp' alexMonadScan' AlexToken inp' len action -> do@@ -91,10 +92,10 @@ lexAll :: Alex [LocToken] lexAll = do- token <- alexMonadScan- case unLoc token of- EOF -> return [token]- _ -> fmap (token :) lexAll+ t <- alexMonadScan+ case unLoc t of+ EOF -> return [t]+ _ -> fmap (t :) lexAll parseQuery' :: FilePath -> String -> Either String [LocToken] parseQuery' fp s = runAlex' lexAll fp s
src/Preql/QuasiQuoter/Raw/TH.hs view
@@ -1,29 +1,20 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} module Preql.QuasiQuoter.Raw.TH where -import Preql.QuasiQuoter.Raw.Lex (Token(..), unLex, parseQuery)-import Preql.Wire (Query(..))--import Data.String (IsString (..))-import Data.Word (Word)-import Language.Haskell.TH-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax (Lift (..))--import qualified Data.Text as T+import Preql.QuasiQuoter.Common+import Preql.QuasiQuoter.Raw.Lex (Token(..), parseQuery, unLex)+import Preql.Wire (Query) --- | A list of n Names beginning with the given character-cNames :: Char -> Int -> Q [Name]-cNames c n = traverse newName (replicate n (c : ""))+import Data.String (IsString(..))+import Language.Haskell.TH+import Language.Haskell.TH.Quote --- | Convert a rewritten SQL string to a ByteString+-- | Convert a rewritten SQL string to a ByteString, leaving width free makeQuery :: String -> Q Exp-makeQuery string = [e|(fromString string :: Query) |]+makeQuery string = [e|(fromString string :: Query $(VarT <$> (newName "n"))) |] -- | Given a SQL query with ${} antiquotes, splice a pair @(Query -- p r, p)@ or a function @\p' -> (Query p r, p)@ if the SQL@@ -48,7 +39,7 @@ -- @(Query, p)@ where p includes both named & numbered params. For example: -- @\a -> ("SELECT name, age FROM cats WHERE age >= $1 and age < $2", (a, maxAge))@ sql :: QuasiQuoter-sql = expressionOnly "aritySql " $ \raw -> do+sql = expressionOnly "sql " $ \raw -> do loc <- location let e_ast = parseQuery (show loc) raw case e_ast of@@ -73,42 +64,22 @@ (tupleE [query, tupleOrSingle (patternNames ++ antiNames)]) Left err -> error err -tupleOrSingle :: [Name] -> Exp-tupleOrSingle names = case names of- [name] -> VarE name- vs -> tupleE $ map VarE vs--expressionOnly :: String -> (String -> Q Exp) -> QuasiQuoter-expressionOnly name qq = QuasiQuoter- { quoteExp = qq- , quotePat = \_ -> error $ "qq " ++ name ++ " cannot be used in pattern context"- , quoteType = \_ -> error $ "qq " ++ name ++ " cannot be used in type context"- , quoteDec = \_ -> error $ "qq " ++ name ++ " cannot be used in declaration context"- }- maxParam :: [Token] -> Word maxParam = foldr nextParam 0 where- nextParam token maxParam =+ nextParam token maxSoFar = case token of- NumberedParam i -> max i maxParam- _ -> maxParam+ NumberedParam i -> max i maxSoFar+ _ -> maxSoFar numberAntiquotes :: Word -> [Token] -> (String, [String])-numberAntiquotes mp ts = (concat sqlStrings, variableNames) where- (sqlStrings, variableNames) = go mp ts- go _maxParam [] = ([], [])- go maxParam (token : ts) =+numberAntiquotes mp tokens = (concat sqlStrings, variableNames) where+ (sqlStrings, variableNames) = go mp tokens+ go _maxSoFar [] = ([], [])+ go maxSoFar (token : ts) = case token of HaskellParam name -> let- newParam = maxParam + 1+ newParam = maxSoFar + 1 (ss, ns) = go newParam ts in (unLex (NumberedParam newParam) : ss, name : ns)- EOF -> go maxParam ts- _ -> let (ss, ns) = go maxParam ts in (unLex token : ss, ns)--tupleE :: [Exp] -> Exp-#if MIN_VERSION_template_haskell(2,16,0)-tupleE = TupE . fmap Just-#else-tupleE = TupE-#endif+ EOF -> go maxSoFar ts+ _ -> let (ss, ns) = go maxSoFar ts in (unLex token : ss, ns)
+ src/Preql/QuasiQuoter/Syntax/Lex.x view
@@ -0,0 +1,344 @@+{+module Preql.QuasiQuoter.Syntax.Lex where++import Data.Text (Text)+import Data.Word (Word)+import Prelude hiding (LT, GT, lex)++import qualified Data.Text as T++}++%wrapper "monadUserState"++$unicodeIds = $printable # [$white \,\.\;\'\"\(\)\<\>=\+\-\^\!@]+$firstLetter = $unicodeIds # [0-9_\$]+$quoted = $printable # [\']+$digit = [0-9]+$haskell = $printable # [\}]+$a = [aA]+$b = [bB]+$c = [cC]+$d = [dD]+$e = [eE]+$f = [fF]+$g = [gG]+$h = [hH]+$i = [iI]+$j = [jJ]+$k = [kK]+$l = [lL]+$m = [mM]+$n = [nN]+$o = [oO]+$p = [pP]+$q = [qQ]+$r = [rR]+$s = [sS]+$t = [tT]+$u = [uU]+$v = [vV]+$w = [wW]+$x = [xX]+$y = [yY]+$z = [zZ]++tokens :-++ $white+ ;++ $a $l $l { lex ALL }+ $a $n $d { lex AND }+ $a $s $c { lex ASC }+ $a $s { lex AS }+ $b $y { lex BY }+ $c $a $s $e { lex CASE }+ $c $o $a $l $e $s $c $e { lex COALESCE }+ $c $r $o $s $s { lex CROSS }+ $d $e $l $e $t $e { lex DELETE_P }+ $d $e $s $c { lex DESC }+ $d $i $s $t $i $n $c $t { lex DISTINCT }+ $e $l $s $e { lex ELSE }+ $e $n $d { lex END_P }+ $e $s $c $a $p $e { lex ESCAPE }+ $e $x $c $e $p $t { lex EXCEPT }+ $f $a $l $s $e { lex FALSE_P }+ $f $i $l $t $e $r { lex FILTER }+ $f $i $r $s $t { lex First }+ $f $o $r { lex FOR }+ $f $r $o $m { lex FROM }+ $f $u $l $l { lex FULL }+ $g $r $e $a $t $e $s $t { lex GREATEST }+ $g $r $o $u $p { lex GROUP_P }+ $h $a $v $i $n $g { lex HAVING }+ $i $l $i $k $e { lex ILIKE }+ $i $n $n $e $r { lex INNER_P }+ $i $n $s $e $r $t { lex INSERT }+ $i $n $t $e $r $s $e $c $t { lex INTERSECT }+ $i $n $t $o { lex INTO }+ $i $s $n $u $l $l { lex ISNULL }+ $i $s { lex IS }+ $j $o $i $n { lex JOIN }+ $k $e $y { lex KEY }+ $l $a $s $t { lex LAST }+ $l $e $a $s $t { lex LEAST }+ $l $e $f $t { lex LEFT }+ $l $i $k $e { lex LIKE }+ $l $i $m $i $t { lex LIMIT }+ $l $o $c $k $e $d { lex LOCKED }+ $m $a $t $e $r $i $a $l $i $z $e $d { lex MATERIALIZED }+ $n $a $t $u $r $a $l { lex NATURAL }+ $n $o $t $n $u $l $l { lex NOTNULL }+ $n $o $t { lex NOT }+ $n $o $w $a $i $t { lex NOWAIT }+ $n $o { lex NO }+ $n $u $l $l $s { lex Nulls }+ $n $u $l $l { lex NULL_P }+ $o $f $f $s $e $t { lex OFFSET }+ $o $f { lex OF }+ $o $n { lex ON }+ $o $p $e $r $a $t $o $r { lex OPERATOR }+ $o $r $d $e $r { lex ORDER }+ $o $r { lex OR }+ $o $v $e $r { lex OVER }+ $p $a $r $t $i $t $i $o $n { lex PARTITION }+ $r $e $c $u $r $s $i $v $e { lex RECURSIVE }+ $r $i $g $h $t { lex RIGHT }+ $s $e $l $e $c $t { lex SELECT }+ $s $e $t { lex SET }+ $s $h $a $r $e { lex SHARE }+ $s $i $m $i $l $a $r { lex SIMILAR }+ $s $k $i $p { lex SKIP }+ $t $a $b $l $e { lex TABLE }+ $t $h $e $n { lex THEN }+ $t $o { lex TO }+ $t $r $u $e { lex TRUE_P }+ $u $n $i $o $n { lex UNION }+ $u $p $d $a $t $e { lex UPDATE }+ $u $s $i $n $g { lex USING }+ $v $a $l $u $e $s { lex VALUES }+ $w $h $e $n { lex WHEN }+ $w $h $e $r $e { lex WHERE }+ $w $i $t $h $i $n { lex WITHIN }+ $w $i $t $h { lex WITH }++ "(" { lex LParen }+ "," { lex Comma }+ ")" { lex RParen }+ "." { lex Dot }+ "*" { lex Mul }+ "/" { lex Div }+ "%" { lex Mod }+ "+" { lex Add }+ "-" { lex Sub }+ "^" { lex Exponent }+ "<>" { lex NotEquals }+ "!=" { lex NotEquals }+ "<" { lex LT }+ "<=" { lex LTE }+ ">" { lex GT }+ ">=" { lex GTE }+ "=" { lex Equals }+ ":=" {lex COLON_EQUALS }+ "=>" { lex EQUALS_GREATER }++ [\'] ("''" | $quoted)* [\'] { lex' (String . T.pack . unquoteString) }+ $firstLetter $unicodeIds* { lex' (Name . T.pack) }++ $digit+ { lex' (Iconst . read) } -- positive only?+ $digit+ ("." $digit+) { lex' (Fconst . read) }+ $digit+ ("." $digit+)? ($e "-"? $digit+) { lex' (Fconst . read) }++ "$" $digit+ { lex' (NumberedParam . read . tail) }+ "${" $haskell+ "}" { lex' (HaskellParam . T.pack . init . drop 2) }+ ";" { lex Semicolon }++{++data LocToken = LocToken+ { loc :: AlexPosn+ , unLoc :: Token+ } deriving Show++-- commented out PascallCase, where I've added CAPS+data Token = -- Delete | Select | Insert+ Nulls | First+ -- TODO rename Name -> Ident to match bison+ | Name Text | String Text | Iconst Word | Fconst Double+ | NumberedParam Word | HaskellParam Text+ | LParen | RParen | Comma+ | Mul | Div | Add | Sub | Mod | Exponent+ | Equals | NotEquals | LT | LTE | GT | GTE+ | Dot | Semicolon | EOF+ | COLON_EQUALS | EQUALS_GREATER+ -- all the keywords, from bison+ | ABORT_P | AUTHORIZATION | BETWEEN | ABSOLUTE_P | ACCESS | ACTION | ADD_P+ | ADMIN | AFTER | AGGREGATE | ALL | ALSO | ALTER | ALWAYS | ANALYSE | ANALYZE | AND+ | ANY | ARRAY | AS | ASC | ASSERTION | ASSIGNMENT | ASYMMETRIC | AT | ATTACH+ | ATTRIBUTE | BACKWARD | BEFORE | BEGIN_P | BIGINT | BINARY | BIT | BOOLEAN_P+ | BOTH | BY | CACHE | CALL | CALLED | CASCADE | CASCADED | CASE | CAST | CATALOG_P+ | CHAIN | CHARACTER | CHARACTERISTICS | CHAR_P | CHECK | CHECKPOINT | CLASS+ | CLOSE | CLUSTER | COALESCE | COLLATE | COLLATION | COLUMN | COLUMNS | COMMENT+ | COMMENTS | COMMIT | COMMITTED | CONCURRENTLY | CONFIGURATION | CONFLICT+ | CONNECTION | CONSTRAINT | CONSTRAINTS | CONTENT_P | CONTINUE_P+ | CONVERSION_P | COPY | COST | CREATE | CROSS | CSV | CUBE | CURRENT_CATALOG+ | CURRENT_DATE | CURRENT_P | CURRENT_ROLE | CURRENT_SCHEMA | CURRENT_TIME+ | CURRENT_TIMESTAMP | CURRENT_USER | CURSOR | CYCLE | DATABASE | DATA_P+ | DAY_P | DEALLOCATE | DEC | DECIMAL_P | DECLARE | DEFAULT | DEFAULTS+ | DEFERRABLE | DEFERRED | DEFINER | DELETE_P | DELIMITER | DELIMITERS+ | DEPENDS | DESC | DETACH | DICTIONARY | DISABLE_P | DISCARD | DISTINCT | DO+ | DOCUMENT_P | DOMAIN_P | DOUBLE_P | DROP | EACH | ELSE | ENABLE_P | ENCODING+ | ENCRYPTED | END_P | ENUM_P | ESCAPE | EVENT | EXCEPT | EXCLUDE | EXCLUDING+ | EXCLUSIVE | EXECUTE | EXISTS | EXPLAIN | EXTENSION | EXTERNAL | EXTRACT+ | FALSE_P | FAMILY | FETCH | FILTER | FIRST_P | FLOAT_P | FOLLOWING | FOR | FORCE+ | FOREIGN | FORWARD | FREEZE | FROM | FULL | FUNCTION | FUNCTIONS | GENERATED+ | GLOBAL | GRANT | GRANTED | GREATEST | GROUPING | GROUPS | GROUP_P | HANDLER+ | HAVING | HEADER_P | HOLD | HOUR_P | IDENTITY_P | IF_P | ILIKE | IMMEDIATE+ | IMMUTABLE | IMPLICIT_P | IMPORT_P | INCLUDE | INCLUDING | INCREMENT | INDEX+ | INDEXES | INHERIT | INHERITS | INITIALLY | INLINE_P | INNER_P | INOUT+ | INPUT_P | INSENSITIVE | INSERT | INSTEAD | INTEGER | INTERSECT | INTERVAL+ | INTO | INT_P | INVOKER | IN_P | IS | ISNULL | ISOLATION | JOIN | KEY | LABEL+ | LANGUAGE | LARGE_P | LAST | LATERAL_P | LEADING | LEAKPROOF | LEAST | LEFT+ | LEVEL | LIKE | LIMIT | LISTEN | LOAD | LOCAL | LOCALTIME | LOCALTIMESTAMP+ | LOCATION | LOCKED | LOCK_P | LOGGED | MAPPING | MATCH | MATERIALIZED+ | MAXVALUE | METHOD | MINUTE_P | MINVALUE | MODE | MONTH_P | MOVE | NAMES+ | NAME_P | NATIONAL | NATURAL | NCHAR | NEW | NEXT | NO | NONE | NOT | NOTHING+ | NOTIFY | NOTNULL | NOWAIT | NULLIF | NULLS_P | NULL_P | NUMERIC | OBJECT_P | OF+ | OFF | OFFSET | OIDS | OLD | ON | ONLY | OPERATOR | OPTION | OPTIONS | OR | ORDER+ | ORDINALITY | OTHERS | OUTER_P | OUT_P | OVER | OVERLAPS | OVERLAY+ | OVERRIDING | OWNED | OWNER | PARALLEL | PARSER | PARTIAL | PARTITION+ | PASSING | PASSWORD | PLACING | PLANS | POLICY | POSITION | PRECEDING+ | PRECISION | PREPARE | PREPARED | PRESERVE | PRIMARY | PRIOR | PRIVILEGES+ | PROCEDURAL | PROCEDURE | PROCEDURES | PROGRAM | PUBLICATION | QUOTE | RANGE+ | READ | REAL | REASSIGN | RECHECK | RECURSIVE | REF | REFERENCES | REFERENCING+ | REFRESH | REINDEX | RELATIVE_P | RELEASE | RENAME | REPEATABLE | REPLACE+ | REPLICA | RESET | RESTART | RESTRICT | RETURNING | RETURNS | REVOKE | RIGHT+ | ROLE | ROLLBACK | ROLLUP | ROUTINE | ROUTINES | ROW | ROWS | RULE | SAVEPOINT+ | SCHEMA | SCHEMAS | SCROLL | SEARCH | SECOND_P | SECURITY | SELECT | SEQUENCE+ | SEQUENCES | SERIALIZABLE | SERVER | SESSION | SESSION_USER | SET | SETOF+ | SETS | SHARE | SHOW | SIMILAR | SIMPLE | SKIP | SMALLINT | SNAPSHOT | SOME+ | SQL_P | STABLE | STANDALONE_P | START | STATEMENT | STATISTICS | STDIN+ | STDOUT | STORAGE | STORED | STRICT_P | STRIP_P | SUBSCRIPTION | SUBSTRING+ | SUPPORT | SYMMETRIC | SYSID | SYSTEM_P | TABLE | TABLES | TABLESAMPLE+ | TABLESPACE | TEMP | TEMPLATE | TEMPORARY | TEXT_P | THEN | TIES | TIME+ | TIMESTAMP | TO | TRAILING | TRANSACTION | TRANSFORM | TREAT | TRIGGER | TRIM+ | TRUE_P | TRUNCATE | TRUSTED | TYPES_P | TYPE_P | UNBOUNDED | UNCOMMITTED+ | UNENCRYPTED | UNION | UNIQUE | UNKNOWN | UNLISTEN | UNLOGGED | UNTIL | UPDATE+ | USER | USING | VACUUM | VALID | VALIDATE | VALIDATOR | VALUES | VALUE_P+ | VARCHAR | VARIADIC | VARYING | VERBOSE | VERSION_P | VIEW | VIEWS+ | VOLATILE | WHEN | WHERE | WHITESPACE_P | WINDOW | WITH | WITHIN+ | WITHOUT | WORK | WRAPPER | WRITE | XMLATTRIBUTES | XMLCONCAT+ | XMLELEMENT | XMLEXISTS | XMLFOREST | XMLNAMESPACES | XMLPARSE+ | XMLPI | XMLROOT | XMLSERIALIZE | XMLTABLE | XML_P | YEAR_P+ | YES_P | ZONE++ deriving (Show, Read, Eq, Ord)++/* from https://github.com/dagit/happy-plus-alex/blob/master/src/Lexer.x */++-- To improve error messages, We keep the path of the file we are+-- lexing in our own state.+data AlexUserState = AlexUserState { filePath :: FilePath }++alexInitUserState :: AlexUserState+alexInitUserState = AlexUserState "<unknown>"++getFilePath :: Alex FilePath+getFilePath = filePath <$> alexGetUserState++setFilePath :: FilePath -> Alex ()+setFilePath = alexSetUserState . AlexUserState++-- For nice parser error messages.+unLex :: Token -> String+unLex t = case t of+ Name n -> T.unpack n + String s -> T.unpack s+ Iconst n -> show n+ Fconst n -> show n+ NumberedParam i -> '$' : show i+ HaskellParam s -> "${" ++ T.unpack s ++ "}"+ LParen -> "("+ RParen -> ")"+ Comma -> ","+ Mul -> "*"+ Div -> "/"+ Add -> "+"+ Sub -> "-"+ Exponent -> "^"+ ISNULL -> "IsNull"+ NOTNULL -> "NotNull"+ Equals -> "="+ NotEquals -> "!="+ Semicolon -> ";"+ EOF -> "<EOF>"+ _ -> show t++-- | remove single quotes, and '' escape sequences+unquoteString :: String -> String+unquoteString ('\'' : str) = go str+ where+ go ('\'' : '\'' : rest) = '\'' : go rest+ go ['\''] = ""+ go [] = error "string did not end with a '"+ go ('\'' : _rest) = error "unescaped ' in middle"+ go (c : rest) = c : go rest+unquoteString _ = error "string did not begin with a '"++alexEOF :: Alex LocToken+alexEOF = do+ (p,_,_,_) <- alexGetInput+ return $ LocToken p EOF++-- Unfortunately, we have to extract the matching bit of string ourselves...+lex' :: (String -> Token) -> AlexAction LocToken+lex' f = \(p,_,_,s) i -> return $ LocToken p (f (take i s))++-- For constructing tokens that do not depend on the input+lex :: Token -> AlexAction LocToken+lex = lex' . const++-- We rewrite alexMonadScan' to delegate to alexError' when lexing fails+-- (the default implementation just returns an error message).+alexMonadScan' :: Alex LocToken+alexMonadScan' = do+ inp <- alexGetInput+ sc <- alexGetStartCode+ case alexScan inp sc of+ AlexEOF -> alexEOF+ AlexError (p, _, _, s) ->+ alexErrorPosn p ("lexical error at character '" ++ take 1 s ++ "'")+ AlexSkip inp' _len -> do+ alexSetInput inp'+ alexMonadScan'+ AlexToken inp' len action -> do+ alexSetInput inp'+ action (ignorePendingBytes inp) len++-- Signal an error, including a commonly accepted source code position.+alexErrorPosn :: AlexPosn -> String -> Alex a+alexErrorPosn (AlexPn _ l c) msg = do+ fp <- getFilePath+ alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)++instance MonadFail Alex where+ fail = alexError++-- A variant of runAlex, keeping track of the path of the file we are lexing.+runAlexWithFilepath :: Alex a -> FilePath -> String -> Either String a+runAlexWithFilepath a fp input = runAlex input (setFilePath fp >> a)++lexAll :: Alex [LocToken]+lexAll = do+ t <- alexMonadScan+ case unLoc t of+ EOF -> return [t]+ _ -> fmap (t :) lexAll++testLex' :: String -> Either String [LocToken]+testLex' s = runAlex s lexAll++testLex :: String -> Either String [Token]+testLex s = map unLoc <$> testLex' s++}
+ src/Preql/QuasiQuoter/Syntax/Name.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+-- | Definitions which need to be private in order to maintain their invariants.++module Preql.QuasiQuoter.Syntax.Name where++import Data.Data+import Data.String (IsString (..))+import Data.Text (Text)+import GHC.Generics+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax (Lift (..))++import qualified Data.Text as T++newtype Name = Name Text+ deriving (Show, Eq, Ord, Generic, Typeable, Data, Lift)++instance IsString Name where+ fromString = Name . T.pack++-- TODO mkName should enforce valid characters in Name+mkName :: Text -> Name+mkName = Name++getName :: Name -> Text+getName (Name name) = name
+ src/Preql/QuasiQuoter/Syntax/Params.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NamedFieldPuns #-}+-- | Parameter substitution for the Untyped SQL AST.++module Preql.QuasiQuoter.Syntax.Params where++import Preql.QuasiQuoter.Syntax.Syntax++import Control.Monad.Trans.State+import Data.Generics+import Data.Text (Text)++numberAntiquotes :: Word -> Statement -> (Statement, AntiquoteState)+numberAntiquotes count q =+ let (rewritten, aqs) = runState+ (everywhereM (mkM numberAntiquotesExpr) q)+ (AntiquoteState count [])+ in (rewritten, aqs { haskellExpressions = reverse (haskellExpressions aqs) })++numberAntiquotesExpr :: Expr -> State AntiquoteState Expr+numberAntiquotesExpr (HaskellParam txt) = do+ AntiquoteState { paramCount, haskellExpressions } <- get+ let i = paramCount + 1+ put (AntiquoteState i (txt : haskellExpressions))+ return (NumberedParam i)+numberAntiquotesExpr expr = return expr++-- invariant: paramCount = length haskellExpressions+data AntiquoteState = AntiquoteState+ { paramCount :: Word+ , haskellExpressions :: [Text]+ } deriving (Show, Eq, Ord)++initialAntiquoteState :: AntiquoteState+initialAntiquoteState = AntiquoteState 0 []++-- | Return the highest-numbered $1-style parameter.+maxParam :: Statement -> Word+maxParam = everything max (mkQ 0 maxParamExpr)++maxParamExpr :: Expr -> Word+maxParamExpr expr = case expr of+ NumberedParam i -> i+ HaskellParam _ -> 0+ BinOp _ l r -> max (maxParamExpr l) (maxParamExpr r)+ Unary _ e -> maxParamExpr e+ Lit _ -> 0+ CRef _ -> 0+ Indirection e _ -> maxParamExpr e+ SelectExpr stmt -> everything max (mkQ 0 maxParamExpr) stmt+ L likeE -> everything max (mkQ 0 maxParamExpr) likeE+ -- L LikeE {string, likePattern, escape} -> maybe id (max . maxParamExpr) escape+ -- (max (maxParamExpr string) (maxParamExpr likePattern))+ Fun f -> everything max (mkQ 0 maxParamExpr) f+ Cas cas -> everything max (mkQ 0 maxParamExpr) cas
+ src/Preql/QuasiQuoter/Syntax/Parser.y view
@@ -0,0 +1,2832 @@+{+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+module Preql.QuasiQuoter.Syntax.Parser (parseStatement, parseSelect, parseExpr) where++import Preql.QuasiQuoter.Syntax.Syntax+import Preql.QuasiQuoter.Syntax.Name+import Preql.QuasiQuoter.Syntax.Lex (Alex, LocToken(..), Token)++import Prelude hiding (LT, GT, lex)+import Control.Monad (when)+import Data.List.NonEmpty (NonEmpty (..))++import qualified Preql.QuasiQuoter.Syntax.Lex as L+import qualified Data.List.NonEmpty as NE+}++%name parseStatement_ Statement+%name parseSelect_ SelectStmt+%name parseExpr_ a_expr+%tokentype { L.LocToken }+%monad { Alex }+%lexer { lexwrap } { L.LocToken _ L.EOF }+%error { happyError }++ -- * NOTES+ -- * CAPITALS are used to represent terminal symbols.+ -- * non-capitals are used to represent non-terminals.++-- This Haskell port generally follows the convention above, taken from the PostgreSQL bison source.+-- Comments with a leading * are taken from the PostgreSQL source.+-- Unimplemnted parts of the official parser are marked TODO, and generally contain bison & C syntax.++-- * Precedence: lowest to highest+%nonassoc SET -- * see relation_expr_opt_alias+%left UNION EXCEPT+%left INTERSECT+%left OR+%left AND+%right NOT+%nonassoc IS ISNULL NOTNULL -- * IS sets precedence for IS NULL, etc+%nonassoc '<' '>' '=' '!=' '<=' '>='+%nonassoc BETWEEN IN_P LIKE ILIKE SIMILAR NOT_LA+%nonassoc ESCAPE -- * ESCAPE must be just above LIKE/ILIKE/SIMILAR+%left POSTFIXOP -- * dummy for postfix Op rules+-- * To support target_el without AS, we must give IDENT an explicit priority+-- * between POSTFIXOP and Op. We can safely assign the same priority to+-- * various unreserved keywords as needed to resolve ambiguities (this can't+-- * have any bad effects since obviously the keywords will still behave the+-- * same as if they weren't keywords). We need to do this:+-- * for PARTITION, RANGE, ROWS, GROUPS to support opt_existing_window_name;+-- * for RANGE, ROWS, GROUPS so that they can follow a_expr without creating+-- * postfix-operator problems;+-- * for GENERATED so that it can follow b_expr;+-- * and for NULL so that it can follow b_expr in ColQualList without creating+-- * postfix-operator problems.+-- *+-- * To support CUBE and ROLLUP in GROUP BY without reserving them, we give them+-- * an explicit priority lower than '(', so that a rule with CUBE '(' will shift+-- * rather than reducing a conflicting rule that takes CUBE as a function name.+-- * Using the same precedence as IDENT seems right for the reasons given above.+-- *+-- * The frame_bound productions UNBOUNDED PRECEDING and UNBOUNDED FOLLOWING+-- * are even messier: since UNBOUNDED is an unreserved keyword (per spec!),+-- * there is no principled way to distinguish these from the productions+-- * a_expr PRECEDING/FOLLOWING. We hack this up by giving UNBOUNDED slightly+-- * lower precedence than PRECEDING and FOLLOWING. At present this doesn't+-- * appear to cause UNBOUNDED to be treated differently from other unreserved+-- * keywords anywhere else in the grammar, but it's definitely risky. We can+-- * blame any funny behavior of UNBOUNDED on the SQL standard, though.+%nonassoc UNBOUNDED -- * ideally should have same precedence as IDENT+%nonassoc IDENT GENERATED NULL_P PARTITION RANGE ROWS GROUPS PRECEDING FOLLOWING CUBE ROLLUP+%left Op OPERATOR -- * multi-character ops and user-defined operators+%left '+' '-'+%left '*' '/' '%'+%left '^'+-- * Unary Operators+%left AT -- * sets precedence for AT TIME ZONE+%left COLLATE+%right UMINUS+%left '[' ']'+%left '(' ')'+%left TYPECAST+%left '.'+-- * These might seem to be low-precedence, but actually they are not part+-- * of the arithmetic hierarchy at all in their use as JOIN operators.+-- * We make them high-precedence to support their use as function names.+-- * They wouldn't be given a precedence at all, were it not that we need+-- * left-associativity among the JOIN rules themselves.+%left JOIN CROSS LEFT FULL RIGHT INNER_P NATURAL+-- * kluge to keep xml_whitespace_option from causing shift/reduce conflicts+%right PRESERVE STRIP_P+++%token+ DELETE { LocToken _ L.DELETE_P }+ SELECT { LocToken _ L.SELECT }+ INSERT { LocToken _ L.INSERT }+ UPDATE { LocToken _ L.UPDATE }++ ASC { LocToken _ L.ASC }+ DESC { LocToken _ L.DESC }+ ORDER { LocToken _ L.ORDER }+ BY { LocToken _ L.BY }+ USING { LocToken _ L.USING }+ OPERATOR { LocToken _ L.OPERATOR }+ NULLS { LocToken _ L.Nulls }+ FIRST { LocToken _ L.First }+ ALL { LocToken _ L.ALL }+ DISTINCT { LocToken _ L.DISTINCT }+ ON { LocToken _ L.ON }+ AS { LocToken _ L.AS }++ UNION { LocToken _ L.UNION }+ EXCEPT { LocToken _ L.EXCEPT }++ FROM { LocToken _ L.FROM }+ WHERE { LocToken _ L.WHERE }+ INTO { LocToken _ L.INTO }+ VALUES { LocToken _ L.VALUES }+ SET { LocToken _ L.SET }+ '(' { LocToken _ L.LParen }+ ',' { LocToken _ L.Comma }+ ')' { LocToken _ L.RParen }+ '.' { LocToken _ L.Dot }++ IDENT { LocToken _ (L.Name $$) }+ STRING { LocToken _ (L.String $$) }+ Iconst { LocToken _ (L.Iconst $$) }+ Fconst { LocToken _ (L.Fconst $$) }+ PARAM { LocToken _ (L.NumberedParam $$) }+ HASKELL_PARAM { LocToken _ (L.HaskellParam $$) }++ '+' { LocToken _ L.Add }+ '-' { LocToken _ L.Sub }+ '*' { LocToken _ L.Mul }+ '/' { LocToken _ L.Div }+ '%' { LocToken _ L.Mod }+ '^' { LocToken _ L.Exponent }++ IS { LocToken _ L.IS }+ ISNULL { LocToken _ L.ISNULL }+ NOTNULL { LocToken _ L.NOTNULL }++ '=' { LocToken _ L.Equals }+ '!=' { LocToken _ L.NotEquals }+ '<' { L.LocToken _ L.LT }+ '>' { L.LocToken _ L.GT }+ '<=' { L.LocToken _ L.LTE }+ '>=' { L.LocToken _ L.GTE }+ NOT { L.LocToken _ L.NOT }+ LIKE { L.LocToken _ L.LIKE }+ ILIKE { L.LocToken _ L.ILIKE }++ AND { LocToken _ L.AND }+ OR { LocToken _ L.OR }++ SEMICOLON { LocToken _ L.Semicolon }++-- Non-keyword token types. These are separate in the bison parser+-- for technical reasons, and here to make coordination with the bison+-- parser easier.+ COLON_EQUALS { L.LocToken _ L.COLON_EQUALS }+ EQUALS_GREATER { L.LocToken _ L.EQUALS_GREATER }++ -- all the keywords not mentioned above, from bison+ ABORT_P { L.LocToken _ L.ABORT_P }+ AUTHORIZATION { L.LocToken _ L.AUTHORIZATION }+ BETWEEN { L.LocToken _ L.BETWEEN }+ ABSOLUTE_P { L.LocToken _ L.ABSOLUTE_P }+ ACCESS { L.LocToken _ L.ACCESS }+ ACTION { L.LocToken _ L.ACTION }+ ADD_P { L.LocToken _ L.ADD_P }+ ADMIN { L.LocToken _ L.ADMIN }+ AFTER { L.LocToken _ L.AFTER }+ AGGREGATE { L.LocToken _ L.AGGREGATE }+ ALSO { L.LocToken _ L.ALSO }+ ALTER { L.LocToken _ L.ALTER }+ ALWAYS { L.LocToken _ L.ALWAYS }+ ANALYSE { L.LocToken _ L.ANALYSE }+ ANALYZE { L.LocToken _ L.ANALYZE }+ ANY { L.LocToken _ L.ANY }+ ARRAY { L.LocToken _ L.ARRAY }+ ASSERTION { L.LocToken _ L.ASSERTION }+ ASSIGNMENT { L.LocToken _ L.ASSIGNMENT }+ ASYMMETRIC { L.LocToken _ L.ASYMMETRIC }+ AT { L.LocToken _ L.AT }+ ATTACH { L.LocToken _ L.ATTACH }+ ATTRIBUTE { L.LocToken _ L.ATTRIBUTE }+ BACKWARD { L.LocToken _ L.BACKWARD }+ BEFORE { L.LocToken _ L.BEFORE }+ BEGIN_P { L.LocToken _ L.BEGIN_P }+ BIGINT { L.LocToken _ L.BIGINT }+ BINARY { L.LocToken _ L.BINARY }+ BIT { L.LocToken _ L.BIT }+ BOOLEAN_P { L.LocToken _ L.BOOLEAN_P }+ BOTH { L.LocToken _ L.BOTH }+ CACHE { L.LocToken _ L.CACHE }+ CALL { L.LocToken _ L.CALL }+ CALLED { L.LocToken _ L.CALLED }+ CASCADE { L.LocToken _ L.CASCADE }+ CASCADED { L.LocToken _ L.CASCADED }+ CASE { L.LocToken _ L.CASE }+ CAST { L.LocToken _ L.CAST }+ CATALOG_P { L.LocToken _ L.CATALOG_P }+ CHAIN { L.LocToken _ L.CHAIN }+ CHARACTER { L.LocToken _ L.CHARACTER }+ CHARACTERISTICS { L.LocToken _ L.CHARACTERISTICS }+ CHAR_P { L.LocToken _ L.CHAR_P }+ CHECK { L.LocToken _ L.CHECK }+ CHECKPOINT { L.LocToken _ L.CHECKPOINT }+ CLASS { L.LocToken _ L.CLASS }+ CLOSE { L.LocToken _ L.CLOSE }+ CLUSTER { L.LocToken _ L.CLUSTER }+ COALESCE { L.LocToken _ L.COALESCE }+ COLLATE { L.LocToken _ L.COLLATE }+ COLLATION { L.LocToken _ L.COLLATION }+ COLUMN { L.LocToken _ L.COLUMN }+ COLUMNS { L.LocToken _ L.COLUMNS }+ COMMENT { L.LocToken _ L.COMMENT }+ COMMENTS { L.LocToken _ L.COMMENTS }+ COMMIT { L.LocToken _ L.COMMIT }+ COMMITTED { L.LocToken _ L.COMMITTED }+ CONCURRENTLY { L.LocToken _ L.CONCURRENTLY }+ CONFIGURATION { L.LocToken _ L.CONFIGURATION }+ CONFLICT { L.LocToken _ L.CONFLICT }+ CONNECTION { L.LocToken _ L.CONNECTION }+ CONSTRAINT { L.LocToken _ L.CONSTRAINT }+ CONSTRAINTS { L.LocToken _ L.CONSTRAINTS }+ CONTENT_P { L.LocToken _ L.CONTENT_P }+ CONTINUE_P { L.LocToken _ L.CONTINUE_P }+ CONVERSION_P { L.LocToken _ L.CONVERSION_P }+ COPY { L.LocToken _ L.COPY }+ COST { L.LocToken _ L.COST }+ CREATE { L.LocToken _ L.CREATE }+ CROSS { L.LocToken _ L.CROSS }+ CSV { L.LocToken _ L.CSV }+ CUBE { L.LocToken _ L.CUBE }+ CURRENT_CATALOG { L.LocToken _ L.CURRENT_CATALOG }+ CURRENT_DATE { L.LocToken _ L.CURRENT_DATE }+ CURRENT_P { L.LocToken _ L.CURRENT_P }+ CURRENT_ROLE { L.LocToken _ L.CURRENT_ROLE }+ CURRENT_SCHEMA { L.LocToken _ L.CURRENT_SCHEMA }+ CURRENT_TIME { L.LocToken _ L.CURRENT_TIME }+ CURRENT_TIMESTAMP { L.LocToken _ L.CURRENT_TIMESTAMP }+ CURRENT_USER { L.LocToken _ L.CURRENT_USER }+ CURSOR { L.LocToken _ L.CURSOR }+ CYCLE { L.LocToken _ L.CYCLE }+ DATABASE { L.LocToken _ L.DATABASE }+ DATA_P { L.LocToken _ L.DATA_P }+ DAY_P { L.LocToken _ L.DAY_P }+ DEALLOCATE { L.LocToken _ L.DEALLOCATE }+ DEC { L.LocToken _ L.DEC }+ DECIMAL_P { L.LocToken _ L.DECIMAL_P }+ DECLARE { L.LocToken _ L.DECLARE }+ DEFAULT { L.LocToken _ L.DEFAULT }+ DEFAULTS { L.LocToken _ L.DEFAULTS }+ DEFERRABLE { L.LocToken _ L.DEFERRABLE }+ DEFERRED { L.LocToken _ L.DEFERRED }+ DEFINER { L.LocToken _ L.DEFINER }+ DELETE_P { L.LocToken _ L.DELETE_P }+ DELIMITER { L.LocToken _ L.DELIMITER }+ DELIMITERS { L.LocToken _ L.DELIMITERS }+ DEPENDS { L.LocToken _ L.DEPENDS }+ DETACH { L.LocToken _ L.DETACH }+ DICTIONARY { L.LocToken _ L.DICTIONARY }+ DISABLE_P { L.LocToken _ L.DISABLE_P }+ DISCARD { L.LocToken _ L.DISCARD }+ DO { L.LocToken _ L.DO }+ DOCUMENT_P { L.LocToken _ L.DOCUMENT_P }+ DOMAIN_P { L.LocToken _ L.DOMAIN_P }+ DOUBLE_P { L.LocToken _ L.DOUBLE_P }+ DROP { L.LocToken _ L.DROP }+ EACH { L.LocToken _ L.EACH }+ ELSE { L.LocToken _ L.ELSE }+ ENABLE_P { L.LocToken _ L.ENABLE_P }+ ENCODING { L.LocToken _ L.ENCODING }+ ENCRYPTED { L.LocToken _ L.ENCRYPTED }+ END_P { L.LocToken _ L.END_P }+ ENUM_P { L.LocToken _ L.ENUM_P }+ ESCAPE { L.LocToken _ L.ESCAPE }+ EVENT { L.LocToken _ L.EVENT }+ EXCLUDE { L.LocToken _ L.EXCLUDE }+ EXCLUDING { L.LocToken _ L.EXCLUDING }+ EXCLUSIVE { L.LocToken _ L.EXCLUSIVE }+ EXECUTE { L.LocToken _ L.EXECUTE }+ EXISTS { L.LocToken _ L.EXISTS }+ EXPLAIN { L.LocToken _ L.EXPLAIN }+ EXTENSION { L.LocToken _ L.EXTENSION }+ EXTERNAL { L.LocToken _ L.EXTERNAL }+ EXTRACT { L.LocToken _ L.EXTRACT }+ FALSE_P { L.LocToken _ L.FALSE_P }+ FAMILY { L.LocToken _ L.FAMILY }+ FETCH { L.LocToken _ L.FETCH }+ FILTER { L.LocToken _ L.FILTER }+ FIRST_P { L.LocToken _ L.FIRST_P }+ FLOAT_P { L.LocToken _ L.FLOAT_P }+ FOLLOWING { L.LocToken _ L.FOLLOWING }+ FOR { L.LocToken _ L.FOR }+ FORCE { L.LocToken _ L.FORCE }+ FOREIGN { L.LocToken _ L.FOREIGN }+ FORWARD { L.LocToken _ L.FORWARD }+ FREEZE { L.LocToken _ L.FREEZE }+ FULL { L.LocToken _ L.FULL }+ FUNCTION { L.LocToken _ L.FUNCTION }+ FUNCTIONS { L.LocToken _ L.FUNCTIONS }+ GENERATED { L.LocToken _ L.GENERATED }+ GLOBAL { L.LocToken _ L.GLOBAL }+ GRANT { L.LocToken _ L.GRANT }+ GRANTED { L.LocToken _ L.GRANTED }+ GREATEST { L.LocToken _ L.GREATEST }+ GROUPING { L.LocToken _ L.GROUPING }+ GROUPS { L.LocToken _ L.GROUPS }+ GROUP_P { L.LocToken _ L.GROUP_P }+ HANDLER { L.LocToken _ L.HANDLER }+ HAVING { L.LocToken _ L.HAVING }+ HEADER_P { L.LocToken _ L.HEADER_P }+ HOLD { L.LocToken _ L.HOLD }+ HOUR_P { L.LocToken _ L.HOUR_P }+ IDENTITY_P { L.LocToken _ L.IDENTITY_P }+ IF_P { L.LocToken _ L.IF_P }+ IMMEDIATE { L.LocToken _ L.IMMEDIATE }+ IMMUTABLE { L.LocToken _ L.IMMUTABLE }+ IMPLICIT_P { L.LocToken _ L.IMPLICIT_P }+ IMPORT_P { L.LocToken _ L.IMPORT_P }+ INCLUDE { L.LocToken _ L.INCLUDE }+ INCLUDING { L.LocToken _ L.INCLUDING }+ INCREMENT { L.LocToken _ L.INCREMENT }+ INDEX { L.LocToken _ L.INDEX }+ INDEXES { L.LocToken _ L.INDEXES }+ INHERIT { L.LocToken _ L.INHERIT }+ INHERITS { L.LocToken _ L.INHERITS }+ INITIALLY { L.LocToken _ L.INITIALLY }+ INLINE_P { L.LocToken _ L.INLINE_P }+ INNER_P { L.LocToken _ L.INNER_P }+ INOUT { L.LocToken _ L.INOUT }+ INPUT_P { L.LocToken _ L.INPUT_P }+ INSENSITIVE { L.LocToken _ L.INSENSITIVE }+ INSTEAD { L.LocToken _ L.INSTEAD }+ INTEGER { L.LocToken _ L.INTEGER }+ INTERSECT { L.LocToken _ L.INTERSECT }+ INTERVAL { L.LocToken _ L.INTERVAL }+ INT_P { L.LocToken _ L.INT_P }+ INVOKER { L.LocToken _ L.INVOKER }+ IN_P { L.LocToken _ L.IN_P }+ ISOLATION { L.LocToken _ L.ISOLATION }+ JOIN { L.LocToken _ L.JOIN }+ KEY { L.LocToken _ L.KEY }+ LABEL { L.LocToken _ L.LABEL }+ LANGUAGE { L.LocToken _ L.LANGUAGE }+ LARGE_P { L.LocToken _ L.LARGE_P }+ LAST { L.LocToken _ L.LAST }+ LATERAL_P { L.LocToken _ L.LATERAL_P }+ LEADING { L.LocToken _ L.LEADING }+ LEAKPROOF { L.LocToken _ L.LEAKPROOF }+ LEAST { L.LocToken _ L.LEAST }+ LEFT { L.LocToken _ L.LEFT }+ LEVEL { L.LocToken _ L.LEVEL }+ LIMIT { L.LocToken _ L.LIMIT }+ LISTEN { L.LocToken _ L.LISTEN }+ LOAD { L.LocToken _ L.LOAD }+ LOCAL { L.LocToken _ L.LOCAL }+ LOCALTIME { L.LocToken _ L.LOCALTIME }+ LOCALTIMESTAMP { L.LocToken _ L.LOCALTIMESTAMP }+ LOCATION { L.LocToken _ L.LOCATION }+ LOCKED { L.LocToken _ L.LOCKED }+ LOCK_P { L.LocToken _ L.LOCK_P }+ LOGGED { L.LocToken _ L.LOGGED }+ MAPPING { L.LocToken _ L.MAPPING }+ MATCH { L.LocToken _ L.MATCH }+ MATERIALIZED { L.LocToken _ L.MATERIALIZED }+ MAXVALUE { L.LocToken _ L.MAXVALUE }+ METHOD { L.LocToken _ L.METHOD }+ MINUTE_P { L.LocToken _ L.MINUTE_P }+ MINVALUE { L.LocToken _ L.MINVALUE }+ MODE { L.LocToken _ L.MODE }+ MONTH_P { L.LocToken _ L.MONTH_P }+ MOVE { L.LocToken _ L.MOVE }+ NAMES { L.LocToken _ L.NAMES }+ NAME_P { L.LocToken _ L.NAME_P }+ NATIONAL { L.LocToken _ L.NATIONAL }+ NATURAL { L.LocToken _ L.NATURAL }+ NCHAR { L.LocToken _ L.NCHAR }+ NEW { L.LocToken _ L.NEW }+ NEXT { L.LocToken _ L.NEXT }+ NO { L.LocToken _ L.NO }+ NONE { L.LocToken _ L.NONE }+ NOTHING { L.LocToken _ L.NOTHING }+ NOTIFY { L.LocToken _ L.NOTIFY }+ NOWAIT { L.LocToken _ L.NOWAIT }+ NULLIF { L.LocToken _ L.NULLIF }+ NULLS_P { L.LocToken _ L.NULLS_P }+ NULL_P { L.LocToken _ L.NULL_P }+ NUMERIC { L.LocToken _ L.NUMERIC }+ OBJECT_P { L.LocToken _ L.OBJECT_P }+ OF { L.LocToken _ L.OF }+ OFF { L.LocToken _ L.OFF }+ OFFSET { L.LocToken _ L.OFFSET }+ OIDS { L.LocToken _ L.OIDS }+ OLD { L.LocToken _ L.OLD }+ ONLY { L.LocToken _ L.ONLY }+ OPTION { L.LocToken _ L.OPTION }+ OPTIONS { L.LocToken _ L.OPTIONS }+ ORDINALITY { L.LocToken _ L.ORDINALITY }+ OTHERS { L.LocToken _ L.OTHERS }+ OUTER_P { L.LocToken _ L.OUTER_P }+ OUT_P { L.LocToken _ L.OUT_P }+ OVER { L.LocToken _ L.OVER }+ OVERLAPS { L.LocToken _ L.OVERLAPS }+ OVERLAY { L.LocToken _ L.OVERLAY }+ OVERRIDING { L.LocToken _ L.OVERRIDING }+ OWNED { L.LocToken _ L.OWNED }+ OWNER { L.LocToken _ L.OWNER }+ PARALLEL { L.LocToken _ L.PARALLEL }+ PARSER { L.LocToken _ L.PARSER }+ PARTIAL { L.LocToken _ L.PARTIAL }+ PARTITION { L.LocToken _ L.PARTITION }+ PASSING { L.LocToken _ L.PASSING }+ PASSWORD { L.LocToken _ L.PASSWORD }+ PLACING { L.LocToken _ L.PLACING }+ PLANS { L.LocToken _ L.PLANS }+ POLICY { L.LocToken _ L.POLICY }+ POSITION { L.LocToken _ L.POSITION }+ PRECEDING { L.LocToken _ L.PRECEDING }+ PRECISION { L.LocToken _ L.PRECISION }+ PREPARE { L.LocToken _ L.PREPARE }+ PREPARED { L.LocToken _ L.PREPARED }+ PRESERVE { L.LocToken _ L.PRESERVE }+ PRIMARY { L.LocToken _ L.PRIMARY }+ PRIOR { L.LocToken _ L.PRIOR }+ PRIVILEGES { L.LocToken _ L.PRIVILEGES }+ PROCEDURAL { L.LocToken _ L.PROCEDURAL }+ PROCEDURE { L.LocToken _ L.PROCEDURE }+ PROCEDURES { L.LocToken _ L.PROCEDURES }+ PROGRAM { L.LocToken _ L.PROGRAM }+ PUBLICATION { L.LocToken _ L.PUBLICATION }+ QUOTE { L.LocToken _ L.QUOTE }+ RANGE { L.LocToken _ L.RANGE }+ READ { L.LocToken _ L.READ }+ REAL { L.LocToken _ L.REAL }+ REASSIGN { L.LocToken _ L.REASSIGN }+ RECHECK { L.LocToken _ L.RECHECK }+ RECURSIVE { L.LocToken _ L.RECURSIVE }+ REF { L.LocToken _ L.REF }+ REFERENCES { L.LocToken _ L.REFERENCES }+ REFERENCING { L.LocToken _ L.REFERENCING }+ REFRESH { L.LocToken _ L.REFRESH }+ REINDEX { L.LocToken _ L.REINDEX }+ RELATIVE_P { L.LocToken _ L.RELATIVE_P }+ RELEASE { L.LocToken _ L.RELEASE }+ RENAME { L.LocToken _ L.RENAME }+ REPEATABLE { L.LocToken _ L.REPEATABLE }+ REPLACE { L.LocToken _ L.REPLACE }+ REPLICA { L.LocToken _ L.REPLICA }+ RESET { L.LocToken _ L.RESET }+ RESTART { L.LocToken _ L.RESTART }+ RESTRICT { L.LocToken _ L.RESTRICT }+ RETURNING { L.LocToken _ L.RETURNING }+ RETURNS { L.LocToken _ L.RETURNS }+ REVOKE { L.LocToken _ L.REVOKE }+ RIGHT { L.LocToken _ L.RIGHT }+ ROLE { L.LocToken _ L.ROLE }+ ROLLBACK { L.LocToken _ L.ROLLBACK }+ ROLLUP { L.LocToken _ L.ROLLUP }+ ROUTINE { L.LocToken _ L.ROUTINE }+ ROUTINES { L.LocToken _ L.ROUTINES }+ ROW { L.LocToken _ L.ROW }+ ROWS { L.LocToken _ L.ROWS }+ RULE { L.LocToken _ L.RULE }+ SAVEPOINT { L.LocToken _ L.SAVEPOINT }+ SCHEMA { L.LocToken _ L.SCHEMA }+ SCHEMAS { L.LocToken _ L.SCHEMAS }+ SCROLL { L.LocToken _ L.SCROLL }+ SEARCH { L.LocToken _ L.SEARCH }+ SECOND_P { L.LocToken _ L.SECOND_P }+ SECURITY { L.LocToken _ L.SECURITY }+ SEQUENCE { L.LocToken _ L.SEQUENCE }+ SEQUENCES { L.LocToken _ L.SEQUENCES }+ SERIALIZABLE { L.LocToken _ L.SERIALIZABLE }+ SERVER { L.LocToken _ L.SERVER }+ SESSION { L.LocToken _ L.SESSION }+ SESSION_USER { L.LocToken _ L.SESSION_USER }+ SETOF { L.LocToken _ L.SETOF }+ SETS { L.LocToken _ L.SETS }+ SHARE { L.LocToken _ L.SHARE }+ SHOW { L.LocToken _ L.SHOW }+ SIMILAR { L.LocToken _ L.SIMILAR }+ SIMPLE { L.LocToken _ L.SIMPLE }+ SKIP { L.LocToken _ L.SKIP }+ SMALLINT { L.LocToken _ L.SMALLINT }+ SNAPSHOT { L.LocToken _ L.SNAPSHOT }+ SOME { L.LocToken _ L.SOME }+ SQL_P { L.LocToken _ L.SQL_P }+ STABLE { L.LocToken _ L.STABLE }+ STANDALONE_P { L.LocToken _ L.STANDALONE_P }+ START { L.LocToken _ L.START }+ STATEMENT { L.LocToken _ L.STATEMENT }+ STATISTICS { L.LocToken _ L.STATISTICS }+ STDIN { L.LocToken _ L.STDIN }+ STDOUT { L.LocToken _ L.STDOUT }+ STORAGE { L.LocToken _ L.STORAGE }+ STORED { L.LocToken _ L.STORED }+ STRICT_P { L.LocToken _ L.STRICT_P }+ STRIP_P { L.LocToken _ L.STRIP_P }+ SUBSCRIPTION { L.LocToken _ L.SUBSCRIPTION }+ SUBSTRING { L.LocToken _ L.SUBSTRING }+ SUPPORT { L.LocToken _ L.SUPPORT }+ SYMMETRIC { L.LocToken _ L.SYMMETRIC }+ SYSID { L.LocToken _ L.SYSID }+ SYSTEM_P { L.LocToken _ L.SYSTEM_P }+ TABLE { L.LocToken _ L.TABLE }+ TABLES { L.LocToken _ L.TABLES }+ TABLESAMPLE { L.LocToken _ L.TABLESAMPLE }+ TABLESPACE { L.LocToken _ L.TABLESPACE }+ TEMP { L.LocToken _ L.TEMP }+ TEMPLATE { L.LocToken _ L.TEMPLATE }+ TEMPORARY { L.LocToken _ L.TEMPORARY }+ TEXT_P { L.LocToken _ L.TEXT_P }+ THEN { L.LocToken _ L.THEN }+ TIES { L.LocToken _ L.TIES }+ TIME { L.LocToken _ L.TIME }+ TIMESTAMP { L.LocToken _ L.TIMESTAMP }+ TO { L.LocToken _ L.TO }+ TRAILING { L.LocToken _ L.TRAILING }+ TRANSACTION { L.LocToken _ L.TRANSACTION }+ TRANSFORM { L.LocToken _ L.TRANSFORM }+ TREAT { L.LocToken _ L.TREAT }+ TRIGGER { L.LocToken _ L.TRIGGER }+ TRIM { L.LocToken _ L.TRIM }+ TRUE_P { L.LocToken _ L.TRUE_P }+ TRUNCATE { L.LocToken _ L.TRUNCATE }+ TRUSTED { L.LocToken _ L.TRUSTED }+ TYPES_P { L.LocToken _ L.TYPES_P }+ TYPE_P { L.LocToken _ L.TYPE_P }+ UNBOUNDED { L.LocToken _ L.UNBOUNDED }+ UNCOMMITTED { L.LocToken _ L.UNCOMMITTED }+ UNENCRYPTED { L.LocToken _ L.UNENCRYPTED }+ UNIQUE { L.LocToken _ L.UNIQUE }+ UNKNOWN { L.LocToken _ L.UNKNOWN }+ UNLISTEN { L.LocToken _ L.UNLISTEN }+ UNLOGGED { L.LocToken _ L.UNLOGGED }+ UNTIL { L.LocToken _ L.UNTIL }+ USER { L.LocToken _ L.USER }+ VACUUM { L.LocToken _ L.VACUUM }+ VALID { L.LocToken _ L.VALID }+ VALIDATE { L.LocToken _ L.VALIDATE }+ VALIDATOR { L.LocToken _ L.VALIDATOR }+ VALUE_P { L.LocToken _ L.VALUE_P }+ VARCHAR { L.LocToken _ L.VARCHAR }+ VARIADIC { L.LocToken _ L.VARIADIC }+ VARYING { L.LocToken _ L.VARYING }+ VERBOSE { L.LocToken _ L.VERBOSE }+ VERSION_P { L.LocToken _ L.VERSION_P }+ VIEW { L.LocToken _ L.VIEW }+ VIEWS { L.LocToken _ L.VIEWS }+ VOLATILE { L.LocToken _ L.VOLATILE }+ WHEN { L.LocToken _ L.WHEN }+ WHITESPACE_P { L.LocToken _ L.WHITESPACE_P }+ WINDOW { L.LocToken _ L.WINDOW }+ WITH { L.LocToken _ L.WITH }+ WITHIN { L.LocToken _ L.WITHIN }+ WITHOUT { L.LocToken _ L.WITHOUT }+ WORK { L.LocToken _ L.WORK }+ WRAPPER { L.LocToken _ L.WRAPPER }+ WRITE { L.LocToken _ L.WRITE }+ XMLATTRIBUTES { L.LocToken _ L.XMLATTRIBUTES }+ XMLCONCAT { L.LocToken _ L.XMLCONCAT }+ XMLELEMENT { L.LocToken _ L.XMLELEMENT }+ XMLEXISTS { L.LocToken _ L.XMLEXISTS }+ XMLFOREST { L.LocToken _ L.XMLFOREST }+ XMLNAMESPACES { L.LocToken _ L.XMLNAMESPACES }+ XMLPARSE { L.LocToken _ L.XMLPARSE }+ XMLPI { L.LocToken _ L.XMLPI }+ XMLROOT { L.LocToken _ L.XMLROOT }+ XMLSERIALIZE { L.LocToken _ L.XMLSERIALIZE }+ XMLTABLE { L.LocToken _ L.XMLTABLE }+ XML_P { L.LocToken _ L.XML_P }+ YEAR_P { L.LocToken _ L.YEAR_P }+ YES_P { L.LocToken _ L.YES_P }+ ZONE { L.LocToken _ L.ZONE }++%%++-- Unlike gram.y, we only parse a single statement, and only DML.++Statement :: { Statement }+ : PreparableStmt { $1 }+ | PreparableStmt SEMICOLON { $1 }++PreparableStmt :: { Statement }+ : SelectStmt { QS $1 }+ | Delete { QD $1 }+ | Insert { QI $1 }+ | Update { QU $1 }++Delete+ : DELETE FROM Name WHERE a_expr { Delete $3 (Just $5) }+ | DELETE FROM Name { Delete $3 Nothing }++-- * A complete SELECT statement looks like this.+-- *+-- * The rule returns either a single SelectStmt node or a tree of them,+-- * representing a set-operation tree.+-- *+-- * There is an ambiguity when a sub-SELECT is within an a_expr and there+-- * are excess parentheses: do the parentheses belong to the sub-SELECT or+-- * to the surrounding a_expr? We don't really care, but bison wants to know.+-- * To resolve the ambiguity, we are careful to define the grammar so that+-- * the decision is staved off as long as possible: as long as we can keep+-- * absorbing parentheses into the sub-SELECT, we will do so, and only when+-- * it's no longer possible to do that will we decide that parens belong to+-- * the expression. For example, in "SELECT (((SELECT 2)) + 3)" the extra+-- * parentheses are treated as part of the sub-select. The necessity of doing+-- * it that way is shown by "SELECT (((SELECT 2)) UNION SELECT 2)". Had we+-- * parsed "((SELECT 2))" as an a_expr, it'd be too late to go back to the+-- * SELECT viewpoint when we see the UNION.+-- *+-- * This approach is implemented by defining a nonterminal select_with_parens,+-- * which represents a SELECT with at least one outer layer of parentheses,+-- * and being careful to use select_with_parens, never '(' SelectStmt ')',+-- * in the expression grammar. We will then have shift-reduce conflicts+-- * which we can resolve in favor of always treating '(' <select> ')' as+-- * a select_with_parens. To resolve the conflicts, the productions that+-- * conflict with the select_with_parens productions are manually given+-- * precedences lower than the precedence of ')', thereby ensuring that we+-- * shift ')' (and then reduce to select_with_parens) rather than trying to+-- * reduce the inner <select> nonterminal to something else. We use UMINUS+-- * precedence for this, which is a fairly arbitrary choice.+-- *+-- * To be able to define select_with_parens itself without ambiguity, we need+-- * a nonterminal select_no_parens that represents a SELECT structure with no+-- * outermost parentheses. This is a little bit tedious, but it works.+-- *+-- * In non-expression contexts, we use SelectStmt which can represent a SELECT+-- * with or without outer parentheses.++SelectStmt :: { SelectStmt }+ : select_no_parens %prec UMINUS { $1 }+ | select_with_parens %prec UMINUS { $1 }++select_with_parens :: { SelectStmt }+ : '(' select_no_parens ')' { $2 }+ | '(' select_with_parens ')' { $2 }++-- * This rule parses the equivalent of the standard's <query expression>.+-- * The duplicative productions are annoying, but hard to get rid of without+-- * creating shift/reduce conflicts.+-- *+-- * The locking clause (FOR UPDATE etc) may be before or after LIMIT/OFFSET.+-- * In <=7.2.X, LIMIT/OFFSET had to be after FOR UPDATE+-- * We now support both orderings, but prefer LIMIT/OFFSET before the locking+-- * clause.+-- * 2002-08-28 bjm++select_no_parens :: { SelectStmt }+ : simple_select { $1 }+ | select_clause sort_clause { S $1 selectOptions { sortBy = $2 } }+ | select_clause opt_sort_clause for_locking_clause opt_select_limit+ { S $1 selectOptions { sortBy = $2, locking = $3, offset = fst $4, limit = snd $4 } }+ | select_clause opt_sort_clause select_limit opt_for_locking_clause+ { S $1 selectOptions { sortBy = $2, offset = fst $3, limit = snd $3, locking = $4 } }+ | with_clause select_clause { S $2 selectOptions { withClause = Just $1 } }+ | with_clause select_clause sort_clause { S $2 selectOptions { withClause = Just $1, sortBy = $3 } }+ | with_clause select_clause opt_sort_clause for_locking_clause opt_select_limit+ { S $2 selectOptions { withClause = Just $1, sortBy = $3, locking = $4, offset = fst $5, limit = snd $5 } }+ | with_clause select_clause opt_sort_clause select_limit opt_for_locking_clause+ { S $2 selectOptions { withClause = Just $1, sortBy = $3, offset = fst $4, limit = snd $4, locking = $5 } }++select_clause :: { SelectStmt }+ : simple_select { $1 }+ | select_with_parens { $1 }++-- * This rule parses SELECT statements that can appear within set operations,+-- * including UNION, INTERSECT and EXCEPT. '(' and ')' can be used to specify+-- * the ordering of the set operations. Without '(' and ')' we want the+-- * operations to be ordered per the precedence specs at the head of this file.+-- *+-- * As with select_no_parens, simple_select cannot have outer parentheses,+-- * but can have parenthesized subclauses.+-- *+-- * Note that sort clauses cannot be included at this level -- *- SQL requires+-- * SELECT foo UNION SELECT bar ORDER BY baz+-- * to be parsed as+-- * (SELECT foo UNION SELECT bar) ORDER BY baz+-- * not+-- * SELECT foo UNION (SELECT bar ORDER BY baz)+-- * Likewise for WITH, FOR UPDATE and LIMIT. Therefore, those clauses are+-- * described as part of the select_no_parens production, not simple_select.+-- * This does not limit functionality, because you can reintroduce these+-- * clauses inside parentheses.+-- *+-- * NOTE: only the leftmost component SelectStmt should have INTO.+-- * However, this is not checked by the grammar; parse analysis must check it.++-- TODO include into_clause+simple_select :: { SelectStmt }+ : SELECT opt_all_clause opt_target_list+ into_clause from_clause where_clause+ group_clause having_clause window_clause { Simple (Select+ { distinct = Nothing+ , targetList = $3+ , from = $5+ , whereClause = $6+ , groupBy = $7+ , having = $8+ , window = $9+ })+ }+ | SELECT distinct_clause target_list+ into_clause from_clause where_clause+ group_clause having_clause window_clause+ { Simple (Select+ { distinct = Just $2+ , targetList = $3+ -- TODO into+ , from = $5+ , whereClause = $6+ , groupBy = $7+ , having = $8+ , window = $9+ }) }+ | values_clause { SelectValues (NE.reverse $1) }+ | TABLE relation_expr { Simple select { targetList = [ Star ], from = [ J (Table $2) ] } }+ -- * same as SELECT * FROM relation_expr+ | select_clause UNION all_or_distinct select_clause { Set Union $3 $1 $4 }+ | select_clause INTERSECT all_or_distinct select_clause { Set Intersect $3 $1 $4 }+ | select_clause EXCEPT all_or_distinct select_clause { Set Except $3 $1 $4 }++-- * SQL standard WITH clause looks like:+-- *+-- * WITH [ RECURSIVE ] <query name> [ (<column>,...) ]+-- * AS (query) [ SEARCH or CYCLE clause ]+-- *+-- * We don't currently support the SEARCH or CYCLE clause.++-- * Recognizing WITH_LA here allows a CTE to be named TIME or ORDINALITY.+with_clause+ : WITH cte_list { With $2 NotRecursive }+ -- FIXME do we need WITH_LA ?+ | WITH RECURSIVE cte_list { With $3 Recursive }++cte_list : list(common_table_expr) { reverse $1 }++common_table_expr+ : name opt_name_list AS opt_materialized '(' PreparableStmt ')'+ { CommonTableExpr+ { name = $1+ , aliases = $2+ , materialized = $4+ , query = $6+ }+ }++opt_materialized :: { Materialized }+ : MATERIALIZED { Materialized }+ | NOT MATERIALIZED { NotMaterialized }+ | { MaterializeDefault }++opt_with_clause :: { Maybe WithClause }+ : with_clause { Just $1 }+ | { Nothing }++into_clause:+ -- TODO INTO OptTempTableName+ -- TODO {+ -- TODO $$ = makeNode(IntoClause);+ -- TODO $$->rel = $2;+ -- TODO $$->colNames = NIL;+ -- TODO $$->options = NIL;+ -- TODO $$->onCommit = ONCOMMIT_NOOP;+ -- TODO $$->tableSpaceName = NULL;+ -- TODO $$->viewQuery = NULL;+ -- TODO $$->skipData = false;+ -- }+ { Nothing }++-- TODO OptTempTableName:++opt_table :: { () }+ : TABLE { () }+ | { () }++all_or_distinct :: { AllOrDistinct }+ : ALL { All }+ | DISTINCT { Distinct }+ | { Distinct }++-- * We use (DistinctAll) as a placeholder to indicate that all target expressions+-- * should be placed in the DISTINCT list during parsetree analysis.+distinct_clause :: { DistinctClause }+ : DISTINCT { DistinctAll }+ | DISTINCT ON '(' expr_list ')' { DistinctOn (NE.fromList $4) }++opt_all_clause+ : ALL { () }+ | { () }++opt_sort_clause :: { [SortBy] }+ : sort_clause { $1 }+ | { [] }++sort_clause :: { [SortBy] }+ : ORDER BY sortby_list { reverse $3 }++sortby_list : list(sortby) { $1 }++sortby :: { SortBy }+ : a_expr USING qual_all_Op opt_nulls_order { SortBy $1 (SortUsing $3) $4 }+ | a_expr opt_asc_desc opt_nulls_order { SortBy $1 (SortOrder $2) $3 }++select_limit :: { (Maybe Expr, Maybe Expr) }+ : limit_clause offset_clause { (Just $2, Just $1) }+ | offset_clause limit_clause { (Just $1, Just $2) }+ | limit_clause { (Nothing, Just $1) }+ | offset_clause { (Just $1, Nothing) }++opt_select_limit :: { (Maybe Expr, Maybe Expr) }+ : select_limit { $1 }+ | { (Nothing, Nothing) }++limit_clause :: { Expr }+ : LIMIT select_limit_value { $2 }+ -- * Disabled because it was too confusing, bjm 2002-02-18 */+ | LIMIT select_limit_value ',' select_offset_value+ {% fail "LIMIT #,# syntax is not supported. Use separate LIMIT and OFFSET clauses." } -- error message to match Postgres+ -- * SQL:2008 syntax */+ -- * to avoid shift/reduce conflicts, handle the optional value with+ -- * a separate production rather than an opt_ expression. The fact+ -- * that ONLY is fully reserved means that this way, we defer any+ -- * decision about what rule reduces ROW or ROWS to the point where+ -- * we can see the ONLY token in the lookahead slot.+ | FETCH first_or_next select_fetch_first_value row_or_rows ONLY { $3 }+ | FETCH first_or_next row_or_rows ONLY { Lit (I 1) }++offset_clause :: { Expr }+ : OFFSET select_offset_value { $2 }+ -- * SQL:2008 syntax */+ | OFFSET select_fetch_first_value row_or_rows { $2 }++select_limit_value :: { Expr }+ : a_expr { $1 }+ -- * LIMIT ALL is represented as a NULL constant */+ | ALL { Lit Null }++select_offset_value :: { Expr }+ : a_expr { $1 }++-- * Allowing full expressions without parentheses causes various parsing+-- * problems with the trailing ROW/ROWS key words. SQL spec only calls for+-- * <simple value specification>, which is either a literal or a parameter (but+-- * an <SQL parameter reference> could be an identifier, bringing up conflicts+-- * with ROW/ROWS). We solve this by leveraging the presence of ONLY (see above)+-- * to determine whether the expression is missing rather than trying to make it+-- * optional in this rule.+-- *+-- * c_expr covers almost all the spec-required cases (and more), but it doesn't+-- * cover signed numeric literals, which are allowed by the spec. So we include+-- * those here explicitly. We need FCONST as well as ICONST because values that+-- * don't fit in the platform's "long", but do fit in bigint, should still be+-- * accepted here. (This is possible in 64-bit Windows as well as all 32-bit+-- * builds.)++select_fetch_first_value :: { Expr }+ : c_expr { $1 }+ | '+' I_or_F_const { Lit $2 }+ | '-' I_or_F_const { Unary Negate (Lit $2) }++I_or_F_const :: { Literal }+ : Fconst { F $1 }+ | Iconst { I $1 }++-- * noise words+row_or_rows :: { () }+ : ROW { () }+ | ROWS { () }++first_or_next :: { () }+ : FIRST_P { () }+ | NEXT { () }++-- * This syntax for group_clause tries to follow the spec quite closely.+-- * However, the spec allows only column references, not expressions,+-- * which introduces an ambiguity between implicit row constructors+-- * (a,b) and lists of column references.+-- *+-- * We handle this by using the a_expr production for what the spec calls+-- * <ordinary grouping set>, which in the spec represents either one column+-- * reference or a parenthesized list of column references. Then, we check the+-- * top node of the a_expr to see if it's an implicit RowExpr, and if so, just+-- * grab and use the list, discarding the node. (this is done in parse analysis,+-- * not here)+-- *+-- * (we abuse the row_format field of RowExpr to distinguish implicit and+-- * explicit row constructors; it's debatable if anyone sanely wants to use them+-- * in a group clause, but if they have a reason to, we make it possible.)+-- *+-- * Each item in the group_clause list is either an expression tree or a+-- * GroupingSet node of some type.+group_clause :: { [Expr] }+ : GROUP_P BY group_by_list { reverse $3 }+ | { [] }++group_by_list : list(group_by_item) { $1 }++group_by_item+ : a_expr { $1 }+-- TODO | empty_grouping_set { $$ = $1; }+-- TODO | cube_clause { $$ = $1; }+-- TODO | rollup_clause { $$ = $1; }+-- TODO | grouping_sets_clause { $$ = $1; }++-- TODO empty_grouping_set:+-- TODO '(' ')'+-- TODO {+-- TODO $$ = (Node *) makeGroupingSet(GROUPING_SET_EMPTY, NIL, @1);++-- TODO rollup_clause:+-- TODO cube_clause:+-- TODO grouping_sets_clause:++having_clause :: { Maybe Expr }+ : HAVING a_expr { Just $2 }+ | { Nothing }++for_locking_clause :: { [Locking] }+ : for_locking_items { reverse $1 }+ | FOR READ ONLY { [] }++opt_for_locking_clause :: { [Locking] }+ : for_locking_clause { $1 }+ | { [] }++for_locking_items :: { [Locking] }+ : for_locking_item { [$1] }+ | for_locking_items for_locking_item { $2 : $1 }++for_locking_item :: { Locking }+ : for_locking_strength locked_rels_list opt_nowait_or_skip+ { Locking $1 (reverse $2) $3 }++for_locking_strength :: { LockingStrength }+ : FOR UPDATE { ForUpdate }+ | FOR NO KEY UPDATE { ForNoKeyUpdate }+ | FOR SHARE { ForShare }+ | FOR KEY SHARE { ForKeyShare }++locked_rels_list :: { [Name] }+ : OF qualified_name_list { $2 }+ | { [] }++opt_nowait_or_skip :: { LockWait }+ : NOWAIT { LockWaitError }+ | SKIP LOCKED { LockWaitSkip }+ | { LockWaitBlock }++-- * We should allow ROW '(' expr_list ')' too, but that seems to require+-- * making VALUES a fully reserved word, which will probably break more apps+-- * than allowing the noise-word is worth.+values_clause :: { NE.NonEmpty (NE.NonEmpty Expr) }+ : VALUES '(' expr_list ')' { NE.fromList $3 :| [] }+ | values_clause ',' '(' expr_list ')' { NE.cons (NE.fromList $4) $1 }++ -- * clauses common to all Optimizable Stmts:+ -- * from_clause - allow list of both JOIN expressions and table names+ -- * where_clause - qualifications for joins or restrictions++from_clause :: { [TableRef] }+ : FROM from_list { reverse $2 }+ | { [] }++from_list : list(table_ref) { $1 }++-- * table_ref is where an alias clause can be attached.+table_ref :: { TableRef }+ : relation_expr opt_alias_clause { case $2 of+ Nothing -> J (Table $1)+ Just a -> As (Table $1) a }+-- TODO | relation_expr opt_alias_clause tablesample_clause+-- TODO {+-- TODO RangeTableSample *n = (RangeTableSample *) $3;+-- TODO $1->alias = $2;+-- TODO /* relation_expr goes inside the RangeTableSample node */+-- TODO n->relation = (Node *) $1;+-- TODO $$ = (Node *) n;+-- TODO }+-- TODO | func_table func_alias_clause+-- TODO {+-- TODO RangeFunction *n = (RangeFunction *) $1;+-- TODO n->alias = linitial($2);+-- TODO n->coldeflist = lsecond($2);+-- TODO $$ = (Node *) n;+-- TODO }+-- TODO | LATERAL_P func_table func_alias_clause+-- TODO {+-- TODO RangeFunction *n = (RangeFunction *) $2;+-- TODO n->lateral = true;+-- TODO n->alias = linitial($3);+-- TODO n->coldeflist = lsecond($3);+-- TODO $$ = (Node *) n;+-- TODO }+-- TODO | xmltable opt_alias_clause+-- TODO {+-- TODO RangeTableFunc *n = (RangeTableFunc *) $1;+-- TODO n->alias = $2;+-- TODO $$ = (Node *) n;+-- TODO }+-- TODO | LATERAL_P xmltable opt_alias_clause+-- TODO {+-- TODO RangeTableFunc *n = (RangeTableFunc *) $2;+-- TODO n->lateral = true;+-- TODO n->alias = $3;+-- TODO $$ = (Node *) n;+-- TODO }+-- * The SQL spec does not permit a subselect+-- * (<derived_table>) without an alias clause,+-- * so we don't either. This avoids the problem+-- * of needing to invent a unique refname for it.+-- * That could be surmounted if there's sufficient+-- * popular demand, but for now let's just implement+-- * the spec and see if anyone complains.+-- * However, it does seem like a good idea to emit+-- * an error message that's better than "syntax error".++-- The comment above and the error messages below are straight from Postgres+ | select_with_parens opt_alias_clause {%+ case $2 of+ Just alias -> return (SubSelect $1 alias)+ Nothing -> case $1 of+ SelectValues _ -> fail "VALUES in FROM must have an alias"++ _ -> fail "subquery in FROM must have an alias"+ }+-- TODO $$ = (Node *) n;+-- TODO }+-- TODO | LATERAL_P select_with_parens opt_alias_clause+-- TODO {+-- TODO RangeSubselect *n = makeNode(RangeSubselect);+-- TODO n->lateral = true;+-- TODO n->subquery = $2;+-- TODO n->alias = $3;+-- TODO /* same comment as above */+-- TODO if ($3 == NULL)+-- TODO {+-- TODO if (IsA($2, SelectStmt) &&+-- TODO ((SelectStmt *) $2)->valuesLists)+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("VALUES in FROM must have an alias"),+-- TODO errhint("For example, FROM (VALUES ...) [AS] foo."),+-- TODO parser_errposition(@2)));+-- TODO else+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("subquery in FROM must have an alias"),+-- TODO errhint("For example, FROM (SELECT ...) [AS] foo."),+-- TODO parser_errposition(@2)));+-- TODO }+-- TODO $$ = (Node *) n;+-- TODO }+ | joined_table { J $1 }+ | '(' joined_table ')' alias_clause { As $2 $4 }++-- * It may seem silly to separate joined_table from table_ref, but there is+-- * method in SQL's madness: if you don't do it this way you get reduce-+-- * reduce conflicts, because it's not clear to the parser generator whether+-- * to expect alias_clause after ')' or not. For the same reason we must+-- * treat 'JOIN' and 'join_type JOIN' separately, rather than allowing+-- * join_type to expand to empty; if we try it, the parser generator can't+-- * figure out when to reduce an empty join_type right after table_ref.+-- *+-- * Note that a CROSS JOIN is the same as an unqualified+-- * INNER JOIN, and an INNER JOIN/ON has the same shape+-- * but a qualification expression to limit membership.+-- * A NATURAL JOIN implicitly matches column names between+-- * tables and the shape is determined by which columns are+-- * in common. We'll collect columns during the later transformations.++joined_table :: { JoinedTable }+ : '(' joined_table ')' { $2 }+ -- * CROSS JOIN is same as unqualified inner join+ | table_ref CROSS JOIN table_ref { CrossJoin $1 $4 }+ | table_ref join_type JOIN table_ref join_qual { Join $2 $5 $1 $4 }+ | table_ref JOIN table_ref join_qual { Join Inner $4 $1 $3 }+ | table_ref NATURAL join_type JOIN table_ref { Join $3 Natural $1 $5 }+ | table_ref NATURAL JOIN table_ref { Join Inner Natural $1 $4 }++alias_clause :: { Alias }+ : AS ColId '(' name_list ')' { Alias $2 (reverse $4) }+ | AS ColId { Alias $2 [] }+ | ColId '(' name_list ')' { Alias $1 (reverse $3) }+ | ColId { Alias $1 [] }++opt_alias_clause :: { Maybe Alias }+ : alias_clause { Just $1 }+ | { Nothing }++-- TODO func_alias_clause:++join_type :: { JoinType }+ : FULL join_outer { Full }+ | LEFT join_outer { LeftJoin }+ | RIGHT join_outer { RightJoin }+ | INNER_P { Inner }++join_outer :: { () } -- * OUTER is just noise...+ : OUTER_P { () }+ | { () }++-- * JOIN qualification clauses+-- * Possibilities are:+-- * USING ( column list ) allows only unqualified column names,+-- * which must match between tables.+-- * ON expr allows more general qualifications.+join_qual :: { JoinQual }+ : USING '(' name_list ')' { Using (reverse $3) }+ | ON a_expr { On $2 }++relation_expr :: { Name } -- TODO FIXME+ : qualified_name { $1 } -- * inheritance query, implicitly+-- TODO | qualified_name '*'+-- TODO {+-- TODO /* inheritance query, explicitly */+-- TODO $$ = $1;+-- TODO $$->inh = true;+-- TODO $$->alias = NULL;+-- TODO }+-- TODO | ONLY qualified_name+-- TODO {+-- TODO /* no inheritance */+-- TODO $$ = $2;+-- TODO $$->inh = false;+-- TODO $$->alias = NULL;+-- TODO }+-- TODO | ONLY '(' qualified_name ')'+-- TODO {+-- TODO /* no inheritance, SQL99-style syntax */+-- TODO $$ = $3;+-- TODO $$->inh = false;+-- TODO $$->alias = NULL;+-- TODO }++relation_expr_list : list(relation_expr) { $1 }++-- TODO relation_expr_opt_alias+-- TODO tablesample_clause+-- TODO opt_repeatable_clause:+-- TODO func_table+-- TODO rowsfrom_item+-- TODO rowsfrom_list:+-- TODO opt_col_def_list+-- TODO opt_ordinality++where_clause :: { Maybe Expr }+ : WHERE a_expr { Just $2 }+ | { Nothing }++-- TODO where_or_current_clause ::+-- TODO OptTableFuncElementList ::+-- TODO TableFuncElementList ::+-- TODO TableFuncElement ::+-- TODO xmltable ::+-- TODO xmltable_column_list ::+-- TODO xmltable_column_el ::+-- TODO xmltable_column_option_list ::+-- TODO xmltable_column_option_el ::+-- TODO xml_namespace_list ::+-- TODO xml_namespace_el ::+-- TODO Typename ::+-- TODO opt_array_bounds ::+-- TODO SimpleTypename ::+-- TODO ConstTypename ::+-- TODO GenericType ::+-- TODO opt_type_modifiers ::+-- TODO Numeric ::++-- * expression grammar++-- * General expressions+-- * This is the heart of the expression syntax.+-- *+-- * We have two expression types: a_expr is the unrestricted kind, and+-- * b_expr is a subset that must be used in some places to avoid shift/reduce+-- * conflicts. For example, we can't do BETWEEN as "BETWEEN a_expr AND a_expr"+-- * because that use of AND conflicts with AND as a boolean operator. So,+-- * b_expr is used in BETWEEN and we remove boolean keywords from b_expr.+-- *+-- * Note that '(' a_expr ')' is a b_expr, so an unrestricted expression can+-- * always be used by surrounding it with parens.+-- *+-- * c_expr is all the productions that are common to a_expr and b_expr;+-- * it's factored out just to eliminate redundant coding.+-- *+-- * Be careful of productions involving more than one terminal token.+-- * By default, bison will assign such productions the precedence of their+-- * last terminal, but in nearly all cases you want it to be the precedence+-- * of the first terminal instead; otherwise you will not get the behavior+-- * you expect! So we use %prec annotations freely to set precedences.++a_expr :: { Expr }+ : c_expr { $1 }+-- TODO | a_expr TYPECAST Typename+-- TODO { $$ = makeTypeCast($1, $3, @2); }+-- TODO | a_expr COLLATE any_name+-- TODO {+-- TODO CollateClause *n = makeNode(CollateClause);+-- TODO n->arg = $1;+-- TODO n->collname = $3;+-- TODO n->location = @2;+-- TODO $$ = (Node *) n;+-- TODO }+-- TODO | a_expr AT TIME ZONE a_expr %prec AT+-- TODO {+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("timezone"),+-- TODO list_make2($5, $1),+-- TODO @2);+-- What about lines 13060-13102 of gram.y?+ | '+' a_expr %prec UMINUS { $2 } -- TODO keep + for round-trip?+ | '-' a_expr %prec UMINUS { Unary Negate $2 }+ | a_expr '+' a_expr { BinOp Add $1 $3 }+ | a_expr '-' a_expr { BinOp Sub $1 $3 }+ | a_expr '*' a_expr { BinOp Mul $1 $3 }+ | a_expr '/' a_expr { BinOp Div $1 $3 }+ | a_expr '%' a_expr { BinOp Mod $1 $3 }+ | a_expr '^' a_expr { BinOp Exponent $1 $3 }+ | a_expr '<' a_expr { BinOp LT $1 $3 }+ | a_expr '>' a_expr { BinOp GT $1 $3 }+ | a_expr '=' a_expr { BinOp Eq $1 $3 }+ | a_expr '<=' a_expr { BinOp LTE $1 $3 }+ | a_expr '>=' a_expr { BinOp GTE $1 $3 }+ | a_expr '!=' a_expr { BinOp NEq $1 $3 }+-- TODO | a_expr qual_Op a_expr %prec Op+-- TODO { $$ = (Node *) makeA_Expr(AEXPR_OP, $2, $1, $3, @2); }+-- TODO | qual_Op a_expr %prec Op+-- TODO { $$ = (Node *) makeA_Expr(AEXPR_OP, $1, NULL, $2, @1); }+-- TODO | a_expr qual_Op %prec POSTFIXOP+-- TODO { $$ = (Node *) makeA_Expr(AEXPR_OP, $2, $1, NULL, @2); }+-- TODO | a_expr qual_Op a_expr %prec Op { BinOp $2 $1 $3 }+ | a_expr AND a_expr { BinOp And $1 $3 }+ | a_expr OR a_expr { BinOp Or $1 $3 }+ | NOT a_expr { Unary Not $2 }+-- TODO | NOT a_expr %prec NOT+-- TODO { $$ = makeNotExpr($2, @1); }+ | a_expr LIKE a_expr { L (LikeE Like $1 $3 Nothing False) }+ | a_expr LIKE a_expr ESCAPE a_expr %prec LIKE { L (LikeE Like $1 $3 (Just $5) False) }+ | a_expr NOT LIKE a_expr %prec NOT { L (LikeE Like $1 $4 Nothing True) }+ | a_expr NOT LIKE a_expr ESCAPE a_expr %prec NOT+ { L (LikeE Like $1 $4 (Just $6) True) }+ | a_expr ILIKE a_expr { L (LikeE ILike $1 $3 Nothing False) }+ | a_expr ILIKE a_expr ESCAPE a_expr %prec ILIKE { L (LikeE ILike $1 $3 (Just $5) False) }+ | a_expr NOT ILIKE a_expr %prec NOT { L (LikeE ILike $1 $4 Nothing True) }+ | a_expr NOT ILIKE a_expr ESCAPE a_expr %prec NOT+ { L (LikeE ILike $1 $4 (Just $6) True) }+ | a_expr SIMILAR TO a_expr %prec SIMILAR+ { L (LikeE Similar $1 $4 Nothing False) }+ | a_expr SIMILAR TO a_expr ESCAPE a_expr %prec SIMILAR+ { L (LikeE Similar $1 $4 (Just $6) False) }+ | a_expr NOT SIMILAR TO a_expr %prec NOT+ { L (LikeE Similar $1 $5 Nothing True) }+ | a_expr NOT SIMILAR TO a_expr ESCAPE a_expr %prec NOT+ { L (LikeE Similar $1 $5 (Just $7) True) }+-- * NullTest clause+-- * Define SQL-style Null test clause.+-- * Allow two forms described in the standard:+-- * a IS NULL+-- * a IS NOT NULL+-- * Allow two SQL extensions+-- * a ISNULL+-- * a NOTNULL+ | a_expr IS NULL_P %prec IS { Unary IsNull $1 }+ | a_expr ISNULL { Unary IsNull $1 }+ | a_expr IS NOT NULL_P %prec IS { Unary NotNull $1 }+ | a_expr NOTNULL { Unary NotNull $1 }+-- TODO | row OVERLAPS row+-- TODO {+-- TODO if (list_length($1) != 2)+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("wrong number of parameters on left side of OVERLAPS expression"),+-- TODO parser_errposition(@1)));+-- TODO if (list_length($3) != 2)+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("wrong number of parameters on right side of OVERLAPS expression"),+-- TODO parser_errposition(@3)));+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("overlaps"),+-- TODO list_concat($1, $3),+-- TODO @2);+-- TODO }+-- TODO | a_expr IS TRUE_P %prec IS+-- TODO {+-- TODO BooleanTest *b = makeNode(BooleanTest);+-- TODO b->arg = (Expr *) $1;+-- TODO b->booltesttype = IS_TRUE;+-- TODO b->location = @2;+-- TODO $$ = (Node *)b;+-- TODO }+-- TODO | a_expr IS NOT TRUE_P %prec IS+-- TODO {+-- TODO BooleanTest *b = makeNode(BooleanTest);+-- TODO b->arg = (Expr *) $1;+-- TODO b->booltesttype = IS_NOT_TRUE;+-- TODO b->location = @2;+-- TODO $$ = (Node *)b;+-- TODO }+-- TODO | a_expr IS FALSE_P %prec IS+-- TODO {+-- TODO BooleanTest *b = makeNode(BooleanTest);+-- TODO b->arg = (Expr *) $1;+-- TODO b->booltesttype = IS_FALSE;+-- TODO b->location = @2;+-- TODO $$ = (Node *)b;+-- TODO }+-- TODO | a_expr IS NOT FALSE_P %prec IS+-- TODO {+-- TODO BooleanTest *b = makeNode(BooleanTest);+-- TODO b->arg = (Expr *) $1;+-- TODO b->booltesttype = IS_NOT_FALSE;+-- TODO b->location = @2;+-- TODO $$ = (Node *)b;+-- TODO }+-- TODO | a_expr IS UNKNOWN %prec IS+-- TODO {+-- TODO BooleanTest *b = makeNode(BooleanTest);+-- TODO b->arg = (Expr *) $1;+-- TODO b->booltesttype = IS_UNKNOWN;+-- TODO b->location = @2;+-- TODO $$ = (Node *)b;+-- TODO }+-- TODO | a_expr IS NOT UNKNOWN %prec IS+-- TODO {+-- TODO BooleanTest *b = makeNode(BooleanTest);+-- TODO b->arg = (Expr *) $1;+-- TODO b->booltesttype = IS_NOT_UNKNOWN;+-- TODO b->location = @2;+-- TODO $$ = (Node *)b;+-- TODO }+ | a_expr IS DISTINCT FROM a_expr %prec IS { BinOp IsDistinctFrom $1 $5 }+ | a_expr IS NOT DISTINCT FROM a_expr %prec IS { BinOp IsNotDistinctFrom $1 $6 }+-- TODO | a_expr IS OF '(' type_list ')' %prec IS+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_OF, "=", $1, (Node *) $5, @2);+-- TODO }+-- TODO | a_expr IS NOT OF '(' type_list ')' %prec IS+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_OF, "<>", $1, (Node *) $6, @2);+-- TODO }+-- TODO | a_expr BETWEEN opt_asymmetric b_expr AND a_expr %prec BETWEEN+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_BETWEEN,+-- TODO "BETWEEN",+-- TODO $1,+-- TODO (Node *) list_make2($4, $6),+-- TODO @2);+-- TODO }+-- TODO | a_expr NOT BETWEEN opt_asymmetric b_expr AND a_expr %prec NOT+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_NOT_BETWEEN,+-- TODO "NOT BETWEEN",+-- TODO $1,+-- TODO (Node *) list_make2($5, $7),+-- TODO @2);+-- TODO }+-- TODO | a_expr BETWEEN SYMMETRIC b_expr AND a_expr %prec BETWEEN+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_BETWEEN_SYM,+-- TODO "BETWEEN SYMMETRIC",+-- TODO $1,+-- TODO (Node *) list_make2($4, $6),+-- TODO @2);+-- TODO }+-- TODO | a_expr NOT BETWEEN SYMMETRIC b_expr AND a_expr %prec NOT+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_NOT_BETWEEN_SYM,+-- TODO "NOT BETWEEN SYMMETRIC",+-- TODO $1,+-- TODO (Node *) list_make2($5, $7),+-- TODO @2);+-- TODO }+-- TODO | a_expr IN_P in_expr+-- TODO {+-- TODO /* in_expr returns a SubLink or a list of a_exprs */+-- TODO if (IsA($3, SubLink))+-- TODO {+-- TODO /* generate foo = ANY (subquery) */+-- TODO SubLink *n = (SubLink *) $3;+-- TODO n->subLinkType = ANY_SUBLINK;+-- TODO n->subLinkId = 0;+-- TODO n->testexpr = $1;+-- TODO n->operName = NIL; /* show it's IN not = ANY */+-- TODO n->location = @2;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO else+-- TODO {+-- TODO /* generate scalar IN expression */+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_IN, "=", $1, $3, @2);+-- TODO }+-- TODO }+-- TODO | a_expr NOT IN_P in_expr %prec NOT+-- TODO {+-- TODO /* in_expr returns a SubLink or a list of a_exprs */+-- TODO if (IsA($4, SubLink))+-- TODO {+-- TODO /* generate NOT (foo = ANY (subquery)) */+-- TODO /* Make an = ANY node */+-- TODO SubLink *n = (SubLink *) $4;+-- TODO n->subLinkType = ANY_SUBLINK;+-- TODO n->subLinkId = 0;+-- TODO n->testexpr = $1;+-- TODO n->operName = NIL; /* show it's IN not = ANY */+-- TODO n->location = @2;+-- TODO /* Stick a NOT on top; must have same parse location */+-- TODO $$ = makeNotExpr((Node *) n, @2);+-- TODO }+-- TODO else+-- TODO {+-- TODO /* generate scalar NOT IN expression */+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_IN, "<>", $1, $4, @2);+-- TODO }+-- TODO }+-- TODO | a_expr subquery_Op sub_type select_with_parens %prec Op+-- TODO {+-- TODO SubLink *n = makeNode(SubLink);+-- TODO n->subLinkType = $3;+-- TODO n->subLinkId = 0;+-- TODO n->testexpr = $1;+-- TODO n->operName = $2;+-- TODO n->subselect = $4;+-- TODO n->location = @2;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO | a_expr subquery_Op sub_type '(' a_expr ')' %prec Op+-- TODO {+-- TODO if ($3 == ANY_SUBLINK)+-- TODO $$ = (Node *) makeA_Expr(AEXPR_OP_ANY, $2, $1, $5, @2);+-- TODO else+-- TODO $$ = (Node *) makeA_Expr(AEXPR_OP_ALL, $2, $1, $5, @2);+-- TODO }+-- TODO | UNIQUE select_with_parens+-- TODO {+-- TODO /* Not sure how to get rid of the parentheses+-- TODO * but there are lots of shift/reduce errors without them.+-- TODO *+-- TODO * Should be able to implement this by plopping the entire+-- TODO * select into a node, then transforming the target expressions+-- TODO * from whatever they are into count(*), and testing the+-- TODO * entire result equal to one.+-- TODO * But, will probably implement a separate node in the executor.+-- TODO */+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),+-- TODO errmsg("UNIQUE predicate is not yet implemented"),+-- TODO parser_errposition(@1)));+-- TODO }+-- TODO | a_expr IS DOCUMENT_P %prec IS+-- TODO {+-- TODO $$ = makeXmlExpr(IS_DOCUMENT, NULL, NIL,+-- TODO list_make1($1), @2);+-- TODO }+-- TODO | a_expr IS NOT DOCUMENT_P %prec IS+-- TODO {+-- TODO $$ = makeNotExpr(makeXmlExpr(IS_DOCUMENT, NULL, NIL,+-- TODO list_make1($1), @2),+-- TODO @2);+-- TODO }+-- TODO | DEFAULT+-- TODO {+-- TODO /*+-- TODO * The SQL spec only allows DEFAULT in "contextually typed+-- TODO * expressions", but for us, it's easier to allow it in+-- TODO * any a_expr and then throw error during parse analysis+-- TODO * if it's in an inappropriate context. This way also+-- TODO * lets us say something smarter than "syntax error".+-- TODO */+-- TODO SetToDefault *n = makeNode(SetToDefault);+-- TODO /* parse analysis will fill in the rest */+-- TODO n->location = @1;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO ;++-- * Restricted expressions+-- *+-- * b_expr is a subset of the complete expression syntax defined by a_expr.+-- *+-- * Presently, AND, NOT, IS, and IN are the a_expr keywords that would+-- * cause trouble in the places where b_expr is used. For simplicity, we+-- * just eliminate all the boolean-keyword-operator productions from b_expr.+b_expr :: { Expr }+ : c_expr { $1 }+-- TODO | b_expr TYPECAST Typename+-- TODO { $$ = makeTypeCast($1, $3, @2); }+ | '+' b_expr %prec UMINUS { $2 } -- TODO keep + for round-trip?+-- TODO { $$ = (Node *) makeSimpleA_Expr(AEXPR_OP, "+", NULL, $2, @1); }+ | '-' b_expr %prec UMINUS { Unary Negate $2 }+ | b_expr '+' b_expr { BinOp Add $1 $3 }+ | b_expr '-' b_expr { BinOp Sub $1 $3 }+ | b_expr '*' b_expr { BinOp Mul $1 $3 }+ | b_expr '/' b_expr { BinOp Div $1 $3 }+ | b_expr '%' b_expr { BinOp Mod $1 $3 }+ | b_expr '^' b_expr { BinOp Exponent $1 $3 }+ | b_expr '<' b_expr { BinOp LT $1 $3 }+ | b_expr '>' b_expr { BinOp GT $1 $3 }+ | b_expr '=' b_expr { BinOp Eq $1 $3 }+ | b_expr '<=' b_expr { BinOp LTE $1 $3 }+ | b_expr '>=' b_expr { BinOp GTE $1 $3 }+ | b_expr '!=' b_expr { BinOp NEq $1 $3 }+ | b_expr qual_Op b_expr %prec Op { BinOp $2 $1 $3 }+-- FIXME exclude user-defined operators, or give up on Syntax allowing only correct operator arity?+-- TODO | qual_Op b_expr %prec Op+-- TODO { $$ = (Node *) makeA_Expr(AEXPR_OP, $1, NULL, $2, @1); }+-- TODO | b_expr qual_Op %prec POSTFIXOP+-- TODO { $$ = (Node *) makeA_Expr(AEXPR_OP, $2, $1, NULL, @2); }+ | b_expr IS DISTINCT FROM b_expr %prec IS { BinOp IsDistinctFrom $1 $5 }+ | b_expr IS NOT DISTINCT FROM b_expr %prec IS { BinOp IsNotDistinctFrom $1 $6 }+-- TODO | b_expr IS OF '(' type_list ')' %prec IS+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_OF, "=", $1, (Node *) $5, @2);+-- TODO }+-- TODO | b_expr IS NOT OF '(' type_list ')' %prec IS+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_OF, "<>", $1, (Node *) $6, @2);+-- TODO }+-- TODO | b_expr IS DOCUMENT_P %prec IS+-- TODO {+-- TODO $$ = makeXmlExpr(IS_DOCUMENT, NULL, NIL,+-- TODO list_make1($1), @2);+-- TODO }+-- TODO | b_expr IS NOT DOCUMENT_P %prec IS+-- TODO {+-- TODO $$ = makeNotExpr(makeXmlExpr(IS_DOCUMENT, NULL, NIL,+-- TODO list_make1($1), @2),+-- TODO @2);+-- TODO }++-- * Productions that can be used in both a_expr and b_expr.+-- *+-- * Note: productions that refer recursively to a_expr or b_expr mostly+-- * cannot appear here. However, it's OK to refer to a_exprs that occur+-- * inside parentheses, such as function arguments; that cannot introduce+-- * ambiguity to the b_expr syntax.+c_expr :: { Expr }+ : columnref { $1 }+ | AexprConst { Lit $1 }+ -- TODO check_indirection+ | PARAM opt_indirection+ { case $2 of+ Nothing -> NumberedParam $1+ Just ne -> Indirection (NumberedParam $1) ne }+ | HASKELL_PARAM { HaskellParam $1 }+ | '(' a_expr ')' opt_indirection+ { case $4 of+ Nothing -> $2+ Just ne -> Indirection $2 ne }+ -- gram.y optionally warns about operator precedence+ | case_expr { Cas $1 }+ | func_expr { Fun $1 }+ | select_with_parens %prec UMINUS { SelectExpr $1 }+ | select_with_parens indirection { Indirection (SelectExpr $1) $2 }+-- * Because the select_with_parens nonterminal is designed+-- * to "eat" as many levels of parens as possible, the+-- * '(' a_expr ')' opt_indirection production above will+-- * fail to match a sub-SELECT with indirection decoration;+-- * the sub-SELECT won't be regarded as an a_expr as long+-- * as there are parens around it. To support applying+-- * subscripting or field selection to a sub-SELECT result,+-- * we need this redundant-looking production.+-- TODO | EXISTS select_with_parens+-- TODO {+-- TODO SubLink *n = makeNode(SubLink);+-- TODO n->subLinkType = EXISTS_SUBLINK;+-- TODO n->subLinkId = 0;+-- TODO n->testexpr = NULL;+-- TODO n->operName = NIL;+-- TODO n->subselect = $2;+-- TODO n->location = @1;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO | ARRAY select_with_parens+-- TODO {+-- TODO SubLink *n = makeNode(SubLink);+-- TODO n->subLinkType = ARRAY_SUBLINK;+-- TODO n->subLinkId = 0;+-- TODO n->testexpr = NULL;+-- TODO n->operName = NIL;+-- TODO n->subselect = $2;+-- TODO n->location = @1;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO | ARRAY array_expr+-- TODO {+-- TODO A_ArrayExpr *n = castNode(A_ArrayExpr, $2);+-- TODO /* point outermost A_ArrayExpr to the ARRAY keyword */+-- TODO n->location = @1;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO | explicit_row+-- TODO {+-- TODO RowExpr *r = makeNode(RowExpr);+-- TODO r->args = $1;+-- TODO r->row_typeid = InvalidOid; /* not analyzed yet */+-- TODO r->colnames = NIL; /* to be filled in during analysis */+-- TODO r->row_format = COERCE_EXPLICIT_CALL; /* abuse */+-- TODO r->location = @1;+-- TODO $$ = (Node *)r;+-- TODO }+-- TODO | implicit_row+-- TODO {+-- TODO RowExpr *r = makeNode(RowExpr);+-- TODO r->args = $1;+-- TODO r->row_typeid = InvalidOid; /* not analyzed yet */+-- TODO r->colnames = NIL; /* to be filled in during analysis */+-- TODO r->row_format = COERCE_IMPLICIT_CAST; /* abuse */+-- TODO r->location = @1;+-- TODO $$ = (Node *)r;+-- TODO }+-- TODO | GROUPING '(' expr_list ')'+-- TODO {+-- TODO GroupingFunc *g = makeNode(GroupingFunc);+-- TODO g->args = $3;+-- TODO g->location = @1;+-- TODO $$ = (Node *)g;+-- TODO }+-- TODO ;++func_application :: { FunctionApplication }+ : func_name '(' ')' { fapp $1 NoArgs }+ | func_name '(' func_arg_list opt_sort_clause ')'+ { fapp $1 (Args (argsList $3)) `setSortBy` $4 }+-- TODO | func_name '(' VARIADIC func_arg_expr opt_sort_clause ')'+-- TODO {+-- TODO FuncCall *n = makeFuncCall($1, list_make1($4), @1);+-- TODO n->func_variadic = true;+-- TODO n->agg_order = $5;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO | func_name '(' func_arg_list ',' VARIADIC func_arg_expr opt_sort_clause ')'+-- TODO {+-- TODO FuncCall *n = makeFuncCall($1, lappend($3, $6), @1);+-- TODO n->func_variadic = true;+-- TODO n->agg_order = $7;+-- TODO $$ = (Node *)n;+-- TODO }+ | func_name '(' ALL func_arg_list opt_sort_clause ')'+ { fapp $1 (Args (argsList $4)) `setSortBy` $5 }+ -- * Ideally we'd mark the FuncCall node to indicate+ -- * "must be an aggregate", but there's no provision+ -- * for that in FuncCall at the moment.+ -- *+ | func_name '(' DISTINCT func_arg_list opt_sort_clause ')'+ { fapp $1 (Args (ArgsList $4 $5 True))}+ | func_name '(' '*' ')' { (fapp $1 StarArg) { arguments = StarArg } }++-- * func_expr and its cousin func_expr_windowless are split out from c_expr just+-- * so that we have classifications for "everything that is a function call or+-- * looks like one". This isn't very important, but it saves us having to+-- * document which variants are legal in places like "FROM function()" or the+-- * backwards-compatible functional-index syntax for CREATE INDEX.+-- * (Note that many of the special SQL functions wouldn't actually make any+-- * sense as functional index entries, but we ignore that consideration here.)++func_expr :: { FunctionApplication }+ : func_application within_group_clause filter_clause over_clause+-- We disallow some cases that the PostgreSQL server disallows,+-- even though our representation doesn't have exactly the same+-- constraints. Upstream comment:+-- * The order clause for WITHIN GROUP and the one for+-- * plain-aggregate ORDER BY share a field, so we have to+-- * check here that at most one is present. We also check+-- * for DISTINCT and VARIADIC here to give a better error+-- * location. Other consistency checks are deferred to+-- * parse analysis.+{% do+ result <- case ($1, $2) of+ (_, []) -> return $1+ (FApp{arguments}, _) -> do+ case arguments of+ Args ArgsList {distinct, sortBy} -> do+ when (not (null sortBy)) (fail "cannot use multiple ORDER BY clauses with WITHIN GROUP")+ when distinct (fail "cannot use DISTINCT with WITHIN GROUP")+ _ -> pure ()+ return $1 { withinGroup = $2 }+ return result { filterClause = $3 , over = $4 }+}+-- TODO if (n->func_variadic)+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("cannot use VARIADIC with WITHIN GROUP"),+-- TODO parser_errposition(@2)));+-- TODO n->agg_order = $2;+-- TODO n->agg_within_group = true;+-- TODO }+ | func_expr_common_subexpr { $1 }++-- * as func_expr but does not accept window functions directly+-- * (but they can still be contained in arguments for functions etc).+-- * use this when window expressions are not allowed, where needed to+-- * disambiguate the grammar (e.g. in CREATE INDEX).++func_expr_windowless :: { FunctionApplication }+ : func_application { $1 }+ | func_expr_common_subexpr { $1 }++-- * Special expressions that are considered to be functions.++func_expr_common_subexpr :: { FunctionApplication }+ : COLLATION FOR '(' a_expr ')' { fapp1 "pg_collation_for" [$4] }+ | CURRENT_DATE { fapp1 "CURRENT_DATE" [] }+ | CURRENT_TIME { fapp1 "CURRENT_TIME" [] }+ | CURRENT_TIME '(' Iconst ')' { fapp1 "CURRENT_TIME" [Lit (I $3)] }+ | CURRENT_TIMESTAMP { fapp1 "CURRENT_TIMESTAMP" [] }+ | CURRENT_TIMESTAMP '(' Iconst ')' { fapp1 "CURRENT_TIMESTAMP" [Lit (I $3)] }+ | LOCALTIME { fapp1 "LOCALTIME" [] }+ | LOCALTIME '(' Iconst ')' { fapp1 "LOCALTIME" [Lit (I $3)] }+ | LOCALTIMESTAMP { fapp1 "LOCALTIMESTAMP" [] }+ | LOCALTIMESTAMP '(' Iconst ')' { fapp1 "LOCALTIMESTAMP" [Lit (I $3)] }+ | CURRENT_ROLE { fapp1 "CURRENT_ROLE" [] }+ | CURRENT_USER { fapp1 "CURRENT_USER" [] }+ | SESSION_USER { fapp1 "SESSION_USER" [] }+ | USER { fapp1 "USER" [] }+ | CURRENT_CATALOG { fapp1 "CURRENT_CATALOG" [] }+ | CURRENT_SCHEMA { fapp1 "CURRENT_SCHEMA" [] }+-- TODO | CAST '(' a_expr AS Typename ')' { $$ = makeTypeCast($3, $5, @1); }+-- TODO | EXTRACT '(' extract_list ')' { fapp1 "date_part" [$3] }+-- TODO | OVERLAY '(' overlay_list ')'+-- TODO {+-- TODO /* overlay(A PLACING B FROM C FOR D) is converted to+-- TODO * overlay(A, B, C, D)+-- TODO * overlay(A PLACING B FROM C) is converted to+-- TODO * overlay(A, B, C)+-- TODO */+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("overlay"), $3, @1);+-- TODO }+-- TODO | POSITION '(' position_list ')'+-- TODO {+-- TODO /* position(A in B) is converted to position(B, A) */+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("position"), $3, @1);+-- TODO }+-- TODO | SUBSTRING '(' substr_list ')'+-- TODO {+-- TODO /* substring(A from B for C) is converted to+-- TODO * substring(A, B, C) - thomas 2000-11-28+-- TODO */+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("substring"), $3, @1);+-- TODO }+-- TODO | TREAT '(' a_expr AS Typename ')'+-- TODO {+-- TODO /* TREAT(expr AS target) converts expr of a particular type to target,+-- TODO * which is defined to be a subtype of the original expression.+-- TODO * In SQL99, this is intended for use with structured UDTs,+-- TODO * but let's make this a generally useful form allowing stronger+-- TODO * coercions than are handled by implicit casting.+-- TODO *+-- TODO * Convert SystemTypeName() to SystemFuncName() even though+-- TODO * at the moment they result in the same thing.+-- TODO */+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName(((Value *)llast($5->names))->val.str),+-- TODO list_make1($3),+-- TODO @1);+-- TODO }+-- TODO | TRIM '(' BOTH trim_list ')'+-- TODO {+-- TODO /* various trim expressions are defined in SQL+-- TODO * - thomas 1997-07-19+-- TODO */+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("btrim"), $4, @1);+-- TODO }+-- TODO | TRIM '(' LEADING trim_list ')'+-- TODO {+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("ltrim"), $4, @1);+-- TODO }+-- TODO | TRIM '(' TRAILING trim_list ')'+-- TODO {+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("rtrim"), $4, @1);+-- TODO }+-- TODO | TRIM '(' trim_list ')'+-- TODO {+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("btrim"), $3, @1);+-- TODO }+-- TODO | NULLIF '(' a_expr ',' a_expr ')'+-- TODO {+-- TODO $$ = (Node *) makeSimpleA_Expr(AEXPR_NULLIF, "=", $3, $5, @1);+-- TODO }+ | COALESCE '(' expr_list ')' { fapp1 "coalesce" $3 }+ | GREATEST '(' expr_list ')' { fapp1 "greatest" $3 }+ | LEAST '(' expr_list ')' { fapp1 "least" $3 }+-- TODO | XMLCONCAT '(' expr_list ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLCONCAT, NULL, NIL, $3, @1);+-- TODO }+-- TODO | XMLELEMENT '(' NAME_P ColLabel ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLELEMENT, $4, NIL, NIL, @1);+-- TODO }+-- TODO | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLELEMENT, $4, $6, NIL, @1);+-- TODO }+-- TODO | XMLELEMENT '(' NAME_P ColLabel ',' expr_list ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLELEMENT, $4, NIL, $6, @1);+-- TODO }+-- TODO | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ',' expr_list ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLELEMENT, $4, $6, $8, @1);+-- TODO }+-- TODO | XMLEXISTS '(' c_expr xmlexists_argument ')'+-- TODO {+-- TODO /* xmlexists(A PASSING [BY REF] B [BY REF]) is+-- TODO * converted to xmlexists(A, B)*/+-- TODO $$ = (Node *) makeFuncCall(SystemFuncName("xmlexists"), list_make2($3, $4), @1);+-- TODO }+-- TODO | XMLFOREST '(' xml_attribute_list ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLFOREST, NULL, $3, NIL, @1);+-- TODO }+-- TODO | XMLPARSE '(' document_or_content a_expr xml_whitespace_option ')'+-- TODO {+-- TODO XmlExpr *x = (XmlExpr *)+-- TODO makeXmlExpr(IS_XMLPARSE, NULL, NIL,+-- TODO list_make2($4, makeBoolAConst($5, -1)),+-- TODO @1);+-- TODO x->xmloption = $3;+-- TODO $$ = (Node *)x;+-- TODO }+-- TODO | XMLPI '(' NAME_P ColLabel ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLPI, $4, NULL, NIL, @1);+-- TODO }+-- TODO | XMLPI '(' NAME_P ColLabel ',' a_expr ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLPI, $4, NULL, list_make1($6), @1);+-- TODO }+-- TODO | XMLROOT '(' a_expr ',' xml_root_version opt_xml_root_standalone ')'+-- TODO {+-- TODO $$ = makeXmlExpr(IS_XMLROOT, NULL, NIL,+-- TODO list_make3($3, $5, $6), @1);+-- TODO }+-- TODO | XMLSERIALIZE '(' document_or_content a_expr AS SimpleTypename ')'+-- TODO {+-- TODO XmlSerialize *n = makeNode(XmlSerialize);+-- TODO n->xmloption = $3;+-- TODO n->expr = $4;+-- TODO n->typeName = $6;+-- TODO n->location = @1;+-- TODO $$ = (Node *)n;+-- TODO }+-- TODO ;++-- TODO xml_root_version ::+-- TODO opt_xml_root_standalone ::+-- TODO xml_attributes ::+-- TODO xml_attribute_list ::+-- TODO xml_attribute_el ::+-- TODO document_or_content ::+-- TODO xml_whitespace_option ::+-- TODO xmlexists_argument ::+-- TODO xml_passing_mech ::++-- * Aggregate decoration clauses+within_group_clause :: { [SortBy] }+ : WITHIN GROUP_P '(' sort_clause ')' { $4 }+ | { [] }++filter_clause :: { Maybe Expr }+ : FILTER '(' WHERE a_expr ')' { Just $4 }+ | { Nothing }++-- * Window Definitions+window_clause+ : WINDOW window_definition_list { reverse $2 }+ | { [] }++window_definition_list : list(window_definition) { $1 }++window_definition :: { WindowDef }+ : ColId AS window_specification { WindowDef $1 $3 }++over_clause :: { Over }+: OVER window_specification { Window $2 }+| OVER ColId { WindowName $2 }+| { noWindow }++window_specification :: { WindowSpec }+: '(' opt_existing_window_name opt_partition_clause opt_sort_clause opt_frame_clause ')'+ { WindowSpec $2 $3 $4 }++-- * If we see PARTITION, RANGE, ROWS or GROUPS as the first token after the '('+-- * of a window_specification, we want the assumption to be that there is+-- * no existing_window_name; but those keywords are unreserved and so could+-- * be ColIds. We fix this by making them have the same precedence as IDENT+-- * and giving the empty production here a slightly higher precedence, so+-- * that the shift/reduce conflict is resolved in favor of reducing the rule.+-- * These keywords are thus precluded from being an existing_window_name but+-- * are not reserved for any other purpose.+opt_existing_window_name :: { Maybe Name }+ : ColId { Just $1 }+ | %prec Op { Nothing }++opt_partition_clause :: { [Expr] }+ : PARTITION BY expr_list { $3 }+ | { [] }++-- * For frame clauses, we return a WindowDef, but only some fields are used:+-- * frameOptions, startOffset, and endOffset.+-- FIXME What is this, how do I want to handle the bitflags?+opt_frame_clause : { () }+-- TODO RANGE frame_extent opt_window_exclusion_clause+-- TODO {+-- TODO WindowDef *n = $2;+-- TODO n->frameOptions |= FRAMEOPTION_NONDEFAULT | FRAMEOPTION_RANGE;+-- TODO n->frameOptions |= $3;+-- TODO $$ = n;+-- TODO }+-- TODO | ROWS frame_extent opt_window_exclusion_clause+-- TODO {+-- TODO WindowDef *n = $2;+-- TODO n->frameOptions |= FRAMEOPTION_NONDEFAULT | FRAMEOPTION_ROWS;+-- TODO n->frameOptions |= $3;+-- TODO $$ = n;+-- TODO }+-- TODO | GROUPS frame_extent opt_window_exclusion_clause+-- TODO {+-- TODO WindowDef *n = $2;+-- TODO n->frameOptions |= FRAMEOPTION_NONDEFAULT | FRAMEOPTION_GROUPS;+-- TODO n->frameOptions |= $3;+-- TODO $$ = n;+-- TODO }+-- TODO | /*EMPTY*/+-- TODO {+-- TODO WindowDef *n = makeNode(WindowDef);+-- TODO n->frameOptions = FRAMEOPTION_DEFAULTS;+-- TODO n->startOffset = NULL;+-- TODO n->endOffset = NULL;+-- TODO $$ = n;+-- TODO }+-- TODO ;++-- TODO frame_extent ::+-- TODO frame_bound ::+-- TODO opt_window_exclusion_clause ::+-- TODO row ::+-- TODO explicit_row ::+-- TODO implicit_row ::+-- TODO sub_type ::++all_Op : MathOp { $1 }+-- We don't (yet?) support user-defined operators++MathOp :: { BinOp }+ : '+' { Add }+ | '-' { Sub }+ | '*' { Mul }+ | '/' { Div }+ | '%' { Mod }+ | '^' { Exponent }+ | '<' { LT }+ | '>' { GT }+ | '=' { Eq }+ | '<=' { LTE }+ | '>=' { GTE }+ | '!=' { NEq }++qual_Op+ -- We don't (yet?) support user-defined operators+ -- : Op { $1 }+ : OPERATOR '(' any_operator ')' { $3 }++qual_all_Op+ : all_Op { $1 }+ | OPERATOR '(' any_operator ')' { $3 }++-- TODO subquery_Op ::++expr_list : list(a_expr) { reverse $1 }++-- * function arguments can have names+func_arg_list : list(func_arg_expr) { NE.fromList (reverse $1) }++func_arg_expr :: { Argument }+ : a_expr { E $1 }+ | param_name COLON_EQUALS a_expr { Named $1 $3 }+ | param_name EQUALS_GREATER a_expr { Named $1 $3 }++-- TODO type_list::+-- TODO array_expr ::+-- TODO array_expr_list ::+-- TODO extract_list ::+-- TODO extract_arg ::+-- TODO overlay_list ::+-- TODO overlay_placing ::+-- TODO position_list ::+-- TODO substr_list ::+-- TODO substr_from ::+-- TODO substr_for ::+-- TODO trim_list ::+-- TODO in_expr ::++-- * Define SQL-style CASE clause.+-- * - Full specification+-- * CASE WHEN a = b THEN c ... ELSE d END+-- * - Implicit argument+-- * CASE a WHEN b THEN c ... ELSE d END+case_expr :: { Case }+ : CASE case_arg when_clause_list case_default END_P+ { Case { implicitArg = $2, whenClause = reverse $3, elseClause = $4 } }++when_clause_list :: { [(Expr, Expr)] }+ : when_clause { [$1] }+ | when_clause_list when_clause { $2 : $1 }++when_clause :: { (Expr, Expr) }+ : WHEN a_expr THEN a_expr { ($2, $4) }++case_default :: { Maybe Expr }+ : ELSE a_expr { Just $2 }+ | { Nothing }++case_arg :: { Maybe Expr }+ : a_expr { Just $1 }+ | { Nothing }+++-- * Ideally param_name should be ColId, but that causes too many conflicts.+param_name :: { Name }+ : type_function_name { $1 }++-- FIXME handwritten+Insert : INSERT INTO Name '(' name_list ')' VALUES '(' expr_list ')'+ { Insert { table = $3, columns = NE.fromList (reverse $5), values = NE.fromList $9 } }++Update :: { Update }+ : UPDATE Name SET SettingList WHERE a_expr { Update { table = $2, settings = NE.fromList (reverse $4), conditions = Just $6 } }+ | UPDATE Name SET SettingList { Update { table = $2, settings = NE.fromList (reverse $4), conditions = Nothing } }++{- These lists are non-empty by construction, but not by type. List head is the right-most element. -}++list(el)+ : el { [$1] }+ | list(el) ',' el { $3 : $1 }++SettingList : list(Setting) { $1 }+++opt_asc_desc+ : ASC { Ascending }+ | DESC { Descending }+ | {- EMPTY -} { DefaultSortOrder }++opt_nulls_order+ : NULLS FIRST { NullsFirst }+ | NULLS LAST { NullsLast }+ | { NullsOrderDefault }++any_operator: all_Op { $1 }+-- We don't yet support schema-qualified operators (they're more useful if user-defined)++Setting :: { Setting }+ : Name '=' a_expr { Setting $1 $3 }++Name : IDENT { mkName $1 }++Null+ : IS NULL_P { IsNull }+ | ISNULL { IsNull }+ | IS NOT NULL_P { NotNull }+ | NOTNULL { NotNull }++columnref :: { Expr }+ : ColId { CRef $1 }+ | ColId indirection { Indirection (CRef $1) $2 }++indirection_el :: { Name } -- TODO bigger type+ : '.' attr_name { $2 }+-- TODO {+-- TODO $$ = (Node *) makeString($2);+-- TODO }+-- TODO | '.' '*'+-- TODO {+-- TODO $$ = (Node *) makeNode(A_Star);+-- TODO }+-- TODO | '[' a_expr ']'+-- TODO {+-- TODO A_Indices *ai = makeNode(A_Indices);+-- TODO ai->is_slice = false;+-- TODO ai->lidx = NULL;+-- TODO ai->uidx = $2;+-- TODO $$ = (Node *) ai;+-- TODO }+-- TODO | '[' opt_slice_bound ':' opt_slice_bound ']'+-- TODO {+-- TODO A_Indices *ai = makeNode(A_Indices);+-- TODO ai->is_slice = true;+-- TODO ai->lidx = $2;+-- TODO ai->uidx = $4;+-- TODO $$ = (Node *) ai;+-- TODO }+-- TODO ;++-- TODO opt_slice_bound:+-- TODO a_expr { $$ = $1; }+-- TODO | /*EMPTY*/ { $$ = NULL; }+-- TODO ;++indirection :: { NonEmpty Name }+ : rev_indirection { NE.reverse $1 }++rev_indirection :: { NonEmpty Name }+ : indirection_el { $1 :| [] }+ | rev_indirection indirection_el { NE.cons $2 $1 }++opt_indirection :: { Maybe (NonEmpty Name) }+ : { Nothing }+ | indirection { Just $1 }++-- TODO opt_asymmetric: ASYMMETRIC+-- TODO | /*EMPTY*/+-- TODO ;++-- * target list for SELECT++opt_target_list :: { [ResTarget] }+ : target_list { $1 }+ | { [] }++target_list : list(target_el) { reverse $1 }++target_el :: { ResTarget }+ : a_expr AS ColLabel { Column $1 (Just $3) }+ | a_expr Name { Column $1 (Just $2) }+ | a_expr { Column $1 Nothing }+ | '*' { Star }++ -- * Names and constants+qualified_name_list : list(qualified_name) { $1 }++-- * The production for a qualified relation name has to exactly match the+-- * production for a qualified func_name, because in a FROM clause we cannot+-- * tell which we are parsing until we see what comes after it ('(' for a+-- * func_name, something else for a relation). Therefore we allow 'indirection'+-- * which may contain subscripts, and reject that case in the C code.++qualified_name :: { Name }+ : ColId { $1 }+-- -- TODO | ColId indirection+-- TODO {+-- TODO check_qualified_name($2, yyscanner);+-- TODO $$ = makeRangeVar(NULL, NULL, @1);+-- TODO switch (list_length($2))+-- TODO {+-- TODO case 1:+-- TODO $$->catalogname = NULL;+-- TODO $$->schemaname = $1;+-- TODO $$->relname = strVal(linitial($2));+-- TODO break;+-- TODO case 2:+-- TODO $$->catalogname = $1;+-- TODO $$->schemaname = strVal(linitial($2));+-- TODO $$->relname = strVal(lsecond($2));+-- TODO break;+-- TODO default:+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("improper qualified name (too many dotted names): %s",+-- TODO NameListToString(lcons(makeString($1), $2))),+-- TODO parser_errposition(@1)));+-- TODO break;+-- TODO }+-- TODO }++name_list : list(name) { $1 }++opt_name_list+ : '(' name_list ')' { $2 }+ | { [] }++name : ColId { $1 }++database_name : ColId { $1 }++access_method : ColId { $1 }++attr_name : ColLabel { $1 }++index_name : ColId { $1 }++file_name : Sconst { $1 }++-- * The production for a qualified func_name has to exactly match the+-- * production for a qualified columnref, because we cannot tell which we+-- * are parsing until we see what comes after it ('(' or Sconst for a func_name,+-- * anything else for a columnref). Therefore we allow 'indirection' which+-- * may contain subscripts, and reject that case in the C code. (If we+-- * ever implement SQL99-like methods, such syntax may actually become legal!)+func_name :: { (Name, [Indirection]) }+ : type_function_name { ($1, []) }+ | ColId indirection { ($1, NE.toList $2) }++-- * Constants++AexprConst :: { Literal }+ : Iconst { I $1 }+ | Fconst { F $1 }+ | Sconst { T $1 }+-- TODO | BCONST+-- TODO {+-- TODO $$ = makeBitStringConst($1, @1);+-- TODO }+-- TODO | XCONST+-- TODO {+-- TODO /* This is a bit constant per SQL99:+-- TODO * Without Feature F511, "BIT data type",+-- TODO * a <general literal> shall not be a+-- TODO * <bit string literal> or a <hex string literal>.+-- TODO */+-- TODO $$ = makeBitStringConst($1, @1);+-- TODO }+-- TODO | func_name Sconst+-- TODO {+-- TODO /* generic type 'literal' syntax */+-- TODO TypeName *t = makeTypeNameFromNameList($1);+-- TODO t->location = @1;+-- TODO $$ = makeStringConstCast($2, @2, t);+-- TODO }+-- TODO | func_name '(' func_arg_list opt_sort_clause ')' Sconst+-- TODO {+-- TODO /* generic syntax with a type modifier */+-- TODO TypeName *t = makeTypeNameFromNameList($1);+-- TODO ListCell *lc;+-- TODO+-- TODO /*+-- TODO * We must use func_arg_list and opt_sort_clause in the+-- TODO * production to avoid reduce/reduce conflicts, but we+-- TODO * don't actually wish to allow NamedArgExpr in this+-- TODO * context, nor ORDER BY.+-- TODO */+-- TODO foreach(lc, $3)+-- TODO {+-- TODO NamedArgExpr *arg = (NamedArgExpr *) lfirst(lc);+-- TODO+-- TODO if (IsA(arg, NamedArgExpr))+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("type modifier cannot have parameter name"),+-- TODO parser_errposition(arg->location)));+-- TODO }+-- TODO if ($4 != NIL)+-- TODO ereport(ERROR,+-- TODO (errcode(ERRCODE_SYNTAX_ERROR),+-- TODO errmsg("type modifier cannot have ORDER BY"),+-- TODO parser_errposition(@4)));+-- TODO+-- TODO t->typmods = $3;+-- TODO t->location = @1;+-- TODO $$ = makeStringConstCast($6, @6, t);+-- TODO }+-- TODO | ConstTypename Sconst+-- TODO {+-- TODO $$ = makeStringConstCast($2, @2, $1);+-- TODO }+-- TODO | ConstInterval Sconst opt_interval+-- TODO {+-- TODO TypeName *t = $1;+-- TODO t->typmods = $3;+-- TODO $$ = makeStringConstCast($2, @2, t);+-- TODO }+-- TODO | ConstInterval '(' Iconst ')' Sconst+-- TODO {+-- TODO TypeName *t = $1;+-- TODO t->typmods = list_make2(makeIntConst(INTERVAL_FULL_RANGE, -1),+-- TODO makeIntConst($3, @3));+-- TODO $$ = makeStringConstCast($5, @5, t);+-- TODO }+ | TRUE_P { B True }+ | FALSE_P { B False }+ | NULL_P { Null }++-- TODO Iconst : ICONST { $1 }+-- TODO rename STRING -> SCONST to match bison+-- TODO Sconst : SCONST { $1 }+Sconst : STRING { $1 }++-- TODO SignedIconst+-- TODO : Iconst { $1 }+-- TODO | '+' Iconst { + $2 }+-- TODO | '-' Iconst { - $2 }+-- TODO++-- * Name classification hierarchy.+-- *+-- * IDENT is the lexeme returned by the lexer for identifiers that match+-- * no known keyword. In most cases, we can accept certain keywords as+-- * names, not only IDENTs. We prefer to accept as many such keywords+-- * as possible to minimize the impact of "reserved words" on programmers.+-- * So, we divide names into several possible classes. The classification+-- * is chosen in part to make keywords acceptable as names wherever possible.++-- Column identifier --- names that can be column, table, etc names.+ColId :: { Name }+ : Name { $1 }+ | unreserved_keyword { $1 }+ | col_name_keyword { $1 }++-- * Type/function identifier -- *- names that can be type or function names.+type_function_name :: { Name }+ : Name { $1 }+ | unreserved_keyword { $1 }+ | type_func_name_keyword { $1 }++-- * Any not-fully-reserved word -- *- these names can be, eg, role names.+NonReservedWord :: { Name }+ : Name { $1 }+ | unreserved_keyword { $1 }+ | col_name_keyword { $1 }+ | type_func_name_keyword { $1 }++-- * Column label -- *- allowed labels in "AS" clauses.+-- * This presently includes *all* Postgres keywords.+ColLabel :: { Name }+ : Name { $1 }+ | unreserved_keyword { $1 }+ | col_name_keyword { $1 }+ | type_func_name_keyword { $1 }+ | reserved_keyword { $1 }++-- * Keyword category lists. Generally, every keyword present in+-- * the Postgres grammar should appear in exactly one of these lists.+-- *+-- * Put a new keyword into the first list that it can go into without causing+-- * shift or reduce conflicts. The earlier lists define "less reserved"+-- * categories of keywords.+-- *+-- * Make sure that each keyword's category in kwlist.h matches where+-- * it is listed here. (Someday we may be able to generate these lists and+-- * kwlist.h's table from a common master list.)++-- * "Unreserved" keywords --- available for use as any kind of name.+unreserved_keyword :: { Name }+ : ABORT_P { Name "abort" }+ | ABSOLUTE_P { Name "absolute" }+ | ACCESS { Name "access" }+ | ACTION { Name "action" }+ | ADD_P { Name "add" }+ | ADMIN { Name "admin" }+ | AFTER { Name "after" }+ | AGGREGATE { Name "aggregate" }+ | ALSO { Name "also" }+ | ALTER { Name "alter" }+ | ALWAYS { Name "always" }+ | ASSERTION { Name "assertion" }+ | ASSIGNMENT { Name "assignment" }+ | AT { Name "at" }+ | ATTACH { Name "attach" }+ | ATTRIBUTE { Name "attribute" }+ | BACKWARD { Name "backward" }+ | BEFORE { Name "before" }+ | BEGIN_P { Name "begin" }+ | BY { Name "by" }+ | CACHE { Name "cache" }+ | CALL { Name "call" }+ | CALLED { Name "called" }+ | CASCADE { Name "cascade" }+ | CASCADED { Name "cascaded" }+ | CATALOG_P { Name "catalog" }+ | CHAIN { Name "chain" }+ | CHARACTERISTICS { Name "characteristics" }+ | CHECKPOINT { Name "checkpoint" }+ | CLASS { Name "class" }+ | CLOSE { Name "close" }+ | CLUSTER { Name "cluster" }+ | COLUMNS { Name "columns" }+ | COMMENT { Name "comment" }+ | COMMENTS { Name "comments" }+ | COMMIT { Name "commit" }+ | COMMITTED { Name "committed" }+ | CONFIGURATION { Name "configuration" }+ | CONFLICT { Name "conflict" }+ | CONNECTION { Name "connection" }+ | CONSTRAINTS { Name "constraints" }+ | CONTENT_P { Name "content" }+ | CONTINUE_P { Name "continue" }+ | CONVERSION_P { Name "conversion" }+ | COPY { Name "copy" }+ | COST { Name "cost" }+ | CSV { Name "csv" }+ | CUBE { Name "cube" }+ | CURRENT_P { Name "current" }+ | CURSOR { Name "cursor" }+ | CYCLE { Name "cycle" }+ | DATA_P { Name "data" }+ | DATABASE { Name "database" }+ | DAY_P { Name "day" }+ | DEALLOCATE { Name "deallocate" }+ | DECLARE { Name "declare" }+ | DEFAULTS { Name "defaults" }+ | DEFERRED { Name "deferred" }+ | DEFINER { Name "definer" }+ | DELETE_P { Name "delete" }+ | DELIMITER { Name "delimiter" }+ | DELIMITERS { Name "delimiters" }+ | DEPENDS { Name "depends" }+ | DETACH { Name "detach" }+ | DICTIONARY { Name "dictionary" }+ | DISABLE_P { Name "disable" }+ | DISCARD { Name "discard" }+ | DOCUMENT_P { Name "document" }+ | DOMAIN_P { Name "domain" }+ | DOUBLE_P { Name "double" }+ | DROP { Name "drop" }+ | EACH { Name "each" }+ | ENABLE_P { Name "enable" }+ | ENCODING { Name "encoding" }+ | ENCRYPTED { Name "encrypted" }+ | ENUM_P { Name "enum" }+ | ESCAPE { Name "escape" }+ | EVENT { Name "event" }+ | EXCLUDE { Name "exclude" }+ | EXCLUDING { Name "excluding" }+ | EXCLUSIVE { Name "exclusive" }+ | EXECUTE { Name "execute" }+ | EXPLAIN { Name "explain" }+ | EXTENSION { Name "extension" }+ | EXTERNAL { Name "external" }+ | FAMILY { Name "family" }+ | FILTER { Name "filter" }+ | FIRST_P { Name "first" }+ | FOLLOWING { Name "following" }+ | FORCE { Name "force" }+ | FORWARD { Name "forward" }+ | FUNCTION { Name "function" }+ | FUNCTIONS { Name "functions" }+ | GENERATED { Name "generated" }+ | GLOBAL { Name "global" }+ | GRANTED { Name "granted" }+ | GROUPS { Name "groups" }+ | HANDLER { Name "handler" }+ | HEADER_P { Name "header" }+ | HOLD { Name "hold" }+ | HOUR_P { Name "hour" }+ | IDENTITY_P { Name "identity" }+ | IF_P { Name "if" }+ | IMMEDIATE { Name "immediate" }+ | IMMUTABLE { Name "immutable" }+ | IMPLICIT_P { Name "implicit" }+ | IMPORT_P { Name "import" }+ | INCLUDE { Name "include" }+ | INCLUDING { Name "including" }+ | INCREMENT { Name "increment" }+ | INDEX { Name "index" }+ | INDEXES { Name "indexes" }+ | INHERIT { Name "inherit" }+ | INHERITS { Name "inherits" }+ | INLINE_P { Name "inline" }+ | INPUT_P { Name "input" }+ | INSENSITIVE { Name "insensitive" }+ | INSERT { Name "insert" }+ | INSTEAD { Name "instead" }+ | INVOKER { Name "invoker" }+ | ISOLATION { Name "isolation" }+ | KEY { Name "key" }+ | LABEL { Name "label" }+ | LANGUAGE { Name "language" }+ | LARGE_P { Name "large" }+ | LAST { Name "last" }+ | LEAKPROOF { Name "leakproof" }+ | LEVEL { Name "level" }+ | LISTEN { Name "listen" }+ | LOAD { Name "load" }+ | LOCAL { Name "local" }+ | LOCATION { Name "location" }+ | LOCK_P { Name "lock" }+ | LOCKED { Name "locked" }+ | LOGGED { Name "logged" }+ | MAPPING { Name "mapping" }+ | MATCH { Name "match" }+ | MATERIALIZED { Name "materialized" }+ | MAXVALUE { Name "maxvalue" }+ | METHOD { Name "method" }+ | MINUTE_P { Name "minute" }+ | MINVALUE { Name "minvalue" }+ | MODE { Name "mode" }+ | MONTH_P { Name "month" }+ | MOVE { Name "move" }+ | NAME_P { Name "name" }+ | NAMES { Name "names" }+ | NEW { Name "new" }+ | NEXT { Name "next" }+ | NO { Name "no" }+ | NOTHING { Name "nothing" }+ | NOTIFY { Name "notify" }+ | NOWAIT { Name "nowait" }+ | NULLS_P { Name "nulls" }+ | OBJECT_P { Name "object" }+ | OF { Name "of" }+ | OFF { Name "off" }+ | OIDS { Name "oids" }+ | OLD { Name "old" }+ | OPERATOR { Name "operator" }+ | OPTION { Name "option" }+ | OPTIONS { Name "options" }+ | ORDINALITY { Name "ordinality" }+ | OTHERS { Name "others" }+ | OVER { Name "over" }+ | OVERRIDING { Name "overriding" }+ | OWNED { Name "owned" }+ | OWNER { Name "owner" }+ | PARALLEL { Name "parallel" }+ | PARSER { Name "parser" }+ | PARTIAL { Name "partial" }+ | PARTITION { Name "partition" }+ | PASSING { Name "passing" }+ | PASSWORD { Name "password" }+ | PLANS { Name "plans" }+ | POLICY { Name "policy" }+ | PRECEDING { Name "preceding" }+ | PREPARE { Name "prepare" }+ | PREPARED { Name "prepared" }+ | PRESERVE { Name "preserve" }+ | PRIOR { Name "prior" }+ | PRIVILEGES { Name "privileges" }+ | PROCEDURAL { Name "procedural" }+ | PROCEDURE { Name "procedure" }+ | PROCEDURES { Name "procedures" }+ | PROGRAM { Name "program" }+ | PUBLICATION { Name "publication" }+ | QUOTE { Name "quote" }+ | RANGE { Name "range" }+ | READ { Name "read" }+ | REASSIGN { Name "reassign" }+ | RECHECK { Name "recheck" }+ | RECURSIVE { Name "recursive" }+ | REF { Name "ref" }+ | REFERENCING { Name "referencing" }+ | REFRESH { Name "refresh" }+ | REINDEX { Name "reindex" }+ | RELATIVE_P { Name "relative" }+ | RELEASE { Name "release" }+ | RENAME { Name "rename" }+ | REPEATABLE { Name "repeatable" }+ | REPLACE { Name "replace" }+ | REPLICA { Name "replica" }+ | RESET { Name "reset" }+ | RESTART { Name "restart" }+ | RESTRICT { Name "restrict" }+ | RETURNS { Name "returns" }+ | REVOKE { Name "revoke" }+ | ROLE { Name "role" }+ | ROLLBACK { Name "rollback" }+ | ROLLUP { Name "rollup" }+ | ROUTINE { Name "routine" }+ | ROUTINES { Name "routines" }+ | ROWS { Name "rows" }+ | RULE { Name "rule" }+ | SAVEPOINT { Name "savepoint" }+ | SCHEMA { Name "schema" }+ | SCHEMAS { Name "schemas" }+ | SCROLL { Name "scroll" }+ | SEARCH { Name "search" }+ | SECOND_P { Name "second" }+ | SECURITY { Name "security" }+ | SEQUENCE { Name "sequence" }+ | SEQUENCES { Name "sequences" }+ | SERIALIZABLE { Name "serializable" }+ | SERVER { Name "server" }+ | SESSION { Name "session" }+ | SET { Name "set" }+ | SETS { Name "sets" }+ | SHARE { Name "share" }+ | SHOW { Name "show" }+ | SIMPLE { Name "simple" }+ | SKIP { Name "skip" }+ | SNAPSHOT { Name "snapshot" }+ | SQL_P { Name "sql" }+ | STABLE { Name "stable" }+ | STANDALONE_P { Name "standalone" }+ | START { Name "start" }+ | STATEMENT { Name "statement" }+ | STATISTICS { Name "statistics" }+ | STDIN { Name "stdin" }+ | STDOUT { Name "stdout" }+ | STORAGE { Name "storage" }+ | STORED { Name "stored" }+ | STRICT_P { Name "strict" }+ | STRIP_P { Name "strip" }+ | SUBSCRIPTION { Name "subscription" }+ | SUPPORT { Name "support" }+ | SYSID { Name "sysid" }+ | SYSTEM_P { Name "system" }+ | TABLES { Name "tables" }+ | TABLESPACE { Name "tablespace" }+ | TEMP { Name "temp" }+ | TEMPLATE { Name "template" }+ | TEMPORARY { Name "temporary" }+ | TEXT_P { Name "text" }+ | TIES { Name "ties" }+ | TRANSACTION { Name "transaction" }+ | TRANSFORM { Name "transform" }+ | TRIGGER { Name "trigger" }+ | TRUNCATE { Name "truncate" }+ | TRUSTED { Name "trusted" }+ | TYPE_P { Name "type" }+ | TYPES_P { Name "types" }+ | UNBOUNDED { Name "unbounded" }+ | UNCOMMITTED { Name "uncommitted" }+ | UNENCRYPTED { Name "unencrypted" }+ | UNKNOWN { Name "unknown" }+ | UNLISTEN { Name "unlisten" }+ | UNLOGGED { Name "unlogged" }+ | UNTIL { Name "until" }+ | UPDATE { Name "update" }+ | VACUUM { Name "vacuum" }+ | VALID { Name "valid" }+ | VALIDATE { Name "validate" }+ | VALIDATOR { Name "validator" }+ | VALUE_P { Name "value" }+ | VARYING { Name "varying" }+ | VERSION_P { Name "version" }+ | VIEW { Name "view" }+ | VIEWS { Name "views" }+ | VOLATILE { Name "volatile" }+ | WHITESPACE_P { Name "whitespace" }+ | WITHIN { Name "within" }+ | WITHOUT { Name "without" }+ | WORK { Name "work" }+ | WRAPPER { Name "wrapper" }+ | WRITE { Name "write" }+ | XML_P { Name "xml" }+ | YEAR_P { Name "year" }+ | YES_P { Name "yes" }+ | ZONE { Name "zone" }++-- * Column identifier -- *- keywords that can be column, table, etc names.+-- *+-- * Many of these keywords will in fact be recognized as type or function+-- * names too; but they have special productions for the purpose, and so+-- * can't be treated as "generic" type or function names.+-- *+-- * The type names appearing here are not usable as function names+-- * because they can be followed by '(' in typename productions, which+-- * looks too much like a function call for an LR(1) parser.+col_name_keyword :: { Name }+ : BETWEEN { Name "between" }+ | BIGINT { Name "bigint" }+ | BIT { Name "bit" }+ | BOOLEAN_P { Name "boolean" }+ | CHAR_P { Name "char" }+ | CHARACTER { Name "character" }+ | COALESCE { Name "coalesce" }+ | DEC { Name "dec" }+ | DECIMAL_P { Name "decimal" }+ | EXISTS { Name "exists" }+ | EXTRACT { Name "extract" }+ | FLOAT_P { Name "float" }+ | GREATEST { Name "greatest" }+ | GROUPING { Name "grouping" }+ | INOUT { Name "inout" }+ | INT_P { Name "int" }+ | INTEGER { Name "integer" }+ | INTERVAL { Name "interval" }+ | LEAST { Name "least" }+ | NATIONAL { Name "national" }+ | NCHAR { Name "nchar" }+ | NONE { Name "none" }+ | NULLIF { Name "nullif" }+ | NUMERIC { Name "numeric" }+ | OUT_P { Name "out" }+ | OVERLAY { Name "overlay" }+ | POSITION { Name "position" }+ | PRECISION { Name "precision" }+ | REAL { Name "real" }+ | ROW { Name "row" }+ | SETOF { Name "setof" }+ | SMALLINT { Name "smallint" }+ | SUBSTRING { Name "substring" }+ | TIME { Name "time" }+ | TIMESTAMP { Name "timestamp" }+ | TREAT { Name "treat" }+ | TRIM { Name "trim" }+ | VALUES { Name "values" }+ | VARCHAR { Name "varchar" }+ | XMLATTRIBUTES { Name "xmlattributes" }+ | XMLCONCAT { Name "xmlconcat" }+ | XMLELEMENT { Name "xmlelement" }+ | XMLEXISTS { Name "xmlexists" }+ | XMLFOREST { Name "xmlforest" }+ | XMLNAMESPACES { Name "xmlnamespaces" }+ | XMLPARSE { Name "xmlparse" }+ | XMLPI { Name "xmlpi" }+ | XMLROOT { Name "xmlroot" }+ | XMLSERIALIZE { Name "xmlserialize" }+ | XMLTABLE { Name "xmltable" }++-- * Type/function identifier -- *- keywords that can be type or function names.+-- *+-- * Most of these are keywords that are used as operators in expressions;+-- * in general such keywords can't be column names because they would be+-- * ambiguous with variables, but they are unambiguous as function identifiers.+-- *+-- * Do not include POSITION, SUBSTRING, etc here since they have explicit+-- * productions in a_expr to support the goofy SQL9x argument syntax.+-- * - thomas 2000-11-28+type_func_name_keyword :: { Name }+ : AUTHORIZATION { Name "authorization" }+ | BINARY { Name "binary" }+ | COLLATION { Name "collation" }+ | CONCURRENTLY { Name "concurrently" }+ | CROSS { Name "cross" }+ | CURRENT_SCHEMA { Name "current_schema" }+ | FREEZE { Name "freeze" }+ | FULL { Name "full" }+ | ILIKE { Name "ilike" }+ | INNER_P { Name "inner" }+ | IS { Name "is" }+ | ISNULL { Name "isnull" }+ | JOIN { Name "join" }+ | LEFT { Name "left" }+ | LIKE { Name "like" }+ | NATURAL { Name "natural" }+ | NOTNULL { Name "notnull" }+ | OUTER_P { Name "outer" }+ | OVERLAPS { Name "overlaps" }+ | RIGHT { Name "right" }+ | SIMILAR { Name "similar" }+ | TABLESAMPLE { Name "tablesample" }+ | VERBOSE { Name "verbose" }++-- * Reserved keyword -- *- these keywords are usable only as a ColLabel.+-- *+-- * Keywords appear here if they could not be distinguished from variable,+-- * type, or function names in some contexts. Don't put things here unless+-- * forced to.+reserved_keyword :: { Name }+ : ALL { Name "all" }+ | ANALYSE { Name "analyse" }+ | ANALYZE { Name "analyze" }+ | AND { Name "and" }+ | ANY { Name "any" }+ | ARRAY { Name "array" }+ | AS { Name "as" }+ | ASC { Name "asc" }+ | ASYMMETRIC { Name "asymmetric" }+ | BOTH { Name "both" }+ | CASE { Name "case" }+ | CAST { Name "cast" }+ | CHECK { Name "check" }+ | COLLATE { Name "collate" }+ | COLUMN { Name "column" }+ | CONSTRAINT { Name "constraint" }+ | CREATE { Name "create" }+ | CURRENT_CATALOG { Name "current_catalog" }+ | CURRENT_DATE { Name "current_date" }+ | CURRENT_ROLE { Name "current_role" }+ | CURRENT_TIME { Name "current_time" }+ | CURRENT_TIMESTAMP { Name "current_timestamp" }+ | CURRENT_USER { Name "current_user" }+ | DEFAULT { Name "default" }+ | DEFERRABLE { Name "deferrable" }+ | DESC { Name "desc" }+ | DISTINCT { Name "distinct" }+ | DO { Name "do" }+ | ELSE { Name "else" }+ | END_P { Name "end" }+ | EXCEPT { Name "except" }+ | FALSE_P { Name "false" }+ | FETCH { Name "fetch" }+ | FOR { Name "for" }+ | FOREIGN { Name "foreign" }+ | FROM { Name "from" }+ | GRANT { Name "grant" }+ | GROUP_P { Name "group" }+ | HAVING { Name "having" }+ | IN_P { Name "in" }+ | INITIALLY { Name "initially" }+ | INTERSECT { Name "intersect" }+ | INTO { Name "into" }+ | LATERAL_P { Name "lateral" }+ | LEADING { Name "leading" }+ | LIMIT { Name "limit" }+ | LOCALTIME { Name "localtime" }+ | LOCALTIMESTAMP { Name "localtimestamp" }+ | NOT { Name "not" }+ | NULL_P { Name "null" }+ | OFFSET { Name "offset" }+ | ON { Name "on" }+ | ONLY { Name "only" }+ | OR { Name "or" }+ | ORDER { Name "order" }+ | PLACING { Name "placing" }+ | PRIMARY { Name "primary" }+ | REFERENCES { Name "references" }+ | RETURNING { Name "returning" }+ | SELECT { Name "select" }+ | SESSION_USER { Name "current_user" }+ | SOME { Name "some" }+ | SYMMETRIC { Name "symmetric" }+ | TABLE { Name "table" }+ | THEN { Name "then" }+ | TO { Name "to" }+ | TRAILING { Name "trailing" }+ | TRUE_P { Name "true" }+ | UNION { Name "union" }+ | UNIQUE { Name "unique" }+ | USER { Name "user" }+ | USING { Name "using" }+ | VARIADIC { Name "variadic" }+ | WHEN { Name "when" }+ | WHERE { Name "where" }+ | WINDOW { Name "window" }+ | WITH { Name "with" }++{++-- from https://github.com/dagit/happy-plus-alex/blob/master/src/Parser.y++happyError :: L.LocToken -> Alex a+happyError (L.LocToken p t) =+ L.alexErrorPosn p ("parse error at token '" ++ L.unLex t ++ "'")++parseStatement :: FilePath -> String -> Either String Statement+parseStatement = L.runAlexWithFilepath parseStatement_++parseSelect :: FilePath -> String -> Either String SelectStmt+parseSelect = L.runAlexWithFilepath parseSelect_++parseExpr :: FilePath -> String -> Either String Expr+parseExpr = L.runAlexWithFilepath parseExpr_++lexwrap :: (L.LocToken -> Alex a) -> Alex a+lexwrap = (L.alexMonadScan' >>=)++}
+ src/Preql/QuasiQuoter/Syntax/Printer.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Print the types in Syntax as valid SQL. The emphasis is on+-- queries to send to the database, not on legibilty; no extra whitespace is introduced.++module Preql.QuasiQuoter.Syntax.Printer where++import Preql.Imports+import Preql.QuasiQuoter.Syntax.Name+import Preql.QuasiQuoter.Syntax.Syntax as Syn hiding (select)++import Data.Data+import Data.List (intersperse)+import GHC.Generics+import Language.Haskell.TH.Syntax (Lift(..))+import Prelude hiding (GT, LT, lex)++import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as B+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Builder.Int as B+import qualified Data.Text.Lazy.Builder.RealFloat as B++quote :: B.Builder -> B.Builder+quote s = "'" <> s <> "'"++doubleQuote :: B.Builder -> B.Builder+doubleQuote s = "\"" <> s <> "\""++parens :: B.Builder -> B.Builder+parens s = "(" <> s <> ")"++parensIf :: Bool -> B.Builder -> B.Builder+parensIf cond inner = if cond then parens inner else inner++spaceAfter :: B.Builder -> B.Builder+spaceAfter = (<> " ")++class FormatSql a where+ fmt :: a -> B.Builder+ fmt = fmtPrec 0++ fmtPrec :: Int -> a -> B.Builder+ fmtPrec _ = fmt++formatAsString :: FormatSql a => a -> String+formatAsString = TL.unpack . TLB.toLazyText . fmt++formatAsByteString :: FormatSql a => a -> ByteString+formatAsByteString = T.encodeUtf8 . formatAsText++formatAsText :: FormatSql a => a -> T.Text+formatAsText = TL.toStrict . TLB.toLazyText . fmt++instance FormatSql Name where+ -- TODO enclose keywoards &c in double quotes+ fmt = B.fromText . getName++instance FormatSql Literal where+ fmt (I i) = B.decimal i+ fmt (F x) = B.realFloat x+ fmt (T t) = quote (B.fromText t)+ fmt (B True) = "true"+ fmt (B False) = "false"+ fmt Null = "null"++instance FormatSql Statement where+ fmt (QI insert) = fmt insert+ fmt (QD delete) = fmt delete+ fmt (QU update) = fmt update+ fmt (QS select) = fmt select++commas :: (FormatSql a, Foldable f) => f a -> B.Builder+commas = fmtList ", "++spaces :: (FormatSql a, Foldable f) => f a -> B.Builder+spaces = fmtList " "++fmtList :: (FormatSql a, Foldable f) => B.Builder -> f a -> B.Builder+fmtList sep as = mconcat (intersperse sep (map fmt (toList as)))++unlessEmpty :: (B.Builder -> B.Builder) -> B.Builder -> B.Builder+unlessEmpty _ "" = ""+unlessEmpty f x = f x++optList :: FormatSql a => B.Builder -> [a] -> B.Builder+optList _ [] = ""+optList prepend as = prepend <> commas as++-- TODO replace all calls to @opt@ with @opt'@, rename+opt :: FormatSql a => B.Builder -> Maybe a -> B.Builder+opt _ Nothing = ""+opt prepend (Just a) = prepend <> fmt a++opt' :: FormatSql a => B.Builder -> Int -> Maybe a -> B.Builder+opt' _ _ Nothing = ""+opt' prepend p (Just a) = prepend <> fmtPrec p a++instance FormatSql B.Builder where+ fmt = id++instance FormatSql Insert where+ fmt Insert{table, columns, values} =+ "INSERT INTO " <> fmt table <> " (" <> commas columns <>+ ") VALUES (" <> commas values <> ")"++instance FormatSql Delete where+ fmt Delete{table, conditions} = "DELETE FROM " <> fmt table <> wh where+ wh = case conditions of+ Nothing -> ""+ Just conditions' -> " WHERE " <> fmt conditions'++instance FormatSql Setting where+ fmt (Setting column rhs) = fmt column <> "=" <> fmt rhs++instance FormatSql Update where+ fmt Update{table, settings, conditions} =+ "UPDATE " <> fmt table <> " SET " <> commas settings <> wh+ where wh = case conditions of+ Nothing -> ""+ Just conditions' -> " WHERE " <> fmt conditions'++instance FormatSql Expr where+ fmtPrec _ (Lit lit) = fmt lit+ fmtPrec _ (CRef name) = fmt name+ fmtPrec _ (NumberedParam i) = B.fromString ('$' : show i)+ fmtPrec _ (HaskellParam txt) = "${" <> B.fromText txt <> "}"+ fmtPrec p (BinOp op l r) = let (assoc, p1) = binOpPrec op+ in parensIf (p > p1) $ case assoc of+ LeftAssoc -> fmtPrec p1 l <> " " <> fmt op <> " " <> fmtPrec (p1 + 1) r+ RightAssoc -> fmtPrec (p1 + 1) l <> " " <> fmt op <> " " <> fmtPrec p1 r+ NonAssoc -> fmtPrec (p1 + 1) l <> " " <> fmt op <> " " <> fmtPrec (p1 + 1) r+ fmtPrec p (Unary op expr) = case op of+ Negate -> parensIf (p > 15) ("-" <> fmtPrec 15 expr)+ Not -> parensIf (p > 5) ("NOT " <> fmtPrec 5 expr)+ IsNull -> parensIf (p > 7) (fmtPrec 8 expr <> " IS NULL")+ NotNull -> parensIf (p > 7) (fmtPrec 8 expr <> " IS NOT NULL")+ -- This looks funky, but seems to match the parser+ fmtPrec _ (Indirection e indirects) =+ let m_parens = case e of+ NumberedParam _ -> id+ CRef _ -> id+ _ -> parens+ in m_parens (fmt e) <> fmtIndirections indirects+ fmtPrec _ (SelectExpr stmt) = parens (fmt stmt)+ fmtPrec p (L likeE) = fmtPrec p likeE+ fmtPrec _ (Fun f) = fmt f+ fmtPrec _ (Cas c) = fmt c++fmtIndirections :: Foldable f => f Indirection -> TLB.Builder+fmtIndirections = foldMap (("." <>) . fmt)++instance FormatSql BinOp where+ fmt op = case op of+ Mul -> "*"+ Div -> "/"+ Add -> "+"+ Sub -> "-"+ Exponent -> "^"+ Mod -> "%"+ Eq -> "="+ LT -> "<"+ LTE -> "<="+ GT -> ">"+ GTE -> ">="+ NEq -> "!="+ IsDistinctFrom -> "IS DISTINCT FROM"+ IsNotDistinctFrom -> "IS NOT DISTINCT FROM"+ And -> "AND"+ Or -> "OR"++data Assoc = LeftAssoc | RightAssoc | NonAssoc+ deriving (Show, Eq, Enum, Bounded, Data, Lift, Generic)++binOpPrec :: BinOp -> (Assoc, Int)+binOpPrec op = case op of+ Or -> (LeftAssoc, 3)+ And -> (LeftAssoc, 4)+ IsDistinctFrom -> (NonAssoc, 7)+ IsNotDistinctFrom -> (NonAssoc, 7)+ Eq -> (NonAssoc, 8)+ LT -> (NonAssoc, 8)+ LTE -> (NonAssoc, 8)+ GT -> (NonAssoc, 8)+ GTE -> (NonAssoc, 8)+ NEq -> (NonAssoc, 8)+ Add -> (LeftAssoc, 12)+ Sub -> (LeftAssoc, 12)+ Mul -> (LeftAssoc, 13)+ Div -> (LeftAssoc, 13)+ Mod -> (LeftAssoc, 13)+ Exponent -> (LeftAssoc, 14)++setOpPrec :: SetOp -> Int+setOpPrec op = case op of+ Union -> 1+ Except -> 1+ Intersect -> 2++instance FormatSql LikeE where+ -- Expr L puts parens around if needed+ fmtPrec p LikeE{op, string, likePattern, escape, invert} = parensIf (p > likePrec) $+ fmtPrec 10 string <> (if invert then " NOT" else "")+ <> op' <> fmtPrec 10 likePattern <> opt' " ESCAPE " 10 escape+ where+ likePrec = if invert then 5 else 9+ op' = case op of+ Like -> " LIKE "+ ILike -> " ILIKE "+ Similar -> " SIMILAR TO "++instance FormatSql SelectStmt where+ fmtPrec _ (SelectValues values) = "VALUES " <> commas (fmap (parens . commas) values)+ fmtPrec _ (Simple un) = fmt un+ fmtPrec p (S ss so) = let topLevel = parensIf (p > 0) (fmtPrec 1 ss <> fmt so) in+ case withClause so of+ Nothing -> topLevel+ Just ctes -> fmt ctes <> " " <> topLevel+ fmtPrec p (Set op distinct l r) = parensIf (p > q) $+ fmtPrec q l <> " " <> fmt op <> d <> fmtPrec (q + 1) r+ where+ q = setOpPrec op+ d = case distinct of+ All -> " ALL "+ Distinct -> " "++instance FormatSql Select where+ fmt Select{targetList, from, distinct, whereClause, groupBy, having, window}+ = "SELECT " <> m_distinct <> commas (fmt <$> targetList) <> " FROM " <> commas from+ <> opt " WHERE " whereClause+ <> optList " GROUP BY " groupBy+ <> opt " HAVING " having+ <> optList " WINDOW " window+ where+ m_distinct = maybe "" (spaceAfter . fmt) distinct++instance FormatSql SelectOptions where+ -- ignore WithClause here; handle it in SelectStmt so we can put it before the top query+ fmt SelectOptions{sortBy, offset, limit, locking} =+ optList " ORDER BY " sortBy+ <> unlessEmpty (" " <>) (spaces locking) -- no commas+ <> opt " LIMIT " limit+ <> opt " OFFSET " offset++instance FormatSql WithClause where+ fmt With {commonTables, recursive} =+ "WITH" <> recursive' <> commas commonTables+ where recursive' = case recursive of+ Recursive -> " RECURSIVE "+ NotRecursive -> " "++instance FormatSql Materialized where+ fmt Materialized = "MATERIALIZED"+ fmt NotMaterialized = "NOT MATERIALIZED"+ fmt MaterializeDefault = ""++instance FormatSql CTE where+ fmt CommonTableExpr {name, aliases, materialized, query} =+ fmt name <> unlessEmpty parens (commas aliases)+ <> unlessEmpty spacesAround (fmt materialized) <> parens (fmt query)+ where+ spacesAround s = " " <> s <> " "++instance FormatSql TableRef where+ fmtPrec p (J jt) = fmtPrec p jt+ fmtPrec p (As jt alias) = parensIf (p > 1) $ fmtPrec 1 jt <> " AS " <> fmt alias+ fmtPrec _ (SubSelect stmt alias) = parens (fmt stmt) <> " AS " <> fmt alias++instance FormatSql Alias where+ fmt (Alias name []) = fmt name+ fmt (Alias name columns) = fmt name <> parens (commas columns)++instance FormatSql JoinedTable where+ fmtPrec _ (Table name) = fmt name+ fmtPrec p (CrossJoin l r) = parensIf (p > 0) $ fmtPrec 0 l <> " CROSS JOIN " <> fmtPrec 1 r+ fmtPrec p (Join Inner Natural l r) = parensIf (p > 0) $ fmtPrec 0 l <> " NATURAL JOIN " <> fmtPrec 1 r+ fmtPrec p (Join ty Natural l r) = parensIf (p > 0) $ fmtPrec 0 l <> " NATURAL" <> fmt ty <> "JOIN " <> fmtPrec 1 r+ fmtPrec p (Join ty (Using cols) l r) = parensIf (p > 0) $ fmtPrec 0 l <> fmt ty <> " JOIN " <> fmtPrec 1 r <> " USING " <> parens (commas cols)+ fmtPrec p (Join ty (On expr) l r) = parensIf (p > 0) $ fmtPrec 0 l <> fmt ty <> " JOIN " <> fmtPrec 0 r <> " ON " <> fmtPrec 0 expr++instance FormatSql JoinType where+ fmt Inner = " INNER "+ fmt LeftJoin = " LEFT "+ fmt RightJoin = " RIGHT "+ fmt Full = " FULL "++instance FormatSql DistinctClause where+ fmt DistinctAll = "DISTINCT"+ fmt (DistinctOn expr) = "DISTINCT ON " <> parens (commas expr)++instance FormatSql SortBy where+ fmt (SortBy expr order nulls) = fmt expr <> " " <> fmt order <> fmt nulls++instance FormatSql SortOrderOrUsing where+ fmt (SortOrder order) = fmt order+ fmt (SortUsing op) = "USING " <> fmt op++instance FormatSql SortOrder where+ -- leading space+ fmt Ascending = " ASC"+ fmt Descending = " DESC"+ fmt DefaultSortOrder = ""++instance FormatSql NullsOrder where+ -- leading space+ fmt NullsFirst = " NULLS FIRST"+ fmt NullsLast = " NULLS LAST"+ fmt NullsOrderDefault = ""++instance FormatSql Locking where+ fmt Locking{strength, tables, wait} =+ " " <> fmt strength <> optList " OF " tables <> " " <> fmt wait++instance FormatSql LockingStrength where+ fmt ForUpdate = "FOR UPDATE"+ fmt ForNoKeyUpdate = "FOR NO KEY UPDATE"+ fmt ForShare = "FOR SHARE"+ fmt ForKeyShare = "FOR KEY SHARE"++instance FormatSql LockWait where+ fmt LockWaitError = "NOWAIT"+ fmt LockWaitSkip = "SKIP LOCKED"+ fmt LockWaitBlock = ""++instance FormatSql SetOp where+ fmt Union = "UNION"+ fmt Intersect = "INTERSECT"+ fmt Except = "EXCEPT"++instance FormatSql ResTarget where+ fmt Star = "*"+ fmt (Column expr Nothing) = fmt expr+ fmt (Column expr (Just name)) = fmt expr <> " AS " <> fmt name++-- instance FormatSql ColumnRef where+-- fmt ColumnRef {value, name} = fmt value <> case name of+-- Nothing -> ""+-- Just n -> "." <> fmt n++instance FormatSql WindowDef where+ fmt (WindowDef name spec) = fmt name <> " AS " <> fmt spec++instance FormatSql WindowSpec where+ fmt WindowSpec { refName, partitionClause, orderClause }+ = "(" <> mconcat [m_refName, m_partition, m_order ] <> ")" where+ m_refName = maybe "" fmt refName+ m_partition = case partitionClause of+ [] -> ""+ _ -> " PARTITION BY " <> commas (fmt <$> partitionClause)+ m_order = case orderClause of+ [] -> ""+ _ -> " ORDER BY " <> commas (fmt <$> orderClause)++instance FormatSql FunctionApplication where+ fmt FApp {..} = fmt name <> fmtIndirections indirection+ <> fmt arguments <> withinGroup'+ <> maybe "" (\fc -> " FILTER " <> parens ("WHERE " <> fmt fc)) filterClause+ <> over'+ where+ withinGroup' = case withinGroup of+ [] -> ""+ _ -> "WITHIN GROUP " <> parens ("ORDER BY " <> commas withinGroup)+ over' = case over of+ (Window (WindowSpec Nothing [] [])) -> ""+ (WindowName alias) -> "OVER " <> fmt alias+ Window WindowSpec {refName, partitionClause, orderClause} ->+ "OVER " <> parens+ (opt "" refName+ <> optList " PARTITION BY " partitionClause+ <> optList " ORDER BY " orderClause)++instance FormatSql FunctionArguments where+ fmt StarArg = "(*)"+ fmt NoArgs = "()"+ fmt (Args ArgsList{..}) = parens (distinct' <> commas arguments <> sortBy') where+ distinct' = if distinct then "DISTINCT " else ""+ sortBy' = optList " ORDER BY " sortBy++instance FormatSql Argument where+ fmt (E e) = fmt e+ fmt (Named name e) = fmt name <> " => " <> fmt e++instance FormatSql Case where+ fmt Case { whenClause, implicitArg, elseClause } =+ "CASE" <> opt " " implicitArg <> whenClauses' <> opt " ELSE " elseClause <> " END"+ where whenClauses' = spaces [ " WHEN " <> fmt condition <> " THEN " <> fmt result+ | (condition, result) <- whenClause ]
+ src/Preql/QuasiQuoter/Syntax/Syntax.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DuplicateRecordFields #-}++-- | Description: Syntax tree for SQL++module Preql.QuasiQuoter.Syntax.Syntax where++import Preql.QuasiQuoter.Syntax.Name++import Data.Data+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Data.String (IsString(..))+import Data.Text (Text)+import Data.Word (Word)+import GHC.Generics+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax (Lift(..))+import qualified Data.Text as T++-- FIXME rename to Constant?+data Literal = I !Word | F !Double | T !Text | B !Bool | Null+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Statement = QI !Insert | QD !Delete | QU !Update | QS !SelectStmt+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++-- | Queries of the form @INSERT INTO table (columns) VALUES (values);@+-- Limitations:+-- * single row+-- * no @ON CONFLICT@+data Insert = Insert+ { table :: !Name+ , columns :: NonEmpty Name+ , values :: NonEmpty Expr -- TODO enforce matched lengths?+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++-- | Queries of the form @DELETE FROM table WHERE conditions@.+data Delete = Delete+ { table :: !Name+ , conditions :: Maybe Expr+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Setting = Setting !Name !Expr+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++-- | Queries of the form @UPDATE table SET settings WHERE conditions@. Where each+-- @Setting name literal@ is like SQL @name = literal@.+data Update = Update+ { table :: !Name+ , settings :: NonEmpty Setting+ , conditions :: Maybe Expr+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++-- TODO prevent multiple SelectOptions on the same query+-- If each constructor takes SelectOptions, we can ditch S and the empty SelectOptions becomes valid+data SelectStmt+ = SelectValues (NonEmpty (NonEmpty Expr))+ | Simple Select+ | S SelectStmt SelectOptions+ | Set SetOp AllOrDistinct SelectStmt SelectStmt+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Select = Select+ { distinct :: Maybe DistinctClause+ , targetList :: [ResTarget]+ , from :: [TableRef]+ , whereClause :: Maybe Expr+ , groupBy :: [Expr] -- TODO more accurate type than Expr?+ , having :: Maybe Expr+ , window :: [WindowDef]+ -- TODO remaining fields+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++data SelectOptions = SelectOptions+ { sortBy :: [SortBy]+ , offset :: Maybe Expr+ , limit :: Maybe Expr+ , locking :: [Locking]+ , withClause :: Maybe WithClause+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++-- This is really for writing tests, but put it here for faster type check errors+select :: Select+select = Select+ { distinct = Nothing+ , targetList = []+ , from = []+ , whereClause = Nothing+ , groupBy = []+ , having = Nothing+ , window = []+ }++selectOptions :: SelectOptions+selectOptions = SelectOptions+ { sortBy = []+ , offset = Nothing+ , limit = Nothing+ , locking = []+ , withClause = Nothing+ }++data TableRef+ = J JoinedTable+ | As JoinedTable Alias+ | SubSelect SelectStmt Alias+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data JoinedTable+ = Table Name+ | Join JoinType JoinQual TableRef TableRef+ | CrossJoin TableRef TableRef+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Alias = Alias+ { aliasName :: Name+ , columnNames :: [ Name ]+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++data JoinType = Inner | LeftJoin | RightJoin | Full+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Enum, Bounded)++data JoinQual = Using [Name] | On Expr | Natural+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data DistinctClause = DistinctAll | DistinctOn (NonEmpty Expr)+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data SetOp = Union | Intersect | Except+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Enum, Bounded)++data AllOrDistinct = All | Distinct+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Enum, Bounded)++data ResTarget = Star | Column Expr (Maybe Name)+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data WindowDef = WindowDef Name WindowSpec+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Over = WindowName Name | Window WindowSpec+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data WindowSpec = WindowSpec+ { refName :: Maybe Name+ , partitionClause :: [Expr]+ , orderClause :: [SortBy ]+ -- , frameOptions :: _ -- FIXME implement+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++noWindow :: Over+noWindow = Window (WindowSpec Nothing [] [])++data SortBy = SortBy+ { column :: Expr+ , direction :: SortOrderOrUsing+ , nulls :: NullsOrder+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++data SortOrderOrUsing = SortOrder SortOrder | SortUsing BinOp+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data SortOrder = Ascending | Descending | DefaultSortOrder+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Enum, Bounded)++data NullsOrder = NullsFirst | NullsLast | NullsOrderDefault+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Enum, Bounded)++data Locking = Locking+ { strength :: LockingStrength+ , tables :: [Name]+ , wait :: LockWait+ } deriving (Show, Eq, Generic, Data, Lift)++data LockingStrength+ = ForUpdate | ForNoKeyUpdate | ForShare | ForKeyShare+ deriving (Show, Eq, Enum, Bounded, Data, Lift, Generic)++data LockWait = LockWaitError | LockWaitSkip | LockWaitBlock+ deriving (Show, Eq, Enum, Bounded, Data, Lift, Generic)++data WithClause = With+ { commonTables :: [ CTE ]+ , recursive :: Recursive+ }+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Recursive = Recursive | NotRecursive+ deriving (Show, Eq, Enum, Bounded, Data, Lift, Generic)++data Materialized = Materialized | NotMaterialized | MaterializeDefault+ deriving (Show, Eq, Enum, Bounded, Data, Lift, Generic)++data CTE = CommonTableExpr+ { name :: Name+ , aliases :: [Name]+ , materialized :: Materialized+ , query :: Statement+ }+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Expr = Lit !Literal | CRef Name+ | NumberedParam !Word+ | HaskellParam !Text+ | BinOp !BinOp !Expr !Expr+ | Unary !UnaryOp !Expr+ | Indirection Expr (NonEmpty Indirection)+ | SelectExpr SelectStmt+ | L LikeE+ | Fun FunctionApplication+ | Cas Case+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++type Indirection = Name -- FIXME++data BinOp = Mul | Div | Add | Sub | Exponent | Mod+ | Eq | LT | LTE | GT | GTE | NEq+ | IsDistinctFrom | IsNotDistinctFrom+ | And | Or+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Bounded, Enum)++data UnaryOp = Negate | Not | IsNull | NotNull+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Bounded, Enum)++data LikeOp = Like | ILike | Similar -- TODO add ~ !~ ~* !~*+ deriving (Show, Eq, Generic, Typeable, Data, Lift, Bounded, Enum)++data LikeE = LikeE+ { op :: LikeOp+ , string :: Expr+ , likePattern :: Expr+ , escape :: Maybe Expr+ , invert :: Bool+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++like :: LikeOp -> Expr -> Expr -> LikeE+like op string likePattern =+ LikeE { op, string, likePattern, escape = Nothing, invert = False }++data FunctionApplication = FApp+ { name :: Name+ , indirection :: [Indirection]+ , arguments :: FunctionArguments+ , withinGroup :: [SortBy] -- not allowed if sortBy in arguments isn't empty+ , filterClause :: Maybe Expr+ , over :: Over+ } deriving (Show, Eq, Generic, Typeable, Data, Lift)++fapp :: (Name, [Indirection]) -> FunctionArguments -> FunctionApplication+fapp (name, indirection) args = FApp+ { name, indirection+ , arguments = args+ , withinGroup = []+ , filterClause = Nothing+ , over = noWindow+ }++fapp1 :: Name -> [Expr] -> FunctionApplication+fapp1 fName args = fapp (fName, []) args' where+ args' = case nonEmpty args of+ Nothing -> NoArgs+ Just ne -> Args (ArgsList (fmap E ne) [] False)++setSortBy :: FunctionApplication -> [SortBy] -> FunctionApplication+setSortBy f@FApp{ arguments } sorts = case arguments of+ Args args -> f { arguments = Args args { sortBy = sorts } }+ _ -> f++data FunctionArguments = StarArg | NoArgs | Args ArgsList+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data ArgsList = ArgsList+ { arguments :: NonEmpty Argument+ , sortBy :: [SortBy]+ , distinct :: Bool+ }+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++argsList :: NonEmpty Argument -> ArgsList+argsList args = ArgsList args [] False++data Argument = E Expr | Named Name Expr+ deriving (Show, Eq, Generic, Typeable, Data, Lift)++data Case = Case+ { whenClause :: [(Expr, Expr)] -- (condition, then)+ , implicitArg :: Maybe Expr+ , elseClause :: Maybe Expr+ } deriving (Show, Eq, Generic, Data, Lift)
+ src/Preql/QuasiQuoter/Syntax/TH.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}+module Preql.QuasiQuoter.Syntax.TH where++import Preql.Imports+import Preql.QuasiQuoter.Common+import Preql.QuasiQuoter.Syntax.Params+import Preql.QuasiQuoter.Syntax.Parser (parseStatement, parseSelect)+import Preql.QuasiQuoter.Syntax.Printer (formatAsByteString)+import Preql.QuasiQuoter.Syntax.Syntax as Syntax hiding (select)+import Preql.Wire.Internal as Wire (Query(..))++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import qualified Data.Text as T++tupleType :: [Name] -> Type+tupleType [v] = VarT v+tupleType names = foldl (\expr v -> AppT expr (VarT v)) (TupleT n) names+ where n = length names++-- | Synthesize a Query tagged with the number of returned columns.+makeArityQuery :: Statement -> Q Exp+makeArityQuery parsed = do+ let+ width = case countColumnsReturned parsed of+ Just n -> pure (LitT (NumTyLit (fromIntegral n)))+ Nothing -> VarT <$> newName "r" -- SELECT *+ formatted = formatAsByteString parsed+ [e| Wire.Query formatted :: Wire.Query $(width) |]++-- | This quasiquoter will accept most syntactically valid SELECT+-- queries. Language features not yet implemented include type casts,+-- lateral joins, EXTRACT, INTO, string & XML operators, and+-- user-defined operators. For now, please fall back to+-- 'Preql.QuasiQuoter.Raw.TH.sql' for these less-frequently used SQL+-- features, or file a bug report if a commonly used feature is not+-- parsed correctly.+--+-- @select@ accepts antiquotes with the same syntax as 'sql'.+select :: QuasiQuoter+select = expressionOnly "select" (aritySql parseSelect QS)++-- | This quasiquoter will accept all queries accepted by 'select',+-- and limited INSERT, UPDATE, and DELETE queries. For details of+-- what can be parsed, consult Parser.y+validSql :: QuasiQuoter+validSql = expressionOnly "validSql" (aritySql parseStatement id)++aritySql :: (String -> String -> Either String a) -> (a -> Statement) -> String -> Q Exp+aritySql parse mkStatement raw = do+ loc <- location+ let e_ast = mkStatement <$> parse (show loc) raw+ case e_ast of+ Right parsed -> do+ let+ positionalCount = maxParam parsed+ (rewritten, aqs) = numberAntiquotes positionalCount parsed+ antiNames = map (mkName . T.unpack) (haskellExpressions aqs)+ typedQuery <- makeArityQuery rewritten+ case positionalCount of+ 0 -> -- only antiquotes (or no params)+ return $ tupleE [typedQuery, tupleOrSingle antiNames]+ 1 -> do -- one positional param, doesn't take a tuple+ patternName <- newName "c"+ return $ LamE [VarP patternName]+ (tupleE [typedQuery, tupleOrSingle (patternName : antiNames)])+ _ -> do -- at least two positional parameters+ patternNames <- cNames 'q' (fromIntegral positionalCount)+ return $ LamE+ [TupP (map VarP patternNames)]+ (tupleE [typedQuery, tupleOrSingle (patternNames ++ antiNames)])+ Left err -> error err++countColumnsReturned :: Statement -> Maybe Int+countColumnsReturned (QS selectQ) = go selectQ where+ go s = case s of+ SelectValues rows -> Just (foldl' max 0 (fmap length rows))+ Simple Select {targetList} -> if Star `elem` targetList+ then Nothing+ else Just (length targetList)+ S ss _ -> go ss+ Set _ _ a b -> case (go a, go b) of+ (Just m, Just n) | m == n -> Just n+ _ -> Nothing+countColumnsReturned _ = Just 0+-- TODO INSERT ... RETURNING &c
src/Preql/Wire.hs view
@@ -1,19 +1,22 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | This module re-exports definitions from Wire.* that are expected to be useful+-- | Description: Encode & Decode Postgres wire format+--+-- This module re-exports definitions from Wire.* that are expected to be useful module Preql.Wire ( -- * Decoding rows- FromSql, FromSqlField+ FromSql(..), FromSqlField -- * Encoding parameters- , ToSql, ToSqlField+ , ToSql(..), ToSqlField -- * Errors , QueryError(..), FieldError(..), UnlocatedFieldError(..), TypeMismatch(..) , module X) where -import Preql.Wire.FromSql as X+import Preql.Wire.Decode as X import Preql.Wire.Errors as X import Preql.Wire.Internal as X (Query, RowDecoder) import Preql.Wire.ToSql as X import Preql.Wire.Types as X import Preql.Wire.Query as X (IsolationLevel(..))+import Preql.FromSql.Class as X
+ src/Preql/Wire/Decode.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Decoding values from Postgres wire format to Haskell.++module Preql.Wire.Decode where++import Preql.Wire.Errors+import Preql.Wire.Internal++import Control.Monad.Except+import GHC.TypeNats+import Preql.Imports++import qualified Data.Vector as V+import qualified Data.Vector.Sized as VS+import qualified Database.PostgreSQL.LibPQ as PQ++decodeVector :: KnownNat n =>+ (PgType -> IO (Either QueryError PQ.Oid)) -> RowDecoder n a -> PQ.Result -> IO (Either QueryError (Vector a))+decodeVector lookupType rd@(RowDecoder pgtypes _parsers) result = do+ mismatches <- fmap (catMaybes . VS.toList) $ for (VS.zip (VS.enumFromN 0) pgtypes) $ \(column@(PQ.Col cint), expected) -> do+ actual <- PQ.ftype result column+ e_expectedOid <- lookupType expected+ case e_expectedOid of+ Right oid | actual == oid -> return Nothing+ _ -> do+ m_name <- liftIO $ PQ.fname result column+ let columnName = decodeUtf8With lenientDecode <$> m_name+ return $ Just (TypeMismatch{column = fromIntegral cint, ..})+ if not (null mismatches)+ then return (Left (PgTypeMismatch mismatches))+ else do+ (PQ.Row ntuples) <- liftIO $ PQ.ntuples result+ fmap (first DecoderError) . runExceptT $+ V.generateM (fromIntegral ntuples) (decodeRow rd result . PQ.toRow)
− src/Preql/Wire/FromSql.hs
@@ -1,209 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}---- | Decoding values from Postgres wire format to Haskell.--module Preql.Wire.FromSql where--import Preql.Wire.Errors-import Preql.Wire.Internal-import Preql.Wire.Tuples (deriveFromSqlTuple)-import Preql.Wire.Types--import Control.Monad.Except-import Control.Monad.Trans.State-import Data.Int-import Data.Time (Day, TimeOfDay, UTCTime)-import Data.UUID (UUID)-import Preql.Imports--import qualified BinaryParser as BP-import qualified Data.Aeson as JSON-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Vector as V-import qualified Database.PostgreSQL.LibPQ as PQ-import qualified PostgreSQL.Binary.Decoding as PGB-import qualified Preql.Wire.TypeInfo.Static as OID---- | A @FieldDecoder@ for a type @a@ consists of an OID indicating the--- Postgres type which can be decoded, and a parser from the binary--- representation of that type to the Haskell representation.-data FieldDecoder a = FieldDecoder PgType (BP.BinaryParser a)- deriving Functor--throwLocated :: UnlocatedFieldError -> InternalDecoder a-throwLocated failure = do- DecoderState{row = PQ.Row r, column = PQ.Col c} <- get- throwError (FieldError (fromIntegral r) (fromIntegral c) failure)--decodeVector :: (PgType -> IO (Either QueryError PQ.Oid)) -> RowDecoder a -> PQ.Result -> IO (Either QueryError (Vector a))-decodeVector lookupType rd@(RowDecoder pgtypes _parsers) result = do- mismatches <- fmap catMaybes $ for (zip [0 ..] pgtypes) $ \(column@(PQ.Col cint), expected) -> do- actual <- PQ.ftype result column- e_expectedOid <- lookupType expected- case e_expectedOid of- Right oid | actual == oid -> return Nothing- _ -> do- m_name <- liftIO $ PQ.fname result column- let columnName = decodeUtf8With lenientDecode <$> m_name- return $ Just (TypeMismatch{column = fromIntegral cint, ..})- if not (null mismatches)- then return (Left (PgTypeMismatch mismatches))- else do- (PQ.Row ntuples) <- liftIO $ PQ.ntuples result- let toRow = PQ.toRow . fromIntegral- fmap (first DecoderError) . runExceptT $- V.generateM (fromIntegral ntuples) (decodeRow rd result . toRow)--notNull :: FieldDecoder a -> RowDecoder a-notNull (FieldDecoder oid parser) = RowDecoder [oid] $ do- m_bs <- getNextValue- case m_bs of- Nothing -> throwLocated UnexpectedNull- Just bs -> either (throwLocated . ParseFailure) pure (BP.run parser bs)--nullable :: FieldDecoder a -> RowDecoder (Maybe a)-nullable (FieldDecoder oid parser) = RowDecoder [oid] $ do- m_bs <- getNextValue- case m_bs of- Nothing -> return Nothing- Just bs -> either (throwLocated . ParseFailure) (pure . Just) (BP.run parser bs)--class FromSqlField a where- fromSqlField :: FieldDecoder a--class FromSql a where- fromSql :: RowDecoder a--instance FromSqlField Bool where- fromSqlField = FieldDecoder (Oid OID.boolOid) PGB.bool-instance FromSql Bool where fromSql = notNull fromSqlField--instance FromSqlField Int16 where- fromSqlField = FieldDecoder (Oid OID.int2Oid) PGB.int-instance FromSql Int16 where fromSql = notNull fromSqlField--instance FromSqlField Int32 where- fromSqlField = FieldDecoder (Oid OID.int4Oid) PGB.int-instance FromSql Int32 where fromSql = notNull fromSqlField--instance FromSqlField Int64 where- fromSqlField = FieldDecoder (Oid OID.int8Oid) PGB.int-instance FromSql Int64 where fromSql = notNull fromSqlField--instance FromSqlField Float where- fromSqlField = FieldDecoder (Oid OID.float4Oid) PGB.float4-instance FromSql Float where fromSql = notNull fromSqlField--instance FromSqlField Double where- fromSqlField = FieldDecoder (Oid OID.float8Oid) PGB.float8-instance FromSql Double where fromSql = notNull fromSqlField---- TODO does Postgres have a single-char type? Does it always return bpchar?--- instance FromSqlField Char where--- fromSqlField = FieldDecoder (Oid OID.charOid) PGB.char--- instance FromSql Char where fromSql = notNull fromSqlField--instance FromSqlField String where- fromSqlField = FieldDecoder (Oid OID.textOid) (T.unpack <$> PGB.text_strict)-instance FromSql String where fromSql = notNull fromSqlField--instance FromSqlField Text where- fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_strict-instance FromSql Text where fromSql = notNull fromSqlField--instance FromSqlField TL.Text where- fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_lazy-instance FromSql TL.Text where fromSql = notNull fromSqlField---- | If you want to encode some more specific Haskell type via JSON,--- it is more efficient to use 'Data.Aeson.encode' and--- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this--- instance.-instance FromSqlField ByteString where- fromSqlField = FieldDecoder (Oid OID.byteaOid) (BS.copy <$> BP.remainders)-instance FromSql ByteString where fromSql = notNull fromSqlField--instance FromSqlField BSL.ByteString where- fromSqlField = FieldDecoder (Oid OID.byteaOid) (BSL.fromStrict . BS.copy <$> BP.remainders)-instance FromSql BSL.ByteString where fromSql = notNull fromSqlField---- TODO check for integer_datetimes setting-instance FromSqlField UTCTime where- fromSqlField = FieldDecoder (Oid OID.timestamptzOid) PGB.timestamptz_int-instance FromSql UTCTime where fromSql = notNull fromSqlField--instance FromSqlField Day where- fromSqlField = FieldDecoder (Oid OID.dateOid) PGB.date-instance FromSql Day where fromSql = notNull fromSqlField--instance FromSqlField TimeOfDay where- fromSqlField = FieldDecoder (Oid OID.timeOid) PGB.time_int-instance FromSql TimeOfDay where fromSql = notNull fromSqlField--instance FromSqlField TimeTZ where- fromSqlField = FieldDecoder (Oid OID.timetzOid) (uncurry TimeTZ <$> PGB.timetz_int)-instance FromSql TimeTZ where fromSql = notNull fromSqlField--instance FromSqlField UUID where- fromSqlField = FieldDecoder (Oid OID.uuidOid) PGB.uuid-instance FromSql UUID where fromSql = notNull fromSqlField--instance FromSqlField PQ.Oid where- fromSqlField = PQ.Oid <$> FieldDecoder (Oid OID.oidOid) PGB.int-instance FromSql PQ.Oid where fromSql = notNull fromSqlField---- | If you want to encode some more specific Haskell type via JSON,--- it is more efficient to use 'fromSqlJsonField' rather than this--- instance.-instance FromSqlField JSON.Value where- fromSqlField = FieldDecoder (Oid OID.jsonbOid) PGB.jsonb_ast-instance FromSql JSON.Value where fromSql = notNull fromSqlField--fromSqlJsonField :: JSON.FromJSON a => FieldDecoder a-fromSqlJsonField = FieldDecoder (Oid OID.jsonbOid)- (PGB.jsonb_bytes (first T.pack . JSON.eitherDecode . BSL.fromStrict))---- Overlappable so applications can write Maybe for multi-field domain types-instance {-# OVERLAPPABLE #-} FromSqlField a => FromSql (Maybe a) where- fromSql = nullable fromSqlField--instance (FromSql a, FromSql b) => FromSql (a, b) where- fromSql = (,) <$> fromSql <*> fromSql--instance (FromSql a, FromSql b, FromSql c) => FromSql (a, b, c) where- fromSql = (,,) <$> fromSql <*> fromSql <*> fromSql---- The instances below all follow the pattern laid out by the tuple--- instances above. The ones above are written out without the macro--- to illustrate the pattern.--$(deriveFromSqlTuple 4)-$(deriveFromSqlTuple 5)-$(deriveFromSqlTuple 6)-$(deriveFromSqlTuple 7)-$(deriveFromSqlTuple 8)-$(deriveFromSqlTuple 9)-$(deriveFromSqlTuple 10)-$(deriveFromSqlTuple 11)-$(deriveFromSqlTuple 12)-$(deriveFromSqlTuple 13)-$(deriveFromSqlTuple 14)-$(deriveFromSqlTuple 15)-$(deriveFromSqlTuple 16)-$(deriveFromSqlTuple 17)-$(deriveFromSqlTuple 18)-$(deriveFromSqlTuple 19)-$(deriveFromSqlTuple 20)-$(deriveFromSqlTuple 21)-$(deriveFromSqlTuple 22)-$(deriveFromSqlTuple 23)-$(deriveFromSqlTuple 24)-$(deriveFromSqlTuple 25)
src/Preql/Wire/Internal.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-} -- | The types in this module have invariants which cannot be checked -- if their constructors are in scope. Preql.Wire exports the type@@ -14,27 +16,37 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.State import Data.String (IsString)+import GHC.TypeNats import Preql.Imports +import qualified Data.Vector.Sized as VS import qualified Database.PostgreSQL.LibPQ as PQ --- TODO less ambiguous name (or rename others) -- | The IsString instance does no validation; the limited instances -- discourage directly manipulating strings, with the high risk of SQL--- injection.-newtype Query = Query ByteString+-- injection. A @Query@ is tagged with a 'Nat' representing the width+-- of its return type.+newtype Query (n :: Nat) = Query ByteString deriving (Show, IsString) --- | @RowDecoder@ is 'Applicative' but not 'Monad' so that we can--- assemble all of the OIDs before we read any of the field data sent--- by Postgres.-data RowDecoder a = RowDecoder [PgType] (InternalDecoder a)+-- | @RowDecoder@ is 'Functor' but not 'Monad' so that we can index+-- the type by the number of columns that it consumes. We also know &+-- verify all of the OIDs before we read any of the field data sent by+-- Postgres, which would admit an 'Applicative' instance but not 'Monad'+data RowDecoder (n :: Nat) a = RowDecoder (VS.Vector n PgType) (InternalDecoder a) deriving Functor -instance Applicative RowDecoder where- pure a = RowDecoder [] (pure a)- RowDecoder t1 p1 <*> RowDecoder t2 p2 = RowDecoder (t1 <> t2) (p1 <*> p2)+-- | Analogous to 'pure', @pureDecoder a@ returns the value @a@+-- without consuming any input from Postgres.+pureDecoder :: a -> RowDecoder 0 a+pureDecoder a = RowDecoder VS.empty (pure a) +-- | Analogous to '<*>', @pureDecoder Constructor `applyDecoder` a+-- `applyDecoder` b@ supplies two arguments to @Constructor@, from the+-- 'RowDecoder' @a@ and @b@.+applyDecoder :: RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m+n) b+applyDecoder (RowDecoder vm f) (RowDecoder vn a) = RowDecoder (vm VS.++ vn) (f <*> a)+ -- TODO can I use ValidationT instead of ExceptT, since I ensure Column is incremented before errors? -- | Internal because we need IO for the libpq FFI, but we promise not -- to do any IO besides decoding. We don't even make network calls to@@ -43,11 +55,12 @@ data DecoderState = DecoderState { result :: PQ.Result- , row :: PQ.Row+ , row :: PQ.Row , column :: PQ.Column- } deriving (Show, Eq)+ }+ deriving (Show, Eq) -decodeRow :: RowDecoder a -> PQ.Result -> PQ.Row -> ExceptT FieldError IO a+decodeRow :: RowDecoder n a -> PQ.Result -> PQ.Row -> ExceptT FieldError IO a decodeRow (RowDecoder _ parsers) result row = evalStateT parsers (DecoderState result row 0)
src/Preql/Wire/Query.hs view
@@ -1,51 +1,57 @@+{-# LANGUAGE FlexibleContexts #-} module Preql.Wire.Query where +import Preql.FromSql import Preql.Wire.Errors-import Preql.Wire.FromSql+import Preql.Wire.Decode import Preql.Wire.Internal import Preql.Wire.ToSql import Control.Monad+import GHC.TypeNats import Preql.Imports import qualified Data.Text as T import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ -queryWith :: RowEncoder p -> RowDecoder r -> PQ.Connection -> Query -> p -> IO (Either QueryError (Vector r))-queryWith enc dec conn (Query query) params = do+queryWith :: KnownNat (Width r) =>+ RowEncoder p -> RowDecoder (Width r) r -> PQ.Connection ->+ Query (Width r) -> p -> IO (Either QueryError (Vector r))+queryWith enc dec conn (Query q) params = do -- TODO safer Connection type -- withMVar (connectionHandle conn) $ \connRaw -> do- e_result <- execParams enc conn query params+ e_result <- execParams enc conn q params case e_result of Left err -> return (Left err)- Right result -> decodeVector (lookupType conn) dec result+ Right rows -> decodeVector (lookupType conn) dec rows -- If there is no result, we don't need a Decoder-queryWith_ :: RowEncoder p -> PQ.Connection -> Query -> p -> IO (Either QueryError ())-queryWith_ enc conn (Query query) params = do- e_result <- execParams enc conn query params+queryWith_ :: RowEncoder p -> PQ.Connection -> Query n -> p -> IO (Either QueryError ())+queryWith_ enc conn (Query q) params = do+ e_result <- execParams enc conn q params return (void e_result) +query :: (ToSql p, FromSql r, KnownNat (Width r)) =>+ PQ.Connection -> Query (Width r) -> p -> IO (Either QueryError (Vector r))+query = queryWith toSql fromSql++query_ :: ToSql p => PQ.Connection -> Query n -> p -> IO (Either QueryError ())+query_ = queryWith_ toSql+ execParams :: RowEncoder p -> PQ.Connection -> ByteString -> p -> IO (Either QueryError PQ.Result)-execParams enc conn query params = do- e_result <- connectionError conn =<< PQ.execParams conn query (runEncoder enc params) PQ.Binary+execParams enc conn q params = do+ e_result <- connectionError conn =<< PQ.execParams conn q (runEncoder enc params) PQ.Binary case e_result of Left err -> return (Left (ConnectionError err))- Right result -> do- status <- PQ.resultStatus result+ Right res -> do+ status <- PQ.resultStatus res if status == PQ.CommandOk || status == PQ.TuplesOk- then return (Right result)+ then return (Right res) else do- msg <- PQ.resultErrorMessage result+ msg <- PQ.resultErrorMessage res <&> maybe (T.pack (show status)) (decodeUtf8With lenientDecode) return (Left (ConnectionError msg))--query :: (ToSql p, FromSql r) => PQ.Connection -> Query -> p -> IO (Either QueryError (Vector r))-query = queryWith toSql fromSql--query_ :: ToSql p => PQ.Connection -> Query -> p -> IO (Either QueryError ())-query_ = queryWith_ toSql connectionError :: PQ.Connection -> Maybe a -> IO (Either Text a) connectionError _conn (Just a) = return (Right a)
src/Preql/Wire/Tuples.hs view
@@ -1,33 +1,14 @@-{-# LANGUAGE TemplateHaskell #-} -- | Template Haskell macros to generate tuple instances for FromSql & ToSql module Preql.Wire.Tuples where -import Language.Haskell.TH--alphabet :: [String]-alphabet = cycle (map (:"") ['a'..'z'])+import Preql.QuasiQuoter.Common (alphabet) -deriveFromSqlTuple :: Int -> Q [Dec]-deriveFromSqlTuple n = do- names <- traverse newName (take n alphabet)- Just classN <- lookupTypeName "FromSql"- Just methodN <- lookupValueName "fromSql"- let- context = [ ConT classN `AppT` VarT n | n <- names ]- instanceHead = ConT classN `AppT` foldl AppT (TupleT n) (map VarT names)- method = ValD- (VarP methodN)- (NormalB (foldl- (\row field -> InfixE (Just row) (VarE '(<*>)) (Just field))- (VarE 'pure `AppE` ConE (tupleDataName n))- (replicate n (VarE methodN))))- [] -- no where clause on the fromSql definition- return [InstanceD Nothing context instanceHead [method]]+import Language.Haskell.TH deriveToSqlTuple :: Int -> Q [Dec]-deriveToSqlTuple n = do- names <- traverse newName (take n alphabet)+deriveToSqlTuple size = do+ names <- traverse newName (take size alphabet) Just classN <- lookupTypeName "ToSql" Just fieldN <- lookupTypeName "ToSqlField" Just toSql <- lookupValueName "toSql"@@ -35,7 +16,7 @@ Just toSqlField <- lookupValueName "toSqlField" let context = [ ConT fieldN `AppT` VarT n | n <- names ]- instanceHead = ConT classN `AppT` foldl AppT (TupleT n) (map VarT names)+ instanceHead = ConT classN `AppT` foldl AppT (TupleT size) (map VarT names) method = FunD toSql [Clause [TupP (map VarP names)]
test/Test.hs view
@@ -1,65 +1,99 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} -import Test.Wire (connectionString, wire)+module Main where -import Preql.QuasiQuoter.Raw.TH-import Preql.Wire+import Test.Syntax.RoundTrip+import Test.Syntax.Parser+import Test.Syntax.Printer+import Test.Wire (badConnection, connectionString, wire) -import Data.Either+import Preql+import Preql.Imports+import Preql.QuasiQuoter.Raw.TH as Raw+import Preql.QuasiQuoter.Syntax.Params as Syntax (AntiquoteState(..), numberAntiquotes)+import Preql.QuasiQuoter.Syntax.Syntax hiding (query, select)+import qualified Preql.QuasiQuoter.Syntax.Syntax as Syntax+import qualified Preql.Wire.Query as W++import Control.Exception (throwIO)+import Control.Monad.Trans.Reader (runReaderT) import Data.Int-import Data.List.NonEmpty (NonEmpty(..))-import Database.PostgreSQL.LibPQ (connectdb, finish)+import GHC.TypeNats import Prelude hiding (Ordering(..), lex) import Test.Tasty import Test.Tasty.HUnit -import qualified Preql.QuasiQuoter.Raw.Lex as L-import qualified Preql.Wire.Query as W--import qualified Data.List.NonEmpty as NE import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Preql.QuasiQuoter.Raw.Lex as Raw main :: IO ()-main = defaultMain $ testGroup "crispy-broccoli"+main = defaultMain $ testGroup "preql" [ antiquotes , wire- -- , integration+ , printer+ , lexer+ , parser+ , roundtrip+ , integration ] +integration :: TestTree+integration = withResource initDB PQ.finish $ \db ->+ let+ query' :: (ToSql p, FromSql r, KnownNat (Width r)) =>+ (Preql.Query (Width r), p) -> IO (Vector r)+ query' qp = runReaderT (query qp) =<< db+ in testGroup "integration"+ [ testCase "SELECT foo, bar FROM baz" $ do+ result <- query' [sql|SELECT foo, bar FROM baz |]+ assertEqual "" [(1, "one"), (2, "two")] (result :: Vector (Int32, T.Text))+ , testCase "with params" $ do+ result <- query' $ [select| SELECT foo, bar FROM baz WHERE foo = $1|] (1 :: Int32)+ assertEqual "" [(1, "one")] (result :: Vector (Int32, T.Text))+ , testCase "antiquote, 2 params" $ do+ let+ foo0 = 1 :: Int32+ bar0 = "one" :: T.Text+ result <- query' [select| SELECT foo, bar FROM baz WHERE foo = ${foo0} AND bar = ${bar0}|]+ assertEqual "" [(1, "one")] (result :: Vector (Int32, T.Text))+ , testCase "antiquote, 1 params" $ do+ let foo0 = 1 :: Int32+ result <- query' [select| SELECT foo, bar FROM baz WHERE foo = ${foo0}|]+ assertEqual "" [(1, "one")] (result :: Vector (Int32, T.Text))+ ] --- integration :: TestTree--- integration = withResource (connectdb connectionString) finish $ \db -> testGroup "integration"- -- [ testCase "SELECT foo, bar FROM baz" $ do- -- conn <- db- -- result <- query conn [sql|SELECT foo, bar FROM baz |]- -- assertEqual "" [(1, "one"), (2, "two")] (result :: [(Int, T.Text)])- -- ]--- , testCase "with params" $ do--- conn <- db--- result <- query conn $ [aritySql| SELECT foo, bar FROM baz WHERE foo = $1|] (1 :: Int)--- assertEqual "" [(1, "one")] (result :: [(Int, T.Text)])--- , testCase "antiquote, 2 params" $ do--- conn <- db--- let--- foo0 = 1 :: Int--- bar0 = "one" :: T.Text--- result <- query conn [aritySql| SELECT foo, bar FROM baz WHERE foo = ${foo0} AND bar = ${bar0}|]--- assertEqual "" [(1, "one")] (result :: [(Int, T.Text)])--- , testCase "antiquote, 1 params" $ do--- conn <- db--- let foo0 = 1 :: Int--- result <- query conn [aritySql| SELECT foo, bar FROM baz WHERE foo = ${foo0}|]--- assertEqual "" [(1, "one")] (result :: [(Int, T.Text)])--- ]+initDB :: HasCallStack => IO PQ.Connection+initDB = do+ conn <- PQ.connectdb =<< connectionString+ status <- PQ.status conn+ unless (status == PQ.ConnectionOk) (throwIO =<< badConnection conn)+ let query' q = either throwIO return =<< W.query_ conn q ()+ query' "DROP TABLE IF EXISTS baz"+ query' "CREATE TABLE baz (foo int4, bar text)"+ query' "INSERT INTO baz (foo, bar) values (1, 'one'), (2, 'two')"+ return conn antiquotes :: TestTree antiquotes = testGroup "antiquotes"- [ testCase "numberAntiquotes" $+ [ testCase "numberAntiquotes, Syntax" $ assertEqual ""+ (QS (Simple Syntax.select+ { from = [ J (Table "baz") ]+ , targetList = [ Column (CRef "foo") Nothing, Column (CRef "bar") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "foo") (NumberedParam 1))+ }), AntiquoteState 1 ["foo0"])+ (Syntax.numberAntiquotes 0 (QS (Simple Syntax.select+ { from = [ J (Table "baz") ]+ , targetList = [ Column (CRef "foo") Nothing, Column (CRef "bar") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "foo") (HaskellParam "foo0"))+ })))+ , testCase "numberAntiquotes, Raw" $+ assertEqual "" ("SELECT foo, bar FROM baz WHERE foo = $1", ["foo0"])- (numberAntiquotes 0 [ L.Sql "SELECT foo, bar FROM baz WHERE foo = ", L.HaskellParam "foo0" ])+ (Raw.numberAntiquotes 0 [ Raw.Sql "SELECT foo, bar FROM baz WHERE foo = ", Raw.HaskellParam "foo0" ]) ]
+ test/Test/Syntax/Generators.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+module Test.Syntax.Generators where++import Preql.QuasiQuoter.Syntax.Name+import Preql.QuasiQuoter.Syntax.Syntax as Syntax++import Control.Applicative+import Control.Monad+import Data.Maybe (isNothing)+import Data.Set (Set)+import Data.Text (Text)+import Hedgehog+import Hedgehog.Internal.Range (clamp)+import qualified Data.Char as Char+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++lit :: Gen Literal+lit = Gen.choice+ -- positive numeric literals only, use Unary Negate for negative+ [ I <$> Gen.sized \case+ -- randomly pick [1,10] when we get down to size 1+ 1 -> Gen.prune (Gen.integral (Range.linear 1 10))+ _ -> Gen.integral (Range.linearFrom 1 0 maxBound)+ , F <$> Gen.double (Range.linearFracFrom 1 0 1e300)+ , T <$> Gen.text (Range.linear 0 100) unicodeNotControl+ , B <$> Gen.bool+ , pure Null+ ]++litE :: Gen Expr+litE = Lit <$> lit++unicodeNotControl :: Gen Char+unicodeNotControl = Gen.filter (\c -> Char.ord c > 31 && c /= '\DEL' && c /= '\'' ) Gen.unicode++-- TODO Gen.prune once we get down to length 1+name_ :: Gen Name+name_ = Gen.sized \case+ -- don't shrink to "a"; assume all letters are the same, make queries more legible+ 1 -> Gen.prune (Name <$> (T.cons <$> Gen.lower <*> pure ""))+ _ -> Name <$> Gen.filter (flip Set.notMember keywords)+ (T.cons <$> Gen.lower <*>+ Gen.text (Range.linear 0 29) (Gen.frequency [(26, Gen.lower), (1, pure '_')]))++haskellVarName :: Gen Text+haskellVarName = T.cons <$> Gen.lower <*> Gen.text (Range.linear 0 29) Gen.alphaNum+++select :: Gen SelectStmt+select = select_++select_ :: Gen SelectStmt+select_ = Gen.sized \case+ 1 -> Gen.frequency smallSelects+ _ -> Gen.frequency ( smallSelects ++ [ (20, setSelect) ])+ where+ smallSelects =+ [ (40, Simple <$> simpleSelect)+ , (20, SelectValues <$> Gen.nonEmpty (Range.exponential 1 100)+ (Gen.nonEmpty (Range.exponential 1 20) (scaleOne valueExpr)))+ , (20, S <$> selectWithoutOptions <*> selectOptions_)+ ]+ setSelect = Set <$> Gen.enumBounded <*> Gen.enumBounded <*> scaleHalf select_ <*> scaleHalf select_+ selectWithoutOptions = Gen.filter noOptions (scaleOne select_)+ noOptions (S _ _) = False+ noOptions _ = True++scaledList :: Range Int -> Gen a -> Gen [a]+scaledList range ga = do+ n <- Gen.integral range+ let scale = Gen.scale (clampSize . (`div` Size n))+ Gen.list (Range.singleton n) (scale ga)++simpleSelect :: Gen Select+simpleSelect = do+ -- now bind fields of Syntax.Select+ distinct <- Gen.maybe distinctClause+ -- TODO why don't we support table.* in ResTarget? Is it part of a_expr?+ targetList <- Gen.frequency [(1, pure [Star]), (99, scaledList (Range.linear 1 15) columnTarget)]+ from <- scaledList (Range.linear 1 10) tableRef+ whereClause <- Gen.maybe (scaleHalf expr)+ groupBy <- scaledList (Range.linear 0 5) expr+ having <- Gen.maybe (scaleHalf expr)+ return $ Syntax.select {distinct, from, targetList, whereClause, groupBy, having}++selectOptions_ :: Gen SelectOptions+selectOptions_ = Gen.filter nonTrivial do+ sortBy <- Gen.list (Range.linear 0 5) sortBy_+ offset <- Gen.maybe (scaleOne expr)+ limit <- Gen.maybe (scaleOne expr)+ locking <- scaledList (Range.linear 0 3) locking_+ let withClause = Nothing+ return SelectOptions{..}+ where+ nonTrivial SelectOptions{..} =+ not (null sortBy && isNothing offset && isNothing limit && null locking && isNothing withClause)++valueExpr :: Gen Expr+valueExpr = Gen.filter notSelectExpr expr where+ notSelectExpr (SelectExpr _) = False+ notSelectExpr _ = True++expr :: Gen Expr+expr = Gen.sized \case+ -- TODO frequency+ 0 -> Gen.choice zeros+ 1 -> Gen.choice (zeros ++ ones)+ _ -> Gen.choice (zeros ++ ones ++ twos)+ where+ zeros =+ [ litE+ , CRef <$> name_+ , NumberedParam <$> Gen.integral (Range.linear 1 20)+ , HaskellParam <$> haskellVarName+ ]+ ones =+ [ Unary <$> unaryOp <*> scaleOne expr+ , L <$> scaleOne likeE+ , Indirection <$> scaleOne expr <*> Gen.nonEmpty (Range.linear 1 4) name_+ ]+ twos =+ [ BinOp <$> binOp <*> scaleHalf expr <*> scaleHalf expr+ -- One might expect scaleOne for SelectExpr, but in practice that+ -- leads to unacceptably long test times for Expr. It might be+ -- nice to work out the maximum number of constructors (or p90?)+ -- in SelectStmt of size n, and do something more precise here.+ , SelectExpr <$> scaleHalf select_+ , Fun <$> funApp+ , Cas <$> caseE+ ]++unaryOp :: Gen UnaryOp+unaryOp = Gen.enumBounded++binOp :: Gen BinOp+binOp = Gen.enumBounded++mathOp :: Gen BinOp+mathOp = Gen.element [ Mul, Div, Add, Sub, Exponent, Mod, Eq, Syntax.LT, LTE, Syntax.GT, GTE, NEq ]++likeOp :: Gen LikeOp+likeOp = Gen.enumBounded++likeE :: Gen LikeE+likeE = do+ op <- likeOp+ string <- scaleHalf expr+ likePattern <- scaleHalf expr+ escape <- Gen.frequency+ [(50, pure Nothing), (49, Just . Lit . T . T.singleton <$> Gen.alphaNum), (1, Just <$> scaleHalf expr)]+ invert <- Gen.bool+ return LikeE {..}++funApp :: Gen FunctionApplication+funApp = do+ name <- name_+ indirection <- Gen.list (Range.linear 0 3) name_+ len_arguments <- Gen.integral (Range.linear (-1) 10)+ len_sortBy <- if len_arguments > 0 then pure 0 else Gen.integral (Range.linear 0 3)+ len_withinGroup <- if len_sortBy == 0 then pure 0 else Gen.integral (Range.linear 0 3)+ hasFilter <- Gen.bool+ hasOver <- Gen.bool+ let+ n = len_sortBy + len_withinGroup + min 0 len_arguments + if hasFilter then 1 else 0 + if hasOver then 3 else 0+ scale = if n <= 0 then id else Gen.scale (clampSize . (`div` Size n))+ arguments <- case len_arguments of+ -1 -> pure StarArg+ 0 -> pure NoArgs+ n -> do+ arguments <- Gen.nonEmpty (Range.singleton len_arguments)+ (Gen.choice [ E <$> scale expr, Named <$> name_ <*> scale expr ])+ sortBy <- Gen.list (Range.singleton len_sortBy) (scale sortBy_)+ distinct <- Gen.bool+ return $ Args ArgsList {..}+ withinGroup <- Gen.list (Range.singleton len_withinGroup) (scale sortBy_)+ filterClause <- if hasFilter then Just <$> scale expr else pure Nothing+ over <- if hasOver then scale over_ else pure noWindow+ return FApp{..}++caseE :: Gen Case+caseE = do+ hasImplicit <- Gen.bool+ hasElse <- Gen.bool+ whenSize <- Gen.integral (Range.linear 1 10)+ let+ oneIf x = if x then 1 else 0+ n = 2 * whenSize + oneIf hasImplicit + oneIf hasElse+ scale = Gen.scale (clampSize . (`div` n))+ justIf x = if x then Just <$> scale expr else pure Nothing+ whenClause <- replicateM (Range.unSize whenSize) (liftA2 (,) (scale expr) (scale expr))+ implicitArg <- justIf hasImplicit+ elseClause <- justIf hasElse+ return Case{..}++tableRef :: Gen TableRef+tableRef = Gen.sized \case+ 0 -> singleTable+ 1 -> Gen.choice [ singleTable, aliased ]+ _ -> Gen.choice [ singleTable, aliased, subSelect ]+ where+ singleTable = J <$> joinedTable+ aliased = As <$> scaleOne joinedTable <*> alias+ alias = Alias <$> name_ <*>+ Gen.choice [pure [], Gen.list (Range.linear 1 5) name_]+ subSelect = SubSelect <$> scaleOne select_ <*> alias++joinedTable :: Gen JoinedTable+joinedTable = Gen.sized \case+ 0 -> singleTable+ 1 -> singleTable+ _ -> Gen.choice [ singleTable, joined, crossJoin ]+ where+ singleTable = Table <$> name_+ joined = Join <$> Gen.enumBounded <*> joinQual+ <*> scaleHalf tableRef <*> scaleHalf tableRef+ crossJoin = CrossJoin <$> scaleHalf tableRef <*> scaleHalf tableRef++joinQual :: Gen JoinQual+joinQual = Gen.choice+ [ pure Natural+ , Using <$> Gen.list (Range.linear 1 10) name_+ , On <$> scaleOne expr+ ]++-- | 'Star' is generated in 'select', so we only do @Column@ here+columnTarget :: Gen ResTarget+columnTarget = Column <$> valueExpr <*> Gen.maybe name_++distinctClause :: Gen DistinctClause+distinctClause = Gen.frequency+ [ (1, pure DistinctAll)+ , (9, DistinctOn <$> Gen.nonEmpty (Range.linear 1 5) expr) ]++over_ :: Gen Over+over_ = do+ Gen.choice [ WindowName <$> name_ , Window <$> window_ ]++window_ :: Gen WindowSpec+window_ = do+ refName <- Gen.maybe name_+ partitionClause <- Gen.list (Range.linear 0 3) expr+ orderClause <- Gen.list (Range.linear 0 3) sortBy_+ return WindowSpec {..}++sortBy_ :: Gen SortBy+sortBy_ = SortBy <$> expr <*> sortOrderOrUsing <*> nullsOrder++sortOrderOrUsing :: Gen SortOrderOrUsing+sortOrderOrUsing = Gen.choice [ SortOrder <$> sortOrder, SortUsing <$> mathOp ]++sortOrder :: Gen SortOrder+sortOrder = Gen.enumBounded++nullsOrder :: Gen NullsOrder+nullsOrder = Gen.enumBounded++locking_ :: Gen Locking+locking_ = do+ strength <- Gen.enumBounded+ tables <- Gen.list (Range.linear 0 5) name_+ wait <- Gen.enumBounded+ return Locking{..}++clampSize :: Size -> Size+clampSize = clamp 0 99++scaleOne :: MonadGen m => m a -> m a+scaleOne = Gen.scale (\s -> clampSize (s - 1))++scaleHalf :: MonadGen m => m a -> m a+scaleHalf = Gen.scale (clampSize . (`div` 2))++keywords :: Set Text+keywords = Set.union reserved_keywords type_func_name_keyword++-- Reserved keyword - these keywords are usable only as a ColLabel.+reserved_keywords :: Set Text+reserved_keywords = Set.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", "current_user", "some", "symmetric", "table", "then", "to", "trailing", "true", "union", "unique", "user", "using", "variadic", "when", "where", "window", "with" ]++-- Type/function identifier - keywords that can be type or function names.+type_func_name_keyword :: Set Text+type_func_name_keyword = Set.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" ]
+ test/Test/Syntax/Parser.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syntax.Parser where++import Preql.QuasiQuoter.Syntax.Name+import Preql.QuasiQuoter.Syntax.Parser+import Preql.QuasiQuoter.Syntax.Syntax++import qualified Preql.QuasiQuoter.Syntax.Lex as L++import Data.Either (isRight)+import Data.List.NonEmpty (NonEmpty(..))+import Prelude hiding (Ordering(..), lex)+import Test.Tasty+import Test.Tasty.HUnit++lexer :: TestTree+lexer = testGroup "lexer"+ [ testLex "'foo''bar'" [L.String "foo'bar"]+ , testLex "SELECT 2 + 3;" [L.SELECT, L.Iconst 2, L.Add, L.Iconst 3, L.Semicolon]+ , testLex "5" [L.Iconst 5]+ , testLex "2.5" [L.Fconst 2.5]+ , testLex "2e-2" [L.Fconst 0.02]+ , testLex "2.5e-1" [L.Fconst 0.25]+ , testLex "1 2.3" [ L.Iconst 1, L.Fconst 2.3 ]+ , testLex "1 ." [ L.Iconst 1, L.Dot ]+ , testLex "SELECT 1 IS NULL" [ L.SELECT, L.Iconst 1, L.IS, L.NULL_P ]+ , testLex "SELECT 1 ISNULL" [ L.SELECT, L.Iconst 1, L.ISNULL ]+ ]++parser :: TestTree+parser = testGroup "parser"+ [ testGroup "Expr"+ [ testParseExpr "2 * 3 + 1"+ (BinOp Add (BinOp Mul (Lit (I 2)) (Lit (I 3))) (Lit (I 1)))+ , testParseExpr "1 + 2 * 3"+ (BinOp Add (Lit (I 1)) (BinOp Mul (Lit (I 2)) (Lit (I 3))) )+ , testParseExpr "name = 'Daniel'"+ (BinOp Eq (CRef "name") (Lit (T "Daniel")))+ , testParseExpr "TRUE" (Lit (B True))+ , testParseExpr "true" (Lit (B True))+ , testParseExpr "false" (Lit (B False))+ ]+ , testGroup "Statement"+ [ testParse "DELETE FROM taffy"+ (QD (Delete (mkName "taffy") Nothing))+ , testParse "dEleTe FROM taffy WHERE flavor = 'blueberry'"+ (QD Delete+ { table = mkName "taffy"+ , conditions = Just (BinOp Eq (CRef "flavor") (Lit (T"blueberry")))+ })+ , testParse "DELETE FROM users WHERE email != 'bergey@teallabs.org'"+ (QD Delete+ { table = mkName "users"+ , conditions = Just (BinOp NEq (CRef "email") (Lit (T "bergey@teallabs.org")))+ })+ , testParse "INSERT INTO users (email) VALUES ('bergey@teallabs.org')"+ (QI Insert+ { table = mkName "users"+ , columns = mkName "email" :| []+ , values = Lit (T "bergey@teallabs.org") :| []+ })+ , testParse "INSERT INTO addresses (street, country) VALUES ('4 Ames St', 'USA')"+ (QI Insert+ { table = "addresses"+ , columns = "street" :| ["country" ]+ , values = Lit (T "4 Ames St") :| [ Lit (T "USA") ]+ })+ ]+ , testGroup "Select"+ [ testParseSelect "SELECT name FROM users"+ (Simple select+ { from = [ J (Table "users") ]+ , targetList = [ Column (CRef "name") Nothing ]+ })+ , testParse "SELECT name, email FROM users"+ (QS (Simple select+ { from = [ J (Table "users") ]+ , targetList = [ Column (CRef "name") Nothing, Column (CRef "email") Nothing ]+ }))+ , testParse "SELECT name, email FROM users WHERE name = 'Daniel'"+ (QS (Simple select+ { from = [ J (Table "users") ]+ , targetList = [ Column (CRef "name") Nothing, Column (CRef "email") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "name") (Lit (T "Daniel")))+ }))+ , testParse "SELECT name, email FROM users WHERE name = 'Daniel' OR name = 'Bergey'"+ (QS (Simple select+ { from = [ J (Table "users") ]+ , targetList = [ Column (CRef "name") Nothing, Column (CRef "email") Nothing ]+ , whereClause = Just (BinOp Or (BinOp Eq (CRef "name") (Lit (T "Daniel"))) (BinOp Eq (CRef "name") (Lit (T "Bergey"))))+ }))+ , testParse "SELECT name FROM users WHERE age = 35"+ -- We currently parse integers & decimals all to Double+ -- Just test that both parser rules work+ (QS (Simple select+ { from = [ J (Table "users") ]+ , targetList = [ Column (CRef "name") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "age") (Lit (I 35)))+ }))+ , testParse "SELECT name FROM users WHERE age = 35.5"+ (QS (Simple select+ { from = [ J (Table "users") ]+ , targetList = [ Column (CRef "name") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "age") (Lit (F 35.5)))+ }))+ , testParse "SELECT foo FROM bar WHERE baz > -2"+ (QS (Simple select+ { from = [ J (Table "bar") ]+ , targetList = [ Column (CRef "foo") Nothing ]+ , whereClause = Just (BinOp GT (CRef "baz") (Unary Negate (Lit (I 2))))+ }))+ , testParse "SELECT foo FROM bar WHERE baz = 2e-2"+ (QS (Simple select+ { from = [ J (Table "bar") ]+ , targetList = [ Column (CRef "foo") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "baz") (Lit (F 0.02)))+ }))+ , testParse "SELECT foo FROM bar WHERE baz = 2E-2"+ (QS (Simple select+ { from = [ J (Table "bar") ]+ , targetList = [ Column (CRef "foo") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "baz") (Lit (F 0.02)))+ }))+ , testParse "SELECT * FROM foobar"+ (QS (Simple select+ { from = [ J (Table "foobar") ]+ , targetList = [ Star ]+ }))+ , testParse "SELECT * FROM foo ORDER BY bar"+ (QS (S (Simple select { from = [J (Table "foo") ], targetList = [Star] })+ selectOptions { sortBy = [ SortBy (CRef "bar") (SortOrder DefaultSortOrder) NullsOrderDefault ] }))+ , testParse "SELECT * FROM foo ORDER BY bar DESC"+ (QS (S (Simple select { from = [J (Table "foo") ], targetList = [Star] })+ selectOptions { sortBy = [ SortBy (CRef "bar") (SortOrder Descending) NullsOrderDefault ] }))+ , testParse "SELECT * FROM foo ORDER BY bar NULLS FIRST"+ (QS (S (Simple select { from = [J (Table "foo") ], targetList = [Star] })+ selectOptions { sortBy = [ SortBy (CRef "bar") (SortOrder DefaultSortOrder) NullsFirst ] }))+ , testParse "SELECT * FROM foo ORDER BY bar ASC NULLS LAST"+ (QS (S (Simple select { from = [J (Table "foo") ], targetList = [Star] })+ selectOptions { sortBy = [ SortBy (CRef "bar") (SortOrder Ascending) NullsLast ] }))+ , testParse "SELECT * FROM foobar LIMIT 5"+ (QS (S (Simple select { from = [J (Table "foobar") ], targetList = [Star] })+ selectOptions { limit = Just (Lit (I 5)) }))+ , testParse "SELECT * FROM foobar LIMIT 5 OFFSET 5"+ (QS (S (Simple select { from = [J (Table "foobar") ], targetList = [Star] })+ selectOptions { limit = Just (Lit (I 5)), offset = Just (Lit (I 5)) }))+ , testParse "SELECT * FROM foobar OFFSET 25"+ (QS (S (Simple select { from = [J (Table "foobar") ], targetList = [Star] })+ selectOptions { offset = Just (Lit (I 25)) }))+ , testParse "TABLE foo"+ (QS (Simple select { from = [J (Table "foo") ], targetList = [Star] }))+ , testParse "SELECT foo FROM bar union SELECT baz FROM quux"+ (QS (Set Union Distinct+ (Simple select { from = [ J (Table "bar") ], targetList = [ Column (CRef "foo") Nothing ] })+ (Simple select { from = [ J (Table "quux") ], targetList = [ Column (CRef "baz") Nothing ] })))+ , testParse "SELECT foo FROM bar Intersect ALL SELECT baz FROM quux"+ (QS (Set Intersect All+ (Simple select { from = [ J (Table "bar") ], targetList = [ Column (CRef "foo") Nothing ] })+ (Simple select { from = [ J (Table "quux") ], targetList = [ Column (CRef "baz") Nothing ] })))+ , testParse "SELECT foo FROM bar EXCEPT SELECT baz FROM quux"+ (QS (Set Except Distinct+ (Simple select { from = [ J (Table "bar") ], targetList = [ Column (CRef "foo") Nothing ] })+ (Simple select { from = [ J (Table "quux") ], targetList = [ Column (CRef "baz") Nothing ] })))+ , testParse "SELECT * FROM foo CROSS JOIN bar"+ (QS (Simple select { from = [ J (CrossJoin (J (Table "foo")) (J (Table "bar"))) ]+ , targetList = [Star] }))+ , testParse "SELECT * FROM foo JOIN bar ON foo.f = bar.b"+ (QS (Simple select { from = [ J (Join Inner (On (BinOp Eq (Indirection (CRef "foo") ("f" :| [])) (Indirection (CRef "bar") ("b" :| [])))) (J (Table "foo")) (J (Table "bar"))) ]+ , targetList = [Star]}))+ , testParse "SELECT * FROM foo JOIN bar USING (f, b)"+ (QS (Simple select { from = [ J (Join Inner (Using ["f", "b"]) (J (Table "foo")) (J (Table "bar"))) ]+ , targetList = [Star]}))+ , testParse "SELECT * FROM foo LEFT JOIN bar ON bar.foo = f.id"+ (QS (Simple select { from = [ J (Join LeftJoin (On (BinOp Eq (Indirection (CRef "bar") ("foo" :| [])) (Indirection (CRef "f") ("id" :| [])))) (J (Table "foo")) (J (Table "bar"))) ]+ , targetList = [Star]}))+ , testParse "SELECT * FROM foo NATURAL JOIN bar"+ (QS (Simple select { from = [ J (Join Inner Natural (J (Table "foo")) (J (Table "bar"))) ]+ , targetList = [Star]}))+ , testParse "SELECT DISTINCT foo FROM bar"+ (QS (Simple select { from = [ J (Table "bar") ], targetList = [ Column (CRef "foo") Nothing ], distinct = Just DistinctAll }))+ , testParse "SELECT DISTINCT ON (foo) * FROM bar"+ (QS (Simple select { from = [ J (Table "bar") ], targetList = [ Star ], distinct = Just (DistinctOn (CRef "foo" :| [] )) } ))+ , testParse "SELECT DISTINCT ON (foo, baz) * FROM bar"+ (QS (Simple select { from = [ J (Table "bar") ], targetList = [ Star ], distinct = Just (DistinctOn (CRef "foo" :| [CRef "baz" ] )) } ))+ , testParse "SELECT * FROM (SELECT foo FROM bar) AS baz"+ (QS (Simple select { targetList = [Star]+ , from = [ SubSelect (Simple select { targetList = [ Column (CRef "foo") Nothing ], from = [ J (Table "bar") ] }) (Alias "baz" []) ] } ))+ , testParse "SELECT * FROM foo GROUP BY bar"+ (QS (Simple select { targetList = [Star], from = [J (Table "foo")]+ , groupBy = [ CRef "bar" ] } ))+ -- TODO add count(*) or something, once we can parse functions+ , testParse "SELECT bar FROM foo GROUP BY bar HAVING count > 1"+ (QS (Simple select { targetList = [ Column (CRef "bar") Nothing ]+ , from = [J (Table "foo")]+ , groupBy = [ CRef "bar" ]+ , having = Just (BinOp GT (CRef "count") (Lit (I 1))) } ))+ , testParse "SELECT * FROM foo WHERE bar LIKE '%'"+ (QS (Simple select { targetList = [Star], from = [J (Table "foo")]+ , whereClause = Just (L (like Like (CRef "bar") (Lit (T "%")))) }))+ , testParse "SELECT * FROM foo WHERE bar NOT LIKE '%'"+ (QS (Simple select { targetList = [Star], from = [J (Table "foo")]+ , whereClause = Just (L (like Like (CRef "bar") (Lit (T "%"))) { invert = True }) }))+ , testParse "SELECT * FROM foo WHERE bar SIMILAR TO '%'"+ (QS (Simple select { targetList = [Star], from = [J (Table "foo")]+ , whereClause = Just (L (like Similar (CRef "bar") (Lit (T "%")))) }))+ , testParse "SELECT coalesce(foo, bar) FROM baz"+ ( QS (Simple select+ { targetList = [ Column (Fun $ fapp1 "coalesce" [CRef "foo", CRef "bar"]) Nothing ]+ , from = [J (Table "baz")] }))+ , testParse "SELECT greatest(foo, bar) FROM baz"+ ( QS (Simple select+ { targetList = [ Column (Fun $ fapp1 "greatest" [CRef "foo", CRef "bar"]) Nothing ]+ , from = [J (Table "baz")] }))+ , testParse "SELECT least(foo, bar) FROM baz"+ ( QS (Simple select+ { targetList = [ Column (Fun $ fapp1 "least" [CRef "foo", CRef "bar"]) Nothing ]+ , from = [J (Table "baz")] }))+ , testParse "SELECT 1 IS NULL"+ ( QS (Simple select { targetList = [ Column (Unary IsNull (Lit (I 1))) Nothing ] } ))+ , testParse "SELECT 1 ISNULL"+ ( QS (Simple select { targetList = [ Column (Unary IsNull (Lit (I 1))) Nothing ] } ))+ , testParse "SELECT CASE WHEN true THEN 1 ELSE 2 END"+ ( QS (Simple select+ { targetList =+ [ Column (Cas (Case+ { whenClause = [(Lit (B True), Lit (I 1))]+ , elseClause = Just (Lit (I 2))+ , implicitArg = Nothing }))+ Nothing ] } ))+ , testParse "SELECT CASE WHEN foo is null THEN 1 WHEN foo > 0 THEN 2 END FROM bar"+ ( QS (Simple select+ { targetList =+ [ Column (Cas (Case+ { whenClause =+ [ (Unary IsNull (CRef "foo"), Lit (I 1))+ , (BinOp GT (CRef "foo") (Lit (I 0)), Lit (I 2))+ ]+ , implicitArg = Nothing+ , elseClause = Nothing }))+ Nothing ]+ , from = [ J (Table "bar") ] } ))+ , testParse "SELECT CASE WHEN foo is null THEN 1 WHEN foo > 0 THEN 2 ELSE 3 END FROM bar"+ ( QS (Simple select+ { targetList =+ [ Column (Cas (Case+ { whenClause =+ [ (Unary IsNull (CRef "foo"), Lit (I 1))+ , (BinOp GT (CRef "foo") (Lit (I 0)), Lit (I 2))+ ]+ , implicitArg = Nothing+ , elseClause = Just (Lit (I 3))}))+ Nothing ]+ , from = [ J (Table "bar") ] } ))+ , testParse "SELECT CASE foo WHEN 'bar' THEN 1 ELSE 0 END FROM quux"+ ( QS (Simple select+ { targetList =+ [ Column (Cas (Case+ { implicitArg = Just (CRef "foo")+ , whenClause = [ (Lit (T "bar"), Lit (I 1)) ]+ , elseClause = Just (Lit (I 0))}))+ Nothing ]+ , from = [ J (Table "quux") ] } ))+ , testParse "SELECT CASE foo WHEN 'bar' THEN 1 WHEN 'baz' THEN 2 ELSE 0 END FROM quux"+ ( QS (Simple select+ { targetList =+ [ Column (Cas (Case+ { implicitArg = Just (CRef "foo")+ , whenClause =+ [ (Lit (T "bar"), Lit (I 1))+ , (Lit (T "baz"), Lit (I 2))+ ]+ , elseClause = Just (Lit (I 0))}))+ Nothing ]+ , from = [ J (Table "quux") ] } ))+ , testParse "WITH regional_sales AS (\+\ SELECT region, SUM(amount) AS total_sales\+\ FROM orders\+\ GROUP BY region\+\)\+\SELECT region,\+\ product,\+\ SUM(quantity) AS product_units,\+\ SUM(amount) AS product_sales \+\FROM orders \+\WHERE region = 'Lemuria' \+\GROUP BY region, product;"+ ( QS (S (Simple select+ { targetList = [ Column (CRef "region") Nothing+ , Column (CRef "product") Nothing+ , Column (Fun $ fapp1 "SUM" [ CRef "quantity" ]) (Just "product_units")+ , Column (Fun $ fapp1 "SUM" [ CRef "amount" ]) (Just "product_sales")+ ]+ , from = [ J (Table "orders") ]+ , whereClause = Just ( BinOp Eq (CRef "region") (Lit (T "Lemuria")) )+ , groupBy = [ CRef "region", CRef "product" ]+ })+ selectOptions+ { withClause = Just With+ { recursive = NotRecursive+ , commonTables = [ CommonTableExpr+ { name = "regional_sales"+ , aliases = []+ , materialized = MaterializeDefault+ , query = QS (Simple select+ { targetList =+ [ Column (CRef "region") Nothing+ , Column (Fun $ fapp1 "SUM" [ CRef "amount" ]) (Just "total_sales")+ ]+ , from = [ J (Table "orders") ]+ , groupBy = [ CRef "region" ]+ })+ } ]+ }+ }))+ , testParse "WITH RECURSIVE t(n) AS (\+\ VALUES (1)\+\ UNION ALL\+\ SELECT n+1 FROM t WHERE n < 100\+\ )\+\ SELECT sum(n) FROM t;"+ ( QS (S (Simple select+ { targetList = [ Column (Fun $ fapp1 "sum" [ CRef "n" ]) Nothing ]+ , from = [ J (Table "t") ]+ })+ selectOptions+ { withClause = Just With+ { recursive = Recursive+ , commonTables = [ CommonTableExpr+ { name = "t"+ , aliases = [ "n" ]+ , materialized = MaterializeDefault+ , query = QS (Set Union All+ (SelectValues ((Lit (I 1) :| []) :| []))+ ( Simple select+ { targetList = [ Column (BinOp Add (CRef "n") (Lit (I 1))) Nothing ]+ , from = [ J (Table "t") ]+ , whereClause = Just (BinOp LT (CRef "n") (Lit (I 100)))+ }))+ } ]+ }+ }))+ ]+ , testGroup "locking"+ [ testParseSelect "SELECT * FROM j FOR UPDATE NOWAIT"+ (S (Simple select { targetList = [Star], from = [J (Table "j")] }) selectOptions { locking = [Locking ForUpdate [] LockWaitError] })+ , testParseSelect "SELECT * FROM j UNION ALL SELECT * FROM d"+ ( Set Union All+ (Simple select { targetList = [Star] , from = [ J (Table "j") ]})+ (Simple select { targetList = [Star] , from = [ J (Table "d") ]})+ )+ , canParse "SELECT * FROM j UNION ALL SELECT * FROM d UNION ALL (SELECT * FROM z UNION ALL SELECT * FROM c) FOR UPDATE NOWAIT"+ ]+ ]++testParse :: TestName -> Statement -> TestTree+testParse queryStr expected = testCase queryStr $+ assertEqual "testParse" (Right expected) (parseStatement "<testcase>" queryStr)++testParseSelect :: TestName -> SelectStmt -> TestTree+testParseSelect queryStr expected = testCase queryStr $+ assertEqual "testParseSelect" (Right expected) (parseSelect "<testcase>" queryStr)++testParseExpr :: TestName -> Expr -> TestTree+testParseExpr queryStr expected = testCase queryStr $+ assertEqual "testParseExpr" (Right expected) (parseExpr "<testcase>" queryStr)++testLex :: TestName -> [L.Token] -> TestTree+testLex queryStr expected = testCase queryStr $+ assertEqual "testLex" (Right (expected ++ [L.EOF])) (L.testLex queryStr)++canParse :: TestName -> TestTree+canParse queryStr = testCase queryStr $+ assertBool "canParse" (isRight (parseSelect "<testcase>" queryStr))
+ test/Test/Syntax/Printer.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syntax.Printer where++import Preql.QuasiQuoter.Syntax.Name+import Preql.QuasiQuoter.Syntax.Printer+import Preql.QuasiQuoter.Syntax.Syntax+import Test.Syntax.Generators hiding (select)++import Control.Monad+import Data.Either+import Data.List.NonEmpty (NonEmpty(..))+import Hedgehog+import Test.Tasty+import Test.Tasty.HUnit hiding (assert)+import qualified Test.Tasty.Hedgehog as Tasty (testProperty)++-- | Tests of the SQL syntax printer+printer :: TestTree+printer = testGroup "printer" [+ testGroup "bespoke" [+ testCase "DELETE, no condition" $+ assertEqual ""+ "DELETE FROM taffy"+ (fmt (QD Delete+ { table = mkName "taffy"+ , conditions = Nothing+ }))+ , testCase "DELETE, = condition" $+ assertEqual ""+ "DELETE FROM taffy WHERE flavor = 'blueberry'"+ (fmt (QD Delete+ { table = mkName "taffy"+ , conditions = Just (BinOp Eq (CRef "flavor") (Lit (T"blueberry")))+ }))+ , testCase "INSERT, one column" $+ assertEqual ""+ "INSERT INTO users (email) VALUES ('bergey@teallabs.org')"+ (fmt (QI Insert+ { table = mkName "users"+ , columns = mkName "email" :| []+ , values = Lit (T "bergey@teallabs.org") :| []+ }))+ , testCase "INSERT, two columns" $+ assertEqual ""+ "INSERT INTO users (email, first_name) VALUES ('bergey@teallabs.org', 'Daniel')"+ (fmt (QI Insert+ { table = mkName "users"+ , columns = mkName "email" :| [ mkName "first_name" ]+ , values = Lit (T "bergey@teallabs.org") :| [ Lit (T "Daniel") ]+ }))+ , testCase "params" $+ assertEqual ""+ -- Extra parens until the printer is clever about Expr precedence+ "SELECT name, email FROM users WHERE name = $1"+ (fmt (QS (Simple select+ { from = [ J (Table "users") ]+ , targetList = [ Column (CRef "name") Nothing, Column (CRef "email") Nothing ]+ , whereClause = Just (BinOp Eq (CRef "name") (NumberedParam 1))+ })))+ , testPrint "SELECT * FROM foobar LIMIT 5.0"+ (QS (S (Simple select { from = [J (Table "foobar") ], targetList = [Star] })+ selectOptions { limit = Just (Lit (F 5)) }))+ , testPrint "SELECT foo FROM bar UNION SELECT baz FROM quux"+ (QS (Set Union Distinct+ (Simple select { from = [ J (Table "bar") ], targetList = [ Column (CRef "foo") Nothing ] })+ (Simple select { from = [ J (Table "quux") ], targetList = [ Column (CRef "baz") Nothing ] })))+ , testPrint "SELECT * FROM (SELECT foo FROM bar) AS baz"+ (QS (Simple select { targetList = [Star]+ , from = [ SubSelect (Simple select { targetList = [ Column (CRef "foo") Nothing ], from = [ J (Table "bar") ] }) (Alias "baz" []) ] } ))+ , testPrint "a.b.c" (Indirection (CRef "a") ("b" :| ["c" ]))+ ]+ , testGroup "hedgehog"+ [ testProperty "hedgehog should run" success+ , testProperty "parse Literal" do+ ast <- forAll litE+ void $ evalNF $ formatAsString ast+ , testProperty "Expr" do+ ast <- forAll expr+ void $ evalNF $ formatAsString ast+ ]+ ]++testPrint :: FormatSql sql => TestName -> sql -> TestTree+testPrint expected statement = testCase expected $+ assertEqual "testPrint" expected (formatAsString statement)++testProperty :: TestName -> PropertyT IO () -> TestTree+testProperty name = Tasty.testProperty name . property
+ test/Test/Syntax/RoundTrip.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE BlockArguments #-}+module Test.Syntax.RoundTrip where++import Preql.QuasiQuoter.Syntax.Parser+import Preql.QuasiQuoter.Syntax.Printer+import Preql.QuasiQuoter.Syntax.Syntax as Syntax+import Test.Syntax.Generators as Gen++import Data.List.NonEmpty (NonEmpty(..))+import Hedgehog+import Test.Tasty (TestName, TestTree, testGroup)+import Test.Tasty.HUnit+import qualified Test.Tasty.Hedgehog as Tasty (testProperty)++roundtrip :: TestTree+roundtrip = testGroup "roundtrip"+ [ testGroup "past failures"+ [ knownCase (Indirection (CRef "a") ("b" :| []))+ , knownCase (Indirection (CRef "a") ("b" :| ["c"]))+ , knownCase (Unary Negate (Lit (I 1)))+ , knownCase (Unary Negate (Lit (I 0)))+ , knownCase (L (LikeE Like (Lit (I 1))+ (L (LikeE Like (Unary IsNull (L (LikeE Like (Lit (I 2)) (Lit (I 3)) Nothing True)))+ (Lit (I 4)) Nothing False))+ Nothing False)+ )+ , knownCase (Simple Syntax.select+ { from = [ J (Join Inner (Using [ "c" ]) (J (Table "a")) (J (Table "b"))) ] })+ ]+ , testGroup "hedgehog"+ [ roundTrip "literal" litE+ , roundTrip "Expr" expr+ , roundTrip "Select" Gen.select+ ]+ ]++testProperty :: TestName -> PropertyT IO () -> TestTree+testProperty testName = Tasty.testProperty testName . property++roundTrip :: (FormatSql sql, ParseSql sql, Show sql, Eq sql) =>+ TestName -> Gen sql -> TestTree+roundTrip testName gen = Tasty.testProperty testName $ property do+ ast <- forAll gen+ tripping ast formatAsString (parseSql testName)++knownCase :: (FormatSql sql, ParseSql sql, Show sql, Eq sql) => sql -> TestTree+knownCase e = testCase testName $+ assertEqual "knownCase" (Right e) (parseSql "knownCase" testName)+ where testName = formatAsString e++class ParseSql a where+ parseSql :: FilePath -> String -> Either String a++instance ParseSql Statement where parseSql = parseStatement+instance ParseSql SelectStmt where parseSql = parseSelect+instance ParseSql Expr where parseSql = parseExpr
test/Test/Wire.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeApplications #-} module Test.Wire where import Preql.Wire@@ -16,23 +17,21 @@ import Data.Int import Data.Maybe (fromMaybe) import Data.Text (Text)-#if MIN_VERSION_time(1,9,0)-import Data.Time (Day, TimeOfDay, UTCTime)-import Data.Time.Format.ISO8601 (iso8601ParseM)-#else-import Data.Time (Day, TimeOfDay, UTCTime, TimeZone)-import Data.Time.Format (parseTimeM, defaultTimeLocale, iso8601DateFormat, ParseTime)-#endif import Data.Text.Encoding (encodeUtf8)+import Data.Time (Day, TimeOfDay, UTCTime) import Data.Vector (Vector)+import GHC.TypeNats import System.Environment (lookupEnv) import Test.Tasty import Test.Tasty.HUnit +import Data.Time.Format.ISO8601 (iso8601ParseM)+ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.UUID as UUID import qualified Database.PostgreSQL.LibPQ as PQ+import qualified PostgreSQL.Binary.Decoding as PGB import qualified Preql.Wire.Query as W wire :: TestTree@@ -40,11 +39,11 @@ let inTransaction desc body = testCase desc $ bracket_ (query_ "BEGIN TRANSACTION" ()) (query_ "ROLLBACK" ()) body- query :: (ToSql p, FromSql r) => Query -> p -> IO (Either QueryError (Vector r))+ query :: (ToSql p, FromSql r, KnownNat (Width r)) => Query (Width r) -> p -> IO (Either QueryError (Vector r)) query q p = db >>= \conn -> W.query conn q p- query_ :: (ToSql p) => Query -> p -> IO ()+ query_ :: (ToSql p) => Query 0 -> p -> IO () query_ q p = db >>= \conn -> W.query_ conn q p >>= either throwIO pure- assertQuery :: (FromSql r, Eq r, Show r) => Vector r -> Query -> IO ()+ assertQuery :: (FromSql r, Eq r, Show r, KnownNat (Width r)) => Vector r -> Query (Width r) -> IO () assertQuery expected q = assertEqual "" (Right expected) =<< query q () in [ testGroup "decoders" [ inTransaction "decode True" $@@ -52,13 +51,13 @@ , inTransaction "decode False" $ assertQuery [False] "SELECT false" , inTransaction "decode Int64 literal" $- assertQuery [2^32 :: Int64] "SELECT (2^32)::int8"+ assertQuery [2 `expt` 32 :: Int64] "SELECT (2^32)::int8" , inTransaction "decode Int32 literal" $- assertQuery [2^16 :: Int32] "SELECT (2^16)::int4"+ assertQuery [2 `expt` 16 :: Int32] "SELECT (2^16)::int4" , inTransaction "decode Int16 literal" $- assertQuery [2^8 :: Int16] "SELECT (2^8)::int2"+ assertQuery [2 `expt` 8 :: Int16] "SELECT (2^8)::int2" , inTransaction "decode Float literal" $- assertQuery [2**32 :: Float] "SELECT (2^32)::float4"+ assertQuery [2**32 :: Float] "SELECT (2 ^ 32)::float4" , inTransaction "decode Double literal" $ assertQuery [2**32 :: Double] "SELECT (2^32)::float8" -- , inTransaction "decode Char literal" $@@ -185,6 +184,16 @@ Left (PgTypeMismatch [TypeMismatch { expected = TypeName "my_enum", column = 0 }]) -> pure () _ -> assertFailure "did not get expected TypeMismatch error"+ , inTransaction "composite type: complex" $ do+ query_ "drop type if exists complex" ()+ query_ "create type complex as (r float, i float)" ()+ result <- query "select row(-1,0)::complex as v" ()+ assertEqual "" (Right [Complex (-1) 0]) result+ , inTransaction "composite type: (bool, int)" $ do+ query_ "drop type if exists foo" ()+ query_ "create type foo as (bar bool, baz int)" ()+ result <- query "select row(true, 1)::foo as foo" ()+ assertEqual "" (Right [Foo True 1]) result ] ] @@ -201,17 +210,18 @@ connectionString = do m_dbname <- lookupEnv "PREQL_TESTS_DB" let dbname = case m_dbname of- Just s -> encodeUtf8 (T.pack s)+ Just s -> encodeUtf8 (T.pack s) Nothing -> "preql_tests" return $ "dbname=" <> dbname data BadConnection = BadConnection- { status :: PQ.ConnStatus+ { status :: PQ.ConnStatus , errorMessage :: ByteString- , host :: ByteString- , port :: ByteString- , user :: ByteString- } deriving (Show)+ , host :: ByteString+ , port :: ByteString+ , user :: ByteString+ }+ deriving (Show) instance Exception BadConnection badConnection :: PQ.Connection -> IO BadConnection@@ -223,16 +233,15 @@ user <- fromMaybe "" <$> PQ.user c return BadConnection {..} -#if !MIN_VERSION_time(1,9,0)-class ParseTime8601 t where- iso8601ParseM :: Monad m => String -> m t+data Complex = Complex { real :: !Double, imag :: !Double } deriving (Show, Eq) -instance ParseTime8601 UTCTime where- iso8601ParseM = parseTimeM False defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%SZ"))-instance ParseTime8601 Day where- iso8601ParseM = parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing)-instance ParseTime8601 TimeOfDay where- iso8601ParseM = parseTimeM False defaultTimeLocale "%H:%M:%S"-instance ParseTime8601 TimeZone where- iso8601ParseM = parseTimeM False defaultTimeLocale "%z"-#endif+instance FromSql Complex where+ fromSql = notNull (FieldDecoder (TypeName "complex") (PGB.composite (Complex <$> PGB.valueComposite PGB.float8 <*> PGB.valueComposite PGB.float8)))++data Foo = Foo !Bool !Int deriving (Show, Eq)++instance FromSql Foo where+ fromSql = notNull (FieldDecoder (TypeName "foo") (PGB.composite (Foo <$> PGB.valueComposite PGB.bool <*> PGB.valueComposite PGB.int)))++expt :: Num a => a -> Int64 -> a+expt = (^)