DsMeta.hs 93.3 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
183
  = concatMap get_scoped_tvs sigs
184
  where
185
186
187
188
189
190
191
192
193
194
195
    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))
       | HsIB { hsib_kvs = implicit_kvs, hsib_tvs = implicit_tvs
              , hsib_body = sig1 } <- sig
       , (explicit_tvs, _) <- splitLHsForAllTy (hswc_body sig1)
       = implicit_kvs ++ implicit_tvs ++ map hsLTyVarName explicit_tvs
    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
       ; tc_tvs <- mk_extra_tvs tc tvs defn
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
257
258
       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
                repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
259
       ; return (Just (loc, dec)) }
260

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

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

288
-------------------------
289
290
291
292
293
294
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
295
                      , dd_cons = cons, dd_derivs = mb_derivs })
296
297
298
299
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
300
301
302
303
304
                          ; case con1 of
                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
                             _cs -> failWithDs (ptext
                                     (sLit "Multiple constructors for newtype:")
                                      <+> pprQuotedList
Alan Zimmerman's avatar
Alan Zimmerman committed
305
                                              (getConNames $ unLoc $ head cons))
306
307
308
                          }
           DataType -> do { consL <- concatMapM (repC tv_names) cons
                          ; cons1 <- coreList conQTyConName consL
309
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
310

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

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

Jan Stolarek's avatar
Jan Stolarek committed
351
352
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
-- | 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 }

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

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

402
-------------------------
403
404
mk_extra_tvs :: Located Name -> LHsQTyVars Name
             -> HsDataDefn Name -> DsM (LHsQTyVars Name)
405
406
407
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
408
mk_extra_tvs tc tvs defn
409
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
410
  = do { extra_tvs <- go hs_kind
411
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
412
413
  | otherwise
  = return tvs
414
415
416
417
418
419
  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
420
                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
421
422
423
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

424
    go (L _ (HsTyVar (L _ n)))
425
426
      | n == liftedTypeKindTyConName
      = return []
427

428
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
429
430

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

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

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

455
456
457
458
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 })
459
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
460
461
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
462
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
463
464
465
466
467
468
            --
            -- But we do NOT bring the binders of 'binds' into scope
            -- because they are properly regarded as occurrences
            -- For example, the method names should be bound to
            -- the selector Ids, not to fresh names (Trac #5410)
            --
469
470
            do { cxt1 <- repLContext cxt
               ; inst_ty1 <- repLTy inst_ty
471
               ; binds1 <- rep_binds binds
472
               ; prags1 <- rep_sigs prags
473
474
475
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
476
               ; repInst cxt1 inst_ty1 decls }
477
 where
478
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
479

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

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

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
498
499
500
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
                                               , hsib_kvs = kv_names
                                               , hsib_tvs = tv_names }
501
                                 , tfe_rhs = rhs }))
502
503
504
505
506
507
508
509
510
511
  = 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
512
                                 , dfid_pats = HsIB { hsib_body = tys, hsib_kvs = kv_names, hsib_tvs = tv_names }
513
                                 , dfid_defn = defn })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
514
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
515
       ; let loc = getLoc tc_name
516
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
517
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
518
         do { tys1 <- repList typeQTyConName repLTy tys
519
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
520

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

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

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

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

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

589
590
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
591
592
ruleBndrNames (L _ (RuleBndrSig n sig))
  | HsIB { hsib_kvs = kvs, hsib_tvs = tvs } <- sig
593
  = unLoc n : kvs ++ tvs
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
594

595
596
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
597
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
598
       ; rep2 ruleVarName [n'] }
599
repRuleBndr (L _ (RuleBndrSig n sig))
600
  = do { MkC n'  <- lookupLBinder n
601
       ; MkC ty' <- repLTy (hsSigWcType sig)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
602
603
       ; rep2 typedRuleVarName [n', ty'] }

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

621
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
622
--                      Constructors
623
624
-------------------------------------------------------

625
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
Alan Zimmerman's avatar
Alan Zimmerman committed
626
627
628
629
630
631
632
633
634
635
636
637
638
repC _ (L _ (ConDeclH98 { con_name = con
                        , con_qvars = Nothing, con_cxt = Nothing
                        , con_details = details }))
  = do { con1 <- lookupLOcc con
                 -- See Note [Binders and occurrences]
       ; mapM (\c -> repConstr c details) [con1] }

repC _ (L _ (ConDeclH98 { con_name = con
                        , con_qvars = mcon_tvs, con_cxt = mcxt
                        , con_details = details }))
  = do { let (eq_ctxt, con_tv_subst) = ([], [])
       ; let con_tvs = fromMaybe (HsQTvs [] []) mcon_tvs
       ; let ctxt = unLoc $ fromMaybe (noLoc []) mcxt
639
640
641
       ; 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) }

Alan Zimmerman's avatar
Alan Zimmerman committed
642
       ; let binds = []
643
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
644
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
Alan Zimmerman's avatar
Alan Zimmerman committed
645
646
    do { con1     <- lookupLOcc con -- See Note [Binders and occurrences]
       ; c'        <- repConstr con1 details
647
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
Alan Zimmerman's avatar
Alan Zimmerman committed
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
       ; if (null (hsq_kvs ex_tvs) && null (hsq_tvs ex_tvs)
             && null (eq_ctxt ++ ctxt))
            then return c'
            else rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ [unC c']) }
    ; return [b]
    }
repC tvs (L _ (ConDeclGADT { con_names = cons
                           , con_type = res_ty@(HsIB { hsib_kvs = con_kvs
                                                     , hsib_tvs = con_tvns })}))
  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
       ; let con_tvs = map (noLoc . UserTyVar . noLoc) con_tvns
       ; let ex_tvs
               = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) con_kvs
                        , hsq_tvs = filterOut
                                          (in_subst con_tv_subst . hsLTyVarName)
                                          con_tvs }

       ; binds <- mapM dupBinder con_tv_subst
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
    do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
       ; let (details,res_ty',_,_) = gadtDeclDetails res_ty
       ; let doc = ptext (sLit "In the constructor for ") <+> ppr (head cons)
       ; (hs_details,_res_ty) <- update_con_result doc details res_ty'
       ; c'        <- mapM (\c -> repConstr c hs_details) cons1
       ; ctxt'     <- repContext eq_ctxt
674
675
676
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
    ; return [b]
    }
677

678
679
680
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
681

Alan Zimmerman's avatar
Alan Zimmerman committed
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
update_con_result :: SDoc
            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
                    -- Original details
            -> LHsType Name -- The original result type
            -> DsM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
                    LHsType Name)
update_con_result doc details ty
  = do {  let (arg_tys, res_ty) = splitHsFunType ty
                -- We can finally split it up,
                -- now the renamer has dealt with fixities
                -- See Note [Sorting out the result type] in RdrHsSyn

       ; case details of
           InfixCon {}  -> pprPanic "update_con_result" (ppr ty)
           -- See Note [Sorting out the result type] in RdrHsSyn

           RecCon {}    -> do { unless (null arg_tys)
                                       (failWithDs (badRecResTy doc))
                                -- AZ: This error used to be reported during
                                --     renaming, will now be reported in type
                                --     checking. Is this a problem?
                              ; return (details, res_ty) }

           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
    where
        badRecResTy :: SDoc -> SDoc
        badRecResTy ctxt = ctxt <+>
                        ptext (sLit "Malformed constructor signature")

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
711
mkGadtCtxt :: [Name]            -- Tyvars of the data type
Alan Zimmerman's avatar
Alan Zimmerman committed
712
           -> LHsSigType Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
713
           -> DsM (HsContext Name, [(Name,Name)])
714
715
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
716
717
718
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
719
-- Example:
720
721
-- 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)
722
723
724
--   returns
--     (b~[e], c~e), [d->a]
--
725
-- This function is fiddly, but not really hard
Alan Zimmerman's avatar
Alan Zimmerman committed
726
727
mkGadtCtxt data_tvs res_ty
  | Just (_, tys) <- hsTyGetAppHead_maybe ty
728
729
730
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

731
  | otherwise
732
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
733
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
734
735
    (_,ty',_,_) = gadtDeclDetails res_ty
    (_arg_tys,ty) = splitHsFunType ty'
736
737
738
739
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
740
       , not (in_subst subst con_tv)
741
742
743
744
745
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
746
         eq_pred = L loc (HsEqTy (L loc (HsTyVar (L loc data_tv))) ty)
747

748
749
750
    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
751

752
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
753
repBangTy ty = do
754
755
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
756
  rep2 strictTypeName [s, t]
757
  where
758
    (str, ty') = case ty of
759
760
761
762
763
         L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty)
           -> (unpackedName,  ty)
         L _ (HsBangTy (HsSrcBang _ _         SrcStrict) ty)
           -> (isStrictName,  ty)
         _ -> (notStrictName, ty)
764
765

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
766
--                      Deriving clause
767
768
-------------------------------------------------------

769
repDerivs :: HsDeriving Name -> DsM (Core [TH.Name])
770
repDerivs Nothing = coreList nameTyConName []
771
repDerivs (Just (L _ ctxt))
772
  = repList nameTyConName (rep_deriv . hsSigType) ctxt
773
  where
774
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
775
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
776
    rep_deriv ty
777
      | Just (L _ cls, []) <- splitLHsClassTy_maybe ty
batterseapower's avatar
batterseapower committed
778
779
780
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
781
782
783
784
785
786


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

787
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
788
789
790
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

796
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
797
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
798
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
799
800
801
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
802
803
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
804
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
805
806
rep_sig (L loc (SpecSig nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
807
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
808
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
809

810
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
811
           -> DsM (SrcSpan, Core TH.DecQ)
812
rep_ty_sig mk_sig loc sig_ty nm
813
  = do { nm1 <- lookupLOcc nm
814
       ; ty1 <- repHsSigType sig_ty
815
       ; sig <- repProto mk_sig nm1 ty1
816
       ; return (loc, sig) }
817
818
819

rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
              -> DsM (SrcSpan, Core TH.DecQ)
820
821
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
rep_wc_ty_sig mk_sig loc sig_ty nm
  | HsIB { hsib_tvs  = implicit_tvs, hsib_body = sig1 } <- sig_ty
  , (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) }
837

838
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
839
           -> InlinePragma      -- Never defaultInlinePragma
840
           -> SrcSpan
841
842
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
843
844
845
846
847
  = 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
848
849
850
       ; return [(loc, pragma)]
       }

851
rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
852
853
854
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
855
       ; ty1 <- repHsSigType ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
856
857
858
859
860
861
862
863
       ; 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 }
864
865
       ; return [(loc, pragma)]
       }
866

867
rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
868
rep_specialiseInst ty loc
869
  = do { ty1    <- repHsSigType ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
870
871
872
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

873
874
875
876
877
878
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
879
880
881
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
882

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
883
884
885
886
887
888
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
889
890

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
891
--                      Types
892
-------------------------------------------------------
893

894
895
896
897
898
899
900
901
902
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
903
904
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
chak's avatar
chak committed
905
906
-- 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
907
-- meta environment and gets the *new* names on Core-level as an argument
908

909
910
911
912
913
914
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
915
                    ; m kbs }
916
       ; wrapGenSyms fresh_names term }
917
918
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
chak's avatar
chak committed
919

920
addTyClTyVarBinds :: LHsQTyVars Name
921
922
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
923
924
925
926
927
928
929

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
936
937
938
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
939
940
941

       ; wrapGenSyms freshNames term }
  where
942
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
943
                       ; repTyVarBndrWithKind tv v }
944
945
946

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
947
repTyVarBndrWithKind :: LHsTyVarBndr Name
948
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
949
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
950
  = repPlainTV nm
951
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
952
  = repLKind ki >>= repKindedTV nm
953

Jan Stolarek's avatar
Jan Stolarek committed
954
955
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
956
957
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
Jan Stolarek's avatar
Jan Stolarek committed
958
959
960
961
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLKind ki
                                                  ; repKindedTV nm' ki' }

chak's avatar
chak committed
962
963
-- represent a type context
--
964
965
966
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
repHsSigType ty = repLTy (hsSigType ty)

repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType (HsIB { hsib_kvs  = implicit_kvs
                     , hsib_tvs  = implicit_tvs
                     , hsib_body = sig1 })
  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
  = addTyVarBinds (HsQTvs { hsq_kvs = implicit_kvs
                          , hsq_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs
                                      ++ explicit_tvs })
                  $ \ th_tvs ->
    do { th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy