Skip to content
GitLab
Commit bbaf76f9 authored by Ben Gamari's avatar Ben Gamari 🐢
Browse files

Revert "Generate Typeable info at definition sites" 

This reverts commit bef2f03e.

This merge was botched

Also reverts haddock submodule.
parent bef2f03e
Hide whitespace changes
Inline Side-by-side
compiler/basicTypes/DataCon.hs
View file @ bbaf76f9
......@@ -35,8 +35,7 @@ module DataCon (
dataConSrcBangs,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe,
dataConImplicitTyThings,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness, dataConImplBangs, dataConBoxer,
splitDataProductType_maybe,
......@@ -47,18 +46,16 @@ module DataCon (
isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
-- ** Promotion related functions
promoteDataCon, promoteDataCon_maybe,
promoteType, promoteKind,
isPromotableType, computeTyConPromotability,
promoteKind, promoteDataCon, promoteDataCon_maybe
) where
#include "HsVersions.h"
import {-# SOURCE #-} MkId( DataConBoxer )
import Type
import ForeignCall( CType )
import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
import ForeignCall( CType )
import Coercion
import Kind
import Unify
......@@ -75,11 +72,11 @@ import BasicTypes
import FastString
import Module
import VarEnv
import NameSet
import Binary
import qualified Data.Data as Data
import qualified Data.Typeable
import Data.Maybe
import Data.Char
import Data.Word
import Data.List( mapAccumL, find )
......@@ -402,8 +399,8 @@ data DataCon
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
dcPromoted :: Promoted TyCon -- The promoted TyCon if this DataCon is promotable
-- See Note [Promoted data constructors] in TyCon
dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable
-- See Note [Promoted data constructors] in TyCon
}
deriving Data.Typeable.Typeable
......@@ -674,9 +671,7 @@ isMarkedStrict _ = True -- All others are strict
-- | Build a new data constructor
mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
-> Promoted TyConRepName -- ^ Whether promoted, and if so the TyConRepName
-- for the promoted TyCon
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
......@@ -693,7 +688,7 @@ mkDataCon :: Name
-> DataCon
-- Can get the tag from the TyCon
mkDataCon name declared_infix prom_info
mkDataCon name declared_infix
arg_stricts -- Must match orig_arg_tys 1-1
fields
univ_tvs ex_tvs
......@@ -738,12 +733,15 @@ mkDataCon name declared_infix prom_info
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted -- See Note [Promoted data constructors] in TyCon
= case prom_info of
NotPromoted -> NotPromoted
Promoted rep_nm -> Promoted (mkPromotedDataCon con name rep_nm prom_kind prom_roles)
prom_kind = promoteType (dataConUserType con)
prom_roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
| isJust (promotableTyCon_maybe rep_tycon)
-- The TyCon is promotable only if all its datacons
-- are, so the promoteType for prom_kind should succeed
= Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
| otherwise
= Nothing
prom_kind = promoteType (dataConUserType con)
roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
......@@ -826,13 +824,11 @@ dataConWrapId dc = case dcRep dc of
-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
-- the union of the 'dataConWorkId' and the 'dataConWrapId'
dataConImplicitTyThings :: DataCon -> [TyThing]
dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })
= [AnId work] ++ wrap_ids
where
wrap_ids = case rep of
NoDataConRep -> []
DCR { dcr_wrap_id = wrap } -> [AnId wrap]
dataConImplicitIds :: DataCon -> [Id]
dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
= case rep of
NoDataConRep -> [work]
DCR { dcr_wrap_id = wrap } -> [wrap,work]
-- | The labels for the fields of this particular 'DataCon'
dataConFieldLabels :: DataCon -> [FieldLabel]
......@@ -1077,112 +1073,60 @@ dataConCannotMatch tys con
{-
************************************************************************
* *
Promotion
These functions are here becuase
- isPromotableTyCon calls dataConFullSig
- mkDataCon calls promoteType
- It's nice to keep the promotion stuff together
Building an algebraic data type
* *
************************************************************************
Note [The overall promotion story]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here is the overall plan.
* Compared to a TyCon T, the promoted 'T has
same Name (and hence Unique)
same TyConRepName
In future the two will collapse into one anyhow.
* Compared to a DataCon K, the promoted 'K (a type constructor) has
same Name (and hence Unique)
But it has a fresh TyConRepName; after all, the DataCon doesn't have
a TyConRepName at all. (See Note [Grand plan for Typeable] in TcTypeable
for TyConRepName.)
Why does 'K have the same unique as K? It's acceptable because we don't
mix types and terms, so we won't get them confused. And it's helpful mainly
so that we know when to print 'K as a qualified name in error message. The
PrintUnqualified stuff depends on whether K is lexically in scope.. but 'K
never is!
* It follows that the tick-mark (eg 'K) is not part of the Occ name of
either promoted data constructors or type constructors. Instead,
pretty-printing: the pretty-printer prints a tick in front of
- promoted DataCons (always)
- promoted TyCons (with -dppr-debug)
See TyCon.pprPromotionQuote
* For a promoted data constructor K, the pipeline goes like this:
User writes (in a type): K or 'K
Parser produces OccName: K{tc} or K{d}, respectively
Renamer makes Name: M.K{d}_r62 (i.e. same unique as DataCon K)
and K{tc} has been turned into K{d}
provided it was unambiguous
Typechecker makes TyCon: PromotedDataCon MK{d}_r62
Note [Checking whether a group is promotable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only want to promote a TyCon if all its data constructors
are promotable; it'd be very odd to promote some but not others.
buildAlgTyCon is here because it is called from TysWiredIn, which in turn
depends on DataCon, but not on BuildTyCl.
-}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> [Role]
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> this TyCon is promotable
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> TyCon
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec is_promotable gadt_syn parent
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
-- tc and mb_promoted_tc are mutually recursive
tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
mb_promoted_tc
But the data constructors may mention this or other TyCons.
mb_promoted_tc
| is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
| otherwise = Nothing
So we treat the recursive uses as all OK (ie promotable) and
do one pass to check that each TyCon is promotable.
{-
************************************************************************
* *
Promoting of data types to the kind level
* *
************************************************************************
Currently type synonyms are not promotable, though that
could change.
These two 'promoted..' functions are here because
* They belong together
* 'promoteDataCon' depends on DataCon stuff
-}
promoteDataCon :: DataCon -> TyCon
promoteDataCon (MkData { dcPromoted = Promoted tc }) = tc
promoteDataCon (MkData { dcPromoted = Just tc }) = tc
promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
promoteDataCon_maybe :: DataCon -> Promoted TyCon
promoteDataCon_maybe :: DataCon -> Maybe TyCon
promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
computeTyConPromotability :: NameSet -> TyCon -> Bool
computeTyConPromotability rec_tycons tc
= isAlgTyCon tc -- Only algebraic; not even synonyms
-- (we could reconsider the latter)
&& ok_kind (tyConKind tc)
&& case algTyConRhs tc of
DataTyCon { data_cons = cs } -> all ok_con cs
TupleTyCon { data_con = c } -> ok_con c
NewTyCon { data_con = c } -> ok_con c
AbstractTyCon {} -> False
where
ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
where -- Checks for * -> ... -> * -> *
(args, res) = splitKindFunTys kind
-- See Note [Promoted data constructors] in TyCon
ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
&& null eq_spec -- No constraints
&& null theta
&& all (isPromotableType rec_tycons) orig_arg_tys
where
(_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
isPromotableType :: NameSet -> Type -> Bool
-- Must line up with promoteType
-- But the function lives here because we must treat the
-- *recursive* tycons as promotable
isPromotableType rec_tcs con_arg_ty
= go con_arg_ty
where
go (TyConApp tc tys) = tys `lengthIs` tyConArity tc
&& (tyConName tc `elemNameSet` rec_tcs
|| isPromotableTyCon tc)
&& all go tys
go (FunTy arg res) = go arg && go res
go (TyVarTy {}) = True
go _ = False
{-
Note [Promoting a Type to a Kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1212,7 +1156,7 @@ promoteType ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
go (TyConApp tc tys) | Promoted prom_tc <- promotableTyCon_maybe tc
go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc
= mkTyConApp prom_tc (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
......@@ -1264,41 +1208,3 @@ splitDataProductType_maybe ty
= Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
| otherwise
= Nothing
{-
************************************************************************
* *
Building an algebraic data type
* *
************************************************************************
buildAlgTyCon is here because it is called from TysWiredIn, which can
depend on this module, but not on BuildTyCl.
-}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> [Role]
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> this TyCon is promotable
-> Bool -- ^ True <=> was declared in GADT syntax
-> AlgTyConFlav
-> TyCon
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec is_promotable gadt_syn parent
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
-- tc and mb_promoted_tc are mutually recursive
tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
mb_promoted_tc
mb_promoted_tc
| is_promotable = Promoted (mkPromotedTyCon tc (promoteKind kind))
| otherwise = NotPromoted
compiler/basicTypes/OccName.hs
View file @ bbaf76f9
......@@ -72,7 +72,6 @@ module OccName (
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc,
-- ** Deconstruction
occNameFS, occNameString, occNameSpace,
......@@ -587,8 +586,7 @@ mkDataConWrapperOcc, mkWorkerOcc,
mkGenR, mkGen1R, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
......@@ -611,24 +609,11 @@ mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes
mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions
mkEqPredCoOcc = mk_simple_deriv tcName "$co"
-- Used in derived instances
-- used in derived instances
mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable
-- incluing the wrinkle about mkSpecialTyConRepName
mkTyConRepSysOcc occ = mk_simple_deriv varName prefix occ
where
prefix | isDataOcc occ = "$tc'"
| otherwise = "$tc"
mkTyConRepUserOcc occ = mk_simple_deriv varName prefix occ
where
-- *User-writable* prefix, for types in gHC_TYPES
prefix | isDataOcc occ = "tc'"
| otherwise = "tc"
-- Generic deriving mechanism
-- | Generate a module-unique name, to be used e.g. while generating new names
......
compiler/basicTypes/Unique.hs
View file @ bbaf76f9
......@@ -48,13 +48,10 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkCostCentreUnique,
tyConRepNameUnique,
dataConWorkerUnique, dataConRepNameUnique,
mkBuiltinUnique,
mkPseudoUniqueD,
mkPseudoUniqueE,
......@@ -102,10 +99,9 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int -- for Var
incrUnique :: Unique -> Unique
stepUnique :: Unique -> Int -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
......@@ -113,11 +109,9 @@ mkUniqueGrimily = MkUnique
getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i + 1)
stepUnique (MkUnique i) n = MkUnique (i + n)
-- deriveUnique uses an 'X' tag so that it won't clash with
-- any of the uniques produced any other way
-- SPJ says: this looks terribly smelly to me!
deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
-- newTagUnique changes the "domain" of a unique to a different char
......@@ -311,19 +305,14 @@ mkPArrDataConUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- Prelude type constructors occupy *three* slots.
-- The first is for the tycon itself; the latter two
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
......@@ -331,22 +320,10 @@ tyConRepNameUnique u = incrUnique u
-- used for the worker function (the function that builds the constructor
-- representation).
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a)
dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
dataConWorkerUnique u = incrUnique u
dataConRepNameUnique u = stepUnique u 2
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
--------------------------------------------------
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
......
compiler/coreSyn/MkCore.hs
View file @ bbaf76f9
......@@ -126,12 +126,12 @@ mkCoreLets binds body = foldr mkCoreLet body binds
-- | Construct an expression which represents the application of one expression
-- to the other
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
-- Respects the let/app invariant by building a case expression where necessary
-- See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp _ fun (Type ty) = App fun (Type ty)
mkCoreApp _ fun (Coercion co) = App fun (Coercion co)
mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
mkCoreApp fun (Type ty) = App fun (Type ty)
mkCoreApp fun (Coercion co) = App fun (Coercion co)
mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
mk_val_app fun arg arg_ty res_ty
where
fun_ty = exprType fun
......
compiler/deSugar/DsBinds.hs
View file @ bbaf76f9
......@@ -44,11 +44,10 @@ import TyCon
import TcEvidence
import TcType
import Type
import Kind( isKind )
import Kind (returnsConstraintKind)
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
, mkBoxedTupleTy, charTy
, typeNatKind, typeSymbolKind )
, mkBoxedTupleTy, charTy, typeNatKind, typeSymbolKind )
import Id
import MkId(proxyHashId)
import Class
......@@ -71,12 +70,15 @@ import FastString
import Util
import MonadUtils
import Control.Monad(liftM,when)
import Fingerprint(Fingerprint(..), fingerprintString)
{-**********************************************************************
{-
************************************************************************
* *
Desugaring a MonoBinds
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
* *
**********************************************************************-}
************************************************************************
-}
dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds binds = ds_lhs_binds binds
......@@ -813,7 +815,7 @@ dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
; dsHsWrapper c1 e1 }
dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
; e1 <- dsHsWrapper c1 (Var x)
; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
; return (Lam x e2) }
dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
dsTcCoercion co (mkCastDs e)
......@@ -851,145 +853,154 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
= (b, var, varSetElems (evVarsOfTerm term))
{-**********************************************************************
* *
Desugaring EvTerms
* *
**********************************************************************-}
---------------------------------------
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCallStack cs) = dsEvCallStack cs
dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
dsEvTerm (EvLit (EvNum n)) = mkIntegerExpr n
dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCastDs tm' }
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvDFunApp df tys tms)
= return (Var df `mkTyApps` tys `mkApps` (map Var tms))
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
dsEvTerm (EvDelayedError ty msg)
= return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
{-**********************************************************************
* *
Desugaring Typeable dictionaries
* *
**********************************************************************-}
dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
-- Return a CoreExpr :: Typeable ty
-- This code is tightly coupled to the representation
-- of TypeRep, in base library Data.Typeable.Internals
dsEvTypeable ty ev
= do { tyCl <- dsLookupTyCon typeableClassName -- Typeable
; let kind = typeKind ty
Just typeable_data_con
= tyConSingleDataCon_maybe tyCl -- "Data constructor"
-- for Typeable
; rep_expr <- ds_ev_typeable ty ev
-- Build Core for (let r::TypeRep = rep in \proxy. rep)
-- See Note [Memoising typeOf]
; repName <- newSysLocalDs (exprType rep_expr)
; let proxyT = mkProxyPrimTy kind ty
method = bindNonRec repName rep_expr
$ mkLams [mkWildValBinder proxyT] (Var repName)
-- Package up the method as `Typeable` dictionary
; return $ mkConApp typeable_data_con [Type kind, Type ty, method] }
ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
-- Returns a CoreExpr :: TypeRep ty
ds_ev_typeable ty EvTypeableTyCon
| Just (tc, ks) <- splitTyConApp_maybe ty
= ASSERT( all isKind ks )
do { ctr <- dsLookupGlobalId mkPolyTyConAppName
-- mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
; tyRepTc <- dsLookupTyCon typeRepTyConName -- TypeRep (the TyCon)
; let tyRepType = mkTyConApp tyRepTc [] -- TypeRep (the Type)
mkRep cRep kReps tReps
= mkApps (Var ctr) [ cRep
, mkListExpr tyRepType kReps
, mkListExpr tyRepType tReps ]
kindRep k -- Returns CoreExpr :: TypeRep for that kind k
= case splitTyConApp_maybe k of
Nothing -> panic "dsEvTypeable: not a kind constructor"
Just (kc,ks) -> do { kcRep <- tyConRep kc
; reps <- mapM kindRep ks
; return (mkRep kcRep [] reps) }
; tcRep <- tyConRep tc
; kReps <- mapM kindRep ks