DsMeta.hs 91.5 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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
43
import NameSet
Simon Marlow's avatar
Simon Marlow committed
44
45
46
import TcType
import TyCon
import TysWiredIn
47
import CoreSyn
48
import MkCore
Simon Marlow's avatar
Simon Marlow committed
49
50
51
52
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
53
import Outputable
Simon Marlow's avatar
Simon Marlow committed
54
import Bag
55
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
56
57
import FastString
import ForeignCall
58
import Util
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
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 })
 = do { let { tv_bndrs = hsSigTvBinders valds
123
124
            ; bndrs = tv_bndrs ++ hsGroupBinders group
            ; instds = tyclds >>= group_instds } ;
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
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
137
                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
138
139
140
141
142
143
                     ; 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
183
  = concatMap get_scoped_tvs sigs
184
  where
185
186
187
188
189
    get_scoped_tvs :: LSig Name -> [Name]
    -- Both implicit and explicit quantified variables
    -- We need the implicit ones for   f :: forall (a::k). blah
    --    here 'k' scopes too
    get_scoped_tvs (L _ (TypeSig _ sig))
190
       | HsIB { hsib_vars = implicit_vars
191
              , hsib_body = sig1 } <- sig
192
193
       , (explicit_vars, _) <- splitLHsForAllTy (hswc_body sig1)
       = implicit_vars ++ map hsLTyVarName explicit_vars
194
195
    get_scoped_tvs _ = []

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


{- Notes

Note [Scoped type variables in bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f :: forall a. a -> a
   f x = x::a
Here the 'forall a' brings 'a' into scope over the binding group.
209
To achieve this we
210
211
212
213
214
215
216
217
218
219

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

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

The relevant places are signposted with references to this Note

Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
220
221
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
222
        Data "T" [] [Con "MkT" []] []
223
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
224
        Data "Foo:T" [] [Con "Foo:MkT" []] []
225
226
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
227
        Data "T79" ....
228
229

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

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

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

-}

242
243
-- represent associated family instances
--
244
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
245

246
247
248
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
249
250
251
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
252
       ; return (Just (loc, dec)) }
253

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

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

278
279
280
281
282
283
284
285
286
-------------------------
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) }

287
-------------------------
288
289
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
290
            -> HsDataDefn Name
291
            -> DsM (Core TH.DecQ)
292
293
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
294
                      , dd_cons = cons, dd_derivs = mb_derivs })
295
296
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
297
298
299
300
301
302
303
304
305
306
307
308
309
310
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
                                   ; ksig' <- repMaybeLKind ksig
                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
                                                derivs1 }
           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                       <+> pprQuotedList
                                       (getConNames $ unLoc $ head cons))
           (DataType, _) -> do { ksig' <- repMaybeLKind ksig
                               ; consL <- mapM repC cons
                               ; cons1 <- coreList conQTyConName consL
                               ; repData cxt1 tc bndrs opt_tys ksig' cons1
                                         derivs1 }
       }
311

312
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
313
314
           -> LHsType Name
           -> DsM (Core TH.DecQ)
315
repSynDecl tc bndrs ty
316
  = do { ty1 <- repLTy ty
317
318
319
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Jan Stolarek's avatar
Jan Stolarek committed
320
321
322
323
324
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
325
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
326
       ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
327
328
             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs
                                   , hsq_dependent = emptyNameSet }
Jan Stolarek's avatar
Jan Stolarek committed
329
330
331
             resTyVar = case resultSig of
                     TyVarSig bndr -> mkHsQTvs [bndr]
                     _             -> mkHsQTvs []
332
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
                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 }
350
351
352
       ; return (loc, dec)
       }

Jan Stolarek's avatar
Jan Stolarek committed
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
-- | 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 }

385
386
repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
387

388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
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 }

404
-------------------------
405
406
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
407
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
408
repLFunDeps fds = repList funDepTyConName repLFunDep fds
409

Alan Zimmerman's avatar
Alan Zimmerman committed
410
411
412
413
414
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'
415

416
417
418
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
419
420
421
422
423
424
425
426
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
427
       ; return (loc, dec) }
428

429
430
431
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                         , cid_sigs = prags, cid_tyfam_insts = ats
432
433
434
                         , cid_datafam_insts = adts
                         , cid_overlap_mode = overlap
                         })
435
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
436
437
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
438
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
439
440
441
442
443
444
            --
            -- 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)
            --
445
446
            do { cxt1 <- repLContext cxt
               ; inst_ty1 <- repLTy inst_ty
447
               ; binds1 <- rep_binds binds
448
               ; prags1 <- rep_sigs prags
449
450
451
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
452
453
               ; rOver <- repOverlap (fmap unLoc overlap)
               ; repInst rOver cxt1 inst_ty1 decls }
454
 where
455
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
456

457
458
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
459
460
461
462
  = do { dec <- addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
                   ; inst_ty' <- repLTy inst_ty
                   ; repDeriv cxt' inst_ty' }
463
464
       ; return (loc, dec) }
  where
465
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
466

467
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
468
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
469
  = do { let tc_name = tyFamInstDeclLName decl
470
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
471
472
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
473
474

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
475
476
477
478
repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
                                             , hsib_vars = var_names }
                           , tfe_rhs = rhs }))
  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
479
480
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
481
482
483
484
485
486
487
488
       ; 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
489
                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }
490
                                 , dfid_defn = defn })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
491
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
492
       ; let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
493
494
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
495
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
496
         do { tys1 <- repList typeQTyConName repLTy tys
497
            ; repDataDefn tc bndrs (Just tys1) defn } }
498

499
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
500
501
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
502
 = do MkC name' <- lookupLOcc name
503
      MkC typ' <- repHsSigType typ
504
505
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
506
      cis' <- conv_cimportspec cis
507
      MkC str <- coreStringLit (static ++ chStr ++ cis')
508
509
510
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
511
512
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
513
514
515
516
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
517
    conv_cimportspec CWrapper = return "wrapper"
518
519
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
520
    static = case cis of
521
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
522
                 _ -> ""
523
    chStr = case mch of
524
525
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
526
repForD decl = notHandled "Foreign declaration" (ppr decl)
527
528

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
529
530
531
532
533
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
534
535
536

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

540
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
541
repFixD (L loc (FixitySig names (Fixity _ prec dir)))
542
  = do { MkC prec' <- coreIntLit prec
543
       ; let rep_fn = case dir of
544
545
546
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
547
548
549
550
551
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
552

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
553
554
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
555
556
557
558
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
559
                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
560
561
562
563
564
565
566
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

567
568
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
569
ruleBndrNames (L _ (RuleBndrSig n sig))
570
571
  | HsIB { hsib_vars = vars } <- sig
  = unLoc n : vars
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
572

573
574
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
575
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
576
       ; rep2 ruleVarName [n'] }
577
repRuleBndr (L _ (RuleBndrSig n sig))
578
  = do { MkC n'  <- lookupLBinder n
579
       ; MkC ty' <- repLTy (hsSigWcType sig)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
580
581
       ; rep2 typedRuleVarName [n', ty'] }

582
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
583
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
584
585
586
587
588
589
  = 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
590
repAnnProv (ValueAnnProvenance (L _ n))
591
592
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
593
repAnnProv (TypeAnnProvenance (L _ n))
594
595
596
597
598
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

599
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
600
--                      Constructors
601
602
-------------------------------------------------------

603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L _ (ConDeclH98 { con_name = con
                      , con_qvars = Nothing, con_cxt = Nothing
                      , con_details = details }))
  = repDataCon con details

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

623
624
625
626
627
628
629
630
631
632
633
634
635
636
repC (L _ (ConDeclGADT { con_names = cons
                       , con_type = res_ty@(HsIB { hsib_vars = con_vars })}))
  | (details, res_ty', L _ [] , []) <- gadtDetails
  , [] <- con_vars
    -- 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 }

  | (details,res_ty',ctxt, tvs) <- gadtDetails
  = do { let doc = text "In the constructor for " <+> ppr (head cons)
             con_tvs = HsQTvs { hsq_implicit = []
                              , hsq_explicit = (map (noLoc . UserTyVar . noLoc)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
637
638
                                                   con_vars) ++ tvs
                              , hsq_dependent = emptyNameSet }
639
640
641
642
643
644
       ; 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)
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
645
  where
646
     gadtDetails = gadtDeclDetails res_ty
647

648
649
650
651
652
653
654
655
656
657
658
repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []

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

repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ))
659
repBangTy ty = do
660
661
662
  MkC u <- repSrcUnpackedness su'
  MkC s <- repSrcStrictness ss'
  MkC b <- rep2 bangName [u, s]
663
  MkC t <- repLTy ty'
664
  rep2 bangTypeName [b, t]
665
  where
666
667
668
    (su', ss', ty') = case ty of
            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
            _ -> (NoSrcUnpack, NoSrcStrict, ty)
669
670

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
671
--                      Deriving clause
672
673
-------------------------------------------------------

674
675
repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ)
repDerivs deriv = do
Simon Peyton Jones's avatar
Simon Peyton Jones committed
676
677
678
    let clauses = case deriv of
                    Nothing         -> []
                    Just (L _ ctxt) -> ctxt
679
680
681
682
683
    tys <- repList typeQTyConName
                   (rep_deriv . hsSigType)
                   clauses
           :: DsM (Core [TH.PredQ])
    repCtxt tys
684
  where
685
686
    rep_deriv :: LHsType Name -> DsM (Core TH.TypeQ)
    rep_deriv (L _ ty) = repTy ty
687
688
689
690
691

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

692
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
693
694
695
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

701
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
702
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
703
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
704
705
706
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
707
708
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
709
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
710
711
rep_sig (L loc (SpecSig nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
712
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
713
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
714

715
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
716
           -> DsM (SrcSpan, Core TH.DecQ)
717
rep_ty_sig mk_sig loc sig_ty nm
718
  = do { nm1 <- lookupLOcc nm
719
       ; ty1 <- repHsSigType sig_ty
720
       ; sig <- repProto mk_sig nm1 ty1
721
       ; return (loc, sig) }
722
723
724

rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
              -> DsM (SrcSpan, Core TH.DecQ)
725
726
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
727
rep_wc_ty_sig mk_sig loc sig_ty nm
728
  | HsIB { hsib_vars = implicit_tvs, hsib_body = sig1 } <- sig_ty
729
730
731
732
733
734
735
736
737
738
739
740
741
  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
  = do { nm1 <- lookupLOcc nm
       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                     ; repTyVarBndrWithKind tv name }
             all_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs ++ explicit_tvs
       ; th_tvs  <- repList tyVarBndrTyConName rep_in_scope_tv all_tvs
       ; th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
       ; ty1 <- if null all_tvs && null (unLoc ctxt)
                then return th_ty
                else repTForall th_tvs th_ctxt th_ty
       ; sig <- repProto mk_sig nm1 ty1
       ; return (loc, sig) }
742

743
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
744
           -> InlinePragma      -- Never defaultInlinePragma
745
           -> SrcSpan
746
747
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
748
749
750
751
752
  = 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
753
754
755
       ; return [(loc, pragma)]
       }

756
rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
757
758
759
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
760
       ; ty1 <- repHsSigType ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
761
762
763
764
765
766
767
768
       ; 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 }
769
770
       ; return [(loc, pragma)]
       }
771

772
rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
773
rep_specialiseInst ty loc
774
  = do { ty1    <- repHsSigType ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
775
776
777
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

778
779
780
781
782
783
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
784
785
786
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
787

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
788
repPhases :: Activation -> DsM (Core TH.Phases)
789
790
791
792
793
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
794
795

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
796
--                      Types
797
-------------------------------------------------------
798

799
800
801
802
803
804
805
806
807
addSimpleTyVarBinds :: [Name]                -- the binders to be added
                    -> DsM (Core (TH.Q a))   -- action in the ext env
                    -> DsM (Core (TH.Q a))
addSimpleTyVarBinds names thing_inside
  = do { fresh_names <- mkGenSyms names
       ; term <- addBinds fresh_names thing_inside
       ; wrapGenSyms fresh_names term }

addTyVarBinds :: LHsQTyVars Name                            -- the binders to be added
808
809
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
chak's avatar
chak committed
810
811
-- 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
812
-- meta environment and gets the *new* names on Core-level as an argument
813

814
815
816
817
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
818
       ; term <- addBinds fresh_names $
819
820
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
                                     (exp_tvs `zip` fresh_exp_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
821
                    ; m kbs }
822
       ; wrapGenSyms fresh_names term }
823
824
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
chak's avatar
chak committed
825

826
addTyClTyVarBinds :: LHsQTyVars Name
827
828
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
829
830
831
832
833
834
835

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
842
       ; term <- addBinds freshNames $
843
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
844
                    ; m kbs }
845
846
847

       ; wrapGenSyms freshNames term }
  where
848
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
849
                       ; repTyVarBndrWithKind tv v }
850
851
852

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
853
repTyVarBndrWithKind :: LHsTyVarBndr Name
854
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
855
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
856
  = repPlainTV nm
857
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
858
  = repLKind ki >>= repKindedTV nm
859

Jan Stolarek's avatar
Jan Stolarek committed
860
861
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
862
863
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
Jan Stolarek's avatar
Jan Stolarek committed
864
865
866
867
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLKind ki
                                                  ; repKindedTV nm' ki' }

chak's avatar
chak committed
868
869
-- represent a type context
--
870
871
872
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

877
repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
878
879
880
repHsSigType (HsIB { hsib_vars = vars
                   , hsib_body = body })
  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
881
882
  = addTyVarBinds (HsQTvs { hsq_implicit = []
                          , hsq_explicit = map (noLoc . UserTyVar . noLoc) vars ++
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
883
884
                                           explicit_tvs
                          , hsq_dependent = emptyNameSet })
885
886
887
                  $ \ th_tvs ->
    do { th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
888
       ; if null vars && null explicit_tvs && null (unLoc ctxt)
889
890
891
         then return th_ty
         else repTForall th_tvs th_ctxt th_ty }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
892
893
894
895
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 })
  = repHsSigType (ib_ty { hsib_body = hswc_body sig1 })

chak's avatar
chak committed
896
897
-- yield the representation of a list of types
--
898
899
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
900

chak's avatar
chak committed
901
902
-- represent a type
--
903
904
905
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

906
907
908
909
repForall :: HsType Name -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
910
911
 = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs
                         , hsq_dependent = emptyNameSet }) $ \bndrs ->
912
913
914
   do { ctxt1  <- repLContext ctxt
      ; ty1    <- repLTy tau
      ; repTForall bndrs ctxt1 ty1 }
thomasw's avatar
thomasw committed
915

916
917
918
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {})   = repForall ty
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
  | isDataOcc occ = do tc1 <- lookupOcc n
924
925
                       repPromotedDataCon tc1
  | n == eqTyConName = repTequality
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
926
927
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
928
929
  where
    occ = nameOccName n
930

931
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
932
933
934
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
935
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
936
937
938
939
940
941
942
943
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
944
945
946
947
repTy (HsPArrTy t)     = do
                           t1   <- repLTy t
                           tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon)))
                           repTapp tcon t1
batterseapower's avatar
batterseapower committed
948
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
949
950
951
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
952
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
953
954
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
955
repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
956
957
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
958
959
960
961
962
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
963