DsMeta.hs 102 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"

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

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

28
import qualified Language.Haskell.TH as TH
29

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

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

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

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

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

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

{- -------------- 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))
-}


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

309
-------------------------
310 311
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
312
            -> HsDataDefn GhcRn
313
            -> DsM (Core TH.DecQ)
314 315
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
316
                      , dd_cons = cons, dd_derivs = mb_derivs })
317 318
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
319 320 321 322 323 324 325 326 327 328 329 330 331 332
       ; 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 }
       }
333

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

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

Jan Stolarek's avatar
Jan Stolarek committed
375
-- | Represent result signature of a type family
376
repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSig)
Jan Stolarek's avatar
Jan Stolarek committed
377 378 379 380 381 382 383 384 385
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.
386
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
Jan Stolarek's avatar
Jan Stolarek committed
387 388 389 390 391 392 393 394 395
                              -> 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
396
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
Jan Stolarek's avatar
Jan Stolarek committed
397 398 399 400 401 402 403 404 405 406
                  -> 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 }

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

410
repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]
411 412 413
repAssocTyFamDefaults = mapM rep_deflt
  where
     -- very like repTyFamEqn, but different in the details
414
    rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
415 416 417 418 419 420 421 422 423 424 425
    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 }

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

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

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

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

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

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

498
repTyFamEqn :: LTyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
499 500 501 502
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
503 504
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
505 506 507 508 509 510
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { tys1 <- repLTys tys
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
            ; repTySynEqn tys2 rhs1 } }

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

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

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

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

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

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

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

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

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

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

627
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645
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'])
            }
       }
646

647
repC (L _ (ConDeclGADT { con_names = cons
648
                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))
649
  | (details, res_ty', L _ [] , []) <- gadtDetails
650
  , [] <- imp_tvs
651 652 653 654 655 656
    -- 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 }

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

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

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

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

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

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

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

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

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

743

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

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

762
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
763
              -> DsM (SrcSpan, Core TH.DecQ)
764 765
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
766
rep_wc_ty_sig mk_sig loc sig_ty nm
767
  | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty
768
  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
769 770 771
  = do { nm1 <- lookupLOcc nm
       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                     ; repTyVarBndrWithKind tv name }
772 773 774 775 776
       ; 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]

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

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

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

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

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

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

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

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

854
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
855
--                      Types
856
-------------------------------------------------------
857

858 859 860 861 862 863 864 865
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 }

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

873 874 875 876
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
877
       ; term <- addBinds fresh_names $
878 879
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
                                     (exp_tvs `zip` fresh_exp_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
880
                    ; m kbs }
881
       ; wrapGenSyms fresh_names term }
882 883
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
884

885
addTyClTyVarBinds :: LHsQTyVars GhcRn
886 887
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
888 889 890 891 892 893 894

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

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

       ; wrapGenSyms freshNames term }
  where
907
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
908
                       ; repTyVarBndrWithKind tv v }
909 910 911

-- Produce kinded binder constructors from the Haskell tyvar binders
--
912
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
913
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
914
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
915
  = repPlainTV nm
916
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
917
  = repLKind ki >>= repKindedTV nm
918

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

927 928
-- represent a type context
--
929
repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
930 931
repLContext (L _ ctxt) = repContext ctxt

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

936
repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
937
repHsSigType (HsIB { hsib_vars = implicit_tvs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
938 939
                   , hsib_body = body })
  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body