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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
Fix compatibility with Template Haskell 2.18 and GHC 9.2.
diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs
index 10d0426cd..d68bc7d5b 100644
--- a/src/Ganeti/BasicTypes.hs
+++ b/src/Ganeti/BasicTypes.hs
@@ -206,12 +206,12 @@ instance MonadTrans (ResultT a) where
instance (MonadIO m, Error a) => MonadIO (ResultT a m) where
liftIO = ResultT . liftIO
. liftM (either (failError . show) return)
- . (try :: IO a -> IO (Either IOError a))
+ . (try :: IO α -> IO (Either IOError α))
instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where
liftBase = ResultT . liftBase
. liftM (either (failError . show) return)
- . (try :: IO a -> IO (Either IOError a))
+ . (try :: IO α -> IO (Either IOError α))
instance (Error a) => MonadTransControl (ResultT a) where
#if MIN_VERSION_monad_control(1,0,0)
diff --git a/src/Ganeti/Lens.hs b/src/Ganeti/Lens.hs
index faa5900ed..747366e6a 100644
--- a/src/Ganeti/Lens.hs
+++ b/src/Ganeti/Lens.hs
@@ -93,14 +93,14 @@ makeCustomLenses' name lst = makeCustomLensesFiltered f name
-- Most often the @g@ functor is @(,) r@ and 'traverseOf2' is used to
-- traverse an effectful computation that also returns an additional output
-- value.
-traverseOf2 :: Over (->) (Compose f g) s t a b
- -> (a -> f (g b)) -> s -> f (g t)
+-- traverseOf2 :: Over (->) (Compose f g) s t a b
+-- -> (a -> f (g b)) -> s -> f (g t)
traverseOf2 k f = getCompose . traverseOf k (Compose . f)
-- | Traverses over a composition of a monad and a functor.
-- See 'traverseOf2'.
-mapMOf2 :: Over (->) (Compose (WrappedMonad m) g) s t a b
- -> (a -> m (g b)) -> s -> m (g t)
+-- mapMOf2 :: Over (->) (Compose (WrappedMonad m) g) s t a b
+-- -> (a -> m (g b)) -> s -> m (g t)
mapMOf2 k f = unwrapMonad . traverseOf2 k (WrapMonad . f)
-- | A helper lens over sets.
diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
index 9ab93d5e3..9a10a9a07 100644
--- a/src/Ganeti/THH.hs
+++ b/src/Ganeti/THH.hs
@@ -996,8 +996,8 @@ buildAccessor fnm fpfx rnm rpfx nm pfx field = do
f_body = AppE (VarE fpfx_name) $ VarE x
return $ [ SigD pfx_name $ ArrowT `AppT` ConT nm `AppT` ftype
, FunD pfx_name
- [ Clause [ConP rnm [VarP x]] (NormalB r_body) []
- , Clause [ConP fnm [VarP x]] (NormalB f_body) []
+ [ Clause [myConP rnm [VarP x]] (NormalB r_body) []
+ , Clause [myConP fnm [VarP x]] (NormalB f_body) []
]]
-- | Build lense declartions for a field.
@@ -1037,10 +1037,10 @@ buildLens (fnm, fdnm) (rnm, rdnm) nm pfx ar (field, i) = do
(ConE cdn)
$ zip [0..] vars
let setterE = LamE [VarP context, VarP var] $ CaseE (VarE context)
- [ Match (ConP fnm [ConP fdnm . set (element i) WildP
+ [ Match (myConP fnm [myConP fdnm . set (element i) WildP
$ map VarP vars])
(body (not isSimple) fnm fdnm) []
- , Match (ConP rnm [ConP rdnm . set (element i) WildP
+ , Match (myConP rnm [myConP rdnm . set (element i) WildP
$ map VarP vars])
(body False rnm rdnm) []
]
@@ -1098,9 +1098,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
$ JSON.showJSON $(varE x) |]
let rdjson = FunD 'JSON.readJSON [Clause [] (NormalB read_body) []]
shjson = FunD 'JSON.showJSON
- [ Clause [ConP (mkName real_nm) [VarP x]]
+ [ Clause [myConP (mkName real_nm) [VarP x]]
(NormalB show_real_body) []
- , Clause [ConP (mkName forth_nm) [VarP x]]
+ , Clause [myConP (mkName forth_nm) [VarP x]]
(NormalB show_forth_body) []
]
instJSONdecl = gntInstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
@@ -1121,9 +1121,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
(fromDictWKeys $(varE xs)) |]
todictx_r <- [| toDict $(varE x) |]
todictx_f <- [| ("forthcoming", JSON.JSBool True) : toDict $(varE x) |]
- let todict = FunD 'toDict [ Clause [ConP (mkName real_nm) [VarP x]]
+ let todict = FunD 'toDict [ Clause [myConP (mkName real_nm) [VarP x]]
(NormalB todictx_r) []
- , Clause [ConP (mkName forth_nm) [VarP x]]
+ , Clause [myConP (mkName forth_nm) [VarP x]]
(NormalB todictx_f) []
]
fromdict = FunD 'fromDictWKeys [ Clause [VarP xs]
@@ -1136,9 +1136,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
let forthPredDecls = [ SigD forthPredName
$ ArrowT `AppT` ConT name `AppT` ConT ''Bool
, FunD forthPredName
- [ Clause [ConP (mkName real_nm) [WildP]]
+ [ Clause [myConP (mkName real_nm) [WildP]]
(NormalB $ ConE 'False) []
- , Clause [ConP (mkName forth_nm) [WildP]]
+ , Clause [myConP (mkName forth_nm) [WildP]]
(NormalB $ ConE 'True) []
]
]
@@ -1412,9 +1412,9 @@ savePParamField fvar field = do
normalexpr <- saveObjectField actualVal field
-- we have to construct the block here manually, because we can't
-- splice-in-splice
- return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
+ return $ CaseE (VarE fvar) [ Match (myConP 'Nothing [])
(NormalB (ConE '[])) []
- , Match (ConP 'Just [VarP actualVal])
+ , Match (myConP 'Just [VarP actualVal])
(NormalB normalexpr) []
]
@@ -1440,9 +1440,9 @@ fillParam sname field_pfx fields = do
-- due to apparent bugs in some older GHC versions, we need to add these
-- prefixes to avoid "binding shadows ..." errors
fbinds <- mapM (newName . ("f_" ++) . nameBase) fnames
- let fConP = ConP name_f (map VarP fbinds)
+ let fConP = myConP name_f (map VarP fbinds)
pbinds <- mapM (newName . ("p_" ++) . nameBase) pnames
- let pConP = ConP name_p (map VarP pbinds)
+ let pConP = myConP name_p (map VarP pbinds)
-- PartialParams instance --------
-- fillParams
let fromMaybeExp fn pn = AppE (AppE (VarE 'fromMaybe) (VarE fn)) (VarE pn)
@@ -1462,7 +1462,7 @@ fillParam sname field_pfx fields = do
memptyClause = Clause [] (NormalB memptyExp) []
-- mappend
pbinds2 <- mapM (newName . ("p2_" ++) . nameBase) pnames
- let pConP2 = ConP name_p (map VarP pbinds2)
+ let pConP2 = myConP name_p (map VarP pbinds2)
-- note the reversal of 'l' and 'r' in the call to <|>
-- as we want the result to be the rightmost value
let altExp = zipWith (\l r -> AppE (AppE (VarE '(<|>)) (VarE r)) (VarE l))
@@ -1575,9 +1575,9 @@ genLoadExc tname sname opdefs = do
opdefs
-- the first function clause; we can't use [| |] due to TH
-- limitations, so we have to build the AST by hand
- let clause1 = Clause [ConP 'JSON.JSArray
- [ListP [ConP 'JSON.JSString [VarP exc_name],
- VarP exc_args]]]
+ let clause1 = Clause [myConP 'JSON.JSArray
+ [ListP [myConP 'JSON.JSString [VarP exc_name],
+ VarP exc_args]]]
(NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
(VarE exc_name))
(str_matches ++ [defmatch]))) []
diff --git a/src/Ganeti/THH/Compat.hs b/src/Ganeti/THH/Compat.hs
index 1f51e49d7..9b07c47ef 100644
--- a/src/Ganeti/THH/Compat.hs
+++ b/src/Ganeti/THH/Compat.hs
@@ -41,6 +41,7 @@ module Ganeti.THH.Compat
, myNotStrict
, nonUnaryTupE
, mkDoE
+ , myConP
) where
import Language.Haskell.TH
@@ -129,3 +130,11 @@ mkDoE s =
#else
DoE s
#endif
+
+-- | ConP is now qualified with an optional [Type].
+myConP :: Name -> [Pat] -> Pat
+myConP n patterns = ConP n
+#if MIN_VERSION_template_haskell(2,18,0)
+ []
+#endif
+ patterns
|
