moved older-call-syntax flag to options

Author: zohl

CHANGELOG.md

@@ -4,6 +4,8 @@
 ### Added
 - Changelog.
 - Explicit type casts options.
+### Changed
+- Flag `older-call-syntax` is an option now.
 
 ## [0.3.0] - 2016-10-29
 ### Added

postgresql-simple-bind.cabal

@@ -24,12 +24,6 @@ flag db-tests
   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.
   manual:      False
@@ -69,9 +63,6 @@ library
   else
     ghc-options:      -O2 -Wall
 
-  if flag(older-call-syntax)
-    cpp-options: -DOlderCallSyntax
-
   if flag(debug-queries)
     cpp-options: -DDebugQueries
 

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
@@ -48,8 +49,11 @@ data PostgresBindOptions = PostgresBindOptions {
     -- ^ Which columns in returned tables can be null.
   , pboSetOfReturnType :: String -> ReturnType
     -- ^ How to process type in "setof" clause.
-  , pboExplicitCasts :: Bool
+  , 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.
   }
 
 instance Default PostgresBindOptions where
@@ -58,6 +62,7 @@ instance Default PostgresBindOptions where
     , pboIsNullable      = \_fname _column -> False
     , pboSetOfReturnType = \_tname -> AsField
     , pboExplicitCasts   = True
+    , pboOlderCallSyntax = True
     }
 
 -- | Remove 'Only' constructor.

src/Database/PostgreSQL/Simple/Bind/Implementation.hs

@@ -52,7 +52,7 @@ import Database.PostgreSQL.Simple.FromRow (FromRow(..))
 import Database.PostgreSQL.Simple.Types (Query(..))
 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(..), lift)
+import Language.Haskell.TH.Syntax (Name, mkName, newName, Lit(..), TyLit(..), TyVarBndr(..))
 import qualified Data.ByteString.Char8 as BS
 
 -- | Mapping from PostgreSQL types to Haskell types.
@@ -83,28 +83,28 @@ instance ToField Argument where
   toField (OptionalArg   name _atype Nothing)  = throw . DefaultValueNotFound $ name
 
 
-callExpression :: String
-#ifdef OlderCallSyntax
-callExpression = " := "
-#else
-callExpression = " => "
-#endif
+untypedPlaceholder, typedPlaceholder :: String -> String
+untypedPlaceholder = const "?"
+typedPlaceholder atype = "(?)::" ++ atype
+
 
-formatArgument :: Bool -> Argument -> Maybe String
-formatArgument cast = format where
+formatArgument :: String -> (String -> String) -> Argument -> Maybe String
+formatArgument callSyntax placeholder = format where
   format = \case
     (MandatoryArg _name atype _value) -> Just $ placeholder atype
 
     (OptionalArg name atype (Just _value)) -> Just . concat $ [
-        name , callExpression, placeholder atype]
+        name, callSyntax, placeholder atype]
 
     (OptionalArg _name _atype Nothing) -> Nothing
 
-  placeholder atype = if cast then ("(?)::" ++ atype) else "?"
 
+formatArguments :: String -> (String -> String) -> [Argument] -> String
+formatArguments callSyntax placeholder = concat
+  . (intersperse ",")
+  . catMaybes
+  . (map $ formatArgument callSyntax placeholder)
 
-formatArguments :: Bool -> [Argument] -> String
-formatArguments cast = concat . (intersperse ",") . catMaybes . (map $ formatArgument cast)
 
 filterArguments :: [Argument] -> [Argument]
 filterArguments = filter isPresented where
@@ -204,17 +204,17 @@ traceIdWrapE = id
 --     (PGFunction "public" "foo"
 --       [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar"))
 --     args -> { Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"] }
-mkSqlQuery :: PostgresBindOptions -> PGFunction -> Maybe Name -> Q Exp
+mkSqlQuery :: PostgresBindOptions -> PGFunction -> Maybe Name -> Exp
 mkSqlQuery opt (PGFunction schema fname _args ret) argsName =
-  lift (pboExplicitCasts opt) >>= \cast ->
-    return . toQuery . traceIdWrapE . AppE (VarE 'concat) . ListE $ [
-        mkStrLit $ concat [prefix opt, " ", functionName, "("]
-      , maybe (mkStrLit "") (\args -> foldl1 AppE [
-          VarE 'formatArguments
-        , cast
-        , VarE args
-        ]) argsName
-      , mkStrLit ")"] where
+  toQuery . traceIdWrapE . AppE (VarE 'concat) . ListE $ [
+      mkStrLit $ concat [prefix opt, " ", functionName, "("]
+    , maybe (mkStrLit "") (\args -> foldl1 AppE [
+        VarE 'formatArguments
+      , mkStrLit $ if (pboOlderCallSyntax opt) then " := " else " => "
+      , VarE $ if (pboExplicitCasts opt) then 'typedPlaceholder else 'untypedPlaceholder
+      , VarE args
+      ]) argsName
+    , mkStrLit ")"] where
 
   prefix (PostgresBindOptions {..}) = case ret of
     PGTable _     -> mkSelect AsRow
@@ -274,11 +274,10 @@ mkFunctionE opt@(PostgresBindOptions {..}) f@(PGFunction _schema _fname args ret
 
   let funcName = mkName $ pboFunctionName f
   let funcArgs = (VarP connName):(map VarP names)
-  sqlQuery <- mkSqlQuery opt f argsName
   let funcBody = NormalB $ unwrapE opt ret $ foldl1 AppE $ [
           VarE $ maybe 'query_ (const 'query) argsName
         , VarE connName
-        , sqlQuery
+        , mkSqlQuery opt f argsName
         ] ++ (const (traceShowIdWrapE argsExpr) <$> maybeToList argsName)
 
   let decl = (\name -> ValD (VarP name) (NormalB argsExpr) []) <$> maybeToList argsName