1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
{-# LANGUAGE
FlexibleInstances,
TemplateHaskell #-}
module Inspection.Boilerplate where
import Control.Applicative (liftA2)
import Language.Haskell.TH
import Generic.Data
{- Example output this generates (modulo reordering):
eqEmptyR, eqEmptyS, eqEmptyG :: Empty a -> Empty a -> Bool
eqEmptyR = \_ _ -> True
eqEmptyS = (==)
eqEmptyG = geq
-}
class AppendQ q where
($++) :: q -> DecsQ -> DecsQ
infixr 2 $++
instance AppendQ (Q Dec) where
($++) = liftA2 (:)
instance AppendQ (Q [Dec]) where
($++) = liftA2 (++)
instance AppendQ q => AppendQ [q] where
ps $++ qs = foldr ($++) qs ps
type Top = Name -> ExpQ -> DecsQ
mk_ :: String -> Maybe Name -> Name -> (TypeQ -> TypeQ) -> Top
mk_ bname fname_ gname ty_ tname ref = do
nameR <- newName (bname ++ nameBase tname ++ "R") -- Reference
nameS <- newName (bname ++ nameBase tname ++ "S") -- Stock
nameG <- newName (bname ++ nameBase tname ++ "G") -- Generic
let ty = ty_ (conT tname)
stock = case fname_ of
Nothing -> pure []
Just fname ->
sigD nameS ty
$++ funD' nameS (varE fname)
$++ pure []
( sigD nameR ty
$++ sigD nameG ty
$++ funD' nameR ref
$++ funD' nameG (varE gname)
$++ stock
$++ pure [] )
funD' :: Name -> ExpQ -> DecQ
funD' name body = funD name [clause [] (normalB body) []]
--
newVar :: String -> Q TypeQ
newVar x = varT <$> newName x
-- Eq and Ord
-- Sometimes there isn't an Eq constraint on the parameter.
mk_eq_ :: (TypeQ -> TypeQ) -> Top
mk_eq_ = mk_ "eq" (Just '(==)) 'geq
mk_eq :: Top
mk_eq = mk_eq_ ty where
ty f = do
a <- newVar "a"
[t| Eq $a => $f $a -> $f $a -> Bool |]
mk_eq' :: Top
mk_eq' = mk_eq_ ty where
ty f = do
a <- newVar "a"
[t| $f $a -> $f $a -> Bool |]
-- Sometimes there isn't an Ord constraint on the parameter.
mk_compare_ :: (TypeQ -> TypeQ) -> Top
mk_compare_ = mk_ "compare" (Just 'compare) 'gcompare
mk_compare :: Top
mk_compare = mk_compare_ ty where
ty f = do
a <- newVar "a"
[t| Ord $a => $f $a -> $f $a -> Ordering |]
mk_compare' :: Top
mk_compare' = mk_compare_ ty where
ty f = do
a <- newVar "a"
[t| $f $a -> $f $a -> Ordering |]
-- Functor, Foldable, Traversable
mk_fmap :: Top
mk_fmap = mk_ "fmap" (Just 'fmap) 'gfmap ty where
ty f = do
a <- newVar "a"
b <- newVar "b"
[t| ($a -> $b) -> $f $a -> $f $b |]
mk_foldMap :: Top
mk_foldMap = mk_ "foldMap" (Just 'foldMap) 'gfoldMap ty where
ty f = do
a <- newVar "a"
m <- newVar "m"
[t| Monoid $m => ($a -> $m) -> $f $a -> $m |]
mk_foldr :: Top
mk_foldr = mk_ "foldr" (Just 'foldr) 'gfoldr ty where
ty f = do
a <- newVar "a"
b <- newVar "b"
[t| ($a -> $b -> $b) -> $b -> $f $a -> $b |]
mk_traverse :: Top
mk_traverse = mk_ "traverse" (Just 'traverse) 'gtraverse ty where
ty f = do
a <- newVar "a"
b <- newVar "b"
g <- newVar "g"
[t| Applicative $g => ($a -> $g $b) -> $f $a -> $g ($f $b) |]
mk_sequenceA :: Top
mk_sequenceA = mk_ "sequenceA" (Just 'sequenceA) 'gsequenceA ty where
ty f = do
a <- newVar "a"
g <- newVar "g"
[t| Applicative $g => $f ($g $a) -> $g ($f $a) |]
-- Applicative (no stock deriving)
mk_ap :: Top
mk_ap = mk_ "ap" Nothing 'gap ty where
ty f = do
a <- newVar "a"
b <- newVar "b"
[t| $f ($a -> $b) -> $f $a -> $f $b |]
mk_liftA2 :: Top
mk_liftA2 = mk_ "liftA2" Nothing 'gliftA2 ty where
ty f = do
a <- newVar "a"
b <- newVar "b"
c <- newVar "c"
[t| ($a -> $b -> $c) -> $f $a -> $f $b -> $f $c |]
|
