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
35aa03e8
Commit
35aa03e8
authored
Oct 07, 2011
by
Björn Peemöller
Browse files
Arity problems (hopefully) solved
parent
dbab7444
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/Checks/SyntaxCheck.lhs
View file @
35aa03e8
...
@@ -99,23 +99,24 @@ by which the variables get renamed.
...
@@ -99,23 +99,24 @@ by which the variables get renamed.
>
modifyRenameEnv
::
(
RenameEnv
->
RenameEnv
)
->
SCM
()
>
modifyRenameEnv
::
(
RenameEnv
->
RenameEnv
)
->
SCM
()
>
modifyRenameEnv
f
=
S
.
modify
$
\
s
->
s
{
renameEnv
=
f
$
renameEnv
s
}
>
modifyRenameEnv
f
=
S
.
modify
$
\
s
->
s
{
renameEnv
=
f
$
renameEnv
s
}
>
incId
::
SCM
()
>
incId
=
S
.
modify
$
\
s
->
s
{
currentId
=
succ
$
currentId
s
}
>
getCurrentId
::
SCM
Integer
>
getCurrentId
=
S
.
gets
currentId
>
newId
::
SCM
Integer
>
newId
=
incId
>>
getCurrentId
>
inNestedEnv
::
SCM
a
->
SCM
a
>
inNestedEnv
::
SCM
a
->
SCM
a
>
inNestedEnv
act
=
do
>
inNestedEnv
act
=
do
>
oldEnv
<-
getRenameEnv
>
oldEnv
<-
getRenameEnv
>
modifyRenameEnv
nestEnv
>
modifyRenameEnv
nestEnv
>
S
.
modify
$
\
s
->
s
{
currentId
=
succ
$
currentId
s
}
>
incId
>
res
<-
act
>
res
<-
act
>
modifyRenameEnv
$
const
oldEnv
>
modifyRenameEnv
$
const
oldEnv
>
return
res
>
return
res
>
newId
::
SCM
Integer
>
newId
=
do
>
S
.
modify
$
\
s
->
s
{
currentId
=
succ
$
currentId
s
}
>
getCurrentId
>
getCurrentId
::
SCM
Integer
>
getCurrentId
=
S
.
gets
currentId
>
report
::
Message
->
SCM
()
>
report
::
Message
->
SCM
()
>
report
msg
=
S
.
modify
$
\
s
->
s
{
errors
=
msg
:
errors
s
}
>
report
msg
=
S
.
modify
$
\
s
->
s
{
errors
=
msg
:
errors
s
}
...
...
src/Checks/TypeCheck.lhs
View file @
35aa03e8
...
@@ -27,7 +27,7 @@ type annotation is present.
...
@@ -27,7 +27,7 @@ type annotation is present.
>
import
qualified
Control.Monad.State
as
S
(
State
,
runState
,
gets
,
modify
)
>
import
qualified
Control.Monad.State
as
S
(
State
,
runState
,
gets
,
modify
)
>
import
Data.List
(
nub
,
partition
)
>
import
Data.List
(
nub
,
partition
)
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
)
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
)
>
import
Data.Maybe
(
catMaybes
,
fromJust
,
isJust
,
listToMaybe
,
maybeToList
)
>
import
Data.Maybe
(
catMaybes
,
fromJust
,
fromMaybe
,
isJust
,
listToMaybe
,
maybeToList
)
>
import
qualified
Data.Set
as
Set
(
Set
,
fromList
,
member
,
notMember
,
unions
)
>
import
qualified
Data.Set
as
Set
(
Set
,
fromList
,
member
,
notMember
,
unions
)
>
import
Text.PrettyPrint
>
import
Text.PrettyPrint
...
@@ -436,22 +436,24 @@ signature the declared type must be too general.
...
@@ -436,22 +436,24 @@ signature the declared type must be too general.
>
genDecl
::
ModuleIdent
->
TCEnv
->
SigEnv
->
Set
.
Set
Int
->
TypeSubst
->
Decl
>
genDecl
::
ModuleIdent
->
TCEnv
->
SigEnv
->
Set
.
Set
Int
->
TypeSubst
->
Decl
>
->
TCM
()
>
->
TCM
()
>
genDecl
m
tcEnv
sigs
lvs
theta
(
FunctionDecl
_
f
_
)
=
>
genDecl
m
tcEnv
sigs
lvs
theta
(
FunctionDecl
_
f
(
Equation
_
lhs
_
:
_
))
=
>
modifyValueEnv
(
genVar
True
m
tcEnv
sigs
lvs
theta
f
)
>
modifyValueEnv
(
genVar
True
m
tcEnv
sigs
lvs
theta
arity
f
)
>
genDecl
m
tcEnv
sigs
lvs
theta
(
PatternDecl
_
t
_
)
=
>
where
arity
=
Just
$
length
$
snd
$
flatLhs
lhs
>
mapM_
(
modifyValueEnv
.
genVar
False
m
tcEnv
sigs
lvs
theta
)
(
bv
t
)
>
genDecl
m
tcEnv
sigs
lvs
theta
(
PatternDecl
_
t
_
)
=
>
mapM_
(
modifyValueEnv
.
genVar
False
m
tcEnv
sigs
lvs
theta
Nothing
)
(
bv
t
)
>
genDecl
_
_
_
_
_
_
=
internalError
"TypeCheck.genDecl: no pattern match"
>
genDecl
_
_
_
_
_
_
=
internalError
"TypeCheck.genDecl: no pattern match"
>
genVar
::
Bool
->
ModuleIdent
->
TCEnv
->
SigEnv
->
Set
.
Set
Int
->
TypeSubst
>
genVar
::
Bool
->
ModuleIdent
->
TCEnv
->
SigEnv
->
Set
.
Set
Int
->
TypeSubst
>
->
Ident
->
ValueEnv
->
ValueEnv
>
->
Maybe
Int
->
Ident
->
ValueEnv
->
ValueEnv
>
genVar
poly
m
tcEnv
sigs
lvs
theta
v
tyEnv
=
case
lookupTypeSig
v
sigs
of
>
genVar
poly
m
tcEnv
sigs
lvs
theta
ma
v
tyEnv
=
case
lookupTypeSig
v
sigs
of
>
Just
sigTy
>
Just
sigTy
>
|
cmpTypes
sigma
(
expandPolyType
m
tcEnv
sigTy
)
->
tyEnv'
>
|
cmpTypes
sigma
(
expandPolyType
m
tcEnv
sigTy
)
->
tyEnv'
>
|
otherwise
->
errorAt
(
positionOfIdent
v
)
>
|
otherwise
->
errorAt
(
positionOfIdent
v
)
>
(
errTypeSigTooGeneral
m
what
sigTy
sigma
)
>
(
errTypeSigTooGeneral
m
what
sigTy
sigma
)
>
Nothing
->
tyEnv'
>
Nothing
->
tyEnv'
>
where
what
=
text
(
if
poly
then
"Function:"
else
"Variable:"
)
<+>
ppIdent
v
>
where
what
=
text
(
if
poly
then
"Function:"
else
"Variable:"
)
<+>
ppIdent
v
>
tyEnv'
=
rebindFun
m
v
(
varArity
v
tyEnv
)
sigma
tyEnv
>
tyEnv'
=
rebindFun
m
v
arity
sigma
tyEnv
>
arity
=
fromMaybe
(
varArity
v
tyEnv
)
ma
>
sigma
=
genType
poly
(
subst
theta
(
varType
v
tyEnv
))
>
sigma
=
genType
poly
(
subst
theta
(
varType
v
tyEnv
))
>
genType
poly'
(
ForAll
n
ty
)
>
genType
poly'
(
ForAll
n
ty
)
>
|
n
>
0
=
internalError
$
"TypeCheck.genVar: "
++
showLine
(
positionOfIdent
v
)
++
show
v
++
" :: "
++
show
ty
>
|
n
>
0
=
internalError
$
"TypeCheck.genVar: "
++
showLine
(
positionOfIdent
v
)
++
show
v
++
" :: "
++
show
ty
...
...
src/Env/Value.lhs
View file @
35aa03e8
...
@@ -11,7 +11,8 @@ are considered equal if their original names match.
...
@@ -11,7 +11,8 @@ are considered equal if their original names match.
\begin{verbatim}
\begin{verbatim}
>
module
Env.Value
>
module
Env.Value
>
(
ValueEnv
,
ValueInfo
(
..
),
bindGlobalInfo
,
bindFun
,
rebindFun
,
bindLabel
>
(
ValueEnv
,
ValueInfo
(
..
)
>
,
bindGlobalInfo
,
bindFun
,
qualBindFun
,
rebindFun
,
unbindFun
,
bindLabel
>
,
lookupValue
,
qualLookupValue
,
qualLookupCons
,
lookupTuple
,
tupleDCs
>
,
lookupValue
,
qualLookupValue
,
qualLookupCons
,
lookupTuple
,
tupleDCs
>
,
initDCEnv
,
ppTypes
)
where
>
,
initDCEnv
,
ppTypes
)
where
...
@@ -80,6 +81,11 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}.
...
@@ -80,6 +81,11 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}.
>
v
=
Value
qf
a
ty
>
v
=
Value
qf
a
ty
>
fun
=
"Base.bindFun"
>
fun
=
"Base.bindFun"
>
qualBindFun
::
ModuleIdent
->
Ident
->
Int
->
TypeScheme
->
ValueEnv
->
ValueEnv
>
qualBindFun
m
f
a
ty
=
qualBindTopEnv
"Base.qualBindFun"
qf
$
>
Value
qf
a
ty
>
where
qf
=
qualifyWith
m
f
>
rebindFun
::
ModuleIdent
->
Ident
->
Int
->
TypeScheme
->
ValueEnv
>
rebindFun
::
ModuleIdent
->
Ident
->
Int
->
TypeScheme
->
ValueEnv
>
->
ValueEnv
>
->
ValueEnv
>
rebindFun
m
f
a
ty
>
rebindFun
m
f
a
ty
...
@@ -88,6 +94,9 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}.
...
@@ -88,6 +94,9 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}.
>
where
qf
=
qualifyWith
m
f
>
where
qf
=
qualifyWith
m
f
>
v
=
Value
qf
a
ty
>
v
=
Value
qf
a
ty
>
unbindFun
::
Ident
->
ValueEnv
->
ValueEnv
>
unbindFun
=
unbindTopEnv
>
bindLabel
::
Ident
->
QualIdent
->
TypeScheme
->
ValueEnv
->
ValueEnv
>
bindLabel
::
Ident
->
QualIdent
->
TypeScheme
->
ValueEnv
->
ValueEnv
>
bindLabel
l
r
ty
tyEnv
=
bindTopEnv
"Base.bindLabel"
l
v
tyEnv
>
bindLabel
l
r
ty
tyEnv
=
bindTopEnv
"Base.bindLabel"
l
v
tyEnv
>
where
v
=
Label
(
qualify
l
)
r
ty
>
where
v
=
Label
(
qualify
l
)
r
ty
...
...
src/Generators/GenFlatCurry.hs
View file @
35aa03e8
...
@@ -249,25 +249,27 @@ visitFuncDecl (IL.FunctionDecl qident params typeexpr expression) = do
...
@@ -249,25 +249,27 @@ visitFuncDecl (IL.FunctionDecl qident params typeexpr expression) = do
let
argtypes
=
splitoffArgTypes
typeexpr
params
let
argtypes
=
splitoffArgTypes
typeexpr
params
setFunctionId
(
qident
,
argtypes
)
setFunctionId
(
qident
,
argtypes
)
qname
<-
visitQualIdent
qident
qname
<-
visitQualIdent
qident
arity
<-
fromMaybe
(
length
params
)
`
liftM
`
lookupIdArity
qident
whenFlatCurry
whenFlatCurry
(
do
is
<-
mapM
newVarIndex
params
(
do
is
<-
mapM
newVarIndex
params
texpr
<-
visitType
typeexpr
texpr
<-
visitType
typeexpr
expr
<-
visitExpression
expression
expr
<-
visitExpression
expression
vis
<-
getVisibility
False
qident
vis
<-
getVisibility
False
qident
clearVarIndices
clearVarIndices
return
(
Func
qname
(
length
params
)
vis
texpr
(
Rule
is
expr
))
return
(
Func
qname
arity
vis
texpr
(
Rule
is
expr
))
)
)
(
do
texpr
<-
visitType
typeexpr
(
do
texpr
<-
visitType
typeexpr
clearVarIndices
clearVarIndices
return
(
Func
qname
(
length
params
)
Public
texpr
(
Rule
[]
(
Var
$
mkIdx
0
)))
return
(
Func
qname
arity
Public
texpr
(
Rule
[]
(
Var
$
mkIdx
0
)))
)
)
visitFuncDecl
(
IL
.
ExternalDecl
qident
_
extname
typeexpr
)
=
do
visitFuncDecl
(
IL
.
ExternalDecl
qident
_
extname
typeexpr
)
=
do
setFunctionId
(
qident
,
[]
)
setFunctionId
(
qident
,
[]
)
texpr
<-
visitType
typeexpr
texpr
<-
visitType
typeexpr
qname
<-
visitQualIdent
qident
qname
<-
visitQualIdent
qident
arity
<-
fromMaybe
(
typeArity
typeexpr
)
`
liftM
`
lookupIdArity
qident
vis
<-
getVisibility
False
qident
vis
<-
getVisibility
False
qident
xname
<-
visitExternalName
extname
xname
<-
visitExternalName
extname
return
$
Func
qname
(
typeArity
typeexpr
)
vis
texpr
(
External
xname
)
return
$
Func
qname
arity
vis
texpr
(
External
xname
)
visitFuncDecl
(
IL
.
NewtypeDecl
_
_
_
)
=
do
visitFuncDecl
(
IL
.
NewtypeDecl
_
_
_
)
=
do
mid
<-
moduleId
mid
<-
moduleId
internalError
$
"
\"
"
++
Id
.
moduleName
mid
internalError
$
"
\"
"
++
Id
.
moduleName
mid
...
...
src/Transformations/Lift.lhs
View file @
35aa03e8
...
@@ -30,7 +30,6 @@ lifted to the top-level.
...
@@ -30,7 +30,6 @@ lifted to the top-level.
>
import
Base.Expr
>
import
Base.Expr
>
import
Base.Messages
(
internalError
)
>
import
Base.Messages
(
internalError
)
>
import
Base.SCC
>
import
Base.SCC
>
import
Base.TopEnv
>
import
Base.Types
>
import
Base.Types
>
import
Env.Eval
(
EvalEnv
)
>
import
Env.Eval
(
EvalEnv
)
...
@@ -195,15 +194,17 @@ in the type environment.
...
@@ -195,15 +194,17 @@ in the type environment.
>
where
tys
=
map
(
varType
tyEnv
)
fvs
>
where
tys
=
map
(
varType
tyEnv
)
fvs
>
abstractFunType
f
tyEnv'
=
>
abstractFunType
f
tyEnv'
=
>
qualBindFun
m
(
liftIdent
pre
f
)
>
qualBindFun
m
(
liftIdent
pre
f
)
>
(
foldr
TypeArrow
(
varType
tyEnv'
f
)
tys
)
>
(
length
fvs
+
varArity
tyEnv'
f
)
-- (arrowArity ty)
>
(
polyType
ty
)
>
(
unbindFun
f
tyEnv'
)
>
(
unbindFun
f
tyEnv'
)
>
where
ty
=
foldr
TypeArrow
(
varType
tyEnv'
f
)
tys
>
abstractFunAnnots
::
ModuleIdent
->
String
->
[
Ident
]
->
EvalEnv
->
EvalEnv
>
abstractFunAnnots
::
ModuleIdent
->
String
->
[
Ident
]
->
EvalEnv
->
EvalEnv
>
abstractFunAnnots
_
pre
fs
evEnv
=
foldr
abstractFunAnnot
evEnv
fs
>
abstractFunAnnots
_
pre
fs
evEnv
=
foldr
abstractFunAnnot
evEnv
fs
>
where
abstractFunAnnot
f
evEnv'
=
>
where
>
case
Map
.
lookup
f
evEnv'
of
>
abstractFunAnnot
f
evEnv'
=
case
Map
.
lookup
f
evEnv'
of
>
Just
ev
->
Map
.
insert
(
liftIdent
pre
f
)
ev
(
Map
.
delete
f
evEnv'
)
>
Just
ev
->
Map
.
insert
(
liftIdent
pre
f
)
ev
(
Map
.
delete
f
evEnv'
)
>
Nothing
->
evEnv'
>
Nothing
->
evEnv'
>
abstractFunDecl
::
String
->
[
Ident
]
->
[
Ident
]
>
abstractFunDecl
::
String
->
[
Ident
]
->
[
Ident
]
>
->
AbstractEnv
->
Decl
->
LiftM
Decl
>
->
AbstractEnv
->
Decl
->
LiftM
Decl
...
@@ -305,18 +306,15 @@ to the top-level.
...
@@ -305,18 +306,15 @@ to the top-level.
>
apply
::
Expression
->
[
Expression
]
->
Expression
>
apply
::
Expression
->
[
Expression
]
->
Expression
>
apply
=
foldl
Apply
>
apply
=
foldl
Apply
>
qualBindFun
::
ModuleIdent
->
Ident
->
Type
->
ValueEnv
->
ValueEnv
>
varArity
::
ValueEnv
->
Ident
->
Int
>
qualBindFun
m
f
ty
=
qualBindTopEnv
"Lift.qualBindFun"
qf
$
>
varArity
tyEnv
v
=
case
lookupValue
v
tyEnv
of
>
Value
qf
(
arrowArity
ty
)
(
polyType
ty
)
>
[
Value
_
a
_
]
->
a
>
where
qf
=
qualifyWith
m
f
>
_
->
internalError
$
"Lift.varArity: "
++
show
v
>
unbindFun
::
Ident
->
ValueEnv
->
ValueEnv
>
unbindFun
=
unbindTopEnv
>
varType
::
ValueEnv
->
Ident
->
Type
>
varType
::
ValueEnv
->
Ident
->
Type
>
varType
tyEnv
v
=
case
lookupValue
v
tyEnv
of
>
varType
tyEnv
v
=
case
lookupValue
v
tyEnv
of
>
[
Value
_
_
(
ForAll
_
ty
)]
->
ty
>
[
Value
_
_
(
ForAll
_
ty
)]
->
ty
>
_
->
internalError
$
"Lift.varType "
++
show
v
>
_
->
internalError
$
"Lift.varType
:
"
++
show
v
>
liftIdent
::
String
->
Ident
->
Ident
>
liftIdent
::
String
->
Ident
->
Ident
>
liftIdent
prefix
x
=
renameIdent
(
mkIdent
$
prefix
++
show
x
)
$
uniqueId
x
>
liftIdent
prefix
x
=
renameIdent
(
mkIdent
$
prefix
++
show
x
)
$
uniqueId
x
...
...
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