DsMeta.hs 88.8 KB
Newer Older
1
2
{-# LANGUAGE CPP #-}

3
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
4
5
6
--
-- (c) The University of Glasgow 2006
--
7
8
9
10
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
11
12
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Gabor Greif's avatar
typos    
Gabor Greif committed
13
-- in prelude/PrelNames.  It's much more convenient to do it here, because
14
15
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
16
17
-----------------------------------------------------------------------------

18
module DsMeta( dsBracket ) where
19

20
21
#include "HsVersions.h"

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

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

27
import qualified Language.Haskell.TH as TH
28

29
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
30
31
32
33
34
35
import Class
import PrelNames
-- To avoid clashes with DsMeta.varName we must make a local alias for
-- OccName.varName we do this by removing varName from the import of
-- OccName above, making a qualified instance of OccName and using
-- OccNameAlias.varName where varName ws previously used in this file.
36
import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
37

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

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

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

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

dreixel's avatar
dreixel committed
77
    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
78
79
80
81
82
    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
83
    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

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

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


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


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

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

109
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
110
111
112
113
114
115
116
117
118
119
120
121
122
123
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , hs_instds  = instds
                        , hs_derivds = derivds
                        , hs_fixds   = fixds
                        , hs_defds   = defds
                        , hs_fords   = fords
                        , hs_warnds  = warnds
                        , hs_annds   = annds
                        , hs_ruleds  = ruleds
                        , hs_vects   = vects
                        , hs_docs    = docs })
 = do { let { tv_bndrs = hsSigTvBinders valds
124
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
125
        ss <- mkGenSyms bndrs ;
126

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

134
        decls <- addBinds ss (
135
136
137
138
139
140
141
142
143
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
                     ; tycl_ds  <- mapM repTyClD (tyClGroupConcat tyclds)
                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
                     ; inst_ds  <- mapM repInstD instds
                     ; deriv_ds <- mapM repStandaloneDerivD derivds
                     ; fix_ds   <- mapM repFixD fixds
                     ; _        <- mapM no_default_decl defds
                     ; for_ds   <- mapM repForD fords
Alan Zimmerman's avatar
Alan Zimmerman committed
144
145
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
146
                     ; ann_ds   <- mapM repAnnD annds
Alan Zimmerman's avatar
Alan Zimmerman committed
147
148
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
149
150
                     ; _        <- mapM no_vect vects
                     ; _        <- mapM no_doc docs
151

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

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

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

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

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


{- Notes

Note [Scoped type variables in bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f :: forall a. a -> a
   f x = x::a
Here the 'forall a' brings 'a' into scope over the binding group.
199
To achieve this we
200
201
202
203
204
205
206
207
208
209

  a) Gensym a binding for 'a' at the same time as we do one for 'f'
     collecting the relevant binders with hsSigTvBinders

  b) When processing the 'forall', don't gensym

The relevant places are signposted with references to this Note

Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
210
211
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
212
        Data "T" [] [Con "MkT" []] []
213
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
214
        Data "Foo:T" [] [Con "Foo:MkT" []] []
215
216
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
217
        Data "T79" ....
218
219

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

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

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

-}

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

236
237
238
repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)

repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
239
240
241
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
242
       ; return (Just (loc, dec)) }
243

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

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

269
270
271
272
273
274
275
276
277
-------------------------
repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRoleD (L loc (RoleAnnotDecl tycon roles))
  = do { tycon1 <- lookupLOcc tycon
       ; roles1 <- mapM repRole roles
       ; roles2 <- coreList roleTyConName roles1
       ; dec <- repRoleAnnotD tycon1 roles2
       ; return (loc, dec) }

278
-------------------------
279
280
281
282
283
284
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
            -> [Name] -> HsDataDefn Name
            -> DsM (Core TH.DecQ)
repDataDefn tc bndrs opt_tys tv_names
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
285
                      , dd_cons = cons, dd_derivs = mb_derivs })
286
287
288
289
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
290
291
292
293
294
295
296
297
298
                          ; case con1 of
                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
                             _cs -> failWithDs (ptext
                                     (sLit "Multiple constructors for newtype:")
                                      <+> pprQuotedList
                                                (con_names $ unLoc $ head cons))
                          }
           DataType -> do { consL <- concatMapM (repC tv_names) cons
                          ; cons1 <- coreList conQTyConName consL
299
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
300

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

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Jan Stolarek's avatar
Jan Stolarek committed
309
310
311
312
313
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
314
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
Jan Stolarek's avatar
Jan Stolarek committed
315
316
317
318
       ; let mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
             resTyVar = case resultSig of
                     TyVarSig bndr -> mkHsQTvs [bndr]
                     _             -> mkHsQTvs []
319
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
                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 }
337
338
339
       ; return (loc, dec)
       }

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

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

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

372
373
repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
374

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ]
repAssocTyFamDefaults = mapM rep_deflt
  where
     -- very like repTyFamEqn, but different in the details
    rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ)
    rep_deflt (L _ (TyFamEqn { tfe_tycon = tc
                             , tfe_pats  = bndrs
                             , tfe_rhs   = rhs }))
      = addTyClTyVarBinds bndrs $ \ _ ->
        do { tc1  <- lookupLOcc tc
           ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
           ; tys2 <- coreList typeQTyConName tys1
           ; rhs1 <- repLTy rhs
           ; eqn1 <- repTySynEqn tys2 rhs1
           ; repTySynInst tc1 eqn1 }

391
-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
392
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
393
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
394
395
396
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
397
mk_extra_tvs tc tvs defn
398
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
399
  = do { extra_tvs <- go hs_kind
400
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
401
402
  | otherwise
  = return tvs
403
404
405
406
407
408
  where
    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
    go (L loc (HsFunTy kind rest))
      = do { uniq <- newUnique
           ; let { occ = mkTyVarOccFS (fsLit "t")
                 ; nm = mkInternalName uniq occ loc
Alan Zimmerman's avatar
Alan Zimmerman committed
409
                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
410
411
412
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

413
    go (L _ (HsTyVar (L _ n)))
414
415
      | n == liftedTypeKindTyConName
      = return []
416

417
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
418
419

-------------------------
420
421
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
422
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
423
repLFunDeps fds = repList funDepTyConName repLFunDep fds
424

Alan Zimmerman's avatar
Alan Zimmerman committed
425
426
427
428
429
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'
430

431
432
433
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
434
435
436
437
438
439
440
441
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
442
       ; return (loc, dec) }
443

444
445
446
447
448
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                         , cid_sigs = prags, cid_tyfam_insts = ats
                         , cid_datafam_insts = adts })
  = addTyVarBinds tvs $ \_ ->
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
449
450
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
451
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
452
453
454
455
456
457
            --
            -- 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)
            --
458
            do { cxt1 <- repContext cxt
459
               ; cls_tcon <- repTy (HsTyVar cls)
batterseapower's avatar
batterseapower committed
460
461
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
462
               ; binds1 <- rep_binds binds
463
               ; prags1 <- rep_sigs prags
464
465
466
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
467
               ; repInst cxt1 inst_ty1 decls }
468
 where
469
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
470

471
472
473
474
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
  = do { dec <- addTyVarBinds tvs $ \_ ->
                do { cxt' <- repContext cxt
475
                   ; cls_tcon <- repTy (HsTyVar cls)
476
477
478
479
480
481
482
                   ; cls_tys <- repLTys tys
                   ; inst_ty <- repTapps cls_tcon cls_tys
                   ; repDeriv cxt' inst_ty }
       ; return (loc, dec) }
  where
    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty

483
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
484
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
485
  = do { let tc_name = tyFamInstDeclLName decl
486
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
487
488
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
489
490

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
491
492
493
494
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
495
496
497
498
499
500
501
502
503
504
505
506
  = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
                             , hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { tys1 <- repLTys tys
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
            ; repTySynEqn tys2 rhs1 } }

repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
                                 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
                                 , dfid_defn = defn })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
507
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
508
       ; let loc = getLoc tc_name
509
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
510
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
511
         do { tys1 <- repList typeQTyConName repLTy tys
512
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
513

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

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
543
544
545
546
547
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
548
549
550

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

554
555
556
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity prec dir)))
  = do { MkC prec' <- coreIntLit prec
557
       ; let rep_fn = case dir of
558
559
560
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
561
562
563
564
565
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
566

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
567
568
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
569
570
571
572
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
573
                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
574
575
576
577
578
579
580
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

581
582
583
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
584
  = unLoc n : kvs ++ tvs
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
585

586
587
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
588
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
589
       ; rep2 ruleVarName [n'] }
590
repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
591
  = do { MkC n'  <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
592
593
594
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

595
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
596
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
597
598
599
600
601
602
  = 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
603
repAnnProv (ValueAnnProvenance (L _ n))
604
605
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
606
repAnnProv (TypeAnnProvenance (L _ n))
607
608
609
610
611
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

612
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
613
--                      Constructors
614
615
-------------------------------------------------------

616
617
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
618
                     , con_details = details, con_res = ResTyH98 }))
619
  | null (hsQTvBndrs con_tvs)
620
621
  = do { con1 <- mapM lookupLOcc con       -- See Note [Binders and occurrences]
       ; mapM (\c -> repConstr c details) con1  }
622

623
repC tvs (L _ (ConDecl { con_names = cons
624
625
626
627
                       , con_qvars = con_tvs, con_cxt = L _ ctxt
                       , con_details = details
                       , con_res = res_ty }))
  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
628
629
630
       ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
                             , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
631
       ; binds <- mapM dupBinder con_tv_subst
632
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
633
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
634
635
    do { cons1     <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
       ; c'        <- mapM (\c -> repConstr c details) cons1
636
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
637
638
639
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
    ; return [b]
    }
640

641
642
643
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
644

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
645
mkGadtCtxt :: [Name]            -- Tyvars of the data type
646
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
647
           -> DsM (HsContext Name, [(Name,Name)])
648
649
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
650
651
652
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
653
-- Example:
654
655
-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
--     mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
656
657
658
--   returns
--     (b~[e], c~e), [d->a]
--
659
660
661
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
Alan Zimmerman's avatar
Alan Zimmerman committed
662
mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
663
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
664
665
666
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

667
  | otherwise
668
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
669
670
671
672
673
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
674
       , not (in_subst subst con_tv)
675
676
677
678
679
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
680
         eq_pred = L loc (HsEqTy (L loc (HsTyVar (L loc data_tv))) ty)
681

682
683
684
    is_hs_tyvar (L _ (HsTyVar (L _ n))) = Just n  -- Type variables *and* tycons
    is_hs_tyvar (L _ (HsParTy ty))      = is_hs_tyvar ty
    is_hs_tyvar _                       = Nothing
685

686

687
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
688
repBangTy ty = do
689
690
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
691
  rep2 strictTypeName [s, t]
692
  where
693
    (str, ty') = case ty of
694
695
696
697
698
         L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty)
           -> (unpackedName,  ty)
         L _ (HsBangTy (HsSrcBang _ _         SrcStrict) ty)
           -> (isStrictName,  ty)
         _ -> (notStrictName, ty)
699
700

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
701
--                      Deriving clause
702
703
-------------------------------------------------------

704
repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
705
repDerivs Nothing = coreList nameTyConName []
706
repDerivs (Just (L _ ctxt))
707
  = repList nameTyConName rep_deriv ctxt
708
  where
709
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
710
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
711
712
713
714
715
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
716
717
718
719
720
721


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

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

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

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

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

761
    rep_ty ty = repTy ty
762

763
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
764
           -> InlinePragma      -- Never defaultInlinePragma
765
           -> SrcSpan
766
767
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
768
769
770
771
772
  = 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
773
774
775
       ; return [(loc, pragma)]
       }

776
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
777
778
779
780
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
781
782
783
784
785
786
787
788
       ; 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 }
789
790
       ; return [(loc, pragma)]
       }
791

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
792
793
794
795
796
797
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

798
799
800
801
802
803
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
804
805
806
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
807

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
808
809
810
811
812
813
repPhases :: Activation -> DsM (Core TH.Phases)
repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
                                ; dataCon' beforePhaseDataConName [arg] }
repPhases (ActiveAfter i)  = do { MkC arg <- coreIntLit i
                                ; dataCon' fromPhaseDataConName [arg] }
repPhases _                = dataCon allPhasesDataConName
814
815

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
816
--                      Types
817
-------------------------------------------------------
818

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
819
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
820
821
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
chak's avatar
chak committed
822
823
-- 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
chak's avatar
chak committed
824
-- meta environment and gets the *new* names on Core-level as an argument
825

826
827
828
829
830
831
addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
  = do { fresh_kv_names <- mkGenSyms kvs
       ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
       ; let fresh_names = fresh_kv_names ++ fresh_tv_names
       ; term <- addBinds fresh_names $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
832
                    ; m kbs }
833
       ; wrapGenSyms fresh_names term }
834
835
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
chak's avatar
chak committed
836

837
addTyClTyVarBinds :: LHsTyVarBndrs Name
838
839
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
840
841
842
843
844
845
846

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
853
854
855
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
856
857
858

       ; wrapGenSyms freshNames term }
  where
859
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
860
                       ; repTyVarBndrWithKind tv v }
861
862
863

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
864
repTyVarBndrWithKind :: LHsTyVarBndr Name
865
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
866
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
867
  = repPlainTV nm
868
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
869
  = repLKind ki >>= repKindedTV nm
870

Jan Stolarek's avatar
Jan Stolarek committed
871
872
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
873
874
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
Jan Stolarek's avatar
Jan Stolarek committed
875
876
877
878
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLKind ki
                                                  ; repKindedTV nm' ki' }

chak's avatar
chak committed
879
880
-- represent a type context
--
881
882
883
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

chak's avatar
chak committed
888
889
-- yield the representation of a list of types
--
890
891
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
892

chak's avatar
chak committed
893
894
-- represent a type
--
895
896
897
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

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


919

920
repTy (HsTyVar (L _ n))
921
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
922
                       repTvar tv1
923
924
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
925
926
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
927
928
  where
    occ = nameOccName n
929

930
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
931
932
933
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
934
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar