[project @ 2004-04-06 12:03:05 by simonpj]
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Lib.hs
1 -- TH.Lib contains lots of useful helper functions for
2 -- generating and manipulating Template Haskell terms
3
4 module Language.Haskell.TH.Lib where
5 -- All of the exports from this module should
6 -- be "public" functions. The main module TH
7 -- re-exports them all.
8
9 import Language.Haskell.TH.Syntax
10 import Control.Monad( liftM, liftM2 )
11
12 ----------------------------------------------------------
13 -- Type synonyms
14 ----------------------------------------------------------
15
16 type InfoQ = Q Info
17 type ExpQ = Q Exp
18 type DecQ = Q Dec
19 type ConQ = Q Con
20 type TypeQ = Q Type
21 type CxtQ = Q Cxt
22 type MatchQ = Q Match
23 type ClauseQ = Q Clause
24 type BodyQ = Q Body
25 type StmtQ = Q Stmt
26 type RangeQ = Q Range
27 type StrictTypeQ = Q StrictType
28 type VarStrictTypeQ = Q VarStrictType
29
30 ----------------------------------------------------------
31 -- Lowercase pattern syntax functions
32 ----------------------------------------------------------
33
34 intPrimL :: Integer -> Lit
35 intPrimL = IntPrimL
36 floatPrimL :: Rational -> Lit
37 floatPrimL = FloatPrimL
38 doublePrimL :: Rational -> Lit
39 doublePrimL = DoublePrimL
40 integerL :: Integer -> Lit
41 integerL = IntegerL
42 charL :: Char -> Lit
43 charL = CharL
44 stringL :: String -> Lit
45 stringL = StringL
46 rationalL :: Rational -> Lit
47 rationalL = RationalL
48
49 litP :: Lit -> Pat
50 litP = LitP
51 varP :: Name -> Pat
52 varP = VarP
53 tupP :: [Pat] -> Pat
54 tupP = TupP
55 conP :: Name -> [Pat] -> Pat
56 conP = ConP
57 tildeP :: Pat -> Pat
58 tildeP = TildeP
59 asP :: Name -> Pat -> Pat
60 asP = AsP
61 wildP :: Pat
62 wildP = WildP
63 recP :: Name -> [FieldPat] -> Pat
64 recP = RecP
65 listP :: [Pat] -> Pat
66 listP = ListP
67
68 fieldPat :: Name -> Pat -> (Name, Pat)
69 fieldPat = (,)
70
71
72 -------------------------------------------------------------------------------
73 -- Stmt
74
75 bindS :: Pat -> ExpQ -> StmtQ
76 bindS p e = liftM (BindS p) e
77
78 letS :: [DecQ] -> StmtQ
79 letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
80
81 noBindS :: ExpQ -> StmtQ
82 noBindS e = do { e1 <- e; return (NoBindS e1) }
83
84 parS :: [[StmtQ]] -> StmtQ
85 parS _ = fail "No parallel comprehensions yet"
86
87 -------------------------------------------------------------------------------
88 -- Range
89
90 fromR :: ExpQ -> RangeQ
91 fromR x = do { a <- x; return (FromR a) }
92
93 fromThenR :: ExpQ -> ExpQ -> RangeQ
94 fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
95
96 fromToR :: ExpQ -> ExpQ -> RangeQ
97 fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
98
99 fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
100 fromThenToR x y z = do { a <- x; b <- y; c <- z;
101 return (FromThenToR a b c) }
102 -------------------------------------------------------------------------------
103 -- Body
104
105 normalB :: ExpQ -> BodyQ
106 normalB e = do { e1 <- e; return (NormalB e1) }
107
108 guardedB :: [(ExpQ,ExpQ)] -> BodyQ
109 guardedB ges = do { ges' <- mapM f ges; return (GuardedB ges') }
110 where f (g, e) = do { g' <- g; e' <- e; return (g', e') }
111
112 -------------------------------------------------------------------------------
113 -- Match and Clause
114
115 match :: Pat -> BodyQ -> [DecQ] -> MatchQ
116 match p rhs ds = do { r' <- rhs;
117 ds' <- sequence ds;
118 return (Match p r' ds') }
119
120 clause :: [Pat] -> BodyQ -> [DecQ] -> ClauseQ
121 clause ps r ds = do { r' <- r;
122 ds' <- sequence ds;
123 return (Clause ps r' ds') }
124
125
126 ---------------------------------------------------------------------------
127 -- Exp
128
129 dyn :: String -> Q Exp
130 dyn s = return (VarE (mkName s))
131
132 global :: Name -> ExpQ
133 global s = return (VarE s)
134
135 varE :: Name -> ExpQ
136 varE s = return (VarE s)
137
138 conE :: Name -> ExpQ
139 conE s = return (ConE s)
140
141 litE :: Lit -> ExpQ
142 litE c = return (LitE c)
143
144 appE :: ExpQ -> ExpQ -> ExpQ
145 appE x y = do { a <- x; b <- y; return (AppE a b)}
146
147 infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
148 infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
149 return (InfixE (Just a) s' (Just b))}
150 infixE Nothing s (Just y) = do { s' <- s; b <- y;
151 return (InfixE Nothing s' (Just b))}
152 infixE (Just x) s Nothing = do { a <- x; s' <- s;
153 return (InfixE (Just a) s' Nothing)}
154 infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }
155
156 infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
157 infixApp x y z = infixE (Just x) y (Just z)
158 sectionL :: ExpQ -> ExpQ -> ExpQ
159 sectionL x y = infixE (Just x) y Nothing
160 sectionR :: ExpQ -> ExpQ -> ExpQ
161 sectionR x y = infixE Nothing x (Just y)
162
163 lamE :: [Pat] -> ExpQ -> ExpQ
164 lamE ps e = liftM (LamE ps) e
165
166 lam1E :: Pat -> ExpQ -> ExpQ -- Single-arg lambda
167 lam1E p e = lamE [p] e
168
169 tupE :: [ExpQ] -> ExpQ
170 tupE es = do { es1 <- sequence es; return (TupE es1)}
171
172 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
173 condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
174
175 letE :: [DecQ] -> ExpQ -> ExpQ
176 letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
177
178 caseE :: ExpQ -> [MatchQ] -> ExpQ
179 caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
180
181 doE :: [StmtQ] -> ExpQ
182 doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
183
184 compE :: [StmtQ] -> ExpQ
185 compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
186
187 arithSeqE :: RangeQ -> ExpQ
188 arithSeqE r = do { r' <- r; return (ArithSeqE r') }
189
190 -- arithSeqE Shortcuts
191 fromE :: ExpQ -> ExpQ
192 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
193
194 fromThenE :: ExpQ -> ExpQ -> ExpQ
195 fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
196
197 fromToE :: ExpQ -> ExpQ -> ExpQ
198 fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
199
200 fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
201 fromThenToE x y z = do { a <- x; b <- y; c <- z;
202 return (ArithSeqE (FromThenToR a b c)) }
203 -- End arithSeqE shortcuts
204
205 listE :: [ExpQ] -> ExpQ
206 listE es = do { es1 <- sequence es; return (ListE es1) }
207
208 sigE :: ExpQ -> TypeQ -> ExpQ
209 sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
210
211 recConE :: Name -> [Q (Name,Exp)] -> ExpQ
212 recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
213
214 recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
215 recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
216
217 stringE :: String -> ExpQ
218 stringE = litE . stringL
219
220 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
221 fieldExp s e = do { e' <- e; return (s,e') }
222
223 -------------------------------------------------------------------------------
224 -- Dec
225
226 valD :: Pat -> BodyQ -> [DecQ] -> DecQ
227 valD p b ds =
228 do { ds' <- sequence ds
229 ; b' <- b
230 ; return (ValD p b' ds')
231 }
232
233 funD :: Name -> [ClauseQ] -> DecQ
234 funD nm cs =
235 do { cs1 <- sequence cs
236 ; return (FunD nm cs1)
237 }
238
239 tySynD :: Name -> [Name] -> TypeQ -> DecQ
240 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
241
242 dataD :: CxtQ -> Name -> [Name] -> [ConQ] -> [Name] -> DecQ
243 dataD ctxt tc tvs cons derivs =
244 do
245 ctxt1 <- ctxt
246 cons1 <- sequence cons
247 return (DataD ctxt1 tc tvs cons1 derivs)
248
249 newtypeD :: CxtQ -> Name -> [Name] -> ConQ -> [Name] -> DecQ
250 newtypeD ctxt tc tvs con derivs =
251 do
252 ctxt1 <- ctxt
253 con1 <- con
254 return (NewtypeD ctxt1 tc tvs con1 derivs)
255
256 classD :: CxtQ -> Name -> [Name] -> [DecQ] -> DecQ
257 classD ctxt cls tvs decs =
258 do
259 decs1 <- sequence decs
260 ctxt1 <- ctxt
261 return $ ClassD ctxt1 cls tvs decs1
262
263 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
264 instanceD ctxt ty decs =
265 do
266 ctxt1 <- ctxt
267 decs1 <- sequence decs
268 ty1 <- ty
269 return $ InstanceD ctxt1 ty1 decs1
270
271 sigD :: Name -> TypeQ -> DecQ
272 sigD fun ty = liftM (SigD fun) $ ty
273
274 forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
275 forImpD cc s str n ty
276 = do ty' <- ty
277 return $ ForeignD (ImportF cc s str n ty')
278
279 cxt :: [TypeQ] -> CxtQ
280 cxt = sequence
281
282 normalC :: Name -> [StrictTypeQ] -> ConQ
283 normalC con strtys = liftM (NormalC con) $ sequence strtys
284
285 recC :: Name -> [VarStrictTypeQ] -> ConQ
286 recC con varstrtys = liftM (RecC con) $ sequence varstrtys
287
288 infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ
289 infixC st1 con st2 = do st1' <- st1
290 st2' <- st2
291 return $ InfixC st1' con st2'
292
293
294 -------------------------------------------------------------------------------
295 -- Type
296
297 forallT :: [Name] -> CxtQ -> TypeQ -> TypeQ
298 forallT tvars ctxt ty = do
299 ctxt1 <- ctxt
300 ty1 <- ty
301 return $ ForallT tvars ctxt1 ty1
302
303 varT :: Name -> TypeQ
304 varT = return . VarT
305
306 conT :: Name -> TypeQ
307 conT = return . ConT
308
309 appT :: TypeQ -> TypeQ -> TypeQ
310 appT t1 t2 = do
311 t1' <- t1
312 t2' <- t2
313 return $ AppT t1' t2'
314
315 arrowT :: TypeQ
316 arrowT = return ArrowT
317
318 listT :: TypeQ
319 listT = return ListT
320
321 tupleT :: Int -> TypeQ
322 tupleT i = return (TupleT i)
323
324 isStrict, notStrict :: Q Strict
325 isStrict = return $ IsStrict
326 notStrict = return $ NotStrict
327
328 strictType :: Q Strict -> TypeQ -> StrictTypeQ
329 strictType = liftM2 (,)
330
331 varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
332 varStrictType v st = do (s, t) <- st
333 return (v, s, t)
334
335 -------------------------------------------------------------------------------
336 -- Callconv
337
338 cCall, stdCall :: Callconv
339 cCall = CCall
340 stdCall = StdCall
341
342 -------------------------------------------------------------------------------
343 -- Safety
344
345 unsafe, safe, threadsafe :: Safety
346 unsafe = Unsafe
347 safe = Safe
348 threadsafe = Threadsafe
349
350 --------------------------------------------------------------
351 -- Useful helper functions
352
353 combine :: [([(Name, Name)], Pat)] -> ([(Name, Name)], [Pat])
354 combine pairs = foldr f ([],[]) pairs
355 where f (env,p) (es,ps) = (env++es,p:ps)
356
357 rename :: Pat -> Q ([(Name, Name)], Pat)
358 rename (LitP c) = return([],LitP c)
359 rename (VarP s) = do { s1 <- newName (nameBase s); return([(s,s1)],VarP s1) }
360 rename (TupP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
361 where g (es,ps) = return (es,TupP ps)
362 rename (ConP nm pats) = do { pairs <- mapM rename pats; g(combine pairs) }
363 where g (es,ps) = return (es,ConP nm ps)
364 rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) }
365 rename (AsP s p) =
366 do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) }
367 rename WildP = return([],WildP)
368 rename (RecP nm fs) = do { pairs <- mapM rename ps; g(combine pairs) }
369 where g (env,ps') = return (env,RecP nm (zip ss ps'))
370 (ss,ps) = unzip fs
371 rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
372 where g (es,ps) = return (es,ListP ps)
373
374 genpat :: Pat -> Q ((Name -> ExpQ), Pat)
375 genpat p = do { (env,p2) <- rename p; return (alpha env,p2) }
376
377 alpha :: [(Name, Name)] -> Name -> ExpQ
378 alpha env s = case lookup s env of
379 Just x -> varE x
380 Nothing -> varE s
381
382 appsE :: [ExpQ] -> ExpQ
383 appsE [] = error "appsExp []"
384 appsE [x] = x
385 appsE (x:y:zs) = appsE ( (appE x y) : zs )
386
387 simpleMatch :: Pat -> Exp -> Match
388 simpleMatch p e = Match p (NormalB e) []
389