DsMeta.hs 57.7 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, expQTyConName, decQTyConName, typQTyConName,
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
46
import PrelNames  ( mETA_META_Name, rationalTyConName, negateName,
		    parrTyConName )
47
import MkIface	  ( ifaceTyThing )
48
import Name       ( Name, nameOccName, nameModule, getSrcLoc )
49
import OccName	  ( isDataOcc, isTvOcc, occNameUserString )
50
51
52
53
54
55
-- 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 )

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

import Outputable
import FastString	( mkFastString )
78
79

import Monad ( zipWithM )
80
import List ( sortBy )
81
82
83
 
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
84
-- Returns a CoreExpr of type M.ExpQ
85
86
87
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

88
89
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
90
91
92
  where
    new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]

93
94
95
96
    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 }
97

98
99
-----------------------------------------------------------------------------
dsReify :: HsReify Id -> DsM CoreExpr
100
101
-- Returns a CoreExpr of type 	reifyType --> M.TypQ
--				reifyDecl --> M.DecQ
102
--				reifyFixty --> Q M.Fix
103
104
105
106
107
108
109
110
111
112
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)
	}
113

114
115
116
dsReify r@(ReifyOut ReifyDecl name)
  = do { thing <- dsLookupGlobal name ;
	 mb_d <- repTyClD (ifaceTyThing thing) ;
117
118
119
120
121
	 case mb_d of
	   Just (MkC d) -> return d 
	   Nothing	-> pprPanic "dsReify" (ppr r)
	}

122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
{- -------------- 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))
-}


137
138
139
140
-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

141
repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
142
143
144
145
repTopDs group
 = do { let { bndrs = groupBinders group } ;
	ss    <- mkGenSyms bndrs ;

146
147
148
149
150
	-- 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
151
	-- only "T", not "Foo:T" where Foo is the current module
152
153

	
154
	decls <- addBinds ss (do {
155
156
157
			val_ds <- rep_binds' (hs_valds group) ;
			tycl_ds <- mapM repTyClD' (hs_tyclds group) ;
			inst_ds <- mapM repInstD' (hs_instds group) ;
158
			-- more needed
159
			return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
160

161
	decl_ty <- lookupType decQTyConName ;
162
	let { core_list = coreList' decl_ty decls } ;
163
164
165

	dec_ty <- lookupType decTyConName ;
	q_decs  <- repSequenceQ dec_ty core_list ;
166
167

	wrapNongenSyms ss q_decs
168
169
170
171
172
	-- Do *not* gensym top-level binders
      }

groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
			hs_fords = foreign_decls })
173
-- Collect the binders of a Group
174
175
176
177
178
  = collectHsBinders val_decls ++
    [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
    [n | ForeignImport n _ _ _ _ <- foreign_decls]


179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
{- 	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.

-}

203
204
205
repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ))
repTyClD decl = do x <- repTyClD' decl
                   return (fmap snd x)
206

207
208
209
repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ))

repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, 
210
		   tcdName = tc, tcdTyVars = tvs, 
211
212
		   tcdCons = DataCons cons, tcdDerivs = mb_derivs,
           tcdLoc = loc}) 
213
214
 = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
215
216
      	       cxt1   <- repContext cxt ;
               cons1   <- mapM repC cons ;
217
      	       cons2   <- coreList conQTyConName cons1 ;
218
      	       derivs1 <- repDerivs mb_derivs ;
219
      	       repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
220
        return $ Just (loc, dec) }
221

222
223
224
225
226
227
228
229
230
231
232
233
repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, 
		   tcdName = tc, tcdTyVars = tvs, 
		   tcdCons = DataCons [con], tcdDerivs = mb_derivs,
           tcdLoc = loc}) 
 = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
      	       cxt1   <- repContext cxt ;
               con1   <- repC con ;
      	       derivs1 <- repDerivs mb_derivs ;
      	       repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ;
        return $ Just (loc, dec) }

234
235
repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
           tcdLoc = loc})
236
237
238
239
 = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
	       ty1 <- repTy ty ;
	       repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
240
 	return (Just (loc, dec)) }
241

242
repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, 
243
244
		      tcdTyVars = tvs, 
		      tcdFDs = [], 	-- We don't understand functional dependencies
245
246
		      tcdSigs = sigs, tcdMeths = mb_meth_binds,
              tcdLoc = loc})
247
248
249
250
251
 = do { cls1 <- lookupOcc cls ;		-- See note [Binders and occurrences] 
    	dec  <- addTyVarBinds tvs $ \bndrs -> do {
 		  cxt1   <- repContext cxt ;
 		  sigs1  <- rep_sigs sigs ;
 		  binds1 <- rep_monobind meth_binds ;
252
 		  decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
253
 		  repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
254
    	return $ Just (loc, dec) }
255
256
257
258
259
 where
	-- If the user quotes a class decl, it'll have default-method 
	-- bindings; but if we (reifyDecl C) where C is a class, we
	-- won't be given the default methods (a definite infelicity).
   meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
260
261

-- Un-handled cases
262
repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
263
264
265
266
	          return Nothing
	     }
  where
    msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
267

268
repInstD' (InstDecl ty binds _ _ loc)
269
	-- Ignore user pragmas for now
chak's avatar
chak committed
270
 = do { cxt1 <- repContext cxt ;
271
272
	inst_ty1 <- repPred (HsClassP cls tys) ;
	binds1 <- rep_monobind binds ;
273
	decls1 <- coreList decQTyConName binds1 ;
274
275
	i <- repInst cxt1 inst_ty1 decls1;
    return (loc, i)}
276
277
278
 where
   (tvs, cxt, cls, tys) = splitHsInstDeclTy ty

279
280
281
282
283

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

284
repC :: ConDecl Name -> DsM (Core M.ConQ)
285
repC (ConDecl con [] [] details loc)
286
  = do { con1     <- lookupOcc con ;		-- See note [Binders and occurrences] 
287
	 repConstr con1 details }
288

289
repBangTy :: BangType Name -> DsM (Core (M.StrictTypQ))
290
291
repBangTy (BangType str ty) = do MkC s <- rep2 strName []
                                 MkC t <- repTy ty
292
                                 rep2 strictTypName [s, t]
293
    where strName = case str of
294
295
                        NotMarkedStrict -> notStrictName
                        _ -> isStrictName
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

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

317
318
319
320
321
rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

326
rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
327
328
	-- Singleton => Ok
	-- Empty     => Too hard, signature ignored
329
330
rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc
rep_sig (Sig nm ty loc)	       = rep_proto nm ty loc
331
332
rep_sig other		       = return []

333
334
rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; 
335
336
		       ty1 <- repTy ty ; 
		       sig <- repProto nm1 ty1 ;
337
		       return [(loc, sig)] }
338
339
340
341
342


-------------------------------------------------------
-- 			Types
-------------------------------------------------------
343

chak's avatar
chak committed
344
345
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
chak's avatar
chak committed
346
-- meta environment and gets the *new* names on Core-level as an argument
chak's avatar
chak committed
347
--
348
addTyVarBinds :: [HsTyVarBndr Name]	         -- the binders to be added
chak's avatar
chak committed
349
350
	      -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
	      -> DsM (Core (M.Q a))
351
addTyVarBinds tvs m =
chak's avatar
chak committed
352
353
354
355
356
357
  do
    let names = map hsTyVarName tvs
    freshNames <- mkGenSyms names
    term       <- addBinds freshNames $ do
		    bndrs <- mapM lookupBinder names 
		    m bndrs
358
    wrapGenSyns freshNames term
chak's avatar
chak committed
359

chak's avatar
chak committed
360
361
-- represent a type context
--
362
repContext :: HsContext Name -> DsM (Core M.CxtQ)
chak's avatar
chak committed
363
364
repContext ctxt = do 
	            preds    <- mapM repPred ctxt
365
		    predList <- coreList typQTyConName preds
chak's avatar
chak committed
366
		    repCtxt predList
367

chak's avatar
chak committed
368
369
-- represent a type predicate
--
370
repPred :: HsPred Name -> DsM (Core M.TypQ)
chak's avatar
chak committed
371
372
373
374
375
376
377
378
379
repPred (HsClassP cls tys) = do
			       tcon <- repTy (HsTyVar cls)
			       tys1 <- repTys tys
			       repTapps tcon tys1
repPred (HsIParam _ _)     = 
  panic "DsMeta.repTy: Can't represent predicates with implicit parameters"

-- yield the representation of a list of types
--
380
repTys :: [HsType Name] -> DsM [Core M.TypQ]
381
repTys tys = mapM repTy tys
382

chak's avatar
chak committed
383
384
-- represent a type
--
385
repTy :: HsType Name -> DsM (Core M.TypQ)
chak's avatar
chak committed
386
repTy (HsForAllTy bndrs ctxt ty)  = 
387
  addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
chak's avatar
chak committed
388
389
390
    ctxt'  <- repContext ctxt
    ty'    <- repTy ty
    repTForall (coreList' stringTy bndrs') ctxt' ty'
391

392
repTy (HsTyVar n)
chak's avatar
chak committed
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
  | isTvOcc (nameOccName n)       = do 
				      tv1 <- lookupBinder 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 (HsPArrTy t)                = do
				      t1   <- repTy t
				      tcon <- repTy (HsTyVar parrTyConName)
				      repTapp tcon t1
repTy (HsTupleTy tc tys)	  = do
				      tys1 <- repTys tys 
				      tcon <- repTupleTyCon (length tys)
				      repTapps tcon tys1
420
repTy (HsOpTy ty1 HsArrow ty2) 	  = repTy (HsFunTy ty1 ty2)
chak's avatar
chak committed
421
422
repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) 
					   `HsAppTy` ty2)
423
repTy (HsParTy t)  	       	  = repTy t
chak's avatar
chak committed
424
425
426
427
428
repTy (HsNumTy i)                 =
  panic "DsMeta.repTy: Can't represent number types (for generics)"
repTy (HsPredTy pred)             = repPred pred
repTy (HsKindSig ty kind)	  = 
  panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
429
430


chak's avatar
chak committed
431
-----------------------------------------------------------------------------
432
-- 		Expressions
chak's avatar
chak committed
433
-----------------------------------------------------------------------------
434

435
repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
436
repEs es = do { es'  <- mapM repE es ;
437
		coreList expQTyConName es' }
438

chak's avatar
chak committed
439
440
441
-- 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
442
repE :: HsExpr Name -> DsM (Core M.ExpQ)
chak's avatar
chak committed
443
444
445
repE (HsVar x)            =
  do { mb_val <- dsLookupMetaEnv x 
     ; case mb_val of
chak's avatar
chak committed
446
	Nothing	         -> do { str <- globalVar x
chak's avatar
chak committed
447
448
449
450
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
451
repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
452
453
454
455
456
457
458

	-- 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}
459

chak's avatar
chak committed
460
repE (OpApp e1 op fix e2) =
461
462
463
464
  do { arg1 <- repE e1; 
       arg2 <- repE e2; 
       the_op <- repE op ;
       repInfixApp arg1 the_op arg2 } 
chak's avatar
chak committed
465
466
467
468
repE (NegApp x nm)        = do
			      a         <- repE x
			      negateVar <- lookupOcc negateName >>= repVar
			      negateVar `repApp` a
chak's avatar
chak committed
469
470
471
472
473
474
475
476
477
478
479
480
481
482
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
483
			       ; wrapGenSyns ss z }
chak's avatar
chak committed
484
-- FIXME: I haven't got the types here right yet
485
486
487
repE (HsDo DoExpr sts _ ty loc) 
 = do { (ss,zs) <- repSts sts; 
        e       <- repDoE (nonEmptyCoreList zs);
488
        wrapGenSyns ss e }
489
490
491
repE (HsDo ListComp sts _ ty loc) 
 = do { (ss,zs) <- repSts sts; 
        e       <- repComp (nonEmptyCoreList zs);
492
        wrapGenSyns ss e }
493
repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
chak's avatar
chak committed
494
495
496
497
498
499
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"
500
501
502
503
504
505
506
507
repE (RecordCon c flds)
 = do { x <- lookupOcc c;
        fs <- repFields flds;
        repRecCon x fs }
repE (RecordUpd e flds)
 = do { x <- repE e;
        fs <- repFields flds;
        repRecUpd x fs }
508
509

repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
510
repE (ArithSeqIn aseq) =
chak's avatar
chak committed
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
  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"
527
repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
chak's avatar
chak committed
528
529
530
531
532
533
534
535
536
537
538
539
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)
540
541
542
543

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

544
repMatchTup ::  Match Name -> DsM (Core M.MatchQ) 
545
546
547
548
repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = 
  do { ss1 <- mkGenSyms (collectPatBinders p) 
     ; addBinds ss1 $ do {
     ; p1 <- repP p
549
     ; (ss2,ds) <- repBinds wheres
550
551
552
     ; addBinds ss2 $ do {
     ; gs    <- repGuards guards
     ; match <- repMatch p1 gs ds
553
     ; wrapGenSyns (ss1++ss2) match }}}
554

555
repClauseTup ::  Match Name -> DsM (Core M.ClauseQ)
556
557
558
559
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = 
  do { ss1 <- mkGenSyms (collectPatsBinders ps) 
     ; addBinds ss1 $ do {
       ps1 <- repPs ps
560
     ; (ss2,ds) <- repBinds wheres
561
562
563
     ; addBinds ss2 $ do {
       gs <- repGuards guards
     ; clause <- repClause ps1 gs ds
564
     ; wrapGenSyns (ss1++ss2) clause }}}
565

566
repGuards ::  [GRHS Name] ->  DsM (Core M.RHSQ)
567
repGuards [GRHS [ResultStmt e loc] loc2] 
568
569
570
571
572
573
574
575
576
  = 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"

577
repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
578
579
580
repFields flds = do
        fnames <- mapM lookupOcc (map fst flds)
        es <- mapM repE (map snd flds)
581
582
        fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
        coreList fieldExpTyConName fs
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

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

610
repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ])
611
612
613
614
615
616
617
618
619
620
621
622
623
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) =
624
   do { (ss1,ds) <- repBinds bs
625
626
627
628
629
630
631
632
633
634
635
      ; 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"      


636
637
638
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
639

640
repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ]) 
641
repBinds decs
642
 = do { let { bndrs = collectHsBinders decs } ;
643
644
	ss	  <- mkGenSyms bndrs ;
	core      <- addBinds ss (rep_binds decs) ;
645
	core_list <- coreList decQTyConName core ;
646
647
	return (ss, core_list) }

648
649
650
651
652
653
654
655
656
rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
rep_binds binds = do locs_cores <- rep_binds' binds
                     return $ de_loc $ sort_by_loc locs_cores

rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
rep_binds' EmptyBinds = return []
rep_binds' (ThenBinds x y)
 = do { core1 <- rep_binds' x
      ; core2 <- rep_binds' y
657
      ; return (core1 ++ core2) }
658
659
660
rep_binds' (MonoBind bs sigs _)
 = do { core1 <- rep_monobind' bs
      ;	core2 <- rep_sigs' sigs
661
      ;	return (core1 ++ core2) }
662
rep_binds' (IPBinds _ _)
663
  = panic "DsMeta:repBinds: can't do implicit parameters"
664

665
666
667
668
669
670
671
672
rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
rep_monobind binds = do locs_cores <- rep_monobind' binds
                        return $ de_loc $ sort_by_loc locs_cores

rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
rep_monobind' EmptyMonoBinds     = return []
rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x; 
				       y1 <- rep_monobind' y; 
673
				       return (x1 ++ y1) }
674
675
676
677

-- 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
678
rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) 
679
 = do { (ss,wherecore) <- repBinds wheres
680
681
682
683
	; guardcore <- addBinds ss (repGuards guards)
	; fn' <- lookupBinder fn
	; p   <- repPvar fn'
	; ans <- repVal p guardcore wherecore
684
	; return [(loc, ans)] }
685

686
rep_monobind' (FunMonoBind fn infx ms loc)
687
688
689
 =   do { ms1 <- mapM repClauseTup ms
	; fn' <- lookupBinder fn
        ; ans <- repFun fn' (nonEmptyCoreList ms1)
690
        ; return [(loc, ans)] }
691

692
rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
693
 =   do { patcore <- repP pat 
694
        ; (ss,wherecore) <- repBinds wheres
695
696
	; guardcore <- addBinds ss (repGuards guards)
        ; ans <- repVal patcore guardcore wherecore
697
        ; return [(loc, ans)] }
698

699
rep_monobind' (VarMonoBind v e)  
700
701
702
703
 =   do { v' <- lookupBinder v 
	; e2 <- repE e
        ; x <- repNormal e2
        ; patcore <- repPvar v'
704
	; empty_decls <- coreList decQTyConName [] 
705
        ; ans <- repVal patcore x empty_decls
706
        ; return [(getSrcLoc v, ans)] }
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725

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


-----------------------------------------------------------------------------
726
-- GHC allows a more general form of lambda abstraction than specified
727
728
729
730
731
-- 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.  

732
repLambda :: Match Name -> DsM (Core M.ExpQ)
733
734
735
736
737
738
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 })
739
      ; wrapGenSyns ss lam }
740
741
742
743
744

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

  
-----------------------------------------------------------------------------
745
--			Patterns
746
747
748
749
750
751
-- 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
752
repPs :: [Pat Name] -> DsM (Core [M.Pat])
753
repPs ps = do { ps' <- mapM repP ps ;
754
		coreList patTyConName ps' }
755

756
repP :: Pat Name -> DsM (Core M.Pat)
757
758
759
760
761
762
763
764
765
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)
766
 = do { con_str <- lookupOcc dc
767
768
      ; case details of
         PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
769
770
         RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
                            ; ps <- sequence $ map repP (map snd pairs)
771
772
                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
                            ; fps' <- coreList fieldPatTyConName fps
773
                            ; repPrec con_str fps' }
774
775
         InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
   }
776
777
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 }
778
779
repP other = panic "Exotic pattern inside meta brackets"

780
repListPat :: [Pat Name] -> DsM (Core M.Pat)     
781
repListPat [] 	  = do { nil_con <- coreStringLit "[]"
782
		       ; nil_args <- coreList patTyConName [] 
783
784
785
786
787
788
789
	               ; repPcon nil_con nil_args }
repListPat (p:ps) = do { p2 <- repP p 
		       ; ps2 <- repListPat ps
		       ; cons_con <- coreStringLit ":"
		       ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }


790
791
792
793
794
795
796
797
798
799
----------------------------------------------------------
-- Declaration ordering helpers

sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
sort_by_loc xs = sortBy comp xs
    where comp x y = compare (fst x) (fst y)

de_loc :: [(SrcLoc, a)] -> [a]
de_loc = map snd

800
801
802
----------------------------------------------------------
--	The meta-environment

chak's avatar
chak committed
803
804
-- A name/identifier association for fresh names of locally bound entities
--
805
806
807
808
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 ...

chak's avatar
chak committed
809
810
-- Generate a fresh name for a locally bound entity
--
811
812
813
mkGenSym :: Name -> DsM GenSymBind
mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }

chak's avatar
chak committed
814
815
-- Ditto for a list of names
--
816
817
818
mkGenSyms :: [Name] -> DsM [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns
	     
chak's avatar
chak committed
819
820
821
822
823
824
825
826
827
-- Add a list of fresh names for locally bound entities to the meta
-- environment (which is part of the state carried around by the desugarer
-- monad) 
--
addBinds :: [GenSymBind] -> DsM a -> DsM a
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m

-- Look up a locally bound name
--
828
829
830
831
832
833
834
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) }

chak's avatar
chak committed
835
836
837
838
839
-- Look up a name that is either locally bound or a global name
--
-- * If it is a global name, generate the "original name" representation (ie,
--   the <module>:<name> form) for the associated entity
--
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
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))

860
lookupType :: Name 	-- Name of type constructor (e.g. M.ExpQ)
861
862
863
864
	   -> DsM Type	-- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
		          return (mkGenTyConApp tc []) }

865
866
867
868
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y 
--	--> bindQ (gensym nm1) (\ id1 -> 
--	    bindQ (gensym nm2 (\ id2 -> 
--	    y))
869

870
wrapGenSyns :: [GenSymBind] 
871
	    -> Core (M.Q a) -> DsM (Core (M.Q a))
872
873
wrapGenSyns binds body@(MkC b)
  = go binds
874
  where
875
876
877
878
879
880
881
882
    [elt_ty] = tcTyConAppArgs (exprType b) 
	-- b :: Q a, so we can get the type 'a' by looking at the
	-- argument type. NB: this relies on Q being a data/newtype,
	-- not a type synonym

    go [] = return body
    go ((name,id) : binds)
      = do { MkC body'  <- go binds
883
884
885
886
887
	   ; lit_str    <- localVar name
	   ; gensym_app <- repGensym lit_str
	   ; repBindQ stringTy elt_ty 
		      gensym_app (MkC (Lam id body')) }

888
889
890
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
891
892
893
894
wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
wrapNongenSyms binds (MkC body)
  = do { binds' <- mapM do_one binds ;
	 return (MkC (mkLets binds' body)) }
895
  where
896
897
898
    do_one (name,id) 
	= do { MkC lit_str <- localVar name	-- No gensym
	     ; return (NonRec id lit_str) }
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933

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 -----------------
934
repPlit   :: Core M.Lit -> DsM (Core M.Pat) 
935
repPlit (MkC l) = rep2 litPatName [l]
936

937
repPvar :: Core String -> DsM (Core M.Pat)
938
repPvar (MkC s) = rep2 varPatName [s]
939

940
repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
941
repPtup (MkC ps) = rep2 tupPatName [ps]
942

943
repPcon   :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
944
repPcon (MkC s) (MkC ps) = rep2 conPatName [s, ps]
945

946
repPrec   :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
947
repPrec (MkC c) (MkC rps) = rep2 recPatName [c,rps]
948

949
repPtilde :: Core M.Pat -> DsM (Core M.Pat)
950
repPtilde (MkC p) = rep2 tildePatName [p]
951

952
repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
953
repPaspat (MkC s) (MkC p) = rep2 asPatName [s, p]
954

955
repPwild  :: DsM (Core M.Pat)
956
repPwild = rep2 wildPatName []
957
958

--------------- Expressions -----------------
959
repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
960
961
962
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
	           | otherwise 		        = repVar str

963
repVar :: Core String -> DsM (Core M.ExpQ)
964
repVar (MkC s) = rep2 varExpName [s] 
965

966
repCon :: Core String -> DsM (Core M.ExpQ)
967
repCon (MkC s) = rep2 conExpName [s] 
968

969
repLit :: Core M.Lit -> DsM (Core M.ExpQ)
970
repLit (MkC c) = rep2 litExpName [c] 
971

972
repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
973
repApp (MkC x) (MkC y) = rep2 appExpName [x,y] 
974

975
repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
976
repLam (MkC ps) (MkC e) = rep2 lamExpName [ps, e]
977

978
repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
979
repTup (MkC es) = rep2 tupExpName [es]
980

981
repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
982
repCond (MkC x) (MkC y) (MkC z) =  rep2 condExpName [x,y,z] 
983

984
repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
985
repLetE (MkC ds) (MkC e) = rep2 letExpName [ds, e] 
986

987
repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
988
repCaseE (MkC e) (MkC ms) = rep2 caseExpName [e, ms]
989

990
repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
991
repDoE (MkC ss) = rep2 doExpName [ss]
992

993
repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
994
repComp (MkC ss) = rep2 compExpName [ss]
995

996
repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
997
998
repListExp (MkC es) = rep2 listExpName [es]

999
repSigExp :: Core M.ExpQ -> Core M.TypQ -> DsM (Core M.ExpQ)
1000
repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
For faster browsing, not all history is shown. View entire blame