DsMeta.hs 111 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
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
261
repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
262
                                   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
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283
           case (opt_kind, info) of 
                  (Nothing, ClosedTypeFamily eqns) ->
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; repClosedFamilyNoKind tc1 bndrs eqns2 }
                  (Just ki, ClosedTypeFamily eqns) ->
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; ki1 <- repLKind ki
                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }              
                  (Nothing, _) ->
                    do { info' <- repFamilyInfo info
                       ; repFamilyNoKind info' tc1 bndrs }
                  (Just ki, _) ->
                    do { info' <- repFamilyInfo info
                       ; ki1 <- repLKind ki 
                       ; repFamilyKind info' tc1 bndrs ki1 }
284 285 286 287 288
       ; return (loc, dec)
       }

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
291
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
292
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
293 294 295
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
296
mk_extra_tvs tc tvs defn
297
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
298
  = do { extra_tvs <- go hs_kind
299
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
300 301
  | otherwise
  = return tvs
302 303 304 305 306 307
  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
308
                 ; hs_tv = L loc (HsTyVarBndr nm (Just kind) Nothing) }
309 310 311 312 313 314
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

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

316
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
317 318

-------------------------
319 320 321
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
322
repLFunDeps fds = repList funDepTyConName repLFunDep fds
323 324

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
325 326 327
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
                               ys' <- repList nameTyConName lookupBinder ys
                               repFunDep xs' ys'
328

329 330
-- represent family declaration flavours
--
331 332 333 334
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
repFamilyInfo DataFamily          = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
335

336 337 338
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
339 340 341 342 343 344 345 346
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
347
       ; return (loc, dec) }
348

349 350 351 352 353
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
354 355
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
356
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
357 358 359 360 361 362
            --
            -- 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)
            --
363
            do { cxt1 <- repContext cxt
364
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
365 366
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
367
               ; binds1 <- rep_binds binds
368
               ; prags1 <- rep_sigs prags
369 370 371
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
372
               ; repInst cxt1 inst_ty1 decls }
373
 where
374
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
375

376
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
377
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
378
  = do { let tc_name = tyFamInstDeclLName decl
379 380 381
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]  
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399

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
400
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
401
       ; let loc = getLoc tc_name
402
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
403
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
404
         do { tys1 <- repList typeQTyConName repLTy tys
405
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
406

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

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []
434
repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
435 436 437

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

441 442 443 444
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
445
       ; let rep_fn = case dir of
446 447 448 449 450 451
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; dec <- rep2 rep_fn [prec', name']
       ; return (loc, dec) }

452 453
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
454 455 456 457 458 459 460 461 462 463 464 465 466 467
  = 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
468
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
469
  = unLoc n : kvs ++ tvs
470 471 472

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
473
  = do { MkC n' <- lookupLBinder n
474 475
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
476
  = do { MkC n'  <- lookupLBinder n
477 478 479
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

Ian Lynagh's avatar
Ian Lynagh committed
480
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
481
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
482

483
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
484
--                      Constructors
485 486
-------------------------------------------------------

487
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
488
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
489
                     , con_details = details, con_res = ResTyH98 }))
490
  | null (hsQTvBndrs con_tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
491
  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]
492
       ; repConstr con1 details  }
493

494 495 496 497 498
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
499 500 501
       ; 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
502
       ; binds <- mapM dupBinder con_tv_subst
503 504
       ; 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
505
    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]
506 507
       ; c'        <- repConstr con1 details
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
508
       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
509

510 511 512
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
513

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
514
mkGadtCtxt :: [Name]            -- Tyvars of the data type
515
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
516
           -> DsM (HsContext Name, [(Name,Name)])
517 518
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
519 520 521
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
522
-- Example:
523 524
-- 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)
525 526 527
--   returns
--     (b~[e], c~e), [d->a]
--
528 529 530 531
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
mkGadtCtxt data_tvs (ResTyGADT res_ty)
532
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
533 534 535
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

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

    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

555

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

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
568
--                      Deriving clause
569 570
-------------------------------------------------------

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


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

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

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

598
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
599 600
        -- Singleton => Ok
        -- Empty     => Too hard, signature ignored
601
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
dreixel's avatar
dreixel committed
602 603 604 605
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") ]

606 607
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
608
rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
609 610
rep_sig _                             = return []

611 612
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
           -> DsM (SrcSpan, Core TH.DecQ)
613
rep_ty_sig loc (L _ ty) nm
614 615 616 617
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
       ; sig <- repProto nm1 ty1
       ; return (loc, sig) }
618
  where
619 620 621 622 623
    -- 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 }
624
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
625 626
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
627
           ; repTForall bndrs1 ctxt1 ty1 }
628

629
    rep_ty ty = repTy ty
630

631

632
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
633
           -> InlinePragma      -- Never defaultInlinePragma
634
           -> SrcSpan
635 636
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
637 638 639 640 641
  = 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
642 643 644
       ; return [(loc, pragma)]
       }

645
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
646 647 648 649
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
650 651 652 653 654 655 656 657
       ; 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 }
658 659
       ; return [(loc, pragma)]
       }
660

661 662 663 664 665 666
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

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

673 674 675
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
676

677 678 679 680 681 682
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
683 684

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
685
--                      Types
686
-------------------------------------------------------
687

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

695
addTyVarBinds tvs m
696
  = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
697 698 699
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
                    ; m kbs }
700 701 702
       ; wrapGenSyms freshNames term }
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
703

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
720 721 722
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
723 724 725

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

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
731
repTyVarBndrWithKind :: LHsTyVarBndr Name
732
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
733
repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing Nothing)) nm
734
  = repPlainTV nm
735
repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) Nothing)) nm
736
  = repLKind ki >>= repKindedTV nm
737 738 739 740 741 742
repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing (Just r))) nm
  = repRole r >>= repRoledTV nm
repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) (Just r))) nm
  = do { ki' <- repLKind ki
       ; r'  <- repRole r
       ; repKindedRoledTV nm ki' r' }
743

744 745
-- represent a type context
--
746 747 748
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

749
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
750
repContext ctxt = do preds <- repList predQTyConName repLPred ctxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
751
                     repCtxt preds
752

753 754
-- represent a type predicate
--
batterseapower's avatar
batterseapower committed
755
repLPred :: LHsType Name -> DsM (Core TH.PredQ)
756 757
repLPred (L _ p) = repPred p

batterseapower's avatar
batterseapower committed
758 759 760
repPred :: HsType Name -> DsM (Core TH.PredQ)
repPred ty
  | Just (cls, tys) <- splitHsClassTy_maybe ty
761 762
  = do
      cls1 <- lookupOcc cls
763 764
      tys1 <- repList typeQTyConName repLTy tys
      repClassP cls1 tys1
765
repPred (HsEqTy tyleft tyright)
766 767 768 769
  = do
      tyleft1  <- repLTy tyleft
      tyright1 <- repLTy tyright
      repEqualP tyleft1 tyright1
batterseapower's avatar
batterseapower committed
770 771
repPred ty
  = notHandled "Exotic predicate type" (ppr ty)
772

773 774
-- yield the representation of a list of types
--
775 776
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
777

778 779
-- represent a type
--
780 781 782
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

783
repTy :: HsType Name -> DsM (Core TH.TypeQ)
784
repTy (HsForAllTy _ tvs ctxt ty)  =
785
  addTyVarBinds tvs $ \bndrs -> do
786 787
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
788
    repTForall bndrs ctxt1 ty1
789

790
repTy (HsTyVar n)
791
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
792
                       repTvar tv1
793 794
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
795 796
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
797 798
  where
    occ = nameOccName n
799

800
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
801 802 803
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
804
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
805 806 807 808 809 810 811 812
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
813
repTy (HsPArrTy t)          = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
814 815 816
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
batterseapower's avatar
batterseapower committed
817
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
818 819 820
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
821
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
822 823
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
824
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
825 826
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
827 828
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
829
                                k1 <- repLKind k
830
                                repTSig t1 k1
831
repTy (HsSpliceTy splice _ _) = repSplice splice
832 833 834 835 836 837 838 839 840 841
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
842
repTy ty                      = notHandled "Exotic form of type" (ppr ty)
843

844
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
845 846
repTyLit (HsNumTy i) = do dflags <- getDynFlags
                          rep2 numTyLitName [mkIntExpr dflags i]
847 848 849 850
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

851 852
-- represent a kind
--
853 854
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
855
  = do { let (kis, ki') = splitHsFunType ki
856 857 858 859 860
       ; 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
861
       }
862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884

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

886 887 888 889 890
repRole :: Role -> DsM (Core TH.Role)
repRole Nominal          = rep2 nominalName []
repRole Representational = rep2 representationalName []
repRole Phantom          = rep2 phantomName []

891
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
892
--              Splices
893 894 895 896 897
-----------------------------------------------------------------------------

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
898
repSplice (HsSplice n _)
899 900
 = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
901 902 903 904
           Just (Splice e) -> do { e' <- dsExpr e
                                 ; return (MkC e') }
           _ -> pprPanic "HsSplice" (ppr n) }
                        -- Should not happen; statically checked
905

906
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
907
--              Expressions
908
-----------------------------------------------------------------------------
909

910
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
911
repLEs es = repList expQTyConName repLE es
912

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

919
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
920
repE (HsVar x)            =
921
  do { mb_val <- dsLookupMetaEnv x
922
     ; case mb_val of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
923 924 925 926 927
        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
928
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
929

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
930 931
        -- Remember, we're desugaring renamer output here, so
        -- HsOverlit can definitely occur
932 933
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
934 935
repE (HsLam (MG { mg_alts = [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = ms }))
936
                   = do { ms' <- mapM repMatchTup ms
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
937 938
                        ; core_ms <- coreList matchQTyConName ms'
                        ; repLamCase core_ms }
939
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
940

Ian Lynagh's avatar
Ian Lynagh committed
941
repE (OpApp e1 op _ e2) =
942 943
  do { arg1 <- repLE e1;
       arg2 <- repLE e2;
944
       the_op <- repLE op ;
945
       repInfixApp arg1 the_op arg2 }
Ian Lynagh's avatar
Ian Lynagh committed
946
repE (NegApp x _)        = do
gmainlan@microsoft.com's avatar