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
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
21
               quoteExpName, quotePatName, quoteDecName, quoteTypeName,
22 23
               tExpTyConName, tExpDataConName, unTypeName, unTypeQName,
               unsafeTExpCoerceName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
24
                ) where
25

26 27
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
30
import MatchLit
31 32
import DsMonad

33
import qualified Language.Haskell.TH as TH
34

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

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

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

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

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

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

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


103
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
104
--                      Declarations
105 106
-------------------------------------------------------

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

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

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

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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
144
        wrapGenSyms ss q_decs
145 146 147
      }


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


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

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

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

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

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

-}

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

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

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

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

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

241 242 243 244 245 246 247 248 249
-------------------------
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) }

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

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

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

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

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

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

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

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

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

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

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

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

389
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
390
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
391
  = do { let tc_name = tyFamInstDeclLName decl
392
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
393 394
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412

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
413
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
414
       ; let loc = getLoc tc_name
415
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
416
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
417
         do { tys1 <- repList typeQTyConName repLTy tys
418
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
419

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

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

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

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

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

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

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

496
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
497
--                      Constructors
498 499
-------------------------------------------------------

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

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

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

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

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

    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

568

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

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
581
--                      Deriving clause
582 583
-------------------------------------------------------

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


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

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

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

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

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

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

642
    rep_ty ty = repTy ty
643

644

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

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

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

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

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

690 691 692 693 694 695
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
696 697

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
698
--                      Types
699
-------------------------------------------------------
700

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

708
addTyVarBinds tvs m
709
  = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
710 711 712
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
                    ; m kbs }
713 714 715
       ; wrapGenSyms freshNames term }
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
716

717
addTyClTyVarBinds :: LHsTyVarBndrs Name
718 719
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
720 721 722 723 724 725 726

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
733 734 735
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
736 737 738

       ; wrapGenSyms freshNames term }
  where
739
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
740
                       ; repTyVarBndrWithKind tv v }
741 742 743

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

751 752
-- represent a type context
--
753 754 755
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

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

765 766
-- represent a type
--
767 768 769
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

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

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

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

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

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

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

879 880 881 882 883
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 []
884

885
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
886
--              Splices
887 888 889 890 891
-----------------------------------------------------------------------------

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

900
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
901
--              Expressions
902
-----------------------------------------------------------------------------
903

904
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
905
repLEs es = repList expQTyConName repLE es
906

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
935
repE (OpApp e1 op _ e2) =