DsMeta.hs 64 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
15
module DsMeta( dsBracket, 
	       templateHaskellNames, qTyConName, nameTyConName,
16
	       liftName, expQTyConName, decQTyConName, typeQTyConName,
17
18
	       decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
	        ) where
19
20
21
22
23

#include "HsVersions.h"

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

24
import MatchLit	  ( dsLit )
Simon Marlow's avatar
Simon Marlow committed
25
import DsUtils    ( mkListExpr, mkStringExpr, mkIntExpr )
26
27
import DsMonad

28
import qualified Language.Haskell.TH as TH
29

30
import HsSyn
31
import Class (FunDep)
32
import PrelNames  ( rationalTyConName, integerTyConName, negateName )
33
import OccName	  ( isDataOcc, isTvOcc, occNameString )
34
35
36
37
-- 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.
38
import qualified OccName
39

Simon Marlow's avatar
Simon Marlow committed
40
41
import Module	  ( Module, mkModule, moduleNameString, moduleName,
                    modulePackageId, mkModuleNameFS )
42
import Id         ( Id, mkLocalId )
43
import OccName	  ( mkOccNameFS )
44
45
import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule, 
		    isExternalName, getSrcLoc )
46
import NameEnv
47
import Type       ( Type, mkTyConApp )
48
import TcType	  ( tcTyConAppArgs )
49
50
import TyCon	  ( tyConName )
import TysWiredIn ( parrTyCon )
51
52
import CoreSyn
import CoreUtils  ( exprType )
53
import SrcLoc	  ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
Simon Marlow's avatar
Simon Marlow committed
54
import PackageConfig ( thPackageId, packageIdString )
55
import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
56
import BasicTypes ( isBoxed ) 
57
import Outputable
58
import Bag	  ( bagToList, unionManyBags )
59
import FastString ( unpackFS )
60
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
61

Simon Marlow's avatar
Simon Marlow committed
62
import Maybe	  ( catMaybes )
63
import Monad ( zipWithM )
64
import List ( sortBy )
65
66
67
 
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
68
-- Returns a CoreExpr of type TH.ExpQ
69
70
71
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

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

77
    do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
78
79
    do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
80
    do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
81
    do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

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


98
99
100
101
-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

102
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
103
repTopDs group
104
 = do { let { bndrs = map unLoc (groupBinders group) } ;
105
	ss <- mkGenSyms bndrs ;
106

107
108
109
110
111
	-- 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
112
	-- only "T", not "Foo:T" where Foo is the current module
113
114

	
115
	decls <- addBinds ss (do {
116
			val_ds  <- rep_val_binds (hs_valds group) ;
117
			tycl_ds <- mapM repTyClD (hs_tyclds group) ;
118
			inst_ds <- mapM repInstD' (hs_instds group) ;
119
			for_ds <- mapM repForD (hs_fords group) ;
120
			-- more needed
121
			return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
122

123
	decl_ty <- lookupType decQTyConName ;
124
	let { core_list = coreList' decl_ty decls } ;
125
126
127

	dec_ty <- lookupType decTyConName ;
	q_decs  <- repSequenceQ dec_ty core_list ;
128
129

	wrapNongenSyms ss q_decs
130
131
132
133
134
	-- Do *not* gensym top-level binders
      }

groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
			hs_fords = foreign_decls })
135
-- Collect the binders of a Group
136
  = collectHsValBinders val_decls ++
137
    [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
138
    [n | L _ (ForeignImport n _ _) <- foreign_decls]
139
140


141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
{- 	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" []] []

159
160
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
161
162
163
164
in repTyClD and repC.

-}

165
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
166

167
168
169
170
repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, 
		    tcdLName = tc, tcdTyVars = tvs, 
		    tcdCons = cons, tcdDerivs = mb_derivs }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
171
        dec <- addTyVarBinds tvs $ \bndrs -> do {
172
      	       cxt1    <- repLContext cxt ;
173
               cons1   <- mapM repC cons ;
174
      	       cons2   <- coreList conQTyConName cons1 ;
175
      	       derivs1 <- repDerivs mb_derivs ;
176
177
	       bndrs1  <- coreList nameTyConName bndrs ;
      	       repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
178
        return $ Just (loc, dec) }
179

180
181
182
183
repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, 
		    tcdLName = tc, tcdTyVars = tvs, 
		    tcdCons = [con], tcdDerivs = mb_derivs }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
184
        dec <- addTyVarBinds tvs $ \bndrs -> do {
185
      	       cxt1   <- repLContext cxt ;
186
187
               con1   <- repC con ;
      	       derivs1 <- repDerivs mb_derivs ;
188
189
	       bndrs1  <- coreList nameTyConName bndrs ;
      	       repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
190
191
        return $ Just (loc, dec) }

192
193
repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
194
        dec <- addTyVarBinds tvs $ \bndrs -> do {
195
	       ty1     <- repLTy ty ;
196
197
	       bndrs1  <- coreList nameTyConName bndrs ;
	       repTySyn tc1 bndrs1 ty1 } ;
198
 	return (Just (loc, dec)) }
199

200
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
201
		      tcdTyVars = tvs, 
202
		      tcdFDs = fds,
203
204
		      tcdSigs = sigs, tcdMeths = meth_binds }))
 = do { cls1 <- lookupLOcc cls ;		-- See note [Binders and occurrences] 
205
    	dec  <- addTyVarBinds tvs $ \bndrs -> do {
206
 		  cxt1   <- repLContext cxt ;
207
 		  sigs1  <- rep_sigs sigs ;
208
 		  binds1 <- rep_binds meth_binds ;
209
	          fds1 <- repLFunDeps fds;
210
 		  decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
211
	          bndrs1 <- coreList nameTyConName bndrs ;
212
 		  repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
213
    	return $ Just (loc, dec) }
214
215

-- Un-handled cases
216
217
218
repTyClD (L loc d) = putSrcSpanDs loc $
		     do { dsWarn (hang ds_msg 4 (ppr d))
			; return Nothing }
219

220
221
222
223
224
225
226
227
228
229
230
231
232
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
repLFunDeps fds = do fds' <- mapM repLFunDep fds
                     fdList <- coreList funDepTyConName fds'
                     return fdList

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
                               ys' <- mapM lookupBinder ys
                               xs_list <- coreList nameTyConName xs'
                               ys_list <- coreList nameTyConName ys'
                               repFunDep xs_list ys_list
233

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
repInstD' (L loc (InstDecl ty binds _))		-- Ignore user pragmas for now
 = do	{ i <- addTyVarBinds tvs $ \tv_bndrs ->
		-- We must bring the type variables into scope, so their occurrences
		-- don't fail,  even though the binders don't appear in the resulting 
		-- data structure
		do {  cxt1 <- repContext cxt
		   ; inst_ty1 <- repPred (HsClassP cls tys)
		   ; ss <- mkGenSyms (collectHsBindBinders binds)
		   ; binds1 <- addBinds ss (rep_binds binds)
		   ; decls1 <- coreList decQTyConName binds1
		   ; decls2 <- wrapNongenSyms ss decls1
		   -- wrapNonGenSyms: do not clone the class op names!
		   -- They must be called 'op' etc, not 'op34'
		   ; repInst cxt1 inst_ty1 decls2 }

249
	; return (loc, i)}
250
 where
251
   (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
252

253
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
254
repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
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
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
      MkC str <- coreStringLit $ static
                              ++ unpackFS ch ++ " "
                              ++ unpackFS cn ++ " "
                              ++ conv_cimportspec cis
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
    conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
    conv_cimportspec (CFunction DynamicTarget) = "dynamic"
    conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
    conv_cimportspec CWrapper = "wrapper"
    static = case cis of
                 CFunction (StaticTarget _) -> "static "
                 _ -> ""

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []

repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []

283
284
ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")

285
286
287
288
-------------------------------------------------------
-- 			Constructors
-------------------------------------------------------

289
repC :: LConDecl Name -> DsM (Core TH.ConQ)
290
repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
291
  = do { con1 <- lookupLOcc con ;		-- See note [Binders and occurrences] 
292
	 repConstr con1 details }
293
repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
294
  = do { addTyVarBinds tvs $ \bndrs -> do {
295
             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
296
297
298
299
300
             ctxt' <- repContext ctxt;
             bndrs' <- coreList nameTyConName bndrs;
             rep2 forallCName [unC bndrs', unC ctxt', unC c']
         }
       }
301
repC (L loc con_decl)		-- GADTs
302
303
  = putSrcSpanDs loc $ 
    do	{ dsWarn (hang ds_msg 4 (ppr con_decl))
304
	; return (panic "DsMeta:repC") }
305

306
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
307
308
309
repBangTy ty= do 
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
310
  rep2 strictTypeName [s, t]
311
312
313
314
  where 
    (str, ty') = case ty of
		   L _ (HsBangTy _ ty) -> (isStrictName,  ty)
		   other	       -> (notStrictName, ty)
315
316
317
318
319

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

320
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
321
repDerivs Nothing = coreList nameTyConName []
322
repDerivs (Just ctxt)
323
  = do { strs <- mapM rep_deriv ctxt ; 
324
	 coreList nameTyConName strs }
325
  where
326
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
327
	-- Deriving clauses must have the simple H98 form
328
329
    rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
    rep_deriv other		  		 = panic "rep_deriv"
330
331
332
333
334
335


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

336
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
337
338
339
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

340
rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
341
	-- We silently ignore ones we don't recognise
342
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
343
344
		     return (concat sigs1) }

345
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
346
347
	-- Singleton => Ok
	-- Empty     => Too hard, signature ignored
348
349
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
rep_sig other		        = return []
350

351
352
353
rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; 
		       ty1 <- repLTy ty ; 
354
		       sig <- repProto nm1 ty1 ;
355
		       return [(loc, sig)] }
356
357
358
359
360


-------------------------------------------------------
-- 			Types
-------------------------------------------------------
361

chak's avatar
chak committed
362
363
-- 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
364
-- meta environment and gets the *new* names on Core-level as an argument
chak's avatar
chak committed
365
--
366
addTyVarBinds :: [LHsTyVarBndr Name]	         -- the binders to be added
367
368
	      -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
	      -> DsM (Core (TH.Q a))
369
addTyVarBinds tvs m =
chak's avatar
chak committed
370
  do
371
    let names = map (hsTyVarName.unLoc) tvs
372
    freshNames <- mkGenSyms names
chak's avatar
chak committed
373
374
375
    term       <- addBinds freshNames $ do
		    bndrs <- mapM lookupBinder names 
		    m bndrs
376
    wrapGenSyns freshNames term
chak's avatar
chak committed
377

chak's avatar
chak committed
378
379
-- represent a type context
--
380
381
382
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

383
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
chak's avatar
chak committed
384
repContext ctxt = do 
385
	            preds    <- mapM repLPred ctxt
386
		    predList <- coreList typeQTyConName preds
chak's avatar
chak committed
387
		    repCtxt predList
388

chak's avatar
chak committed
389
390
-- represent a type predicate
--
391
392
393
repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
repLPred (L _ p) = repPred p

394
repPred :: HsPred Name -> DsM (Core TH.TypeQ)
chak's avatar
chak committed
395
396
repPred (HsClassP cls tys) = do
			       tcon <- repTy (HsTyVar cls)
397
			       tys1 <- repLTys tys
chak's avatar
chak committed
398
399
400
401
402
403
			       repTapps tcon tys1
repPred (HsIParam _ _)     = 
  panic "DsMeta.repTy: Can't represent predicates with implicit parameters"

-- yield the representation of a list of types
--
404
405
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
406

chak's avatar
chak committed
407
408
-- represent a type
--
409
410
411
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

412
413
414
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy (HsForAllTy _ tvs ctxt ty)  = 
  addTyVarBinds tvs $ \bndrs -> do
415
416
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
417
418
    bndrs1 <- coreList nameTyConName bndrs
    repTForall bndrs1 ctxt1 ty1
419

420
repTy (HsTyVar n)
chak's avatar
chak committed
421
422
423
424
425
426
427
  | isTvOcc (nameOccName n)       = do 
				      tv1 <- lookupBinder n
				      repTvar tv1
  | otherwise		          = do 
				      tc1 <- lookupOcc n
				      repNamedTyCon tc1
repTy (HsAppTy f a)               = do 
428
429
				      f1 <- repLTy f
				      a1 <- repLTy a
chak's avatar
chak committed
430
431
				      repTapp f1 a1
repTy (HsFunTy f a)               = do 
432
433
				      f1   <- repLTy f
				      a1   <- repLTy a
chak's avatar
chak committed
434
435
436
				      tcon <- repArrowTyCon
				      repTapps tcon [f1, a1]
repTy (HsListTy t)		  = do
437
				      t1   <- repLTy t
chak's avatar
chak committed
438
439
440
				      tcon <- repListTyCon
				      repTapp tcon t1
repTy (HsPArrTy t)                = do
441
				      t1   <- repLTy t
442
				      tcon <- repTy (HsTyVar (tyConName parrTyCon))
chak's avatar
chak committed
443
444
				      repTapp tcon t1
repTy (HsTupleTy tc tys)	  = do
445
				      tys1 <- repLTys tys 
chak's avatar
chak committed
446
447
				      tcon <- repTupleTyCon (length tys)
				      repTapps tcon tys1
448
449
450
repTy (HsOpTy ty1 n ty2) 	  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
					   `nlHsAppTy` ty2)
repTy (HsParTy t)  	       	  = repLTy t
chak's avatar
chak committed
451
452
repTy (HsNumTy i)                 =
  panic "DsMeta.repTy: Can't represent number types (for generics)"
453
repTy (HsPredTy pred)             = repPred pred
chak's avatar
chak committed
454
455
repTy (HsKindSig ty kind)	  = 
  panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
456
457


chak's avatar
chak committed
458
-----------------------------------------------------------------------------
459
-- 		Expressions
chak's avatar
chak committed
460
-----------------------------------------------------------------------------
461

462
463
464
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
repLEs es = do { es'  <- mapM repLE es ;
		 coreList expQTyConName es' }
465

chak's avatar
chak committed
466
467
468
-- 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
469
470
471
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
repLE (L _ e) = repE e

472
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
chak's avatar
chak committed
473
474
475
repE (HsVar x)            =
  do { mb_val <- dsLookupMetaEnv x 
     ; case mb_val of
chak's avatar
chak committed
476
	Nothing	         -> do { str <- globalVar x
chak's avatar
chak committed
477
478
479
480
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
481
repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
482
483
484
485
486

	-- 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 }
487
repE (HsLam (MatchGroup [m] _)) = repLambda m
488
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
489

chak's avatar
chak committed
490
repE (OpApp e1 op fix e2) =
491
492
493
  do { arg1 <- repLE e1; 
       arg2 <- repLE e2; 
       the_op <- repLE op ;
494
       repInfixApp arg1 the_op arg2 } 
chak's avatar
chak committed
495
repE (NegApp x nm)        = do
496
			      a         <- repLE x
chak's avatar
chak committed
497
498
			      negateVar <- lookupOcc negateName >>= repVar
			      negateVar `repApp` a
499
500
501
repE (HsPar x)            = repLE x
repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } 
repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } 
502
503
504
repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
				       ; ms2 <- mapM repMatchTup ms
				       ; repCaseE arg (nonEmptyCoreList ms2) }
505
506
507
508
repE (HsIf x y z)         = do
			      a <- repLE x
			      b <- repLE y
			      c <- repLE z
chak's avatar
chak committed
509
510
			      repCond a b c
repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
511
			       ; e2 <- addBinds ss (repLE e)
chak's avatar
chak committed
512
			       ; z <- repLetE ds e2
513
			       ; wrapGenSyns ss z }
chak's avatar
chak committed
514
-- FIXME: I haven't got the types here right yet
515
repE (HsDo DoExpr sts body ty) 
516
 = do { (ss,zs) <- repLSts sts; 
517
	body'	<- addBinds ss $ repLE body;
518
519
	ret	<- repNoBindSt body';	
        e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
520
        wrapGenSyns ss e }
521
repE (HsDo ListComp sts body ty) 
522
 = do { (ss,zs) <- repLSts sts; 
523
	body'	<- addBinds ss $ repLE body;
524
525
	ret	<- repNoBindSt body';	
        e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
526
        wrapGenSyns ss e }
527
528
repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } 
chak's avatar
chak committed
529
530
531
repE (ExplicitPArr ty es) = 
  panic "DsMeta.repE: No explicit parallel arrays yet"
repE (ExplicitTuple es boxed) 
532
  | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
chak's avatar
chak committed
533
  | otherwise		  = panic "DsMeta.repE: Can't represent unboxed tuples"
534
repE (RecordCon c _ flds)
535
 = do { x <- lookupLOcc c;
536
537
        fs <- repFields flds;
        repRecCon x fs }
538
repE (RecordUpd e flds _ _)
539
 = do { x <- repLE e;
540
541
        fs <- repFields flds;
        repRecUpd x fs }
542

543
repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
544
repE (ArithSeq _ aseq) =
chak's avatar
chak committed
545
  case aseq of
546
    From e              -> do { ds1 <- repLE e; repFrom ds1 }
chak's avatar
chak committed
547
    FromThen e1 e2      -> do 
548
549
		             ds1 <- repLE e1
			     ds2 <- repLE e2
chak's avatar
chak committed
550
551
			     repFromThen ds1 ds2
    FromTo   e1 e2      -> do 
552
553
			     ds1 <- repLE e1
			     ds2 <- repLE e2
chak's avatar
chak committed
554
555
			     repFromTo ds1 ds2
    FromThenTo e1 e2 e3 -> do 
556
557
558
			     ds1 <- repLE e1
			     ds2 <- repLE e2
			     ds3 <- repLE e3
chak's avatar
chak committed
559
			     repFromThenTo ds1 ds2 ds3
560
repE (PArrSeq _ aseq)     = panic "DsMeta.repE: parallel array seq.s missing"
561
repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
chak's avatar
chak committed
562
repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
563
564
565
566
567
568
569
570
571
repE (HsBracketOut _ _)   = panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSpliceE (HsSplice n _)) 
  = 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 e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
572
573
574
575

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

576
repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ) 
577
repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
578
  do { ss1 <- mkGenSyms (collectPatBinders p) 
579
     ; addBinds ss1 $ do {
580
     ; p1 <- repLP p
581
     ; (ss2,ds) <- repBinds wheres
582
583
584
     ; addBinds ss2 $ do {
     ; gs    <- repGuards guards
     ; match <- repMatch p1 gs ds
585
     ; wrapGenSyns (ss1++ss2) match }}}
586

587
repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
588
repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
589
  do { ss1 <- mkGenSyms (collectPatsBinders ps) 
590
     ; addBinds ss1 $ do {
591
       ps1 <- repLPs ps
592
     ; (ss2,ds) <- repBinds wheres
593
594
595
     ; addBinds ss2 $ do {
       gs <- repGuards guards
     ; clause <- repClause ps1 gs ds
596
     ; wrapGenSyns (ss1++ss2) clause }}}
597

598
repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
599
repGuards [L _ (GRHS [] e)]
600
  = do {a <- repLE e; repNormal a }
601
repGuards other 
602
603
604
605
  = do { zs <- mapM process other;
     let {(xs, ys) = unzip zs};
	 gd <- repGuarded (nonEmptyCoreList ys);
     wrapGenSyns (concat xs) gd }
606
  where 
607
    process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
608
    process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
609
610
           = do { x <- repLNormalGE e1 e2;
                  return ([], x) }
611
    process (L _ (GRHS ss rhs))
612
           = do (gs, ss') <- repLSts ss
613
		rhs' <- addBinds gs $ repLE rhs
614
                g <- repPatGE (nonEmptyCoreList ss') rhs'
615
                return (gs, g)
616

617
repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
618
repFields flds = do
619
620
        fnames <- mapM lookupLOcc (map fst flds)
        es <- mapM repLE (map snd flds)
621
622
        fs <- zipWithM repFieldExp fnames es
        coreList fieldExpQTyConName fs
623

624
625
626

-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
627
-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
-- 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.

650
651
652
repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts stmts = repSts (map unLoc stmts)

653
repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
654
repSts (BindStmt p e _ _ : ss) =
655
   do { e2 <- repLE e 
656
      ; ss1 <- mkGenSyms (collectPatBinders p) 
657
      ; addBinds ss1 $ do {
658
      ; p1 <- repLP p; 
659
660
661
662
      ; (ss2,zs) <- repSts ss
      ; z <- repBindSt p1 e2
      ; return (ss1++ss2, z : zs) }}
repSts (LetStmt bs : ss) =
663
   do { (ss1,ds) <- repBinds bs
664
665
666
      ; z <- repLetSt ds
      ; (ss2,zs) <- addBinds ss1 (repSts ss)
      ; return (ss1++ss2, z : zs) } 
667
repSts (ExprStmt e _ _ : ss) =       
668
   do { e2 <- repLE e
669
670
671
      ; z <- repNoBindSt e2 
      ; (ss2,zs) <- repSts ss
      ; return (ss2, z : zs) }
672
repSts [] = return ([],[])
673
674
675
repSts other = panic "Exotic Stmt in meta brackets"      


676
677
678
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
679

680
681
682
683
684
685
686
687
688
689
repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) 
repBinds EmptyLocalBinds
  = do	{ core_list <- coreList decQTyConName []
	; return ([], core_list) }

repBinds (HsIPBinds _)
  = panic "DsMeta:repBinds: can't do implicit parameters"

repBinds (HsValBinds decs)
 = do	{ let { bndrs = map unLoc (collectHsValBinders decs) }
690
691
692
693
		-- No need to worrry about detailed scopes within
		-- the binding group, because we are talking Names
		-- here, so we can safely treat it as a mutually 
		-- recursive group
694
	; ss        <- mkGenSyms bndrs
695
696
697
	; prs       <- addBinds ss (rep_val_binds decs)
	; core_list <- coreList decQTyConName 
				(de_loc (sort_by_loc prs))
698
	; return (ss, core_list) }
699

700
rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
701
-- Assumes: all the binders of the binding are alrady in the meta-env
702
703
rep_val_binds (ValBindsOut binds sigs)
 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
704
      ;	core2 <- rep_sigs' sigs
705
706
      ;	return (core1 ++ core2) }

707
rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
708
709
710
711
712
rep_binds binds = do { binds_w_locs <- rep_binds' binds
		     ; return (de_loc (sort_by_loc binds_w_locs)) }

rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_binds' binds = mapM rep_bind (bagToList binds)
713

714
rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
715
-- Assumes: all the binders of the binding are alrady in the meta-env
716
717
718
719

-- 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
720
721
rep_bind (L loc (FunBind { fun_id = fn, 
			   fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
722
 = do { (ss,wherecore) <- repBinds wheres
723
	; guardcore <- addBinds ss (repGuards guards)
724
725
726
727
728
	; fn'  <- lookupLBinder fn
	; p    <- repPvar fn'
	; ans  <- repVal p guardcore wherecore
	; ans' <- wrapGenSyns ss ans
	; return (loc, ans') }
729

730
rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
731
 =   do { ms1 <- mapM repClauseTup ms
732
	; fn' <- lookupLBinder fn
733
        ; ans <- repFun fn' (nonEmptyCoreList ms1)
734
        ; return (loc, ans) }
735

736
rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
737
 =   do { patcore <- repLP pat 
738
        ; (ss,wherecore) <- repBinds wheres
739
	; guardcore <- addBinds ss (repGuards guards)
740
741
742
        ; ans  <- repVal patcore guardcore wherecore
	; ans' <- wrapGenSyns ss ans
        ; return (loc, ans') }
743

744
rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
745
 =   do { v' <- lookupBinder v 
746
	; e2 <- repLE e
747
748
        ; x <- repNormal e2
        ; patcore <- repPvar v'
749
	; empty_decls <- coreList decQTyConName [] 
750
        ; ans <- repVal patcore x empty_decls
751
        ; return (srcLocSpan (getSrcLoc v), ans) }
752
753

-----------------------------------------------------------------------------
754
-- Since everything in a Bind is mutually recursive we need rename all
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
-- 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


-----------------------------------------------------------------------------
771
-- GHC allows a more general form of lambda abstraction than specified
772
773
774
775
776
-- 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.  

777
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
778
repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
779
 = do { let bndrs = collectPatsBinders ps ;
780
      ; ss  <- mkGenSyms bndrs
781
      ; lam <- addBinds ss (
782
		do { xs <- repLPs ps; body <- repLE e; repLam xs body })
783
      ; wrapGenSyns ss lam }
784
785
786
787
788

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

  
-----------------------------------------------------------------------------
789
--			Patterns
790
791
792
793
794
795
-- 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
796
repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
797
repLPs ps = do { ps' <- mapM repLP ps ;
798
		 coreList patQTyConName ps' }
799

800
repLP :: LPat Name -> DsM (Core TH.PatQ)
801
repLP (L _ p) = repP p
802

803
repP :: Pat Name -> DsM (Core TH.PatQ)
804
805
806
807
808
809
810
811
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 <- repLP p; repPtilde p1 }
repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
repP (ParPat p)        = repLP p 
repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
812
repP (ConPatIn dc details)
813
 = do { con_str <- lookupLOcc dc
814
      ; case details of
815
816
817
         PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
                            ; ps <- sequence $ map repLP (map snd pairs)
818
                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
819
                            ; fps' <- coreList fieldPatQTyConName fps
820
                            ; repPrec con_str fps' }
821
822
823
         InfixCon p1 p2 -> do { p1' <- repLP p1;
                                p2' <- repLP p2;
                                repPinfix p1' con_str p2' }
824
   }
825
826
repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
827
repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
828
829
repP other = panic "Exotic pattern inside meta brackets"

830
831
832
----------------------------------------------------------
-- Declaration ordering helpers

833
sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
834
835
836
sort_by_loc xs = sortBy comp xs
    where comp x y = compare (fst x) (fst y)

837
de_loc :: [(a, b)] -> [b]
838
839
de_loc = map snd

840
841
842
----------------------------------------------------------
--	The meta-environment

chak's avatar
chak committed
843
-- A name/identifier association for fresh names of locally bound entities
844
845
846
847
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
848
-- Generate a fresh name for a locally bound entity
849

850
851
mkGenSyms :: [Name] -> DsM [GenSymBind]
-- We can use the existing name.  For example:
852
853
854
855
856
--	[| \x_77 -> x_77 + x_77 |]
-- desugars to
--	do { x_77 <- genSym "x"; .... }
-- We use the same x_77 in the desugared program, but with the type Bndr
-- instead of Int
chak's avatar
chak committed
857
--
858
859
860
861
862
863
-- We do make it an Internal name, though (hence localiseName)
--
-- Nevertheless, it's monadic because we have to generate nameTy
mkGenSyms ns = do { var_ty <- lookupType nameTyConName
		  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }

864
	     
chak's avatar
chak committed
865
addBinds :: [GenSymBind] -> DsM a -> DsM a
866
867
868
-- 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) 
chak's avatar
chak committed
869
870
871
872
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m

-- Look up a locally bound name
--
873
874
875
lookupLBinder :: Located Name -> DsM (Core TH.Name)
lookupLBinder (L _ n) = lookupBinder n

876
lookupBinder :: Name -> DsM (Core TH.Name)
877
878
879
880
lookupBinder n 
  = do { mb_val <- dsLookupMetaEnv n;
	 case mb_val of
	    Just (Bound x) -> return (coreVar x)
881
	    other	   -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
882

chak's avatar
chak committed
883
884
-- Look up a name that is either locally bound or a global name
--
885
--  * If it is a global name, generate the "original name" representation (ie,
chak's avatar
chak committed
886
887
--   the <module>:<name> form) for the associated entity
--
888
lookupLOcc :: Located Name -> DsM (Core TH.Name)
889
890
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
891
892
893
lookupLOcc (L _ n) = lookupOcc n

lookupOcc :: Name -> DsM (Core TH.Name)
894
895
896
897
898
899
900
901
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) 
    }

902
903
904
905
906
907
908
909
globalVar :: Name -> DsM (Core TH.Name)
-- Not bound by the meta-env
-- Could be top-level; or could be local
--	f x = $(g [| x |])
-- Here the x will be local
globalVar name
  | isExternalName name
  = do	{ MkC mod <- coreStringLit name_mod
Simon Marlow's avatar
Simon Marlow committed
910
        ; MkC pkg <- coreStringLit name_pkg
911
	; MkC occ <- occNameLit name
Simon Marlow's avatar
Simon Marlow committed
912