DsMeta.hs 46 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
	       liftName, exprTyConName, declTyConName, typeTyConName,
17
	       decTyConName, typTyConName ) where
18
19
20
21
22

#include "HsVersions.h"

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

23
24
import MatchLit	  ( dsLit )
import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
25
26
27
28
29
30
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
		  )

chak's avatar
chak committed
45
import PrelNames  ( mETA_META_Name, rationalTyConName, negateName )
46
import MkIface	  ( ifaceTyThing )
47
import Name       ( Name, nameOccName, nameModule )
48
import OccName	  ( isDataOcc, isTvOcc, occNameUserString )
49
50
51
52
53
54
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- we do this by removing varName from the import of OccName above, making
-- a qualified instance of OccName and using OccNameAlias.varName where varName
-- ws previously used in this file.
import qualified OccName( varName, tcName )

55
import Module	  ( Module, mkThPkgModule, moduleUserString )
56
import Id         ( Id, idType )
57
58
import Name	  ( mkKnownKeyExternalName )
import OccName	  ( mkOccFS )
59
import NameEnv
60
import NameSet
61
import Type       ( Type, TyThing(..), mkGenTyConApp )
62
import TyCon	  ( DataConDetails(..) )
63
64
65
import TysWiredIn ( stringTy )
import CoreSyn
import CoreUtils  ( exprType )
66
67
import SrcLoc	  ( noSrcLoc )
import Maybe	  ( catMaybes )
68
import Panic	  ( panic )
69
import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
chak's avatar
chak committed
70
import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) 
71
72
73
74
75
76
77
78
79
80

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!

81
82
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
83
84
85
  where
    new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]

86
87
88
89
    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 }
90

91
92
-----------------------------------------------------------------------------
dsReify :: HsReify Id -> DsM CoreExpr
93
94
95
-- Returns a CoreExpr of type 	reifyType --> M.Type
--				reifyDecl --> M.Decl
--				reifyFixty --> Q M.Fix
96
97
98
99
100
101
102
103
104
105
dsReify (ReifyOut ReifyType name)
  = do { thing <- dsLookupGlobal name ;
		-- By deferring the lookup until now (rather than doing it
		-- in the type checker) we ensure that all zonking has
		-- been done.
	 case thing of
	    AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
			    return e }
	    other   -> pprPanic "dsReify: reifyType" (ppr name)
	}
106

107
108
109
dsReify r@(ReifyOut ReifyDecl name)
  = do { thing <- dsLookupGlobal name ;
	 mb_d <- repTyClD (ifaceTyThing thing) ;
110
111
112
113
114
	 case mb_d of
	   Just (MkC d) -> return d 
	   Nothing	-> pprPanic "dsReify" (ppr r)
	}

115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
{- -------------- 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))
-}


130
131
132
133
-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

134
repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
135
136
137
138
repTopDs group
 = do { let { bndrs = groupBinders group } ;
	ss    <- mkGenSyms bndrs ;

139
140
141
142
143
144
145
146
	-- Bind all the names mainly to avoid repeated use of explicit strings.
	-- Thus	we get
	--	do { t :: String <- genSym "T" ;
	--	     return (Data t [] ...more t's... }
	-- The other important reason is that the output must mention
	-- only "T", not "Foo.T" where Foo is the current module

	
147
148
149
150
151
152
153
	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) }) ;

154
155
156
157
158
	decl_ty <- lookupType declTyConName ;
	let { core_list = coreList' decl_ty decls } ;
	q_decs  <- repSequenceQ decl_ty core_list ;

	wrapNongenSyms ss q_decs
159
160
161
162
163
	-- Do *not* gensym top-level binders
      }

groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
			hs_fords = foreign_decls })
164
-- Collect the binders of a Group
165
166
167
168
169
  = collectHsBinders val_decls ++
    [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
    [n | ForeignImport n _ _ _ _ <- foreign_decls]


170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
{- 	Note [Binders and occurrences]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we desugar [d| data T = MkT |]
we want to get
	Data "T" [] [Con "MkT" []] []
and *not*
	Data "Foo:T" [] [Con "Foo:MkT" []] []
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
	Data "T79" ....

But if we see this:
	data T = MkT 
	foo = reifyDecl T

then we must desugar to
	foo = Data "Foo:T" [] [Con "Foo:MkT" []] []

So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
but in dsReify we do not.  And we use lookupOcc, rather than lookupBinder
in repTyClD and repC.

-}

194
195
196
197
198
repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))

repTyClD (TyData { tcdND = DataType, tcdCtxt = [], 
		   tcdName = tc, tcdTyVars = tvs, 
		   tcdCons = DataCons cons, tcdDerivs = mb_derivs }) 
199
 = do { tc1  <- lookupOcc tc ;		-- See note [Binders and occurrences] 
200
	tvs1  <- repTvs tvs ;
201
	cons1 <- mapM repC cons ;
202
203
	cons2 <- coreList consTyConName cons1 ;
	derivs1 <- repDerivs mb_derivs ;
204
205
	dec <- repData tc1 tvs1 cons2 derivs1 ;
	return (Just dec) }
206

207
repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, 
208
		      tcdTyVars = tvs, tcdFDs = [], 
209
210
		      tcdSigs = sigs, tcdMeths = Just binds
	})
211
 = do { cls1 <- lookupOcc cls ;		-- See note [Binders and occurrences] 
212
213
	tvs1 <- repTvs tvs ;
	cxt1 <- repCtxt cxt ;
214
215
216
217
218
219
220
221
222
223
224
225
	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:")
226

227
repInstD (InstDecl ty binds _ _ loc)
228
	-- Ignore user pragmas for now
229
230
231
232
233
 = do { cxt1 <- repCtxt cxt ;
	inst_ty1 <- repPred (HsClassP cls tys) ;
	binds1 <- rep_monobind binds ;
	decls1 <- coreList declTyConName binds1 ;
	repInst cxt1 inst_ty1 decls1  }
234
235
236
 where
   (tvs, cxt, cls, tys) = splitHsInstDeclTy ty

237
238
239
240
241
242
243

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

repC :: ConDecl Name -> DsM (Core M.Cons)
repC (ConDecl con [] [] details loc)
244
  = do { con1     <- lookupOcc con ;		-- See note [Binders and occurrences] 
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
	 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
-------------------------------------------------------
296
297
298

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

301
-----------------
302
repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
303
304
repCtxt ctxt = do { preds <- mapM repPred ctxt; 
		    coreList typeTyConName preds }
305

306
307
308
309
310
311
-----------------
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"
312

313
314
315
-----------------
repTys :: [HsType Name] -> DsM [Core M.Type]
repTys tys = mapM repTy tys
316

317
318
-----------------
repTy :: HsType Name -> DsM (Core M.Type)
319

320
321
322
323
324
325
326
327
328
329
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 }
330
repTy (HsOpTy ty1 HsArrow ty2) 	  = repTy (HsFunTy ty1 ty2)
331
repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
332
repTy (HsParTy t)  	       	  = repTy t
333
repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys)
334

335
repTy other_ty = pprPanic "repTy" (ppr other_ty)	-- HsForAllTy, HsKindSig
336

chak's avatar
chak committed
337
-----------------------------------------------------------------------------
338
-- 		Expressions
chak's avatar
chak committed
339
-----------------------------------------------------------------------------
340
341
342
343
344

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

chak's avatar
chak committed
345
346
347
-- FIXME: some of these panics should be converted into proper error messages
--	  unless we can make sure that constructs, which are plainly not
--	  supported in TH already lead to error messages at an earlier stage
348
repE :: HsExpr Name -> DsM (Core M.Expr)
chak's avatar
chak committed
349
350
351
repE (HsVar x)            =
  do { mb_val <- dsLookupMetaEnv x 
     ; case mb_val of
chak's avatar
chak committed
352
	Nothing	         -> do { str <- globalVar x
chak's avatar
chak committed
353
354
355
356
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
357
repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
358
359
360
361
362
363
364

	-- Remember, we're desugaring renamer output here, so
	-- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
repE (HsLam m)     = repLambda m
repE (HsApp x y)   = do {a <- repE x; b <- repE y; repApp a b}
365

chak's avatar
chak committed
366
367
368
369
370
371
372
repE (OpApp e1 op fix e2) =
  case op of
    HsVar op -> do { arg1 <- repE e1; 
		     arg2 <- repE e2; 
		     the_op <- lookupOcc op ;
		     repInfixApp arg1 the_op arg2 } 
    _        -> panic "DsMeta.repE: Operator is not a variable"
chak's avatar
chak committed
373
374
375
376
repE (NegApp x nm)        = do
			      a         <- repE x
			      negateVar <- lookupOcc negateName >>= repVar
			      negateVar `repApp` a
chak's avatar
chak committed
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
repE (HsPar x)            = repE x
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 } 
repE (HsCase e ms loc)    = do { arg <- repE e
			       ; ms2 <- mapM repMatchTup ms
			       ; repCaseE arg (nonEmptyCoreList ms2) }
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 }
-- FIXME: I haven't got the types here right yet
393
394
395
396
397
398
399
400
401
repE (HsDo DoExpr sts _ ty loc) 
 = do { (ss,zs) <- repSts sts; 
        e       <- repDoE (nonEmptyCoreList zs);
        wrapGenSyns expTyConName ss e }
repE (HsDo ListComp sts _ ty loc) 
 = do { (ss,zs) <- repSts sts; 
        e       <- repComp (nonEmptyCoreList zs);
        wrapGenSyns expTyConName ss e }
repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
chak's avatar
chak committed
402
403
404
405
406
407
408
409
repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } 
repE (ExplicitPArr ty es) = 
  panic "DsMeta.repE: No explicit parallel arrays yet"
repE (ExplicitTuple es boxed) 
  | isBoxed boxed         = do { xs <- repEs es; repTup xs }
  | otherwise		  = panic "DsMeta.repE: Can't represent unboxed tuples"
repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
410
411

repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
412
repE (ArithSeqIn aseq) =
chak's avatar
chak committed
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
440
  case aseq of
    From e              -> do { ds1 <- repE e; repFrom ds1 }
    FromThen e1 e2      -> do 
		             ds1 <- repE e1
			     ds2 <- repE e2
			     repFromThen ds1 ds2
    FromTo   e1 e2      -> do 
			     ds1 <- repE e1
			     ds2 <- repE e2
			     repFromTo ds1 ds2
    FromThenTo e1 e2 e3 -> do 
			     ds1 <- repE e1
			     ds2 <- repE e2
			     ds3 <- repE e3
			     repFromThenTo ds1 ds2 ds3
repE (PArrSeqOut _ aseq)  = panic "DsMeta.repE: parallel array seq.s missing"
repE (HsCCall _ _ _ _ _)  = panic "DsMeta.repE: Can't represent __ccall__"
repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _)   = 
  panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSplice n e loc)   = 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 (HsReify _)          = panic "DsMeta.repE: Can't represent reification"
repE e                    = 
  pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
441
442
443
444
445
446
447
448
449

-----------------------------------------------------------------------------
-- 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
450
     ; (ss2,ds) <- repBinds wheres
451
452
453
     ; addBinds ss2 $ do {
     ; gs    <- repGuards guards
     ; match <- repMatch p1 gs ds
454
     ; wrapGenSyns matTyConName (ss1++ss2) match }}}
455
456
457
458
459
460

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
461
     ; (ss2,ds) <- repBinds wheres
462
463
464
     ; addBinds ss2 $ do {
       gs <- repGuards guards
     ; clause <- repClause ps1 gs ds
465
     ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
466
467

repGuards ::  [GRHS Name] ->  DsM (Core M.Rihs)
468
repGuards [GRHS [ResultStmt e loc] loc2] 
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
  = 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) =
518
   do { (ss1,ds) <- repBinds bs
519
520
521
522
523
524
525
526
527
528
529
      ; 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"      


530
531
532
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
533

534
535
repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl]) 
repBinds decs
536
 = do { let { bndrs = collectHsBinders decs } ;
537
538
	ss	  <- mkGenSyms bndrs ;
	core      <- addBinds ss (rep_binds decs) ;
539
540
541
	core_list <- coreList declTyConName core ;
	return (ss, core_list) }

542
543
544
545
546
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
547
      ; return (core1 ++ core2) }
548
549
rep_binds (MonoBind bs sigs _)
 = do { core1 <- rep_monobind bs
550
551
      ;	core2 <- rep_sigs sigs
      ;	return (core1 ++ core2) }
552
553
rep_binds (IPBinds _ _)
  = panic "DsMeta:repBinds: can't do implicit parameters"
554

555
556
557
558
559
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) }
560
561
562
563

-- 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
564
565
rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) 
 = do { (ss,wherecore) <- repBinds wheres
566
567
568
569
570
571
	; guardcore <- addBinds ss (repGuards guards)
	; fn' <- lookupBinder fn
	; p   <- repPvar fn'
	; ans <- repVal p guardcore wherecore
	; return [ans] }

572
rep_monobind (FunMonoBind fn infx ms loc)
573
574
575
576
577
 =   do { ms1 <- mapM repClauseTup ms
	; fn' <- lookupBinder fn
        ; ans <- repFun fn' (nonEmptyCoreList ms1)
        ; return [ans] }

578
rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
579
 =   do { patcore <- repP pat 
580
        ; (ss,wherecore) <- repBinds wheres
581
582
583
584
	; guardcore <- addBinds ss (repGuards guards)
        ; ans <- repVal patcore guardcore wherecore
        ; return [ans] }

585
rep_monobind (VarMonoBind v e)  
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
 =   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


-----------------------------------------------------------------------------
612
-- GHC allows a more general form of lambda abstraction than specified
613
614
615
616
617
618
619
620
621
622
623
624
-- 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 })
625
      ; wrapGenSyns expTyConName ss lam }
626
627
628
629
630

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

  
-----------------------------------------------------------------------------
631
--			Patterns
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
-- 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)
652
 = do { con_str <- lookupOcc dc
653
654
655
656
657
      ; 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 }
   }
658
659
repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
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
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

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

mkGenSyms :: [Name] -> DsM [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns
	     
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
lookupBinder :: Name -> DsM (Core String)
lookupBinder n 
  = do { mb_val <- dsLookupMetaEnv n;
	 case mb_val of
	    Just (Bound x) -> return (coreVar x)
	    other	   -> pprPanic "Failed binder lookup:" (ppr n) }

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)
		Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) 
    }

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

715
716
717
718
719
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 []) }

720
721
722
723
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y 
--	--> bindQ (gensym nm1) (\ id1 -> 
--	    bindQ (gensym nm2 (\ id2 -> 
--	    y))
724

725
726
727
728
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)
729
730
731
732
733
734
735
736
737
738
739
  = 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')) }

740
741
742
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
743
744
745
746
wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
wrapNongenSyms binds (MkC body)
  = do { binds' <- mapM do_one binds ;
	 return (MkC (mkLets binds' body)) }
747
  where
748
749
750
    do_one (name,id) 
	= do { MkC lit_str <- localVar name	-- No gensym
	     ; return (NonRec id lit_str) }
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
805
806
807

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 -----------------
808
809
810
811
repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
	           | otherwise 		        = repVar str

812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
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]

848
849
850
repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]

851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
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]

907
908
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]
909
910
911
912
913
914
915

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]

916
917
918
repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]

919
920
921
922
923
924
925
926
927
928
929
930
------------ 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 }

931
--------- Type constructors --------------
932
933
934
935

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

936
937
938
repTupleTyCon :: Int -> DsM (Core M.Type)
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
939
940
941
942

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

943
repListTyCon :: DsM (Core M.Type)
944
945
946
repListTyCon = rep2 listTyConName []


947
948
949
950
----------------------------------------------------------
--		Literals

repLiteral :: HsLit -> DsM (Core M.Lit)
951
952
953
954
repLiteral lit 
  = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
  where
    lit_name = case lit of
955
956
957
958
959
		 HsInteger _ -> integerLName
		 HsChar _    -> charLName
		 HsString _  -> stringLName
		 HsRat _ _   -> rationalLName
		 other 	     -> uh_oh
960
961
    uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
		    (ppr lit)
962

963
repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
964
repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInteger i)
965
966
967
968
969
repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
					       repLiteral (HsRat f rat_ty) }
	-- The type Rational will be in the environment, becuase 
	-- the smart constructor 'THSyntax.rationalL' uses it in its type,
	-- and rationalL is sucked in when any TH stuff is used
970
              
971
972
973
974
975
976
977
978
979
980
981
982
983
--------------- 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] 

984
985
986
987
repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
repSequenceQ ty_a (MkC list)
  = rep2 sequenceQName [Type ty_a, list]

988
989
990
991
992
993
------------ 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 
994
995
996
997
998
  = 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 ))
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013

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])

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)
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032



-- %************************************************************************
-- %*									*
--		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
1033
  = mkNameSet [ integerLName,charLName, stringLName, rationalLName,
1034
		plitName, pvarName, ptupName, 
1035
1036
1037
		pconName, ptildeName, paspatName, pwildName, 
                varName, conName, litName, appName, infixEName, lamName,
                tupName, doEName, compName, 
1038
                listExpName, sigExpName, condName, letEName, caseEName,
chak's avatar
chak committed
1039
                infixAppName, sectionLName, sectionRName,
chak's avatar
chak committed
1040
                guardedName, normalName, 
1041
1042
1043
		bindStName, letStName, noBindStName, parStName,
		fromName, fromThenName, fromToName, fromThenToName,
		funName, valName, liftName,
1044
	  	gensymName, returnQName, bindQName, sequenceQName,
1045
1046
1047
1048
1049
1050
		matchName, clauseName, funName, valName, dataDName, classDName,
		instName, protoName, tvarName, tconName, tappName, 
		arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
		constrName,
		exprTyConName, declTyConName, pattTyConName, mtchTyConName, 
		clseTyConName, stmtTyConName, consTyConName, typeTyConName,
1051
1052
		qTyConName, expTyConName, matTyConName, clsTyConName,
		decTyConName, typTyConName ]
1053
1054


1055
1056
1057
1058
1059
1060
1061
varQual  = mk_known_key_name OccName.varName
tcQual   = mk_known_key_name OccName.tcName

thModule :: Module
-- NB: the THSyntax module comes from the "haskell-src" package
thModule = mkThPkgModule mETA_META_Name

1062
mk_known_key_name space str uniq 
1063
1064
  = mkKnownKeyExternalName thModule (mkOccFS space str) uniq 

1065
integerLName   = varQual FSLIT("integerL")      integerLIdKey
1066
charLName      = varQual FSLIT("charL")         charLIdKey
1067
1068
stringLName    = varQual FSLIT("stringL")       stringLIdKey
rationalLName  = varQual FSLIT("rationalL")     rationalLIdKey
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
plitName       = varQual FSLIT("plit")          plitIdKey
pvarName       = varQual FSLIT("pvar")          pvarIdKey
ptupName       = varQual FSLIT("ptup")          ptupIdKey
pconName       = varQual FSLIT("pcon")          pconIdKey
ptildeName     = varQual FSLIT("ptilde")        ptildeIdKey
paspatName     = varQual FSLIT("paspat")        paspatIdKey
pwildName      = varQual FSLIT("pwild")         pwildIdKey
varName        = varQual FSLIT("var")           varIdKey
conName        = varQual FSLIT("con")           conIdKey
litName        = varQual FSLIT("lit")           litIdKey
appName        = varQual FSLIT("app")           appIdKey
infixEName     = varQual FSLIT("infixE")        infixEIdKey
lamName        = varQual FSLIT("lam")           lamIdKey
tupName        = varQual FSLIT("tup")           tupIdKey
doEName        = varQual FSLIT("doE")           doEIdKey
compName       = varQual FSLIT("comp")          compIdKey
listExpName    = varQual FSLIT("listExp")       listExpIdKey
1086
sigExpName     = varQual FSLIT("sigExp")        sigExpIdKey
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
condName       = varQual FSLIT("cond")          condIdKey
letEName       = varQual FSLIT("letE")          letEIdKey
caseEName      = varQual FSLIT("caseE")         caseEIdKey
infixAppName   = varQual FSLIT("infixApp")      infixAppIdKey
sectionLName   = varQual FSLIT("sectionL")      sectionLIdKey
sectionRName   = varQual FSLIT("sectionR")      sectionRIdKey
guardedName    = varQual FSLIT("guarded")       guardedIdKey
normalName     = varQual FSLIT("normal")        normalIdKey
bindStName     = varQual FSLIT("bindSt")        bindStIdKey
letStName      = varQual FSLIT("letSt")         letStIdKey
noBindStName   = varQual FSLIT("noBindSt")      noBindStIdKey
parStName      = varQual FSLIT("parSt")         parStIdKey
fromName       = varQual FSLIT("from")          fromIdKey
fromThenName   = varQual FSLIT("fromThen")      fromThenIdKey
fromToName     = varQual FSLIT("fromTo")        fromToIdKey
fromThenToName = varQual FSLIT("fromThenTo")    fromThenToIdKey
liftName       = varQual FSLIT("lift")          liftIdKey
gensymName     = varQual FSLIT("gensym")        gensymIdKey
returnQName    = varQual FSLIT("returnQ")       returnQIdKey
bindQName      = varQual FSLIT("bindQ")         bindQIdKey
1107
sequenceQName  = varQual FSLIT("sequenceQ")     sequenceQIdKey
1108
1109

-- type Mat = ...
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
matchName      = varQual FSLIT("match")         matchIdKey
			 
-- type Cls = ...	 
clauseName     = varQual FSLIT("clause")        clauseIdKey
			 
-- data Dec = ...	 
funName        = varQual FSLIT("fun")           funIdKey
valName        = varQual FSLIT("val")           valIdKey
dataDName      = varQual FSLIT("dataD")         dataDIdKey
classDName     = varQual FSLIT("classD")        classDIdKey
instName       = varQual FSLIT("inst")          instIdKey
protoName      = varQual FSLIT("proto")         protoIdKey
			 
-- data Typ = ...	 
tvarName       = varQual FSLIT("tvar")          tvarIdKey
tconName       = varQual FSLIT("tcon")          tconIdKey
tappName       = varQual FSLIT("tapp")          tappIdKey
			 
-- data Tag = ...	 
arrowTyConName = varQual FSLIT("arrowTyCon")   arrowIdKey
tupleTyConName = varQual FSLIT("tupleTyCon")   tupleIdKey
listTyConName  = varQual FSLIT("listTyCon")    listIdKey
namedTyConName = varQual FSLIT("namedTyCon")   namedTyConIdKey
			 
-- data Con = ...	 
constrName     = varQual FSLIT("constr")        constrIdKey
			 
exprTyConName  = tcQual  FSLIT("Expr")  	       exprTyConKey
declTyConName  = tcQual  FSLIT("Decl")  	       declTyConKey
pattTyConName  = tcQual  FSLIT("Patt")  	       pattTyConKey
mtchTyConName  = tcQual  FSLIT("Mtch")  	       mtchTyConKey
clseTyConName  = tcQual  FSLIT("Clse")  	       clseTyConKey
stmtTyConName  = tcQual  FSLIT("Stmt") 	       stmtTyConKey
consTyConName  = tcQual  FSLIT("Cons")  	       consTyConKey
typeTyConName  = tcQual  FSLIT("Type")  	       typeTyConKey
			 
qTyConName     = tcQual  FSLIT("Q")  	       qTyConKey
expTyConName   = tcQual  FSLIT("Exp")  	       expTyConKey
decTyConName   = tcQual  FSLIT("Dec")  	       decTyConKey
typTyConName   = tcQual  FSLIT("Typ")  	       typTyConKey
matTyConName   = tcQual  FSLIT("Mat")  	       matTyConKey
clsTyConName   = tcQual  FSLIT("Cls")  	       clsTyConKey
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167

--	TyConUniques available: 100-119
-- 	Check in PrelNames if you want to change this

expTyConKey  = mkPreludeTyConUnique 100
matTyConKey  = mkPreludeTyConUnique 101
clsTyConKey  = mkPreludeTyConUnique 102
qTyConKey    = mkPreludeTyConUnique 103
exprTyConKey = mkPreludeTyConUnique 104
declTyConKey = mkPreludeTyConUnique 105
pattTyConKey = mkPreludeTyConUnique 106
mtchTyConKey = mkPreludeTyConUnique 107
clseTyConKey = mkPreludeTyConUnique 108
stmtTyConKey = mkPreludeTyConUnique 109
consTyConKey = mkPreludeTyConUnique 110
typeTyConKey = mkPreludeTyConUnique 111
1168
1169
1170
typTyConKey  = mkPreludeTyConUnique 112
decTyConKey  = mkPreludeTyConUnique 113

1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187


-- 	IdUniques available: 200-299
-- 	If you want to change this, make sure you check in PrelNames
fromIdKey       = mkPreludeMiscIdUnique 200
fromThenIdKey   = mkPreludeMiscIdUnique 201
fromToIdKey     = mkPreludeMiscIdUnique 202
fromThenToIdKey = mkPreludeMiscIdUnique 203
liftIdKey       = mkPreludeMiscIdUnique 204
gensymIdKey     = mkPreludeMiscIdUnique 205
returnQIdKey    = mkPreludeMiscIdUnique 206
bindQIdKey      = mkPreludeMiscIdUnique 207
funIdKey        = mkPreludeMiscIdUnique 208
valIdKey        = mkPreludeMiscIdUnique 209
protoIdKey      = mkPreludeMiscIdUnique 210
matchIdKey      = mkPreludeMiscIdUnique 211
clauseIdKey     = mkPreludeMiscIdUnique 212
1188
integerLIdKey   = mkPreludeMiscIdUnique 213
1189
1190
1191
1192
1193
1194
charLIdKey      = mkPreludeMiscIdUnique 214

classDIdKey     = mkPreludeMiscIdUnique 215
instIdKey       = mkPreludeMiscIdUnique 216
dataDIdKey      = mkPreludeMiscIdUnique 217

1195
sequenceQIdKey  = mkPreludeMiscIdUnique 218
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217

plitIdKey       = mkPreludeMiscIdUnique 220
pvarIdKey       = mkPreludeMiscIdUnique 221
ptupIdKey       = mkPreludeMiscIdUnique 222
pconIdKey       = mkPreludeMiscIdUnique 223
ptildeIdKey     = mkPreludeMiscIdUnique 224
paspatIdKey     = mkPreludeMiscIdUnique 225
pwildIdKey      = mkPreludeMiscIdUnique 226
varIdKey        = mkPreludeMiscIdUnique 227
conIdKey        = mkPreludeMiscIdUnique 228
litIdKey        = mkPreludeMiscIdUnique 229
appIdKey        = mkPreludeMiscIdUnique 230
infixEIdKey     = mkPreludeMiscIdUnique 231
lamIdKey        = mkPreludeMiscIdUnique 232
tupIdKey        = mkPreludeMiscIdUnique 233
doEIdKey        = mkPreludeMiscIdUnique 234
compIdKey       = mkPreludeMiscIdUnique 235
listExpIdKey    = mkPreludeMiscIdUnique 237
condIdKey       = mkPreludeMiscIdUnique 238
letEIdKey       = mkPreludeMiscIdUnique 239
caseEIdKey      = mkPreludeMiscIdUnique 240
infixAppIdKey   = mkPreludeMiscIdUnique 241
chak's avatar
chak committed
1218
-- 242 unallocated
chak's avatar
chak committed
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
sectionLIdKey   = mkPreludeMiscIdUnique 243
sectionRIdKey   = mkPreludeMiscIdUnique 244
guardedIdKey    = mkPreludeMiscIdUnique 245
normalIdKey     = mkPreludeMiscIdUnique 246
bindStIdKey     = mkPreludeMiscIdUnique 247
letStIdKey      = mkPreludeMiscIdUnique 248
noBindStIdKey   = mkPreludeMiscIdUnique 249
parStIdKey      = mkPreludeMiscIdUnique 250

tvarIdKey	= mkPreludeMiscIdUnique 251
tconIdKey	= mkPreludeMiscIdUnique 252
tappIdKey	= mkPreludeMiscIdUnique 253

arrowIdKey	= mkPreludeMiscIdUnique 254
tupleIdKey	= mkPreludeMiscIdUnique 255
listIdKey	= mkPreludeMiscIdUnique 256
namedTyConIdKey	= mkPreludeMiscIdUnique 257

constrIdKey	= mkPreludeMiscIdUnique 258
1238

1239
1240
1241
1242
1243
1244
1245
stringLIdKey	= mkPreludeMiscIdUnique 259
rationalLIdKey	= mkPreludeMiscIdUnique 260

sigExpIdKey     = mkPreludeMiscIdUnique 261



1246
1247
1248
1249
1250
1251
1252
1253
1254
-- %************************************************************************
-- %*									*
--		Other utilities
-- %*									*
-- %************************************************************************

-- It is rather usatisfactory that we don't have a SrcLoc
addDsWarn :: SDoc -> DsM ()
addDsWarn msg = dsWarn (noSrcLoc, msg)