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,248
Issues
4,248
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
396
Merge Requests
396
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
5a0fa261
Commit
5a0fa261
authored
Oct 30, 2003
by
simonpj
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[project @ 2003-10-30 09:33:30 by simonpj]
Updating TH; not finished
parent
8fc898cb
Changes
1
Show whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
44 additions
and
32 deletions
+44
-32
ghc/compiler/deSugar/DsMeta.hs
ghc/compiler/deSugar/DsMeta.hs
+44
-32
No files found.
ghc/compiler/deSugar/DsMeta.hs
View file @
5a0fa261
...
...
@@ -141,7 +141,7 @@ dsReify r@(ReifyOut ReifyDecl name)
repTopDs
::
HsGroup
Name
->
DsM
(
Core
(
M
.
Q
[
M
.
Dec
]))
repTopDs
group
=
do
{
let
{
bndrs
=
groupBinders
group
}
;
ss
<-
mkGenSyms
bndrs
;
let
{
ss
=
mkGenSyms
bndrs
}
;
-- Bind all the names mainly to avoid repeated use of explicit strings.
-- Thus we get
...
...
@@ -262,12 +262,16 @@ repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
repInstD'
(
InstDecl
ty
binds
_
loc
)
-- Ignore user pragmas for now
=
do
{
cxt1
<-
repContext
cxt
;
inst_ty1
<-
repPred
(
HsClassP
cls
tys
)
;
binds1
<-
rep_monobind
binds
;
decls1
<-
coreList
decQTyConName
binds1
;
i
<-
repInst
cxt1
inst_ty1
decls1
;
return
(
loc
,
i
)}
=
do
{
cxt1
<-
repContext
cxt
;
inst_ty1
<-
repPred
(
HsClassP
cls
tys
)
;
let
ss
=
mkGenSyms
(
collectMonoBinders
binds
)
;
binds1
<-
addBinds
ss
(
rep_monobind
binds
)
;
decls1
<-
coreList
decQTyConName
binds1
;
i
<-
repInst
cxt1
inst_ty1
(
wrapNonGenSyms
ss
decls1
)
-- wrapNonGenSyms: do not clone the class op names!
-- They must be called 'op' etc, not 'op34'
;
return
(
loc
,
i
)}
where
(
tvs
,
cxt
,
cls
,
tys
)
=
splitHsInstDeclTy
ty
...
...
@@ -345,7 +349,7 @@ addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
addTyVarBinds
tvs
m
=
do
let
names
=
map
hsTyVarName
tvs
freshNames
<-
mkGenSyms
names
let
freshNames
=
mkGenSyms
names
term
<-
addBinds
freshNames
$
do
bndrs
<-
mapM
lookupBinder
names
m
bndrs
...
...
@@ -535,7 +539,7 @@ repE e =
repMatchTup
::
Match
Name
->
DsM
(
Core
M
.
MatchQ
)
repMatchTup
(
Match
[
p
]
ty
(
GRHSs
guards
wheres
ty2
))
=
do
{
ss1
<-
mkGenSyms
(
collectPatBinders
p
)
do
{
let
ss1
=
mkGenSyms
(
collectPatBinders
p
)
;
addBinds
ss1
$
do
{
;
p1
<-
repP
p
;
(
ss2
,
ds
)
<-
repBinds
wheres
...
...
@@ -546,7 +550,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
repClauseTup
::
Match
Name
->
DsM
(
Core
M
.
ClauseQ
)
repClauseTup
(
Match
ps
ty
(
GRHSs
guards
wheres
ty2
))
=
do
{
ss1
<-
mkGenSyms
(
collectPatsBinders
ps
)
do
{
let
ss1
=
mkGenSyms
(
collectPatsBinders
ps
)
;
addBinds
ss1
$
do
{
ps1
<-
repPs
ps
;
(
ss2
,
ds
)
<-
repBinds
wheres
...
...
@@ -576,7 +580,7 @@ repFields flds = do
-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
-- shad
d
ow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
-- First gensym new names for every variable in any of the patterns.
-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
-- if variables didn't shaddow, the static gensym wouldn't be necessary
...
...
@@ -606,7 +610,7 @@ repSts [ResultStmt e loc] =
;
return
(
[]
,
[
e1
])
}
repSts
(
BindStmt
p
e
loc
:
ss
)
=
do
{
e2
<-
repE
e
;
ss1
<-
mkGenSyms
(
collectPatBinders
p
)
;
let
ss1
=
mkGenSyms
(
collectPatBinders
p
)
;
addBinds
ss1
$
do
{
;
p1
<-
repP
p
;
;
(
ss2
,
zs
)
<-
repSts
ss
...
...
@@ -631,17 +635,23 @@ repSts other = panic "Exotic Stmt in meta brackets"
repBinds
::
HsBinds
Name
->
DsM
([
GenSymBind
],
Core
[
M
.
DecQ
])
repBinds
decs
=
do
{
let
{
bndrs
=
collectHsBinders
decs
}
;
ss
<-
mkGenSyms
bndrs
;
core
<-
addBinds
ss
(
rep_binds
decs
)
;
core_list
<-
coreList
decQTyConName
core
;
return
(
ss
,
core_list
)
}
=
do
{
let
{
bndrs
=
collectHsBinders
decs
}
-- No need to worrry about detailed scopes within
-- the binding group, because we are talking Names
-- here, so we can safely treat it as a mutually
-- recursive group
;
let
ss
=
mkGenSyms
bndrs
;
core
<-
addBinds
ss
(
rep_binds
decs
)
;
core_list
<-
coreList
decQTyConName
core
;
return
(
ss
,
core_list
)
}
rep_binds
::
HsBinds
Name
->
DsM
[
Core
M
.
DecQ
]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_binds
binds
=
do
locs_cores
<-
rep_binds'
binds
return
$
de_loc
$
sort_by_loc
locs_cores
rep_binds'
::
HsBinds
Name
->
DsM
[(
SrcLoc
,
Core
M
.
DecQ
)]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_binds'
EmptyBinds
=
return
[]
rep_binds'
(
ThenBinds
x
y
)
=
do
{
core1
<-
rep_binds'
x
...
...
@@ -655,10 +665,12 @@ rep_binds' (IPBinds _)
=
panic
"DsMeta:repBinds: can't do implicit parameters"
rep_monobind
::
MonoBinds
Name
->
DsM
[
Core
M
.
DecQ
]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_monobind
binds
=
do
locs_cores
<-
rep_monobind'
binds
return
$
de_loc
$
sort_by_loc
locs_cores
rep_monobind'
::
MonoBinds
Name
->
DsM
[(
SrcLoc
,
Core
M
.
DecQ
)]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_monobind'
EmptyMonoBinds
=
return
[]
rep_monobind'
(
AndMonoBinds
x
y
)
=
do
{
x1
<-
rep_monobind'
x
;
y1
<-
rep_monobind'
y
;
...
...
@@ -725,7 +737,7 @@ repLambda :: Match Name -> DsM (Core M.ExpQ)
repLambda
(
Match
ps
_
(
GRHSs
[
GRHS
[
ResultStmt
e
_
]
_
]
EmptyBinds
_
))
=
do
{
let
bndrs
=
collectPatsBinders
ps
;
;
ss
<-
mkGenSyms
bndrs
;
let
ss
=
mkGenSyms
bndrs
;
lam
<-
addBinds
ss
(
do
{
xs
<-
repPs
ps
;
body
<-
repE
e
;
repLam
xs
body
})
;
wrapGenSyns
ss
lam
}
...
...
@@ -783,26 +795,24 @@ de_loc = map snd
-- 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 ...
-- Generate a fresh name for a locally bound entity
--
mkGenSym
::
Name
->
DsM
GenSymBind
mkGenSym
nm
=
do
{
id
<-
newUniqueId
nm
stringTy
;
return
(
nm
,
id
)
}
mkGenSym
::
Name
->
GenSymBind
mkGenSym
nm
=
(
nm
,
mkLocalId
nm
stringTy
)
-- Ditto for a list of names
--
mkGenSyms
::
[
Name
]
->
DsM
[
GenSymBind
]
mkGenSyms
ns
=
map
M
mkGenSym
ns
mkGenSyms
::
[
Name
]
->
[
GenSymBind
]
mkGenSyms
ns
=
map
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
-- 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
bs
m
=
dsExtendMetaEnv
(
mkNameEnv
[(
n
,
Bound
id
)
|
(
n
,
id
)
<-
bs
])
m
-- Look up a locally bound name
...
...
@@ -844,13 +854,13 @@ lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
lookupType
tc_name
=
do
{
tc
<-
dsLookupTyCon
tc_name
;
return
(
mkGenTyConApp
tc
[]
)
}
wrapGenSyns
::
[
GenSymBind
]
->
Core
(
M
.
Q
a
)
->
DsM
(
Core
(
M
.
Q
a
))
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y
-- --> bindQ (gensym nm1) (\ id1 ->
-- bindQ (gensym nm2 (\ id2 ->
-- y))
wrapGenSyns
::
[
GenSymBind
]
->
Core
(
M
.
Q
a
)
->
DsM
(
Core
(
M
.
Q
a
))
wrapGenSyns
binds
body
@
(
MkC
b
)
=
go
binds
where
...
...
@@ -868,8 +878,10 @@ wrapGenSyns binds body@(MkC b)
gensym_app
(
MkC
(
Lam
id
body'
))
}
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
-- Instead use the existing name:
-- let x = "x" in ...
-- Only used for [Decl], and for the class ops in class
-- and instance decls
wrapNongenSyms
::
[
GenSymBind
]
->
Core
a
->
DsM
(
Core
a
)
wrapNongenSyms
binds
(
MkC
body
)
=
do
{
binds'
<-
mapM
do_one
binds
;
...
...
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