DsMeta.hs 100 KB
Newer Older
1
{-# LANGUAGE CPP, TypeFamilies #-}
2

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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
43
import NameSet
Simon Marlow's avatar
Simon Marlow committed
44 45 46
import TcType
import TyCon
import TysWiredIn
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 Maybes
60
import MonadUtils
61

62
import Data.ByteString ( unpack )
Simon Marlow's avatar
Simon Marlow committed
63 64
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
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , 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 })
122 123 124
 = do { let { bndrs  = hsSigTvBinders valds
                       ++ hsGroupBinders group
                       ++ hsPatSynSelectors valds
125
            ; instds = tyclds >>= group_instds } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
126
        ss <- mkGenSyms bndrs ;
127

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

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

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

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

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

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

181 182 183
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
184
  = concatMap get_scoped_tvs sigs
185
  where
186 187 188 189 190
    get_scoped_tvs :: LSig Name -> [Name]
    -- Both implicit and explicit quantified variables
    -- We need the implicit ones for   f :: forall (a::k). blah
    --    here 'k' scopes too
    get_scoped_tvs (L _ (TypeSig _ sig))
191
       | HsIB { hsib_vars = implicit_vars
192 193
              , hsib_body = hs_ty } <- hswc_body sig
       , (explicit_vars, _) <- splitLHsForAllTy hs_ty
194
       = implicit_vars ++ map hsLTyVarName explicit_vars
195 196
    get_scoped_tvs _ = []

197
    sigs = case binds of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
198 199
             ValBindsIn  _ sigs -> sigs
             ValBindsOut _ sigs -> sigs
200 201 202 203 204 205 206 207 208

{- 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.
209
To achieve this we
210 211 212 213 214 215 216 217 218 219

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

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
230 231
        data T = MkT
        foo = reifyDecl T
232 233

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

236 237
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
238 239
in repTyClD and repC.

240 241 242 243 244 245 246 247 248 249 250 251 252
Note [Don't quantify implicit type variables in quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you're not careful, it's suprisingly easy to take this quoted declaration:

  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
      idProxy x = x
    |]

and have Template Haskell turn it into this:

  idProxy :: forall k proxy (b :: k). proxy b -> proxy b
  idProxy x = x

Gabor Greif's avatar
Gabor Greif committed
253
Notice that we explicitly quantified the variable `k`! This is quite bad, as the
254 255 256 257 258 259 260
latter declaration requires -XTypeInType, while the former does not. Not to
mention that the latter declaration isn't even what the user wrote in the
first place.

Usually, the culprit behind these bugs is taking implicitly quantified type
variables (often from the hsib_vars field of HsImplicitBinders) and putting
them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
261 262
-}

263 264
-- represent associated family instances
--
265
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
266

267 268 269
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
270 271 272
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
273
       ; return (Just (loc, dec)) }
274

275
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
276
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
277 278
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repDataDefn tc1 bndrs Nothing defn
279
       ; return (Just (loc, dec)) }
280

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
281 282 283
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
                             tcdTyVars = tvs, tcdFDs = fds,
                             tcdSigs = sigs, tcdMeths = meth_binds,
284
                             tcdATs = ats, tcdATDefs = atds }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
285 286
  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
       ; dec  <- addTyVarBinds tvs $ \bndrs ->
287
           do { cxt1   <- repLContext cxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
288 289 290
              ; sigs1  <- rep_sigs sigs
              ; binds1 <- rep_binds meth_binds
              ; fds1   <- repLFunDeps fds
291
              ; ats1   <- repFamilyDecls ats
292 293
              ; atds1  <- repAssocTyFamDefaults atds
              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
294
              ; repClass cxt1 cls1 bndrs fds1 decls1
295
              }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
296
       ; return $ Just (loc, dec)
297
       }
298

299 300 301 302 303 304 305 306 307
-------------------------
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) }

308
-------------------------
309 310
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
311
            -> HsDataDefn Name
312
            -> DsM (Core TH.DecQ)
313 314
repDataDefn tc bndrs opt_tys
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
315
                      , dd_cons = cons, dd_derivs = mb_derivs })
316 317
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
318 319 320 321 322 323 324 325 326 327 328 329 330 331
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
                                   ; ksig' <- repMaybeLKind ksig
                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
                                                derivs1 }
           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                       <+> pprQuotedList
                                       (getConNames $ unLoc $ head cons))
           (DataType, _) -> do { ksig' <- repMaybeLKind ksig
                               ; consL <- mapM repC cons
                               ; cons1 <- coreList conQTyConName consL
                               ; repData cxt1 tc bndrs opt_tys ksig' cons1
                                         derivs1 }
       }
332

333
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
334 335
           -> LHsType Name
           -> DsM (Core TH.DecQ)
336
repSynDecl tc bndrs ty
337
  = do { ty1 <- repLTy ty
338 339 340
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Jan Stolarek's avatar
Jan Stolarek committed
341 342 343 344 345
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
346
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
347
       ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
348 349
             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs
                                   , hsq_dependent = emptyNameSet }
Jan Stolarek's avatar
Jan Stolarek committed
350 351 352
             resTyVar = case resultSig of
                     TyVarSig bndr -> mkHsQTvs [bndr]
                     _             -> mkHsQTvs []
353
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370
                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 }
371 372 373
       ; return (loc, dec)
       }

Jan Stolarek's avatar
Jan Stolarek committed
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405
-- | 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 }

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

409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ]
repAssocTyFamDefaults = mapM rep_deflt
  where
     -- very like repTyFamEqn, but different in the details
    rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ)
    rep_deflt (L _ (TyFamEqn { tfe_tycon = tc
                             , tfe_pats  = bndrs
                             , tfe_rhs   = rhs }))
      = addTyClTyVarBinds bndrs $ \ _ ->
        do { tc1  <- lookupLOcc tc
           ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
           ; tys2 <- coreList typeQTyConName tys1
           ; rhs1 <- repLTy rhs
           ; eqn1 <- repTySynEqn tys2 rhs1
           ; repTySynInst tc1 eqn1 }

425
-------------------------
426 427
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
428
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
429
repLFunDeps fds = repList funDepTyConName repLFunDep fds
430

Alan Zimmerman's avatar
Alan Zimmerman committed
431 432 433 434 435
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'
436

437 438 439
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
440 441 442 443 444 445 446 447
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
448
       ; return (loc, dec) }
449

450 451 452
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                         , cid_sigs = prags, cid_tyfam_insts = ats
453 454 455
                         , cid_datafam_insts = adts
                         , cid_overlap_mode = overlap
                         })
456
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
457 458
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
459
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
460 461 462 463 464 465
            --
            -- 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)
            --
466 467
            do { cxt1 <- repLContext cxt
               ; inst_ty1 <- repLTy inst_ty
468
               ; binds1 <- rep_binds binds
469
               ; prags1 <- rep_sigs prags
470 471 472
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
473 474
               ; rOver <- repOverlap (fmap unLoc overlap)
               ; repInst rOver cxt1 inst_ty1 decls }
475
 where
476
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
477

478
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Ryan Scott's avatar
Ryan Scott committed
479 480
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
                                      , deriv_type     = ty }))
481 482
  = do { dec <- addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
Ryan Scott's avatar
Ryan Scott committed
483
                   ; strat'   <- repDerivStrategy strat
484
                   ; inst_ty' <- repLTy inst_ty
Ryan Scott's avatar
Ryan Scott committed
485
                   ; repDeriv strat' cxt' inst_ty' }
486 487
       ; return (loc, dec) }
  where
488
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
489

490
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
491
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
492
  = do { let tc_name = tyFamInstDeclLName decl
493
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
494 495
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
496 497

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
498 499 500 501
repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
                                             , hsib_vars = var_names }
                           , tfe_rhs = rhs }))
  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
502 503
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
504 505 506 507 508 509 510 511
       ; 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
512
                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }
513
                                 , dfid_defn = defn })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
514
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
515
       ; let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
516 517
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
518
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
519
         do { tys1 <- repList typeQTyConName repLTy tys
520
            ; repDataDefn tc bndrs (Just tys1) defn } }
521

522
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
523 524
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
525
 = do MkC name' <- lookupLOcc name
526
      MkC typ' <- repHsSigType typ
527 528
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
529
      cis' <- conv_cimportspec cis
530
      MkC str <- coreStringLit (static ++ chStr ++ cis')
531 532 533
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
534 535
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
536 537 538 539
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
540
    conv_cimportspec CWrapper = return "wrapper"
541 542
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
543
    static = case cis of
544
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
545
                 _ -> ""
546
    chStr = case mch of
547 548
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
549
repForD decl = notHandled "Foreign declaration" (ppr decl)
550 551

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
552 553 554 555 556
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
557 558 559

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

563
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
564
repFixD (L loc (FixitySig names (Fixity _ prec dir)))
565
  = do { MkC prec' <- coreIntLit prec
566
       ; let rep_fn = case dir of
567 568 569
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
570 571 572 573 574
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
575

576 577
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
578 579 580 581
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
582
                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
583 584 585 586 587 588 589
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

590 591
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
592
ruleBndrNames (L _ (RuleBndrSig n sig))
593
  | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
594
  = unLoc n : vars
595

596 597
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
598
  = do { MkC n' <- lookupLBinder n
599
       ; rep2 ruleVarName [n'] }
600
repRuleBndr (L _ (RuleBndrSig n sig))
601
  = do { MkC n'  <- lookupLBinder n
602
       ; MkC ty' <- repLTy (hsSigWcType sig)
603 604
       ; rep2 typedRuleVarName [n', ty'] }

605
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
606
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
607 608 609 610 611 612
  = 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
613
repAnnProv (ValueAnnProvenance (L _ n))
614 615
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
616
repAnnProv (TypeAnnProvenance (L _ n))
617 618 619 620 621
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

622
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
623
--                      Constructors
624 625
-------------------------------------------------------

626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644
repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L _ (ConDeclH98 { con_name = con
                      , con_qvars = Nothing, con_cxt = Nothing
                      , con_details = details }))
  = repDataCon con details

repC (L _ (ConDeclH98 { con_name = con
                      , con_qvars = mcon_tvs, con_cxt = mcxt
                      , con_details = details }))
  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs
             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt
       ; addTyVarBinds con_tvs $ \ ex_bndrs ->
         do { c'    <- repDataCon con details
            ; ctxt' <- repContext ctxt
            ; if isEmptyLHsQTvs con_tvs && null ctxt
              then return c'
              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
            }
       }
645

646
repC (L _ (ConDeclGADT { con_names = cons
647
                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))
648
  | (details, res_ty', L _ [] , []) <- gadtDetails
649
  , [] <- imp_tvs
650 651 652 653 654 655
    -- no implicit or explicit variables, no context = no need for a forall
  = do { let doc = text "In the constructor for " <+> ppr (head cons)
       ; (hs_details, gadt_res_ty) <-
           updateGadtResult failWithDs doc details res_ty'
       ; repGadtDataCons cons hs_details gadt_res_ty }

656
  | (details,res_ty',ctxt, exp_tvs) <- gadtDetails
657
  = do { let doc = text "In the constructor for " <+> ppr (head cons)
658 659
             con_tvs = HsQTvs { hsq_implicit  = imp_tvs
                              , hsq_explicit  = exp_tvs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
660
                              , hsq_dependent = emptyNameSet }
661 662
             -- NB: Don't put imp_tvs into the hsq_explicit field above
             -- See Note [Don't quantify implicit type variables in quotes]
663 664 665 666 667
       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do
       { (hs_details, gadt_res_ty) <-
           updateGadtResult failWithDs doc details res_ty'
       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty
       ; ctxt' <- repContext (unLoc ctxt)
668 669 670
       ; if null exp_tvs && null (unLoc ctxt)
         then return c'
         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
671
  where
672
     gadtDetails = gadtDeclDetails res_ty
673

674 675 676 677 678 679 680 681 682 683 684
repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []

repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []

repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ))
685
repBangTy ty = do
686 687 688
  MkC u <- repSrcUnpackedness su'
  MkC s <- repSrcStrictness ss'
  MkC b <- rep2 bangName [u, s]
689
  MkC t <- repLTy ty'
690
  rep2 bangTypeName [b, t]
691
  where
692 693 694
    (su', ss', ty') = case ty of
            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
            _ -> (NoSrcUnpack, NoSrcStrict, ty)
695 696

-------------------------------------------------------
Ryan Scott's avatar
Ryan Scott committed
697
--                      Deriving clauses
698 699
-------------------------------------------------------

Ryan Scott's avatar
Ryan Scott committed
700 701 702 703 704 705 706 707 708 709
repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ])
repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses

repDerivClause :: LHsDerivingClause Name
               -> DsM (Core TH.DerivClauseQ)
repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
                                      , deriv_clause_tys      = L _ dct }))
  = do MkC dcs' <- repDerivStrategy dcs
       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
       rep2 derivClauseName [dcs',dct']
710
  where
Ryan Scott's avatar
Ryan Scott committed
711 712
    rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ)
    rep_deriv_ty (L _ ty) = repTy ty
713 714 715 716 717

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

718
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
719 720 721
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

722
rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
723
        -- We silently ignore ones we don't recognise
724
rep_sigs' = concatMapM rep_sig
725

726
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
727
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
728
rep_sig (L loc (PatSynSig nms ty))    = mapM (rep_patsyn_ty_sig loc ty) nms
729 730 731
rep_sig (L loc (ClassOpSig is_deflt nms ty))
  | is_deflt                          = mapM (rep_ty_sig defaultSigDName loc ty) nms
  | otherwise                         = mapM (rep_ty_sig sigDName loc ty) nms
732 733
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
734
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
735
rep_sig (L loc (SpecSig nm tys ispec))
736
  = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
737
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
738
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
739
rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
740 741
rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc

742

743
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
744
           -> DsM (SrcSpan, Core TH.DecQ)
745
rep_ty_sig mk_sig loc sig_ty nm
746
  = do { nm1 <- lookupLOcc nm
747
       ; ty1 <- repHsSigType sig_ty
748
       ; sig <- repProto mk_sig nm1 ty1
749
       ; return (loc, sig) }
750

751 752
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name
                  -> DsM (SrcSpan, Core TH.DecQ)
753 754
-- represents a pattern synonym type signature;
-- see Note [Pattern synonym type signatures and Template Haskell] in Convert
755 756 757 758 759 760
rep_patsyn_ty_sig loc sig_ty nm
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repHsPatSynSigType sig_ty
       ; sig <- repProto patSynSigDName nm1 ty1
       ; return (loc, sig) }

761 762
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
              -> DsM (SrcSpan, Core TH.DecQ)
763 764
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
765
rep_wc_ty_sig mk_sig loc sig_ty nm
766
  | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty
767
  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
768 769 770
  = do { nm1 <- lookupLOcc nm
       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                     ; repTyVarBndrWithKind tv name }
771 772 773 774 775
       ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv
                                    explicit_tvs
         -- NB: Don't pass any implicit type variables to repList above
         -- See Note [Don't quantify implicit type variables in quotes]

776 777
       ; th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
778
       ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
779
                then return th_ty
780
                else repTForall th_explicit_tvs th_ctxt th_ty
781 782
       ; sig <- repProto mk_sig nm1 ty1
       ; return (loc, sig) }
783

784
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
785
           -> InlinePragma      -- Never defaultInlinePragma
786
           -> SrcSpan
787 788
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
789 790 791 792 793
  = 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
794 795 796
       ; return [(loc, pragma)]
       }

797
rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
798 799 800
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
801
       ; ty1 <- repHsSigType ty
802 803 804 805 806 807 808 809
       ; 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 }
810 811
       ; return [(loc, pragma)]
       }
812

813
rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
814
rep_specialiseInst ty loc
815
  = do { ty1    <- repHsSigType ty
816 817 818
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

819 820 821 822 823 824
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

825 826 827
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
828

829
repPhases :: Activation -> DsM (Core TH.Phases)
830 831 832 833 834
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
835

836 837 838 839 840 841 842 843 844 845 846 847 848 849 850
rep_complete_sig :: Located [Located Name]
                 -> Maybe (Located Name)
                 -> SrcSpan
                 -> DsM [(SrcSpan, Core TH.DecQ)]
rep_complete_sig (L _ cls) mty loc
  = do { mty' <- rep_maybe_name mty
       ; cls' <- repList nameTyConName lookupLOcc cls
       ; sig <- repPragComplete cls' mty'
       ; return [(loc, sig)] }
  where
    rep_maybe_name Nothing = coreNothing nameTyConName
    rep_maybe_name (Just n) = do
      cn <- lookupLOcc n
      coreJust nameTyConName cn

851
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
852
--                      Types
853
-------------------------------------------------------
854

855 856 857 858 859 860 861 862 863
addSimpleTyVarBinds :: [Name]                -- the binders to be added
                    -> DsM (Core (TH.Q a))   -- action in the ext env
                    -> DsM (Core (TH.Q a))
addSimpleTyVarBinds names thing_inside
  = do { fresh_names <- mkGenSyms names
       ; term <- addBinds fresh_names thing_inside
       ; wrapGenSyms fresh_names term }

addTyVarBinds :: LHsQTyVars Name                            -- the binders to be added
864 865
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
866 867
-- 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
868
-- meta environment and gets the *new* names on Core-level as an argument
869

870 871 872 873
addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
  = do { fresh_imp_names <- mkGenSyms imp_tvs
       ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
       ; let fresh_names = fresh_imp_names ++ fresh_exp_names
874
       ; term <- addBinds fresh_names $
875 876
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
                                     (exp_tvs `zip` fresh_exp_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
877
                    ; m kbs }
878
       ; wrapGenSyms fresh_names term }
879 880
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
881

882
addTyClTyVarBinds :: LHsQTyVars Name
883 884
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
885 886 887 888 889 890 891

-- 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
892
  = do { let tv_names = hsAllLTyVarNames tvs
893 894
       ; env <- dsGetMetaEnv
       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
895
            -- Make fresh names for the ones that are not already in scope
896 897
            -- This makes things work for family declarations

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
898
       ; term <- addBinds freshNames $
899
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
900
                    ; m kbs }
901 902 903

       ; wrapGenSyms freshNames term }
  where
904
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
905
                       ; repTyVarBndrWithKind tv v }
906 907 908

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
909
repTyVarBndrWithKind :: LHsTyVarBndr Name
910
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
911
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
912
  = repPlainTV nm
913
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
914
  = repLKind ki >>= repKindedTV nm
915

Jan Stolarek's avatar
Jan Stolarek committed
916 917
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
918 919
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
Jan Stolarek's avatar
Jan Stolarek committed
920 921 922 923
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLKind ki
                                                  ; repKindedTV nm' ki' }

924 925
-- represent a type context
--
926 927 928
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

933
repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
934
repHsSigType (HsIB { hsib_vars = implicit_tvs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
935 936
                   , hsib_body = body })
  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
937 938
  = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs
                          , hsq_explicit = explicit_tvs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
939
                          , hsq_dependent = emptyNameSet })
940 941 942
    -- NB: Don't pass implicit_tvs to the hsq_explicit field above
    -- See Note [Don't quantify implicit type variables in quotes]
                  $ \ th_explicit_tvs ->
943 944
    do { th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
945
       ; if null explicit_tvs && null (unLoc ctxt)
946
         then return th_ty
947
         else repTForall th_explicit_tvs th_ctxt th_ty }
948

949 950 951
repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
                         , hsib_body = body })
952 953
  = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs ->
      addTyVarBinds (newTvs [] exis) $ \th_exis ->
954 955 956 957 958
    do { th_reqs  <- repLContext reqs
       ; th_provs <- repLContext provs
       ; th_ty    <- repLTy ty
       ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
  where
959 960 961
    newTvs impl_tvs expl_tvs = HsQTvs
      { hsq_implicit  = impl_tvs
      , hsq_explicit  = expl_tvs
962
      , hsq_dependent = emptyNameSet }
963 964 965
    -- NB: Don't pass impl_tvs to the hsq_explicit field above
    -- See Note [Don't quantify implicit type variables in quotes]

966 967
    (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
968
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
969 970
repHsSigWcType (HsWC { hswc_body = sig1 })
  = repHsSigType sig1
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
971

972
-- yield the representation of a list of types
973 974
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
975

976
-- represent a type
977 978 979
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

980 981 982 983
repForall :: HsType Name -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed