DsMeta.hs 86.7 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 ) where
19

20 21
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
24
import MatchLit
25 26
import DsMonad

27
import qualified Language.Haskell.TH as TH
28

29
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
30 31 32 33 34 35
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.
36
import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
37

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

61
import Data.ByteString ( unpack )
Simon Marlow's avatar
Simon Marlow committed
62 63 64
import Data.Maybe
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
65

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

72 73
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
74
  where
75
    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
76

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

{- -------------- Examples --------------------

  [| \x -> x |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (var x1)


  [| \x -> $(f [| x |]) |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (f (var x1))
-}


100
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
101
--                      Declarations
102 103
-------------------------------------------------------

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

109
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
110 111 112 113 114 115 116 117 118 119 120 121 122 123
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
124
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
125
        ss <- mkGenSyms bndrs ;
126

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
127 128 129 130 131 132
        -- 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
133

134
        decls <- addBinds ss (
135 136 137 138 139 140 141 142 143
                  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
Alan Zimmerman's avatar
Alan Zimmerman committed
144 145
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
146
                     ; ann_ds   <- mapM repAnnD annds
Alan Zimmerman's avatar
Alan Zimmerman committed
147 148
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
149 150
                     ; _        <- mapM no_vect vects
                     ; _        <- mapM no_doc docs
151

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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
165
        wrapGenSyms ss q_decs
166
      }
167 168 169 170 171 172 173 174 175 176 177 178
  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
179

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


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

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

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

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

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

-}

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

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

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

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

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

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

282
-------------------------
283 284 285 286 287 288
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
289
                      , dd_cons = cons, dd_derivs = mb_derivs })
290 291 292 293
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
294 295 296 297 298 299 300 301 302
                          ; case con1 of
                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
                             _cs -> failWithDs (ptext
                                     (sLit "Multiple constructors for newtype:")
                                      <+> pprQuotedList
                                                (con_names $ unLoc $ head cons))
                          }
           DataType -> do { consL <- concatMapM (repC tv_names) cons
                          ; cons1 <- coreList conQTyConName consL
303
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
304

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

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Jan Stolarek's avatar
Jan Stolarek committed
313 314 315 316 317
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
                                        fdLName     = tc,
                                        fdTyVars    = tvs,
                                        fdResultSig = L _ resultSig,
                                        fdInjectivityAnn = injectivity }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
318
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
Jan Stolarek's avatar
Jan Stolarek committed
319 320 321 322
       ; let mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
             resTyVar = case resultSig of
                     TyVarSig bndr -> mkHsQTvs [bndr]
                     _             -> mkHsQTvs []
323
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340
                addTyClTyVarBinds resTyVar $ \_ ->
           case info of
             ClosedTypeFamily Nothing ->
                 notHandled "abstract closed type family" (ppr decl)
             ClosedTypeFamily (Just eqns) ->
               do { eqns1  <- mapM repTyFamEqn eqns
                  ; eqns2  <- coreList tySynEqnQTyConName eqns1
                  ; result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
             OpenTypeFamily ->
               do { result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repOpenFamilyD tc1 bndrs result inj }
             DataFamily ->
               do { kind <- repFamilyResultSigToMaybeKind resultSig
                  ; repDataFamilyD tc1 bndrs kind }
341 342 343
       ; return (loc, dec)
       }

Jan Stolarek's avatar
Jan Stolarek committed
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
-- | Represent result signature of a type family
repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig)
repFamilyResultSig  NoSig          = repNoSig
repFamilyResultSig (KindSig ki)    = do { ki' <- repLKind ki
                                        ; repKindSig ki' }
repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr
                                        ; repTyVarSig bndr' }

-- | Represent result signature using a Maybe Kind. Used with data families,
-- where the result signature can be either missing or a kind but never a named
-- result variable.
repFamilyResultSigToMaybeKind :: FamilyResultSig Name
                              -> DsM (Core (Maybe TH.Kind))
repFamilyResultSigToMaybeKind NoSig =
    do { coreNothing kindTyConName }
repFamilyResultSigToMaybeKind (KindSig ki) =
    do { ki' <- repLKind ki
       ; coreJust kindTyConName ki' }
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"

-- | Represent injectivity annotation of a type family
repInjectivityAnn :: Maybe (LInjectivityAnn Name)
                  -> DsM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
    do { coreNothing injAnnTyConName }
repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
    do { lhs'   <- lookupBinder (unLoc lhs)
       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
       ; rhs2   <- coreList nameTyConName rhs1
       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
       ; coreJust injAnnTyConName injAnn }

376 377
repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
378 379

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
380
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
381
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
382 383 384
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
385
mk_extra_tvs tc tvs defn
386
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
387
  = do { extra_tvs <- go hs_kind
388
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
389 390
  | otherwise
  = return tvs
391 392 393 394 395 396
  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
Alan Zimmerman's avatar
Alan Zimmerman committed
397
                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
398 399 400 401 402 403
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

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

405
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
406 407

-------------------------
408 409
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
410
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
411
repLFunDeps fds = repList funDepTyConName repLFunDep fds
412

Alan Zimmerman's avatar
Alan Zimmerman committed
413 414 415 416 417
repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys))
   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
        repFunDep xs' ys'
418

419 420 421
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
422 423 424 425 426 427 428 429
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
430
       ; return (loc, dec) }
431

432 433 434 435 436
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
437 438
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
439
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
440 441 442 443 444 445
            --
            -- 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)
            --
446
            do { cxt1 <- repContext cxt
447
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
448 449
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
450
               ; binds1 <- rep_binds binds
451
               ; prags1 <- rep_sigs prags
452 453 454
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
455
               ; repInst cxt1 inst_ty1 decls }
456
 where
457
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
458

459 460 461 462 463 464 465 466 467 468 469 470
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

471
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
472
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
473
  = do { let tc_name = tyFamInstDeclLName decl
474
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
475 476
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
477 478

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
479 480 481 482
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
483 484 485 486 487 488 489 490 491 492 493 494
  = 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
495
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
496
       ; let loc = getLoc tc_name
497
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
498
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
499
         do { tys1 <- repList typeQTyConName repLTy tys
500
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
501

502
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
503
repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
504 505 506 507
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
508
      cis' <- conv_cimportspec cis
509
      MkC str <- coreStringLit (static ++ chStr ++ cis')
510 511 512
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
513 514
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
515 516 517 518
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
519
    conv_cimportspec CWrapper = return "wrapper"
520 521
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
522
    static = case cis of
523
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
524
                 _ -> ""
525
    chStr = case mch of
526 527
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
528
repForD decl = notHandled "Foreign declaration" (ppr decl)
529 530

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
531 532 533 534 535
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
536 537 538

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

542 543 544
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity prec dir)))
  = do { MkC prec' <- coreIntLit prec
545
       ; let rep_fn = case dir of
546 547 548
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
549 550 551 552 553
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
554

555 556
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
557 558 559 560
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
561
                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
562 563 564 565 566 567 568
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

569 570 571
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
572
  = unLoc n : kvs ++ tvs
573

574 575
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
576
  = do { MkC n' <- lookupLBinder n
577
       ; rep2 ruleVarName [n'] }
578
repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
579
  = do { MkC n'  <- lookupLBinder n
580 581 582
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

583
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
584
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
585 586 587 588 589 590
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (loc, dec) }

repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
Alan Zimmerman's avatar
Alan Zimmerman committed
591
repAnnProv (ValueAnnProvenance (L _ n))
592 593
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
594
repAnnProv (TypeAnnProvenance (L _ n))
595 596 597 598 599
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

Ian Lynagh's avatar
Ian Lynagh committed
600
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
601
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
602

603
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
604
--                      Constructors
605 606
-------------------------------------------------------

607 608
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
609
                     , con_details = details, con_res = ResTyH98 }))
610
  | null (hsQTvBndrs con_tvs)
611 612
  = do { con1 <- mapM lookupLOcc con       -- See Note [Binders and occurrences]
       ; mapM (\c -> repConstr c details) con1  }
613

614
repC tvs (L _ (ConDecl { con_names = cons
615 616 617 618
                       , 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
619 620 621
       ; 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
622
       ; binds <- mapM dupBinder con_tv_subst
623
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
624
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
625 626
    do { cons1     <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
       ; c'        <- mapM (\c -> repConstr c details) cons1
627
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
628 629 630
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
    ; return [b]
    }
631

632 633 634
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
635

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
636
mkGadtCtxt :: [Name]            -- Tyvars of the data type
637
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
638
           -> DsM (HsContext Name, [(Name,Name)])
639 640
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
641 642 643
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
644
-- Example:
645 646
-- 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)
647 648 649
--   returns
--     (b~[e], c~e), [d->a]
--
650 651 652
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
Alan Zimmerman's avatar
Alan Zimmerman committed
653
mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
654
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
655 656 657
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

658
  | otherwise
659
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
660 661 662 663 664
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
665
       , not (in_subst subst con_tv)
666 667 668 669 670
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
671
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
672 673 674 675 676

    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

677

678
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
679
repBangTy ty = do
680 681
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
682
  rep2 strictTypeName [s, t]
683
  where
684
    (str, ty') = case ty of
685 686 687 688 689
         L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty)
           -> (unpackedName,  ty)
         L _ (HsBangTy (HsSrcBang _ _         SrcStrict) ty)
           -> (isStrictName,  ty)
         _ -> (notStrictName, ty)
690 691

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
692
--                      Deriving clause
693 694
-------------------------------------------------------

695
repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
696
repDerivs Nothing = coreList nameTyConName []
697
repDerivs (Just (L _ ctxt))
698
  = repList nameTyConName rep_deriv ctxt
699
  where
700
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
701
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
702 703 704 705 706
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
707 708 709 710 711 712


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

713
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
714 715 716
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

722
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
thomasw's avatar
thomasw committed
723
rep_sig (L loc (TypeSig nms ty _))    = mapM (rep_ty_sig sigDName loc ty) nms
724
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
725
rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty) nms
726 727
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
728
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
729 730
rep_sig (L loc (SpecSig nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
731
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
732
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
733

734
rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
735
           -> DsM (SrcSpan, Core TH.DecQ)
736
rep_ty_sig mk_sig loc (L _ ty) nm
737 738
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
739
       ; sig <- repProto mk_sig nm1 ty1
740
       ; return (loc, sig) }
741
  where
742 743
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
thomasw's avatar
thomasw committed
744
    rep_ty (HsForAllTy Explicit _ tvs ctxt ty)
745 746
      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                         ; repTyVarBndrWithKind tv name }
747
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
748 749
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
750
           ; repTForall bndrs1 ctxt1 ty1 }
751

752
    rep_ty ty = repTy ty
753

754
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
755
           -> InlinePragma      -- Never defaultInlinePragma
756
           -> SrcSpan
757 758
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
759 760 761 762 763
  = 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
764 765 766
       ; return [(loc, pragma)]
       }

767
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
768 769 770 771
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
772 773 774 775 776 777 778 779
       ; 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 }
780 781
       ; return [(loc, pragma)]
       }
782

783 784 785 786 787 788
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

789 790 791 792 793 794
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

795 796 797
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
798

799 800 801 802 803 804
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
805 806

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
807
--                      Types
808
-------------------------------------------------------
809

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
810
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
811 812
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
813 814
-- 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
815
-- meta environment and gets the *new* names on Core-level as an argument
816

817 818 819 820 821 822
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
823
                    ; m kbs }
824
       ; wrapGenSyms fresh_names term }
825 826
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
827

828
addTyClTyVarBinds :: LHsTyVarBndrs Name
829 830
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
831 832 833 834 835 836 837

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
844 845 846
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
847 848 849

       ; wrapGenSyms freshNames term }
  where
850
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
851
                       ; repTyVarBndrWithKind tv v }
852 853 854

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
855
repTyVarBndrWithKind :: LHsTyVarBndr Name
856
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
857
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
858
  = repPlainTV nm
859
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
860
  = repLKind ki >>= repKindedTV nm
861

Jan Stolarek's avatar
Jan Stolarek committed
862 863 864 865 866 867 868 869
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
repTyVarBndr (L _ (UserTyVar nm)) = do { nm' <- lookupBinder nm
                                       ; repPlainTV nm' }
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLKind ki
                                                  ; repKindedTV nm' ki' }

870 871
-- represent a type context
--
872 873 874
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

879 880
-- yield the representation of a list of types
--
881 882
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
883

884 885
-- represent a type
--
886 887 888
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

889
repTy :: HsType Name -> DsM (Core TH.TypeQ)
thomasw's avatar
thomasw committed
890
repTy (HsForAllTy _ extra tvs ctxt ty)  =
891
  addTyVarBinds tvs $ \bndrs -> do
thomasw's avatar
thomasw committed
892
    ctxt1  <- repLContext ctxt'
893
    ty1    <- repLTy ty
894
    repTForall bndrs ctxt1 ty1
thomasw's avatar
thomasw committed
895 896 897 898 899 900 901 902 903 904 905 906 907 908 909
  where
    -- If extra is not Nothing, an extra-constraints wild card was removed
    -- (just) before renaming. It must be put back now, otherwise the
    -- represented type won't include this extra-constraints wild card.
    ctxt'
      | Just loc <- extra
      = let uniq = panic "addExtraCtsWC"
             -- This unique will be discarded by repLContext, but is required
             -- to make a Name
            name = mkInternalName uniq (mkTyVarOcc "_") loc
        in  (++ [L loc (HsWildCardTy (AnonWildCard name))]) `fmap` ctxt
      | otherwise
      = ctxt


910

911
repTy (HsTyVar n)
912
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
913
                       repTvar tv1
914 915
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
916 917
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
918 919
  where
    occ = nameOccName n
920

921
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
922 923 924
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
925
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
926 927 928 929 930 931 932 933
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
934
repTy (HsPArrTy t)          = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
935 936 937
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
batterseapower's avatar
batterseapower committed
938
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
939 940 941
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
942
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
943 944
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
945
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
946 947
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
948 949 950 951 952
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
953 954
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
955
                                k1 <- repLKind k
956
                                repTSig t1 k1
957
repTy (HsSpliceTy splice _)     = repSplice splice
958 959 960 961 962 963 964 965 966 967
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'
thomasw's avatar
thomasw committed
968 969 970 971
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
repTy (HsWildCardTy (NamedWildCard n)) = do
                                           nwc <- lookupOcc n
                                           repTNamedWildCard nwc
thomasw's avatar
thomasw committed
972

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
973
repTy ty                      = notHandled "Exotic form of type" (ppr ty)
974

975
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
976 977 978 979 980
repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
                            rep2 numTyLitName [iExpr]
repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
                            ; rep2 strTyLitName [s']
                            }