DsMeta.hs 82.1 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
4 5 6
--
-- (c) The University of Glasgow 2006
--
7 8 9 10
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
11 12
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Gabor Greif's avatar
typos  
Gabor Greif committed
13
-- in prelude/PrelNames.  It's much more convenient to do it here, because
14 15
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
16 17
-----------------------------------------------------------------------------

18
module DsMeta( dsBracket ) where
19

20 21
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
24
import MatchLit
25 26
import DsMonad

27
import qualified Language.Haskell.TH as TH
28

29
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
30 31 32 33 34 35
import Class
import PrelNames
-- To avoid clashes with DsMeta.varName we must make a local alias for
-- OccName.varName we do this by removing varName from the import of
-- OccName above, making a qualified instance of OccName and using
-- OccNameAlias.varName where varName ws previously used in this file.
36
import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
37

Simon Marlow's avatar
Simon Marlow committed
38 39
import Module
import Id
40
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
41
import THNames
42
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
43 44 45
import TcType
import TyCon
import TysWiredIn
46
import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
47
import CoreSyn
48
import MkCore
Simon Marlow's avatar
Simon Marlow committed
49 50 51 52
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
53
import Outputable
Simon Marlow's avatar
Simon Marlow committed
54
import Bag
55
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
56 57
import FastString
import ForeignCall
58
import Util
59
import MonadUtils
60

Simon Marlow's avatar
Simon Marlow committed
61 62 63
import Data.Maybe
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
64

65
-----------------------------------------------------------------------------
66
dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr
67
-- Returns a CoreExpr of type TH.ExpQ
68 69 70
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

71 72
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
73
  where
74
    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
75

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

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


99
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
100
--                      Declarations
101 102
-------------------------------------------------------

103
repTopP :: LPat Name -> DsM (Core TH.PatQ)
104
repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
105
                 ; pat' <- addBinds ss (repLP pat)
106
                 ; wrapGenSyms ss pat' }
107

108
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
109 110 111 112 113 114 115 116 117 118 119 120 121 122
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , hs_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
123
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
124
        ss <- mkGenSyms bndrs ;
125

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
126 127 128 129 130 131
        -- 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
132

133
        decls <- addBinds ss (
134 135 136 137 138 139 140 141 142
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
                     ; tycl_ds  <- mapM repTyClD (tyClGroupConcat tyclds)
                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
                     ; inst_ds  <- mapM repInstD instds
                     ; deriv_ds <- mapM repStandaloneDerivD derivds
                     ; fix_ds   <- mapM repFixD fixds
                     ; _        <- mapM no_default_decl defds
                     ; for_ds   <- mapM repForD fords
Alan Zimmerman's avatar
Alan Zimmerman committed
143 144
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
145
                     ; ann_ds   <- mapM repAnnD annds
Alan Zimmerman's avatar
Alan Zimmerman committed
146 147
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
148 149
                     ; _        <- mapM no_vect vects
                     ; _        <- mapM no_doc docs
150

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
151
                        -- more needed
152
                     ;  return (de_loc $ sort_by_loc $
153 154
                                val_ds ++ catMaybes tycl_ds ++ role_ds
                                       ++ (concat fix_ds)
155
                                       ++ inst_ds ++ rule_ds ++ for_ds
156
                                       ++ ann_ds ++ deriv_ds) }) ;
157

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
158 159
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
160

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
161 162
        dec_ty <- lookupType decTyConName ;
        q_decs  <- repSequenceQ dec_ty core_list ;
163

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
164
        wrapGenSyms ss q_decs
165
      }
166 167 168 169 170 171 172 173 174 175 176 177
  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
178

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


{- 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.
198
To achieve this we
199 200 201 202 203 204 205 206 207 208

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

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
219 220
        data T = MkT
        foo = reifyDecl T
221 222

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

225 226
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
227 228 229 230
in repTyClD and repC.

-}

231 232
-- represent associated family instances
--
233
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
234

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

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

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

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

272 273 274 275 276 277 278 279 280
-------------------------
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) }

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

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

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

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
344
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
345
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
346 347 348
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
349
mk_extra_tvs tc tvs defn
350
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
351
  = do { extra_tvs <- go hs_kind
352
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
353 354
  | otherwise
  = return tvs
355 356 357 358 359 360
  where
    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
    go (L loc (HsFunTy kind rest))
      = do { uniq <- newUnique
           ; let { occ = mkTyVarOccFS (fsLit "t")
                 ; nm = mkInternalName uniq occ loc
Alan Zimmerman's avatar
Alan Zimmerman committed
361
                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
362 363 364 365 366 367
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

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

369
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
370 371

-------------------------
372 373
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
374
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
375
repLFunDeps fds = repList funDepTyConName repLFunDep fds
376

Alan Zimmerman's avatar
Alan Zimmerman committed
377 378 379 380 381
repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys))
   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
        repFunDep xs' ys'
382

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

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

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

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

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

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

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

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

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

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

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

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

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

550
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
551
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
552 553 554 555 556 557
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (loc, dec) }

repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
Alan Zimmerman's avatar
Alan Zimmerman committed
558
repAnnProv (ValueAnnProvenance (L _ n))
559 560
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
561
repAnnProv (TypeAnnProvenance (L _ n))
562 563 564 565 566
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

Ian Lynagh's avatar
Ian Lynagh committed
567
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
568
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
569

570
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
571
--                      Constructors
572 573
-------------------------------------------------------

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

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

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

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

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

    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

644

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

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
657
--                      Deriving clause
658 659
-------------------------------------------------------

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


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

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

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

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

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

717
    rep_ty ty = repTy ty
718

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

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

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

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

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

764 765 766 767 768 769
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
770 771

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
772
--                      Types
773
-------------------------------------------------------
774

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

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

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

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

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

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

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

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

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

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

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

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

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

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

913
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
914 915 916 917 918
repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
                            rep2 numTyLitName [iExpr]
repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
                            ; rep2 strTyLitName [s']
                            }
919

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

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