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
369538e8
Commit
369538e8
authored
Sep 25, 2012
by
Björn Peemöller
Browse files
Adopted the latest changes in the Curry AST
parent
adda624b
Changes
14
Hide whitespace changes
Inline
Side-by-side
src/Base/Expr.hs
View file @
369538e8
...
...
@@ -62,13 +62,13 @@ instance QualExpr Decl where
qfv
_
_
=
[]
instance
QuantExpr
Decl
where
bv
(
TypeSig
_
vs
_
)
=
vs
bv
(
FunctionDecl
_
f
_
)
=
[
f
]
bv
(
External
Decl
_
_
_
f
_
)
=
[
f
]
bv
(
Flat
ExternalDecl
_
fs
)
=
fs
bv
(
PatternDecl
_
t
_
)
=
bv
t
bv
(
ExtraVariables
_
vs
)
=
vs
bv
_
=
[]
bv
(
TypeSig
_
vs
_
)
=
vs
bv
(
FunctionDecl
_
f
_
)
=
[
f
]
bv
(
Foreign
Decl
_
_
_
f
_
)
=
[
f
]
bv
(
ExternalDecl
_
fs
)
=
fs
bv
(
PatternDecl
_
t
_
)
=
bv
t
bv
(
FreeDecl
_
vs
)
=
vs
bv
_
=
[]
instance
QualExpr
Equation
where
qfv
m
(
Equation
_
lhs
rhs
)
=
filterBv
lhs
$
qfv
m
lhs
++
qfv
m
rhs
...
...
@@ -139,7 +139,7 @@ instance QualExpr InfixOp where
qfv
m
(
InfixOp
op
)
=
qfv
m
$
Variable
op
qfv
_
(
InfixConstr
_
)
=
[]
instance
QuantExpr
ConstrT
er
m
where
instance
QuantExpr
Patt
er
n
where
bv
(
LiteralPattern
_
)
=
[]
bv
(
NegativePattern
_
_
)
=
[]
bv
(
VariablePattern
v
)
=
[
v
]
...
...
@@ -154,7 +154,7 @@ instance QuantExpr ConstrTerm where
bv
(
InfixFuncPattern
t1
op
t2
)
=
bvFuncPatt
$
InfixFuncPattern
t1
op
t2
bv
(
RecordPattern
fs
r
)
=
maybe
[]
bv
r
++
bv
fs
instance
QualExpr
ConstrT
er
m
where
instance
QualExpr
Patt
er
n
where
qfv
_
(
LiteralPattern
_
)
=
[]
qfv
_
(
NegativePattern
_
_
)
=
[]
qfv
_
(
VariablePattern
_
)
=
[]
...
...
@@ -189,7 +189,7 @@ filterBv e = filter (`Set.notMember` Set.fromList (bv e))
-- Each variable occuring in the function pattern will be unique in the result
-- list.
bvFuncPatt
::
ConstrT
er
m
->
[
Ident
]
bvFuncPatt
::
Patt
er
n
->
[
Ident
]
bvFuncPatt
=
bvfp
[]
where
bvfp
bvs
(
LiteralPattern
_
)
=
bvs
...
...
src/Base/Typing.lhs
View file @
369538e8
...
...
@@ -99,7 +99,7 @@ environment.}
>
instance
Typeable
Ident
where
>
typeOf
=
computeType
identType
>
instance
Typeable
ConstrT
er
m
where
>
instance
Typeable
Patt
er
n
where
>
typeOf
=
computeType
argType
>
instance
Typeable
Expression
where
...
...
@@ -135,7 +135,7 @@ environment.}
>
litType
_
(
Float
_
_
)
=
return
floatType
>
litType
_
(
String
_
_
)
=
return
stringType
>
argType
::
ValueEnv
->
ConstrT
er
m
->
TyState
Type
>
argType
::
ValueEnv
->
Patt
er
n
->
TyState
Type
>
argType
tyEnv
(
LiteralPattern
l
)
=
litType
tyEnv
l
>
argType
tyEnv
(
NegativePattern
_
l
)
=
litType
tyEnv
l
>
argType
tyEnv
(
VariablePattern
v
)
=
identType
tyEnv
v
...
...
@@ -182,7 +182,7 @@ environment.}
>
tys
<-
mapM
(
fieldPattType
tyEnv
)
fs
>
return
(
TypeRecord
tys
Nothing
)
>
fieldPattType
::
ValueEnv
->
Field
ConstrT
er
m
->
TyState
(
Ident
,
Type
)
>
fieldPattType
::
ValueEnv
->
Field
Patt
er
n
->
TyState
(
Ident
,
Type
)
>
fieldPattType
tyEnv
(
Field
_
l
t
)
=
>
do
>
lty
<-
instUniv
(
labelType
l
tyEnv
)
...
...
src/Checks/KindCheck.lhs
View file @
369538e8
...
...
@@ -113,27 +113,27 @@ traversed because they can contain local type signatures.
\begin{verbatim}
>
checkDecl
::
Decl
->
KCM
Decl
>
checkDecl
(
DataDecl
p
tc
tvs
cs
)
=
do
>
checkDecl
(
DataDecl
p
tc
tvs
cs
)
=
do
>
tvs'
<-
checkTypeLhs
tvs
>
cs'
<-
mapM
(
checkConstrDecl
tvs'
)
cs
>
return
$
DataDecl
p
tc
tvs'
cs'
>
checkDecl
(
NewtypeDecl
p
tc
tvs
nc
)
=
do
>
checkDecl
(
NewtypeDecl
p
tc
tvs
nc
)
=
do
>
tvs'
<-
checkTypeLhs
tvs
>
nc'
<-
checkNewConstrDecl
tvs'
nc
>
return
$
NewtypeDecl
p
tc
tvs'
nc'
>
checkDecl
(
TypeDecl
p
tc
tvs
ty
)
=
do
>
checkDecl
(
TypeDecl
p
tc
tvs
ty
)
=
do
>
tvs'
<-
checkTypeLhs
tvs
>
ty'
<-
checkClosedType
tvs'
ty
>
return
$
TypeDecl
p
tc
tvs'
ty'
>
checkDecl
(
TypeSig
p
vs
ty
)
=
>
checkDecl
(
TypeSig
p
vs
ty
)
=
>
TypeSig
p
vs
`
liftM
`
checkType
ty
>
checkDecl
(
FunctionDecl
p
f
eqs
)
=
>
checkDecl
(
FunctionDecl
p
f
eqs
)
=
>
FunctionDecl
p
f
`
liftM
`
mapM
checkEquation
eqs
>
checkDecl
(
PatternDecl
p
t
rhs
)
=
>
checkDecl
(
PatternDecl
p
t
rhs
)
=
>
PatternDecl
p
t
`
liftM
`
checkRhs
rhs
>
checkDecl
(
External
Decl
p
cc
ie
f
ty
)
=
>
External
Decl
p
cc
ie
f
`
liftM
`
checkType
ty
>
checkDecl
d
=
return
d
>
checkDecl
(
Foreign
Decl
p
cc
ie
f
ty
)
=
>
Foreign
Decl
p
cc
ie
f
`
liftM
`
checkType
ty
>
checkDecl
d
=
return
d
>
checkConstrDecl
::
[
Ident
]
->
ConstrDecl
->
KCM
ConstrDecl
>
checkConstrDecl
tvs
(
ConstrDecl
p
evs
c
tys
)
=
do
...
...
src/Checks/PrecCheck.lhs
View file @
369538e8
...
...
@@ -107,10 +107,10 @@ imported precedence environment.
>
constr
(
ConOpDecl
_
_
_
op
_
)
=
op
>
boundValues
(
NewtypeDecl
_
_
_
(
NewConstrDecl
_
_
c
_
))
=
[
c
]
>
boundValues
(
FunctionDecl
_
f
_
)
=
[
f
]
>
boundValues
(
External
Decl
_
_
_
f
_
)
=
[
f
]
>
boundValues
(
Flat
ExternalDecl
_
fs
)
=
fs
>
boundValues
(
Foreign
Decl
_
_
_
f
_
)
=
[
f
]
>
boundValues
(
ExternalDecl
_
fs
)
=
fs
>
boundValues
(
PatternDecl
_
t
_
)
=
bv
t
>
boundValues
(
ExtraVariables
_
vs
)
=
vs
>
boundValues
(
FreeDecl
_
vs
)
=
vs
>
boundValues
_
=
[]
\end{verbatim}
...
...
@@ -131,7 +131,7 @@ interface.
>
checkDecl
(
FunctionDecl
p
f
eqs
)
=
>
FunctionDecl
p
f
`
liftM
`
mapM
checkEquation
eqs
>
checkDecl
(
PatternDecl
p
t
rhs
)
=
>
liftM2
(
PatternDecl
p
)
(
check
ConstrT
er
m
t
)
(
checkRhs
rhs
)
>
liftM2
(
PatternDecl
p
)
(
check
Patt
er
n
t
)
(
checkRhs
rhs
)
>
checkDecl
d
=
return
d
>
checkEquation
::
Equation
->
PCM
Equation
...
...
@@ -139,47 +139,47 @@ interface.
>
liftM2
(
Equation
p
)
(
checkLhs
lhs
)
(
checkRhs
rhs
)
>
checkLhs
::
Lhs
->
PCM
Lhs
>
checkLhs
(
FunLhs
f
ts
)
=
FunLhs
f
`
liftM
`
mapM
check
ConstrT
er
m
ts
>
checkLhs
(
FunLhs
f
ts
)
=
FunLhs
f
`
liftM
`
mapM
check
Patt
er
n
ts
>
checkLhs
(
OpLhs
t1
op
t2
)
=
>
liftM2
(
flip
OpLhs
op
)
(
check
ConstrT
er
m
t1
>>=
checkOpL
op
)
>
(
check
ConstrT
er
m
t2
>>=
checkOpR
op
)
>
liftM2
(
flip
OpLhs
op
)
(
check
Patt
er
n
t1
>>=
checkOpL
op
)
>
(
check
Patt
er
n
t2
>>=
checkOpR
op
)
>
checkLhs
(
ApLhs
lhs
ts
)
=
>
liftM2
ApLhs
(
checkLhs
lhs
)
(
mapM
check
ConstrT
er
m
ts
)
>
check
ConstrT
er
m
::
ConstrT
er
m
->
PCM
ConstrT
er
m
>
check
ConstrT
er
m
l
@
(
LiteralPattern
_
)
=
return
l
>
check
ConstrT
er
m
n
@
(
NegativePattern
_
_
)
=
return
n
>
check
ConstrT
er
m
v
@
(
VariablePattern
_
)
=
return
v
>
check
ConstrT
er
m
(
ConstructorPattern
c
ts
)
=
>
ConstructorPattern
c
`
liftM
`
mapM
check
ConstrT
er
m
ts
>
check
ConstrT
er
m
(
InfixPattern
t1
op
t2
)
=
do
>
t1'
<-
check
ConstrT
er
m
t1
>
t2'
<-
check
ConstrT
er
m
t2
>
liftM2
ApLhs
(
checkLhs
lhs
)
(
mapM
check
Patt
er
n
ts
)
>
check
Patt
er
n
::
Patt
er
n
->
PCM
Patt
er
n
>
check
Patt
er
n
l
@
(
LiteralPattern
_
)
=
return
l
>
check
Patt
er
n
n
@
(
NegativePattern
_
_
)
=
return
n
>
check
Patt
er
n
v
@
(
VariablePattern
_
)
=
return
v
>
check
Patt
er
n
(
ConstructorPattern
c
ts
)
=
>
ConstructorPattern
c
`
liftM
`
mapM
check
Patt
er
n
ts
>
check
Patt
er
n
(
InfixPattern
t1
op
t2
)
=
do
>
t1'
<-
check
Patt
er
n
t1
>
t2'
<-
check
Patt
er
n
t2
>
fixPrecT
InfixPattern
t1'
op
t2'
>
check
ConstrT
er
m
(
ParenPattern
t
)
=
>
ParenPattern
`
liftM
`
check
ConstrT
er
m
t
>
check
ConstrT
er
m
(
TuplePattern
p
ts
)
=
>
TuplePattern
p
`
liftM
`
mapM
check
ConstrT
er
m
ts
>
check
ConstrT
er
m
(
ListPattern
p
ts
)
=
>
ListPattern
p
`
liftM
`
mapM
check
ConstrT
er
m
ts
>
check
ConstrT
er
m
(
AsPattern
v
t
)
=
>
AsPattern
v
`
liftM
`
check
ConstrT
er
m
t
>
check
ConstrT
er
m
(
LazyPattern
p
t
)
=
>
LazyPattern
p
`
liftM
`
check
ConstrT
er
m
t
>
check
ConstrT
er
m
(
FunctionPattern
f
ts
)
=
>
FunctionPattern
f
`
liftM
`
mapM
check
ConstrT
er
m
ts
>
check
ConstrT
er
m
(
InfixFuncPattern
t1
op
t2
)
=
do
>
t1'
<-
check
ConstrT
er
m
t1
>
t2'
<-
check
ConstrT
er
m
t2
>
check
Patt
er
n
(
ParenPattern
t
)
=
>
ParenPattern
`
liftM
`
check
Patt
er
n
t
>
check
Patt
er
n
(
TuplePattern
p
ts
)
=
>
TuplePattern
p
`
liftM
`
mapM
check
Patt
er
n
ts
>
check
Patt
er
n
(
ListPattern
p
ts
)
=
>
ListPattern
p
`
liftM
`
mapM
check
Patt
er
n
ts
>
check
Patt
er
n
(
AsPattern
v
t
)
=
>
AsPattern
v
`
liftM
`
check
Patt
er
n
t
>
check
Patt
er
n
(
LazyPattern
p
t
)
=
>
LazyPattern
p
`
liftM
`
check
Patt
er
n
t
>
check
Patt
er
n
(
FunctionPattern
f
ts
)
=
>
FunctionPattern
f
`
liftM
`
mapM
check
Patt
er
n
ts
>
check
Patt
er
n
(
InfixFuncPattern
t1
op
t2
)
=
do
>
t1'
<-
check
Patt
er
n
t1
>
t2'
<-
check
Patt
er
n
t2
>
fixPrecT
InfixFuncPattern
t1'
op
t2'
>
check
ConstrT
er
m
(
RecordPattern
fs
r
)
=
>
check
Patt
er
n
(
RecordPattern
fs
r
)
=
>
liftM2
RecordPattern
(
mapM
checkFieldPattern
fs
)
$
>
case
r
of
>
Nothing
->
return
Nothing
>
Just
r'
->
Just
`
fmap
`
check
ConstrT
er
m
r'
>
Just
r'
->
Just
`
fmap
`
check
Patt
er
n
r'
>
checkFieldPattern
::
Field
ConstrT
er
m
->
PCM
(
Field
ConstrT
er
m
)
>
checkFieldPattern
(
Field
p
l
e
)
=
Field
p
l
`
liftM
`
check
ConstrT
er
m
e
>
checkFieldPattern
::
Field
Patt
er
n
->
PCM
(
Field
Patt
er
n
)
>
checkFieldPattern
(
Field
p
l
e
)
=
Field
p
l
`
liftM
`
check
Patt
er
n
e
>
checkRhs
::
Rhs
->
PCM
Rhs
>
checkRhs
(
SimpleRhs
p
e
ds
)
=
withLocalPrecEnv
$
...
...
@@ -218,7 +218,7 @@ interface.
>
checkExpr
(
LeftSection
e
op
)
=
checkExpr
e
>>=
checkLSection
op
>
checkExpr
(
RightSection
op
e
)
=
checkExpr
e
>>=
checkRSection
op
>
checkExpr
(
Lambda
r
ts
e
)
=
>
liftM2
(
Lambda
r
)
(
mapM
check
ConstrT
er
m
ts
)
(
checkExpr
e
)
>
liftM2
(
Lambda
r
)
(
mapM
check
Patt
er
n
ts
)
(
checkExpr
e
)
>
checkExpr
(
Let
ds
e
)
=
withLocalPrecEnv
$
>
liftM2
Let
(
checkDecls
ds
)
(
checkExpr
e
)
>
checkExpr
(
Do
sts
e
)
=
withLocalPrecEnv
$
...
...
@@ -241,10 +241,10 @@ interface.
>
checkStmt
(
StmtExpr
p
e
)
=
StmtExpr
p
`
liftM
`
checkExpr
e
>
checkStmt
(
StmtDecl
ds
)
=
StmtDecl
`
liftM
`
checkDecls
ds
>
checkStmt
(
StmtBind
p
t
e
)
=
>
liftM2
(
StmtBind
p
)
(
check
ConstrT
er
m
t
)
(
checkExpr
e
)
>
liftM2
(
StmtBind
p
)
(
check
Patt
er
n
t
)
(
checkExpr
e
)
>
checkAlt
::
Alt
->
PCM
Alt
>
checkAlt
(
Alt
p
t
rhs
)
=
liftM2
(
Alt
p
)
(
check
ConstrT
er
m
t
)
(
checkRhs
rhs
)
>
checkAlt
(
Alt
p
t
rhs
)
=
liftM2
(
Alt
p
)
(
check
Patt
er
n
t
)
(
checkRhs
rhs
)
\end{verbatim}
The functions \texttt{fixPrec}, \texttt{fixUPrec}, and
...
...
@@ -368,8 +368,8 @@ this case, the negation must bind more tightly than the operator for
the pattern to be accepted.
\begin{verbatim}
>
fixPrecT
::
(
ConstrT
er
m
->
QualIdent
->
ConstrT
er
m
->
ConstrT
er
m
)
>
->
ConstrT
er
m
->
QualIdent
->
ConstrT
er
m
->
PCM
ConstrT
er
m
>
fixPrecT
::
(
Patt
er
n
->
QualIdent
->
Patt
er
n
->
Patt
er
n
)
>
->
Patt
er
n
->
QualIdent
->
Patt
er
n
->
PCM
Patt
er
n
>
fixPrecT
infixpatt
t1
@
(
NegativePattern
uop
_
)
op
t2
=
do
>
OpPrec
fix
pr
<-
prec
op
`
liftM
`
getPrecEnv
>
unless
(
pr
<
6
||
pr
==
6
&&
fix
==
InfixL
)
$
...
...
@@ -377,8 +377,8 @@ the pattern to be accepted.
>
fixRPrecT
infixpatt
t1
op
t2
>
fixPrecT
infixpatt
t1
op
t2
=
fixRPrecT
infixpatt
t1
op
t2
>
fixRPrecT
::
(
ConstrT
er
m
->
QualIdent
->
ConstrT
er
m
->
ConstrT
er
m
)
>
->
ConstrT
er
m
->
QualIdent
->
ConstrT
er
m
->
PCM
ConstrT
er
m
>
fixRPrecT
::
(
Patt
er
n
->
QualIdent
->
Patt
er
n
->
Patt
er
n
)
>
->
Patt
er
n
->
QualIdent
->
Patt
er
n
->
PCM
Patt
er
n
>
fixRPrecT
infixpatt
t1
op
t2
@
(
NegativePattern
uop
_
)
=
do
>
OpPrec
_
pr
<-
prec
op
`
liftM
`
getPrecEnv
>
unless
(
pr
<
6
)
$
report
$
errInvalidParse
"unary"
uop
op
...
...
@@ -409,16 +409,16 @@ the pattern to be accepted.
>
return
$
infixpatt
t1
op1
(
InfixFuncPattern
t2
op2
t3
)
>
fixRPrecT
infixpatt
t1
op
t2
=
return
$
infixpatt
t1
op
t2
>
{-fixPrecT :: Position -> OpPrecEnv ->
ConstrT
er
m
-> QualIdent ->
ConstrT
er
m
>
->
ConstrT
er
m
>
{-fixPrecT :: Position -> OpPrecEnv ->
Patt
er
n
-> QualIdent ->
Patt
er
n
>
->
Patt
er
n
>
fixPrecT p pEnv t1@(NegativePattern uop l) op t2
>
| pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2
>
| otherwise = errorAt p $ errInvalidParse "unary" uop op
>
where OpPrec fix pr = prec op pEnv
>
fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-}
>
{-fixRPrecT :: Position -> OpPrecEnv ->
ConstrT
er
m
-> QualIdent ->
ConstrT
er
m
>
->
ConstrT
er
m
>
{-fixRPrecT :: Position -> OpPrecEnv ->
Patt
er
n
-> QualIdent ->
Patt
er
n
>
->
Patt
er
n
>
fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)
>
| pr < 6 = InfixPattern t1 op t2
>
| otherwise = errorAt p $ errInvalidParse "unary" uop op
...
...
@@ -440,7 +440,7 @@ patterns they must bind more tightly than the operator, otherwise the
left-hand side of the declaration is invalid.
\begin{verbatim}
>
checkOpL
::
Ident
->
ConstrT
er
m
->
PCM
ConstrT
er
m
>
checkOpL
::
Ident
->
Patt
er
n
->
PCM
Patt
er
n
>
checkOpL
op
t
@
(
NegativePattern
uop
_
)
=
do
>
OpPrec
fix
pr
<-
prec
(
qualify
op
)
`
liftM
`
getPrecEnv
>
unless
(
pr
<
6
||
pr
==
6
&&
fix
==
InfixL
)
$
...
...
@@ -454,7 +454,7 @@ left-hand side of the declaration is invalid.
>
return
t
>
checkOpL
_
t
=
return
t
>
checkOpR
::
Ident
->
ConstrT
er
m
->
PCM
ConstrT
er
m
>
checkOpR
::
Ident
->
Patt
er
n
->
PCM
Patt
er
n
>
checkOpR
op
t
@
(
NegativePattern
uop
_
)
=
do
>
OpPrec
_
pr
<-
prec
(
qualify
op
)
`
liftM
`
getPrecEnv
>
when
(
pr
>=
6
)
$
report
$
errInvalidParse
"unary"
uop
(
qualify
op
)
...
...
src/Checks/SyntaxCheck.lhs
View file @
369538e8
...
...
@@ -249,7 +249,7 @@ Furthermore, it is not allowed to declare a label more than once.
>
|
otherwise
=
let
arty
=
length
$
snd
$
getFlatLhs
$
head
equs
>
qid
=
qualifyWith
m
ident
>
in
bindGlobal
m
ident
(
GlobalVar
arty
qid
)
env
>
bindFuncDecl
m
(
External
Decl
_
_
_
ident
texpr
)
env
>
bindFuncDecl
m
(
Foreign
Decl
_
_
_
ident
texpr
)
env
>
=
let
arty
=
typeArity
texpr
>
qid
=
qualifyWith
m
ident
>
in
bindGlobal
m
ident
(
GlobalVar
arty
qid
)
env
...
...
@@ -272,7 +272,7 @@ Furthermore, it is not allowed to declare a label more than once.
>
|
otherwise
=
let
arty
=
length
$
snd
$
getFlatLhs
$
head
equs
>
in
bindLocal
(
unRenameIdent
ident
)
(
LocalVar
arty
ident
)
env
>
bindVarDecl
(
PatternDecl
_
t
_
)
env
=
foldr
bindVar
env
(
bv
t
)
>
bindVarDecl
(
ExtraVariables
_
vs
)
env
=
foldr
bindVar
env
vs
>
bindVarDecl
(
FreeDecl
_
vs
)
env
=
foldr
bindVar
env
vs
>
bindVarDecl
_
env
=
env
>
bindVar
::
Ident
->
RenameEnv
->
RenameEnv
...
...
@@ -357,14 +357,14 @@ top-level.
>
(
\
vs'
->
TypeSig
p
vs'
ty
)
`
liftM
`
mapM
(
checkVar
"type signature"
)
vs
>
checkDeclLhs
(
FunctionDecl
p
_
eqs
)
=
>
checkEquationsLhs
p
eqs
>
checkDeclLhs
(
External
Decl
p
cc
ie
f
ty
)
=
>
(
\
f'
->
External
Decl
p
cc
ie
f'
ty
)
`
liftM
`
checkVar
"
external
declaration"
f
>
checkDeclLhs
(
Flat
ExternalDecl
p
fs
)
=
>
Flat
ExternalDecl
p
`
liftM
`
mapM
(
checkVar
"
flat
external declaration"
)
fs
>
checkDeclLhs
(
Foreign
Decl
p
cc
ie
f
ty
)
=
>
(
\
f'
->
Foreign
Decl
p
cc
ie
f'
ty
)
`
liftM
`
checkVar
"
foreign
declaration"
f
>
checkDeclLhs
(
ExternalDecl
p
fs
)
=
>
ExternalDecl
p
`
liftM
`
mapM
(
checkVar
"external declaration"
)
fs
>
checkDeclLhs
(
PatternDecl
p
t
rhs
)
=
>
(
\
t'
->
PatternDecl
p
t'
rhs
)
`
liftM
`
check
ConstrT
er
m
p
t
>
checkDeclLhs
(
ExtraVariables
p
vs
)
=
>
ExtraVariables
p
`
liftM
`
mapM
(
checkVar
"free variables declaration"
)
vs
>
(
\
t'
->
PatternDecl
p
t'
rhs
)
`
liftM
`
check
Patt
er
n
p
t
>
checkDeclLhs
(
FreeDecl
p
vs
)
=
>
FreeDecl
p
`
liftM
`
mapM
(
checkVar
"free variables declaration"
)
vs
>
checkDeclLhs
d
=
return
d
>
checkVar
::
String
->
Ident
->
SCM
Ident
...
...
@@ -389,7 +389,7 @@ top-level.
>
return
$
PatternDecl
p'
t
rhs
>
checkEquationsLhs
_
_
=
internalError
"SyntaxCheck.checkEquationsLhs"
>
checkEqLhs
::
Position
->
Lhs
->
SCM
(
Either
(
Ident
,
Lhs
)
ConstrT
er
m
)
>
checkEqLhs
::
Position
->
Lhs
->
SCM
(
Either
(
Ident
,
Lhs
)
Patt
er
n
)
>
checkEqLhs
p
toplhs
=
do
>
m
<-
getModuleIdent
>
k
<-
getScopeId
...
...
@@ -426,8 +426,8 @@ top-level.
>
return
$
r
>
where
(
f
,
_
)
=
flatLhs
lhs
>
checkOpLhs
::
Integer
->
RenameEnv
->
(
ConstrT
er
m
->
ConstrT
er
m
)
>
->
ConstrT
er
m
->
Either
(
Ident
,
Lhs
)
ConstrT
er
m
>
checkOpLhs
::
Integer
->
RenameEnv
->
(
Patt
er
n
->
Patt
er
n
)
>
->
Patt
er
n
->
Either
(
Ident
,
Lhs
)
Patt
er
n
>
checkOpLhs
k
env
f
(
InfixPattern
t1
op
t2
)
>
|
isJust
m
||
isDataConstr
op'
env
>
=
checkOpLhs
k
env
(
f
.
InfixPattern
t1
op
)
t2
...
...
@@ -453,7 +453,7 @@ top-level.
>
let
dbls
@
[
dblVar
,
dblTys
]
=
map
findDouble
[
bvs
,
tys
]
>
onJust
(
report
.
errDuplicateDefinition
)
dblVar
>
onJust
(
report
.
errDuplicateTypeSig
)
dblTys
>
let
missingTy
=
[
f
|
Flat
ExternalDecl
_
fs'
<-
ds
,
f
<-
fs'
,
f
`
notElem
`
tys
]
>
let
missingTy
=
[
f
|
ExternalDecl
_
fs'
<-
ds
,
f
<-
fs'
,
f
`
notElem
`
tys
]
>
mapM_
(
report
.
errNoTypeSig
)
missingTy
>
if
all
isNothing
dbls
&&
null
missingTy
>
then
do
...
...
@@ -489,80 +489,80 @@ top-level.
>
return
$
Equation
p
lhs'
rhs'
>
checkLhs
::
Position
->
Lhs
->
SCM
Lhs
>
checkLhs
p
(
FunLhs
f
ts
)
=
FunLhs
f
`
liftM
`
mapM
(
check
ConstrT
er
m
p
)
ts
>
checkLhs
p
(
FunLhs
f
ts
)
=
FunLhs
f
`
liftM
`
mapM
(
check
Patt
er
n
p
)
ts
>
checkLhs
p
(
OpLhs
t1
op
t2
)
=
do
>
let
wrongCalls
=
concatMap
(
checkParen
ConstrT
er
m
(
Just
$
qualify
op
))
[
t1
,
t2
]
>
let
wrongCalls
=
concatMap
(
checkParen
Patt
er
n
(
Just
$
qualify
op
))
[
t1
,
t2
]
>
unless
(
null
wrongCalls
)
$
report
$
errInfixWithoutParens
>
(
idPosition
op
)
wrongCalls
>
liftM2
(
flip
OpLhs
op
)
(
check
ConstrT
er
m
p
t1
)
(
check
ConstrT
er
m
p
t2
)
>
liftM2
(
flip
OpLhs
op
)
(
check
Patt
er
n
p
t1
)
(
check
Patt
er
n
p
t2
)
>
checkLhs
p
(
ApLhs
lhs
ts
)
=
>
liftM2
ApLhs
(
checkLhs
p
lhs
)
(
mapM
(
check
ConstrT
er
m
p
)
ts
)
>
liftM2
ApLhs
(
checkLhs
p
lhs
)
(
mapM
(
check
Patt
er
n
p
)
ts
)
checkParen
@param Aufrufende InfixFunktion
@param
ConstrT
er
m
@param
Patt
er
n
@return Liste mit fehlerhaften Funktionsaufrufen
\begin{verbatim}
>
checkParen
ConstrT
er
m
::
(
Maybe
QualIdent
)
->
ConstrT
er
m
->
[(
QualIdent
,
QualIdent
)]
>
checkParen
ConstrT
er
m
_
(
LiteralPattern
_
)
=
[]
>
checkParen
ConstrT
er
m
_
(
NegativePattern
_
_
)
=
[]
>
checkParen
ConstrT
er
m
_
(
VariablePattern
_
)
=
[]
>
checkParen
ConstrT
er
m
_
(
ConstructorPattern
_
cs
)
=
>
concatMap
(
checkParen
ConstrT
er
m
Nothing
)
cs
>
checkParen
ConstrT
er
m
o
(
InfixPattern
t1
op
t2
)
=
>
checkParen
Patt
er
n
::
(
Maybe
QualIdent
)
->
Patt
er
n
->
[(
QualIdent
,
QualIdent
)]
>
checkParen
Patt
er
n
_
(
LiteralPattern
_
)
=
[]
>
checkParen
Patt
er
n
_
(
NegativePattern
_
_
)
=
[]
>
checkParen
Patt
er
n
_
(
VariablePattern
_
)
=
[]
>
checkParen
Patt
er
n
_
(
ConstructorPattern
_
cs
)
=
>
concatMap
(
checkParen
Patt
er
n
Nothing
)
cs
>
checkParen
Patt
er
n
o
(
InfixPattern
t1
op
t2
)
=
>
maybe
[]
(
\
c
->
[(
c
,
op
)])
o
>
++
checkParen
ConstrT
er
m
Nothing
t1
++
checkParen
ConstrT
er
m
Nothing
t2
>
checkParen
ConstrT
er
m
_
(
ParenPattern
t
)
=
>
checkParen
ConstrT
er
m
Nothing
t
>
checkParen
ConstrT
er
m
_
(
TuplePattern
_
ts
)
=
>
concatMap
(
checkParen
ConstrT
er
m
Nothing
)
ts
>
checkParen
ConstrT
er
m
_
(
ListPattern
_
ts
)
=
>
concatMap
(
checkParen
ConstrT
er
m
Nothing
)
ts
>
checkParen
ConstrT
er
m
o
(
AsPattern
_
t
)
=
>
checkParen
ConstrT
er
m
o
t
>
checkParen
ConstrT
er
m
o
(
LazyPattern
_
t
)
=
>
checkParen
ConstrT
er
m
o
t
>
checkParen
ConstrT
er
m
_
(
FunctionPattern
_
ts
)
=
>
concatMap
(
checkParen
ConstrT
er
m
Nothing
)
ts
>
checkParen
ConstrT
er
m
o
(
InfixFuncPattern
t1
op
t2
)
=
>
++
checkParen
Patt
er
n
Nothing
t1
++
checkParen
Patt
er
n
Nothing
t2
>
checkParen
Patt
er
n
_
(
ParenPattern
t
)
=
>
checkParen
Patt
er
n
Nothing
t
>
checkParen
Patt
er
n
_
(
TuplePattern
_
ts
)
=
>
concatMap
(
checkParen
Patt
er
n
Nothing
)
ts
>
checkParen
Patt
er
n
_
(
ListPattern
_
ts
)
=
>
concatMap
(
checkParen
Patt
er
n
Nothing
)
ts
>
checkParen
Patt
er
n
o
(
AsPattern
_
t
)
=
>
checkParen
Patt
er
n
o
t
>
checkParen
Patt
er
n
o
(
LazyPattern
_
t
)
=
>
checkParen
Patt
er
n
o
t
>
checkParen
Patt
er
n
_
(
FunctionPattern
_
ts
)
=
>
concatMap
(
checkParen
Patt
er
n
Nothing
)
ts
>
checkParen
Patt
er
n
o
(
InfixFuncPattern
t1
op
t2
)
=
>
maybe
[]
(
\
c
->
[(
c
,
op
)])
o
>
++
checkParen
ConstrT
er
m
Nothing
t1
++
checkParen
ConstrT
er
m
Nothing
t2
>
checkParen
ConstrT
er
m
_
(
RecordPattern
fs
t
)
=
>
maybe
[]
(
checkParen
ConstrT
er
m
Nothing
)
t
>
++
concatMap
(
\
(
Field
_
_
t'
)
->
checkParen
ConstrT
er
m
Nothing
t'
)
fs
>
++
checkParen
Patt
er
n
Nothing
t1
++
checkParen
Patt
er
n
Nothing
t2
>
checkParen
Patt
er
n
_
(
RecordPattern
fs
t
)
=
>
maybe
[]
(
checkParen
Patt
er
n
Nothing
)
t
>
++
concatMap
(
\
(
Field
_
_
t'
)
->
checkParen
Patt
er
n
Nothing
t'
)
fs
>
check
ConstrT
er
m
::
Position
->
ConstrT
er
m
->
SCM
ConstrT
er
m
>
check
ConstrT
er
m
_
(
LiteralPattern
l
)
=
>
check
Patt
er
n
::
Position
->
Patt
er
n
->
SCM
Patt
er
n
>
check
Patt
er
n
_
(
LiteralPattern
l
)
=
>
LiteralPattern
`
liftM
`
renameLiteral
l
>
check
ConstrT
er
m
_
(
NegativePattern
op
l
)
=
>
check
Patt
er
n
_
(
NegativePattern
op
l
)
=
>
NegativePattern
op
`
liftM
`
renameLiteral
l
>
check
ConstrT
er
m
p
(
VariablePattern
v
)
>
check
Patt
er
n
p
(
VariablePattern
v
)
>
|
isAnonId
v
=
(
VariablePattern
.
renameIdent
v
)
`
liftM
`
newId
>
|
otherwise
=
checkConstructorPattern
p
(
qualify
v
)
[]
>
check
ConstrT
er
m
p
(
ConstructorPattern
c
ts
)
=
>
check
Patt
er
n
p
(
ConstructorPattern
c
ts
)
=
>
checkConstructorPattern
p
c
ts
>
check
ConstrT
er
m
p
(
InfixPattern
t1
op
t2
)
=
>
check
Patt
er
n
p
(
InfixPattern
t1
op
t2
)
=
>
checkInfixPattern
p
t1
op
t2
>
check
ConstrT
er
m
p
(
ParenPattern
t
)
=
>
ParenPattern
`
liftM
`
check
ConstrT
er
m
p
t
>
check
ConstrT
er
m
p
(
TuplePattern
pos
ts
)
=
>
TuplePattern
pos
`
liftM
`
mapM
(
check
ConstrT
er
m
p
)
ts
>
check
ConstrT
er
m
p
(
ListPattern
pos
ts
)
=
>
ListPattern
pos
`
liftM
`
mapM
(
check
ConstrT
er
m
p
)
ts
>
check
ConstrT
er
m
p
(
AsPattern
v
t
)
=
do
>
liftM2
AsPattern
(
checkVar
"@ pattern"
v
)
(
check
ConstrT
er
m
p
t
)
>
check
ConstrT
er
m
p
(
LazyPattern
pos
t
)
=
>
LazyPattern
pos
`
liftM
`
check
ConstrT
er
m
p
t
>
check
ConstrT
er
m
p
(
RecordPattern
fs
t
)
=
>
check
Patt
er
n
p
(
ParenPattern
t
)
=
>
ParenPattern
`
liftM
`
check
Patt
er
n
p
t
>
check
Patt
er
n
p
(
TuplePattern
pos
ts
)
=
>
TuplePattern
pos
`
liftM
`
mapM
(
check
Patt
er
n
p
)
ts
>
check
Patt
er
n
p
(
ListPattern
pos
ts
)
=
>
ListPattern
pos
`
liftM
`
mapM
(
check
Patt
er
n
p
)
ts
>
check
Patt
er
n
p
(
AsPattern
v
t
)
=
do
>
liftM2
AsPattern
(
checkVar
"@ pattern"
v
)
(
check
Patt
er
n
p
t
)
>
check
Patt
er
n
p
(
LazyPattern
pos
t
)
=
>
LazyPattern
pos
`
liftM
`
check
Patt
er
n
p
t
>
check
Patt
er
n
p
(
RecordPattern
fs
t
)
=
>
checkRecordPattern
p
fs
t
>
check
ConstrT
er
m
_
(
FunctionPattern
_
_
)
=
internalError
$
>
"SyntaxCheck.check
ConstrT
er
m
: function pattern not defined"
>
check
ConstrT
er
m
_
(
InfixFuncPattern
_
_
_
)
=
internalError
$
>
"SyntaxCheck.check
ConstrT
er
m
: infix function pattern not defined"
>
check
Patt
er
n
_
(
FunctionPattern
_
_
)
=
internalError
$
>
"SyntaxCheck.check
Patt
er
n
: function pattern not defined"
>
check
Patt
er
n
_
(
InfixFuncPattern
_
_
_
)
=
internalError
$
>
"SyntaxCheck.check
Patt
er
n
: infix function pattern not defined"
>
checkConstructorPattern
::
Position
->
QualIdent
->
[
ConstrT
er
m
]
>
->
SCM
ConstrT
er
m
>
checkConstructorPattern
::
Position
->
QualIdent
->
[
Patt
er
n
]
>
->
SCM
Patt
er
n
>
checkConstructorPattern
p
c
ts
=
do
>
env
<-
getRenameEnv
>
m
<-
getModuleIdent
...
...
@@ -585,22 +585,22 @@ checkParen
>
n'
=
length
ts
>
processCons
qc
n
=
do
>
when
(
n
/=
n'
)
$
report
$
errWrongArity
c
n
n'
>
ConstructorPattern
qc
`
liftM
`
mapM
(
check
ConstrT
er
m
p
)
ts
>
ConstructorPattern
qc
`
liftM
`
mapM
(
check
Patt
er
n
p
)
ts
>
processVarFun
r
k
=
do
>
let
n
=
arity
r
>
if
null
ts
&&
not
(
isQualified
c
)
>
then
return
$
VariablePattern
$
renameIdent
(
varIdent
r
)
k
>
else
do
>
checkFuncPatsExtension
p
>
ts'
<-
mapM
(
check
ConstrT
er
m
p
)
ts
>
ts'
<-
mapM
(
check
Patt
er
n
p
)
ts
>
if
n'
>
n
>
then
let
(
ts1
,
ts2
)
=
splitAt
n
ts'
>
in
return
$
genFuncPattAppl
>
(
FunctionPattern
(
qualVarIdent
r
)
ts1
)
ts2
>
else
return
$
FunctionPattern
(
qualVarIdent
r
)
ts'
>
checkInfixPattern
::
Position
->
ConstrT
er
m
->
QualIdent
->
ConstrT
er
m
>
->
SCM
ConstrT
er
m
>
checkInfixPattern
::
Position
->
Patt
er
n
->
QualIdent
->
Patt
er
n
>
->
SCM
Patt
er
n
>
checkInfixPattern
p
t1
op
t2
=
do
>
m
<-
getModuleIdent
>
env
<-
getRenameEnv
...
...
@@ -617,17 +617,17 @@ checkParen
>
where
>
infixPattern
qop
n
=
do
>
when
(
n
/=
2
)
$
report
$
errWrongArity
op
n
2
>
liftM2
(
flip
InfixPattern
qop
)
(
check
ConstrT
er
m
p
t1
)
>
(
check
ConstrT
er
m
p
t2
)
>
liftM2
(
flip
InfixPattern
qop
)
(
check
Patt
er
n
p
t1
)
>
(
check
Patt
er
n
p
t2
)
>
funcPattern
qop
=
do
>
checkFuncPatsExtension
p
>
liftM2
(
flip
InfixFuncPattern
qop
)
(
check
ConstrT
er
m
p
t1
)
>
(
check
ConstrT
er
m
p
t2
)
>
liftM2
(
flip
InfixFuncPattern
qop
)
(
check
Patt
er
n
p
t1
)
>
(
check
Patt
er
n
p
t2
)
>
checkRecordPattern
::
Position
->
[
Field
ConstrT
er
m
]
>
->
(
Maybe
ConstrT
er
m
)
->
SCM
ConstrT
er
m
>
checkRecordPattern
::
Position
->
[
Field
Patt
er
n
]
>
->
(
Maybe
Patt
er
n
)
->
SCM
Patt
er
n
>
checkRecordPattern
p
fs
t
=
do
>
checkRecordExtension
p
>
case
fs
of
...
...
@@ -647,7 +647,7 @@ checkParen
>
else
if
t
==
Just
(
VariablePattern
anonId
)
>
then
liftM2
RecordPattern
>
(
mapM
(
checkFieldPatt
r
)
fs
)
>
(
Just
`
liftM
`
check
ConstrT
er
m
p
(
fromJust
t
))
>
(
Just
`
liftM
`
check
Patt
er
n
p
(
fromJust
t
))
>
else
do
report
(
errIllegalRecordPattern
p
)
>
return
$
RecordPattern
fs
t
>
where
ls'
=
map
fieldLabel
fs
...
...
@@ -657,7 +657,7 @@ checkParen
>
[
_
]
->
report
(
errNotALabel
l
)
>>
return
(
RecordPattern
fs
t
)
>
_
->
report
(
errDuplicateDefinition
l
)
>>
return
(
RecordPattern
fs
t
)
>
checkFieldPatt
::
QualIdent
->
Field
ConstrT
er
m
->
SCM
(
Field
ConstrT
er
m
)
>
checkFieldPatt
::
QualIdent
->
Field
Patt
er
n
->
SCM
(
Field
Patt
er
n
)
>
checkFieldPatt
r
(
Field
p
l
t
)
=
do
>
env
<-
getRenameEnv
>
case
lookupVar
l
env
of
...
...
@@ -665,7 +665,7 @@ checkParen
>
[]
->
report
$
errUndefinedLabel
l
>
[
_
]
->
report
$
errNotALabel
l
>
_
->
report
$
errDuplicateDefinition
l