Skip to content

Commit a3c2562

Browse files
zohlzohl
committed
refactored implementation
1 parent 461b638 commit a3c2562

7 files changed

Lines changed: 231 additions & 192 deletions

File tree

‎default.nix‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,14 @@
11
{ mkDerivation, attoparsec, base, bytestring, case-conversion
2-
, data-default, heredoc, hspec, postgresql-simple, stdenv
3-
, template-haskell, text, time
2+
, data-default, exceptions, heredoc, hspec, postgresql-simple
3+
, stdenv, template-haskell, text, time
44
}:
55
mkDerivation {
66
pname = "postgresql-simple-bind";
77
version = "0.1.0.0";
88
src = ./.;
99
libraryHaskellDepends = [
10-
attoparsec base bytestring heredoc postgresql-simple
11-
template-haskell text time
10+
attoparsec base bytestring data-default exceptions heredoc
11+
postgresql-simple template-haskell text time
1212
];
1313
testHaskellDepends = [
1414
attoparsec base bytestring case-conversion data-default hspec

‎postgresql-simple-bind.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ library
2626
, attoparsec >= 0.13.0 && < 0.14
2727
, bytestring >= 0.10.8 && < 0.11
2828
, data-default
29+
, exceptions
2930
, heredoc >= 0.2.0 && < 0.3
3031
, postgresql-simple >= 0.5.2 && < 0.6
3132
, template-haskell >= 2.11.0 && < 2.12

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module Database.PostgreSQL.Simple.Bind (
1919
bindFunction
2020

2121
, PostgresBindOptions(..)
22+
, PostgresBindException(..)
2223
, PostgresType
2324

2425
, PGFunction(..)
@@ -29,6 +30,5 @@ module Database.PostgreSQL.Simple.Bind (
2930

3031

3132
import Database.PostgreSQL.Simple.Bind.Implementation
32-
import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGColumn(..), PGResult(..))
33+
import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGColumn(..), PGResult(..), PostgresBindException(..))
3334
import Database.PostgreSQL.Simple.Bind.Common (PostgresBindOptions(..))
34-

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

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,6 @@ module Database.PostgreSQL.Simple.Bind.Common (
3030
, PostgresBindOptions(..)
3131
) where
3232

33-
3433
import Data.Default (Default, def)
3534
import Database.PostgreSQL.Simple (Only(..))
3635
import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..))

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

Lines changed: 79 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,9 @@
2020
License: GPL3
2121
Maintainer: Al Zohali <zohl@fmap.me>
2222
Stability: experimental
23+
24+
TH functions that generate bindings. Examples are provided as
25+
pseudo-code snippets.
2326
-}
2427

2528

@@ -28,72 +31,73 @@ module Database.PostgreSQL.Simple.Bind.Implementation (
2831
, PostgresType
2932
) where
3033

34+
import Control.Exception (throw)
3135
import Data.List (intersperse)
36+
import Data.Maybe (catMaybes, maybeToList)
3237
import Data.Text (Text)
33-
import Database.PostgreSQL.Simple
34-
import Database.PostgreSQL.Simple.Bind.Representation
38+
import Database.PostgreSQL.Simple (Connection, query, query_)
39+
import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGResult(..), PGColumn(..))
40+
import Database.PostgreSQL.Simple.Bind.Representation (parsePGFunction, PostgresBindException(..))
3541
import Database.PostgreSQL.Simple.Bind.Common (unwrapRow, unwrapColumn, PostgresBindOptions(..))
3642
import Database.PostgreSQL.Simple.FromField (FromField)
37-
import Database.PostgreSQL.Simple.ToField
38-
import Database.PostgreSQL.Simple.Types
39-
import GHC.TypeLits
40-
import Language.Haskell.TH.Syntax
43+
import Database.PostgreSQL.Simple.ToField (ToField(..))
44+
import Database.PostgreSQL.Simple.Types (Query(..))
45+
import GHC.TypeLits (Symbol)
46+
import Language.Haskell.TH.Syntax (Q, Dec(..), Exp(..), Type(..), Clause(..), Body(..), Pat(..))
47+
import Language.Haskell.TH.Syntax (Name, mkName, newName, Lit(..), TyLit(..), TyVarBndr(..))
4148
import qualified Data.ByteString.Char8 as BS
4249

43-
4450
-- | Mapping from PostgreSQL types to Haskell types.
4551
type family PostgresType (a :: Symbol)
4652

47-
4853
-- | Function that constructs binding for PostgreSQL stored function by it's signature.
4954
bindFunction :: PostgresBindOptions -> Text -> Q [Dec]
50-
bindFunction opt = (mkFunction opt) . parsePGFunction
51-
55+
bindFunction opt s = parsePGFunction s >>= mkFunction opt
5256

57+
mkFunction :: PostgresBindOptions -> PGFunction -> Q [Dec]
58+
mkFunction opt f = sequence $ (($ f) . ($ opt)) <$> [mkFunctionT, mkFunctionE]
5359

5460
data Argument = forall a . (ToField a) => MandatoryArg String a
5561
| forall a . (ToField a) => OptionalArg String (Maybe a)
5662

5763
instance ToField Argument where
58-
toField (MandatoryArg _ x) = toField x
59-
toField (OptionalArg _ (Just x)) = toField x
60-
toField (OptionalArg _ Nothing) = error "OptionalArg::toField: encountered Nothing"
61-
62-
63-
formatArgument :: Argument -> String
64-
formatArgument (MandatoryArg _name _) = "?"
65-
formatArgument (OptionalArg name (Just _)) = name ++ " := ?"
66-
formatArgument (OptionalArg _ Nothing) = error "TODO"
64+
toField (MandatoryArg _ x) = toField x
65+
toField (OptionalArg _ (Just x)) = toField x
66+
toField (OptionalArg name Nothing) = throw . DefaultValueNotFound $ name
6767

68+
formatArgument :: Argument -> Maybe String
69+
formatArgument (MandatoryArg _name _value) = Just "?"
70+
formatArgument (OptionalArg name (Just _value)) = Just $ name ++ " := ?"
71+
formatArgument (OptionalArg _name Nothing) = Nothing
6872

6973
formatArguments :: [Argument] -> String
70-
formatArguments = concat . (intersperse ",") . (map formatArgument)
71-
72-
73-
isActual :: Argument -> Bool
74-
isActual (OptionalArg _ Nothing) = False
75-
isActual _ = True
74+
formatArguments = concat . (intersperse ",") . catMaybes . (map formatArgument)
7675

7776
filterArguments :: [Argument] -> [Argument]
78-
filterArguments = filter isActual
79-
80-
77+
filterArguments = filter isPresented where
78+
isPresented :: Argument -> Bool
79+
isPresented (OptionalArg _name Nothing) = False
80+
isPresented _ = True
8181

8282

83-
mkFunction :: PostgresBindOptions -> PGFunction -> Q [Dec]
84-
mkFunction opt f = sequence $ (($ f) . ($ opt)) <$> [mkFunctionT, mkFunctionE]
85-
83+
-- | Example: "varchar" -> PostgresType "varchar"
8684
postgresT :: String -> Type
8785
postgresT t = AppT (ConT ''PostgresType) (LitT (StrTyLit t))
8886

87+
-- | Example: "varchar" FromField a -> [PostgresType "varchar" ~ a, FromField a]
8988
mkContextT :: Name -> String -> Name -> [Type]
9089
mkContextT c t n = [
9190
EqualityT `AppT` (postgresT t) `AppT` (VarT n)
9291
, (ConT c) `AppT` (VarT n)] where
9392

94-
93+
-- | Examples:
94+
-- (PGSingle "varchar") -> (["y"], [PostgresType "varchar" ~ y, FromField y], y)
95+
-- (PGSetOf "varchar") -> (["y"], [PostgresType "varchar" ~ y, FromField y], [y])
96+
-- (PGTable ["bigint", "varchar"]) -> (
97+
-- ["y", "z"]
98+
-- , [PostgresType "bigint" ~ y, FromField y, PostgresType "varchar" ~ z, FromField z]
99+
-- , (y, z))
95100
mkResultT :: PGResult -> Q ([Name], [Type], Type)
96-
97101
mkResultT (PGSingle t) = do
98102
name <- newName "y"
99103
return ([name], mkContextT ''FromField t name, VarT name)
@@ -108,7 +112,10 @@ mkResultT (PGTable cs) = do
108112
let clause = AppT ListT $ foldl AppT (TupleT (length cs)) $ map VarT names
109113
return (names, context, clause)
110114

111-
115+
-- | Example: [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] -> (
116+
-- ["x1", "x2"]
117+
-- , [PostgresType "varchar" ~ x1, ToField x1, PostgresType "bigint" ~ x2, ToField x2]
118+
-- , [x1, Maybe x2])
112119
mkArgsT :: [PGArgument] -> Q ([Name], [Type], [Type])
113120
mkArgsT cs = do
114121
names <- sequence $ replicate (length cs) (newName "x")
@@ -121,7 +128,12 @@ mkArgsT cs = do
121128
let clause = zipWith (\(PGArgument _ _ d) -> (defWrap d) . VarT) cs names
122129
return (names, context, clause)
123130

124-
131+
-- | Example: (PGFunction "public" "foo"
132+
-- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) -> {
133+
-- foo :: forall x1 x2 x3. (
134+
-- PostgresType "varchar" ~ x1, ToField x1
135+
-- , PostgresType "bigint" ~ x2, ToField x2
136+
-- , PostgresType "varchar" ~ x2, FromField x3) => Connection -> x1 -> Maybe x2 -> x3}
125137
mkFunctionT :: PostgresBindOptions -> PGFunction -> Q Dec
126138
mkFunctionT (PostgresBindOptions {..}) f@(PGFunction _schema _name args ret) = do
127139
(argNames, argContext, argClause) <- mkArgsT args
@@ -136,12 +148,15 @@ mkFunctionT (PostgresBindOptions {..}) f@(PGFunction _schema _name args ret) = d
136148
return $ SigD (mkName $ pboFunctionName f) $ ForallT vars context clause
137149

138150

139-
140-
mkSqlQuery :: PGFunction -> Name -> Exp
141-
mkSqlQuery (PGFunction schema name _args ret) argsName = toQuery $ foldr1 AppE [
142-
(AppE (VarE '(++)) (mkStrLit $ concat [prefix, " ", functionName, "("]))
143-
, (AppE (VarE '(++)) ((VarE 'formatArguments) `AppE` (VarE argsName)))
144-
, (mkStrLit ")")] where
151+
-- | Example:
152+
-- (PGFunction "public" "foo"
153+
-- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar"))
154+
-- args -> { Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"] }
155+
mkSqlQuery :: PGFunction -> Maybe Name -> Exp
156+
mkSqlQuery (PGFunction schema name _args ret) argsName = toQuery $ AppE (VarE 'concat) $ ListE [
157+
mkStrLit $ concat [prefix, " ", functionName, "("]
158+
, maybe (mkStrLit "") (\args -> (VarE 'formatArguments) `AppE` (VarE args)) argsName
159+
, mkStrLit ")"] where
145160

146161
prefix = case ret of
147162
PGTable _ -> "select * from"
@@ -152,39 +167,44 @@ mkSqlQuery (PGFunction schema name _args ret) argsName = toQuery $ foldr1 AppE [
152167
_ -> schema ++ "." ++ name
153168

154169
mkStrLit s = LitE (StringL s)
155-
156170
toQuery = AppE (ConE 'Query) . AppE (VarE 'BS.pack)
157171

158-
159-
172+
-- | Examples:
173+
-- (PGSingle _) q -> { unwrapRow q }
174+
-- (PGSetOf _) q -> { unwrapColumn q }
175+
-- (PGTable _) q -> { q }
160176
unwrapE :: PGResult -> Exp -> Exp
161177
unwrapE (PGSingle _) q = (VarE 'fmap) `AppE` (VarE 'unwrapRow) `AppE` q
162178
unwrapE (PGSetOf _) q = (VarE 'fmap) `AppE` (VarE 'unwrapColumn) `AppE` q
163179
unwrapE (PGTable _) q = q
164180

165-
181+
-- | Example: (PGFunction "public" "foo"
182+
-- [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) -> {
183+
-- foo conn x1 x2 = query conn
184+
-- (Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"])
185+
-- (filterArguments [MandatoryArg "x1" x1, OptionalArg "x2" x2])
166186
mkFunctionE :: PostgresBindOptions -> PGFunction -> Q Dec
167187
mkFunctionE (PostgresBindOptions {..}) f@(PGFunction _schema _name args ret) = do
168188
names <- sequence $ replicate (length args) (newName "x")
169-
170189
connName <- newName "conn"
171-
argsName <- newName "args"
172-
173-
let funcName = mkName $ pboFunctionName f
174-
175-
let funcArgs = (VarP connName):(map VarP names)
176190

177-
let funcBody = NormalB $ unwrapE ret $ foldl1 AppE [
178-
(VarE 'query)
179-
, (VarE connName)
180-
, (mkSqlQuery f argsName)
181-
, (VarE argsName)]
191+
argsName <- case (null args) of
192+
True -> return Nothing
193+
False -> Just <$> newName "args"
182194

183195
let wrapArg (PGArgument n _ d) argName = foldl1 AppE $ case d of
184196
False -> [(ConE 'MandatoryArg), (LitE (StringL n)), (VarE argName)]
185197
True -> [(ConE 'OptionalArg), (LitE (StringL n)), (VarE argName)]
186198

187-
let argsBody = NormalB $ (VarE 'filterArguments) `AppE` (ListE $ zipWith wrapArg args names)
188-
189-
return $ FunD funcName [Clause funcArgs funcBody [ValD (VarP argsName) argsBody []]]
199+
let argsExpr = (VarE 'filterArguments) `AppE` (ListE $ zipWith wrapArg args names)
190200

201+
let funcName = mkName $ pboFunctionName f
202+
let funcArgs = (VarP connName):(map VarP names)
203+
let funcBody = NormalB $ unwrapE ret $ foldl1 AppE $ [
204+
VarE $ maybe 'query_ (const 'query) argsName
205+
, VarE connName
206+
, mkSqlQuery f argsName
207+
] ++ (const argsExpr <$> maybeToList argsName)
208+
209+
let decl = (\name -> ValD (VarP name) (NormalB argsExpr) []) <$> maybeToList argsName
210+
return $ FunD funcName [Clause funcArgs funcBody decl]

0 commit comments

Comments
 (0)