Skip to content

Commit 3e5528a

Browse files
zohlzohl
committed
moved debug queries flag to options
1 parent 5beb212 commit 3e5528a

6 files changed

Lines changed: 84 additions & 65 deletions

File tree

‎CHANGELOG.md‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55
- Changelog.
66
- Explicit type casts options.
77
### Changed
8-
- Flag `older-call-syntax` is an option now.
8+
- Flags `older-call-syntax` and `debug-queries` are options now.
99

1010
## [0.3.0] - 2016-10-29
1111
### Added

‎examples/Common.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ bindOptions = (def :: PostgresBindOptions) {
2727
"t_user" -> AsRow
2828
_ -> AsField
2929
, pboIsNullable = isNullable
30+
, pboDebugQueries = True
3031
} where
3132
isNullable :: String -> String -> Bool
3233
isNullable "get_new_messages" "contents" = True

‎postgresql-simple-bind.cabal‎

Lines changed: 1 addition & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -24,11 +24,6 @@ flag build-examples
2424
manual: False
2525
default: False
2626

27-
flag debug-queries
28-
description: Turn on output of executed queries.
29-
manual: False
30-
default: False
31-
3227
source-repository head
3328
type: git
3429
location: https://github.com/zohl/postgresql-simple-bind.git
@@ -63,9 +58,6 @@ library
6358
else
6459
ghc-options: -O2 -Wall
6560

66-
if flag(debug-queries)
67-
cpp-options: -DDebugQueries
68-
6961
test-suite tests
7062
type: exitcode-stdio-1.0
7163

@@ -96,7 +88,7 @@ test-suite examples
9688
main-is: Main.hs
9789
default-language: Haskell2010
9890

99-
ghc-options: -Wall -Wno-redundant-constraints
91+
ghc-options: -Wall -Wno-redundant-constraints -ddump-splices
10092

10193
if flag(build-examples)
10294
build-depends: base >= 4.7 && < 5.0

‎src/Database/PostgreSQL/Simple/Bind/Common.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,8 @@ data PostgresBindOptions = PostgresBindOptions {
5454
, pboOlderCallSyntax :: Bool
5555
-- ^ Whether to use old-style call syntax (:=) instead of (=>). This is
5656
-- necessary for PostgreSQL < 9.5.
57+
, pboDebugQueries :: Bool
58+
-- ^ Whether to print executed queries and their arguments.
5759
}
5860

5961
instance Default PostgresBindOptions where
@@ -63,6 +65,7 @@ instance Default PostgresBindOptions where
6365
, pboSetOfReturnType = \_tname -> AsField
6466
, pboExplicitCasts = True
6567
, pboOlderCallSyntax = True
68+
, pboDebugQueries = False
6669
}
6770

6871
-- | Remove 'Only' constructor.

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

Lines changed: 75 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@
1313
{-# LANGUAGE ScopedTypeVariables #-}
1414
{-# LANGUAGE FlexibleInstances #-}
1515
{-# LANGUAGE RecordWildCards #-}
16-
{-# LANGUAGE CPP #-}
1716
{-# LANGUAGE LambdaCase #-}
1817

1918
{-|
@@ -34,13 +33,9 @@ module Database.PostgreSQL.Simple.Bind.Implementation (
3433
) where
3534

3635
import Control.Exception (throw)
37-
38-
#ifdef DebugQueries
39-
import Debug.Trace (traceId, traceShowId)
40-
#endif
41-
36+
import Debug.Trace (traceIO)
4237
import Data.List (intersperse)
43-
import Data.Maybe (catMaybes, maybeToList)
38+
import Data.Maybe (catMaybes)
4439
import Data.Text (Text)
4540
import Database.PostgreSQL.Simple (Connection, query, query_)
4641
import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGResult(..), PGColumn(..))
@@ -53,8 +48,10 @@ import Database.PostgreSQL.Simple.Types (Query(..))
5348
import GHC.TypeLits (Symbol)
5449
import Language.Haskell.TH.Syntax (Q, Dec(..), Exp(..), Type(..), Clause(..), Body(..), Pat(..))
5550
import Language.Haskell.TH.Syntax (Name, mkName, newName, Lit(..), TyLit(..), TyVarBndr(..))
51+
import Language.Haskell.TH.Syntax (Stmt(..))
5652
import qualified Data.ByteString.Char8 as BS
5753

54+
5855
-- | Mapping from PostgreSQL types to Haskell types.
5956
type family PostgresType (a :: Symbol)
6057

@@ -65,23 +62,36 @@ bindFunction opt s = parsePGFunction s >>= mkFunction opt
6562
mkFunction :: PostgresBindOptions -> PGFunction -> Q [Dec]
6663
mkFunction opt f = sequence $ (($ f) . ($ opt)) <$> [mkFunctionT, mkFunctionE]
6764

68-
#ifdef DebugQueries
69-
data Argument = forall a . (Show a, ToField a) => MandatoryArg String String a
70-
| forall a . (Show a, ToField a) => OptionalArg String String (Maybe a)
7165

72-
instance Show Argument where
73-
show (MandatoryArg name atype value) = "mandatory: " ++ name ++ " => " ++ show value ++ "::" ++ atype
74-
show (OptionalArg name atype value) = "optional: " ++ name ++ " => " ++ show value ++ "::" ++ atype
75-
#else
76-
data Argument = forall a . (ToField a) => MandatoryArg String String a
77-
| forall a . (ToField a) => OptionalArg String String (Maybe a)
78-
#endif
66+
data Argument
67+
= forall a . (ToField a) => MandatoryArg {
68+
argName :: String
69+
, argType :: String
70+
, argRepresentation :: Maybe String
71+
, margValue :: a
72+
}
73+
| forall a . (ToField a) => OptionalArg {
74+
argName :: String
75+
, argType :: String
76+
, argRepresentation :: Maybe String
77+
, morgValue :: Maybe a
78+
}
7979

8080
instance ToField Argument where
81-
toField (MandatoryArg _name _atype x) = toField x
82-
toField (OptionalArg _name _atype (Just x)) = toField x
83-
toField (OptionalArg name _atype Nothing) = throw . DefaultValueNotFound $ name
81+
toField MandatoryArg {..} = toField margValue
82+
toField OptionalArg {..} = maybe
83+
(throw . DefaultValueNotFound $ argName)
84+
toField
85+
morgValue
8486

87+
instance Show Argument where
88+
show arg = concat $ [
89+
argName arg
90+
, " => "
91+
, maybe (throw . RepresentationNotFound $ argName arg) id (argRepresentation arg)
92+
, " :: "
93+
, argType arg
94+
]
8595

8696
untypedPlaceholder, typedPlaceholder :: String -> String
8797
untypedPlaceholder = const "?"
@@ -91,26 +101,24 @@ typedPlaceholder atype = "(?)::" ++ atype
91101
formatArgument :: String -> (String -> String) -> Argument -> Maybe String
92102
formatArgument callSyntax placeholder = format where
93103
format = \case
94-
(MandatoryArg _name atype _value) -> Just $ placeholder atype
95-
96-
(OptionalArg name atype (Just _value)) -> Just . concat $ [
97-
name, callSyntax, placeholder atype]
98-
99-
(OptionalArg _name _atype Nothing) -> Nothing
104+
MandatoryArg {..} -> Just $ placeholder argType
105+
OptionalArg {..} -> fmap
106+
(const . concat $ [argName, callSyntax, placeholder argType])
107+
morgValue
100108

101109

102110
formatArguments :: String -> (String -> String) -> [Argument] -> String
103111
formatArguments callSyntax placeholder = concat
104-
. (intersperse ",")
112+
. (intersperse ", ")
105113
. catMaybes
106114
. (map $ formatArgument callSyntax placeholder)
107115

108116

109117
filterArguments :: [Argument] -> [Argument]
110118
filterArguments = filter isPresented where
111119
isPresented :: Argument -> Bool
112-
isPresented (OptionalArg _name _atype Nothing) = False
113-
isPresented _ = True
120+
isPresented (OptionalArg {..}) = maybe False (const True) $ morgValue
121+
isPresented _ = True
114122

115123

116124
-- | Example: "varchar" -> PostgresType "varchar"
@@ -193,20 +201,13 @@ mkFunctionT opt@(PostgresBindOptions {..}) f@(PGFunction _schema fname args ret)
193201
return $ SigD (mkName $ pboFunctionName f) $ ForallT vars context clause
194202

195203

196-
traceIdWrapE :: Exp -> Exp
197-
#ifdef DebugQueries
198-
traceIdWrapE q = (VarE 'traceId) `AppE` q
199-
#else
200-
traceIdWrapE = id
201-
#endif
202-
203204
-- | Example:
204205
-- (PGFunction "public" "foo"
205206
-- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar"))
206207
-- args -> { Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"] }
207208
mkSqlQuery :: PostgresBindOptions -> PGFunction -> Maybe Name -> Exp
208209
mkSqlQuery opt (PGFunction schema fname _args ret) argsName =
209-
toQuery . traceIdWrapE . AppE (VarE 'concat) . ListE $ [
210+
toQuery . AppE (VarE 'concat) . ListE $ [
210211
mkStrLit $ concat [prefix opt, " ", functionName, "("]
211212
, maybe (mkStrLit "") (\args -> foldl1 AppE [
212213
VarE 'formatArguments
@@ -245,12 +246,17 @@ unwrapE _ (PGSingle _) q = (VarE 'fmap) `AppE` (VarE 'unwrapRow) `AppE` q
245246
unwrapE opt (PGSetOf tname) q = unwrapE' (pboSetOfReturnType opt tname) q
246247
unwrapE _ (PGTable _) q = unwrapE' AsRow q
247248

248-
traceShowIdWrapE :: Exp -> Exp
249-
#ifdef DebugQueries
250-
traceShowIdWrapE q = (VarE 'traceShowId) `AppE` q
251-
#else
252-
traceShowIdWrapE = id
253-
#endif
249+
250+
wrapArg :: PostgresBindOptions -> PGArgument -> Name -> Exp
251+
wrapArg (PostgresBindOptions {..}) (PGArgument n t d) argName = foldl1 AppE $ [
252+
ConE $ if d then 'OptionalArg else 'MandatoryArg
253+
, LitE $ StringL n
254+
, LitE $ StringL t
255+
, if pboDebugQueries
256+
then foldr1 AppE [ConE 'Just, VarE 'show, VarE argName]
257+
else ConE 'Nothing
258+
, VarE argName]
259+
254260

255261
-- | Example: (PGFunction "public" "foo"
256262
-- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) -> {
@@ -266,20 +272,34 @@ mkFunctionE opt@(PostgresBindOptions {..}) f@(PGFunction _schema _fname args ret
266272
True -> return Nothing
267273
False -> Just <$> newName "args"
268274

269-
let wrapArg (PGArgument n t d) argName = foldl1 AppE $ case d of
270-
False -> [ConE 'MandatoryArg, LitE (StringL n), LitE (StringL t), VarE argName]
271-
True -> [ConE 'OptionalArg, LitE (StringL n), LitE (StringL t), VarE argName]
275+
let argsExpr = (VarE 'filterArguments) `AppE` (ListE $ zipWith (wrapArg opt) args names)
272276

273-
let argsExpr = (VarE 'filterArguments) `AppE` (ListE $ zipWith wrapArg args names)
277+
sqlQueryName <- newName "sqlQuery"
278+
let sqlQueryExpr = mkSqlQuery opt f argsName
274279

275280
let funcName = mkName $ pboFunctionName f
276281
let funcArgs = (VarP connName):(map VarP names)
277-
let funcBody = NormalB $ unwrapE opt ret $ foldl1 AppE $ [
278-
VarE $ maybe 'query_ (const 'query) argsName
279-
, VarE connName
280-
, mkSqlQuery opt f argsName
281-
] ++ (const (traceShowIdWrapE argsExpr) <$> maybeToList argsName)
282-
283-
let decl = (\name -> ValD (VarP name) (NormalB argsExpr) []) <$> maybeToList argsName
284-
return $ FunD funcName [Clause funcArgs funcBody decl]
282+
283+
let funcBody = NormalB $ if pboDebugQueries
284+
then DoE $ NoBindS <$> [traceQuery, traceArgs, execQuery]
285+
else execQuery
286+
where
287+
traceQuery = foldr1 AppE [VarE 'traceIO, VarE 'show, VarE sqlQueryName]
288+
289+
traceArgs = foldr1 AppE . maybe
290+
[VarE 'traceIO, LitE $ StringL "no arguments"]
291+
(\name -> [VarE 'traceIO, VarE 'show, VarE name])
292+
$ argsName
293+
294+
execQuery = unwrapE opt ret $ foldl1 AppE $ [
295+
VarE $ maybe 'query_ (const 'query) argsName
296+
, VarE connName
297+
, sqlQueryExpr
298+
] ++ (maybe [] (return . VarE) argsName)
299+
300+
let funcDecl = [
301+
ValD (VarP sqlQueryName) (NormalB sqlQueryExpr) []
302+
] ++ (maybe [] (\name -> return $ ValD (VarP name) (NormalB argsExpr) []) argsName)
303+
304+
return $ FunD funcName [Clause funcArgs funcBody funcDecl]
285305

‎src/Database/PostgreSQL/Simple/Bind/Representation.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,9 @@ data PostgresBindException
5050
| DefaultValueNotFound String
5151
-- ^ Thrown when 'Argument' expected to have default value while
5252
-- it doesn't. Actually this should never happen, but we all know...
53+
| RepresentationNotFound String
54+
-- ^ Thrown when 'Argument' is beign printed, but representation was't
55+
-- provided. Again, this should never happen.
5356
deriving (Eq, Show, Typeable)
5457

5558
instance Exception PostgresBindException

0 commit comments

Comments
 (0)