DsMeta.hs 42.2 KB
Newer Older
1
2
3
4
5
-----------------------------------------------------------------------------
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
6
7
8
9
10
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
-- in prelude/PrelNames.  It's much more convenient to do it here, becuase
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
11
12
13
-----------------------------------------------------------------------------


14
module DsMeta( dsBracket, dsReify,
15
	       templateHaskellNames, qTyConName, 
16
17
	       liftName, exprTyConName, declTyConName,
	       decTyConName, typTyConName ) where
18
19
20
21
22
23
24
25
26
27
28
29
30

#include "HsVersions.h"

import {-# SOURCE #-}	DsExpr ( dsExpr )

import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup,
		    mkIntExpr, mkCharExpr )
import DsMonad

import qualified Language.Haskell.THSyntax as M

import HsSyn  	  ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
		    Match(..), GRHSs(..), GRHS(..), HsBracket(..),
31
                    HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
32
		    HsBinds(..), MonoBinds(..), HsConDetails(..),
33
		    TyClDecl(..), HsGroup(..),
34
		    HsReify(..), ReifyFlavour(..), 
35
36
37
38
		    HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
	 	    HsTyVarBndr(..), Sig(..), ForeignDecl(..),
		    InstDecl(..), ConDecl(..), BangType(..),
		    PendingSplice, splitHsInstDeclTy,
39
		    placeHolderType, tyClDeclNames,
40
		    collectHsBinders, collectPatBinders, collectPatsBinders,
41
42
		    hsTyVarName, hsConArgs, getBangType,
		    toHsType
43
44
		  )

45
import PrelNames  ( mETA_META_Name, varQual, tcQual )
46
import MkIface	  ( ifaceTyThing )
47
import Name       ( Name, nameOccName, nameModule )
48
import OccName	  ( isDataOcc, isTvOcc, occNameUserString )
49
import Module	  ( moduleUserString )
50
import Id         ( Id, idType )
51
import NameEnv
52
import NameSet
53
import Type       ( Type, TyThing(..), mkGenTyConApp )
54
import TyCon	  ( DataConDetails(..) )
55
56
57
import TysWiredIn ( stringTy )
import CoreSyn
import CoreUtils  ( exprType )
58
59
import SrcLoc	  ( noSrcLoc )
import Maybe	  ( catMaybes )
60
import Panic	  ( panic )
61
62
import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
import BasicTypes ( NewOrData(..), StrictnessMark(..) ) 
63
64
65
66
67
68
69
70
71
72

import Outputable
import FastString	( mkFastString )
 
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
-- Returns a CoreExpr of type M.Expr
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

73
74
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
75
76
77
  where
    new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]

78
79
80
81
    do_brack (ExpBr e)  = do { MkC e1  <- repE e      ; return e1 }
    do_brack (PatBr p)  = do { MkC p1  <- repP p      ; return p1 }
    do_brack (TypBr t)  = do { MkC t1  <- repTy t     ; return t1 }
    do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
82

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
-----------------------------------------------------------------------------
dsReify :: HsReify Id -> DsM CoreExpr
-- Returns a CoreExpr of type 	reifyType --> M.Typ
--				reifyDecl --> M.Dec
--				reifyFixty --> M.Fix
dsReify (ReifyOut ReifyType (AnId id))
  = do { MkC e <- repTy (toHsType (idType id)) ;
	 return e }

dsReify r@(ReifyOut ReifyDecl thing)
  = do { mb_d <- repTyClD (ifaceTyThing thing) ;
	 case mb_d of
	   Just (MkC d) -> return d 
	   Nothing	-> pprPanic "dsReify" (ppr r)
	}

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
{- -------------- Examples --------------------

  [| \x -> x |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (var x1)


  [| \x -> $(f [| x |]) |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (f (var x1))
-}


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
-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

repTopDs :: HsGroup Name -> DsM (Core [M.Decl])
repTopDs group
 = do { let { bndrs = groupBinders group } ;
	ss    <- mkGenSyms bndrs ;

	decls <- addBinds ss (do {
			val_ds <- rep_binds (hs_valds group) ;
			tycl_ds <- mapM repTyClD (hs_tyclds group) ;
			inst_ds <- mapM repInstD (hs_instds group) ;
			-- more needed
			return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;

	core_list <- coreList declTyConName decls ;
	wrapNongenSyms ss core_list
	-- Do *not* gensym top-level binders
      }

groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
			hs_fords = foreign_decls })
  = collectHsBinders val_decls ++
    [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
    [n | ForeignImport n _ _ _ _ <- foreign_decls]


repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))

repTyClD (TyData { tcdND = DataType, tcdCtxt = [], 
		   tcdName = tc, tcdTyVars = tvs, 
		   tcdCons = DataCons cons, tcdDerivs = mb_derivs }) 
 = do { tc1  <- lookupBinder tc ;
148
	tvs1  <- repTvs tvs ;
149
	cons1 <- mapM repC cons ;
150
151
	cons2 <- coreList consTyConName cons1 ;
	derivs1 <- repDerivs mb_derivs ;
152
153
	dec <- repData tc1 tvs1 cons2 derivs1 ;
	return (Just dec) }
154

155
repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, 
156
		      tcdTyVars = tvs, tcdFDs = [], 
157
158
159
		      tcdSigs = sigs, tcdMeths = Just binds
	})
 = do { cls1 <- lookupBinder cls ;
160
161
	tvs1 <- repTvs tvs ;
	cxt1 <- repCtxt cxt ;
162
163
164
165
166
167
168
169
170
171
172
173
	sigs1  <- rep_sigs sigs ;
	binds1 <- rep_monobind binds ;
	decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
	dec <- repClass cxt1 cls1 tvs1 decls1 ;
	return (Just dec) }

-- Un-handled cases
repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
	          return Nothing
	     }
  where
    msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
174

175
repInstD (InstDecl ty binds _ _ loc)
176
	-- Ignore user pragmas for now
177
178
179
180
181
 = do { cxt1 <- repCtxt cxt ;
	inst_ty1 <- repPred (HsClassP cls tys) ;
	binds1 <- rep_monobind binds ;
	decls1 <- coreList declTyConName binds1 ;
	repInst cxt1 inst_ty1 decls1  }
182
183
184
 where
   (tvs, cxt, cls, tys) = splitHsInstDeclTy ty

185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243

-------------------------------------------------------
-- 			Constructors
-------------------------------------------------------

repC :: ConDecl Name -> DsM (Core M.Cons)
repC (ConDecl con [] [] details loc)
  = do { con1     <- lookupBinder con ;
	 arg_tys  <- mapM (repBangTy con) (hsConArgs details) ;
	 arg_tys1 <- coreList typeTyConName arg_tys ;
	 repConstr con1 arg_tys1 }

repBangTy con (BangType NotMarkedStrict ty) = repTy ty
repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) }
   where
     msg = ptext SLIT("Ignoring stricness on argument of constructor")
		 <+> quotes (ppr con)

-------------------------------------------------------
-- 			Deriving clause
-------------------------------------------------------

repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
repDerivs Nothing = return (coreList' stringTy [])
repDerivs (Just ctxt)
  = do { strs <- mapM rep_deriv ctxt ; 
	 return (coreList' stringTy strs) }
  where
    rep_deriv :: HsPred Name -> DsM (Core String)
	-- Deriving clauses must have the simple H98 form
    rep_deriv (HsClassP cls []) = lookupOcc cls
    rep_deriv other		= panic "rep_deriv"


-------------------------------------------------------
--   Signatures in a class decl, or a group of bindings
-------------------------------------------------------

rep_sigs :: [Sig Name] -> DsM [Core M.Decl]
	-- We silently ignore ones we don't recognise
rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ;
		     return (concat sigs1) }

rep_sig :: Sig Name -> DsM [Core M.Decl]
	-- Singleton => Ok
	-- Empty     => Too hard, signature ignored
rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
rep_sig (Sig nm ty _)	       = rep_proto nm ty
rep_sig other		       = return []

rep_proto nm ty = do { nm1 <- lookupBinder nm ; 
		       ty1 <- repTy ty ; 
		       sig <- repProto nm1 ty1 ;
		       return [sig] }


-------------------------------------------------------
-- 			Types
-------------------------------------------------------
244
245
246

repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
247
		  return (coreList' stringTy tvs1) } 
248

249
-----------------
250
repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
251
252
repCtxt ctxt = do { preds <- mapM repPred ctxt; 
		    coreList typeTyConName preds }
253

254
255
256
257
258
259
-----------------
repPred :: HsPred Name -> DsM (Core M.Type)
repPred (HsClassP cls tys)
  = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1;
	 tys1 <- repTys tys; repTapps tcon tys1 }
repPred (HsIParam _ _) = panic "No implicit parameters yet"
260

261
262
263
-----------------
repTys :: [HsType Name] -> DsM [Core M.Type]
repTys tys = mapM repTy tys
264

265
266
-----------------
repTy :: HsType Name -> DsM (Core M.Type)
267

268
269
270
271
272
273
274
275
276
277
repTy (HsTyVar n)
  | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 }
  | otherwise		    = do { tc1 <- lookupOcc n; repNamedTyCon tc1 }
repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 }
repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; 
			   tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
repTy (HsListTy t)  = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 }
repTy (HsTupleTy tc tys)	  = do { tys1 <- repTys tys; 
					 tcon <- repTupleTyCon (length tys);
					 repTapps tcon tys1 }
278
repTy (HsOpTy ty1 HsArrow ty2) 	  = repTy (HsFunTy ty1 ty2)
279
repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
280
repTy (HsParTy t)  	       	  = repTy t
281
repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys)
282

283
repTy other_ty = pprPanic "repTy" (ppr other_ty)	-- HsForAllTy, HsKindSig
284
285

-----------------------------------------------------------------------------      
286
287
-- 		Expressions
-----------------------------------------------------------------------------      
288
289
290
291
292
293
294
295
296
297

repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
repEs es = do { es'  <- mapM repE es ;
		coreList exprTyConName es' }

repE :: HsExpr Name -> DsM (Core M.Expr)
repE (HsVar x)
  = do { mb_val <- dsLookupMetaEnv x 
       ; case mb_val of
	  Nothing	   -> do { str <- globalVar x
298
299
				 ; repVarOrCon x str }
	  Just (Bound y)   -> repVarOrCon x (coreVar y)
300
301
302
303
304
305
306
	  Just (Splice e)  -> do { e' <- dsExpr e
				 ; return (MkC e') } }

repE (HsIPVar x)    = panic "Can't represent implicit parameters"
repE (HsLit l)      = do { a <- repLiteral l;           repLit a }
repE (HsOverLit l)  = do { a <- repOverloadedLiteral l; repLit a }

307
repE (HsSplice n e loc) 
308
309
310
311
312
313
314
315
316
317
318
319
320
  = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
	     Just (Splice e) -> do { e' <- dsExpr e
				   ; return (MkC e') }
	     other	     -> pprPanic "HsSplice" (ppr n) }
			

repE (HsLam m)      = repLambda m
repE (HsApp x y)    = do {a <- repE x; b <- repE y; repApp a b}
repE (NegApp x nm)  = panic "No negate yet"
repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b } 
repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b } 

321
322
repE (OpApp e1 (HsVar op) fix e2)
  =  do { arg1 <- repE e1; 
323
	  arg2 <- repE e2; 
324
	  the_op <- lookupOcc op ;
325
326
327
328
329
330
331
332
333
334
	  repInfixApp arg1 the_op arg2 } 

repE (HsCase e ms loc)
  = do { arg <- repE e
       ; ms2 <- mapM repMatchTup ms
       ; repCaseE arg (nonEmptyCoreList ms2) }

-- 	I havn't got the types here right yet
repE (HsDo DoExpr sts _ ty loc)      = do { (ss,zs) <- repSts sts; 
					    e       <- repDoE (nonEmptyCoreList zs);
335
					    wrapGenSyns expTyConName ss e }
336
337
repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts; 
					  e       <- repComp (nonEmptyCoreList zs);
338
					  wrapGenSyns expTyConName ss e }
339
340
341
342
343
344
345
346
347

repE (ArithSeqIn (From e)) 		= do { ds1 <- repE e; repFrom ds1 }
repE (ArithSeqIn (FromThen e1 e2))      = do { ds1 <- repE e1; ds2 <- repE e2; 
					       repFromThen ds1 ds2 }
repE (ArithSeqIn (FromTo   e1 e2))      = do { ds1 <- repE e1; ds2 <- repE e2; 
					       repFromTo   ds1 ds2 }
repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2; 
					       ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }

348
349
350
351
352
353
354
355
356
357
358
359
repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c } 

repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
		       ; e2 <- addBinds ss (repE e)
		       ; z <- repLetE ds e2
		       ; wrapGenSyns expTyConName ss z }
repE (ExplicitList ty es)     = do { xs <- repEs es; repListExp xs } 
repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs }

repE (HsWith _ _ _) 	    = panic "No with for implicit parameters yet"
repE (ExplicitPArr ty es)   = panic "No parallel arrays yet"
repE (RecordConOut _ _ _)   = panic "No record construction yet"
360
repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
361
repE (ExprWithTySig e ty)   = panic "No expressions with type signatures yet"
362
363
364
365
366
367
368
369
370
371


-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt, 

repMatchTup ::  Match Name -> DsM (Core M.Mtch) 
repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = 
  do { ss1 <- mkGenSyms (collectPatBinders p) 
     ; addBinds ss1 $ do {
     ; p1 <- repP p
372
     ; (ss2,ds) <- repBinds wheres
373
374
375
     ; addBinds ss2 $ do {
     ; gs    <- repGuards guards
     ; match <- repMatch p1 gs ds
376
     ; wrapGenSyns matTyConName (ss1++ss2) match }}}
377
378
379
380
381
382

repClauseTup ::  Match Name -> DsM (Core M.Clse)
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = 
  do { ss1 <- mkGenSyms (collectPatsBinders ps) 
     ; addBinds ss1 $ do {
       ps1 <- repPs ps
383
     ; (ss2,ds) <- repBinds wheres
384
385
386
     ; addBinds ss2 $ do {
       gs <- repGuards guards
     ; clause <- repClause ps1 gs ds
387
     ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
388
389

repGuards ::  [GRHS Name] ->  DsM (Core M.Rihs)
390
repGuards [GRHS [ResultStmt e loc] loc2] 
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
  = do {a <- repE e; repNormal a }
repGuards other 
  = do { zs <- mapM process other; 
	 repGuarded (nonEmptyCoreList (map corePair zs)) }
  where 
    process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
           = do { x <- repE e1; y <- repE e2; return (x, y) }
    process other = panic "Non Haskell 98 guarded body"


-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
-- shaddow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
-- First gensym new names for every variable in any of the patterns.
-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
-- if variables didn't shaddow, the static gensym wouldn't be necessary
-- and we could reuse the original names (x and x).
--
-- do { x'1 <- gensym "x"
--    ; x'2 <- gensym "x"   
--    ; doE [ BindSt (pvar x'1) [| f 1 |]
--          , BindSt (pvar x'2) [| f x |] 
--          , NoBindSt [| g x |] 
--          ]
--    }

-- The strategy is to translate a whole list of do-bindings by building a
-- bigger environment, and a bigger set of meta bindings 
-- (like:  x'1 <- gensym "x" ) and then combining these with the translations
-- of the expressions within the Do
      
-----------------------------------------------------------------------------
-- The helper function repSts computes the translation of each sub expression
-- and a bunch of prefix bindings denoting the dynamic renaming.

repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
repSts [ResultStmt e loc] = 
   do { a <- repE e
      ; e1 <- repNoBindSt a
      ; return ([], [e1]) }
repSts (BindStmt p e loc : ss) =
   do { e2 <- repE e 
      ; ss1 <- mkGenSyms (collectPatBinders p) 
      ; addBinds ss1 $ do {
      ; p1 <- repP p; 
      ; (ss2,zs) <- repSts ss
      ; z <- repBindSt p1 e2
      ; return (ss1++ss2, z : zs) }}
repSts (LetStmt bs : ss) =
440
   do { (ss1,ds) <- repBinds bs
441
442
443
444
445
446
447
448
449
450
451
      ; z <- repLetSt ds
      ; (ss2,zs) <- addBinds ss1 (repSts ss)
      ; return (ss1++ss2, z : zs) } 
repSts (ExprStmt e ty loc : ss) =       
   do { e2 <- repE e
      ; z <- repNoBindSt e2 
      ; (ss2,zs) <- repSts ss
      ; return (ss2, z : zs) }
repSts other = panic "Exotic Stmt in meta brackets"      


452
453
454
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
455

456
457
repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl]) 
repBinds decs
458
 = do { let { bndrs = collectHsBinders decs } ;
459
460
	ss	  <- mkGenSyms bndrs ;
	core      <- addBinds ss (rep_binds decs) ;
461
462
463
	core_list <- coreList declTyConName core ;
	return (ss, core_list) }

464
465
466
467
468
rep_binds :: HsBinds Name -> DsM [Core M.Decl] 
rep_binds EmptyBinds = return []
rep_binds (ThenBinds x y)
 = do { core1 <- rep_binds x
      ; core2 <- rep_binds y
469
      ; return (core1 ++ core2) }
470
471
rep_binds (MonoBind bs sigs _)
 = do { core1 <- rep_monobind bs
472
473
474
      ;	core2 <- rep_sigs sigs
      ;	return (core1 ++ core2) }

475
476
477
478
479
rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
rep_monobind EmptyMonoBinds     = return []
rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x; 
				       y1 <- rep_monobind y; 
				       return (x1 ++ y1) }
480
481
482
483

-- Note GHC treats declarations of a variable (not a pattern) 
-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match 
-- with an empty list of patterns
484
485
rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) 
 = do { (ss,wherecore) <- repBinds wheres
486
487
488
489
490
491
	; guardcore <- addBinds ss (repGuards guards)
	; fn' <- lookupBinder fn
	; p   <- repPvar fn'
	; ans <- repVal p guardcore wherecore
	; return [ans] }

492
rep_monobind (FunMonoBind fn infx ms loc)
493
494
495
496
497
 =   do { ms1 <- mapM repClauseTup ms
	; fn' <- lookupBinder fn
        ; ans <- repFun fn' (nonEmptyCoreList ms1)
        ; return [ans] }

498
rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
499
 =   do { patcore <- repP pat 
500
        ; (ss,wherecore) <- repBinds wheres
501
502
503
504
	; guardcore <- addBinds ss (repGuards guards)
        ; ans <- repVal patcore guardcore wherecore
        ; return [ans] }

505
rep_monobind (VarMonoBind v e)  
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
 =   do { v' <- lookupBinder v 
	; e2 <- repE e
        ; x <- repNormal e2
        ; patcore <- repPvar v'
	; empty_decls <- coreList declTyConName [] 
        ; ans <- repVal patcore x empty_decls
        ; return [ans] }

-----------------------------------------------------------------------------
-- Since everything in a MonoBind is mutually recursive we need rename all
-- all the variables simultaneously. For example: 
-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
-- do { f'1 <- gensym "f"
--    ; g'2 <- gensym "g"
--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
--      ]}
-- This requires collecting the bindings (f'1 <- gensym "f"), and the 
-- environment ( f |-> f'1 ) from each binding, and then unioning them 
-- together. As we do this we collect GenSymBinds's which represent the renamed 
-- variables bound by the Bindings. In order not to lose track of these 
-- representations we build a shadow datatype MB with the same structure as 
-- MonoBinds, but which has slots for the representations


-----------------------------------------------------------------------------
532
-- GHC allows a more general form of lambda abstraction than specified
533
534
535
536
537
538
539
540
541
542
543
544
-- by Haskell 98. In particular it allows guarded lambda's like : 
-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
-- (\ p1 .. pn -> exp) by causing an error.  

repLambda :: Match Name -> DsM (Core M.Expr)
repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] 
		             EmptyBinds _))
 = do { let bndrs = collectPatsBinders ps ;
      ; ss <- mkGenSyms bndrs
      ; lam <- addBinds ss (
		do { xs <- repPs ps; body <- repE e; repLam xs body })
545
      ; wrapGenSyns expTyConName ss lam }
546
547
548
549
550

repLambda z = panic "Can't represent a guarded lambda in Template Haskell"  

  
-----------------------------------------------------------------------------
551
--			Patterns
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
-- repP deals with patterns.  It assumes that we have already
-- walked over the pattern(s) once to collect the binders, and 
-- have extended the environment.  So every pattern-bound 
-- variable should already appear in the environment.

-- Process a list of patterns
repPs :: [Pat Name] -> DsM (Core [M.Patt])
repPs ps = do { ps' <- mapM repP ps ;
		coreList pattTyConName ps' }

repP :: Pat Name -> DsM (Core M.Patt)
repP (WildPat _)     = repPwild 
repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
repP (LazyPat p)     = do { p1 <- repP p; repPtilde p1 }
repP (AsPat x p)     = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
repP (ParPat p)      = repP p 
repP (ListPat ps _)  = repListPat ps
repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
repP (ConPatIn dc details)
572
 = do { con_str <- lookupOcc dc
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
      ; case details of
         PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
         RecCon pairs   -> error "No records in template haskell yet"
         InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
   }
repP other = panic "Exotic pattern inside meta brackets"

repListPat :: [Pat Name] -> DsM (Core M.Patt)     
repListPat [] 	  = do { nil_con <- coreStringLit "[]"
		       ; nil_args <- coreList pattTyConName [] 
	               ; repPcon nil_con nil_args }
repListPat (p:ps) = do { p2 <- repP p 
		       ; ps2 <- repListPat ps
		       ; cons_con <- coreStringLit ":"
		       ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }


----------------------------------------------------------
--	The meta-environment

type GenSymBind = (Name, Id)	-- Gensym the string and bind it to the Id
				-- I.e.		(x, x_id) means
				--	let x_id = gensym "x" in ...

addBinds :: [GenSymBind] -> DsM a -> DsM a
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m

lookupBinder :: Name -> DsM (Core String)
lookupBinder n 
  = do { mb_val <- dsLookupMetaEnv n;
	 case mb_val of
	    Just (Bound id) -> return (MkC (Var id))
	    other	    -> pprPanic "Failed binder lookup:" (ppr n) }

mkGenSym :: Name -> DsM GenSymBind
mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }

mkGenSyms :: [Name] -> DsM [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns
	     
lookupType :: Name 	-- Name of type constructor (e.g. M.Expr)
	   -> DsM Type	-- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
		          return (mkGenTyConApp tc []) }

618
619
620
621
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y 
--	--> bindQ (gensym nm1) (\ id1 -> 
--	    bindQ (gensym nm2 (\ id2 -> 
--	    y))
622

623
624
625
626
wrapGenSyns :: Name 	-- Name of the type (consructor) for 'a'
	    -> [GenSymBind] 
	    -> Core (M.Q a) -> DsM (Core (M.Q a))
wrapGenSyns tc_name binds body@(MkC b)
627
628
629
630
631
632
633
634
635
636
637
  = do { elt_ty <- lookupType tc_name
       ; go elt_ty binds }
  where
    go elt_ty [] = return body
    go elt_ty ((name,id) : binds)
      = do { MkC body'  <- go elt_ty binds
	   ; lit_str    <- localVar name
	   ; gensym_app <- repGensym lit_str
	   ; repBindQ stringTy elt_ty 
		      gensym_app (MkC (Lam id body')) }

638
639
640
641
642
643
644
645
646
647
648
649
650
651
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
wrapNongenSyms :: [GenSymBind] 
	       -> Core [M.Decl] -> DsM (Core [M.Decl])
wrapNongenSyms binds body@(MkC b)
  = go binds
  where
    go [] = return body
    go ((name,id) : binds)
      = do { MkC body'   <- go binds
	   ; MkC lit_str <- localVar name	-- No gensym
	   ; return (MkC (Let (NonRec id lit_str) body'))
	   }
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708

void = placeHolderType

string :: String -> HsExpr Id
string s = HsLit (HsString (mkFastString s))


-- %*********************************************************************
-- %*									*
--		Constructing code
-- %*									*
-- %*********************************************************************

-----------------------------------------------------------------------------
-- PHANTOM TYPES for consistency. In order to make sure we do this correct 
-- we invent a new datatype which uses phantom types.

newtype Core a = MkC CoreExpr
unC (MkC x) = x

rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
rep2 n xs = do { id <- dsLookupGlobalId n
               ; return (MkC (foldl App (Var id) xs)) }

-- Then we make "repConstructors" which use the phantom types for each of the
-- smart constructors of the Meta.Meta datatypes.


-- %*********************************************************************
-- %*									*
--		The 'smart constructors'
-- %*									*
-- %*********************************************************************

--------------- Patterns -----------------
repPlit   :: Core M.Lit -> DsM (Core M.Patt) 
repPlit (MkC l) = rep2 plitName [l]

repPvar :: Core String -> DsM (Core M.Patt)
repPvar (MkC s) = rep2 pvarName [s]

repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
repPtup (MkC ps) = rep2 ptupName [ps]

repPcon   :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]

repPtilde :: Core M.Patt -> DsM (Core M.Patt)
repPtilde (MkC p) = rep2 ptildeName [p]

repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]

repPwild  :: DsM (Core M.Patt)
repPwild = rep2 pwildName []

--------------- Expressions -----------------
709
710
711
712
repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
	           | otherwise 		        = repVar str

713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
repVar :: Core String -> DsM (Core M.Expr)
repVar (MkC s) = rep2 varName [s] 

repCon :: Core String -> DsM (Core M.Expr)
repCon (MkC s) = rep2 conName [s] 

repLit :: Core M.Lit -> DsM (Core M.Expr)
repLit (MkC c) = rep2 litName [c] 

repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repApp (MkC x) (MkC y) = rep2 appName [x,y] 

repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]

repTup :: Core [M.Expr] -> DsM (Core M.Expr)
repTup (MkC es) = rep2 tupName [es]

repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repCond (MkC x) (MkC y) (MkC z) =  rep2 condName [x,y,z] 

repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] 

repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]

repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
repDoE (MkC ss) = rep2 doEName [ss]

repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
repComp (MkC ss) = rep2 compName [ss]

repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
repListExp (MkC es) = rep2 listExpName [es]

repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]

repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]

repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]

------------ Right hand sides (guarded expressions) ----
repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
repGuarded (MkC pairs) = rep2 guardedName [pairs]

repNormal :: Core M.Expr -> DsM (Core M.Rihs)
repNormal (MkC e) = rep2 normalName [e]

------------- Statements -------------------
repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]

repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
repLetSt (MkC ds) = rep2 letStName [ds]

repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
repNoBindSt (MkC e) = rep2 noBindStName [e]

-------------- DotDot (Arithmetic sequences) -----------
repFrom :: Core M.Expr -> DsM (Core M.Expr)
repFrom (MkC x) = rep2 fromName [x]

repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]

repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]

repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]

------------ Match and Clause Tuples -----------
repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]

repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]

-------------- Dec -----------------------------
repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]

repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)  
repFun (MkC nm) (MkC b) = rep2 funName [nm, b]

repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]

805
806
repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
807
808
809
810
811
812
813

repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]

repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]

814
815
816
repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]

817
818
819
820
821
822
823
824
825
826
827
828
------------ Types -------------------

repTvar :: Core String -> DsM (Core M.Type)
repTvar (MkC s) = rep2 tvarName [s]

repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]

repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
repTapps f []     = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }

829
--------- Type constructors --------------
830
831
832
833

repNamedTyCon :: Core String -> DsM (Core M.Type)
repNamedTyCon (MkC s) = rep2 namedTyConName [s]

834
835
836
repTupleTyCon :: Int -> DsM (Core M.Type)
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
837
838
839
840

repArrowTyCon :: DsM (Core M.Type)
repArrowTyCon = rep2 arrowTyConName []

841
repListTyCon :: DsM (Core M.Type)
842
843
844
repListTyCon = rep2 listTyConName []


845
846
847
848
849
850
851
852
853
854
855
856
857
----------------------------------------------------------
--		Literals

repLiteral :: HsLit -> DsM (Core M.Lit)
repLiteral (HsInt i)  = rep2 intLName [mkIntExpr i]
repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
repLiteral x = panic "trying to represent exotic literal"

repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
repOverloadedLiteral (HsIntegral i _)   = rep2 intLName [mkIntExpr i]
repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"

              
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
--------------- Miscellaneous -------------------

repLift :: Core e -> DsM (Core M.Expr)
repLift (MkC x) = rep2 liftName [x]

repGensym :: Core String -> DsM (Core (M.Q String))
repGensym (MkC lit_str) = rep2 gensymName [lit_str]

repBindQ :: Type -> Type	-- a and b
	 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
repBindQ ty_a ty_b (MkC x) (MkC y) 
  = rep2 bindQName [Type ty_a, Type ty_b, x, y] 

------------ Lists and Tuples -------------------
-- turn a list of patterns into a single pattern matching a list

coreList :: Name	-- Of the TyCon of the element type
	 -> [Core a] -> DsM (Core [a])
coreList tc_name es 
877
878
879
880
881
  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }

coreList' :: Type 	-- The element type
	  -> [Core a] -> Core [a]
coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
882
883
884
885
886
887
888
889
890
891

nonEmptyCoreList :: [Core a] -> Core [a]
  -- The list must be non-empty so we can get the element type
  -- Otherwise use coreList
nonEmptyCoreList [] 	      = panic "coreList: empty argument"
nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))

corePair :: (Core a, Core b) -> Core (a,b)
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])

892
893
894
895
896
897
898
899
900
901
902
lookupOcc :: Name -> DsM (Core String)
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
lookupOcc n
  = do {  mb_val <- dsLookupMetaEnv n ;
          case mb_val of
		Nothing        -> globalVar n
		Just (Bound x) -> return (coreVar x)
		other	       -> pprPanic "repE:lookupOcc" (ppr n) 
    }

903
904
905
906
907
908
909
910
911
912
913
914
915
916
globalVar :: Name -> DsM (Core String)
globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
 	    where
	      name_mod = moduleUserString (nameModule n)
	      name_occ = occNameUserString (nameOccName n)

localVar :: Name -> DsM (Core String)
localVar n = coreStringLit (occNameUserString (nameOccName n))

coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringLit s; return(MkC z) }

coreVar :: Id -> Core String	-- The Id has type String
coreVar id = MkC (Var id)
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951



-- %************************************************************************
-- %*									*
--		The known-key names for Template Haskell
-- %*									*
-- %************************************************************************

-- To add a name, do three things
-- 
--  1) Allocate a key
--  2) Make a "Name"
--  3) Add the name to knownKeyNames

templateHaskellNames :: NameSet
-- The names that are implicitly mentioned by ``bracket''
-- Should stay in sync with the import list of DsMeta
templateHaskellNames
  = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName, 
		pconName, ptildeName, paspatName, pwildName, 
                varName, conName, litName, appName, infixEName, lamName,
                tupName, doEName, compName, 
                listExpName, condName, letEName, caseEName,
                infixAppName, sectionLName, sectionRName, guardedName, normalName,
		bindStName, letStName, noBindStName, parStName,
		fromName, fromThenName, fromToName, fromThenToName,
		funName, valName, liftName,
	  	gensymName, returnQName, bindQName, 
		matchName, clauseName, funName, valName, dataDName, classDName,
		instName, protoName, tvarName, tconName, tappName, 
		arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
		constrName,
		exprTyConName, declTyConName, pattTyConName, mtchTyConName, 
		clseTyConName, stmtTyConName, consTyConName, typeTyConName,
952
953
		qTyConName, expTyConName, matTyConName, clsTyConName,
		decTyConName, typTyConName ]
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000



intLName       = varQual mETA_META_Name FSLIT("intL")          intLIdKey
charLName      = varQual mETA_META_Name FSLIT("charL")         charLIdKey
plitName       = varQual mETA_META_Name FSLIT("plit")          plitIdKey
pvarName       = varQual mETA_META_Name FSLIT("pvar")          pvarIdKey
ptupName       = varQual mETA_META_Name FSLIT("ptup")          ptupIdKey
pconName       = varQual mETA_META_Name FSLIT("pcon")          pconIdKey
ptildeName     = varQual mETA_META_Name FSLIT("ptilde")        ptildeIdKey
paspatName     = varQual mETA_META_Name FSLIT("paspat")        paspatIdKey
pwildName      = varQual mETA_META_Name FSLIT("pwild")         pwildIdKey
varName        = varQual mETA_META_Name FSLIT("var")           varIdKey
conName        = varQual mETA_META_Name FSLIT("con")           conIdKey
litName        = varQual mETA_META_Name FSLIT("lit")           litIdKey
appName        = varQual mETA_META_Name FSLIT("app")           appIdKey
infixEName     = varQual mETA_META_Name FSLIT("infixE")        infixEIdKey
lamName        = varQual mETA_META_Name FSLIT("lam")           lamIdKey
tupName        = varQual mETA_META_Name FSLIT("tup")           tupIdKey
doEName        = varQual mETA_META_Name FSLIT("doE")           doEIdKey
compName       = varQual mETA_META_Name FSLIT("comp")          compIdKey
listExpName    = varQual mETA_META_Name FSLIT("listExp")       listExpIdKey
condName       = varQual mETA_META_Name FSLIT("cond")          condIdKey
letEName       = varQual mETA_META_Name FSLIT("letE")          letEIdKey
caseEName      = varQual mETA_META_Name FSLIT("caseE")         caseEIdKey
infixAppName   = varQual mETA_META_Name FSLIT("infixApp")      infixAppIdKey
sectionLName   = varQual mETA_META_Name FSLIT("sectionL")      sectionLIdKey
sectionRName   = varQual mETA_META_Name FSLIT("sectionR")      sectionRIdKey
guardedName    = varQual mETA_META_Name FSLIT("guarded")       guardedIdKey
normalName     = varQual mETA_META_Name FSLIT("normal")        normalIdKey
bindStName     = varQual mETA_META_Name FSLIT("bindSt")        bindStIdKey
letStName      = varQual mETA_META_Name FSLIT("letSt")         letStIdKey
noBindStName   = varQual mETA_META_Name FSLIT("noBindSt")      noBindStIdKey
parStName      = varQual mETA_META_Name FSLIT("parSt")         parStIdKey
fromName       = varQual mETA_META_Name FSLIT("from")          fromIdKey
fromThenName   = varQual mETA_META_Name FSLIT("fromThen")      fromThenIdKey
fromToName     = varQual mETA_META_Name FSLIT("fromTo")        fromToIdKey
fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo")    fromThenToIdKey
liftName       = varQual mETA_META_Name FSLIT("lift")          liftIdKey
gensymName     = varQual mETA_META_Name FSLIT("gensym")        gensymIdKey
returnQName    = varQual mETA_META_Name FSLIT("returnQ")       returnQIdKey
bindQName      = varQual mETA_META_Name FSLIT("bindQ")         bindQIdKey

-- type Mat = ...
matchName      = varQual mETA_META_Name FSLIT("match")         matchIdKey

-- type Cls = ...