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
ac77d931
Commit
ac77d931
authored
Jun 10, 2016
by
Jan Rasmus Tikovsky
Browse files
Refactored CaseCompletion and removed ScopeEnv
parent
9856e54d
Changes
1
Hide whitespace changes
Inline
Side-by-side
src/Transformations/CaseCompletion.hs
View file @
ac77d931
...
...
@@ -3,7 +3,7 @@
Description : CaseCompletion
Copyright : (c) 2005 , Martin Engelke
2011 - 2015, Björn Peemöller
201
5
, Jan Tikovsky
201
6
, Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -34,6 +34,7 @@ module Transformations.CaseCompletion (completeCase) where
#
if
__GLASGOW_HASKELL__
<
710
import
Control.Applicative
((
<$>
),
(
<*>
))
#
endif
import
Control.Monad
(
replicateM
)
import
qualified
Control.Monad.State
as
S
(
State
,
evalState
,
gets
,
modify
)
import
Data.List
(
find
)
import
Data.Maybe
(
fromMaybe
,
listToMaybe
)
...
...
@@ -44,8 +45,6 @@ import qualified Curry.Syntax as CS
import
Base.Expr
import
Base.Messages
(
internalError
)
import
qualified
Base.ScopeEnv
as
SE
(
ScopeEnv
,
new
,
beginScope
,
insert
,
exists
)
import
Env.Interface
(
InterfaceEnv
,
lookupInterface
)
import
IL
...
...
@@ -53,8 +52,7 @@ import IL
-- The interface environment 'iEnv' is needed to compute these constructors.
completeCase
::
InterfaceEnv
->
Module
->
Module
completeCase
iEnv
mdl
@
(
Module
mid
is
ds
)
=
Module
mid
is
ds'
where
ds'
=
S
.
evalState
(
mapM
(
withLocalEnv
.
ccDecl
)
ds
)
(
CCState
mdl
iEnv
(
getModuleScope
mdl
))
where
ds'
=
S
.
evalState
(
mapM
ccDecl
ds
)
(
CCState
mdl
iEnv
0
)
-- -----------------------------------------------------------------------------
-- Internally used state monad
...
...
@@ -63,7 +61,7 @@ completeCase iEnv mdl@(Module mid is ds) = Module mid is ds'
data
CCState
=
CCState
{
modul
::
Module
,
interfaceEnv
::
InterfaceEnv
,
scopeEnv
::
ScopeEnv
,
nextId
::
Int
}
type
CCM
a
=
S
.
State
CCState
a
...
...
@@ -74,21 +72,12 @@ getModule = S.gets modul
getInterfaceEnv
::
CCM
InterfaceEnv
getInterfaceEnv
=
S
.
gets
interfaceEnv
modifyScopeEnv
::
(
ScopeEnv
->
ScopeEnv
)
->
CCM
()
modifyScopeEnv
f
=
S
.
modify
$
\
s
->
s
{
scopeEnv
=
f
$
scopeEnv
s
}
getScopeEnv
::
CCM
ScopeEnv
getScopeEnv
=
S
.
gets
scopeEnv
withLocalEnv
::
CCM
a
->
CCM
a
withLocalEnv
act
=
do
oldEnv
<-
getScopeEnv
res
<-
act
modifyScopeEnv
$
const
oldEnv
return
res
inNestedScope
::
CCM
a
->
CCM
a
inNestedScope
act
=
modifyScopeEnv
SE
.
beginScope
>>
act
-- Create a fresh identifier
freshIdent
::
CCM
Ident
freshIdent
=
do
nid
<-
S
.
gets
nextId
S
.
modify
$
\
s
->
s
{
nextId
=
succ
nid
}
return
$
mkIdent
$
"_#comp"
++
show
nid
-- -----------------------------------------------------------------------------
-- The following functions traverse an IL term searching for case expressions
...
...
@@ -97,9 +86,7 @@ inNestedScope act = modifyScopeEnv SE.beginScope >> act
ccDecl
::
Decl
->
CCM
Decl
ccDecl
dd
@
(
DataDecl
_
_
_
)
=
return
dd
ccDecl
nt
@
(
NewtypeDecl
_
_
_
)
=
return
nt
ccDecl
(
FunctionDecl
qid
vs
ty
e
)
=
inNestedScope
$
do
modifyScopeEnv
(
flip
(
foldr
insertIdent
)
vs
)
FunctionDecl
qid
vs
ty
<$>
ccExpr
e
ccDecl
(
FunctionDecl
qid
vs
ty
e
)
=
FunctionDecl
qid
vs
ty
<$>
ccExpr
e
ccDecl
ed
@
(
ExternalDecl
_
_
_
_
)
=
return
ed
ccExpr
::
Expression
->
CCM
Expression
...
...
@@ -113,21 +100,13 @@ ccExpr (Case r ea e bs) = do
bs'
<-
mapM
ccAlt
bs
ccCase
r
ea
e'
bs'
ccExpr
(
Or
e1
e2
)
=
Or
<$>
ccExpr
e1
<*>
ccExpr
e2
ccExpr
(
Exist
v
e
)
=
inNestedScope
$
do
modifyScopeEnv
$
insertIdent
v
Exist
v
<$>
ccExpr
e
ccExpr
(
Let
b
e
)
=
inNestedScope
$
do
modifyScopeEnv
$
insertBinding
b
flip
Let
<$>
ccExpr
e
<*>
ccBinding
b
ccExpr
(
Letrec
bs
e
)
=
inNestedScope
$
do
modifyScopeEnv
$
flip
(
foldr
insertBinding
)
bs
flip
Letrec
<$>
ccExpr
e
<*>
mapM
ccBinding
bs
ccExpr
(
Exist
v
e
)
=
Exist
v
<$>
ccExpr
e
ccExpr
(
Let
b
e
)
=
Let
<$>
ccBinding
b
<*>
ccExpr
e
ccExpr
(
Letrec
bs
e
)
=
Letrec
<$>
mapM
ccBinding
bs
<*>
ccExpr
e
ccExpr
(
Typed
e
ty
)
=
flip
Typed
ty
<$>
ccExpr
e
ccAlt
::
Alt
->
CCM
Alt
ccAlt
(
Alt
p
e
)
=
inNestedScope
$
do
modifyScopeEnv
$
insertConstrTerm
p
Alt
p
<$>
ccExpr
e
ccAlt
(
Alt
p
e
)
=
Alt
p
<$>
ccExpr
e
ccBinding
::
Binding
->
CCM
Binding
ccBinding
(
Binding
v
e
)
=
Binding
v
<$>
ccExpr
e
...
...
@@ -180,7 +159,8 @@ completeConsAlts r ea ce alts = do
-- complementary constructor patterns
complPats
<-
mapM
genPat
$
getComplConstrs
mdl
menv
[
c
|
(
Alt
(
ConstructorPattern
c
_
)
_
)
<-
consAlts
]
[
v
,
w
]
<-
newIdentList
2
"x"
v
<-
freshIdent
w
<-
freshIdent
return
$
case
(
complPats
,
defaultAlt
v
)
of
(
_
:
_
,
Just
e'
)
->
bindDefVar
v
ce
w
e'
complPats
_
->
Case
r
ea
ce
consAlts
...
...
@@ -189,7 +169,7 @@ completeConsAlts r ea ce alts = do
consAlts
=
[
a
|
a
@
(
Alt
(
ConstructorPattern
_
_
)
_
)
<-
alts
]
-- generate a new constructor pattern
genPat
(
qid
,
arity
)
=
ConstructorPattern
qid
<$>
newIdentList
arity
"x"
genPat
(
qid
,
arity
)
=
ConstructorPattern
qid
<$>
replicateM
arity
freshIdent
-- default alternative, if there is one
defaultAlt
v
=
listToMaybe
[
replaceVar
x
(
Variable
v
)
e
...
...
@@ -230,7 +210,7 @@ completeConsAlts r ea ce alts = do
-- If the default expression is missing, @failed@ is used instead.
completeLitAlts
::
SrcRef
->
Eval
->
Expression
->
[
Alt
]
->
CCM
Expression
completeLitAlts
r
ea
ce
alts
=
do
[
x
]
<-
newIdentList
1
"x"
x
<-
freshIdent
return
$
mkBinding
x
ce
$
nestedCases
x
alts
where
nestedCases
_
[]
=
failedExpr
...
...
@@ -400,65 +380,3 @@ getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos
-- Compute complementary constructors
complementary
::
[
QualIdent
]
->
[(
QualIdent
,
Int
)]
->
[(
QualIdent
,
Int
)]
complementary
known
others
=
filter
((`
notElem
`
known
)
.
fst
)
others
-- ---------------------------------------------------------------------------
-- ScopeEnv stuff
-- ---------------------------------------------------------------------------
-- Type for representing an environment containing identifiers in several
-- scope levels
type
ScopeEnv
=
SE
.
ScopeEnv
(
Either
String
Integer
)
()
insertIdent
::
Ident
->
ScopeEnv
->
ScopeEnv
insertIdent
i
=
SE
.
insert
(
Left
(
idName
i
))
()
.
SE
.
insert
(
Right
(
idUnique
i
))
()
newIdentList
::
Int
->
String
->
CCM
[
Ident
]
newIdentList
num
str
=
genIdentList
num
(
0
::
Integer
)
where
-- Generates a list of new identifiers where each identifier has
-- the prefix 'name' followed by an index (i.e., "var3" if 'name' was "var").
-- All returned identifiers are unique within the current scope.
genIdentList
s
i
|
s
==
0
=
return
[]
|
otherwise
=
do
env
<-
getScopeEnv
case
genIdent
(
str
++
show
i
)
env
of
Nothing
->
genIdentList
s
(
i
+
1
)
Just
ident
->
do
modifyScopeEnv
$
insertIdent
ident
idents
<-
genIdentList
(
s
-
1
)
(
i
+
1
)
return
(
ident
:
idents
)
-- Generates a new identifier for the specified name. The new identifier is
-- unique within the current scope. If no identifier can be generated for
-- 'name', then 'Nothing' will be returned
genIdent
n
env
|
SE
.
exists
(
Left
n
)
env
=
Nothing
|
otherwise
=
Just
(
try
0
)
where
try
i
|
SE
.
exists
(
Right
i
)
env
=
try
(
i
+
1
)
|
otherwise
=
renameIdent
(
mkIdent
n
)
i
getModuleScope
::
Module
->
ScopeEnv
getModuleScope
(
Module
_
_
ds
)
=
foldr
insertDecl
SE
.
new
ds
insertDecl
::
Decl
->
ScopeEnv
->
ScopeEnv
insertDecl
(
DataDecl
qid
_
cs
)
=
flip
(
foldr
insertConstrDecl
)
cs
.
insertQIdent
qid
insertDecl
(
NewtypeDecl
qid
_
c
)
=
insertConstrDecl
c
.
insertQIdent
qid
insertDecl
(
FunctionDecl
qid
_
_
_
)
=
insertQIdent
qid
insertDecl
(
ExternalDecl
qid
_
_
_
)
=
insertQIdent
qid
insertConstrDecl
::
ConstrDecl
a
->
ScopeEnv
->
ScopeEnv
insertConstrDecl
(
ConstrDecl
qid
_
)
=
insertQIdent
qid
insertConstrTerm
::
ConstrTerm
->
ScopeEnv
->
ScopeEnv
insertConstrTerm
(
LiteralPattern
_
)
=
id
insertConstrTerm
(
ConstructorPattern
_
vs
)
=
flip
(
foldr
insertIdent
)
vs
insertConstrTerm
(
VariablePattern
v
)
=
insertIdent
v
insertBinding
::
Binding
->
ScopeEnv
->
ScopeEnv
insertBinding
(
Binding
v
_
)
=
insertIdent
v
insertQIdent
::
QualIdent
->
ScopeEnv
->
ScopeEnv
insertQIdent
q
=
insertIdent
(
unqualify
q
)
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