Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
bbaf76f9
Commit
bbaf76f9
authored
Oct 29, 2015
by
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
Changes
109
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"
--
U
sed in derived instances
--
u
sed 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
(
is
Kind
)
import
Kind
(
returnsConstraint
Kind
)
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