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
ee71aa43
Commit
ee71aa43
authored
Jun 06, 2016
by
Kirchmayr
Browse files
Replaced ScopeEnv with NestEnv in WarnCheck, fixes #1255
parent
2e2ed023
Changes
3
Hide whitespace changes
Inline
Side-by-side
src/Base/NestEnv.hs
View file @
ee71aa43
...
...
@@ -19,7 +19,9 @@
module
Base.NestEnv
(
module
Base
.
TopEnv
,
NestEnv
,
bindNestEnv
,
qualBindNestEnv
,
lookupNestEnv
,
qualLookupNestEnv
,
toplevelEnv
,
globalEnv
,
nestEnv
,
elemNestEnv
,
rebindNestEnv
,
qualRebindNestEnv
,
nestedEnv
,
toplevelEnv
,
globalEnv
,
nestEnv
,
elemNestEnv
,
qualModifyNestEnv
,
modifyNestEnv
,
localNestEnv
,
qualInLocalNestEnv
)
where
import
qualified
Data.Map
as
Map
...
...
@@ -43,6 +45,10 @@ globalEnv = GlobalEnv
nestEnv
::
NestEnv
a
->
NestEnv
a
nestEnv
env
=
LocalEnv
env
Map
.
empty
nestedEnv
::
NestEnv
a
->
NestEnv
a
nestedEnv
(
GlobalEnv
_
)
=
internalError
"NestedEnv.nestedEnv environment is top environment"
nestedEnv
(
LocalEnv
genv
_
)
=
genv
toplevelEnv
::
NestEnv
a
->
TopEnv
a
toplevelEnv
(
GlobalEnv
env
)
=
env
toplevelEnv
(
LocalEnv
genv
_
)
=
toplevelEnv
genv
...
...
@@ -62,6 +68,19 @@ qualBindNestEnv x y (LocalEnv genv env)
Nothing
->
LocalEnv
genv
$
Map
.
insert
x'
y
env
where
x'
=
unqualify
x
-- Rebinds a value to a variable, failes if the variable was unbound before
rebindNestEnv
::
Ident
->
a
->
NestEnv
a
->
NestEnv
a
rebindNestEnv
=
qualRebindNestEnv
.
qualify
qualRebindNestEnv
::
QualIdent
->
a
->
NestEnv
a
->
NestEnv
a
qualRebindNestEnv
x
y
(
GlobalEnv
env
)
=
GlobalEnv
$
qualRebindTopEnv
x
y
env
qualRebindNestEnv
x
y
(
LocalEnv
genv
env
)
|
isQualified
x
=
internalError
$
"NestEnv.qualRebindNestEnv "
++
show
x
|
otherwise
=
case
Map
.
lookup
x'
env
of
Just
_
->
LocalEnv
genv
$
Map
.
insert
x'
y
env
Nothing
->
LocalEnv
(
qualRebindNestEnv
x
y
genv
)
env
where
x'
=
unqualify
x
lookupNestEnv
::
Ident
->
NestEnv
a
->
[
a
]
lookupNestEnv
x
(
GlobalEnv
env
)
=
lookupTopEnv
x
env
lookupNestEnv
x
(
LocalEnv
genv
env
)
=
case
Map
.
lookup
x
env
of
...
...
@@ -75,3 +94,23 @@ qualLookupNestEnv x env
elemNestEnv
::
Ident
->
NestEnv
a
->
Bool
elemNestEnv
x
env
=
not
(
null
(
lookupNestEnv
x
env
))
-- Applies a function to a value binding, does nothing if the variable is unbound
modifyNestEnv
::
(
a
->
a
)
->
Ident
->
NestEnv
a
->
NestEnv
a
modifyNestEnv
f
=
qualModifyNestEnv
f
.
qualify
qualModifyNestEnv
::
(
a
->
a
)
->
QualIdent
->
NestEnv
a
->
NestEnv
a
qualModifyNestEnv
f
x
env
=
case
qualLookupNestEnv
x
env
of
[]
->
env
y
:
_
->
qualRebindNestEnv
x
(
f
y
)
env
-- Returns the variables and values bound on the bottom (meaning non-top) scope
localNestEnv
::
NestEnv
a
->
[(
Ident
,
a
)]
localNestEnv
(
GlobalEnv
env
)
=
localBindings
env
localNestEnv
(
LocalEnv
_
env
)
=
Map
.
toList
env
-- Returns wether the variable is bound on the bottom (meaning non-top) scope
qualInLocalNestEnv
::
QualIdent
->
NestEnv
a
->
Bool
qualInLocalNestEnv
x
(
GlobalEnv
env
)
=
qualElemTopEnv
x
env
qualInLocalNestEnv
x
(
LocalEnv
_
env
)
=
(
not
(
isQualified
x
))
&&
Map
.
member
(
unqualify
x
)
env
src/Base/TopEnv.hs
View file @
ee71aa43
...
...
@@ -43,7 +43,7 @@ module Base.TopEnv
,
bindTopEnv
,
qualBindTopEnv
,
rebindTopEnv
,
qualRebindTopEnv
,
unbindTopEnv
,
lookupTopEnv
,
qualLookupTopEnv
,
allImports
,
moduleImports
,
localBindings
,
allLocalBindings
,
allEntities
,
allEntities
,
qualElemTopEnv
)
where
import
Control.Arrow
(
second
)
...
...
@@ -165,3 +165,6 @@ allLocalBindings (TopEnv env) = [ (x, y) | (x, ys) <- Map.toList env
allEntities
::
TopEnv
a
->
[
a
]
allEntities
(
TopEnv
env
)
=
[
y
|
(
_
,
ys
)
<-
Map
.
toList
env
,
(
_
,
y
)
<-
ys
]
qualElemTopEnv
::
QualIdent
->
TopEnv
a
->
Bool
qualElemTopEnv
x
env
=
not
(
null
(
qualLookupTopEnv
x
env
))
src/Checks/WarnCheck.hs
View file @
ee71aa43
...
...
@@ -21,7 +21,8 @@ import Control.Monad.State.Strict (State, execState, gets, modify)
import
qualified
Data.IntSet
as
IntSet
(
IntSet
,
empty
,
insert
,
notMember
,
singleton
,
union
,
unions
)
import
qualified
Data.Map
as
Map
(
empty
,
insert
,
lookup
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
,
isJust
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
,
listToMaybe
)
import
Data.List
(
intersect
,
intersectBy
,
nub
,
sort
,
unionBy
)
...
...
@@ -33,9 +34,9 @@ import Curry.Syntax.Pretty (ppPattern, ppExpr, ppIdent)
import
Base.CurryTypes
(
ppTypeScheme
)
import
Base.Messages
(
Message
,
posMessage
,
internalError
)
import
qualified
Base.Sc
op
e
Env
as
SE
(
ScopeEnv
,
new
,
beginScope
,
endScopeUp
,
insert
,
lookup
,
level
,
modify
,
lookupWithLevel
,
toLevelList
,
currentLevel
)
import
Base.NestEnv
(
NestEnv
,
emptyT
opEnv
,
globalEnv
,
localNestEnv
,
nestEnv
,
nestedEnv
,
qualBindNestEnv
,
qualInLocalNestEnv
,
qualLookupNestEnv
,
qualModifyNestEnv
)
import
Base.Types
import
Base.Utils
(
findMultiples
)
...
...
@@ -62,7 +63,7 @@ warnCheck opts aEnv valEnv tcEnv (Module _ mid es is ds)
checkMissingTypeSignatures
ds
checkModuleAlias
is
type
ScopeEnv
=
SE
.
ScopeEnv
QualIdent
IdInfo
type
ScopeEnv
=
NestEnv
IdInfo
-- Current state of generating warnings
data
WcState
=
WcState
...
...
@@ -82,7 +83,9 @@ type WCM = State WcState
initWcState
::
ModuleIdent
->
AliasEnv
->
ValueEnv
->
TCEnv
->
[
WarnFlag
]
->
WcState
initWcState
mid
ae
ve
te
wf
=
WcState
mid
SE
.
new
ae
ve
te
wf
[]
initWcState
mid
ae
ve
te
wf
=
WcState
mid
newEnv
ae
ve
te
wf
[]
where
newEnv
=
globalEnv
emptyTopEnv
getModuleIdent
::
WCM
ModuleIdent
getModuleIdent
=
gets
moduleId
...
...
@@ -968,7 +971,7 @@ visitVariable (VarInfo v _) = VarInfo v True
visitVariable
info
=
info
insertScope
::
QualIdent
->
IdInfo
->
WCM
()
insertScope
qid
info
=
modifyScope
$
SE
.
insert
qid
info
insertScope
qid
info
=
modifyScope
$
qualBindNestEnv
qid
info
insertVar
::
Ident
->
WCM
()
insertVar
v
=
unless
(
isAnonId
v
)
$
do
...
...
@@ -999,13 +1002,13 @@ shadowsVar v = gets (shadows $ commonId v)
where
shadows
::
QualIdent
->
WcState
->
Maybe
Ident
shadows
qid
s
=
do
(
info
,
l
)
<-
SE
.
lookupWithLevel
qid
sc
guard
(
l
<
SE
.
currentLevel
sc
)
guard
$
not
(
qualInLocalNestEnv
qid
sc
)
info
<-
listToMaybe
$
qualLookupNestEnv
qid
sc
getVariable
info
where
sc
=
scope
s
visitId
::
Ident
->
WCM
()
visitId
v
=
modifyScope
(
SE
.
modify
visitVariable
(
commonId
v
))
visitId
v
=
modifyScope
(
qualModifyNestEnv
visitVariable
(
commonId
v
))
visitQId
::
QualIdent
->
WCM
()
visitQId
v
=
do
...
...
@@ -1013,7 +1016,7 @@ visitQId v = do
maybe
ok
visitId
(
localIdent
mid
v
)
visitTypeId
::
Ident
->
WCM
()
visitTypeId
v
=
modifyScope
(
SE
.
modify
visitVariable
(
typeId
v
))
visitTypeId
v
=
modifyScope
(
qualModifyNestEnv
visitVariable
(
typeId
v
))
visitQTypeId
::
QualIdent
->
WCM
()
visitQTypeId
v
=
do
...
...
@@ -1028,40 +1031,38 @@ isUnrefTypeVar v = gets (\s -> isUnref s (typeId v))
returnUnrefVars
::
WCM
[
Ident
]
returnUnrefVars
=
gets
(
\
s
->
let
ids
=
map
fst
(
SE
.
toLevelList
(
scope
s
))
unrefs
=
filter
(
isUnref
s
)
ids
in
map
unqualify
unrefs
)
let
ids
=
map
fst
(
localNestEnv
(
scope
s
))
unrefs
=
filter
(
isUnref
s
.
qualify
)
ids
in
unrefs
)
inNestedScope
::
WCM
a
->
WCM
()
inNestedScope
m
=
beginScope
>>
m
>>
endScope
beginScope
::
WCM
()
beginScope
=
modifyScope
SE
.
beginScope
beginScope
=
modifyScope
nestEnv
endScope
::
WCM
()
endScope
=
modifyScope
SE
.
endScopeUp
endScope
=
modifyScope
nestedEnv
------------------------------------------------------------------------------
isKnown
::
WcState
->
QualIdent
->
Bool
isKnown
s
qid
=
let
sc
=
scope
s
in
isJust
(
SE
.
lookup
qid
sc
)
&&
SE
.
level
qid
sc
==
SE
.
currentLevel
sc
isKnown
s
qid
=
qualInLocalNestEnv
qid
(
scope
s
)
isUnref
::
WcState
->
QualIdent
->
Bool
isUnref
s
qid
=
let
sc
=
scope
s
in
maybe
False
(
not
.
variableVisited
)
(
SE
.
lookup
qid
sc
)
&&
SE
.
level
qid
sc
==
SE
.
currentLevel
sc
in
(
any
(
not
.
variableVisited
)
(
qualLookupNestEnv
qid
sc
)
)
&&
qualInLocalNestEnv
qid
sc
isVar
::
QualIdent
->
WcState
->
Bool
isVar
qid
s
=
maybe
(
isAnonId
(
unqualify
qid
))
isVariable
(
SE
.
lookup
qid
(
scope
s
))
(
listToMaybe
(
qualLookupNestEnv
qid
(
scope
s
))
)
isCons
::
QualIdent
->
WcState
->
Bool
isCons
qid
s
=
maybe
(
isImportedCons
s
qid
)
isConstructor
(
SE
.
lookup
qid
(
scope
s
))
(
listToMaybe
(
qualLookupNestEnv
qid
(
scope
s
))
)
where
isImportedCons
s'
qid'
=
case
qualLookupValue
qid'
(
valueEnv
s'
)
of
(
DataConstructor
_
_
_
_
)
:
_
->
True
(
NewtypeConstructor
_
_
_
)
:
_
->
True
...
...
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