6bd5aecee1eac941e59b85ef5f90f3da3c5be276
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Syntax.hs
1 {-# OPTIONS -fglasgow-exts #-}
2 -- Need GlaExts for the nested forall in defn of Q
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Language.Haskell.Syntax
6 -- Copyright : (c) The University of Glasgow 2003
7 -- License : BSD-style (see the file libraries/base/LICENSE)
8 --
9 -- Maintainer : libraries@haskell.org
10 -- Stability : experimental
11 -- Portability : portable
12 --
13 -- Abstract syntax definitions for Template Haskell.
14 --
15 -----------------------------------------------------------------------------
16
17 module Language.Haskell.TH.Syntax(
18 Quasi(..), Lift(..),
19
20 Q, runQ,
21 report, recover, reify,
22 currentModule, runIO,
23
24 -- Names
25 Name(..), mkName, newName, nameBase,
26
27 -- The algebraic data types
28 Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..),
29 Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
30 Lit(..), Pat(..), FieldExp, FieldPat,
31 Strict(..), Foreign(..), Callconv(..), Safety(..),
32 StrictType, VarStrictType,
33 Info(..),
34 Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
35
36 -- Internal functions
37 returnQ, bindQ, sequenceQ,
38 NameFlavour(..), NameSpace (..),
39 mkNameG_v, mkNameG_d, mkNameG_tc, mkNameU,
40 tupleTypeName, tupleDataName,
41 OccName, mkOccName, occString,
42 ModName, mkModName, modString
43 ) where
44
45 import Data.PackedString
46 import GHC.Base ( Int(..), Int#, (<#), (==#) )
47
48 import IO ( hPutStrLn, stderr )
49 import Data.IORef
50 import GHC.IOBase ( unsafePerformIO )
51 import Control.Monad (liftM)
52
53 -----------------------------------------------------
54 --
55 -- The Quasi class
56 --
57 -----------------------------------------------------
58
59 class Monad m => Quasi m where
60 -- Fresh names
61 qNewName :: String -> m Name
62
63 -- Error reporting and recovery
64 qReport :: Bool -> String -> m () -- Report an error (True) or warning (False)
65 -- ...but carry on; use 'fail' to stop
66 qRecover :: m a -> m a -> m a -- Recover from the monadic 'fail'
67 -- The first arg is the error handler
68
69 -- Inspect the type-checker's environment
70 qReify :: Name -> m Info
71 qCurrentModule :: m String
72
73 -- Input/output (dangerous)
74 qRunIO :: IO a -> m a
75
76
77 -----------------------------------------------------
78 -- The IO instance of Quasi
79 --
80 -- This instance is used only when running a Q
81 -- computation in the IO monad, usually just to
82 -- print the result. There is no interesting
83 -- type environment, so reification isn't going to
84 -- work.
85 --
86 -----------------------------------------------------
87
88 instance Quasi IO where
89 qNewName s = do { n <- readIORef counter
90 ; writeIORef counter (n+1)
91 ; return (mkNameU s n) }
92
93 qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
94 qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
95
96 qReify v = badIO "reify"
97 qCurrentModule = badIO "currentModule"
98 qRecover a b = badIO "recover" -- Maybe we could fix this?
99
100 qRunIO m = m
101
102 badIO :: String -> IO a
103 badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
104 ; fail "Template Haskell failure" }
105
106 -- Global variable to generate unique symbols
107 counter :: IORef Int
108 {-# NOINLINE counter #-}
109 counter = unsafePerformIO (newIORef 0)
110
111
112 -----------------------------------------------------
113 --
114 -- The Q monad
115 --
116 -----------------------------------------------------
117
118 newtype Q a = Q { unQ :: forall m. Quasi m => m a }
119
120 runQ :: Quasi m => Q a -> m a
121 runQ (Q m) = m
122
123 instance Monad Q where
124 return x = Q (return x)
125 Q m >>= k = Q (m >>= \x -> unQ (k x))
126 Q m >> Q n = Q (m >> n)
127 fail s = Q (fail s)
128
129 ----------------------------------------------------
130 -- Packaged versions for the programmer, hiding the Quasi-ness
131 newName :: String -> Q Name
132 newName s = Q (qNewName s)
133
134 report :: Bool -> String -> Q ()
135 report b s = Q (qReport b s)
136
137 recover :: Q a -> Q a -> Q a
138 recover (Q r) (Q m) = Q (qRecover r m)
139
140 reify :: Name -> Q Info
141 reify v = Q (qReify v)
142
143 currentModule :: Q String
144 currentModule = Q qCurrentModule
145
146 runIO :: IO a -> Q a
147 runIO m = Q (qRunIO m)
148
149 instance Quasi Q where
150 qNewName = newName
151 qReport = report
152 qRecover = recover
153 qReify = reify
154 qCurrentModule = currentModule
155 qRunIO = runIO
156
157
158 ----------------------------------------------------
159 -- The following operations are used solely in DsMeta when desugaring brackets
160 -- They aren't necessary for the user, who can use ordinary return and (>>=) etc
161
162 returnQ :: a -> Q a
163 returnQ = return
164
165 bindQ :: Q a -> (a -> Q b) -> Q b
166 bindQ = (>>=)
167
168 sequenceQ :: [Q a] -> Q [a]
169 sequenceQ = sequence
170
171
172 -----------------------------------------------------
173 --
174 -- The Lift class
175 --
176 -----------------------------------------------------
177
178 class Lift t where
179 lift :: t -> Q Exp
180
181 instance Lift Integer where
182 lift x = return (LitE (IntegerL x))
183
184 instance Lift Int where
185 lift x= return (LitE (IntegerL (fromIntegral x)))
186
187 instance Lift Char where
188 lift x = return (LitE (CharL x))
189
190 instance Lift Bool where
191 lift True = return (ConE trueName)
192 lift False = return (ConE falseName)
193
194 instance Lift a => Lift [a] where
195 lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
196
197 instance (Lift a, Lift b) => Lift (a, b) where
198 lift (a, b)
199 = liftM TupE $ sequence [lift a, lift b]
200
201 instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
202 lift (a, b, c)
203 = liftM TupE $ sequence [lift a, lift b, lift c]
204
205 instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
206 lift (a, b, c, d)
207 = liftM TupE $ sequence [lift a, lift b, lift c, lift d]
208
209 instance (Lift a, Lift b, Lift c, Lift d, Lift e)
210 => Lift (a, b, c, d, e) where
211 lift (a, b, c, d, e)
212 = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
213
214 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
215 => Lift (a, b, c, d, e, f) where
216 lift (a, b, c, d, e, f)
217 = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
218
219 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
220 => Lift (a, b, c, d, e, f, g) where
221 lift (a, b, c, d, e, f, g)
222 = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
223
224 -- TH has a special form for literal strings,
225 -- which we should take advantage of.
226 -- NB: the lhs of the rule has no args, so that
227 -- the rule will apply to a 'lift' all on its own
228 -- which happens to be the way the type checker
229 -- creates it.
230 {-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}
231
232
233 trueName, falseName :: Name
234 trueName = mkNameG DataName "GHC.Base" "True"
235 falseName = mkNameG DataName "GHC.Base" "False"
236
237
238 -----------------------------------------------------
239 -- Names and uniques
240 -----------------------------------------------------
241
242 type ModName = PackedString -- Module name
243
244 mkModName :: String -> ModName
245 mkModName s = packString s
246
247 modString :: ModName -> String
248 modString m = unpackPS m
249
250
251 -----------------------------------------------------
252 -- OccName
253 -----------------------------------------------------
254
255 type OccName = PackedString
256
257 mkOccName :: String -> OccName
258 mkOccName s = packString s
259
260 occString :: OccName -> String
261 occString occ = unpackPS occ
262
263
264 -----------------------------------------------------
265 -- Names
266 -----------------------------------------------------
267
268 -- For "global" names (NameG) we need a totally unique name,
269 -- so we must include the name-space of the thing
270 --
271 -- For unique-numbered things (NameU), we've got a unique reference
272 -- anyway, so no need for name space
273 --
274 -- For dynamically bound thing (NameS) we probably want them to
275 -- in a context-dependent way, so again we don't want the name
276 -- space. For example:
277 -- let v = mkName "T" in [| data $v = $v |]
278 -- Here we use the same Name for both type constructor and data constructor
279
280 data Name = Name OccName NameFlavour
281
282 data NameFlavour
283 = NameS -- Just a string; dynamically bound
284 | NameU Int# -- A unique local name
285 | NameG NameSpace ModName -- An original name (occurrences only, not binders)
286 -- Need the namespace too to be sure which
287 -- thing we are naming
288
289 data NameSpace = VarName -- Variables
290 | DataName -- Data constructors
291 | TcClsName -- Type constructors and classes; Haskell has them
292 -- in the same name space for now.
293 deriving( Eq, Ord )
294
295 type Uniq = Int
296
297 nameBase :: Name -> String
298 nameBase (Name occ _) = occString occ
299
300 mkName :: String -> Name
301 mkName s = Name (mkOccName s) NameS
302
303 mkNameU :: String -> Uniq -> Name -- Only used internally
304 mkNameU s (I# u) = Name (mkOccName s) (NameU u)
305
306 mkNameG :: NameSpace -> String -> String -> Name -- Used for 'x etc, but not available
307 mkNameG ns mod occ -- to the programmer
308 = Name (mkOccName occ) (NameG ns (mkModName mod))
309
310 mkNameG_v = mkNameG VarName
311 mkNameG_tc = mkNameG TcClsName
312 mkNameG_d = mkNameG DataName
313
314 instance Eq Name where
315 v1 == v2 = cmpEq (v1 `compare` v2)
316
317 instance Ord Name where
318 (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp`
319 (o1 `compare` o2)
320
321 instance Eq NameFlavour where
322 f1 == f2 = cmpEq (f1 `compare` f2)
323
324 instance Ord NameFlavour where
325 NameS `compare` NameS = EQ
326 NameS `compare` other = LT
327
328 (NameU _) `compare` NameS = GT
329 (NameU u1) `compare` (NameU u2) | u1 <# u2 = LT
330 | u1 ==# u2 = EQ
331 | otherwise = GT
332 (NameU _) `compare` other = LT
333
334 (NameG ns1 m1) `compare` (NameG ns2 m2) = (ns1 `compare` ns2) `thenCmp`
335 (m1 `compare` m2)
336 (NameG _ _) `compare` other = GT
337
338 instance Show Name where
339 show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u)
340 show (Name occ NameS) = occString occ
341 show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ
342
343
344 -- Tuple data and type constructors
345 tupleDataName :: Int -> Name -- Data constructor
346 tupleTypeName :: Int -> Name -- Type constructor
347
348 tupleDataName 0 = mk_tup_name 0 DataName
349 tupleDataName 1 = error "tupleDataName 1"
350 tupleDataName n = mk_tup_name (n-1) DataName
351
352 tupleTypeName 0 = mk_tup_name 0 TcClsName
353 tupleTypeName 1 = error "tupleTypeName 1"
354 tupleTypeName n = mk_tup_name (n-1) TcClsName
355
356 mk_tup_name n_commas space
357 = Name occ (NameG space tup_mod)
358 where
359 occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
360 tup_mod = mkModName "GHC.Tuple"
361
362
363 -----------------------------------------------------
364 --
365 -- The Info returned by reification
366 --
367 -----------------------------------------------------
368
369 data Info
370 = ClassI Dec
371 | ClassOpI
372 Name -- The class op itself
373 Type -- Type of the class-op (fully polymoprhic)
374 Name -- Name of the parent class
375 Fixity
376
377 | TyConI Dec
378 | DataConI
379 Name -- The data con itself
380 Type -- Type of the constructor (fully polymorphic)
381 Name -- Name of the parent TyCon
382 Fixity
383
384 | VarI
385 Name -- The variable itself
386 Type
387 (Maybe Dec) -- Nothing for lambda-bound variables, and
388 -- for anything else TH can't figure out
389 -- E.g. [| let x = 1 in $(do { d <- reify 'x; .. }) |]
390 Fixity
391
392 | TyVarI -- Scoped type variable
393 Name
394 Type -- What it is bound to
395
396 data Fixity = Fixity Int FixityDirection deriving( Eq )
397 data FixityDirection = InfixL | InfixR | InfixN deriving( Eq )
398
399 maxPrecedence = (9::Int)
400 defaultFixity = Fixity maxPrecedence InfixL
401
402
403 -----------------------------------------------------
404 --
405 -- The main syntax data types
406 --
407 -----------------------------------------------------
408
409 data Lit = CharL Char
410 | StringL String
411 | IntegerL Integer -- Used for overloaded and non-overloaded
412 -- literals. We don't have a good way to
413 -- represent non-overloaded literals at
414 -- the moment. Maybe that doesn't matter?
415 | RationalL Rational -- Ditto
416 | IntPrimL Integer
417 | FloatPrimL Rational
418 | DoublePrimL Rational
419 deriving( Show, Eq )
420
421 -- We could add Int, Float, Double etc, as we do in HsLit,
422 -- but that could complicate the
423 -- suppposedly-simple TH.Syntax literal type
424
425 data Pat
426 = LitP Lit -- { 5 or 'c' }
427 | VarP Name -- { x }
428 | TupP [Pat] -- { (p1,p2) }
429 | ConP Name [Pat] -- data T1 = C1 t1 t2; {C1 p1 p1} = e
430 | InfixP Pat Name Pat -- foo ({x :+ y}) = e
431 | TildeP Pat -- { ~p }
432 | AsP Name Pat -- { x @ p }
433 | WildP -- { _ }
434 | RecP Name [FieldPat] -- f (Pt { pointx = x }) = g x
435 | ListP [ Pat ] -- { [1,2,3] }
436 | SigP Pat Type -- p :: t
437 deriving( Show, Eq )
438
439 type FieldPat = (Name,Pat)
440
441 data Match = Match Pat Body [Dec]
442 -- case e of { pat -> body where decs }
443 deriving( Show, Eq )
444 data Clause = Clause [Pat] Body [Dec]
445 -- f { p1 p2 = body where decs }
446 deriving( Show, Eq )
447
448 data Exp
449 = VarE Name -- { x }
450 | ConE Name -- data T1 = C1 t1 t2; p = {C1} e1 e2
451 | LitE Lit -- { 5 or 'c'}
452 | AppE Exp Exp -- { f x }
453
454 | InfixE (Maybe Exp) Exp (Maybe Exp) -- {x + y} or {(x+)} or {(+ x)} or {(+)}
455 -- It's a bit gruesome to use an Exp as the
456 -- operator, but how else can we distinguish
457 -- constructors from non-constructors?
458 -- Maybe there should be a var-or-con type?
459 -- Or maybe we should leave it to the String itself?
460
461 | LamE [Pat] Exp -- { \ p1 p2 -> e }
462 | TupE [Exp] -- { (e1,e2) }
463 | CondE Exp Exp Exp -- { if e1 then e2 else e3 }
464 | LetE [Dec] Exp -- { let x=e1; y=e2 in e3 }
465 | CaseE Exp [Match] -- { case e of m1; m2 }
466 | DoE [Stmt] -- { do { p <- e1; e2 } }
467 | CompE [Stmt] -- { [ (x,y) | x <- xs, y <- ys ] }
468 | ArithSeqE Range -- { [ 1 ,2 .. 10 ] }
469 | ListE [ Exp ] -- { [1,2,3] }
470 | SigE Exp Type -- e :: t
471 | RecConE Name [FieldExp] -- { T { x = y, z = w } }
472 | RecUpdE Exp [FieldExp] -- { (f x) { z = w } }
473 deriving( Show, Eq )
474
475 type FieldExp = (Name,Exp)
476
477 -- Omitted: implicit parameters
478
479 data Body
480 = GuardedB [(Guard,Exp)] -- f p { | e1 = e2 | e3 = e4 } where ds
481 | NormalB Exp -- f p { = e } where ds
482 deriving( Show, Eq )
483
484 data Guard
485 = NormalG Exp
486 | PatG [Stmt]
487 deriving( Show, Eq )
488
489 data Stmt
490 = BindS Pat Exp
491 | LetS [ Dec ]
492 | NoBindS Exp
493 | ParS [[Stmt]]
494 deriving( Show, Eq )
495
496 data Range = FromR Exp | FromThenR Exp Exp
497 | FromToR Exp Exp | FromThenToR Exp Exp Exp
498 deriving( Show, Eq )
499
500 data Dec
501 = FunD Name [Clause] -- { f p1 p2 = b where decs }
502 | ValD Pat Body [Dec] -- { p = b where decs }
503 | DataD Cxt Name [Name]
504 [Con] [Name] -- { data Cxt x => T x = A x | B (T x)
505 -- deriving (Z,W)}
506 | NewtypeD Cxt Name [Name]
507 Con [Name] -- { newtype Cxt x => T x = A (B x)
508 -- deriving (Z,W)}
509 | TySynD Name [Name] Type -- { type T x = (x,x) }
510 | ClassD Cxt Name [Name] [Dec] -- { class Eq a => Ord a where ds }
511 | InstanceD Cxt Type [Dec] -- { instance Show w => Show [w]
512 -- where ds }
513 | SigD Name Type -- { length :: [a] -> Int }
514 | ForeignD Foreign
515 deriving( Show, Eq )
516
517 data Foreign = ImportF Callconv Safety String Name Type
518 | ExportF Callconv String Name Type
519 deriving( Show, Eq )
520
521 data Callconv = CCall | StdCall
522 deriving( Show, Eq )
523
524 data Safety = Unsafe | Safe | Threadsafe
525 deriving( Show, Eq )
526
527 type Cxt = [Type] -- (Eq a, Ord b)
528
529 data Strict = IsStrict | NotStrict
530 deriving( Show, Eq )
531
532 data Con = NormalC Name [StrictType]
533 | RecC Name [VarStrictType]
534 | InfixC StrictType Name StrictType
535 | ForallC [Name] Cxt Con
536 deriving( Show, Eq )
537
538 type StrictType = (Strict, Type)
539 type VarStrictType = (Name, Strict, Type)
540
541 data Module = Module [ Dec ]
542 deriving( Show, Eq )
543
544 -- FIXME: Why this special status for "List" (even tuples might be handled
545 -- differently)? -=chak
546 data Type = ForallT [Name] Cxt Type -- forall <vars>. <ctxt> -> <type>
547 | VarT Name -- a
548 | ConT Name -- T
549 | TupleT Int -- (,), (,,), etc.
550 | ArrowT -- ->
551 | ListT -- []
552 | AppT Type Type -- T a b
553 deriving( Show, Eq )
554
555 -----------------------------------------------------
556 -- Internal helper functions
557 -----------------------------------------------------
558
559 cmpEq :: Ordering -> Bool
560 cmpEq EQ = True
561 cmpEq _ = False
562
563 thenCmp :: Ordering -> Ordering -> Ordering
564 thenCmp EQ o2 = o2
565 thenCmp o1 o2 = o1
566