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

4
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
5 6 7
--
-- (c) The University of Glasgow 2006
--
8 9 10 11
-- 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.
12 13
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Gabor Greif's avatar
typos  
Gabor Greif committed
14
-- in prelude/PrelNames.  It's much more convenient to do it here, because
15 16
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
17 18
-----------------------------------------------------------------------------

19
module DsMeta( dsBracket ) where
20

21 22
#include "HsVersions.h"

23 24
import GhcPrelude

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

Simon Marlow's avatar
Simon Marlow committed
27
import MatchLit
28 29
import DsMonad

30
import qualified Language.Haskell.TH as TH
31

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

Simon Marlow's avatar
Simon Marlow committed
41 42
import Module
import Id
43
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
44
import THNames
45
import NameEnv
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
46
import NameSet
Simon Marlow's avatar
Simon Marlow committed
47 48 49
import TcType
import TyCon
import TysWiredIn
50
import CoreSyn
51
import MkCore
Simon Marlow's avatar
Simon Marlow committed
52 53 54 55
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
56
import Outputable
Simon Marlow's avatar
Simon Marlow committed
57
import Bag
58
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
59 60
import FastString
import ForeignCall
61
import Util
62
import Maybes
63
import MonadUtils
64

65
import Data.ByteString ( unpack )
Simon Marlow's avatar
Simon Marlow committed
66 67
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
68

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

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

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

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

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


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


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

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

112
repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
113 114 115 116 117 118 119 120 121 122 123 124
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 })
125 126 127
 = do { let { bndrs  = hsSigTvBinders valds
                       ++ hsGroupBinders group
                       ++ hsPatSynSelectors valds
128
            ; instds = tyclds >>= group_instds } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
129
        ss <- mkGenSyms bndrs ;
130

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

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

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

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

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

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

184
hsSigTvBinders :: HsValBinds GhcRn -> [Name]
185 186
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
187
  = concatMap get_scoped_tvs sigs
188
  where
189
    get_scoped_tvs :: LSig GhcRn -> [Name]
190 191 192 193
    -- 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))
194
       | HsIB { hsib_vars = implicit_vars
195 196
              , hsib_body = hs_ty } <- hswc_body sig
       , (explicit_vars, _) <- splitLHsForAllTy hs_ty
197
       = implicit_vars ++ map hsLTyVarName explicit_vars
198 199
    get_scoped_tvs _ = []

200
    sigs = case binds of
Ben Gamari's avatar
Ben Gamari committed
201 202
             ValBindsIn  _ sigs -> sigs
             ValBindsOut _ sigs -> sigs
203 204 205 206 207 208 209 210 211

{- 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.
212
To achieve this we
213 214 215 216 217 218 219 220 221 222

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

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
233 234
        data T = MkT
        foo = reifyDecl T
235 236

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

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

243 244 245 246 247 248 249 250 251 252 253 254 255
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
256
Notice that we explicitly quantified the variable `k`! This is quite bad, as the
257 258 259 260 261 262 263
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.
264 265
-}

266 267
-- represent associated family instances
--
268
repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
269

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

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

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

302
-------------------------
303
repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
304 305 306 307 308 309 310
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) }

311
-------------------------
Ryan Scott's avatar
Ryan Scott committed
312
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
313
            -> Maybe (Core [TH.TypeQ])
314
            -> HsDataDefn GhcRn
315
            -> DsM (Core TH.DecQ)
316 317
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
318
                      , dd_cons = cons, dd_derivs = mb_derivs })
319 320
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
321 322
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
Ryan Scott's avatar
Ryan Scott committed
323
                                   ; ksig' <- repMaybeLTy ksig
324 325 326 327 328
                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
                                                derivs1 }
           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                       <+> pprQuotedList
                                       (getConNames $ unLoc $ head cons))
Ryan Scott's avatar
Ryan Scott committed
329
           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
330 331 332 333 334
                               ; consL <- mapM repC cons
                               ; cons1 <- coreList conQTyConName consL
                               ; repData cxt1 tc bndrs opt_tys ksig' cons1
                                         derivs1 }
       }
335

Ryan Scott's avatar
Ryan Scott committed
336
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
337
           -> LHsType GhcRn
338
           -> DsM (Core TH.DecQ)
339
repSynDecl tc bndrs ty
340
  = do { ty1 <- repLTy ty
341 342
       ; repTySyn tc bndrs ty1 }

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

Jan Stolarek's avatar
Jan Stolarek committed
377
-- | Represent result signature of a type family
Ryan Scott's avatar
Ryan Scott committed
378
repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
Jan Stolarek's avatar
Jan Stolarek committed
379
repFamilyResultSig  NoSig          = repNoSig
Ryan Scott's avatar
Ryan Scott committed
380
repFamilyResultSig (KindSig ki)    = do { ki' <- repLTy ki
Jan Stolarek's avatar
Jan Stolarek committed
381 382 383 384 385 386 387
                                        ; 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.
388
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
Ryan Scott's avatar
Ryan Scott committed
389
                              -> DsM (Core (Maybe TH.KindQ))
Jan Stolarek's avatar
Jan Stolarek committed
390
repFamilyResultSigToMaybeKind NoSig =
Ryan Scott's avatar
Ryan Scott committed
391
    do { coreNothing kindQTyConName }
Jan Stolarek's avatar
Jan Stolarek committed
392
repFamilyResultSigToMaybeKind (KindSig ki) =
Ryan Scott's avatar
Ryan Scott committed
393 394
    do { ki' <- repLTy ki
       ; coreJust kindQTyConName ki' }
Jan Stolarek's avatar
Jan Stolarek committed
395 396 397
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"

-- | Represent injectivity annotation of a type family
398
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
Jan Stolarek's avatar
Jan Stolarek committed
399 400 401 402 403 404 405 406 407 408
                  -> 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 }

409
repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
410
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
411

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

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

Alan Zimmerman's avatar
Alan Zimmerman committed
434 435 436 437 438
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'
439

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

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

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

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

500 501 502 503
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (HsIB { hsib_vars = var_names
                  , hsib_body = FamEqn { feqn_pats = tys
                                       , feqn_rhs  = rhs }})
504
  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
505 506
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
507 508 509 510 511 512
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { tys1 <- repLTys tys
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
            ; repTySynEqn tys2 rhs1 } }

513
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
514 515 516 517 518
repDataFamInstD (DataFamInstDecl { dfid_eqn =
                  (HsIB { hsib_vars = var_names
                        , hsib_body = FamEqn { feqn_tycon = tc_name
                                             , feqn_pats  = tys
                                             , feqn_rhs   = defn }})})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
519
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
520
       ; let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
521 522
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
523
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
524
         do { tys1 <- repList typeQTyConName repLTy tys
525
            ; repDataDefn tc bndrs (Just tys1) defn } }
526

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

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
557 558 559 560 561
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
562 563 564

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

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

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

595
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
596
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
597
ruleBndrNames (L _ (RuleBndrSig n sig))
598
  | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
599
  = unLoc n : vars
600

601
repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
602
repRuleBndr (L _ (RuleBndr n))
603
  = do { MkC n' <- lookupLBinder n
604
       ; rep2 ruleVarName [n'] }
605
repRuleBndr (L _ (RuleBndrSig n sig))
606
  = do { MkC n'  <- lookupLBinder n
607
       ; MkC ty' <- repLTy (hsSigWcType sig)
608 609
       ; rep2 typedRuleVarName [n', ty'] }

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

627
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
628
--                      Constructors
629 630
-------------------------------------------------------

631
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
632
repC (L _ (ConDeclH98 { con_name = con
633 634 635 636
                      , con_forall = False
                      , con_mb_cxt = Nothing
                      , con_args = args }))
  = repDataCon con args
637 638

repC (L _ (ConDeclH98 { con_name = con
639 640 641 642 643 644 645 646
                      , con_forall = is_existential
                      , con_ex_tvs = con_tvs
                      , con_mb_cxt = mcxt
                      , con_args = args }))
  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
         do { c'    <- repDataCon con args
            ; ctxt' <- repMbContext mcxt
            ; if not is_existential && isNothing mcxt
647 648 649 650
              then return c'
              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
            }
       }
651

652
repC (L _ (ConDeclGADT { con_names = cons
653 654 655 656 657 658 659 660 661
                       , con_qvars = qtvs, con_mb_cxt = mcxt
                       , con_args = args, con_res_ty = res_ty }))
  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
  , Nothing <- mcxt      -- No context
                         -- ==> no need for a forall
  = repGadtDataCons cons args res_ty

  | otherwise
  = addTyVarBinds qtvs $ \ ex_bndrs ->
662
             -- See Note [Don't quantify implicit type variables in quotes]
663 664 665
    do { c'    <- repGadtDataCons cons args res_ty
       ; ctxt' <- repMbContext mcxt
       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
666
         then return c'
667 668 669 670 671
         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }

repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing          = repContext []
repMbContext (Just (L _ cxt)) = repContext cxt
672

673 674 675 676 677 678 679 680 681 682
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 []

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

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

699
repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
Ryan Scott's avatar
Ryan Scott committed
700 701
repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses

702
repDerivClause :: LHsDerivingClause GhcRn
Ryan Scott's avatar
Ryan Scott committed
703 704 705 706 707 708
               -> 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']
709
  where
710
    rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
Ryan Scott's avatar
Ryan Scott committed
711
    rep_deriv_ty (L _ ty) = repTy ty
712 713 714 715 716

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

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

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

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

741

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

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

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

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

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

796 797
rep_specialise :: Located Name -> LHsSigType GhcRn -> 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
       ; phases <- repPhases $ inl_act ispec
       ; let inline = inl_inline ispec
804
       ; pragma <- if noUserInlineSpec inline
805 806 807 808 809
                   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 814
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
                   -> DsM [(SrcSpan, Core TH.DecQ)]
815
rep_specialiseInst ty loc
816
  = do { ty1    <- repHsSigType ty
817 818 819
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

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

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

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

837 838 839 840 841 842 843 844 845 846 847 848 849 850 851
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

852
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
853
--                      Types
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 }

864 865 866 867 868 869 870 871 872 873 874 875 876
addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added
                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
                -> DsM (Core (TH.Q a))
addHsTyVarBinds exp_tvs thing_inside
  = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
       ; term <- addBinds fresh_exp_names $
                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
                                     (exp_tvs `zip` fresh_exp_names)
                    ; thing_inside kbs }
       ; wrapGenSyms fresh_exp_names term }
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)

877
addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
Ryan Scott's avatar
Ryan Scott committed
878
              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
879
              -> DsM (Core (TH.Q a))
880 881
-- 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
882
-- meta environment and gets the *new* names on Core-level as an argument
883 884 885 886 887
addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs })
              thing_inside
  = addSimpleTyVarBinds imp_tvs $
    addHsTyVarBinds exp_tvs $
    thing_inside
888

889
addTyClTyVarBinds :: LHsQTyVars GhcRn
Ryan Scott's avatar
Ryan Scott committed
890
                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
891
                  -> DsM (Core (TH.Q a))
892 893 894 895 896 897 898

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
905
       ; term <- addBinds freshNames $
Ryan Scott's avatar
Ryan Scott committed
906 907
                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
                                     (hsQTvExplicit tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
908
                    ; m kbs }
909 910 911

       ; wrapGenSyms freshNames term }
  where
Ryan Scott's avatar
Ryan Scott committed
912
    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
913
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
914
                       ; repTyVarBndrWithKind tv v }
915 916 917

-- Produce kinded binder constructors from the Haskell tyvar binders
--
918
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
Ryan Scott's avatar
Ryan Scott committed
919
                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
Ben Gamari's avatar
Ben Gamari committed
920
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
921
  = repPlainTV nm
Ben Gamari's avatar
Ben Gamari committed
922
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
Ryan Scott's avatar
Ryan Scott committed
923
  = repLTy ki >>= repKindedTV nm
924

Jan Stolarek's avatar
Jan Stolarek committed
925
-- | Represent a type variable binder
Ryan Scott's avatar
Ryan Scott committed
926
repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
Ben Gamari's avatar
Ben Gamari committed
927 928 929 930 931
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLTy ki
                                                  ; repKindedTV nm' ki' }
Jan Stolarek's avatar
Jan Stolarek committed
932

933 934
-- represent a type context
--
935
repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)