postgresql-simple-bind 0.3.0.0 → 0.4.0

raw patch · 7 files changed

+443/−248 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−0
• examples/Main.hs +1/−7
• postgresql-simple-bind.cabal +28/−42
• src/Database/PostgreSQL/Simple/Bind/Common.hs +17/−3
• src/Database/PostgreSQL/Simple/Bind/Implementation.hs +160/−92
• src/Database/PostgreSQL/Simple/Bind/Representation.hs +50/−33
• tests/Main.hs +149/−71

@@ -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+

@@ -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+

@@ -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 <zohl@fmap.me>--- 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

@@ -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.

@@ -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] 

@@ -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+

@@ -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" } ]+        }