DsMeta.hs 113 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 116 117 118 119 120 121 122 123 124 125 126 127 128
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , hs_instds  = instds
                        , hs_derivds = derivds
                        , hs_fixds   = fixds
                        , hs_defds   = defds
                        , hs_fords   = fords
                        , hs_warnds  = warnds
                        , hs_annds   = annds
                        , hs_ruleds  = ruleds
                        , hs_vects   = vects
                        , hs_docs    = docs })
 = do { let { tv_bndrs = hsSigTvBinders valds
129
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
130
        ss <- mkGenSyms bndrs ;
131

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
132 133 134 135 136 137
        -- 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
138

139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
        decls <- addBinds ss (
                  do { val_ds  <- rep_val_binds valds
                     ; _       <- mapM no_splice splcds
                     ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds)
                     ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
                     ; inst_ds <- mapM repInstD instds
                     ; _       <- mapM no_standalone_deriv derivds
                     ; fix_ds  <- mapM repFixD fixds
                     ; _       <- mapM no_default_decl defds
                     ; for_ds  <- mapM repForD fords
                     ; _       <- mapM no_warn warnds
                     ; _       <- mapM no_ann annds
                     ; rule_ds <- mapM repRuleD ruleds
                     ; _       <- mapM no_vect vects
                     ; _       <- mapM no_doc docs

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
155
                        -- more needed
156
                     ;  return (de_loc $ sort_by_loc $
157
                                val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds
158
                                       ++ inst_ds ++ rule_ds ++ for_ds) }) ;
159

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
160 161
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
162

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
163 164
        dec_ty <- lookupType decTyConName ;
        q_decs  <- repSequenceQ dec_ty core_list ;
165

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
166
        wrapGenSyms ss q_decs
167
      }
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
  where
    no_splice (L loc _)
      = notHandledL loc "Splices within declaration brackets" empty
    no_standalone_deriv (L loc (DerivDecl { deriv_type = deriv_ty }))
      = notHandledL loc "Standalone-deriving" (ppr deriv_ty)
    no_default_decl (L loc decl)
      = notHandledL loc "Default declarations" (ppr decl)
    no_warn (L loc (Warning thing _))
      = notHandledL loc "WARNING and DEPRECATION pragmas" $
                    text "Pragma for declaration of" <+> ppr thing
    no_ann (L loc decl)
      = notHandledL loc "ANN pragmas" (ppr decl)
    no_vect (L loc decl)
      = notHandledL loc "Vectorisation pragmas" (ppr decl)
    no_doc (L loc _)
      = notHandledL loc "Haddock documentation" empty
184

185 186 187
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
188 189
  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
                     , tv <- hsQTvBndrs qtvs]
190 191
  where
    sigs = case binds of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
192 193
             ValBindsIn  _ sigs -> sigs
             ValBindsOut _ sigs -> sigs
194 195 196 197 198 199 200 201 202 203


{- 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.
204
To achieve this we
205 206 207 208 209 210 211 212 213 214

  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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
215 216
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
217
        Data "T" [] [Con "MkT" []] []
218
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
219
        Data "Foo:T" [] [Con "Foo:MkT" []] []
220 221
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
222
        Data "T79" ....
223 224

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
225 226
        data T = MkT
        foo = reifyDecl T
227 228

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

231 232
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
233 234 235 236
in repTyClD and repC.

-}

237 238
-- represent associated family instances
--
239
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
240

241 242 243
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
244 245 246
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
247
       ; return (Just (loc, dec)) }
248

249
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
250
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
251
       ; tc_tvs <- mk_extra_tvs tc tvs defn
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
252 253
       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
                repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
254
       ; return (Just (loc, dec)) }
255

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
256 257 258
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
                             tcdTyVars = tvs, tcdFDs = fds,
                             tcdSigs = sigs, tcdMeths = meth_binds,
259
                             tcdATs = ats, tcdATDefs = [] }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
260 261
  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
       ; dec  <- addTyVarBinds tvs $ \bndrs ->
262
           do { cxt1   <- repLContext cxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
263 264 265
              ; sigs1  <- rep_sigs sigs
              ; binds1 <- rep_binds meth_binds
              ; fds1   <- repLFunDeps fds
266
              ; ats1   <- repFamilyDecls ats
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
267 268
              ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
              ; repClass cxt1 cls1 bndrs fds1 decls1
269
              }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
270
       ; return $ Just (loc, dec)
271
       }
272 273

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

278 279 280 281 282 283 284 285 286
-------------------------
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) }

287
-------------------------
288 289 290 291 292 293
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
294
                      , dd_cons = cons, dd_derivs = mb_derivs })
295 296 297 298 299
  = 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 }
300 301
           DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
302

303 304 305 306
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
          -> LHsType Name
          -> DsM (Core TH.DecQ)
repSynDecl tc bndrs ty
307
  = do { ty1 <- repLTy ty
308 309 310
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
311
repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
312
                                   fdLName   = tc,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
313 314 315
                                   fdTyVars  = tvs,
                                   fdKindSig = opt_kind }))
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
316
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
317
           case (opt_kind, info) of
318 319 320 321 322 323 324 325
                  (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
326
                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
327 328 329 330 331
                  (Nothing, _) ->
                    do { info' <- repFamilyInfo info
                       ; repFamilyNoKind info' tc1 bndrs }
                  (Just ki, _) ->
                    do { info' <- repFamilyInfo info
332
                       ; ki1 <- repLKind ki
333
                       ; repFamilyKind info' tc1 bndrs ki1 }
334 335 336 337 338
       ; return (loc, dec)
       }

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
341
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
342
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
343 344 345
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
346
mk_extra_tvs tc tvs defn
347
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
348
  = do { extra_tvs <- go hs_kind
349
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
350 351
  | otherwise
  = return tvs
352 353 354 355 356 357
  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
358
                 ; hs_tv = L loc (KindedTyVar nm kind) }
359 360 361 362 363 364
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

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

366
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
367 368

-------------------------
369 370 371
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
372
repLFunDeps fds = repList funDepTyConName repLFunDep fds
373 374

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
375 376 377
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
                               ys' <- repList nameTyConName lookupBinder ys
                               repFunDep xs' ys'
378

379 380
-- represent family declaration flavours
--
381 382 383 384
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
repFamilyInfo DataFamily          = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
385

386 387 388
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
389 390 391 392 393 394 395 396
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
397
       ; return (loc, dec) }
398

399 400 401 402 403
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
404 405
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
406
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
407 408 409 410 411 412
            --
            -- 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)
            --
413
            do { cxt1 <- repContext cxt
414
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
415 416
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
417
               ; binds1 <- rep_binds binds
418
               ; prags1 <- rep_sigs prags
419 420 421
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
422
               ; repInst cxt1 inst_ty1 decls }
423
 where
424
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
425

426
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
427
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
428
  = do { let tc_name = tyFamInstDeclLName decl
429
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
430 431
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
432 433

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
434 435 436 437
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
438 439 440 441 442 443 444 445 446 447 448 449
  = 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
450
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
451
       ; let loc = getLoc tc_name
452
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
453
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
454
         do { tys1 <- repList typeQTyConName repLTy tys
455
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
456

457
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
458
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
459 460 461 462
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
463
      cis' <- conv_cimportspec cis
464
      MkC str <- coreStringLit (static ++ chStr ++ cis')
465 466 467
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
468 469
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
470 471
    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
472
    conv_cimportspec CWrapper = return "wrapper"
473
    static = case cis of
474
                 CFunction (StaticTarget _ _ _) -> "static "
475
                 _ -> ""
476 477 478
    chStr = case mch of
            Nothing -> ""
            Just (Header h) -> unpackFS h ++ " "
479
repForD decl = notHandled "Foreign declaration" (ppr decl)
480 481 482 483

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []
484
repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
485 486 487

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

491 492 493 494
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
495
       ; let rep_fn = case dir of
496 497 498 499 500 501
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; dec <- rep2 rep_fn [prec', name']
       ; return (loc, dec) }

502 503
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
504 505 506 507 508 509 510 511 512 513 514 515 516 517
  = 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
518
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
519
  = unLoc n : kvs ++ tvs
520 521 522

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
523
  = do { MkC n' <- lookupLBinder n
524 525
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
526
  = do { MkC n'  <- lookupLBinder n
527 528 529
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

Ian Lynagh's avatar
Ian Lynagh committed
530
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
531
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
532

533
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
534
--                      Constructors
535 536
-------------------------------------------------------

537
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
538
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
539
                     , con_details = details, con_res = ResTyH98 }))
540
  | null (hsQTvBndrs con_tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
541
  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]
542
       ; repConstr con1 details  }
543

544 545 546 547 548
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
549 550 551
       ; 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
552
       ; binds <- mapM dupBinder con_tv_subst
553 554
       ; 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
555
    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]
556 557
       ; c'        <- repConstr con1 details
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
558
       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
559

560 561 562
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
563

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
564
mkGadtCtxt :: [Name]            -- Tyvars of the data type
565
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
566
           -> DsM (HsContext Name, [(Name,Name)])
567 568
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
569 570 571
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
572
-- Example:
573 574
-- 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)
575 576 577
--   returns
--     (b~[e], c~e), [d->a]
--
578 579 580 581
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
mkGadtCtxt data_tvs (ResTyGADT res_ty)
582
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
583 584 585
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

586
  | otherwise
587
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
588 589 590 591 592
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
593
       , not (in_subst subst con_tv)
594 595 596 597 598
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
599
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
600 601 602 603 604

    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

605

606
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
607
repBangTy ty= do
608 609
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
610
  rep2 strictTypeName [s, t]
611
  where
612
    (str, ty') = case ty of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
613 614 615
                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
                   _                               -> (notStrictName, ty)
616 617

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
618
--                      Deriving clause
619 620
-------------------------------------------------------

621
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
622
repDerivs Nothing = coreList nameTyConName []
623
repDerivs (Just ctxt)
624
  = repList nameTyConName rep_deriv ctxt
625
  where
626
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
627
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
628 629 630 631 632
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
633 634 635 636 637 638


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

639
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
640 641 642
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

648
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
649
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
650 651 652 653 654
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
rep_sig (L _   (GenericSig nm _))     = notHandled "Default type signatures" msg
  where msg = text "Illegal default signature for" <+> quotes (ppr nm)
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
655 656
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
657
rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
658
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
659

660 661
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
           -> DsM (SrcSpan, Core TH.DecQ)
662
rep_ty_sig loc (L _ ty) nm
663 664 665 666
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
       ; sig <- repProto nm1 ty1
       ; return (loc, sig) }
667
  where
668 669 670 671 672
    -- 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 }
673
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
674 675
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
676
           ; repTForall bndrs1 ctxt1 ty1 }
677

678
    rep_ty ty = repTy ty
679

680

681
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
682
           -> InlinePragma      -- Never defaultInlinePragma
683
           -> SrcSpan
684 685
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
686 687 688 689 690
  = 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
691 692 693
       ; return [(loc, pragma)]
       }

694
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
695 696 697 698
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
699 700 701 702 703 704 705 706
       ; 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 }
707 708
       ; return [(loc, pragma)]
       }
709

710 711 712 713 714 715
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

716 717 718 719 720 721
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

722 723 724
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
725

726 727 728 729 730 731
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
732 733

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
734
--                      Types
735
-------------------------------------------------------
736

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
737
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
738 739
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
740 741
-- 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
742
-- meta environment and gets the *new* names on Core-level as an argument
743

744 745 746 747 748 749
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
750
                    ; m kbs }
751
       ; wrapGenSyms fresh_names term }
752 753
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
754

755
addTyClTyVarBinds :: LHsTyVarBndrs Name
756 757
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
758 759 760 761 762 763 764

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
771 772 773
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
774 775 776

       ; wrapGenSyms freshNames term }
  where
777
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
778
                       ; repTyVarBndrWithKind tv v }
779 780 781

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
782
repTyVarBndrWithKind :: LHsTyVarBndr Name
783
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
784
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
785
  = repPlainTV nm
786
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
787
  = repLKind ki >>= repKindedTV nm
788

789 790
-- represent a type context
--
791 792 793
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

798 799
-- yield the representation of a list of types
--
800 801
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
802

803 804
-- represent a type
--
805 806 807
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

808
repTy :: HsType Name -> DsM (Core TH.TypeQ)
809
repTy (HsForAllTy _ tvs ctxt ty)  =
810
  addTyVarBinds tvs $ \bndrs -> do
811 812
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
813
    repTForall bndrs ctxt1 ty1
814

815
repTy (HsTyVar n)
816
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
817
                       repTvar tv1
818 819
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
820 821
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
822 823
  where
    occ = nameOccName n
824

825
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
826 827 828
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
829
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
830 831 832 833 834 835 836 837
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
838
repTy (HsPArrTy t)          = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
839 840 841
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
batterseapower's avatar
batterseapower committed
842
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
843 844 845
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
846
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
847 848
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
849
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
850 851
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
852 853 854 855 856
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
857 858
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
859
                                k1 <- repLKind k
860
                                repTSig t1 k1
861
repTy (HsSpliceTy splice _)     = repSplice splice
862 863 864 865 866 867 868 869 870 871
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
872
                          
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
873
repTy ty                      = notHandled "Exotic form of type" (ppr ty)
874

875
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
876 877
repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
                          rep2 numTyLitName [iExpr]
878 879 880 881
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

882 883
-- represent a kind
--
884 885
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
886
  = do { let (kis, ki') = splitHsFunType ki
887 888 889 890 891
       ; 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
892
       }
893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915

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

917 918 919 920 921
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 []
922

923
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
924
--              Splices
925 926 927 928 929
-----------------------------------------------------------------------------

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
930
repSplice (HsSplice n _)
931 932
 = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
933 934 935 936
           Just (Splice e) -> do { e' <- dsExpr e
                                 ; return (MkC e') }
           _ -> pprPanic "HsSplice" (ppr n) }
                        -- Should not happen; statically checked
937

938
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
939
--              Expressions
940
-----------------------------------------------------------------------------
941

942
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
943
repLEs es = repList expQTyConName repLE es
944

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

951
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
952
repE (HsVar x)            =
953
  do { mb_val <- dsLookupMetaEnv x
954
     ; case mb_val of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
955 956 957 958 959
        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
960