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
3212d689
Commit
3212d689
authored
Nov 13, 2002
by
chak
Browse files
[project @ 2002-11-13 09:57:02 by chak]
Added forall's to the representation of type terms
parent
12a5d425
Changes
1
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/deSugar/DsMeta.hs
View file @
3212d689
...
...
@@ -42,7 +42,8 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
toHsType
)
import
PrelNames
(
mETA_META_Name
,
rationalTyConName
,
negateName
)
import
PrelNames
(
mETA_META_Name
,
rationalTyConName
,
negateName
,
parrTyConName
)
import
MkIface
(
ifaceTyThing
)
import
Name
(
Name
,
nameOccName
,
nameModule
)
import
OccName
(
isDataOcc
,
isTvOcc
,
occNameUserString
)
...
...
@@ -64,7 +65,7 @@ import TysWiredIn ( stringTy )
import
CoreSyn
import
CoreUtils
(
exprType
)
import
SrcLoc
(
noSrcLoc
)
import
Maybe
(
catMaybes
)
import
Maybe
(
catMaybes
,
fromMaybe
)
import
Panic
(
panic
)
import
Unique
(
mkPreludeTyConUnique
,
mkPreludeMiscIdUnique
)
import
BasicTypes
(
NewOrData
(
..
),
StrictnessMark
(
..
),
isBoxed
)
...
...
@@ -210,7 +211,7 @@ repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
})
=
do
{
cls1
<-
lookupOcc
cls
;
-- See note [Binders and occurrences]
tvs1
<-
repTvs
tvs
;
cxt1
<-
repC
t
xt
cxt
;
cxt1
<-
repC
onte
xt
cxt
;
sigs1
<-
rep_sigs
sigs
;
binds1
<-
rep_monobind
binds
;
decls1
<-
coreList
declTyConName
(
sigs1
++
binds1
)
;
...
...
@@ -226,7 +227,7 @@ repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
repInstD
(
InstDecl
ty
binds
_
_
loc
)
-- Ignore user pragmas for now
=
do
{
cxt1
<-
repC
t
xt
cxt
;
=
do
{
cxt1
<-
repC
onte
xt
cxt
;
inst_ty1
<-
repPred
(
HsClassP
cls
tys
)
;
binds1
<-
rep_monobind
binds
;
decls1
<-
coreList
declTyConName
binds1
;
...
...
@@ -294,45 +295,87 @@ rep_proto nm ty = do { nm1 <- lookupBinder nm ;
-- Types
-------------------------------------------------------
-- represent a list of type variables in a usage position that does not need
-- gensym'ing
--
repTvs
::
[
HsTyVarBndr
Name
]
->
DsM
(
Core
[
String
])
repTvs
tvs
=
do
{
tvs1
<-
mapM
(
localVar
.
hsTyVarName
)
tvs
;
return
(
coreList'
stringTy
tvs1
)
}
-----------------
repCtxt
::
HsContext
Name
->
DsM
(
Core
M
.
Ctxt
)
repCtxt
ctxt
=
do
{
preds
<-
mapM
repPred
ctxt
;
coreList
typeTyConName
preds
}
-- represent a type context
--
repContext
::
HsContext
Name
->
DsM
(
Core
M
.
Ctxt
)
repContext
ctxt
=
do
preds
<-
mapM
repPred
ctxt
predList
<-
coreList
typeTyConName
preds
repCtxt
predList
-----------------
-- represent a type predicate
--
repPred
::
HsPred
Name
->
DsM
(
Core
M
.
Type
)
repPred
(
HsClassP
cls
tys
)
=
do
{
tc1
<-
lookupOcc
cls
;
tcon
<-
repNamedTyCon
tc1
;
tys1
<-
repTys
tys
;
repTapps
tcon
tys1
}
repPred
(
HsIParam
_
_
)
=
panic
"No implicit parameters yet"
-----------------
repPred
(
HsClassP
cls
tys
)
=
do
tcon
<-
repTy
(
HsTyVar
cls
)
tys1
<-
repTys
tys
repTapps
tcon
tys1
repPred
(
HsIParam
_
_
)
=
panic
"DsMeta.repTy: Can't represent predicates with implicit parameters"
-- yield the representation of a list of types
--
repTys
::
[
HsType
Name
]
->
DsM
[
Core
M
.
Type
]
repTys
tys
=
mapM
repTy
tys
-----------------
-- represent a type
--
repTy
::
HsType
Name
->
DsM
(
Core
M
.
Type
)
repTy
(
HsForAllTy
bndrs
ctxt
ty
)
=
do
let
names
=
map
hsTyVarName
(
fromMaybe
[]
bndrs
)
freshNames
<-
mkGenSyms
names
forallTy
<-
addBinds
freshNames
$
do
bndrs'
<-
mapM
lookupBinder
names
ctxt'
<-
repContext
ctxt
ty'
<-
repTy
ty
repTForall
(
coreList'
stringTy
bndrs'
)
ctxt'
ty'
wrapGenSyns
typTyConName
freshNames
forallTy
repTy
(
HsTyVar
n
)
|
isTvOcc
(
nameOccName
n
)
=
do
{
tv1
<-
localVar
n
;
repTvar
tv1
}
|
otherwise
=
do
{
tc1
<-
lookupOcc
n
;
repNamedTyCon
tc1
}
repTy
(
HsAppTy
f
a
)
=
do
{
f1
<-
repTy
f
;
a1
<-
repTy
a
;
repTapp
f1
a1
}
repTy
(
HsFunTy
f
a
)
=
do
{
f1
<-
repTy
f
;
a1
<-
repTy
a
;
tcon
<-
repArrowTyCon
;
repTapps
tcon
[
f1
,
a1
]
}
repTy
(
HsListTy
t
)
=
do
{
t1
<-
repTy
t
;
tcon
<-
repListTyCon
;
repTapp
tcon
t1
}
repTy
(
HsTupleTy
tc
tys
)
=
do
{
tys1
<-
repTys
tys
;
tcon
<-
repTupleTyCon
(
length
tys
);
repTapps
tcon
tys1
}
|
isTvOcc
(
nameOccName
n
)
=
do
tv1
<-
lookupBinder
n
repTvar
tv1
|
otherwise
=
do
tc1
<-
lookupOcc
n
repNamedTyCon
tc1
repTy
(
HsAppTy
f
a
)
=
do
f1
<-
repTy
f
a1
<-
repTy
a
repTapp
f1
a1
repTy
(
HsFunTy
f
a
)
=
do
f1
<-
repTy
f
a1
<-
repTy
a
tcon
<-
repArrowTyCon
repTapps
tcon
[
f1
,
a1
]
repTy
(
HsListTy
t
)
=
do
t1
<-
repTy
t
tcon
<-
repListTyCon
repTapp
tcon
t1
repTy
(
HsPArrTy
t
)
=
do
t1
<-
repTy
t
tcon
<-
repTy
(
HsTyVar
parrTyConName
)
repTapp
tcon
t1
repTy
(
HsTupleTy
tc
tys
)
=
do
tys1
<-
repTys
tys
tcon
<-
repTupleTyCon
(
length
tys
)
repTapps
tcon
tys1
repTy
(
HsOpTy
ty1
HsArrow
ty2
)
=
repTy
(
HsFunTy
ty1
ty2
)
repTy
(
HsOpTy
ty1
(
HsTyOp
n
)
ty2
)
=
repTy
((
HsTyVar
n
`
HsAppTy
`
ty1
)
`
HsAppTy
`
ty2
)
repTy
(
HsOpTy
ty1
(
HsTyOp
n
)
ty2
)
=
repTy
((
HsTyVar
n
`
HsAppTy
`
ty1
)
`
HsAppTy
`
ty2
)
repTy
(
HsParTy
t
)
=
repTy
t
repTy
(
HsPredTy
(
HsClassP
c
tys
))
=
repTy
(
foldl
HsAppTy
(
HsTyVar
c
)
tys
)
repTy
(
HsNumTy
i
)
=
panic
"DsMeta.repTy: Can't represent number types (for generics)"
repTy
(
HsPredTy
pred
)
=
repPred
pred
repTy
(
HsKindSig
ty
kind
)
=
panic
"DsMeta.repTy: Can't represent explicit kind signatures yet"
repTy
other_ty
=
pprPanic
"repTy"
(
ppr
other_ty
)
-- HsForAllTy, HsKindSig
-----------------------------------------------------------------------------
-- Expressions
...
...
@@ -672,19 +715,31 @@ repListPat (p:ps) = do { p2 <- repP p
----------------------------------------------------------
-- The meta-environment
-- A name/identifier association for fresh names of locally bound entities
--
type
GenSymBind
=
(
Name
,
Id
)
-- Gensym the string and bind it to the Id
-- I.e. (x, x_id) means
-- let x_id = gensym "x" in ...
addBinds
::
[
GenSymBind
]
->
DsM
a
->
DsM
a
addBinds
bs
m
=
dsExtendMetaEnv
(
mkNameEnv
[(
n
,
Bound
id
)
|
(
n
,
id
)
<-
bs
])
m
-- Generate a fresh name for a locally bound entity
--
mkGenSym
::
Name
->
DsM
GenSymBind
mkGenSym
nm
=
do
{
id
<-
newUniqueId
nm
stringTy
;
return
(
nm
,
id
)
}
-- Ditto for a list of names
--
mkGenSyms
::
[
Name
]
->
DsM
[
GenSymBind
]
mkGenSyms
ns
=
mapM
mkGenSym
ns
-- Add a list of fresh names for locally bound entities to the meta
-- environment (which is part of the state carried around by the desugarer
-- monad)
--
addBinds
::
[
GenSymBind
]
->
DsM
a
->
DsM
a
addBinds
bs
m
=
dsExtendMetaEnv
(
mkNameEnv
[(
n
,
Bound
id
)
|
(
n
,
id
)
<-
bs
])
m
-- Look up a locally bound name
--
lookupBinder
::
Name
->
DsM
(
Core
String
)
lookupBinder
n
=
do
{
mb_val
<-
dsLookupMetaEnv
n
;
...
...
@@ -692,6 +747,11 @@ lookupBinder n
Just
(
Bound
x
)
->
return
(
coreVar
x
)
other
->
pprPanic
"Failed binder lookup:"
(
ppr
n
)
}
-- Look up a name that is either locally bound or a global name
--
-- * If it is a global name, generate the "original name" representation (ie,
-- the <module>:<name> form) for the associated entity
--
lookupOcc
::
Name
->
DsM
(
Core
String
)
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
...
...
@@ -913,11 +973,17 @@ repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs
repProto
::
Core
String
->
Core
M
.
Type
->
DsM
(
Core
M
.
Decl
)
repProto
(
MkC
s
)
(
MkC
ty
)
=
rep2
protoName
[
s
,
ty
]
repCtxt
::
Core
[
M
.
Type
]
->
DsM
(
Core
M
.
Ctxt
)
repCtxt
(
MkC
tys
)
=
rep2
ctxtName
[
tys
]
repConstr
::
Core
String
->
Core
[
M
.
Type
]
->
DsM
(
Core
M
.
Cons
)
repConstr
(
MkC
con
)
(
MkC
tys
)
=
rep2
constrName
[
con
,
tys
]
repConstr
(
MkC
con
)
(
MkC
tys
)
=
rep2
constrName
[
con
,
tys
]
------------ Types -------------------
repTForall
::
Core
[
String
]
->
Core
M
.
Ctxt
->
Core
M
.
Type
->
DsM
(
Core
M
.
Type
)
repTForall
(
MkC
tvars
)
(
MkC
ctxt
)
(
MkC
ty
)
=
rep2
tforallName
[
tvars
,
ctxt
,
ty
]
repTvar
::
Core
String
->
DsM
(
Core
M
.
Type
)
repTvar
(
MkC
s
)
=
rep2
tvarName
[
s
]
...
...
@@ -1043,9 +1109,9 @@ templateHaskellNames
funName
,
valName
,
liftName
,
gensymName
,
returnQName
,
bindQName
,
sequenceQName
,
matchName
,
clauseName
,
funName
,
valName
,
dataDName
,
classDName
,
instName
,
protoName
,
tvarName
,
tconName
,
tappName
,
instName
,
protoName
,
tforallName
,
tvarName
,
tconName
,
tappName
,
arrowTyConName
,
tupleTyConName
,
listTyConName
,
namedTyConName
,
constrName
,
ctxtName
,
constrName
,
exprTyConName
,
declTyConName
,
pattTyConName
,
mtchTyConName
,
clseTyConName
,
stmtTyConName
,
consTyConName
,
typeTyConName
,
qTyConName
,
expTyConName
,
matTyConName
,
clsTyConName
,
...
...
@@ -1121,15 +1187,19 @@ instName = varQual FSLIT("inst") instIdKey
protoName
=
varQual
FSLIT
(
"proto"
)
protoIdKey
-- data Typ = ...
tforallName
=
varQual
FSLIT
(
"tforall"
)
tforallIdKey
tvarName
=
varQual
FSLIT
(
"tvar"
)
tvarIdKey
tconName
=
varQual
FSLIT
(
"tcon"
)
tconIdKey
tappName
=
varQual
FSLIT
(
"tapp"
)
tappIdKey
-- data Tag = ...
arrowTyConName
=
varQual
FSLIT
(
"arrowTyCon"
)
arrowIdKey
tupleTyConName
=
varQual
FSLIT
(
"tupleTyCon"
)
tupleIdKey
listTyConName
=
varQual
FSLIT
(
"listTyCon"
)
listIdKey
namedTyConName
=
varQual
FSLIT
(
"namedTyCon"
)
namedTyConIdKey
arrowTyConName
=
varQual
FSLIT
(
"arrowTyCon"
)
arrowIdKey
tupleTyConName
=
varQual
FSLIT
(
"tupleTyCon"
)
tupleIdKey
listTyConName
=
varQual
FSLIT
(
"listTyCon"
)
listIdKey
namedTyConName
=
varQual
FSLIT
(
"namedTyCon"
)
namedTyConIdKey
-- type Ctxt = ...
ctxtName
=
varQual
FSLIT
(
"ctxt"
)
ctxtIdKey
-- data Con = ...
constrName
=
varQual
FSLIT
(
"constr"
)
constrIdKey
...
...
@@ -1225,21 +1295,24 @@ letStIdKey = mkPreludeMiscIdUnique 248
noBindStIdKey
=
mkPreludeMiscIdUnique
249
parStIdKey
=
mkPreludeMiscIdUnique
250
tvarIdKey
=
mkPreludeMiscIdUnique
251
tconIdKey
=
mkPreludeMiscIdUnique
252
tappIdKey
=
mkPreludeMiscIdUnique
253
tforallIdKey
=
mkPreludeMiscIdUnique
251
tvarIdKey
=
mkPreludeMiscIdUnique
252
tconIdKey
=
mkPreludeMiscIdUnique
253
tappIdKey
=
mkPreludeMiscIdUnique
254
arrowIdKey
=
mkPreludeMiscIdUnique
255
tupleIdKey
=
mkPreludeMiscIdUnique
256
listIdKey
=
mkPreludeMiscIdUnique
257
namedTyConIdKey
=
mkPreludeMiscIdUnique
258
arrowIdKey
=
mkPreludeMiscIdUnique
254
tupleIdKey
=
mkPreludeMiscIdUnique
255
listIdKey
=
mkPreludeMiscIdUnique
256
namedTyConIdKey
=
mkPreludeMiscIdUnique
257
ctxtIdKey
=
mkPreludeMiscIdUnique
259
constrIdKey
=
mkPreludeMiscIdUnique
2
58
constrIdKey
=
mkPreludeMiscIdUnique
2
60
stringLIdKey
=
mkPreludeMiscIdUnique
2
59
rationalLIdKey
=
mkPreludeMiscIdUnique
26
0
stringLIdKey
=
mkPreludeMiscIdUnique
2
61
rationalLIdKey
=
mkPreludeMiscIdUnique
26
2
sigExpIdKey
=
mkPreludeMiscIdUnique
26
1
sigExpIdKey
=
mkPreludeMiscIdUnique
26
3
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment