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
a011a71c
Commit
a011a71c
authored
May 21, 2003
by
igloo
Browse files
[project @ 2003-05-21 02:58:39 by igloo]
Added support for newtypes to TH and altered a test for them.
parent
a77e522a
Changes
2
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/deSugar/DsMeta.hs
View file @
a011a71c
...
...
@@ -219,6 +219,18 @@ repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
repData
cxt1
tc1
(
coreList'
stringTy
bndrs
)
cons2
derivs1
}
;
return
$
Just
(
loc
,
dec
)
}
repTyClD'
(
TyData
{
tcdND
=
NewType
,
tcdCtxt
=
cxt
,
tcdName
=
tc
,
tcdTyVars
=
tvs
,
tcdCons
=
DataCons
[
con
],
tcdDerivs
=
mb_derivs
,
tcdLoc
=
loc
})
=
do
{
tc1
<-
lookupOcc
tc
;
-- See note [Binders and occurrences]
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
cxt1
<-
repContext
cxt
;
con1
<-
repC
con
;
derivs1
<-
repDerivs
mb_derivs
;
repNewtype
cxt1
tc1
(
coreList'
stringTy
bndrs
)
con1
derivs1
}
;
return
$
Just
(
loc
,
dec
)
}
repTyClD'
(
TySynonym
{
tcdName
=
tc
,
tcdTyVars
=
tvs
,
tcdSynRhs
=
ty
,
tcdLoc
=
loc
})
=
do
{
tc1
<-
lookupOcc
tc
;
-- See note [Binders and occurrences]
...
...
@@ -1049,6 +1061,9 @@ repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
repData
::
Core
M
.
CxtQ
->
Core
String
->
Core
[
String
]
->
Core
[
M
.
ConQ
]
->
Core
[
String
]
->
DsM
(
Core
M
.
DecQ
)
repData
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
tvs
)
(
MkC
cons
)
(
MkC
derivs
)
=
rep2
dataDName
[
cxt
,
nm
,
tvs
,
cons
,
derivs
]
repNewtype
::
Core
M
.
CxtQ
->
Core
String
->
Core
[
String
]
->
Core
M
.
ConQ
->
Core
[
String
]
->
DsM
(
Core
M
.
DecQ
)
repNewtype
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
tvs
)
(
MkC
con
)
(
MkC
derivs
)
=
rep2
newtypeDName
[
cxt
,
nm
,
tvs
,
con
,
derivs
]
repTySyn
::
Core
String
->
Core
[
String
]
->
Core
M
.
TypQ
->
DsM
(
Core
M
.
DecQ
)
repTySyn
(
MkC
nm
)
(
MkC
tvs
)
(
MkC
rhs
)
=
rep2
tySynDName
[
nm
,
tvs
,
rhs
]
...
...
@@ -1225,7 +1240,7 @@ templateHaskellNames
fromName
,
fromThenName
,
fromToName
,
fromThenToName
,
funName
,
valName
,
liftName
,
gensymName
,
returnQName
,
bindQName
,
sequenceQName
,
matchName
,
clauseName
,
funName
,
valName
,
tySynDName
,
dataDName
,
classDName
,
matchName
,
clauseName
,
funName
,
valName
,
tySynDName
,
dataDName
,
newtypeDName
,
classDName
,
instName
,
protoName
,
tforallName
,
tvarName
,
tconName
,
tappName
,
arrowTyConName
,
tupleTyConName
,
listTyConName
,
namedTyConName
,
ctxtName
,
constrName
,
recConstrName
,
infixConstrName
,
...
...
@@ -1309,6 +1324,7 @@ clauseName = varQual FSLIT("clause") clauseIdKey
funName
=
varQual
FSLIT
(
"fun"
)
funIdKey
valName
=
varQual
FSLIT
(
"val"
)
valIdKey
dataDName
=
varQual
FSLIT
(
"dataD"
)
dataDIdKey
newtypeDName
=
varQual
FSLIT
(
"newtypeD"
)
newtypeDIdKey
tySynDName
=
varQual
FSLIT
(
"tySynD"
)
tySynDIdKey
classDName
=
varQual
FSLIT
(
"classD"
)
classDIdKey
instName
=
varQual
FSLIT
(
"inst"
)
instIdKey
...
...
@@ -1480,6 +1496,8 @@ intPrimLIdKey = mkPreludeMiscIdUnique 275
floatPrimLIdKey
=
mkPreludeMiscIdUnique
276
doublePrimLIdKey
=
mkPreludeMiscIdUnique
277
newtypeDIdKey
=
mkPreludeMiscIdUnique
278
-- %************************************************************************
-- %* *
-- Other utilities
...
...
ghc/compiler/hsSyn/Convert.lhs
View file @
a011a71c
...
...
@@ -46,6 +46,27 @@ import Outputable
convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message]
convertToHsDecls ds = map cvt_top ds
mk_con con = case con of
Constr c strtys
-> ConDecl (cName c) noExistentials noContext
(PrefixCon (map mk_arg strtys)) loc0
RecConstr c varstrtys
-> ConDecl (cName c) noExistentials noContext
(Hs.RecCon (map mk_id_arg varstrtys)) loc0
InfixConstr st1 c st2
-> ConDecl (cName c) noExistentials noContext
(InfixCon (mk_arg st1) (mk_arg st2)) loc0
where
mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty)
mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty)
mk_id_arg (i, Strict, ty)
= (vName i, BangType MarkedUserStrict (cvtType ty))
mk_id_arg (i, NonStrict, ty)
= (vName i, BangType NotMarkedStrict (cvtType ty))
mk_derivs [] = Nothing
mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
cvt_top d@(Val _ _ _) = Left $ ValD (cvtd d)
...
...
@@ -59,27 +80,12 @@ cvt_top (Data ctxt tc tvs constrs derivs)
(cvt_context ctxt, tconName tc, cvt_tvs tvs)
(DataCons (map mk_con constrs))
(mk_derivs derivs) loc0)
where
mk_con (Constr c strtys)
= ConDecl (cName c) noExistentials noContext
(PrefixCon (map mk_arg strtys)) loc0
mk_con (RecConstr c varstrtys)
= ConDecl (cName c) noExistentials noContext
(Hs.RecCon (map mk_id_arg varstrtys)) loc0
mk_con (InfixConstr st1 c st2)
= ConDecl (cName c) noExistentials noContext
(InfixCon (mk_arg st1) (mk_arg st2)) loc0
mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty)
mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty)
mk_id_arg (i, Strict, ty)
= (vName i, BangType MarkedUserStrict (cvtType ty))
mk_id_arg (i, NonStrict, ty)
= (vName i, BangType NotMarkedStrict (cvtType ty))
mk_derivs [] = Nothing
mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
cvt_top (Newtype ctxt tc tvs constr derivs)
= Left $ TyClD (mkTyData NewType
(cvt_context ctxt, tconName tc, cvt_tvs tvs)
(DataCons [mk_con constr])
(mk_derivs derivs) loc0)
cvt_top (Class ctxt cl tvs decs)
= Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
...
...
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