DsMeta.hs 111 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
4 5 6
--
-- (c) The University of Glasgow 2006
--
7 8 9 10
-- 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.
11 12
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Gabor Greif's avatar
typos  
Gabor Greif committed
13
-- in prelude/PrelNames.  It's much more convenient to do it here, because
14 15
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
16 17
-----------------------------------------------------------------------------

18
module DsMeta( dsBracket,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
19 20
               templateHaskellNames, qTyConName, nameTyConName,
               liftName, liftStringName, expQTyConName, patQTyConName,
21
               decQTyConName, decsQTyConName, typeQTyConName,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
22
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
23
               quoteExpName, quotePatName, quoteDecName, quoteTypeName,
24 25
               tExpTyConName, tExpDataConName, unTypeName, unTypeQName,
               unsafeTExpCoerceName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
26
                ) where
27

28 29
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
32
import MatchLit
33 34
import DsMonad

35
import qualified Language.Haskell.TH as TH
36

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

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

Simon Marlow's avatar
Simon Marlow committed
67 68 69
import Data.Maybe
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
70

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

77 78
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
79
  where
80
    new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n, e) <- splices]
81

dreixel's avatar
dreixel committed
82
    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
83 84 85 86 87
    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"
88
    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104

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


105
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
106
--                      Declarations
107 108
-------------------------------------------------------

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
120 121 122 123 124 125
        -- 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
126

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
127
        decls <- addBinds ss (do {
128
                        fix_ds  <- mapM repFixD (hs_fixds group) ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
129
                        val_ds  <- rep_val_binds (hs_valds group) ;
130 131
                        tycl_ds <- mapM repTyClD (tyClGroupConcat (hs_tyclds group)) ;
                        role_ds <- mapM repRoleD (concatMap group_roles (hs_tyclds group)) ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
132 133 134 135 136
                        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 $
137
                                val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds
138
                                       ++ inst_ds ++ rule_ds ++ for_ds) }) ;
139

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
140 141
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
142

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
143 144
        dec_ty <- lookupType decTyConName ;
        q_decs  <- repSequenceQ dec_ty core_list ;
145

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
146
        wrapGenSyms ss q_decs
147 148 149
      }


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


{- 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.
169
To achieve this we
170 171 172 173 174 175 176 177 178 179

  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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
180 181
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
182
        Data "T" [] [Con "MkT" []] []
183
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
184
        Data "Foo:T" [] [Con "Foo:MkT" []] []
185 186
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
187
        Data "T79" ....
188 189

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
190 191
        data T = MkT
        foo = reifyDecl T
192 193

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

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

-}

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

206 207 208
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
209 210 211
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
212
       ; return (Just (loc, dec)) }
213

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

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

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

243 244 245 246 247 248 249 250 251
-------------------------
repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRoleD (L loc (RoleAnnotDecl tycon roles))
  = do { tycon1 <- lookupLOcc tycon
       ; roles1 <- mapM repRole roles
       ; roles2 <- coreList roleTyConName roles1
       ; dec <- repRoleAnnotD tycon1 roles2
       ; return (loc, dec) }

252
-------------------------
253 254 255 256 257 258
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
259
                      , dd_cons = cons, dd_derivs = mb_derivs })
260 261 262 263 264
  = 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 }
265 266
           DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
267

268 269 270 271
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
          -> LHsType Name
          -> DsM (Core TH.DecQ)
repSynDecl tc bndrs ty
272
  = do { ty1 <- repLTy ty
273 274 275
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
276
repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
277
                                   fdLName   = tc,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
278 279 280
                                   fdTyVars  = tvs,
                                   fdKindSig = opt_kind }))
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
281
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
282
           case (opt_kind, info) of
283 284 285 286 287 288 289 290
                  (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
291
                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
292 293 294 295 296
                  (Nothing, _) ->
                    do { info' <- repFamilyInfo info
                       ; repFamilyNoKind info' tc1 bndrs }
                  (Just ki, _) ->
                    do { info' <- repFamilyInfo info
297
                       ; ki1 <- repLKind ki
298
                       ; repFamilyKind info' tc1 bndrs ki1 }
299 300 301 302 303
       ; return (loc, dec)
       }

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
306
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
307
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
308 309 310
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
311
mk_extra_tvs tc tvs defn
312
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
313
  = do { extra_tvs <- go hs_kind
314
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
315 316
  | otherwise
  = return tvs
317 318 319 320 321 322
  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
323
                 ; hs_tv = L loc (KindedTyVar nm kind) }
324 325 326 327 328 329
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

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

331
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
332 333

-------------------------
334 335 336
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
337
repLFunDeps fds = repList funDepTyConName repLFunDep fds
338 339

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
340 341 342
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
                               ys' <- repList nameTyConName lookupBinder ys
                               repFunDep xs' ys'
343

344 345
-- represent family declaration flavours
--
346 347 348 349
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
repFamilyInfo DataFamily          = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
350

351 352 353
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
354 355 356 357 358 359 360 361
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
362
       ; return (loc, dec) }
363

364 365 366 367 368
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
369 370
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
371
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
372 373 374 375 376 377
            --
            -- 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)
            --
378
            do { cxt1 <- repContext cxt
379
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
380 381
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
382
               ; binds1 <- rep_binds binds
383
               ; prags1 <- rep_sigs prags
384 385 386
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
387
               ; repInst cxt1 inst_ty1 decls }
388
 where
389
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
390

391
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
392
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
393
  = do { let tc_name = tyFamInstDeclLName decl
394
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
395 396
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
397 398

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
399 400 401 402
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
403 404 405 406 407 408 409 410 411 412 413 414
  = 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
415
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
416
       ; let loc = getLoc tc_name
417
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
418
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
419
         do { tys1 <- repList typeQTyConName repLTy tys
420
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
421

422
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
423
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
424 425 426 427
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
428
      cis' <- conv_cimportspec cis
429
      MkC str <- coreStringLit (static ++ chStr ++ cis')
430 431 432
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
433 434
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
435 436
    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
437
    conv_cimportspec CWrapper = return "wrapper"
438
    static = case cis of
439
                 CFunction (StaticTarget _ _ _) -> "static "
440
                 _ -> ""
441 442 443
    chStr = case mch of
            Nothing -> ""
            Just (Header h) -> unpackFS h ++ " "
444
repForD decl = notHandled "Foreign declaration" (ppr decl)
445 446 447 448

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []
449
repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
450 451 452

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

456 457 458 459
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
460
       ; let rep_fn = case dir of
461 462 463 464 465 466
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; dec <- rep2 rep_fn [prec', name']
       ; return (loc, dec) }

467 468
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
469 470 471 472 473 474 475 476 477 478 479 480 481 482
  = 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
483
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
484
  = unLoc n : kvs ++ tvs
485 486 487

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
488
  = do { MkC n' <- lookupLBinder n
489 490
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
491
  = do { MkC n'  <- lookupLBinder n
492 493 494
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

Ian Lynagh's avatar
Ian Lynagh committed
495
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
496
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
497

498
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
499
--                      Constructors
500 501
-------------------------------------------------------

502
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
503
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
504
                     , con_details = details, con_res = ResTyH98 }))
505
  | null (hsQTvBndrs con_tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
506
  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]
507
       ; repConstr con1 details  }
508

509 510 511 512 513
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
514 515 516
       ; 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
517
       ; binds <- mapM dupBinder con_tv_subst
518 519
       ; 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
520
    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]
521 522
       ; c'        <- repConstr con1 details
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
523
       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
524

525 526 527
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
528

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
529
mkGadtCtxt :: [Name]            -- Tyvars of the data type
530
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
531
           -> DsM (HsContext Name, [(Name,Name)])
532 533
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
534 535 536
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
537
-- Example:
538 539
-- 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)
540 541 542
--   returns
--     (b~[e], c~e), [d->a]
--
543 544 545 546
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
mkGadtCtxt data_tvs (ResTyGADT res_ty)
547
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
548 549 550
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

551
  | otherwise
552
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
553 554 555 556 557
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
558
       , not (in_subst subst con_tv)
559 560 561 562 563
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
564
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
565 566 567 568 569

    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

570

571
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
572
repBangTy ty= do
573 574
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
575
  rep2 strictTypeName [s, t]
576
  where
577
    (str, ty') = case ty of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
578 579 580
                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
                   _                               -> (notStrictName, ty)
581 582

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
583
--                      Deriving clause
584 585
-------------------------------------------------------

586
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
587
repDerivs Nothing = coreList nameTyConName []
588
repDerivs (Just ctxt)
589
  = repList nameTyConName rep_deriv ctxt
590
  where
591
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
592
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
593 594 595 596 597
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
598 599 600 601 602 603


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

604
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
605 606 607
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

613
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
614 615
        -- Singleton => Ok
        -- Empty     => Too hard, signature ignored
616
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
dreixel's avatar
dreixel committed
617 618 619 620
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") ]

621 622
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
623
rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
624 625
rep_sig _                             = return []

626 627
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
           -> DsM (SrcSpan, Core TH.DecQ)
628
rep_ty_sig loc (L _ ty) nm
629 630 631 632
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
       ; sig <- repProto nm1 ty1
       ; return (loc, sig) }
633
  where
634 635 636 637 638
    -- 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 }
639
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
640 641
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
642
           ; repTForall bndrs1 ctxt1 ty1 }
643

644
    rep_ty ty = repTy ty
645

646

647
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
648
           -> InlinePragma      -- Never defaultInlinePragma
649
           -> SrcSpan
650 651
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
652 653 654 655 656
  = 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
657 658 659
       ; return [(loc, pragma)]
       }

660
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
661 662 663 664
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
665 666 667 668 669 670 671 672
       ; 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 }
673 674
       ; return [(loc, pragma)]
       }
675

676 677 678 679 680 681
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

682 683 684 685 686 687
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

688 689 690
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
691

692 693 694 695 696 697
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
698 699

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
700
--                      Types
701
-------------------------------------------------------
702

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
703
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
704 705
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
706 707
-- 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
708
-- meta environment and gets the *new* names on Core-level as an argument
709

710 711 712 713 714 715
addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
  = do { fresh_kv_names <- mkGenSyms kvs
       ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
       ; let fresh_names = fresh_kv_names ++ fresh_tv_names
       ; term <- addBinds fresh_names $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
716
                    ; m kbs }
717
       ; wrapGenSyms fresh_names term }
718 719
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
720

721
addTyClTyVarBinds :: LHsTyVarBndrs Name
722 723
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
724 725 726 727 728 729 730

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
737 738 739
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
740 741 742

       ; wrapGenSyms freshNames term }
  where
743
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
744
                       ; repTyVarBndrWithKind tv v }
745 746 747

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
748
repTyVarBndrWithKind :: LHsTyVarBndr Name
749
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
750
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
751
  = repPlainTV nm
752
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
753
  = repLKind ki >>= repKindedTV nm
754

755 756
-- represent a type context
--
757 758 759
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

760
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
761
repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
762
                     repCtxt preds
763

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

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

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

781
repTy (HsTyVar n)
782
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
783
                       repTvar tv1
784 785
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
786 787
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
788 789
  where
    occ = nameOccName n
790

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

841
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
842 843
repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
                          rep2 numTyLitName [iExpr]
844 845 846 847
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

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

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

883 884 885 886 887
repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
repRole (L _ (Just Nominal))          = rep2 nominalRName []
repRole (L _ (Just Representational)) = rep2 representationalRName []
repRole (L _ (Just Phantom))          = rep2 phantomRName []
repRole (L _ Nothing)                 = rep2 inferRName []
888

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

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

904
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
905
--              Expressions
906
-----------------------------------------------------------------------------
907

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

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

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

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