DsMeta.hs 115 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,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
19
20
               templateHaskellNames, qTyConName, nameTyConName,
               liftName, liftStringName, expQTyConName, patQTyConName,
21
               decQTyConName, decsQTyConName, typeQTyConName,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
22
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
23
               quoteExpName, quotePatName, quoteDecName, quoteTypeName,
24
25
               tExpTyConName, tExpDataConName, unTypeName, unTypeQName,
               unsafeTExpCoerceName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
26
                ) 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.
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

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

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

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

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

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


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

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

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

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

139
140
141
142
143
144
145
146
147
148
149
        decls <- addBinds ss (
                  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
                     ; _       <- mapM no_standalone_deriv derivds
                     ; fix_ds  <- mapM repFixD fixds
                     ; _       <- mapM no_default_decl defds
                     ; for_ds  <- mapM repForD fords
                     ; _       <- mapM no_warn warnds
150
                     ; ann_ds  <- mapM repAnnD annds
151
152
153
154
                     ; rule_ds <- mapM repRuleD ruleds
                     ; _       <- mapM no_vect vects
                     ; _       <- mapM no_doc docs

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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
167
        wrapGenSyms ss q_decs
168
      }
169
170
171
172
173
174
175
176
177
178
179
180
181
182
  where
    no_splice (L loc _)
      = notHandledL loc "Splices within declaration brackets" empty
    no_standalone_deriv (L loc (DerivDecl { deriv_type = deriv_ty }))
      = notHandledL loc "Standalone-deriving" (ppr deriv_ty)
    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
183

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


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

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

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

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

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

-}

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

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

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

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

-- Un-handled cases
273
repTyClD (L loc d) = putSrcSpanDs loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
274
275
                     do { warnDs (hang ds_msg 4 (ppr d))
                        ; return Nothing }
276

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

286
-------------------------
287
288
289
290
291
292
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
293
                      , dd_cons = cons, dd_derivs = mb_derivs })
294
295
296
297
298
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
                          ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
299
300
           DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
301

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

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
310
repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
311
                                   fdLName   = tc,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
312
313
314
                                   fdTyVars  = tvs,
                                   fdKindSig = opt_kind }))
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
315
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
316
           case (opt_kind, info) of
317
318
319
320
321
322
323
324
                  (Nothing, ClosedTypeFamily eqns) ->
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; repClosedFamilyNoKind tc1 bndrs eqns2 }
                  (Just ki, ClosedTypeFamily eqns) ->
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; ki1 <- repLKind ki
325
                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
326
327
328
329
330
                  (Nothing, _) ->
                    do { info' <- repFamilyInfo info
                       ; repFamilyNoKind info' tc1 bndrs }
                  (Just ki, _) ->
                    do { info' <- repFamilyInfo info
331
                       ; ki1 <- repLKind ki
332
                       ; repFamilyKind info' tc1 bndrs ki1 }
333
334
335
336
337
       ; return (loc, dec)
       }

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
340
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
341
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
342
343
344
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
345
mk_extra_tvs tc tvs defn
346
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
347
  = do { extra_tvs <- go hs_kind
348
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
349
350
  | otherwise
  = return tvs
351
352
353
354
355
356
  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
357
                 ; hs_tv = L loc (KindedTyVar nm kind) }
358
359
360
361
362
363
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

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

365
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
366
367

-------------------------
368
369
370
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
371
repLFunDeps fds = repList funDepTyConName repLFunDep fds
372
373

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
374
375
376
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
                               ys' <- repList nameTyConName lookupBinder ys
                               repFunDep xs' ys'
377

378
379
-- represent family declaration flavours
--
380
381
382
383
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
repFamilyInfo DataFamily          = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
384

385
386
387
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
388
389
390
391
392
393
394
395
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
396
       ; return (loc, dec) }
397

398
399
400
401
402
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
403
404
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
405
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
406
407
408
409
410
411
            --
            -- 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)
            --
412
            do { cxt1 <- repContext cxt
413
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
414
415
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
416
               ; binds1 <- rep_binds binds
417
               ; prags1 <- rep_sigs prags
418
419
420
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
421
               ; repInst cxt1 inst_ty1 decls }
422
 where
423
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
424

425
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
426
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
427
  = do { let tc_name = tyFamInstDeclLName decl
428
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
429
430
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
431
432

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
433
434
435
436
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
437
438
439
440
441
442
443
444
445
446
447
448
  = 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
449
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
450
       ; let loc = getLoc tc_name
451
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
452
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
453
         do { tys1 <- repList typeQTyConName repLTy tys
454
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
455

456
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
457
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
458
459
460
461
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
462
      cis' <- conv_cimportspec cis
463
      MkC str <- coreStringLit (static ++ chStr ++ cis')
464
465
466
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
467
468
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
469
470
    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
471
    conv_cimportspec CWrapper = return "wrapper"
472
    static = case cis of
473
                 CFunction (StaticTarget _ _ _) -> "static "
474
                 _ -> ""
475
476
477
    chStr = case mch of
            Nothing -> ""
            Just (Header h) -> unpackFS h ++ " "
478
repForD decl = notHandled "Foreign declaration" (ppr decl)
479
480
481
482

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []
483
repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
484
485
486

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

490
491
492
493
repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
repFixD (L loc (FixitySig name (Fixity prec dir)))
  = do { MkC name' <- lookupLOcc name
       ; MkC prec' <- coreIntLit prec
494
       ; let rep_fn = case dir of
495
496
497
498
499
500
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; dec <- rep2 rep_fn [prec', name']
       ; return (loc, dec) }

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
501
502
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
503
504
505
506
507
508
509
510
511
512
513
514
515
516
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
                     ; n'   <- coreStringLit $ unpackFS n
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

ruleBndrNames :: RuleBndr Name -> [Name]
ruleBndrNames (RuleBndr n)      = [unLoc n]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
517
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
518
  = unLoc n : kvs ++ tvs
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
519
520
521

repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
522
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
523
524
       ; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
525
  = do { MkC n'  <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
526
527
528
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repAnnD (L loc (HsAnnotation ann_prov (L _ exp)))
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (loc, dec) }

repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
repAnnProv (ValueAnnProvenance n)
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
repAnnProv (TypeAnnProvenance n)
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

Ian Lynagh's avatar
Ian Lynagh committed
546
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
547
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
548

549
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
550
--                      Constructors
551
552
-------------------------------------------------------

553
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
554
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
555
                     , con_details = details, con_res = ResTyH98 }))
556
  | null (hsQTvBndrs con_tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
557
  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]
558
       ; repConstr con1 details  }
559

560
561
562
563
564
repC tvs (L _ (ConDecl { con_name = con
                       , 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
565
566
567
       ; 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
568
       ; binds <- mapM dupBinder con_tv_subst
569
570
       ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
571
    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]
572
573
       ; c'        <- repConstr con1 details
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
574
       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
575

576
577
578
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
579

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
580
mkGadtCtxt :: [Name]            -- Tyvars of the data type
581
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
582
           -> DsM (HsContext Name, [(Name,Name)])
583
584
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
585
586
587
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
588
-- Example:
589
590
-- 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)
591
592
593
--   returns
--     (b~[e], c~e), [d->a]
--
594
595
596
597
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
mkGadtCtxt data_tvs (ResTyGADT res_ty)
598
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
599
600
601
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

602
  | otherwise
603
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
604
605
606
607
608
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
609
       , not (in_subst subst con_tv)
610
611
612
613
614
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
615
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
616
617
618
619
620

    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

621

622
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
623
repBangTy ty= do
624
625
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
626
  rep2 strictTypeName [s, t]
627
  where
628
    (str, ty') = case ty of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
629
630
631
                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
                   _                               -> (notStrictName, ty)
632
633

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
634
--                      Deriving clause
635
636
-------------------------------------------------------

637
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
638
repDerivs Nothing = coreList nameTyConName []
639
repDerivs (Just ctxt)
640
  = repList nameTyConName rep_deriv ctxt
641
  where
642
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
643
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
644
645
646
647
648
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
649
650
651
652
653
654


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

655
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
656
657
658
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

664
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
665
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
666
667
668
669
670
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
rep_sig (L _   (GenericSig nm _))     = notHandled "Default type signatures" msg
  where msg = text "Illegal default signature for" <+> quotes (ppr nm)
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
671
672
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
673
rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
674
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
675

676
677
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
           -> DsM (SrcSpan, Core TH.DecQ)
678
rep_ty_sig loc (L _ ty) nm
679
680
681
682
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
       ; sig <- repProto nm1 ty1
       ; return (loc, sig) }
683
  where
684
685
686
687
688
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
    rep_ty (HsForAllTy Explicit tvs ctxt ty)
      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                         ; repTyVarBndrWithKind tv name }
689
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
690
691
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
692
           ; repTForall bndrs1 ctxt1 ty1 }
693

694
    rep_ty ty = repTy ty
695

696

697
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
698
           -> InlinePragma      -- Never defaultInlinePragma
699
           -> SrcSpan
700
701
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
702
703
704
705
706
  = 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
707
708
709
       ; return [(loc, pragma)]
       }

710
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
711
712
713
714
               -> 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
715
716
717
718
719
720
721
722
       ; 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 }
723
724
       ; return [(loc, pragma)]
       }
725

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
726
727
728
729
730
731
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

732
733
734
735
736
737
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
738
739
740
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
741

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
742
743
744
745
746
747
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
748
749

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
750
--                      Types
751
-------------------------------------------------------
752

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
753
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
754
755
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
chak's avatar
chak committed
756
757
-- 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
758
-- meta environment and gets the *new* names on Core-level as an argument
759

760
761
762
763
764
765
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
766
                    ; m kbs }
767
       ; wrapGenSyms fresh_names term }
768
769
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
chak's avatar
chak committed
770

771
addTyClTyVarBinds :: LHsTyVarBndrs Name
772
773
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
774
775
776
777
778
779
780

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
787
788
789
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
790
791
792

       ; wrapGenSyms freshNames term }
  where
793
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
794
                       ; repTyVarBndrWithKind tv v }
795
796
797

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
798
repTyVarBndrWithKind :: LHsTyVarBndr Name
799
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
800
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
801
  = repPlainTV nm
802
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
803
  = repLKind ki >>= repKindedTV nm
804

chak's avatar
chak committed
805
806
-- represent a type context
--
807
808
809
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

chak's avatar
chak committed
814
815
-- yield the representation of a list of types
--
816
817
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
818

chak's avatar
chak committed
819
820
-- represent a type
--
821
822
823
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

824
repTy :: HsType Name -> DsM (Core TH.TypeQ)
825
repTy (HsForAllTy _ tvs ctxt ty)  =
826
  addTyVarBinds tvs $ \bndrs -> do
827
828
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
829
    repTForall bndrs ctxt1 ty1
830

831
repTy (HsTyVar n)
832
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
833
                       repTvar tv1
834
835
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
836
837
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
838
839
  where
    occ = nameOccName n
840

841
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
842
843
844
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
845
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
846
847
848
849
850
851
852
853
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
854
repTy (HsPArrTy t)          = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
855
856
857
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
batterseapower's avatar
batterseapower committed
858
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
859
860
861
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
862
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
863
864
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
dreixel's avatar
dreixel committed
865
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
866
867
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
868
869
870
871
872
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
873
874
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
875
                                k1 <- repLKind k
876
                                repTSig t1 k1
877
repTy (HsSpliceTy splice _)     = repSplice splice
878
879
880
881
882
883
884
885
886
887
repTy (HsExplicitListTy _ tys)  = do
                                    tys1 <- repLTys tys
                                    repTPromotedList tys1
repTy (HsExplicitTupleTy _ tys) = do
                                    tys1 <- repLTys tys
                                    tcon <- repPromotedTupleTyCon (length tys)
                                    repTapps tcon tys1
repTy (HsTyLit lit) = do
                        lit' <- repTyLit lit
                        repTLit lit'
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
888
                          
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
889
repTy ty                      = notHandled "Exotic form of type" (ppr ty)
890

891
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
892
893
repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
                          rep2 numTyLitName [iExpr]
894
895
896
897
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

898
899
-- represent a kind
--
900
901
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
902
  = do { let (kis, ki') = splitHsFunType ki
903
904
905
906
907
       ; kis_rep <- mapM repLKind kis
       ; ki'_rep <- repNonArrowLKind ki'
       ; kcon <- repKArrow
       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
       ; foldrM f ki'_rep kis_rep
908
       }
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931

repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
repNonArrowLKind (L _ ki) = repNonArrowKind ki

repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
repNonArrowKind (HsTyVar name)
  | name == liftedTypeKindTyConName = repKStar
  | name == constraintKindTyConName = repKConstraint
  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar
  | otherwise                       = lookupOcc name >>= repKCon
repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f
                                          ; a' <- repLKind a
                                          ; repKApp f' a'
                                          }
repNonArrowKind (HsListTy k)        = do  { k' <- repLKind k
                                          ; kcon <- repKList
                                          ; repKApp kcon k'
                                          }
repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks
                                          ; kcon <- repKTuple (length ks)
                                          ; repKApps kcon ks'
                                          }
repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)
932

933
934
935
936
937
repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
repRole (L _ (Just Nominal))          = rep2 nominalRName []
repRole (L _ (Just Representational)) = rep2 representationalRName []
repRole (L _ (Just Phantom))          = rep2 phantomRName []
repRole (L _ Nothing)                 = rep2 inferRName []
938

939
-----------------------------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
940
--              Splices