DsMeta.hs 64.8 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 )
25
import DsUtils    ( mkListExpr, mkStringExpr, mkCoreTup, 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
repTyClD (L loc d) = putSrcSpanDs loc $
217
		     do { warnDs (hang ds_msg 4 (ppr d))
218
			; 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
repInstD' (L loc (InstDecl ty binds _ _))		-- Ignore user pragmas for now
235
236
237
238
239
240
241
242
243
244
245
246
247
248
 = 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
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
259
      cis' <- conv_cimportspec cis
260
261
262
      MkC str <- coreStringLit $ static
                              ++ unpackFS ch ++ " "
                              ++ unpackFS cn ++ " "
263
                              ++ cis'
264
265
266
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
267
268
269
270
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
    conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
    conv_cimportspec CWrapper = return "wrapper"
271
272
273
    static = case cis of
                 CFunction (StaticTarget _) -> "static "
                 _ -> ""
274
repForD decl = notHandled "Foreign declaration" (ppr decl)
275
276
277
278
279
280
281
282
283
284

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

285
286
ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")

287
288
289
290
-------------------------------------------------------
-- 			Constructors
-------------------------------------------------------

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

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

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

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


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

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

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

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

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


-------------------------------------------------------
-- 			Types
-------------------------------------------------------
362

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

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

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

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

395
repPred :: HsPred Name -> DsM (Core TH.TypeQ)
chak's avatar
chak committed
396
397
repPred (HsClassP cls tys) = do
			       tcon <- repTy (HsTyVar cls)
398
			       tys1 <- repLTys tys
chak's avatar
chak committed
399
			       repTapps tcon tys1
400
repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
chak's avatar
chak committed
401
402
403

-- 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
451
repTy (HsPredTy pred)             = repPred pred
452
453
repTy ty@(HsNumTy _)              = notHandled "Number types (for generics)" (ppr ty)
repTy ty			  = notHandled "Exotic form of type" (ppr ty)
454
455


chak's avatar
chak committed
456
-----------------------------------------------------------------------------
457
-- 		Expressions
chak's avatar
chak committed
458
-----------------------------------------------------------------------------
459

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

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

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

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

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

540
repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
541
repE (ArithSeq _ aseq) =
chak's avatar
chak committed
542
  case aseq of
543
    From e              -> do { ds1 <- repLE e; repFrom ds1 }
chak's avatar
chak committed
544
    FromThen e1 e2      -> do 
545
546
		             ds1 <- repLE e1
			     ds2 <- repLE e2
chak's avatar
chak committed
547
548
			     repFromThen ds1 ds2
    FromTo   e1 e2      -> do 
549
550
			     ds1 <- repLE e1
			     ds2 <- repLE e2
chak's avatar
chak committed
551
552
			     repFromTo ds1 ds2
    FromThenTo e1 e2 e3 -> do 
553
554
555
			     ds1 <- repLE e1
			     ds2 <- repLE e2
			     ds3 <- repLE e3
chak's avatar
chak committed
556
			     repFromThenTo ds1 ds2 ds3
557
558
559
560
561
repE (HsSpliceE (HsSplice n _)) 
  = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
		 Just (Splice e) -> do { e' <- dsExpr e
				       ; return (MkC e') }
562
563
		 other -> pprPanic "HsSplice" (ppr n) }
			-- Should not happen; statically checked
564

565
566
567
568
569
repE e@(PArrSeq {})      = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {})    = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {})        = notHandled "Cost centres" (ppr e)
repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
repE e 			 = notHandled "Expression form" (ppr e)
570
571
572
573

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

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

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

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

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

623
624
625

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

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

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


675
676
677
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
678

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

684
repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
685
686
687

repBinds (HsValBinds decs)
 = do	{ let { bndrs = map unLoc (collectHsValBinders decs) }
688
689
690
691
		-- 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
692
	; ss        <- mkGenSyms bndrs
693
694
695
	; prs       <- addBinds ss (rep_val_binds decs)
	; core_list <- coreList decQTyConName 
				(de_loc (sort_by_loc prs))
696
	; return (ss, core_list) }
697

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

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
rep_bind other = panic "rep_bind: AbsBinds"

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


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

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

787
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
788
789
790

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

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

805
repP :: Pat Name -> DsM (Core TH.PatQ)
806
807
808
809
810
811
812
813
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 }
814
repP (ConPatIn dc details)
815
 = do { con_str <- lookupLOcc dc
816
      ; case details of
817
         PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
818
819
         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
                            ; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
820
                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
821
                            ; fps' <- coreList fieldPatQTyConName fps
822
                            ; repPrec con_str fps' }
823
824
825
         InfixCon p1 p2 -> do { p1' <- repLP p1;
                                p2' <- repLP p2;
                                repPinfix p1' con_str p2' }
826
   }
827
repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
828
829
830
831
832
833
834
835
836
837
repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
	-- The problem is to do with scoped type variables.
	-- To implement them, we have to implement the scoping rules
	-- here in DsMeta, and I don't want to do that today!
	--	 do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
	--	repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
	--	repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]

repP other = notHandled "Exotic pattern" (ppr other)
838

839
840
841
----------------------------------------------------------
-- Declaration ordering helpers

842
sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
843
844
845
sort_by_loc xs = sortBy comp xs
    where comp x y = compare (fst x) (fst y)

846
de_loc :: [(a, b)] -> [b]
847
848
de_loc = map snd

849
850
851
----------------------------------------------------------
--	The meta-environment

chak's avatar
chak committed
852
-- A name/identifier association for fresh names of locally bound entities
853
854
855
856
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
857
-- Generate a fresh name for a locally bound entity
858

859
860
mkGenSyms :: [Name] -> DsM [GenSymBind]
-- We can use the existing name.  For example:
861
862
863
864
865
--	[| \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
866
--
867
868
869
870
871
872
-- 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] }

873