DsMeta.hs 117 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
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)) | PendSplice 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 150 151 152 153 154
                  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
                     ; _        <- mapM no_warn warnds
                     ; ann_ds   <- mapM repAnnD annds
                     ; rule_ds  <- mapM repRuleD ruleds
                     ; _        <- mapM no_vect vects
                     ; _        <- mapM no_doc docs
155

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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
169
        wrapGenSyms ss q_decs
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_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
thomasw's avatar
thomasw committed
187
  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs
188
                     , 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
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
298 299 300 301 302 303 304 305 306
                          ; 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
307
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
308

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

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
317
repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
318
                                   fdLName   = tc,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
319 320 321
                                   fdTyVars  = tvs,
                                   fdKindSig = opt_kind }))
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
322
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
323
           case (opt_kind, info) of
324 325 326 327 328 329 330 331
                  (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
332
                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
333 334 335 336 337
                  (Nothing, _) ->
                    do { info' <- repFamilyInfo info
                       ; repFamilyNoKind info' tc1 bndrs }
                  (Just ki, _) ->
                    do { info' <- repFamilyInfo info
338
                       ; ki1 <- repLKind ki
339
                       ; repFamilyKind info' tc1 bndrs ki1 }
340 341 342 343 344
       ; return (loc, dec)
       }

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

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

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

372
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
373 374

-------------------------
375 376 377
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
378
repLFunDeps fds = repList funDepTyConName repLFunDep fds
379 380

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
381 382 383
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
                               ys' <- repList nameTyConName lookupBinder ys
                               repFunDep xs' ys'
384

385 386
-- represent family declaration flavours
--
387 388 389 390
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
repFamilyInfo DataFamily          = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
391

392 393 394
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
395 396 397 398 399 400 401 402
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
403
       ; return (loc, dec) }
404

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

432 433 434 435 436 437 438 439 440 441 442 443
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

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

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
452 453 454 455
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
456 457 458 459 460 461 462 463 464 465 466 467
  = 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
468
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
469
       ; let loc = getLoc tc_name
470
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
471
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
472
         do { tys1 <- repList typeQTyConName repLTy tys
473
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
474

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

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
500 501 502 503 504
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
505 506 507

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

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

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

538 539 540
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
541
  = unLoc n : kvs ++ tvs
542

543 544
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
545
  = do { MkC n' <- lookupLBinder n
546
       ; rep2 ruleVarName [n'] }
547
repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
548
  = do { MkC n'  <- lookupLBinder n
549 550 551
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568
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
569
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
570
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
571

572
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
573
--                      Constructors
574 575
-------------------------------------------------------

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

583
repC tvs (L _ (ConDecl { con_names = cons
584 585 586 587
                       , 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
588 589 590
       ; 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
591
       ; binds <- mapM dupBinder con_tv_subst
592
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
593
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
594 595
    do { cons1     <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
       ; c'        <- mapM (\c -> repConstr c details) cons1
596
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
597 598 599
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
    ; return [b]
    }
600

601 602 603
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
604

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

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

    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

646

647
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
648
repBangTy ty= do
649 650
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
651
  rep2 strictTypeName [s, t]
652
  where
653
    (str, ty') = case ty of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
654 655 656
                   L _ (HsBangTy (HsSrcBang (Just True) True) ty) -> (unpackedName,  ty)
                   L _ (HsBangTy (HsSrcBang _     True) ty)       -> (isStrictName,  ty)
                   _                                              -> (notStrictName, ty)
657 658

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
659
--                      Deriving clause
660 661
-------------------------------------------------------

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


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

680
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
681 682 683
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

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

701
rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
702
           -> DsM (SrcSpan, Core TH.DecQ)
703
rep_ty_sig mk_sig loc (L _ ty) nm
704 705
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
706
       ; sig <- repProto mk_sig nm1 ty1
707
       ; return (loc, sig) }
708
  where
709 710
    -- 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
711
    rep_ty (HsForAllTy Explicit _ tvs ctxt ty)
712 713
      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                         ; repTyVarBndrWithKind tv name }
714
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
715 716
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
717
           ; repTForall bndrs1 ctxt1 ty1 }
718

719
    rep_ty ty = repTy ty
720

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

734
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
735 736 737 738
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
739 740 741 742 743 744 745 746
       ; 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 }
747 748
       ; return [(loc, pragma)]
       }
749

750 751 752 753 754 755
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

756 757 758 759 760 761
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

762 763 764
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
765

766 767 768 769 770 771
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
772 773

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
774
--                      Types
775
-------------------------------------------------------
776

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

784 785 786 787 788 789
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
790
                    ; m kbs }
791
       ; wrapGenSyms fresh_names term }
792 793
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
794

795
addTyClTyVarBinds :: LHsTyVarBndrs Name
796 797
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
798 799 800 801 802 803 804

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
811 812 813
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
814 815 816

       ; wrapGenSyms freshNames term }
  where
817
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
818
                       ; repTyVarBndrWithKind tv v }
819 820 821

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

829 830
-- represent a type context
--
831 832 833
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

838 839
-- yield the representation of a list of types
--
840 841
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
842

843 844
-- represent a type
--
845 846 847
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

848
repTy :: HsType Name -> DsM (Core TH.TypeQ)
thomasw's avatar
thomasw committed
849
repTy (HsForAllTy _ _ tvs ctxt ty)  =
850
  addTyVarBinds tvs $ \bndrs -> do
851 852
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
853
    repTForall bndrs ctxt1 ty1
854

855
repTy (HsTyVar n)
856
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
857
                       repTvar tv1
858 859
  | isDataOcc occ = do tc1 <- lookupOcc n
                       repPromotedTyCon tc1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
860 861
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
862 863
  where
    occ = nameOccName n
864

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

915
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
916 917
repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
                          rep2 numTyLitName [iExpr]
918 919 920 921
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
                         ; rep2 strTyLitName [s']
                         }

922 923
-- represent a kind
--
924 925
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
926
  = do { let (kis, ki') = splitHsFunType ki
927 928 929 930 931
       ; 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
932
       }
933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955

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)
956

957 958 959 960 961
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 []
962