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

Austin Seipp's avatar
Austin Seipp committed
18
19
20
21
22
23
24
25
26
module DsMeta( dsBracket,
               templateHaskellNames, qTyConName, nameTyConName,
               liftName, liftStringName, expQTyConName, patQTyConName,
               decQTyConName, decsQTyConName, typeQTyConName,
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
               quoteExpName, quotePatName, quoteDecName, quoteTypeName,
               tExpTyConName, tExpDataConName, unTypeName, unTypeQName,
               unsafeTExpCoerceName
                ) where
27

28
29
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
32
import MatchLit
33
34
import DsMonad

35
import qualified Language.Haskell.TH as TH
36

37
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
38
39
40
41
42
43
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.
Austin Seipp's avatar
Austin Seipp committed
44
import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName )
45

Simon Marlow's avatar
Simon Marlow committed
46
47
import Module
import Id
48
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
49
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
50
51
52
import TcType
import TyCon
import TysWiredIn
53
import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
54
import CoreSyn
55
import MkCore
Simon Marlow's avatar
Simon Marlow committed
56
57
58
59
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
60
import Outputable
Simon Marlow's avatar
Simon Marlow committed
61
import Bag
62
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
63
64
import FastString
import ForeignCall
65
import Util
66
import MonadUtils
67

Simon Marlow's avatar
Simon Marlow committed
68
69
70
import Data.Maybe
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
71

72
-----------------------------------------------------------------------------
73
dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr
74
-- Returns a CoreExpr of type TH.ExpQ
75
76
77
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

78
79
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
80
  where
81
    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
82

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

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


106
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
107
--                      Declarations
108
109
-------------------------------------------------------

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

115
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
116
117
118
119
120
121
122
123
124
125
126
127
128
129
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
130
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
131
        ss <- mkGenSyms bndrs ;
132

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
133
134
135
136
137
138
        -- 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
139

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

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

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

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

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

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


{- 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.
205
To achieve this we
206
207
208
209
210
211
212
213
214
215

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

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
226
227
        data T = MkT
        foo = reifyDecl T
228
229

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

232
233
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
234
235
236
237
in repTyClD and repC.

-}

238
239
-- represent associated family instances
--
240
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
241

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

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

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

-- Un-handled cases
275
repTyClD (L loc d) = putSrcSpanDs loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
276
277
                     do { warnDs (hang ds_msg 4 (ppr d))
                        ; return Nothing }
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
305
306
307
308
                          ; case con1 of
                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
                             _cs -> failWithDs (ptext
                                     (sLit "Multiple constructors for newtype:")
                                      <+> pprQuotedList
                                                (con_names $ unLoc $ head cons))
                          }
           DataType -> do { consL <- concatMapM (repC tv_names) cons
                          ; cons1 <- coreList conQTyConName consL
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)
319
320
321
322
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo  = info,
                                        fdLName   = tc,
                                        fdTyVars  = tvs,
                                        fdKindSig = opt_kind }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
323
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
324
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
325
           case (opt_kind, info) of
326
327
328
                  (_      , ClosedTypeFamily Nothing) ->
                    notHandled "abstract closed type family" (ppr decl)
                  (Nothing, ClosedTypeFamily (Just eqns)) ->
329
330
331
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; repClosedFamilyNoKind tc1 bndrs eqns2 }
332
                  (Just ki, ClosedTypeFamily (Just eqns)) ->
333
334
335
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; ki1 <- repLKind ki
336
                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
337
338
339
340
341
                  (Nothing, _) ->
                    do { info' <- repFamilyInfo info
                       ; repFamilyNoKind info' tc1 bndrs }
                  (Just ki, _) ->
                    do { info' <- repFamilyInfo info
342
                       ; ki1 <- repLKind ki
343
                       ; repFamilyKind info' tc1 bndrs ki1 }
344
345
346
347
348
       ; return (loc, dec)
       }

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
351
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
352
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
353
354
355
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
356
mk_extra_tvs tc tvs defn
357
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
358
  = do { extra_tvs <- go hs_kind
359
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
360
361
  | otherwise
  = return tvs
362
363
364
365
366
367
  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
368
                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
369
370
371
372
373
374
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

    go (L _ (HsTyVar n))
      | n == liftedTypeKindTyConName
      = return []
375

376
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
377
378

-------------------------
379
380
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
381
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
382
repLFunDeps fds = repList funDepTyConName repLFunDep fds
383

Alan Zimmerman's avatar
Alan Zimmerman committed
384
385
386
387
388
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'
389

390
391
-- represent family declaration flavours
--
392
393
394
395
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
repFamilyInfo DataFamily          = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
396

397
398
399
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
400
401
402
403
404
405
406
407
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
408
       ; return (loc, dec) }
409

410
411
412
413
414
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                         , cid_sigs = prags, cid_tyfam_insts = ats
                         , cid_datafam_insts = adts })
  = addTyVarBinds tvs $ \_ ->
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
415
416
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
417
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
418
419
420
421
422
423
            --
            -- 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)
            --
424
            do { cxt1 <- repContext cxt
425
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
426
427
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
428
               ; binds1 <- rep_binds binds
429
               ; prags1 <- rep_sigs prags
430
431
432
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
433
               ; repInst cxt1 inst_ty1 decls }
434
 where
435
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
436

437
438
439
440
441
442
443
444
445
446
447
448
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
  = do { dec <- addTyVarBinds tvs $ \_ ->
                do { cxt' <- repContext cxt
                   ; cls_tcon <- repTy (HsTyVar (unLoc cls))
                   ; cls_tys <- repLTys tys
                   ; inst_ty <- repTapps cls_tcon cls_tys
                   ; repDeriv cxt' inst_ty }
       ; return (loc, dec) }
  where
    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty

449
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
450
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
451
  = do { let tc_name = tyFamInstDeclLName decl
452
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
453
454
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
455
456

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
457
458
459
460
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
461
462
463
464
465
466
467
468
469
470
471
472
  = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
                             , hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { tys1 <- repLTys tys
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
            ; repTySynEqn tys2 rhs1 } }

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

480
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
481
repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
482
483
484
485
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
486
      cis' <- conv_cimportspec cis
487
      MkC str <- coreStringLit (static ++ chStr ++ cis')
488
489
490
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
491
492
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
493
494
    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
495
    conv_cimportspec CWrapper = return "wrapper"
496
    static = case cis of
497
                 CFunction (StaticTarget _ _ _) -> "static "
498
                 _ -> ""
499
500
501
    chStr = case mch of
            Nothing -> ""
            Just (Header h) -> unpackFS h ++ " "
502
repForD decl = notHandled "Foreign declaration" (ppr decl)
503
504

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
505
506
507
508
509
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
510
511
512

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

516
517
518
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity prec dir)))
  = do { MkC prec' <- coreIntLit prec
519
       ; let rep_fn = case dir of
520
521
522
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
523
524
525
526
527
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
528

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
529
530
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
531
532
533
534
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
535
                     ; n'   <- coreStringLit $ unpackFS $ unLoc n
536
537
538
539
540
541
542
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

543
544
545
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
546
  = unLoc n : kvs ++ tvs
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
547

548
549
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
550
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
551
       ; rep2 ruleVarName [n'] }
552
repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
553
  = do { MkC n'  <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
554
555
556
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

557
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
558
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
559
560
561
562
563
564
  = 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
565
repAnnProv (ValueAnnProvenance (L _ n))
566
567
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
568
repAnnProv (TypeAnnProvenance (L _ n))
569
570
571
572
573
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

Ian Lynagh's avatar
Ian Lynagh committed
574
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
575
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
576

577
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
578
--                      Constructors
579
580
-------------------------------------------------------

581
582
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
583
                     , con_details = details, con_res = ResTyH98 }))
584
  | null (hsQTvBndrs con_tvs)
585
586
  = do { con1 <- mapM lookupLOcc con       -- See Note [Binders and occurrences]
       ; mapM (\c -> repConstr c details) con1  }
587

588
repC tvs (L _ (ConDecl { con_names = cons
589
590
591
592
                       , con_qvars = con_tvs, con_cxt = L _ ctxt
                       , con_details = details
                       , con_res = res_ty }))
  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
593
594
595
       ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
                             , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
596
       ; binds <- mapM dupBinder con_tv_subst
597
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
598
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
599
600
    do { cons1     <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
       ; c'        <- mapM (\c -> repConstr c details) cons1
601
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
602
603
604
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
    ; return [b]
    }
605

606
607
608
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
609

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
610
mkGadtCtxt :: [Name]            -- Tyvars of the data type
611
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
612
           -> DsM (HsContext Name, [(Name,Name)])
613
614
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
615
616
617
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
618
-- Example:
619
620
-- 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)
621
622
623
--   returns
--     (b~[e], c~e), [d->a]
--
624
625
626
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
Alan Zimmerman's avatar
Alan Zimmerman committed
627
mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
628
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
629
630
631
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

632
  | otherwise
633
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
634
635
636
637
638
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
639
       , not (in_subst subst con_tv)
640
641
642
643
644
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
645
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
646
647
648
649
650

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

651

652
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
653
repBangTy ty= do
654
655
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
656
  rep2 strictTypeName [s, t]
657
  where
658
    (str, ty') = case ty of
Alan Zimmerman's avatar
Alan Zimmerman committed
659
660
661
         L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName,  ty)
         L _ (HsBangTy (HsSrcBang _ _     True) ty)       -> (isStrictName,  ty)
         _                                                -> (notStrictName, ty)
662
663

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
664
--                      Deriving clause
665
666
-------------------------------------------------------

667
repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
668
repDerivs Nothing = coreList nameTyConName []
669
repDerivs (Just (L _ ctxt))
670
  = repList nameTyConName rep_deriv ctxt
671
  where
672
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
673
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
674
675
676
677
678
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
679
680
681
682
683
684


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

685
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
686
687
688
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

694
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
thomasw's avatar
thomasw committed
695
rep_sig (L loc (TypeSig nms ty _))    = mapM (rep_ty_sig sigDName loc ty) nms
696
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
697
rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty) nms
698
699
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
700
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
701
702
rep_sig (L loc (SpecSig nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
703
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
704
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
705

706
rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
707
           -> DsM (SrcSpan, Core TH.DecQ)
708
rep_ty_sig mk_sig loc (L _ ty) nm
709
710
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
711
       ; sig <- repProto mk_sig nm1 ty1
712
       ; return (loc, sig) }
713
  where
714
715
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
thomasw's avatar
thomasw committed
716
    rep_ty (HsForAllTy Explicit _ tvs ctxt ty)
717
718
      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                         ; repTyVarBndrWithKind tv name }
719
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
720
721
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
722
           ; repTForall bndrs1 ctxt1 ty1 }
723

724
    rep_ty ty = repTy ty
725

726
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
727
           -> InlinePragma      -- Never defaultInlinePragma
728
           -> SrcSpan
729
730
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
731
732
733
734
735
  = 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
736
737
738
       ; return [(loc, pragma)]
       }

739
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
740
741
742
743
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
744
745
746
747
748
749
750
751
       ; 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 }
752
753
       ; return [(loc, pragma)]
       }
754

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
755
756
757
758
759
760
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

761
762
763
764
765
766
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
767
768
769
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
770

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
771
772
773
774
775
776
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
777
778

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
779
--                      Types
780
-------------------------------------------------------
781

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
782
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
783
784
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
chak's avatar
chak committed
785
786
-- 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
787
-- meta environment and gets the *new* names on Core-level as an argument
788

789
790
791
792
793
794
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
795
                    ; m kbs }
796
       ; wrapGenSyms fresh_names term }
797
798
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
chak's avatar
chak committed
799

800
addTyClTyVarBinds :: LHsTyVarBndrs Name
801
802
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
803
804
805
806
807
808
809

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
816
817
818
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
819
820
821

       ; wrapGenSyms freshNames term }
  where
822
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
823
                       ; repTyVarBndrWithKind tv v }
824
825
826

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
827
repTyVarBndrWithKind :: LHsTyVarBndr Name
828
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
829
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
830
  = repPlainTV nm
831
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
832
  = repLKind ki >>= repKindedTV nm
833

chak's avatar
chak committed
834
835
-- represent a type context
--
836
837
838
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

chak's avatar
chak committed
843
844
-- yield the representation of a list of types
--
845
846
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
847

chak's avatar
chak committed
848
849
-- represent a type
--
850
851
852
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

853
repTy :: HsType Name -> DsM (Core TH.TypeQ)
thomasw's avatar
thomasw committed
854
repTy (HsForAllTy _ _ tvs ctxt ty)  =
855
  addTyVarBinds tvs $ \bndrs -> do
856
857
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
858
    repTForall bndrs ctxt1 ty1
859

860
repTy (HsTyVar n)
861
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
862
                       repTvar tv1
863
864
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
865
866
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
867
868
  where
    occ = nameOccName n
869

870
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
871
872
873
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
874
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
875
876
877
878
879
880
881
882
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
883
repTy (HsPArrTy t)          = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
884
885
886
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
batterseapower's avatar
batterseapower committed
887
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
888
889
890
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
891
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
892
893
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
894
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
895
896
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
897
898
899
900
901
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
902
903
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
904
                                k1 <- repLKind k
905
                                repTSig t1 k1
906
repTy (HsSpliceTy splice _)     = repSplice splice