DsMeta.hs 104 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
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Gabor Greif's avatar
typos  
Gabor Greif committed
11
-- in prelude/PrelNames.  It's much more convenient to do it here, because
12 13
-- 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) ;
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
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
            -- appear in the resulting data structure
	    --
	    -- But we do NOT bring the binders of 'binds' into scope
Gabor Greif's avatar
typos  
Gabor Greif committed
354
	    -- because they are properly regarded as occurrences
355 356 357 358
	    -- 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) }

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
466 467 468

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
469
  = do { MkC n' <- lookupLBinder n
470 471
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
472
  = do { MkC n'  <- lookupLBinder n
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
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
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
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

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)

670 671 672
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
673

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

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

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

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

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

892
-----------------------------------------------------------------------------
893
-- 		Expressions
894
-----------------------------------------------------------------------------
895

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

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)
906
repE (HsVar x)            =
907
  do { mb_val <- dsLookupMetaEnv x
908
     ; case mb_val of
909
	Nothing	         -> do { str <- globalVar x
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
                   = do { ms' <- mapM repMatchTup ms
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
923 924
                        ; core_ms <- coreList matchQTyConName ms'
                        ; repLamCase core_ms }
925
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
926

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

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

 | ListComp <- ctxt
966
 = do { (ss,zs) <- repLSts sts;
967
        e'      <- repComp (nonEmptyCoreList zs);
968
        wrapGenSyms ss e' }
969 970

  | otherwise
971
  = notHandled "mdo, monad comprehension and [: :]" (ppr e)
972

973
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
Ian Lynagh's avatar
Ian Lynagh committed
974
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
975
repE e@(ExplicitTuple es boxed)
976
  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
977 978
  | isBoxed boxed              = do { xs <- repLEs [e | Present e <- es]; repTup xs }
  | otherwise                  = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
979

980
repE (RecordCon c _ flds)
981
 = do { x <- lookupLOcc c;
982 983
        fs <- repFields flds;
        repRecCon x fs }
984
repE (RecordUpd e flds _ _ _)