Skip to content

Commit 083c81f

Browse files
s9gf4ults9gf4ult
committed
buildable with ghc-8.0.1
1 parent d53158e commit 083c81f

File tree

5 files changed

+146
-21
lines changed

5 files changed

+146
-21
lines changed

‎ghc-8.0.1.yaml

Lines changed: 103 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
flags: {}
2+
extra-package-dbs: []
3+
packages:
4+
- '.'
5+
extra-deps:
6+
- MonadRandom-0.4.2.3
7+
- QuickCheck-2.8.2
8+
- StateVar-1.1.0.4
9+
- aeson-0.11.2.0
10+
- ansi-terminal-0.6.2.3
11+
- ansi-wl-pprint-0.6.7.3
12+
- async-2.1.0
13+
- attoparsec-0.13.0.2
14+
- auto-update-0.1.4
15+
- base-orphans-0.5.4
16+
- bifunctors-5.3
17+
- blaze-builder-0.4.0.2
18+
- bytestring-builder-0.10.8.1.0
19+
- case-insensitive-1.2.0.6
20+
- clock-0.7.2
21+
- comonad-5
22+
- conduit-1.2.6.6
23+
- conduit-extra-1.1.13.2
24+
- contravariant-1.4
25+
- cpphs-1.20.1
26+
- data-default-0.7.1.1
27+
- data-default-class-0.1.2.0
28+
- data-default-instances-containers-0.0.1
29+
- data-default-instances-dlist-0.0.1
30+
- data-default-instances-old-locale-0.0.1
31+
- derive-2.5.26
32+
- distributive-0.5.0.2
33+
- dlist-0.7.1.2
34+
- easy-file-0.2.1
35+
- either-4.4.1.1
36+
- exceptions-0.8.2.1
37+
- fail-4.9.0.0
38+
- fast-logger-2.4.6
39+
- file-embed-0.0.10
40+
- free-4.12.4
41+
- hashable-1.2.4.0
42+
- haskell-src-exts-1.17.1
43+
- haskell-src-meta-0.6.0.14
44+
- hreader-1.0.2
45+
- hset-2.2.0
46+
- ieee754-0.7.8
47+
- inflections-0.2.0.1
48+
- lifted-base-0.2.3.6
49+
- mmorph-1.0.6
50+
- monad-control-1.0.1.0
51+
- monad-logger-0.3.19
52+
- monad-loops-0.4.3
53+
- mtl-2.2.1
54+
- network-2.6.2.1
55+
- old-locale-1.0.0.7
56+
- old-time-1.1.0.3
57+
- optparse-applicative-0.12.1.0
58+
- parsec-3.1.11
59+
- polyparse-1.12
60+
- postgresql-libpq-0.9.1.1
61+
- postgresql-simple-0.5.2.1
62+
- prelude-extras-0.4.0.3
63+
- primitive-0.6.1.0
64+
- profunctors-5.2
65+
- quickcheck-assertions-0.2.0
66+
- quickcheck-instances-0.3.12
67+
- random-1.1
68+
- regex-base-0.93.2
69+
- regex-tdfa-1.2.2
70+
- resource-pool-0.2.3.2
71+
- resourcet-1.1.7.4
72+
- safe-0.3.9
73+
- scientific-0.3.4.8
74+
- semigroupoids-5.1
75+
- semigroups-0.18.2
76+
- stm-2.4.4.1
77+
- stm-chans-3.0.0.4
78+
- streaming-commons-0.1.15.5
79+
- syb-0.6
80+
- tagged-0.8.4
81+
- tasty-0.11.0.3
82+
- tasty-hunit-0.9.2
83+
- tasty-quickcheck-0.8.4
84+
- tasty-th-0.1.4
85+
- text-1.2.2.1
86+
- tf-random-0.5
87+
- th-expand-syns-0.4.0.0
88+
- th-lift-0.7.6
89+
- th-lift-instances-0.1.9
90+
- th-orphans-0.13.1
91+
- th-reify-many-0.1.6
92+
- transformers-base-0.4.4
93+
- transformers-compat-0.5.1.4
94+
- type-fun-0.1.1
95+
- unbounded-delays-0.1.0.9
96+
- uniplate-1.6.12
97+
- unix-time-0.3.6
98+
- unordered-containers-0.2.7.1
99+
- uuid-types-1.0.3
100+
- vector-0.11.0.0
101+
- void-0.7.1
102+
- zlib-0.6.1.1
103+
resolver: ghc-8.0.1

‎src/Database/PostgreSQL/Query/TH/Common.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ module Database.PostgreSQL.Query.TH.Common
33
, cArgs
44
, cFieldNames
55
, lookupVNameErr
6+
, dataConstructors
67
) where
78

89
import Prelude
@@ -32,3 +33,15 @@ lookupVNameErr name =
3233
lookupValueName name >>=
3334
maybe (error $ "could not find identifier: " ++ name)
3435
return
36+
37+
38+
dataConstructors :: Info -> [Con]
39+
dataConstructors = \case
40+
TyConI d ->
41+
#if MIN_VERSION_template_haskell(2,11,0)
42+
let DataD _ _ _ _ cs _ = d
43+
#else
44+
let DataD _ _ _ cs _ = d
45+
#endif
46+
in cs
47+
x -> error $ "Expected type constructor, " ++ show x ++ " got"

‎src/Database/PostgreSQL/Query/TH/Entity.hs

Lines changed: 19 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,10 @@ import Language.Haskell.TH
1717
import Language.Haskell.TH.Syntax
1818
import Text.Inflections
1919

20+
#if !MIN_VERSION_base(4,8,0)
21+
import Control.Applicative
22+
#endif
23+
2024
-- | Options for deriving `Entity`
2125
data EntityOptions = EntityOptions
2226
{ eoTableName :: String -> String -- ^ Type name to table name converter
@@ -74,17 +78,26 @@ NOTE: 'toUnderscore' is from package 'inflections' here
7478

7579
deriveEntity :: EntityOptions -> Name -> Q [Dec]
7680
deriveEntity opts tname = do
77-
TyConI (DataD _ _ _ [tcon] _) <- reify tname
81+
tcon <- dataConstructors <$> reify tname >>= \case
82+
[a] -> return a
83+
x -> fail $ "expected exactly 1 data constructor, but " ++ show (length x) ++ " got"
7884
econt <- [t|Entity $(conT tname)|]
7985
ConT entityIdName <- [t|EntityId|]
8086
let tnames = nameBase tname
8187
idname = tnames ++ "Id"
8288
unidname = "get" ++ idname
8389
idtype = ConT (eoIdType opts)
90+
#if MIN_VERSION_template_haskell(2,11,0)
91+
idcon = RecC (mkName idname)
92+
[(mkName unidname, Bang NoSourceUnpackedness NoSourceStrictness, idtype)]
93+
iddec = NewtypeInstD [] entityIdName [ConT tname] Nothing
94+
idcon (map ConT $ eoDeriveClasses opts)
95+
#else
8496
idcon = RecC (mkName idname)
8597
[(mkName unidname, NotStrict, idtype)]
8698
iddec = NewtypeInstD [] entityIdName [ConT tname]
8799
idcon (eoDeriveClasses opts)
100+
#endif
88101
tblName = fromString $ eoTableName opts tnames
89102
fldNames = map (fromString . eoColumnNames opts . nameBase)
90103
$ cFieldNames tcon
@@ -94,7 +107,10 @@ deriveEntity opts tname = do
94107
fldExp <- mapM lift (fldNames :: [FN])
95108
let tbldec = FunD ntableName [Clause [WildP] (NormalB tblExp) []]
96109
flddec = FunD nfieldNames [Clause [WildP] (NormalB $ ListE fldExp) []]
97-
ret = InstanceD [] econt
98-
[ iddec, tbldec, flddec ]
110+
#if MIN_VERSION_template_haskell(2,11,0)
111+
ret = InstanceD Nothing [] econt [ iddec, tbldec, flddec ]
112+
#else
113+
ret = InstanceD [] econt [ iddec, tbldec, flddec ]
114+
#endif
99115
syndec = TySynD (mkName idname) [] (AppT (ConT entityIdName) (ConT tname))
100116
return [ret, syndec]

‎src/Database/PostgreSQL/Query/TH/Enum.hs

Lines changed: 5 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Database.PostgreSQL.Query.TH.Enum
66
) where
77

88
import Data.FileEmbed
9+
import Database.PostgreSQL.Query.TH.Common
910
import Database.PostgreSQL.Simple.FromField
1011
import Database.PostgreSQL.Simple.ToField
1112
import Language.Haskell.TH
@@ -34,22 +35,10 @@ derivePgEnum
3435
-- ^ type to derive instances for
3536
-> DecsQ
3637
derivePgEnum infl typeName = do
37-
info <- reify typeName
38-
case info of
39-
TyConI dec ->
40-
case dec of
41-
DataD _ _ _ constructors _ -> do
42-
tfInstance <- makeToField infl typeName constructors
43-
ffInstance <- makeFromField infl typeName constructors
44-
pure [tfInstance, ffInstance]
45-
node -> error
46-
$ "unsupported constructor type "
47-
++ show node
48-
++ "in makePgEnumExplicit"
49-
node -> error
50-
$ "unsupported type "
51-
++ show node
52-
++ " in makePgEnumExplicit"
38+
constructors <- dataConstructors <$> reify typeName
39+
tfInstance <- makeToField infl typeName constructors
40+
ffInstance <- makeFromField infl typeName constructors
41+
pure [tfInstance, ffInstance]
5342

5443
makeToField :: InflectorFunc
5544
-> Name

‎src/Database/PostgreSQL/Query/TH/Row.hs

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,9 @@ Datatype must have just one constructor with arbitrary count of fields
3939

4040
deriveFromRow :: Name -> Q [Dec]
4141
deriveFromRow t = do
42-
TyConI (DataD _ _ _ [con] _) <- reify t
42+
con <- dataConstructors <$> reify t >>= \case
43+
[a] -> return a
44+
x -> fail $ "expected exactly 1 data constructor, but " ++ show (length x) ++ " got"
4345
cname <- cName con
4446
cargs <- cArgs con
4547
[d|instance FromRow $(return $ ConT t) where
@@ -77,7 +79,9 @@ instance ToRow Entity where
7779

7880
deriveToRow :: Name -> Q [Dec]
7981
deriveToRow t = do
80-
TyConI (DataD _ _ _ [con] _) <- reify t
82+
con <- dataConstructors <$> reify t >>= \case
83+
[a] -> return a
84+
x -> fail $ "expected exactly 1 data constructor, but " ++ show (length x) ++ " got"
8185
cname <- cName con
8286
cargs <- cArgs con
8387
cvars <- sequence

0 commit comments

Comments
 (0)