DsMeta.hs 99.7 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

80 81 82 83 84 85 86 87
    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 }
    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103

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


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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
132 133 134 135 136 137
        -- Bind all the names mainly to avoid repeated use of explicit strings.
        -- Thus we get
        --      do { t :: String <- genSym "T" ;
        --           return (Data t [] ...more t's... }
        -- The other important reason is that the output must mention
        -- only "T", not "Foo:T" where Foo is the current module
138

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

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

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

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

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

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

201
    sigs = case binds of
202 203
             ValBinds           _ _ sigs  -> sigs
             XValBindsLR (NValBinds _ sigs) -> sigs
204 205 206 207 208 209 210 211 212

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

632
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650
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'])
            }
       }
651

652
repC (L _ (ConDeclGADT { con_names = cons
653
                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))
654
  | (details, res_ty', L _ [] , []) <- gadtDetails
655
  , [] <- imp_tvs
656 657 658 659 660 661
    -- 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 }

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

680 681 682 683 684 685 686 687 688 689
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 []

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

-------------------------------------------------------
Ryan Scott's avatar
Ryan Scott committed
703
--                      Deriving clauses
704 705
-------------------------------------------------------

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

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

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

724
rep_sigs :: [LSig GhcRn] -> DsM [Core TH.DecQ]
725 726 727
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

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

748

749
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
750
           -> DsM (SrcSpan, Core TH.DecQ)
751
rep_ty_sig mk_sig loc sig_ty nm
752
  = do { nm1 <- lookupLOcc nm
753
       ; ty1 <- repHsSigType sig_ty
754
       ; sig <- repProto mk_sig nm1 ty1
755
       ; return (loc, sig) }
756

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

767
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
768
              -> DsM (SrcSpan, Core TH.DecQ)
769 770
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
771
rep_wc_ty_sig mk_sig loc sig_ty nm
772
  | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty
773
  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
774 775 776
  = 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
777
       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
778 779 780 781
                                    explicit_tvs
         -- NB: Don't pass any implicit type variables to repList above
         -- See Note [Don't quantify implicit type variables in quotes]

782 783
       ; th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
784
       ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
785
                then return th_ty
786
                else repTForall th_explicit_tvs th_ctxt th_ty
787 788
       ; sig <- repProto mk_sig nm1 ty1
       ; return (loc, sig) }
789

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

803 804
rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
               -> SrcSpan
805 806 807
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
808
       ; ty1 <- repHsSigType ty
809 810
       ; phases <- repPhases $ inl_act ispec
       ; let inline = inl_inline ispec
811
       ; pragma <- if noUserInlineSpec inline
812 813 814 815 816
                   then -- SPECIALISE
                     repPragSpec nm1 ty1 phases
                   else -- SPECIALISE INLINE
                     do { inline1 <- repInline inline
                        ; repPragSpecInl nm1 ty1 inline1 phases }
817 818
       ; return [(loc, pragma)]
       }
819

820 821
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
                   -> DsM [(SrcSpan, Core TH.DecQ)]
822
rep_specialiseInst ty loc
823
  = do { ty1    <- repHsSigType ty
824 825 826
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

827 828 829 830 831 832
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

833 834 835
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
836

837
repPhases :: Activation -> DsM (Core TH.Phases)
838 839 840 841 842
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
843

844 845 846 847 848 849 850 851 852 853 854 855 856 857 858
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

859
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
860
--                      Types
861
-------------------------------------------------------
862

863 864 865 866 867 868 869 870
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 }

871
addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
Ryan Scott's avatar
Ryan Scott committed
872
              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
873
              -> DsM (Core (TH.Q a))
874 875
-- 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
876
-- meta environment and gets the *new* names on Core-level as an argument
877

878 879 880 881
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
882
       ; term <- addBinds fresh_names $
Ryan Scott's avatar
Ryan Scott committed
883
                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
884
                                     (exp_tvs `zip` fresh_exp_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
885
                    ; m kbs }
886
       ; wrapGenSyms fresh_names term }
887 888
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
889

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

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

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

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

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