diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,38 @@ +# Change Log + +## [Unreleased] + +## [0.4.0] +### Added +- Changelog. +- Explicit type casts options. +### Changed +- Flags `older-call-syntax` and `debug-queries` are options now. + +## [0.3.0] - 2016-10-29 +### Added +- Cabal flag `debug-queries`. +- Support for nullable columns. + +## [0.2.1] - 2016-09-19 +### Added +- Cabal flags `db-tests`, `older-call-syntax`. + +## [0.2.0] - 2016-08-21 +### Added +- Cabal flag `dev`. +### Changed +- Relicensed to `BSD3`. +- Refactored tests (now using `hspec`). +- Refactored internals. + +## 0.1.0 - 2016-05-28 +### Added +- Initial version of the package. + +[Unreleased]: ../../compare/v0.4.0...HEAD +[0.4.0]: ../../compare/v0.3.0...v0.4.0 +[0.3.0]: ../../compare/v0.2.1...v0.3.0 +[0.2.1]: ../../compare/v0.2.0...v0.2.1 +[0.2.0]: ../../compare/v0.1.0...v0.2.0 + diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} - -#ifdef DBTests import Common (withDB, withRollback) import Data.Text () import Database.PostgreSQL.Simple (Connection, ConnectInfo(..)) @@ -27,7 +24,4 @@ , specUsers , specMessages ] -#else -main :: IO () -main = return () -#endif + diff --git a/postgresql-simple-bind.cabal b/postgresql-simple-bind.cabal --- a/postgresql-simple-bind.cabal +++ b/postgresql-simple-bind.cabal @@ -1,35 +1,26 @@ name: postgresql-simple-bind -version: 0.3.0.0 +version: 0.4.0 synopsis: FFI-like bindings for PostgreSQL stored functions description: For tutorial see here: https:\/\/github.com\/zohl\/postgresql-simple-bind\/blob\/master\/README.md license: BSD3 license-file: LICENSE author: Al Zohali maintainer: Al Zohali --- copyright: + category: Database build-type: Simple --- extra-source-files: cabal-version: >=1.10 +extra-source-files: + CHANGELOG.md + flag dev description: Turn on development settings. manual: True default: False -flag db-tests - description: Turn on tests with database. - manual: False - default: False - -flag older-call-syntax - description: Turn on usage of (:=) in queries instead of (=>). This - is necessary for PostgreSQL < 9.5. - manual: True - default: True - -flag debug-queries - description: Turn on output of executed queries. +flag build-examples + description: Whether to build (and test) examples. manual: False default: False @@ -67,12 +58,6 @@ else ghc-options: -O2 -Wall - if flag(older-call-syntax) - cpp-options: -DOlderCallSyntax - - if flag(debug-queries) - cpp-options: -DDebugQueries - test-suite tests type: exitcode-stdio-1.0 @@ -91,35 +76,36 @@ default-language: Haskell2010 if flag(dev) - ghc-options: -Wall -Werror + ghc-options: -Werror else - ghc-options: -O2 -Wall + ghc-options: -O2 test-suite examples type: exitcode-stdio-1.0 - hs-source-dirs: examples - main-is: Main.hs + hs-source-dirs: examples + main-is: Main.hs + default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -Wno-redundant-constraints - build-depends: base >= 4.7 && < 5.0 - , attoparsec >= 0.13.0 && < 0.14 - , bytestring >= 0.10.8 && < 0.11 - , case-conversion - , data-default - , hspec - , postgresql-simple >= 0.5.2 && < 0.6 - , postgresql-simple-bind - , text >= 1.2.2 && < 1.3 + if flag(build-examples) + build-depends: base >= 4.7 && < 5.0 + , attoparsec >= 0.13.0 && < 0.14 + , bytestring >= 0.10.8 && < 0.11 + , case-conversion + , data-default + , hspec + , postgresql-simple >= 0.5.2 && < 0.6 + , postgresql-simple-bind + , text >= 1.2.2 && < 1.3 - default-language: Haskell2010 + if flag(dev) + ghc-options: -Werror + else + ghc-options: -O2 - if flag(dev) - ghc-options: -Wall -Wno-redundant-constraints -Werror else - ghc-options: -O2 -Wall -Wno-redundant-constraints + buildable: False - if flag(db-tests) - cpp-options: -DDBTests diff --git a/src/Database/PostgreSQL/Simple/Bind/Common.hs b/src/Database/PostgreSQL/Simple/Bind/Common.hs --- a/src/Database/PostgreSQL/Simple/Bind/Common.hs +++ b/src/Database/PostgreSQL/Simple/Bind/Common.hs @@ -13,6 +13,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} + {-| Module: Database.PostgreSQL.Simple.Bind.Common Copyright: (c) 2016 Al Zohali @@ -42,9 +43,19 @@ -- | Options that specify how to construct the function binding. data PostgresBindOptions = PostgresBindOptions { - pboFunctionName :: PGFunction -> String -- ^ Function that generates name of a binding. - , pboIsNullable :: String -> String -> Bool -- ^ Which columns in returned tables can be null. - , pboSetOfReturnType :: String -> ReturnType -- ^ How to process type in "setof" clause. + pboFunctionName :: PGFunction -> String + -- ^ Function that generates name of a binding. + , pboIsNullable :: String -> String -> Bool + -- ^ Which columns in returned tables can be null. + , pboSetOfReturnType :: String -> ReturnType + -- ^ How to process type in "setof" clause. + , pboExplicitCasts :: Bool + -- ^ Whether to add explicit type casts to arguments. + , pboOlderCallSyntax :: Bool + -- ^ Whether to use old-style call syntax (:=) instead of (=>). This is + -- necessary for PostgreSQL < 9.5. + , pboDebugQueries :: Bool + -- ^ Whether to print executed queries and their arguments. } instance Default PostgresBindOptions where @@ -52,6 +63,9 @@ pboFunctionName = \(PGFunction _schema name _args _result) -> name , pboIsNullable = \_fname _column -> False , pboSetOfReturnType = \_tname -> AsField + , pboExplicitCasts = True + , pboOlderCallSyntax = True + , pboDebugQueries = False } -- | Remove 'Only' constructor. diff --git a/src/Database/PostgreSQL/Simple/Bind/Implementation.hs b/src/Database/PostgreSQL/Simple/Bind/Implementation.hs --- a/src/Database/PostgreSQL/Simple/Bind/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/Bind/Implementation.hs @@ -13,7 +13,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-| Module: Database.PostgreSQL.Simple.Bind.Implementation @@ -33,13 +33,9 @@ ) where import Control.Exception (throw) - -#ifdef DebugQueries -import Debug.Trace (traceId, traceShowId) -#endif - +import Debug.Trace (traceIO) import Data.List (intersperse) -import Data.Maybe (catMaybes, maybeToList) +import Data.Maybe (catMaybes) import Data.Text (Text) import Database.PostgreSQL.Simple (Connection, query, query_) import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGResult(..), PGColumn(..)) @@ -52,8 +48,10 @@ import GHC.TypeLits (Symbol) import Language.Haskell.TH.Syntax (Q, Dec(..), Exp(..), Type(..), Clause(..), Body(..), Pat(..)) import Language.Haskell.TH.Syntax (Name, mkName, newName, Lit(..), TyLit(..), TyVarBndr(..)) +import Language.Haskell.TH.Syntax (Stmt(..)) import qualified Data.ByteString.Char8 as BS + -- | Mapping from PostgreSQL types to Haskell types. type family PostgresType (a :: Symbol) @@ -64,42 +62,63 @@ mkFunction :: PostgresBindOptions -> PGFunction -> Q [Dec] mkFunction opt f = sequence $ (($ f) . ($ opt)) <$> [mkFunctionT, mkFunctionE] -#ifdef DebugQueries -data Argument = forall a . (Show a, ToField a) => MandatoryArg String a - | forall a . (Show a, ToField a) => OptionalArg String (Maybe a) -instance Show Argument where - show (MandatoryArg name value) = "mandatory: " ++ name ++ " => " ++ show value - show (OptionalArg name value) = "optional: " ++ name ++ " => " ++ show value -#else -data Argument = forall a . (ToField a) => MandatoryArg String a - | forall a . (ToField a) => OptionalArg String (Maybe a) -#endif +data Argument + = forall a . (ToField a) => MandatoryArg { + argName :: String + , argType :: String + , argRepresentation :: Maybe String + , margValue :: a + } + | forall a . (ToField a) => OptionalArg { + argName :: String + , argType :: String + , argRepresentation :: Maybe String + , morgValue :: Maybe a + } instance ToField Argument where - toField (MandatoryArg _ x) = toField x - toField (OptionalArg _ (Just x)) = toField x - toField (OptionalArg name Nothing) = throw . DefaultValueNotFound $ name + toField MandatoryArg {..} = toField margValue + toField OptionalArg {..} = maybe + (throw . DefaultValueNotFound $ argName) + toField + morgValue -formatArgument :: Argument -> Maybe String -formatArgument (MandatoryArg _name _value) = Just "?" -formatArgument (OptionalArg name (Just _value)) = Just $ name ++ -#ifdef OlderCallSyntax - " := ?" -#else - " => ?" -#endif +instance Show Argument where + show arg = concat $ [ + argName arg + , " => " + , maybe (throw . RepresentationNotFound $ argName arg) id (argRepresentation arg) + , " :: " + , argType arg + ] -formatArgument (OptionalArg _name Nothing) = Nothing +untypedPlaceholder, typedPlaceholder :: String -> String +untypedPlaceholder = const "?" +typedPlaceholder atype = "(?)::" ++ atype -formatArguments :: [Argument] -> String -formatArguments = concat . (intersperse ",") . catMaybes . (map formatArgument) +formatArgument :: String -> (String -> String) -> Argument -> Maybe String +formatArgument callSyntax placeholder = format where + format = \case + MandatoryArg {..} -> Just $ placeholder argType + OptionalArg {..} -> fmap + (const . concat $ [argName, callSyntax, placeholder argType]) + morgValue + + +formatArguments :: String -> (String -> String) -> [Argument] -> String +formatArguments callSyntax placeholder = concat + . (intersperse ", ") + . catMaybes + . (map $ formatArgument callSyntax placeholder) + + filterArguments :: [Argument] -> [Argument] filterArguments = filter isPresented where isPresented :: Argument -> Bool - isPresented (OptionalArg _name Nothing) = False - isPresented _ = True + isPresented (OptionalArg {..}) = maybe False (const True) $ morgValue + isPresented _ = True -- | Example: "varchar" -> PostgresType "varchar" @@ -146,32 +165,47 @@ return (names, context, clause) --- | Example: [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] -> ( --- ["x1", "x2"] --- , [PostgresType "varchar" ~ x1, ToField x1, PostgresType "bigint" ~ x2, ToField x2] --- , [x1, Maybe x2]) + +-- | Example: [ +-- PGArgument { pgaName = "x", pgaType = "varchar", pgaOptional = True } +-- , PGArgument { pgaName = "y", pgaType = "bigint", pgaOptional = False } +-- ] -> ( +-- ["x1", "x2"] +-- , [PostgresType "varchar" ~ x1, ToField x1, PostgresType "bigint" ~ x2, ToField x2] +-- , [x1, Maybe x2] +-- ) mkArgsT :: [PGArgument] -> Q ([Name], [Type], [Type]) mkArgsT cs = do names <- sequence $ replicate (length cs) (newName "x") - let context = concat $ zipWith (\(PGArgument _ t _) n -> mkContextT ''ToField t n) cs names + let context = concat $ zipWith (\PGArgument {..} n -> mkContextT ''ToField pgaType n) cs names let defWrap d = case d of True -> AppT (ConT ''Maybe) False -> id - let clause = zipWith (\(PGArgument _ _ d) -> (defWrap d) . VarT) cs names + let clause = zipWith (\PGArgument {..} -> (defWrap pgaOptional) . VarT) cs names return (names, context, clause) --- | Example: (PGFunction "public" "foo" --- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) -> { --- foo :: forall x1 x2 x3. ( --- PostgresType "varchar" ~ x1, ToField x1 --- , PostgresType "bigint" ~ x2, ToField x2 --- , PostgresType "varchar" ~ x2, FromField x3) => Connection -> x1 -> Maybe x2 -> x3} + +-- | Example: PGFunction { +-- pgfSchema = "public" +-- , pgfName = "foo" +-- , pgfResult = PGSingle "varchar" +-- , pgfArguments = [ +-- PGArgument { pgaName = "x", pgaType = "varchar", pgaOptional = True } +-- , PGArgument { pgaName = "y", pgaType = "bigint", pgaOptional = False } +-- ] +-- } -> { +-- foo :: forall x1 x2 x3. ( +-- PostgresType "varchar" ~ x1, ToField x1 +-- , PostgresType "bigint" ~ x2, ToField x2 +-- , PostgresType "varchar" ~ x2, FromField x3 +-- ) => Connection -> x1 -> Maybe x2 -> x3 +-- } mkFunctionT :: PostgresBindOptions -> PGFunction -> Q Dec -mkFunctionT opt@(PostgresBindOptions {..}) f@(PGFunction _schema fname args ret) = do - (argNames, argContext, argClause) <- mkArgsT args - (retNames, retContext, retClause) <- mkResultT opt fname ret +mkFunctionT opt@(PostgresBindOptions {..}) f@(PGFunction {..}) = do + (argNames, argContext, argClause) <- mkArgsT pgfArguments + (retNames, retContext, retClause) <- mkResultT opt pgfName pgfResult let vars = map PlainTV (argNames ++ retNames) let context = argContext ++ retContext @@ -182,25 +216,30 @@ return $ SigD (mkName $ pboFunctionName f) $ ForallT vars context clause -traceIdWrapE :: Exp -> Exp -#ifdef DebugQueries -traceIdWrapE q = (VarE 'traceId) `AppE` q -#else -traceIdWrapE = id -#endif - --- | Example: --- (PGFunction "public" "foo" --- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) --- args -> { Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"] } +-- | Example: PGFunction { +-- pgfSchema = "public" +-- , pgfName = "foo" +-- , pgfResult = PGSingle "varchar" +-- , pgfArguments = [ +-- PGArgument { pgaName = "x", pgaType = "varchar", pgaOptional = True } +-- , PGArgument { pgaName = "y", pgaType = "bigint", pgaOptional = False } +-- ] +-- } -> { +-- Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"] +-- } mkSqlQuery :: PostgresBindOptions -> PGFunction -> Maybe Name -> Exp -mkSqlQuery opt (PGFunction schema fname _args ret) argsName = - toQuery . traceIdWrapE . AppE (VarE 'concat) . ListE $ [ - mkStrLit $ concat [prefix opt, " ", functionName, "("] - , maybe (mkStrLit "") (\args -> (VarE 'formatArguments) `AppE` (VarE args)) argsName +mkSqlQuery PostgresBindOptions {..} PGFunction {..} argsName = + toQuery . AppE (VarE 'concat) . ListE $ [ + mkStrLit $ concat [prefix, " ", functionName, "("] + , maybe (mkStrLit "") (\args -> foldl1 AppE [ + VarE 'formatArguments + , mkStrLit $ if pboOlderCallSyntax then " := " else " => " + , VarE $ if pboExplicitCasts then 'typedPlaceholder else 'untypedPlaceholder + , VarE args + ]) argsName , mkStrLit ")"] where - prefix (PostgresBindOptions {..}) = case ret of + prefix = case pgfResult of PGTable _ -> mkSelect AsRow PGSetOf tname -> mkSelect $ pboSetOfReturnType tname _ -> mkSelect AsField @@ -208,9 +247,9 @@ mkSelect AsRow = "select * from" mkSelect AsField = "select" - functionName = case schema of - "" -> fname - _ -> schema ++ "." ++ fname + functionName = case pgfSchema of + "" -> pgfName + _ -> pgfSchema ++ "." ++ pgfName mkStrLit s = LitE (StringL s) toQuery = AppE (ConE 'Query) . AppE (VarE 'BS.pack) @@ -229,41 +268,70 @@ unwrapE opt (PGSetOf tname) q = unwrapE' (pboSetOfReturnType opt tname) q unwrapE _ (PGTable _) q = unwrapE' AsRow q -traceShowIdWrapE :: Exp -> Exp -#ifdef DebugQueries -traceShowIdWrapE q = (VarE 'traceShowId) `AppE` q -#else -traceShowIdWrapE = id -#endif --- | Example: (PGFunction "public" "foo" --- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) -> { --- foo conn x1 x2 = query conn --- (Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"]) --- (filterArguments [MandatoryArg "x1" x1, OptionalArg "x2" x2]) +wrapArg :: PostgresBindOptions -> PGArgument -> Name -> Exp +wrapArg (PostgresBindOptions {..}) (PGArgument n t d) argName = foldl1 AppE $ [ + ConE $ if d then 'OptionalArg else 'MandatoryArg + , LitE $ StringL n + , LitE $ StringL t + , if pboDebugQueries + then foldr1 AppE [ConE 'Just, VarE 'show, VarE argName] + else ConE 'Nothing + , VarE argName] + + +-- | Example: PGFunction { +-- pgfSchema = "public" +-- , pgfName = "foo" +-- , pgfResult = PGSingle "varchar" +-- , pgfArguments = [ +-- PGArgument { pgaName = "x", pgaType = "varchar", pgaOptional = True } +-- , PGArgument { pgaName = "y", pgaType = "bigint", pgaOptional = False } +-- ] +-- } -> { +-- foo conn x1 x2 = query conn +-- (Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"]) +-- (filterArguments [MandatoryArg "x1" x1, OptionalArg "x2" x2]) +-- } mkFunctionE :: PostgresBindOptions -> PGFunction -> Q Dec -mkFunctionE opt@(PostgresBindOptions {..}) f@(PGFunction _schema _fname args ret) = do - names <- sequence $ replicate (length args) (newName "x") +mkFunctionE opt@(PostgresBindOptions {..}) f@(PGFunction {..}) = do + names <- sequence $ replicate (length pgfArguments) (newName "x") connName <- newName "conn" - argsName <- case (null args) of + argsName <- case (null pgfArguments) of True -> return Nothing False -> Just <$> newName "args" - let wrapArg (PGArgument n _ d) argName = foldl1 AppE $ case d of - False -> [(ConE 'MandatoryArg), (LitE (StringL n)), (VarE argName)] - True -> [(ConE 'OptionalArg), (LitE (StringL n)), (VarE argName)] + let argsExpr = AppE + (VarE 'filterArguments) + (ListE $ zipWith (wrapArg opt) pgfArguments names) - let argsExpr = (VarE 'filterArguments) `AppE` (ListE $ zipWith wrapArg args names) + sqlQueryName <- newName "sqlQuery" + let sqlQueryExpr = mkSqlQuery opt f argsName let funcName = mkName $ pboFunctionName f let funcArgs = (VarP connName):(map VarP names) - let funcBody = NormalB $ unwrapE opt ret $ foldl1 AppE $ [ - VarE $ maybe 'query_ (const 'query) argsName - , VarE connName - , mkSqlQuery opt f argsName - ] ++ (const (traceShowIdWrapE argsExpr) <$> maybeToList argsName) - let decl = (\name -> ValD (VarP name) (NormalB argsExpr) []) <$> maybeToList argsName - return $ FunD funcName [Clause funcArgs funcBody decl] + let funcBody = NormalB $ if pboDebugQueries + then DoE $ NoBindS <$> [traceQuery, traceArgs, execQuery] + else execQuery + where + traceQuery = foldr1 AppE [VarE 'traceIO, VarE 'show, VarE sqlQueryName] + + traceArgs = foldr1 AppE . maybe + [VarE 'traceIO, LitE $ StringL "no arguments"] + (\name -> [VarE 'traceIO, VarE 'show, VarE name]) + $ argsName + + execQuery = unwrapE opt pgfResult $ foldl1 AppE $ [ + VarE $ maybe 'query_ (const 'query) argsName + , VarE connName + , sqlQueryExpr + ] ++ (maybe [] (return . VarE) argsName) + + let funcDecl = [ + ValD (VarP sqlQueryName) (NormalB sqlQueryExpr) [] + ] ++ (maybe [] (\name -> return $ ValD (VarP name) (NormalB argsExpr) []) argsName) + + return $ FunD funcName [Clause funcArgs funcBody funcDecl] diff --git a/src/Database/PostgreSQL/Simple/Bind/Representation.hs b/src/Database/PostgreSQL/Simple/Bind/Representation.hs --- a/src/Database/PostgreSQL/Simple/Bind/Representation.hs +++ b/src/Database/PostgreSQL/Simple/Bind/Representation.hs @@ -12,6 +12,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} {-| Module: Database.PostgreSQL.Simple.Bind.Representation @@ -50,24 +52,41 @@ | DefaultValueNotFound String -- ^ Thrown when 'Argument' expected to have default value while -- it doesn't. Actually this should never happen, but we all know... + | RepresentationNotFound String + -- ^ Thrown when 'Argument' is beign printed, but representation was't + -- provided. Again, this should never happen. deriving (Eq, Show, Typeable) instance Exception PostgresBindException --- | Representation of a function's argument (name, type, is optional). -data PGArgument = PGArgument String String Bool deriving (Show, Eq) +-- | Representation of a function's argument. +data PGArgument = PGArgument { + pgaName :: String + , pgaType :: String + , pgaOptional :: Bool + } deriving (Show, Eq) -- | Representation of a PostrgeSQL function signature (schema, name, arguments, result). -data PGFunction = PGFunction String String [PGArgument] PGResult deriving (Show, Eq) +data PGFunction = PGFunction { + pgfSchema :: String + , pgfName :: String + , pgfArguments :: [PGArgument] + , pgfResult :: PGResult + } deriving (Show, Eq) -- | Representation of a resultant's column (name, type). -data PGColumn = PGColumn String String deriving (Show, Eq) +data PGColumn = PGColumn { + pgcName :: String + , pgcType :: String + } deriving (Show, Eq) -- | Representation of a function's return value. -data PGResult = PGSingle String - | PGSetOf String - | PGTable [PGColumn] deriving (Show, Eq) +data PGResult + = PGSingle String + | PGSetOf String + | PGTable [PGColumn] + deriving (Show, Eq) -- | Takes PostgreSQL function signature and represent it as an algebraic data type. parsePGFunction :: (MonadThrow m) => Text -> m PGFunction @@ -78,39 +97,36 @@ ss = skipSpace function = do - _ <- asciiCI "function" - schema <- ss *> ((identifier <* (char '.')) <|> (string "")) - name <- ss *> identifier - args <- ss *> char '(' *> (arguments `sepBy` (char ',')) - ret <- ss *> char ')' *> returnType - _ <- ss - return $ PGFunction (unpack schema) (unpack name) args ret + _ <- asciiCI "function" + pgfSchema <- fmap unpack $ ss *> ((identifier <* (char '.')) <|> (string "")) + pgfName <- fmap unpack $ ss *> identifier + pgfArguments <- ss *> char '(' *> (arguments `sepBy` (char ',')) + pgfResult <- ss *> char ')' *> returnType + _ <- ss + return PGFunction {..} arguments = do - name <- ss *> identifier - datatype <- ss *> postgresType - def <- ss *> ((asciiCI "default" <|> string "=") *> (takeTill (inClass ",)")) - <|> (string "")) + pgaName <- fmap unpack $ ss *> identifier + pgaType <- fmap unpack $ ss *> postgresType + pgaOptional <- fmap (( > 0) . length) $ ss *> ( + (asciiCI "default" <|> string "=") *> (takeTill (inClass ",)")) + <|> (string "")) -- WARNING: parsing default values requires ability to parse almost arbitraty expressions. -- Here is a quick and dirty implementation of the parser. - - return $ PGArgument (unpack name) (unpack datatype) ((length def) > 0) + return PGArgument {..} cols = do - name <- ss *> identifier - datatype <- ss *> postgresType <* ss - return $ PGColumn (unpack name) (unpack datatype) - - returnType = do - ret <- ss *> asciiCI "returns" *> ss *> ( - asciiCI "setof" - <|> asciiCI "table" - <|> postgresType) + pgcName <- fmap unpack $ ss *> identifier + pgcType <- fmap unpack $ ss *> postgresType <* ss + return PGColumn {..} - case toLower(ret) of - "setof" -> (PGSetOf . unpack) <$> (ss *> postgresType) - "table" -> PGTable <$> (ss *> char '(' *> cols `sepBy` (char ',') <* ss <* char ')') - t -> return $ PGSingle (unpack t) + returnType = ss *> asciiCI "returns" *> ss *> (fmap toLower $ + asciiCI "setof" + <|> asciiCI "table" + <|> postgresType) >>= \case + "setof" -> (PGSetOf . unpack) <$> (ss *> postgresType) + "table" -> PGTable <$> (ss *> char '(' *> cols `sepBy` (char ',') <* ss <* char ')') + t -> return $ PGSingle (unpack t) identifier = do s1 <- takeWhile1 (inClass "a-zA-Z_") @@ -167,3 +183,4 @@ _ -> (modifiers $ Just (n - 1))) modifier = (decimal :: Parser Int) *> ss + diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} import Test.Hspec import Database.PostgreSQL.Simple.Bind.Representation @@ -10,124 +9,203 @@ spec :: Spec spec = do + let test = \declaration result -> parsePGFunction declaration >>= shouldBe result + describe "parsePGFunction" $ do it "works with simple signatures" $ do - (parsePGFunction "function f(x bigint) returns bigint") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "bigint" False] (PGSingle "bigint")) + let r = PGFunction { + pgfSchema = "" + , pgfName = "" + , pgfArguments = [] + , pgfResult = PGSingle "" + } - (parsePGFunction "function g(x bigint, y varchar) returns void") >>= shouldBe - (PGFunction "" "g" [PGArgument "x" "bigint" False, PGArgument "y" "varchar" False] - (PGSingle "void")) + test "function f(x bigint) returns bigint" r { + pgfName = "f" + , pgfResult = PGSingle "bigint" + , pgfArguments = [ + PGArgument { pgaName = "x", pgaType = "bigint", pgaOptional = False } + ] + } - (parsePGFunction "function h() returns varchar") >>= shouldBe - (PGFunction "" "h" [] (PGSingle "varchar")) + test "function g(x bigint, y varchar) returns void" r { + pgfName = "g" + , pgfArguments = [ + PGArgument { pgaName = "x", pgaType = "bigint", pgaOptional = False } + , PGArgument { pgaName = "y", pgaType = "varchar", pgaOptional = False } + ] + , pgfResult = PGSingle "void" + } - (parsePGFunction "FUNCTION H(Z VARCHAR) RETURNS BIGINT") >>= shouldBe - (PGFunction "" "h" [PGArgument "z" "varchar" False] (PGSingle "bigint")) + test "function h() returns varchar" r { + pgfName = "h" + , pgfArguments = [] + , pgfResult = PGSingle "varchar" + } + test "FUNCTION H(Z VARCHAR) RETURNS BIGINT" r { + pgfName = "h" + , pgfArguments = [ + PGArgument { pgaName = "z", pgaType = "varchar", pgaOptional = False } + ] + , pgfResult = PGSingle "bigint" + } + it "works with default values" $ do - (parsePGFunction "function f(x bigint default 0::bigint) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "bigint" True] (PGSingle "void")) + let r = PGFunction { + pgfSchema = "" + , pgfName = "f" + , pgfArguments = [] + , pgfResult = PGSingle "void" + } - (parsePGFunction "function f(x bigint, y bigint default 0::bigint) returns void") >>= shouldBe - (PGFunction "" "f" - [PGArgument "x" "bigint" False, PGArgument "y" "bigint" True] (PGSingle "void")) + test "function f(x bigint default 0::bigint) returns void" r { + pgfArguments = [ + PGArgument { pgaName = "x", pgaType = "bigint", pgaOptional = True } + ] + } - (parsePGFunction - "function f(x bigint, y bigint = 0::bigint, z bigint = 0::bigint) returns void") >>= shouldBe - (PGFunction "" "f" [ - PGArgument "x" "bigint" False - , PGArgument "y" "bigint" True - , PGArgument "z" "bigint" True - ] (PGSingle "void")) + test "function f(x bigint, y bigint default 0::bigint) returns void" r { + pgfArguments = [ + PGArgument { pgaName = "x", pgaType = "bigint", pgaOptional = False } + , PGArgument { pgaName = "y", pgaType = "bigint", pgaOptional = True } + ] + } + test "function f(x bigint, y bigint = 0::bigint, z bigint = 0::bigint) returns void" r { + pgfArguments = [ + PGArgument { pgaName = "x", pgaType = "bigint", pgaOptional = False } + , PGArgument { pgaName = "y", pgaType = "bigint", pgaOptional = True } + , PGArgument { pgaName = "z", pgaType = "bigint", pgaOptional = True } + ] + } it "works with return value types" $ do - (parsePGFunction "function f() returns setof bigint") >>= shouldBe - (PGFunction "" "f" [] (PGSetOf "bigint")) + let r = PGFunction { + pgfSchema = "" + , pgfName = "f" + , pgfArguments = [] + , pgfResult = PGSetOf "" + } - (parsePGFunction "function f() returns SETOF bigint") >>= shouldBe - (PGFunction "" "f" [] (PGSetOf "bigint")) + test "function f() returns setof bigint" r { pgfResult = PGSetOf "bigint" } - (parsePGFunction "function f() returns table (x bigint, y varchar)") >>= shouldBe - (PGFunction "" "f" [] (PGTable [PGColumn "x" "bigint", PGColumn "y" "varchar"])) + test "function f() returns SETOF bigint" r { pgfResult = PGSetOf "bigint" } + test "function f() returns table (x bigint, y varchar)" r { + pgfResult = PGTable [ + PGColumn { pgcName = "x", pgcType = "bigint" } + , PGColumn { pgcName = "y", pgcType = "varchar" } + ] + } it "works with schema names" $ do - (parsePGFunction "function public.f() returns bigint") >>= shouldBe - (PGFunction "public" "f" [] (PGSingle "bigint")) + let r = PGFunction { + pgfSchema = "" + , pgfName = "f" + , pgfArguments = [] + , pgfResult = PGSingle "bigint" + } - (parsePGFunction "function Test.f() returns bigint") >>= shouldBe - (PGFunction "test" "f" [] (PGSingle "bigint")) + test "function public.f() returns bigint" r { pgfSchema = "public" } + test "function Test.f() returns bigint" r { pgfSchema = "test" } describe "parsing a function with specific type" $ do - it "works for multiple word types" $ do - (parsePGFunction "function f(x double precision) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "double precision" False] (PGSingle "void")) + let r = PGFunction { + pgfSchema = "" + , pgfName = "f" + , pgfArguments = [] + , pgfResult = PGSingle "void" + } + let x = PGArgument { pgaName = "x", pgaType = "", pgaOptional = False } + it "works for multiple word types" $ do + test "function f(x double precision) returns void" r { + pgfArguments = [ x { pgaType = "double precision" } ] + } + it "works for types with precisions" $ do - (parsePGFunction "function f(x bit) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "bit" False] (PGSingle "void")) + test "function f(x bit) returns void" r { + pgfArguments = [ x { pgaType = "bit" } ] + } - (parsePGFunction "function f(x bit (32)) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "bit" False] (PGSingle "void")) + test "function f(x bit (32)) returns void" r { + pgfArguments = [ x { pgaType = "bit" } ] + } it "works for types with precisions and multiple words" $ do - (parsePGFunction "function f(x character varying) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "character varying" False] (PGSingle "void")) - (parsePGFunction "function f(x character varying (256)) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "character varying" False] (PGSingle "void")) + test "function f(x character varying) returns void" r { + pgfArguments = [ x { pgaType = "character varying" } ] + } + test "function f(x character varying (256)) returns void" r { + pgfArguments = [ x { pgaType = "character varying" } ] + } + it "works for types with multiple precisions" $ do - (parsePGFunction "function f(x numeric) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "numeric" False] (PGSingle "void")) + test "function f(x numeric) returns void" r { + pgfArguments = [ x { pgaType = "numeric" } ] + } - (parsePGFunction "function f(x numeric(10)) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "numeric" False] (PGSingle "void")) + test "function f(x numeric(10)) returns void" r { + pgfArguments = [ x { pgaType = "numeric" } ] + } - (parsePGFunction "function f(x numeric(10,3)) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "numeric" False] (PGSingle "void")) + test "function f(x numeric(10,3)) returns void" r { + pgfArguments = [ x { pgaType = "numeric" } ] + } - (parsePGFunction "function f(x user_defined_type(1,2,3,4)) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "user_defined_type" False] (PGSingle "void")) + test "function f(x user_defined_type(1,2,3,4)) returns void" r { + pgfArguments = [ x { pgaType = "user_defined_type" } ] + } it "works for time types" $ do - (parsePGFunction "function f(x time) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "time" False] (PGSingle "void")) + test "function f(x time) returns void" r { + pgfArguments = [ x { pgaType = "time" } ] + } - (parsePGFunction "function f(x time (6)) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "time" False] (PGSingle "void")) + test "function f(x time (6)) returns void" r { + pgfArguments = [ x { pgaType = "time" } ] + } - (parsePGFunction "function f(x time (6) with time zone) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "time with time zone" False] (PGSingle "void")) + test "function f(x time (6) with time zone) returns void" r { + pgfArguments = [ x { pgaType = "time with time zone" } ] + } - (parsePGFunction "function f(x time with time zone) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "time with time zone" False] (PGSingle "void")) + test "function f(x time with time zone) returns void" r { + pgfArguments = [ x { pgaType = "time with time zone" } ] + } - (parsePGFunction "function f(x time without time zone) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "time without time zone" False] (PGSingle "void")) + test "function f(x time without time zone) returns void" r { + pgfArguments = [ x { pgaType = "time without time zone" } ] + } - (parsePGFunction "function f(x timestamp with time zone) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "timestamp with time zone" False] (PGSingle "void")) + test "function f(x timestamp with time zone) returns void" r { + pgfArguments = [ x { pgaType = "timestamp with time zone" } ] + } - (parsePGFunction "function f(x timestamptz) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "timestamptz" False] (PGSingle "void")) + test "function f(x timestamptz) returns void" r { + pgfArguments = [ x { pgaType = "timestamptz" } ] + } it "works for intervals" $ do - (parsePGFunction "function f(x interval) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "interval" False] (PGSingle "void")) + test "function f(x interval) returns void" r { + pgfArguments = [ x { pgaType = "interval" } ] + } - (parsePGFunction "function f(x interval month) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "interval month" False] (PGSingle "void")) + test "function f(x interval month) returns void" r { + pgfArguments = [ x { pgaType = "interval month" } ] + } - (parsePGFunction "function f(x interval minute to second (4)) returns void") >>= shouldBe - (PGFunction "" "f" [PGArgument "x" "interval minute to second" False] (PGSingle "void")) + test "function f(x interval minute to second (4)) returns void" r { + pgfArguments = [ x { pgaType = "interval minute to second" } ] + }