DsMeta.hs 106 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
-----------------------------------------------------------------------------

16
module DsMeta( dsBracket,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
17 18
               templateHaskellNames, qTyConName, nameTyConName,
               liftName, liftStringName, expQTyConName, patQTyConName,
19
               decQTyConName, decsQTyConName, typeQTyConName,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
20 21 22
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
               quoteExpName, quotePatName, quoteDecName, quoteTypeName
                ) where
23

24 25
#include "HsVersions.h"

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
26
import {-# SOURCE #-}   DsExpr ( dsExpr )
27

Simon Marlow's avatar
Simon Marlow committed
28
import MatchLit
29 30
import DsMonad

31
import qualified Language.Haskell.TH as TH
32

33
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
34 35 36 37 38 39
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.
40
import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName )
41

Simon Marlow's avatar
Simon Marlow committed
42 43
import Module
import Id
44
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
45
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
46 47 48
import TcType
import TyCon
import TysWiredIn
49
import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
50
import CoreSyn
51
import MkCore
Simon Marlow's avatar
Simon Marlow committed
52 53 54 55
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
56
import Outputable
Simon Marlow's avatar
Simon Marlow committed
57
import Bag
58
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
59 60
import FastString
import ForeignCall
61
import Util
62

Simon Marlow's avatar
Simon Marlow committed
63 64 65
import Data.Maybe
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
66

67 68
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
69
-- Returns a CoreExpr of type TH.ExpQ
70 71 72
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

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

dreixel's avatar
dreixel committed
78
    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
79 80 81 82 83
    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"
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99

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


100
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
101
--                      Declarations
102 103
-------------------------------------------------------

104
repTopP :: LPat Name -> DsM (Core TH.PatQ)
105
repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
106
                 ; pat' <- addBinds ss (repLP pat)
107
                 ; wrapGenSyms ss pat' }
108

109
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
110
repTopDs group
111 112
 = do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
113
        ss <- mkGenSyms bndrs ;
114

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
115 116 117 118 119 120
        -- 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
        -- only "T", not "Foo:T" where Foo is the current module
121

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
122
        decls <- addBinds ss (do {
123
                        fix_ds  <- mapM repFixD (hs_fixds group) ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
124 125 126 127 128 129 130
                        val_ds  <- rep_val_binds (hs_valds group) ;
                        tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
                        inst_ds <- mapM repInstD (hs_instds group) ;
                        rule_ds <- mapM repRuleD (hs_ruleds group) ;
                        for_ds  <- mapM repForD  (hs_fords group) ;
                        -- more needed
                        return (de_loc $ sort_by_loc $
131
                                val_ds ++ catMaybes tycl_ds ++ fix_ds
132
                                       ++ inst_ds ++ rule_ds ++ for_ds) }) ;
133

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
134 135
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
136

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
137 138
        dec_ty <- lookupType decTyConName ;
        q_decs  <- repSequenceQ dec_ty core_list ;
139

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
140
        wrapGenSyms ss q_decs
141 142 143
      }


144 145 146
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
147 148
  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
                     , tv <- hsQTvBndrs qtvs]
149 150
  where
    sigs = case binds of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
151 152
             ValBindsIn  _ sigs -> sigs
             ValBindsOut _ sigs -> sigs
153 154 155 156 157 158 159 160 161 162


{- 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.
163
To achieve this we
164 165 166 167 168 169 170 171 172 173

  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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
174 175
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
176
        Data "T" [] [Con "MkT" []] []
177
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
178
        Data "Foo:T" [] [Con "Foo:MkT" []] []
179 180
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:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
181
        Data "T79" ....
182 183

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
184 185
        data T = MkT
        foo = reifyDecl T
186 187

then we must desugar to
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
188
        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
189

190 191
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
192 193 194 195
in repTyClD and repC.

-}

196 197
-- represent associated family instances
--
198
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
199

200 201 202
repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)

repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
203 204 205
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
206
       ; return (Just (loc, dec)) }
207

208
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
209
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
210
       ; tc_tvs <- mk_extra_tvs tc tvs defn
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
211 212
       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
                repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
213
       ; return (Just (loc, dec)) }
214

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
215 216 217
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
                             tcdTyVars = tvs, tcdFDs = fds,
                             tcdSigs = sigs, tcdMeths = meth_binds,
218
                             tcdATs = ats, tcdATDefs = [] }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
219 220
  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
       ; dec  <- addTyVarBinds tvs $ \bndrs ->
221
           do { cxt1   <- repLContext cxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
222 223 224
              ; sigs1  <- rep_sigs sigs
              ; binds1 <- rep_binds meth_binds
              ; fds1   <- repLFunDeps fds
225
              ; ats1   <- repFamilyDecls ats
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
226 227
              ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
              ; repClass cxt1 cls1 bndrs fds1 decls1
228
              }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
229
       ; return $ Just (loc, dec)
230
       }
231 232

-- Un-handled cases
233
repTyClD (L loc d) = putSrcSpanDs loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
234 235
                     do { warnDs (hang ds_msg 4 (ppr d))
                        ; return Nothing }
236

237
-------------------------
238 239 240 241 242 243
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
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
244
                      , dd_cons = cons, dd_derivs = mb_derivs })
245 246 247 248 249
  = 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 }
250 251
           DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
252

253 254 255 256
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
          -> LHsType Name
          -> DsM (Core TH.DecQ)
repSynDecl tc bndrs ty
257
  = do { ty1 <- repLTy ty
258 259 260 261 262
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour,
                                   fdLName   = tc,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
263 264 265
                                   fdTyVars  = tvs,
                                   fdKindSig = opt_kind }))
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
266 267
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
           do { flav <- repFamilyFlavour flavour
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
268
              ; case opt_kind of
269
                  Nothing -> repFamilyNoKind flav tc1 bndrs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
270
                  Just ki -> do { ki1 <- repLKind ki
271 272 273 274 275 276 277
                                ; repFamilyKind flav tc1 bndrs ki1 }
              }
       ; return (loc, dec)
       }

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
280
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
281
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
282 283 284
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
285
mk_extra_tvs tc tvs defn
286
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
287
  = do { extra_tvs <- go hs_kind
288
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
289 290
  | otherwise
  = return tvs
291 292 293 294 295 296
  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
297
                 ; hs_tv = L loc (KindedTyVar nm kind) }
298 299 300 301 302 303
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

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

305
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
306 307

-------------------------
308 309 310
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
311
repLFunDeps fds = repList funDepTyConName repLFunDep fds
312 313

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
314 315 316
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
                               ys' <- repList nameTyConName lookupBinder ys
                               repFunDep xs' ys'
317

318 319 320 321 322 323
-- represent family declaration flavours
--
repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
repFamilyFlavour TypeFamily = rep2 typeFamName []
repFamilyFlavour DataFamily = rep2 dataFamName []

324 325 326
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
327 328 329 330 331 332 333 334
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
335
       ; return (loc, dec) }
336

337 338 339 340 341
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 $ \_ ->
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
342 343
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
344
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
345 346 347 348 349 350
            --
            -- But we do NOT bring the binders of 'binds' into scope
            -- because they are properly regarded as occurrences
            -- For example, the method names should be bound to
            -- the selector Ids, not to fresh names (Trac #5410)
            --
351
            do { cxt1 <- repContext cxt
352
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
353 354
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
355
               ; binds1 <- rep_binds binds
356
               ; prags1 <- rep_sigs prags
357 358 359
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
360
               ; repInst cxt1 inst_ty1 decls }
361
 where
362
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
363

364 365 366
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns })
  = do { let tc_name = tyFamInstDeclLName decl
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
367
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388
       ; 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 })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
389
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
390
       ; let loc = getLoc tc_name
391
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
392
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
393
         do { tys1 <- repList typeQTyConName repLTy tys
394
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
395

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

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []
423
repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
424 425 426

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

430 431 432 433
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
434
       ; let rep_fn = case dir of
435 436 437 438 439 440
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; dec <- rep2 rep_fn [prec', name']
       ; return (loc, dec) }

441 442
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
443 444 445 446 447 448 449 450 451 452 453 454 455 456
  = 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]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
457
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
458
  = unLoc n : kvs ++ tvs
459 460 461

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
462
  = do { MkC n' <- lookupLBinder n
463 464
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
465
  = do { MkC n'  <- lookupLBinder n
466 467 468
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

Ian Lynagh's avatar
Ian Lynagh committed
469
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
470
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
471

472
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
473
--                      Constructors
474 475
-------------------------------------------------------

476
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
477
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
478
                     , con_details = details, con_res = ResTyH98 }))
479
  | null (hsQTvBndrs con_tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
480
  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]
481
       ; repConstr con1 details  }
482

483 484 485 486 487
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
488 489 490
       ; 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) }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
491
       ; binds <- mapM dupBinder con_tv_subst
492 493
       ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
494
    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]
495 496
       ; c'        <- repConstr con1 details
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
497
       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
498

499 500 501
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
502

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
503
mkGadtCtxt :: [Name]            -- Tyvars of the data type
504
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
505
           -> DsM (HsContext Name, [(Name,Name)])
506 507
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
508 509 510
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
511
-- Example:
512 513
-- 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)
514 515 516
--   returns
--     (b~[e], c~e), [d->a]
--
517 518 519 520 521 522 523 524 525
-- 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))

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

    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

545

546
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
547
repBangTy ty= do
548 549
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
550
  rep2 strictTypeName [s, t]
551
  where
552
    (str, ty') = case ty of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
553 554 555
                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
                   _                               -> (notStrictName, ty)
556 557

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
558
--                      Deriving clause
559 560
-------------------------------------------------------

561
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
562
repDerivs Nothing = coreList nameTyConName []
563
repDerivs (Just ctxt)
564
  = repList nameTyConName rep_deriv ctxt
565
  where
566
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
567
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
568 569 570 571 572
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
573 574 575 576 577 578


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

579
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
580 581 582
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

583
rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
584
        -- We silently ignore ones we don't recognise
585
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
586
                     return (concat sigs1) }
587

588
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
589 590
        -- Singleton => Ok
        -- Empty     => Too hard, signature ignored
591
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
dreixel's avatar
dreixel committed
592 593 594 595
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") ]

596 597
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
598
rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
599 600
rep_sig _                             = return []

601 602
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
           -> DsM (SrcSpan, Core TH.DecQ)
603
rep_ty_sig loc (L _ ty) nm
604 605 606 607
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
       ; sig <- repProto nm1 ty1
       ; return (loc, sig) }
608
  where
609 610 611 612 613
    -- 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 }
614
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
615 616
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
617
           ; repTForall bndrs1 ctxt1 ty1 }
618

619
    rep_ty ty = repTy ty
620

621

622
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
623
           -> InlinePragma      -- Never defaultInlinePragma
624
           -> SrcSpan
625 626
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
627 628 629 630 631
  = 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
632 633 634
       ; return [(loc, pragma)]
       }

635
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
636 637 638 639
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
640 641 642 643 644 645 646 647
       ; 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 }
648 649
       ; return [(loc, pragma)]
       }
650

651 652 653 654 655 656
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

657 658 659 660 661 662
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

663 664 665
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
666

667 668 669 670 671 672
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
673 674

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
675
--                      Types
676
-------------------------------------------------------
677

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
678
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
679 680
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
681 682
-- 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
683
-- meta environment and gets the *new* names on Core-level as an argument
684

685
addTyVarBinds tvs m
686
  = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
687 688 689
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
                    ; m kbs }
690 691 692
       ; wrapGenSyms freshNames term }
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
693

694
addTyClTyVarBinds :: LHsTyVarBndrs Name
695 696
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
697 698 699 700 701 702 703

-- 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
704
  = do { let tv_names = hsLKiTyVarNames tvs
705 706
       ; env <- dsGetMetaEnv
       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
707
            -- Make fresh names for the ones that are not already in scope
708 709
            -- This makes things work for family declarations

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
710 711 712
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
713 714 715

       ; wrapGenSyms freshNames term }
  where
716
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
717
                       ; repTyVarBndrWithKind tv v }
718 719 720

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
721
repTyVarBndrWithKind :: LHsTyVarBndr Name
722
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
723 724
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
  = repPlainTV nm
725
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
726
  = repLKind ki >>= repKindedTV nm
727

728 729
-- represent a type context
--
730 731 732
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

733
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
734
repContext ctxt = do preds <- repList predQTyConName repLPred ctxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
735
                     repCtxt preds
736

737 738
-- represent a type predicate
--
batterseapower's avatar
batterseapower committed
739
repLPred :: LHsType Name -> DsM (Core TH.PredQ)
740 741
repLPred (L _ p) = repPred p

batterseapower's avatar
batterseapower committed
742 743 744
repPred :: HsType Name -> DsM (Core TH.PredQ)
repPred ty
  | Just (cls, tys) <- splitHsClassTy_maybe ty
745 746
  = do
      cls1 <- lookupOcc cls
747 748
      tys1 <- repList typeQTyConName repLTy tys
      repClassP cls1 tys1
749
repPred (HsEqTy tyleft tyright)
750 751 752 753
  = do
      tyleft1  <- repLTy tyleft
      tyright1 <- repLTy tyright
      repEqualP tyleft1 tyright1
batterseapower's avatar
batterseapower committed
754 755
repPred ty
  = notHandled "Exotic predicate type" (ppr ty)
756

757 758
-- yield the representation of a list of types
--
759 760
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
761

762 763
-- represent a type
--
764 765 766
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

767
repTy :: HsType Name -> DsM (Core TH.TypeQ)
768
repTy (HsForAllTy _ tvs ctxt ty)  =
769
  addTyVarBinds tvs $ \bndrs -> do
770 771
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
772
    repTForall bndrs ctxt1 ty1
773

774
repTy (HsTyVar n)
775
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
776
                       repTvar tv1
777 778
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
779 780
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
781 782
  where
    occ = nameOccName n
783

784
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
785 786 787
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
788
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
789 790 791 792 793 794 795 796
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
797
repTy (HsPArrTy t)          = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
798 799 800
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
batterseapower's avatar
batterseapower committed
801
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
802 803 804
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
805
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
806 807
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
808
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
809 810
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
811 812
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
813
                                k1 <- repLKind k
814
                                repTSig t1 k1
815
repTy (HsSpliceTy splice _ _) = repSplice splice
816 817 818 819 820 821 822 823 824 825
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'
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
826
repTy ty                      = notHandled "Exotic form of type" (ppr ty)
827

828
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
829 830
repTyLit (HsNumTy i) = do dflags <- getDynFlags
                          rep2 numTyLitName [mkIntExpr dflags i]
831 832 833 834
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

835 836
-- represent a kind
--
837 838
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
839
  = do { let (kis, ki') = splitHsFunType ki
840 841 842 843 844
       ; 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
845
       }
846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868

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

870
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
871
--              Splices
872 873 874 875 876
-----------------------------------------------------------------------------

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
877
repSplice (HsSplice n _)
878 879
 = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
880 881 882 883
           Just (Splice e) -> do { e' <- dsExpr e
                                 ; return (MkC e') }
           _ -> pprPanic "HsSplice" (ppr n) }
                        -- Should not happen; statically checked
884

885
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
886
--              Expressions
887
-----------------------------------------------------------------------------
888

889
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
890
repLEs es = repList expQTyConName repLE es
891

892
-- FIXME: some of these panics should be converted into proper error messages
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
893 894
--        unless we can make sure that constructs, which are plainly not
--        supported in TH already lead to error messages at an earlier stage
895
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
896
repLE (L loc e) = putSrcSpanDs loc (repE e)
897

898
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
899
repE (HsVar x)            =
900
  do { mb_val <- dsLookupMetaEnv x
901
     ; case mb_val of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
902 903 904 905 906
        Nothing          -> do { str <- globalVar x
                               ; 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
907
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
908

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
909 910
        -- Remember, we're desugaring renamer output here, so
        -- HsOverlit can definitely occur
911 912
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
913 914
repE (HsLam (MG { mg_alts = [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = ms }))
915
                   = do { ms' <- mapM repMatchTup ms
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
916 917
                        ; core_ms <- coreList matchQTyConName ms'
                        ; repLamCase core_ms }
918
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
919

Ian Lynagh's avatar
Ian Lynagh committed
920
repE (OpApp e1 op _ e2) =
921 922
  do { arg1 <- repLE e1;
       arg2 <- repLE e2;
923
       the_op <- repLE op ;
924
       repInfixApp arg1 the_op arg2 }
Ian Lynagh's avatar
Ian Lynagh committed
925
repE (NegApp x _)        = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
926 927 928
                              a         <- repLE x
                              negateVar <- lookupOcc negateName >>= repVar
                              negateVar `repApp` a
929
repE (HsPar x)            = repLE x
930 931
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 }
932
repE (HsCase e (MG { mg_alts = ms }))
933 934
                          = do { arg <- repLE e
                               ; ms2 <- mapM repMatchTup ms
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
935 936
                               ; core_ms2 <- coreList matchQTyConName ms2
                               ; repCaseE arg core_ms2 }
937
repE (HsIf _ x y z)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
938 939 940 941
                              a <- repLE x
                              b <- repLE y
                              c <- repLE z
                              repCond a b c
942 943 944 945
repE (HsMultiIf _ alts)
  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
       ; expr' <- repMultiIf (nonEmptyCoreList alts')
       ; wrapGenSyms (concat binds) expr' }