DsMeta.hs 116 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)) | PendSplice 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
        decls <- addBinds ss (
140 141 142 143 144 145 146 147 148 149 150 151 152 153
                  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
                     ; deriv_ds <- mapM repStandaloneDerivD derivds
                     ; fix_ds   <- mapM repFixD fixds
                     ; _        <- mapM no_default_decl defds
                     ; for_ds   <- mapM repForD fords
                     ; _        <- mapM no_warn warnds
                     ; ann_ds   <- mapM repAnnD annds
                     ; rule_ds  <- mapM repRuleD ruleds
                     ; _        <- mapM no_vect vects
                     ; _        <- mapM no_doc docs
154

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
                                       ++ ann_ds ++ deriv_ds) }) ;
160

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
167
        wrapGenSyms ss q_decs
168
      }
169 170 171 172 173 174 175 176 177 178 179 180
  where
    no_splice (L loc _)
      = notHandledL loc "Splices within declaration brackets" empty
    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_vect (L loc decl)
      = notHandledL loc "Vectorisation pragmas" (ppr decl)
    no_doc (L loc _)
      = notHandledL loc "Haddock documentation" empty
181

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


{- 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.
201
To achieve this we
202 203 204 205 206 207 208 209 210 211

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

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
222 223
        data T = MkT
        foo = reifyDecl T
224 225

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

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

-}

234 235
-- represent associated family instances
--
236
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
237

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

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

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

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

275 276 277 278 279 280 281 282 283
-------------------------
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) }

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

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

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

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

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

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

363
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
364 365

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

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

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

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

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

423 424 425 426 427 428 429 430 431 432 433 434
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
  = do { dec <- addTyVarBinds tvs $ \_ ->
                do { cxt' <- repContext cxt
                   ; cls_tcon <- repTy (HsTyVar (unLoc cls))
                   ; cls_tys <- repLTys tys
                   ; inst_ty <- repTapps cls_tcon cls_tys
                   ; repDeriv cxt' inst_ty }
       ; return (loc, dec) }
  where
    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty

435
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
436
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
437
  = do { let tc_name = tyFamInstDeclLName decl
438
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
439 440
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
441 442

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

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

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []
493
repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
494 495 496

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

500 501 502 503
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
504
       ; let rep_fn = case dir of
505 506 507 508 509 510
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; dec <- rep2 rep_fn [prec', name']
       ; return (loc, dec) }

511 512
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
513 514 515 516 517 518 519 520 521 522 523 524 525 526
  = 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
527
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
528
  = unLoc n : kvs ++ tvs
529 530 531

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
532
  = do { MkC n' <- lookupLBinder n
533 534
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
535
  = do { MkC n'  <- lookupLBinder n
536 537 538
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repAnnD (L loc (HsAnnotation ann_prov (L _ exp)))
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (loc, dec) }

repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
repAnnProv (ValueAnnProvenance n)
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
repAnnProv (TypeAnnProvenance n)
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

Ian Lynagh's avatar
Ian Lynagh committed
556
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
557
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
558

559
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
560
--                      Constructors
561 562
-------------------------------------------------------

563
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
564
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
565
                     , con_details = details, con_res = ResTyH98 }))
566
  | null (hsQTvBndrs con_tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
567
  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]
568
       ; repConstr con1 details  }
569

570 571 572 573 574
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
575 576 577
       ; 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
578
       ; binds <- mapM dupBinder con_tv_subst
579 580
       ; 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
581
    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]
582 583
       ; c'        <- repConstr con1 details
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
584
       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
585

586 587 588
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
589

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
590
mkGadtCtxt :: [Name]            -- Tyvars of the data type
591
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
592
           -> DsM (HsContext Name, [(Name,Name)])
593 594
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
595 596 597
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
598
-- Example:
599 600
-- 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)
601 602 603
--   returns
--     (b~[e], c~e), [d->a]
--
604 605 606 607
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
mkGadtCtxt data_tvs (ResTyGADT res_ty)
608
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
609 610 611
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

612
  | otherwise
613
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
614 615 616 617 618
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
619
       , not (in_subst subst con_tv)
620 621 622 623 624
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
625
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
626 627 628 629 630

    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

631

632
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
633
repBangTy ty= do
634 635
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
636
  rep2 strictTypeName [s, t]
637
  where
638
    (str, ty') = case ty of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
639 640 641
                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
                   _                               -> (notStrictName, ty)
642 643

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
644
--                      Deriving clause
645 646
-------------------------------------------------------

647
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
648
repDerivs Nothing = coreList nameTyConName []
649
repDerivs (Just ctxt)
650
  = repList nameTyConName rep_deriv ctxt
651
  where
652
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
653
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
654 655 656 657 658
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
659 660 661 662 663 664


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

665
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
666 667 668
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

674
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
675
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig sigDName loc ty) nms
676
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
677
rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty) nms
678 679
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
680 681
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
682
rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
683
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
684

685
rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
686
           -> DsM (SrcSpan, Core TH.DecQ)
687
rep_ty_sig mk_sig loc (L _ ty) nm
688 689
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
690
       ; sig <- repProto mk_sig nm1 ty1
691
       ; return (loc, sig) }
692
  where
693 694 695 696 697
    -- 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 }
698
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
699 700
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
701
           ; repTForall bndrs1 ctxt1 ty1 }
702

703
    rep_ty ty = repTy ty
704

705
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
706
           -> InlinePragma      -- Never defaultInlinePragma
707
           -> SrcSpan
708 709
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
710 711 712 713 714
  = 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
715 716 717
       ; return [(loc, pragma)]
       }

718
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
719 720 721 722
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
723 724 725 726 727 728 729 730
       ; 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 }
731 732
       ; return [(loc, pragma)]
       }
733

734 735 736 737 738 739
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

740 741 742 743 744 745
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

746 747 748
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
749

750 751 752 753 754 755
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
756 757

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
758
--                      Types
759
-------------------------------------------------------
760

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
761
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
762 763
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
764 765
-- 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
766
-- meta environment and gets the *new* names on Core-level as an argument
767

768 769 770 771 772 773
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
774
                    ; m kbs }
775
       ; wrapGenSyms fresh_names term }
776 777
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
778

779
addTyClTyVarBinds :: LHsTyVarBndrs Name
780 781
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
782 783 784 785 786 787 788

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
795 796 797
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
798 799 800

       ; wrapGenSyms freshNames term }
  where
801
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
802
                       ; repTyVarBndrWithKind tv v }
803 804 805

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
806
repTyVarBndrWithKind :: LHsTyVarBndr Name
807
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
808
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
809
  = repPlainTV nm
810
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
811
  = repLKind ki >>= repKindedTV nm
812

813 814
-- represent a type context
--
815 816 817
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

822 823
-- yield the representation of a list of types
--
824 825
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
826

827 828
-- represent a type
--
829 830 831
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

832
repTy :: HsType Name -> DsM (Core TH.TypeQ)
833
repTy (HsForAllTy _ tvs ctxt ty)  =
834
  addTyVarBinds tvs $ \bndrs -> do
835 836
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
837
    repTForall bndrs ctxt1 ty1
838

839
repTy (HsTyVar n)
840
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
841
                       repTvar tv1
842 843
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
844 845
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
846 847
  where
    occ = nameOccName n
848

849
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
850 851 852
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
853
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
854 855 856 857 858 859 860 861
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
862
repTy (HsPArrTy t)          = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
863 864 865
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
batterseapower's avatar
batterseapower committed
866
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
867 868 869
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
870
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
871 872
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
873
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
874 875
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
876 877 878 879 880
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
881 882
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
883
                                k1 <- repLKind k
884
                                repTSig t1 k1
885
repTy (HsSpliceTy splice _)     = repSplice splice
886 887 888 889 890 891 892 893 894 895
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
896
                          
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
897
repTy ty                      = notHandled "Exotic form of type" (ppr ty)
898

899
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
900 901
repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
                          rep2 numTyLitName [iExpr]
902 903 904 905
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

906 907
-- represent a kind
--
908 909
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
910
  = do { let (kis, ki') = splitHsFunType ki
911 912 913 914 915
       ; 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
916
       }
917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939

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

941 942 943 944 945
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 []
946

947
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
948
--              Splices
949 950 951 952 953
-----------------------------------------------------------------------------

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
954
repSplice (HsSplice n _)
955 956
 = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
957 958 959 960
           Just (Splice e) -> do { e' <- dsExpr e
                                 ; return (MkC e') }
           _ -> pprPanic "HsSplice" (ppr n) }
                        -- Should not happen; statically checked
961

962
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
963
--              Expressions
964
-----------------------------------------------------------------------------
965

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