Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,256
Issues
4,256
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
394
Merge Requests
394
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
a011a71c
Commit
a011a71c
authored
May 21, 2003
by
igloo
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[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
Showing
2 changed files
with
45 additions
and
21 deletions
+45
-21
ghc/compiler/deSugar/DsMeta.hs
ghc/compiler/deSugar/DsMeta.hs
+19
-1
ghc/compiler/hsSyn/Convert.lhs
ghc/compiler/hsSyn/Convert.lhs
+26
-20
No files found.
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
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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