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,251
Issues
4,251
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
398
Merge Requests
398
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
Hide 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)
...
@@ -141,7 +141,7 @@ dsReify r@(ReifyOut ReifyDecl name)
repTopDs
::
HsGroup
Name
->
DsM
(
Core
(
M
.
Q
[
M
.
Dec
]))
repTopDs
::
HsGroup
Name
->
DsM
(
Core
(
M
.
Q
[
M
.
Dec
]))
repTopDs
group
repTopDs
group
=
do
{
let
{
bndrs
=
groupBinders
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.
-- Bind all the names mainly to avoid repeated use of explicit strings.
-- Thus we get
-- Thus we get
...
@@ -262,12 +262,16 @@ repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
...
@@ -262,12 +262,16 @@ repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
repInstD'
(
InstDecl
ty
binds
_
loc
)
repInstD'
(
InstDecl
ty
binds
_
loc
)
-- Ignore user pragmas for now
-- Ignore user pragmas for now
=
do
{
cxt1
<-
repContext
cxt
;
=
do
{
cxt1
<-
repContext
cxt
inst_ty1
<-
repPred
(
HsClassP
cls
tys
)
;
;
inst_ty1
<-
repPred
(
HsClassP
cls
tys
)
binds1
<-
rep_monobind
binds
;
;
let
ss
=
mkGenSyms
(
collectMonoBinders
binds
)
decls1
<-
coreList
decQTyConName
binds1
;
;
binds1
<-
addBinds
ss
(
rep_monobind
binds
)
i
<-
repInst
cxt1
inst_ty1
decls1
;
;
decls1
<-
coreList
decQTyConName
binds1
return
(
loc
,
i
)}
;
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
where
(
tvs
,
cxt
,
cls
,
tys
)
=
splitHsInstDeclTy
ty
(
tvs
,
cxt
,
cls
,
tys
)
=
splitHsInstDeclTy
ty
...
@@ -345,7 +349,7 @@ addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
...
@@ -345,7 +349,7 @@ addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
addTyVarBinds
tvs
m
=
addTyVarBinds
tvs
m
=
do
do
let
names
=
map
hsTyVarName
tvs
let
names
=
map
hsTyVarName
tvs
freshNames
<-
mkGenSyms
names
let
freshNames
=
mkGenSyms
names
term
<-
addBinds
freshNames
$
do
term
<-
addBinds
freshNames
$
do
bndrs
<-
mapM
lookupBinder
names
bndrs
<-
mapM
lookupBinder
names
m
bndrs
m
bndrs
...
@@ -535,7 +539,7 @@ repE e =
...
@@ -535,7 +539,7 @@ repE e =
repMatchTup
::
Match
Name
->
DsM
(
Core
M
.
MatchQ
)
repMatchTup
::
Match
Name
->
DsM
(
Core
M
.
MatchQ
)
repMatchTup
(
Match
[
p
]
ty
(
GRHSs
guards
wheres
ty2
))
=
repMatchTup
(
Match
[
p
]
ty
(
GRHSs
guards
wheres
ty2
))
=
do
{
ss1
<-
mkGenSyms
(
collectPatBinders
p
)
do
{
let
ss1
=
mkGenSyms
(
collectPatBinders
p
)
;
addBinds
ss1
$
do
{
;
addBinds
ss1
$
do
{
;
p1
<-
repP
p
;
p1
<-
repP
p
;
(
ss2
,
ds
)
<-
repBinds
wheres
;
(
ss2
,
ds
)
<-
repBinds
wheres
...
@@ -546,7 +550,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
...
@@ -546,7 +550,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
repClauseTup
::
Match
Name
->
DsM
(
Core
M
.
ClauseQ
)
repClauseTup
::
Match
Name
->
DsM
(
Core
M
.
ClauseQ
)
repClauseTup
(
Match
ps
ty
(
GRHSs
guards
wheres
ty2
))
=
repClauseTup
(
Match
ps
ty
(
GRHSs
guards
wheres
ty2
))
=
do
{
ss1
<-
mkGenSyms
(
collectPatsBinders
ps
)
do
{
let
ss1
=
mkGenSyms
(
collectPatsBinders
ps
)
;
addBinds
ss1
$
do
{
;
addBinds
ss1
$
do
{
ps1
<-
repPs
ps
ps1
<-
repPs
ps
;
(
ss2
,
ds
)
<-
repBinds
wheres
;
(
ss2
,
ds
)
<-
repBinds
wheres
...
@@ -576,7 +580,7 @@ repFields flds = do
...
@@ -576,7 +580,7 @@ repFields flds = do
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
-- 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.
-- 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"))
-- 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
-- if variables didn't shaddow, the static gensym wouldn't be necessary
...
@@ -606,7 +610,7 @@ repSts [ResultStmt e loc] =
...
@@ -606,7 +610,7 @@ repSts [ResultStmt e loc] =
;
return
(
[]
,
[
e1
])
}
;
return
(
[]
,
[
e1
])
}
repSts
(
BindStmt
p
e
loc
:
ss
)
=
repSts
(
BindStmt
p
e
loc
:
ss
)
=
do
{
e2
<-
repE
e
do
{
e2
<-
repE
e
;
ss1
<-
mkGenSyms
(
collectPatBinders
p
)
;
let
ss1
=
mkGenSyms
(
collectPatBinders
p
)
;
addBinds
ss1
$
do
{
;
addBinds
ss1
$
do
{
;
p1
<-
repP
p
;
;
p1
<-
repP
p
;
;
(
ss2
,
zs
)
<-
repSts
ss
;
(
ss2
,
zs
)
<-
repSts
ss
...
@@ -631,17 +635,23 @@ repSts other = panic "Exotic Stmt in meta brackets"
...
@@ -631,17 +635,23 @@ repSts other = panic "Exotic Stmt in meta brackets"
repBinds
::
HsBinds
Name
->
DsM
([
GenSymBind
],
Core
[
M
.
DecQ
])
repBinds
::
HsBinds
Name
->
DsM
([
GenSymBind
],
Core
[
M
.
DecQ
])
repBinds
decs
repBinds
decs
=
do
{
let
{
bndrs
=
collectHsBinders
decs
}
;
=
do
{
let
{
bndrs
=
collectHsBinders
decs
}
ss
<-
mkGenSyms
bndrs
;
-- No need to worrry about detailed scopes within
core
<-
addBinds
ss
(
rep_binds
decs
)
;
-- the binding group, because we are talking Names
core_list
<-
coreList
decQTyConName
core
;
-- here, so we can safely treat it as a mutually
return
(
ss
,
core_list
)
}
-- 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
]
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
rep_binds
binds
=
do
locs_cores
<-
rep_binds'
binds
return
$
de_loc
$
sort_by_loc
locs_cores
return
$
de_loc
$
sort_by_loc
locs_cores
rep_binds'
::
HsBinds
Name
->
DsM
[(
SrcLoc
,
Core
M
.
DecQ
)]
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'
EmptyBinds
=
return
[]
rep_binds'
(
ThenBinds
x
y
)
rep_binds'
(
ThenBinds
x
y
)
=
do
{
core1
<-
rep_binds'
x
=
do
{
core1
<-
rep_binds'
x
...
@@ -655,10 +665,12 @@ rep_binds' (IPBinds _)
...
@@ -655,10 +665,12 @@ rep_binds' (IPBinds _)
=
panic
"DsMeta:repBinds: can't do implicit parameters"
=
panic
"DsMeta:repBinds: can't do implicit parameters"
rep_monobind
::
MonoBinds
Name
->
DsM
[
Core
M
.
DecQ
]
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
rep_monobind
binds
=
do
locs_cores
<-
rep_monobind'
binds
return
$
de_loc
$
sort_by_loc
locs_cores
return
$
de_loc
$
sort_by_loc
locs_cores
rep_monobind'
::
MonoBinds
Name
->
DsM
[(
SrcLoc
,
Core
M
.
DecQ
)]
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'
EmptyMonoBinds
=
return
[]
rep_monobind'
(
AndMonoBinds
x
y
)
=
do
{
x1
<-
rep_monobind'
x
;
rep_monobind'
(
AndMonoBinds
x
y
)
=
do
{
x1
<-
rep_monobind'
x
;
y1
<-
rep_monobind'
y
;
y1
<-
rep_monobind'
y
;
...
@@ -725,7 +737,7 @@ repLambda :: Match Name -> DsM (Core M.ExpQ)
...
@@ -725,7 +737,7 @@ repLambda :: Match Name -> DsM (Core M.ExpQ)
repLambda
(
Match
ps
_
(
GRHSs
[
GRHS
[
ResultStmt
e
_
]
_
]
repLambda
(
Match
ps
_
(
GRHSs
[
GRHS
[
ResultStmt
e
_
]
_
]
EmptyBinds
_
))
EmptyBinds
_
))
=
do
{
let
bndrs
=
collectPatsBinders
ps
;
=
do
{
let
bndrs
=
collectPatsBinders
ps
;
;
ss
<-
mkGenSyms
bndrs
;
let
ss
=
mkGenSyms
bndrs
;
lam
<-
addBinds
ss
(
;
lam
<-
addBinds
ss
(
do
{
xs
<-
repPs
ps
;
body
<-
repE
e
;
repLam
xs
body
})
do
{
xs
<-
repPs
ps
;
body
<-
repE
e
;
repLam
xs
body
})
;
wrapGenSyns
ss
lam
}
;
wrapGenSyns
ss
lam
}
...
@@ -783,26 +795,24 @@ de_loc = map snd
...
@@ -783,26 +795,24 @@ de_loc = map snd
-- The meta-environment
-- The meta-environment
-- A name/identifier association for fresh names of locally bound entities
-- A name/identifier association for fresh names of locally bound entities
--
type
GenSymBind
=
(
Name
,
Id
)
-- Gensym the string and bind it to the Id
type
GenSymBind
=
(
Name
,
Id
)
-- Gensym the string and bind it to the Id
-- I.e. (x, x_id) means
-- I.e. (x, x_id) means
-- let x_id = gensym "x" in ...
-- let x_id = gensym "x" in ...
-- Generate a fresh name for a locally bound entity
-- Generate a fresh name for a locally bound entity
--
mkGenSym
::
Name
->
DsM
GenSymBind
mkGenSym
::
Name
->
GenSymBind
mkGenSym
nm
=
do
{
id
<-
newUniqueId
nm
stringTy
;
return
(
nm
,
id
)
}
mkGenSym
nm
=
(
nm
,
mkLocalId
nm
stringTy
)
-- Ditto for a list of names
-- Ditto for a list of names
--
--
mkGenSyms
::
[
Name
]
->
DsM
[
GenSymBind
]
mkGenSyms
::
[
Name
]
->
[
GenSymBind
]
mkGenSyms
ns
=
map
M
mkGenSym
ns
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
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
addBinds
bs
m
=
dsExtendMetaEnv
(
mkNameEnv
[(
n
,
Bound
id
)
|
(
n
,
id
)
<-
bs
])
m
-- Look up a locally bound name
-- Look up a locally bound name
...
@@ -844,13 +854,13 @@ lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
...
@@ -844,13 +854,13 @@ lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
lookupType
tc_name
=
do
{
tc
<-
dsLookupTyCon
tc_name
;
lookupType
tc_name
=
do
{
tc
<-
dsLookupTyCon
tc_name
;
return
(
mkGenTyConApp
tc
[]
)
}
return
(
mkGenTyConApp
tc
[]
)
}
wrapGenSyns
::
[
GenSymBind
]
->
Core
(
M
.
Q
a
)
->
DsM
(
Core
(
M
.
Q
a
))
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y
-- --> bindQ (gensym nm1) (\ id1 ->
-- --> bindQ (gensym nm1) (\ id1 ->
-- bindQ (gensym nm2 (\ id2 ->
-- bindQ (gensym nm2 (\ id2 ->
-- y))
-- y))
wrapGenSyns
::
[
GenSymBind
]
->
Core
(
M
.
Q
a
)
->
DsM
(
Core
(
M
.
Q
a
))
wrapGenSyns
binds
body
@
(
MkC
b
)
wrapGenSyns
binds
body
@
(
MkC
b
)
=
go
binds
=
go
binds
where
where
...
@@ -868,8 +878,10 @@ wrapGenSyns binds body@(MkC b)
...
@@ -868,8 +878,10 @@ wrapGenSyns binds body@(MkC b)
gensym_app
(
MkC
(
Lam
id
body'
))
}
gensym_app
(
MkC
(
Lam
id
body'
))
}
-- Just like wrapGenSym, but don't actually do the gensym
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Instead use the existing name:
-- Only used for [Decl]
-- 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
::
[
GenSymBind
]
->
Core
a
->
DsM
(
Core
a
)
wrapNongenSyms
binds
(
MkC
body
)
wrapNongenSyms
binds
(
MkC
body
)
=
do
{
binds'
<-
mapM
do_one
binds
;
=
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