DsMeta.hs 103 KB
Newer Older
1
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
2
3
4
--
-- (c) The University of Glasgow 2006
--
5
6
7
8
-- 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.
9
10
11
12
13
--
-- 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).
14
15
-----------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
16
17
18
19
20
21
22
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

23
module DsMeta( dsBracket,
24
	       templateHaskellNames, qTyConName, nameTyConName,
25
	       liftName, liftStringName, expQTyConName, patQTyConName,
26
               decQTyConName, decsQTyConName, typeQTyConName,
27
	       decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
28
	       quoteExpName, quotePatName, quoteDecName, quoteTypeName
29
	        ) where
30

31
32
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
35
import MatchLit
36
37
import DsMonad

38
import qualified Language.Haskell.TH as TH
39

40
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
41
42
43
44
45
46
import Class
import PrelNames
-- 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.
47
import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName )
48

Simon Marlow's avatar
Simon Marlow committed
49
50
import Module
import Id
51
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
52
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
53
54
55
import TcType
import TyCon
import TysWiredIn
56
import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
57
import CoreSyn
58
import MkCore
Simon Marlow's avatar
Simon Marlow committed
59
60
61
62
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
63
import Outputable
Simon Marlow's avatar
Simon Marlow committed
64
import Bag
65
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
66
67
import FastString
import ForeignCall
68
import Util
69

Simon Marlow's avatar
Simon Marlow committed
70
71
72
import Data.Maybe
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
73

74
75
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
76
-- Returns a CoreExpr of type TH.ExpQ
77
78
79
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

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

dreixel's avatar
dreixel committed
85
    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
86
87
88
89
90
    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

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


107
108
109
110
-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

111
repTopP :: LPat Name -> DsM (Core TH.PatQ)
112
repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
113
                 ; pat' <- addBinds ss (repLP pat)
114
                 ; wrapGenSyms ss pat' }
115

116
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
117
repTopDs group
118
119
 = do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
120
	ss <- mkGenSyms bndrs ;
121

122
123
124
125
126
	-- 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
127
	-- only "T", not "Foo:T" where Foo is the current module
128

129
	decls <- addBinds ss (do {
130
                        fix_ds  <- mapM repFixD (hs_fixds group) ;
131
			val_ds  <- rep_val_binds (hs_valds group) ;
132
			tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
133
			inst_ds <- mapM repInstD (hs_instds group) ;
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
134
135
			rule_ds <- mapM repRuleD (hs_ruleds group) ;
			for_ds  <- mapM repForD  (hs_fords group) ;
136
			-- more needed
137
			return (de_loc $ sort_by_loc $
138
                                val_ds ++ catMaybes tycl_ds ++ fix_ds
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
139
                                       ++ inst_ds ++ rule_ds ++ for_ds) }) ;
140

141
	decl_ty <- lookupType decQTyConName ;
142
	let { core_list = coreList' decl_ty decls } ;
143
144
145

	dec_ty <- lookupType decTyConName ;
	q_decs  <- repSequenceQ dec_ty core_list ;
146

147
	wrapGenSyms ss q_decs
148
149
150
      }


151
152
153
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
154
155
  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
                     , tv <- hsQTvBndrs qtvs]
156
157
158
159
160
161
162
163
164
165
166
167
168
169
  where
    sigs = case binds of
     	     ValBindsIn  _ sigs -> sigs
     	     ValBindsOut _ sigs -> sigs


{- Notes

Note [Scoped type variables in bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f :: forall a. a -> a
   f x = x::a
Here the 'forall a' brings 'a' into scope over the binding group.
170
To achieve this we
171
172
173
174
175
176
177
178
179
180

  a) Gensym a binding for 'a' at the same time as we do one for 'f'
     collecting the relevant binders with hsSigTvBinders

  b) When processing the 'forall', don't gensym

The relevant places are signposted with references to this Note

Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
181
182
183
184
185
186
187
188
189
190
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:
191
	data T = MkT
192
193
194
195
196
	foo = reifyDecl T

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

197
198
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
199
200
201
202
in repTyClD and repC.

-}

203
204
-- represent associated family instances
--
205
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
206

207
208
209
210
211
212
213
repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)

repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
  = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences]  
       ; dec <- addTyClTyVarBinds tvs $ \bndrs -> 
	        repSynDecl tc1 bndrs rhs
       ; return (Just (loc, dec)) }
214

215
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
216
217
  = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences]  
       ; tc_tvs <- mk_extra_tvs tc tvs defn
218
       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> 
219
	        repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
220
       ; return (Just (loc, dec)) }
221

222
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
223
224
		             tcdTyVars = tvs, tcdFDs = fds,
		             tcdSigs = sigs, tcdMeths = meth_binds, 
225
                             tcdATs = ats, tcdATDefs = [] }))
226
227
228
229
230
231
  = do { cls1 <- lookupLOcc cls 	-- See note [Binders and occurrences] 
       ; dec  <- addTyVarBinds tvs $ \bndrs -> 
           do { cxt1   <- repLContext cxt
 	      ; sigs1  <- rep_sigs sigs
 	      ; binds1 <- rep_binds meth_binds
	      ; fds1   <- repLFunDeps fds
232
              ; ats1   <- repFamilyDecls ats
233
 	      ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
234
 	      ; repClass cxt1 cls1 bndrs fds1 decls1 
235
236
237
              }
       ; return $ Just (loc, dec) 
       }
238
239

-- Un-handled cases
240
repTyClD (L loc d) = putSrcSpanDs loc $
241
		     do { warnDs (hang ds_msg 4 (ppr d))
242
			; return Nothing }
243

244
-------------------------
245
246
247
248
249
250
251
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
            -> [Name] -> HsDataDefn Name
            -> DsM (Core TH.DecQ)
repDataDefn tc bndrs opt_tys tv_names
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
		      , dd_cons = cons, dd_derivs = mb_derivs })
252
253
254
255
256
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
                          ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
257
258
           DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
259

260
261
262
263
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
          -> LHsType Name
          -> DsM (Core TH.DecQ)
repSynDecl tc bndrs ty
264
  = do { ty1 <- repLTy ty
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour,
                                   fdLName   = tc,
                                   fdTyVars  = tvs, 
		                   fdKindSig = opt_kind }))
  = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
           do { flav <- repFamilyFlavour flavour
	      ; case opt_kind of 
                  Nothing -> repFamilyNoKind flav tc1 bndrs
                  Just ki -> do { ki1 <- repLKind ki 
                                ; repFamilyKind flav tc1 bndrs ki1 }
              }
       ; return (loc, dec)
       }

repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
285
286

-------------------------
287
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name 
288
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
289
290
291
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
292
mk_extra_tvs tc tvs defn
293
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
294
  = do { extra_tvs <- go hs_kind
295
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
296
297
  | otherwise
  = return tvs
298
299
300
301
302
303
  where
    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
    go (L loc (HsFunTy kind rest))
      = do { uniq <- newUnique
           ; let { occ = mkTyVarOccFS (fsLit "t")
                 ; nm = mkInternalName uniq occ loc
304
                 ; hs_tv = L loc (KindedTyVar nm kind) }
305
306
307
308
309
310
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

    go (L _ (HsTyVar n))
      | n == liftedTypeKindTyConName
      = return []
311

312
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
313
314

-------------------------
315
316
317
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
318
repLFunDeps fds = repList funDepTyConName repLFunDep fds
319
320

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
321
322
323
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
                               ys' <- repList nameTyConName lookupBinder ys
                               repFunDep xs' ys'
324

325
326
327
328
329
330
-- represent family declaration flavours
--
repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
repFamilyFlavour TypeFamily = rep2 typeFamName []
repFamilyFlavour DataFamily = rep2 dataFamName []

331
332
333
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
334
335
336
337
338
339
340
341
repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
  = do { dec <- repTyFamInstD fi_decl
       ; return (loc, dec) }
repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
  = do { dec <- repDataFamInstD fi_decl
       ; return (loc, dec) }
repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
  = do { dec <- repClsInstD cls_decl
342
       ; return (loc, dec) }
343

344
345
346
347
348
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                         , cid_sigs = prags, cid_tyfam_insts = ats
                         , cid_datafam_insts = adts })
  = addTyVarBinds tvs $ \_ ->
349
	    -- We must bring the type variables into scope, so their
350
	    -- occurrences don't fail, even though the binders don't
351
352
353
354
355
356
357
358
            -- appear in the resulting data structure
	    --
	    -- But we do NOT bring the binders of 'binds' into scope
	    -- becuase they are properly regarded as occurrences
	    -- For example, the method names should be bound to
	    -- the selector Ids, not to fresh names (Trac #5410)
	    --
            do { cxt1 <- repContext cxt
359
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
360
361
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
362
               ; binds1 <- rep_binds binds
363
               ; prags1 <- rep_sigs prags
364
365
366
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
367
               ; repInst cxt1 inst_ty1 decls }
368
 where
369
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
370

371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns })
  = do { let tc_name = tyFamInstDeclLName decl
       ; tc <- lookupLOcc tc_name		-- See note [Binders and occurrences]  
       ; eqns1 <- mapM repTyFamEqn eqns
       ; eqns2 <- coreList tySynEqnQTyConName eqns1
       ; repTySynInst tc eqns2 }

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
                                                    , hswb_kvs = kv_names
                                                    , hswb_tvs = tv_names }
                                 , tfie_rhs = rhs }))
  = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
                             , hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { tys1 <- repLTys tys
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
            ; repTySynEqn tys2 rhs1 } }

repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
                                 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
                                 , dfid_defn = defn })
  = do { tc <- lookupLOcc tc_name 		-- See note [Binders and occurrences]  
397
       ; let loc = getLoc tc_name
398
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
399
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
400
         do { tys1 <- repList typeQTyConName repLTy tys
401
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
402

403
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
404
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
405
406
407
408
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
409
      cis' <- conv_cimportspec cis
410
      MkC str <- coreStringLit (static ++ chStr ++ cis')
411
412
413
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
414
415
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
416
417
    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
418
    conv_cimportspec CWrapper = return "wrapper"
419
    static = case cis of
420
                 CFunction (StaticTarget _ _ _) -> "static "
421
                 _ -> ""
422
423
424
    chStr = case mch of
            Nothing -> ""
            Just (Header h) -> unpackFS h ++ " "
425
repForD decl = notHandled "Foreign declaration" (ppr decl)
426
427
428
429

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []
430
repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
431
432
433

repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
434
repSafety PlayInterruptible = rep2 interruptibleName []
Ian Lynagh's avatar
Ian Lynagh committed
435
repSafety PlaySafe = rep2 safeName []
436

437
438
439
440
repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
repFixD (L loc (FixitySig name (Fixity prec dir)))
  = do { MkC name' <- lookupLOcc name
       ; MkC prec' <- coreIntLit prec
441
       ; let rep_fn = case dir of
442
443
444
445
446
447
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; dec <- rep2 rep_fn [prec', name']
       ; return (loc, dec) }

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
448
449
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
                     ; n'   <- coreStringLit $ unpackFS n
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

ruleBndrNames :: RuleBndr Name -> [Name]
ruleBndrNames (RuleBndr n)      = [unLoc n]
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })) 
  = unLoc n : kvs ++ tvs
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
466
467
468

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
469
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
470
471
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
472
  = do { MkC n'  <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
473
474
475
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

Ian Lynagh's avatar
Ian Lynagh committed
476
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
477
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
478

479
480
481
482
-------------------------------------------------------
-- 			Constructors
-------------------------------------------------------

483
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
484
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
485
                     , con_details = details, con_res = ResTyH98 }))
486
  | null (hsQTvBndrs con_tvs)
487
  = do { con1 <- lookupLOcc con 	-- See Note [Binders and occurrences] 
488
       ; repConstr con1 details  }
489

490
491
492
493
494
repC tvs (L _ (ConDecl { con_name = con
                       , con_qvars = con_tvs, con_cxt = L _ ctxt
                       , con_details = details
                       , con_res = res_ty }))
  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
495
496
497
       ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
                             , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }

498
499
500
       ; binds <- mapM dupBinder con_tv_subst 
       ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
501
    do { con1      <- lookupLOcc con 	-- See Note [Binders and occurrences] 
502
503
       ; c'        <- repConstr con1 details
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
504
       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
505

506
507
508
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
509
510

mkGadtCtxt :: [Name]		-- Tyvars of the data type
511
           -> ResType (LHsType Name)
512
	   -> DsM (HsContext Name, [(Name,Name)])
513
514
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
515
516
517
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
518
-- Example:
519
520
-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
--     mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
521
522
523
--   returns
--     (b~[e], c~e), [d->a]
--
524
525
526
527
528
529
530
531
532
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
mkGadtCtxt data_tvs (ResTyGADT res_ty)
  | let (head_ty, tys) = splitHsAppTys res_ty []
  , Just _ <- is_hs_tyvar head_ty
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

533
  | otherwise
534
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
535
536
537
538
539
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
540
       , not (in_subst subst con_tv)
541
542
543
544
545
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
546
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
547
548
549
550
551

    is_hs_tyvar (L _ (HsTyVar n))  = Just n   -- Type variables *and* tycons
    is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
    is_hs_tyvar _                  = Nothing

552

553
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
554
repBangTy ty= do
555
556
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
557
  rep2 strictTypeName [s, t]
558
  where
559
    (str, ty') = case ty of
560
561
		   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
		   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
562
		   _                               -> (notStrictName, ty)
563
564
565
566
567

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

568
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
569
repDerivs Nothing = coreList nameTyConName []
570
repDerivs (Just ctxt)
571
  = repList nameTyConName rep_deriv ctxt
572
  where
573
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
574
	-- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
575
576
577
578
579
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
580
581
582
583
584
585


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

586
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
587
588
589
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

590
rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
591
	-- We silently ignore ones we don't recognise
592
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
593
594
		     return (concat sigs1) }

595
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
596
597
	-- Singleton => Ok
	-- Empty     => Too hard, signature ignored
598
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
dreixel's avatar
dreixel committed
599
600
601
602
rep_sig (L _   (GenericSig nm _))     = failWithDs msg
  where msg = vcat  [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
                    , ptext (sLit "Default signatures are not supported by Template Haskell") ]

603
604
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
605
rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
606
607
rep_sig _                             = return []

608
609
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
           -> DsM (SrcSpan, Core TH.DecQ)
610
rep_ty_sig loc (L _ ty) nm
611
612
613
614
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
       ; sig <- repProto nm1 ty1
       ; return (loc, sig) }
615
  where
616
617
618
619
620
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
    rep_ty (HsForAllTy Explicit tvs ctxt ty)
      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                         ; repTyVarBndrWithKind tv name }
621
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
622
623
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
624
           ; repTForall bndrs1 ctxt1 ty1 }
625

626
    rep_ty ty = repTy ty
627

628

629
rep_inline :: Located Name
630
           -> InlinePragma	-- Never defaultInlinePragma
631
           -> SrcSpan
632
633
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
634
635
636
637
638
  = do { nm1    <- lookupLOcc nm
       ; inline <- repInline $ inl_inline ispec
       ; rm     <- repRuleMatch $ inl_rule ispec
       ; phases <- repPhases $ inl_act ispec
       ; pragma <- repPragInl nm1 inline rm phases
639
640
641
       ; return [(loc, pragma)]
       }

642
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
643
644
645
646
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
647
648
649
650
651
652
653
654
       ; phases <- repPhases $ inl_act ispec
       ; let inline = inl_inline ispec
       ; pragma <- if isEmptyInlineSpec inline
                   then -- SPECIALISE
                     repPragSpec nm1 ty1 phases
                   else -- SPECIALISE INLINE
                     do { inline1 <- repInline inline
                        ; repPragSpecInl nm1 ty1 inline1 phases }
655
656
       ; return [(loc, pragma)]
       }
657

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
658
659
660
661
662
663
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

664
665
666
667
668
669
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
670
671
672
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
673

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
674
675
676
677
678
679
repPhases :: Activation -> DsM (Core TH.Phases)
repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
                                ; dataCon' beforePhaseDataConName [arg] }
repPhases (ActiveAfter i)  = do { MkC arg <- coreIntLit i
                                ; dataCon' fromPhaseDataConName [arg] }
repPhases _                = dataCon allPhasesDataConName
680
681
682
683

-------------------------------------------------------
-- 			Types
-------------------------------------------------------
684

685
addTyVarBinds :: LHsTyVarBndrs Name	                       -- the binders to be added
686
687
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
chak's avatar
chak committed
688
689
-- 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
690
-- meta environment and gets the *new* names on Core-level as an argument
691

692
addTyVarBinds tvs m
693
  = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
694
       ; term <- addBinds freshNames $ 
695
696
	    	 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
	    	    ; m kbs }
697
698
699
       ; wrapGenSyms freshNames term }
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
chak's avatar
chak committed
700

701
addTyClTyVarBinds :: LHsTyVarBndrs Name
702
703
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
704
705
706
707
708
709
710

-- Used for data/newtype declarations, and family instances,
-- so that the nested type variables work right
--    instance C (T a) where
--      type W (T a) = blah
-- The 'a' in the type instance is the one bound by the instance decl
addTyClTyVarBinds tvs m
711
  = do { let tv_names = hsLKiTyVarNames tvs
712
713
714
715
716
717
       ; env <- dsGetMetaEnv
       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
       	    -- Make fresh names for the ones that are not already in scope
            -- This makes things work for family declarations

       ; term <- addBinds freshNames $ 
718
719
	    	 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
	    	    ; m kbs }
720
721
722

       ; wrapGenSyms freshNames term }
  where
723
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
724
                       ; repTyVarBndrWithKind tv v }
725
726
727
728
729

-- Produce kinded binder constructors from the Haskell tyvar binders
--
repTyVarBndrWithKind :: LHsTyVarBndr Name 
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
730
731
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
  = repPlainTV nm
732
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
733
  = repLKind ki >>= repKindedTV nm
734

chak's avatar
chak committed
735
736
-- represent a type context
--
737
738
739
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

740
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
741
742
repContext ctxt = do preds <- repList predQTyConName repLPred ctxt
		     repCtxt preds
743

chak's avatar
chak committed
744
745
-- represent a type predicate
--
batterseapower's avatar
batterseapower committed
746
repLPred :: LHsType Name -> DsM (Core TH.PredQ)
747
748
repLPred (L _ p) = repPred p

batterseapower's avatar
batterseapower committed
749
750
751
repPred :: HsType Name -> DsM (Core TH.PredQ)
repPred ty
  | Just (cls, tys) <- splitHsClassTy_maybe ty
752
753
  = do
      cls1 <- lookupOcc cls
754
755
      tys1 <- repList typeQTyConName repLTy tys
      repClassP cls1 tys1
756
repPred (HsEqTy tyleft tyright)
757
758
759
760
  = do
      tyleft1  <- repLTy tyleft
      tyright1 <- repLTy tyright
      repEqualP tyleft1 tyright1
batterseapower's avatar
batterseapower committed
761
762
repPred ty
  = notHandled "Exotic predicate type" (ppr ty)
763

chak's avatar
chak committed
764
765
-- yield the representation of a list of types
--
766
767
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
768

chak's avatar
chak committed
769
770
-- represent a type
--
771
772
773
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

774
repTy :: HsType Name -> DsM (Core TH.TypeQ)
775
repTy (HsForAllTy _ tvs ctxt ty)  =
776
  addTyVarBinds tvs $ \bndrs -> do
777
778
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
779
    repTForall bndrs ctxt1 ty1
780

781
repTy (HsTyVar n)
782
783
784
785
786
787
  | isTvOcc occ   = do tv1 <- lookupOcc n
		       repTvar tv1
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
  | otherwise	  = do tc1 <- lookupOcc n
		       repNamedTyCon tc1
788
789
  where
    occ = nameOccName n
790

791
repTy (HsAppTy f a)         = do
792
793
794
			        f1 <- repLTy f
			        a1 <- repLTy a
			        repTapp f1 a1
795
repTy (HsFunTy f a)         = do
796
797
798
799
800
801
802
803
804
805
806
807
			        f1   <- repLTy f
			        a1   <- repLTy a
			        tcon <- repArrowTyCon
			        repTapps tcon [f1, a1]
repTy (HsListTy t)	    = do
			        t1   <- repLTy t
			        tcon <- repListTyCon
			        repTapp tcon t1
repTy (HsPArrTy t)          = do
			        t1   <- repLTy t
			        tcon <- repTy (HsTyVar (tyConName parrTyCon))
			        repTapp tcon t1
batterseapower's avatar
batterseapower committed
808
repTy (HsTupleTy HsUnboxedTuple tys) = do
809
810
811
			        tys1 <- repLTys tys
			        tcon <- repUnboxedTupleTyCon (length tys)
			        repTapps tcon tys1
812
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
813
814
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
815
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
816
817
818
819
			    	   `nlHsAppTy` ty2)
repTy (HsParTy t)  	    = repLTy t
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
820
                                k1 <- repLKind k
821
                                repTSig t1 k1
822
repTy (HsSpliceTy splice _ _) = repSplice splice
823
824
825
826
827
828
829
830
831
832
repTy (HsExplicitListTy _ tys)  = do
                                    tys1 <- repLTys tys
                                    repTPromotedList tys1
repTy (HsExplicitTupleTy _ tys) = do
                                    tys1 <- repLTys tys
                                    tcon <- repPromotedTupleTyCon (length tys)
                                    repTapps tcon tys1
repTy (HsTyLit lit) = do
                        lit' <- repTyLit lit
                        repTLit lit'
833
repTy ty		      = notHandled "Exotic form of type" (ppr ty)
834

835
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
836
837
repTyLit (HsNumTy i) = do dflags <- getDynFlags
                          rep2 numTyLitName [mkIntExpr dflags i]
838
839
840
841
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

842
843
-- represent a kind
--
844
845
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
846
  = do { let (kis, ki') = splitHsFunType ki
847
848
849
850
851
       ; kis_rep <- mapM repLKind kis
       ; ki'_rep <- repNonArrowLKind ki'
       ; kcon <- repKArrow
       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
       ; foldrM f ki'_rep kis_rep
852
       }
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875

repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
repNonArrowLKind (L _ ki) = repNonArrowKind ki

repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
repNonArrowKind (HsTyVar name)
  | name == liftedTypeKindTyConName = repKStar
  | name == constraintKindTyConName = repKConstraint
  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar
  | otherwise                       = lookupOcc name >>= repKCon
repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f
                                          ; a' <- repLKind a
                                          ; repKApp f' a'
                                          }
repNonArrowKind (HsListTy k)        = do  { k' <- repLKind k
                                          ; kcon <- repKList
                                          ; repKApp kcon k'
                                          }
repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks
                                          ; kcon <- repKTuple (length ks)
                                          ; repKApps kcon ks'
                                          }
repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)
876

877
878
879
880
881
882
883
-----------------------------------------------------------------------------
-- 		Splices
-----------------------------------------------------------------------------

repSplice :: HsSplice Name -> DsM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know
884
repSplice (HsSplice n _)
885
886
887
888
889
890
891
 = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
	   Just (Splice e) -> do { e' <- dsExpr e
				 ; return (MkC e') }
	   _ -> pprPanic "HsSplice" (ppr n) }
			-- Should not happen; statically checked

chak's avatar
chak committed
892
-----------------------------------------------------------------------------
893
-- 		Expressions
chak's avatar
chak committed
894
-----------------------------------------------------------------------------
895

896
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
897
repLEs es = repList expQTyConName repLE es
898

chak's avatar
chak committed
899
900
901
-- 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
902
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
903
repLE (L loc e) = putSrcSpanDs loc (repE e)
904

905
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
chak's avatar
chak committed
906
repE (HsVar x)            =
907
  do { mb_val <- dsLookupMetaEnv x
chak's avatar
chak committed
908
     ; case mb_val of
chak's avatar
chak committed
909
	Nothing	         -> do { str <- globalVar x
chak's avatar
chak committed
910
911
912
913
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
Ian Lynagh's avatar
Ian Lynagh committed
914
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
915
916
917
918
919

	-- 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 }
920
921
repE (HsLam (MG { mg_alts = [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = ms }))
922
923
                   = do { ms' <- mapM repMatchTup ms
                        ; repLamCase (nonEmptyCoreList ms') }
924
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
925

Ian Lynagh's avatar
Ian Lynagh committed
926
repE (OpApp e1 op _ e2) =
927
928
  do { arg1 <- repLE e1;
       arg2 <- repLE e2;
929
       the_op <- repLE op ;
930
       repInfixApp arg1 the_op arg2 }
Ian Lynagh's avatar
Ian Lynagh committed
931
repE (NegApp x _)        = do
932
			      a         <- repLE x
chak's avatar
chak committed
933
934
			      negateVar <- lookupOcc negateName >>= repVar
			      negateVar `repApp` a
935
repE (HsPar x)            = repLE x
936
937
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 }
938
repE (HsCase e (MG { mg_alts = ms }))
939
940
941
                          = do { arg <- repLE e
                               ; ms2 <- mapM repMatchTup ms
                               ; repCaseE arg (nonEmptyCoreList ms2) }
942
repE (HsIf _ x y z)         = do
943
944
945
			      a <- repLE x
			      b <- repLE y
			      c <- repLE z
chak's avatar
chak committed
946
			      repCond a b c
947
948
949
950
repE (HsMultiIf _ alts)
  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
       ; expr' <- repMultiIf (nonEmptyCoreList alts')
       ; wrapGenSyms (concat binds) expr' }
chak's avatar
chak committed
951
repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
952
			       ; e2 <- addBinds ss (repLE e)
chak's avatar
chak committed
953
			       ; z <- repLetE ds e2
954
			       ; wrapGenSyms ss z }
955

chak's avatar
chak committed
956
-- FIXME: I haven't got the types here right yet
957
repE e@(HsDo ctxt sts _)
958
 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
959
 = do { (ss,zs) <- repLSts sts;
960
        e'      <- repDoE (nonEmptyCoreList zs);
961
        wrapGenSyms ss e' }
962
963

 | ListComp <- ctxt
964
 = do { (ss,zs) <- repLSts sts;
965
        e'      <- repComp (nonEmptyCoreList zs);
966
        wrapGenSyms ss e' }