Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
27b59ad4
Commit
27b59ad4
authored
Aug 31, 2015
by
Jan Rasmus Tikovsky
Browse files
Adapted AbstractCurry generation to distinguish visibility of types and values -- fixes #1329
parent
ed12bb6d
Changes
1
Hide whitespace changes
Inline
Side-by-side
src/Generators/GenAbstractCurry.hs
View file @
27b59ad4
...
...
@@ -74,13 +74,13 @@ cvImportDecl (ImportDecl _ mid _ _ _) = moduleName mid
trTypeDecl
::
Decl
->
GAC
[
CTypeDecl
]
trTypeDecl
(
DataDecl
_
t
vs
cs
)
=
(
\
t'
v
vs'
cs'
->
[
CType
t'
v
vs'
cs'
])
<$>
trGlobalIdent
t
<*>
getVisibility
t
<$>
trGlobalIdent
t
<*>
get
Type
Visibility
t
<*>
mapM
genTVarIndex
vs
<*>
mapM
trConsDecl
cs
trTypeDecl
(
TypeDecl
_
t
vs
ty
)
=
(
\
t'
v
vs'
ty'
->
[
CTypeSyn
t'
v
vs'
ty'
])
<$>
trGlobalIdent
t
<*>
getVisibility
t
<$>
trGlobalIdent
t
<*>
get
Type
Visibility
t
<*>
mapM
genTVarIndex
vs
<*>
trTypeExpr
ty
trTypeDecl
(
NewtypeDecl
_
t
vs
nc
)
=
(
\
t'
v
vs'
nc'
->
[
CNewType
t'
v
vs'
nc'
])
<$>
trGlobalIdent
t
<*>
getVisibility
t
<$>
trGlobalIdent
t
<*>
get
Type
Visibility
t
<*>
mapM
genTVarIndex
vs
<*>
trNewConsDecl
nc
trTypeDecl
_
=
return
[]
...
...
@@ -342,7 +342,8 @@ prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped"
data
AbstractEnv
=
AbstractEnv
{
moduleId
::
ModuleIdent
-- ^name of the module
,
typeEnv
::
ValueEnv
-- ^known values
,
exports
::
Set
.
Set
Ident
-- ^exported symbols
,
tyExports
::
Set
.
Set
Ident
-- ^exported type symbols
,
valExports
::
Set
.
Set
Ident
-- ^exported value symbols
,
varIndex
::
Int
-- ^counter for variable indices
,
tvarIndex
::
Int
-- ^counter for type variable indices
,
varEnv
::
NestEnv
Int
-- ^stack of variable tables
...
...
@@ -357,7 +358,8 @@ abstractEnv :: Bool -> CompilerEnv -> Module -> AbstractEnv
abstractEnv
uacy
env
(
Module
_
mid
es
_
ds
)
=
AbstractEnv
{
moduleId
=
mid
,
typeEnv
=
valueEnv
env
,
exports
=
foldr
(
buildExportTable
mid
)
Set
.
empty
es'
,
tyExports
=
foldr
(
buildTypeExports
mid
)
Set
.
empty
es'
,
valExports
=
foldr
(
buildValueExports
mid
)
Set
.
empty
es'
,
varIndex
=
0
,
tvarIndex
=
0
,
varEnv
=
globalEnv
emptyTopEnv
...
...
@@ -372,12 +374,18 @@ abstractEnv uacy env (Module _ mid es _ ds) = AbstractEnv
_
->
internalError
"GenAbstractCurry.abstractEnv"
-- Builds a table containing all exported identifiers from a module.
buildExportTable
::
ModuleIdent
->
Export
->
Set
.
Set
Ident
->
Set
.
Set
Ident
buildExportTable
mid
(
Export
q
)
buildTypeExports
::
ModuleIdent
->
Export
->
Set
.
Set
Ident
->
Set
.
Set
Ident
buildTypeExports
mid
(
ExportTypeWith
tc
_
)
|
isLocalIdent
mid
tc
=
Set
.
insert
(
unqualify
tc
)
buildTypeExports
_
_
=
id
-- Builds a table containing all exported identifiers from a module.
buildValueExports
::
ModuleIdent
->
Export
->
Set
.
Set
Ident
->
Set
.
Set
Ident
buildValueExports
mid
(
Export
q
)
|
isLocalIdent
mid
q
=
Set
.
insert
(
unqualify
q
)
buildExport
Table
mid
(
ExportTypeWith
tc
cs
)
|
isLocalIdent
mid
tc
=
flip
(
foldr
Set
.
insert
)
(
unqualify
tc
:
cs
)
buildExport
Table
_
_
=
id
build
Value
Export
s
mid
(
ExportTypeWith
tc
cs
)
|
isLocalIdent
mid
tc
=
flip
(
foldr
Set
.
insert
)
cs
build
Value
Export
s
_
_
=
id
-- Looks up the unique index for the variable 'ident' in the
-- variable table of the current scope.
...
...
@@ -469,6 +477,10 @@ getType' f False = do
_
->
internalError
$
"GenAbstractCurry.getType: "
++
show
f
getTypeVisibility
::
Ident
->
GAC
CVisibility
getTypeVisibility
i
=
S
.
gets
$
\
env
->
if
Set
.
member
i
(
tyExports
env
)
then
Public
else
Private
getVisibility
::
Ident
->
GAC
CVisibility
getVisibility
i
=
S
.
gets
$
\
env
->
if
Set
.
member
i
(
exports
env
)
then
Public
else
Private
getVisibility
i
=
S
.
gets
$
\
env
->
if
Set
.
member
i
(
valExports
env
)
then
Public
else
Private
Write
Preview
Supports
Markdown
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