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
6081fb44
Commit
6081fb44
authored
Aug 24, 2011
by
Björn Peemöller
Browse files
Internal errors improved, KindCheck improved
parent
84eccf2a
Changes
28
Expand all
Hide whitespace changes
Inline
Side-by-side
src/Base/CurryTypes.lhs
View file @
6081fb44
...
...
@@ -44,7 +44,7 @@ order of type variables in the left hand side of a type declaration.
>
toType'
tvs
(
CS
.
ConstructorType
tc
tys
)
=
>
TypeConstructor
tc
(
map
(
toType'
tvs
)
tys
)
>
toType'
tvs
(
CS
.
VariableType
tv
)
=
>
maybe
(
internalError
$
"toType "
++
show
tv
)
TypeVariable
(
Map
.
lookup
tv
tvs
)
>
maybe
(
internalError
$
"
Base.CurryTypes.
toType
':
"
++
show
tv
)
TypeVariable
(
Map
.
lookup
tv
tvs
)
>
toType'
tvs
(
CS
.
TupleType
tys
)
>
|
null
tys
=
TypeConstructor
(
qualify
unitId
)
[]
>
|
otherwise
=
TypeConstructor
(
qualify
(
tupleId
(
length
tys'
)))
tys'
...
...
@@ -57,7 +57,7 @@ order of type variables in the left hand side of a type declaration.
>
(
maybe
Nothing
>
(
\
ty
->
case
toType'
tvs
ty
of
>
TypeVariable
tv
->
Just
tv
>
_
->
internalError
(
"toType "
++
show
ty
))
>
_
->
internalError
(
"
Base.CurryTypes.
toType
'
"
++
show
ty
))
>
rty
)
>
fromQualType
::
ModuleIdent
->
Type
->
CS
.
TypeExpr
...
...
src/Base/Typing.lhs
View file @
6081fb44
...
...
@@ -330,7 +330,7 @@ checker.
>
S
.
modify
(
bindVar
tv
(
TypeArrow
ty1
ty2
))
>
return
(
ty1
,
ty2
)
>
TypeArrow
ty1
ty2
->
return
(
ty1
,
ty2
)
>
ty'
->
internalError
(
"unifyArrow ("
++
show
ty'
++
")"
)
>
ty'
->
internalError
(
"
Base.Typing.
unifyArrow ("
++
show
ty'
++
")"
)
>
unifyArrow2
::
Type
->
TyState
(
Type
,
Type
,
Type
)
>
unifyArrow2
ty
=
...
...
@@ -367,7 +367,7 @@ checker.
>
(
TypeVariable
a2
)
>
(
foldr
(
unifyTypedLabels
fs1
)
theta
fs2
)
>
unifyTypes
ty1
ty2
_
=
>
internalError
(
"unify: ("
++
show
ty1
++
") ("
++
show
ty2
++
")"
)
>
internalError
(
"
Base.Typing.
unify: ("
++
show
ty1
++
") ("
++
show
ty2
++
")"
)
>
unifyTypedLabels
::
[(
Ident
,
Type
)]
->
(
Ident
,
Type
)
->
TypeSubst
->
TypeSubst
>
unifyTypedLabels
fs1
(
l
,
ty
)
theta
=
...
...
@@ -382,28 +382,24 @@ pattern variables, and variables.
\begin{verbatim}
>
constrType
::
QualIdent
->
ValueEnv
->
ExistTypeScheme
>
constrType
c
tyEnv
=
>
case
qualLookupValue
c
tyEnv
of
>
constrType
c
tyEnv
=
case
qualLookupValue
c
tyEnv
of
>
[
DataConstructor
_
sigma
]
->
sigma
>
[
NewtypeConstructor
_
sigma
]
->
sigma
>
_
->
internalError
(
"
constrType "
++
show
c
)
>
_
->
internalError
$
"Base.Typing.
constrType
:
"
++
show
c
>
varType
::
Ident
->
ValueEnv
->
TypeScheme
>
varType
v
tyEnv
=
>
case
lookupValue
v
tyEnv
of
>
varType
v
tyEnv
=
case
lookupValue
v
tyEnv
of
>
[
Value
_
sigma
]
->
sigma
>
_
->
internalError
(
"
varType "
++
show
v
)
>
_
->
internalError
$
"Base.Typing.
varType
:
"
++
show
v
>
funType
::
QualIdent
->
ValueEnv
->
TypeScheme
>
funType
f
tyEnv
=
>
case
qualLookupValue
f
tyEnv
of
>
funType
f
tyEnv
=
case
qualLookupValue
f
tyEnv
of
>
[
Value
_
sigma
]
->
sigma
>
_
->
internalError
(
"
funType "
++
show
f
)
>
_
->
internalError
$
"Base.Typing.
funType
:
"
++
show
f
>
labelType
::
Ident
->
ValueEnv
->
TypeScheme
>
labelType
l
tyEnv
=
>
case
lookupValue
l
tyEnv
of
>
labelType
l
tyEnv
=
case
lookupValue
l
tyEnv
of
>
[
Label
_
_
sigma
]
->
sigma
>
_
->
internalError
(
"
labelType "
++
show
l
)
>
_
->
internalError
$
"Base.Typing.
labelType
:
"
++
show
l
\end{verbatim}
src/Checks.hs
View file @
6081fb44
...
...
@@ -29,31 +29,32 @@ import CompilerOpts
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck
::
[
Decl
]
->
CompilerEnv
->
(
[
Decl
]
,
CompilerEnv
)
kindCheck
decls
env
=
(
decl
s'
,
env
)
where
d
ecl
s'
=
KC
.
kindCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
d
ecl
s
kindCheck
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
kindCheck
(
Module
m
es
is
ds
)
env
=
(
Module
m
es
is
d
s'
,
env
)
where
ds'
=
KC
.
kindCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
ds
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck
::
[
Decl
]
->
CompilerEnv
->
(
[
Decl
]
,
CompilerEnv
)
precCheck
decls
env
=
(
decl
s'
,
env
{
opPrecEnv
=
pEnv'
})
where
(
pEnv'
,
d
ecl
s'
)
=
PC
.
precCheck
(
moduleIdent
env
)
(
opPrecEnv
env
)
d
ecl
s
precCheck
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
precCheck
(
Module
m
es
is
ds
)
env
=
(
Module
m
es
is
d
s'
,
env
{
opPrecEnv
=
pEnv'
})
where
(
pEnv'
,
ds'
)
=
PC
.
precCheck
(
moduleIdent
env
)
(
opPrecEnv
env
)
ds
-- |Apply the syntax check.
syntaxCheck
::
Options
->
[
Decl
]
->
CompilerEnv
->
(
[
Decl
]
,
CompilerEnv
)
syntaxCheck
opts
decls
env
=
(
decl
s'
,
env
)
where
d
ecls'
=
SC
.
syntaxCheck
withExt
(
moduleIdent
env
)
(
aliasEnv
env
)
(
arityEnv
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
d
ecl
s
syntaxCheck
::
Options
->
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
syntaxCheck
opts
(
Module
m
es
is
ds
)
env
=
(
Module
m
es
is
d
s'
,
env
)
where
d
s'
=
SC
.
syntaxCheck
withExt
(
moduleIdent
env
)
(
aliasEnv
env
)
(
arityEnv
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
ds
withExt
=
BerndExtension
`
elem
`
optExtensions
opts
-- |Apply the type check.
typeCheck
::
[
Decl
]
->
CompilerEnv
->
(
[
Decl
]
,
CompilerEnv
)
typeCheck
decls
env
=
(
decls
,
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
})
typeCheck
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
typeCheck
mdl
@
(
Module
_
_
_
ds
)
env
=
(
mdl
,
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
})
where
(
tcEnv'
,
tyEnv'
)
=
TC
.
typeCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
d
ecl
s
(
tyConsEnv
env
)
(
valueEnv
env
)
ds
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck
::
CompilerEnv
->
[
ImportDecl
]
->
[
Decl
]
->
[
Message
]
warnCheck
env
=
WC
.
warnCheck
(
moduleIdent
env
)
(
valueEnv
env
)
warnCheck
::
Module
->
CompilerEnv
->
[
Message
]
warnCheck
(
Module
_
_
is
ds
)
env
=
WC
.
warnCheck
(
moduleIdent
env
)
(
valueEnv
env
)
is
ds
src/Checks/KindCheck.lhs
View file @
6081fb44
This diff is collapsed.
Click to expand it.
src/Checks/PrecCheck.lhs
View file @
6081fb44
...
...
@@ -38,13 +38,11 @@ imported precedence environment.
\begin{verbatim}
>
bindPrecs
::
ModuleIdent
->
[
Decl
]
->
PEnv
->
PEnv
>
bindPrecs
m
ds
pEnv
=
>
case
findDouble
ops
of
>
Nothing
->
>
case
[
op
|
op
<-
ops
,
op
`
notElem
`
bvs
]
of
>
[]
->
foldr
bindPrec
pEnv
fixDs
>
op
:
_
->
errorAt'
(
undefinedOperator
op
)
>
Just
op
->
errorAt'
(
duplicatePrecedence
op
)
>
bindPrecs
m
ds
pEnv
=
case
findDouble
ops
of
>
Nothing
->
case
[
op
|
op
<-
ops
,
op
`
notElem
`
bvs
]
of
>
[]
->
foldr
bindPrec
pEnv
fixDs
>
op
:
_
->
errorAt'
(
undefinedOperator
op
)
>
Just
op
->
errorAt'
(
duplicatePrecedence
op
)
>
where
(
fixDs
,
nonFixDs
)
=
partition
isInfixDecl
ds
>
bvs
=
concatMap
boundValues
nonFixDs
>
ops
=
[
op
|
InfixDecl
_
_
_
ops'
<-
fixDs
,
op
<-
ops'
]
...
...
@@ -56,8 +54,8 @@ imported precedence environment.
>
boundValues
::
Decl
->
[
Ident
]
>
boundValues
(
DataDecl
_
_
_
cs
)
=
map
constr
cs
>
where
constr
(
ConstrDecl
_
_
c
_
)
=
c
>
constr
(
ConOpDecl
_
_
_
op
_
)
=
op
>
where
constr
(
ConstrDecl
_
_
c
_
)
=
c
>
constr
(
ConOpDecl
_
_
_
op
_
)
=
op
>
boundValues
(
NewtypeDecl
_
_
_
(
NewConstrDecl
_
_
c
_
))
=
[
c
]
>
boundValues
(
FunctionDecl
_
f
_
)
=
[
f
]
>
boundValues
(
ExternalDecl
_
_
_
f
_
)
=
[
f
]
...
...
@@ -77,13 +75,13 @@ be returned because it is needed for constructing the module's
interface.
\begin{verbatim}
>
precCheck
::
ModuleIdent
->
PEnv
->
[
Decl
]
->
(
PEnv
,[
Decl
])
>
precCheck
::
ModuleIdent
->
PEnv
->
[
Decl
]
->
(
PEnv
,
[
Decl
])
>
precCheck
=
checkDecls
>
checkDecls
::
ModuleIdent
->
PEnv
->
[
Decl
]
->
(
PEnv
,[
Decl
])
>
checkDecls
m
pEnv
ds
=
pEnv'
`
seq
`
(
pEnv'
,
ds'
)
>
checkDecls
::
ModuleIdent
->
PEnv
->
[
Decl
]
->
(
PEnv
,
[
Decl
])
>
checkDecls
m
pEnv
ds
=
pEnv'
`
seq
`
(
pEnv'
,
ds'
)
>
where
pEnv'
=
bindPrecs
m
ds
pEnv
>
ds'
=
map
(
checkDecl
m
pEnv'
)
ds
>
ds'
=
map
(
checkDecl
m
pEnv'
)
ds
>
checkDecl
::
ModuleIdent
->
PEnv
->
Decl
->
Decl
>
checkDecl
m
pEnv
(
FunctionDecl
p
f
eqs
)
=
...
...
@@ -430,10 +428,9 @@ an operator definition that shadows an imported definition.
>
opPrec
op
=
prec
(
opName
op
)
>
prec
::
QualIdent
->
PEnv
->
OpPrec
>
prec
op
env
=
>
case
qualLookupP
op
env
of
>
[]
->
defaultP
>
PrecInfo
_
p
:
_
->
p
>
prec
op
env
=
case
qualLookupP
op
env
of
>
[]
->
defaultP
>
PrecInfo
_
p
:
_
->
p
\end{verbatim}
Error messages.
...
...
src/Checks/SyntaxCheck.lhs
View file @
6081fb44
...
...
@@ -127,12 +127,12 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
>
[
ArityInfo
_
arity'
]
->
GlobalVar
arity'
qid
>
rs
->
case
qualLookupArity
qid'
aEnv
of
>
[
ArityInfo
_
arity''
]
->
GlobalVar
arity''
qid
>
_
->
maybe
(
internalError
$
"renameInfo: missing arity for "
++
show
qid
)
>
_
->
maybe
(
internalError
$
"
SyntaxCheck.
renameInfo: missing arity for "
++
show
qid
)
>
(
\
(
ArityInfo
_
arity''
)
->
GlobalVar
arity''
qid
)
>
(
find
(
\
(
ArityInfo
qid''
_
)
->
qid''
==
qid
)
rs
)
>
renameInfo
tcEnv
_
_
(
Label
_
r
_
)
=
case
(
qualLookupTC
r
tcEnv
)
of
>
[
AliasType
_
_
(
TypeRecord
fs
_
)]
->
RecordLabel
r
(
map
fst
fs
)
>
_
->
internalError
"renameInfo: no record"
>
_
->
internalError
"
SyntaxCheck.
renameInfo: no record"
\end{verbatim}
Since record types are currently translated into data types, it is
...
...
@@ -178,7 +178,7 @@ than once.
>
bindFuncDecl
::
ModuleIdent
->
Decl
->
RenameEnv
->
RenameEnv
>
bindFuncDecl
m
(
FunctionDecl
_
ident
equs
)
env
>
|
null
equs
=
internalError
"bindFuncDecl: missing equations"
>
|
null
equs
=
internalError
"
SyntaxCheck.
bindFuncDecl: missing equations"
>
|
otherwise
=
let
(
_
,
ts
)
=
getFlatLhs
(
head
equs
)
> in bindGlobal m
> ident
...
...
@@ -199,7 +199,7 @@ than once.
>
bindVarDecl
::
Decl
->
RenameEnv
->
RenameEnv
>
bindVarDecl
(
FunctionDecl
_
ident
equs
)
env
>
|
null
equs
>
=
internalError
"bindFuncDecl: missing equations"
>
=
internalError
"
SyntaxCheck.
bindFuncDecl: missing equations"
>
|
otherwise
>
=
let
(
_
,
ts
)
=
getFlatLhs
(
head
equs
)
> in bindLocal (unRenameIdent ident) (LocalVar (length ts) ident) env
...
...
@@ -260,7 +260,7 @@ local declarations.
>
checkTypeDecl
::
Bool
->
ModuleIdent
->
Decl
->
Decl
>
checkTypeDecl
withExt
_
(
TypeDecl
p
r
tvs
(
RecordType
fs
rty
))
>
|
not
withExt
=
errorAt
(
positionOfIdent
r
)
noRecordExt
>
|
isJust
rty
=
internalError
"checkTypeDecl - illegal record type"
>
|
isJust
rty
=
internalError
"
SyntaxCheck.
checkTypeDecl - illegal record type"
>
|
null
fs
=
errorAt
(
positionOfIdent
r
)
emptyRecord
>
|
otherwise
=
TypeDecl
p
r
tvs
(
RecordType
fs
Nothing
)
>
checkTypeDecl
_
_
d
=
d
...
...
@@ -327,7 +327,7 @@ top-level.
>
patDecl
t
>
|
k
==
globalKey
=
errorAt
p
noToplevelPattern
>
|
otherwise
=
PatternDecl
p'
t
rhs
>
checkEquationLhs
_
_
_
_
_
_
=
internalError
"checkEquationLhs"
>
checkEquationLhs
_
_
_
_
_
_
=
internalError
"
SyntaxCheck.
checkEquationLhs"
>
checkEqLhs
::
ModuleIdent
->
Integer
->
RenameEnv
->
Position
->
Lhs
>
->
Either
(
Ident
,
Lhs
)
ConstrTerm
...
...
@@ -648,13 +648,14 @@ top-level.
>
checkExpr
::
Bool
->
Position
->
ModuleIdent
->
RenameEnv
->
Expression
>
->
RenameState
Expression
>
checkExpr
_
_
_
_
(
Literal
l
)
=
liftM
Literal
(
renameLiteral
l
)
>
checkExpr
_
_
m
env
(
Variable
v
)
=
>
case
(
qualLookupVar
v
env
)
of
>
[]
->
errorAt'
(
undefinedVariable
v
)
>
[
Constr
_
]
->
return
(
Constructor
v
)
>
[
GlobalVar
_
_
]
->
return
(
Variable
v
)
>
[
LocalVar
_
v'
]
->
return
(
Variable
(
qualify
v'
))
>
rs
->
case
(
qualLookupVar
(
qualQualify
m
v
)
env
)
of
>
checkExpr
_
_
m
env
var
@
(
Variable
v
)
>
|
unqualify
v
==
anonId
=
return
var
>
|
otherwise
=
case
qualLookupVar
v
env
of
>
[]
->
errorAt'
(
undefinedVariable
v
)
>
[
Constr
_
]
->
return
(
Constructor
v
)
>
[
GlobalVar
_
_
]
->
return
(
Variable
v
)
>
[
LocalVar
_
v'
]
->
return
(
Variable
(
qualify
v'
))
>
rs
->
case
qualLookupVar
(
qualQualify
m
v
)
env
of
>
[]
->
errorAt'
(
ambiguousIdent
rs
v
)
>
[
Constr
_
]
->
return
(
Constructor
v
)
>
[
GlobalVar
_
_
]
->
return
(
Variable
v
)
...
...
@@ -922,12 +923,12 @@ the user about the fact that the identifier is ambiguous.
>
varIdent
::
RenameInfo
->
Ident
>
varIdent
(
GlobalVar
_
v
)
=
unqualify
v
>
varIdent
(
LocalVar
_
v
)
=
v
>
varIdent
_
=
internalError
"not a variable"
>
varIdent
_
=
internalError
"
SyntaxCheck.varIdent:
not a variable"
>
qualVarIdent
::
RenameInfo
->
QualIdent
>
qualVarIdent
(
GlobalVar
_
v
)
=
v
>
qualVarIdent
(
LocalVar
_
v
)
=
qualify
v
>
qualVarIdent
_
=
internalError
"not a qualified variable"
>
qualVarIdent
_
=
internalError
"
SyntaxCheck.qualVarIdent:
not a qualified variable"
>
arity
::
RenameInfo
->
Int
>
arity
(
Constr
n
)
=
n
...
...
src/Checks/TypeCheck.lhs
View file @
6081fb44
...
...
@@ -63,7 +63,7 @@ The type checker returns the resulting type
constructor and type environments.
\begin{verbatim}
>
typeCheck
::
ModuleIdent
->
TCEnv
->
ValueEnv
->
[
Decl
]
->
(
TCEnv
,
ValueEnv
)
>
typeCheck
::
ModuleIdent
->
TCEnv
->
ValueEnv
->
[
Decl
]
->
(
TCEnv
,
ValueEnv
)
>
typeCheck
m
tcEnv
tyEnv
ds
=
>
run
(
tcDecls
m
tcEnv'
Map
.
empty
vds
>>
>
S
.
lift
S
.
get
>>=
\
theta
->
S
.
get
>>=
\
tyEnv'
->
...
...
@@ -143,7 +143,7 @@ and \texttt{expandMonoTypes}, respectively.
>
free
_
=
error
"TypeCheck.sortTypeDecls.free: no pattern match"
>
typeDecl
::
ModuleIdent
->
[
Decl
]
->
Decl
>
typeDecl
_
[]
=
internalError
"typeDecl"
>
typeDecl
_
[]
=
internalError
"
TypeCheck.
typeDecl"
>
typeDecl
_
[
d
@
(
DataDecl
_
_
_
_
)]
=
d
>
typeDecl
_
[
d
@
(
NewtypeDecl
_
_
_
_
)]
=
d
>
typeDecl
m
[
d
@
(
TypeDecl
_
tc
_
ty
)]
...
...
@@ -340,7 +340,7 @@ either one of the basic types or \texttt{()}.
>
where
typeOf
f'
tcEnv'
sigs'
=
>
case
lookupTypeSig
f'
sigs'
of
>
Just
ty
->
return
(
expandPolyType
m
tcEnv'
ty
)
>
Nothing
->
internalError
"tcFlatExternalFunct"
>
Nothing
->
internalError
"
TypeCheck.
tcFlatExternalFunct"
>
tcExtraVar
::
ModuleIdent
->
TCEnv
->
SigEnv
->
Ident
>
->
TcState
()
...
...
@@ -425,8 +425,7 @@ signature the declared type must be too general.
>
tyEnv'
=
rebindFun
m
v
sigma
tyEnv
>
sigma
=
genType
poly
(
subst
theta
(
varType
v
tyEnv
))
>
genType
poly'
(
ForAll
n
ty
)
>
|
n
>
0
=
internalError
(
"genVar: "
++
showLine
(
positionOfIdent
v
)
++
>
show
v
++
" :: "
++
show
ty
)
>
|
n
>
0
=
internalError
$
"TypeCheck.genVar: "
++
showLine
(
positionOfIdent
v
)
++
show
v
++
" :: "
++
show
ty
>
|
poly'
=
gen
lvs
ty
>
|
otherwise
=
monoType
ty
>
cmpTypes
(
ForAll
_
t1
)
(
ForAll
_
t2
)
=
equTypes
t1
t2
...
...
@@ -474,7 +473,7 @@ signature the declared type must be too general.
>
unify
p
"pattern"
(
doc
$-$
text
"Term:"
<+>
ppConstrTerm
0
t1
)
>
m
ty1
>>
>
unifyArgs
doc
ts1
ty2
>
unifyArgs
_
_
_
=
internalError
"tcConstrTerm"
>
unifyArgs
_
_
_
=
internalError
"
TypeCheck.
tcConstrTerm"
>
tcConstrTerm
m
tcEnv
sigs
p
t
@
(
InfixPattern
t1
op
t2
)
=
>
do
>
tyEnv
<-
S
.
get
...
...
@@ -486,7 +485,7 @@ signature the declared type must be too general.
>
unify
p
"pattern"
(
doc
$-$
text
"Term:"
<+>
ppConstrTerm
0
t'
)
>
m
ty1
>>
>
unifyArgs
doc
ts'
ty2
>
unifyArgs
_
_
_
=
internalError
"tcConstrTerm"
>
unifyArgs
_
_
_
=
internalError
"
TypeCheck.
tcConstrTerm"
>
tcConstrTerm
m
tcEnv
sigs
p
(
ParenPattern
t
)
=
tcConstrTerm
m
tcEnv
sigs
p
t
>
tcConstrTerm
m
tcEnv
sigs
p
(
TuplePattern
_
ts
)
>
|
null
ts
=
return
unitType
...
...
@@ -525,7 +524,7 @@ signature the declared type must be too general.
> (doc $-$ text "Term:" <+
>
ppConstrTerm
0
t1
)
>
m
ty1
>>
>
unifyArgs
doc
ts1
ty2
>
unifyArgs
_
_
ty
=
internalError
(
"
tcConstrTerm: "
++
show
ty
)
>
unifyArgs
_
_
ty
=
internalError
$
"TypeCheck.
tcConstrTerm: "
++
show
ty
>
tcConstrTerm
m
tcEnv
sigs
p
(
InfixFuncPattern
t1
op
t2
)
=
>
tcConstrTerm
m
tcEnv
sigs
p
(
FunctionPattern
op
[
t1
,
t2
])
>
tcConstrTerm
m
tcEnv
sigs
p
r
@
(
RecordPattern
fs
rt
)
...
...
@@ -573,7 +572,7 @@ because of possibly multiple occurrences of variables.
>
unify
p
"pattern"
(
doc
$-$
text
"Term:"
<+>
ppConstrTerm
0
t1
)
>
m
ty1
>>
>
unifyArgs
doc
ts1
ty2
>
unifyArgs
_
_
_
=
internalError
"tcConstrTermFP"
>
unifyArgs
_
_
_
=
internalError
"
TypeCheck.
tcConstrTermFP"
>
tcConstrTermFP
m
tcEnv
sigs
p
t
@
(
InfixPattern
t1
op
t2
)
=
>
do
>
tyEnv
<-
S
.
get
...
...
@@ -585,7 +584,7 @@ because of possibly multiple occurrences of variables.
>
unify
p
"pattern"
(
doc
$-$
text
"Term:"
<+>
ppConstrTerm
0
t'
)
>
m
ty1
>>
>
unifyArgs
doc
ts'
ty2
>
unifyArgs
_
_
_
=
internalError
"tcConstrTermFP"
>
unifyArgs
_
_
_
=
internalError
"
TypeCheck.
tcConstrTermFP"
>
tcConstrTermFP
m
tcEnv
sigs
p
(
ParenPattern
t
)
=
tcConstrTermFP
m
tcEnv
sigs
p
t
>
tcConstrTermFP
m
tcEnv
sigs
p
(
TuplePattern
_
ts
)
>
|
null
ts
=
return
unitType
...
...
@@ -623,7 +622,7 @@ because of possibly multiple occurrences of variables.
>
unify
p
"pattern"
(
doc
$-$
text
"Term:"
<+>
ppConstrTerm
0
t1
)
>
m
ty1
>>
>
unifyArgs
doc
ts1
ty2
>
unifyArgs
_
_
_
=
internalError
"tcConstrTermFP"
>
unifyArgs
_
_
_
=
internalError
"
TypeCheck.
tcConstrTermFP"
>
tcConstrTermFP
m
tcEnv
sigs
p
(
InfixFuncPattern
t1
op
t2
)
=
>
tcConstrTermFP
m
tcEnv
sigs
p
(
FunctionPattern
op
[
t1
,
t2
])
>
tcConstrTermFP
m
tcEnv
sigs
p
r
@
(
RecordPattern
fs
rt
)
...
...
@@ -689,7 +688,7 @@ because of possibly multiple occurrences of variables.
>
tcExpr
::
ModuleIdent
->
TCEnv
->
SigEnv
->
Position
->
Expression
>
->
TcState
Type
>
tcExpr
m
_
_
_
(
Literal
l
)
=
tcLiteral
m
l
>
tcExpr
m
_
_
_
(
Literal
l
)
=
tcLiteral
m
l
>
tcExpr
m
tcEnv
sigs
_
(
Variable
v
)
=
>
case
qualLookupTypeSig
m
v
sigs
of
>
Just
ty
->
inst
(
expandPolyType
m
tcEnv
ty
)
...
...
@@ -772,7 +771,7 @@ because of possibly multiple occurrences of variables.
>
where
opType
op'
>
|
op'
==
minusId
=
freshConstrained
[
intType
,
floatType
]
>
|
op'
==
fminusId
=
return
floatType
>
|
otherwise
=
internalError
(
"
tcExpr unary "
++
name
op'
)
>
|
otherwise
=
internalError
$
"TypeCheck.
tcExpr unary "
++
name
op'
>
tcExpr
m
tcEnv
sigs
p
e
@
(
Apply
e1
e2
)
=
>
do
>
ty1
<-
tcExpr
m
tcEnv
sigs
p
e1
...
...
@@ -1079,7 +1078,7 @@ of~\cite{PeytonJones87:Book}).
> (unifyTypes m ty ty'))
>
(
lookup
l
fs2
))
>
(
unifyTypedLabels
m
fs1
tr
)
>
unifyTypedLabels
_
_
_
=
internalError
"unifyTypedLabels"
>
unifyTypedLabels
_
_
_
=
internalError
"
TypeCheck.
unifyTypedLabels"
\end{verbatim}
For each declaration group, the type checker has to ensure that no
...
...
@@ -1159,40 +1158,35 @@ unambiguously refers to the local definition.
\begin{verbatim}
>
constrType
::
ModuleIdent
->
QualIdent
->
ValueEnv
->
ExistTypeScheme
>
constrType
m
c
tyEnv
=
>
case
qualLookupValue
c
tyEnv
of
>
[
DataConstructor
_
sigma
]
->
sigma
>
[
NewtypeConstructor
_
sigma
]
->
sigma
>
_
->
case
(
qualLookupValue
(
qualQualify
m
c
)
tyEnv
)
of
>
[
DataConstructor
_
sigma
]
->
sigma
>
[
NewtypeConstructor
_
sigma
]
->
sigma
>
_
->
internalError
(
"constrType "
++
show
c
)
>
constrType
m
c
tyEnv
=
case
qualLookupValue
c
tyEnv
of
>
[
DataConstructor
_
sigma
]
->
sigma
>
[
NewtypeConstructor
_
sigma
]
->
sigma
>
_
->
case
qualLookupValue
(
qualQualify
m
c
)
tyEnv
of
>
[
DataConstructor
_
sigma
]
->
sigma
>
[
NewtypeConstructor
_
sigma
]
->
sigma
>
_
->
internalError
$
"TypeCheck.constrType "
++
show
c
>
varType
::
Ident
->
ValueEnv
->
TypeScheme
>
varType
v
tyEnv
=
>
case
lookupValue
v
tyEnv
of
>
Value
_
sigma
:
_
->
sigma
>
_
->
internalError
(
"varType "
++
show
v
)
>
varType
v
tyEnv
=
case
lookupValue
v
tyEnv
of
>
Value
_
sigma
:
_
->
sigma
>
_
->
internalError
$
"TypeCheck.varType "
++
show
v
>
sureVarType
::
Ident
->
ValueEnv
->
Maybe
TypeScheme
>
sureVarType
v
tyEnv
=
>
case
lookupValue
v
tyEnv
of
>
Value
_
sigma
:
_
->
Just
sigma
>
_
->
Nothing
>
sureVarType
v
tyEnv
=
case
lookupValue
v
tyEnv
of
>
Value
_
sigma
:
_
->
Just
sigma
>
_
->
Nothing
>
funType
::
ModuleIdent
->
QualIdent
->
ValueEnv
->
TypeScheme
>
funType
m
f
tyEnv
=
>
case
(
qualLookupValue
f
tyEnv
)
of
>
[
Value
_
sigma
]
->
sigma
>
_
->
case
(
qualLookupValue
(
qualQualify
m
f
)
tyEnv
)
of
>
[
Value
_
sigma
]
->
sigma
>
_
->
internalError
(
"funType "
++
show
f
)
>
funType
m
f
tyEnv
=
case
qualLookupValue
f
tyEnv
of
>
[
Value
_
sigma
]
->
sigma
>
_
->
case
qualLookupValue
(
qualQualify
m
f
)
tyEnv
of
>
[
Value
_
sigma
]
->
sigma
>
_
->
internalError
$
"TypeCheck.funType "
++
show
f
>
sureLabelType
::
Ident
->
ValueEnv
->
Maybe
TypeScheme
>
sureLabelType
l
tyEnv
=
>
case
lookupValue
l
tyEnv
of
>
Label
_
_
sigma
:
_
->
Just
sigma
>
_
->
Nothing
>
sureLabelType
l
tyEnv
=
case
lookupValue
l
tyEnv
of
>
Label
_
_
sigma
:
_
->
Just
sigma
>
_
->
Nothing
\end{verbatim}
...
...
@@ -1221,7 +1215,7 @@ in which the type was defined.
>
[
DataType
tc'
_
_
]
->
TypeConstructor
tc'
tys'
>
[
RenamingType
tc'
_
_
]
->
TypeConstructor
tc'
tys'
>
[
AliasType
_
_
ty
]
->
expandAliasType
tys'
ty
>
_
->
internalError
(
"
expandType "
++
show
tc
)
>
_
->
internalError
$
"TypeCheck.
expandType "
++
show
tc
>
where
tys'
=
map
(
expandType
m
tcEnv
)
tys
>
expandType
_
_
(
TypeVariable
tv
)
=
TypeVariable
tv
>
expandType
_
_
(
TypeConstrained
tys
tv
)
=
TypeConstrained
tys
tv
...
...
src/Checks/WarnCheck.hs
View file @
6081fb44
This diff is collapsed.
Click to expand it.
src/Env/Eval.lhs
View file @
6081fb44
...
...
@@ -24,8 +24,8 @@ The function \texttt{evalEnv} collects all evaluation annotations of
the module by traversing the syntax tree.
\begin{verbatim}
>
evalEnv
::
[
Decl
]
->
EvalEnv
>
evalEnv
=
foldr
collectAnnotsDecl
Map
.
empty
>
evalEnv
::
Module
->
EvalEnv
>
evalEnv
(
Module
_
_
_
ds
)
=
foldr
collectAnnotsDecl
Map
.
empty
ds
>
initEEnv
::
EvalEnv
>
initEEnv
=
Map
.
empty
...
...
src/Env/NestEnv.lhs
View file @
6081fb44
...
...
@@ -41,17 +41,17 @@ imported.
>
=
GlobalEnv
(
bindTopEnv
"NestEnv.bindNestEnv"
x
y
env
)
>
bindNestEnv
x
y
(
LocalEnv
genv
env
)
=
>
case
Map
.
lookup
x
env
of
>
Just
_
->
internalError
"bindNestEnv"
>
Just
_
->
internalError
"
NestEnv.
bindNestEnv"
>
Nothing
->
LocalEnv
genv
(
Map
.
insert
x
y
env
)
>
qualBindNestEnv
::
QualIdent
->
a
->
NestEnv
a
->
NestEnv
a
>
qualBindNestEnv
x
y
(
GlobalEnv
env
)
>
=
GlobalEnv
(
qualBindTopEnv
"NestEnv.qualBindNestEnv"
x
y
env
)
>
qualBindNestEnv
x
y
(
LocalEnv
genv
env
)
>
|
isQualified
x
=
internalError
"qualBindNestEnv"
>
|
isQualified
x
=
internalError
"
NestEnv.
qualBindNestEnv"
>
|
otherwise
=
>
case
Map
.
lookup
x'
env
of
>
Just
_
->
internalError
"qualBindNestEnv"
>
Just
_
->
internalError
"
NestEnv.
qualBindNestEnv"
>
Nothing
->
LocalEnv
genv
(
Map
.
insert
x'
y
env
)
>
where
x'
=
unqualify
x
...
...
src/Env/TopEnv.lhs
View file @
6081fb44
...
...
@@ -71,7 +71,7 @@ imported.
>
predefTopEnv
::
Entity
a
=>
QualIdent
->
a
->
TopEnv
a
->
TopEnv
a
>
predefTopEnv
x
y
(
TopEnv
env
)
=
>
case
Map
.
lookup
x
env
of
>
Just
_
->
internalError
"predefTopEnv"
>
Just
_
->
internalError
"
TopEnv.
predefTopEnv"
>
Nothing
->
TopEnv
(
Map
.
insert
x
[(
Import
[]
,
y
)]
env
)
>
importTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
->
TopEnv
a
...
...
@@ -101,8 +101,8 @@ imported.
>
TopEnv
(
Map
.
insert
x
(
bindLocal
y
(
entities
x
env
))
env
)
>
where
bindLocal
y'
ys
>
|
null
[
y''
|
(
Local
,
y''
)
<-
ys
]
=
(
Local
,
y'
)
:
ys
>
|
otherwise
=
internalError
(
"
\"
qualBindTopEnv "
++
show
x
>
++
"
\"
failed in function
\"
"
++
fun
++
"
\"
"
)
>
|
otherwise
=
internalError
$
"
\"
qualBindTopEnv "
++
show
x
>
++
"
\"
failed in function
\"
"
++
fun
++
"
\"
"
>
rebindTopEnv
::
Ident
->
a
->
TopEnv
a
->
TopEnv
a
>
rebindTopEnv
=
qualRebindTopEnv
.
qualify
...
...
@@ -110,7 +110,7 @@ imported.
>
qualRebindTopEnv
::
QualIdent
->
a
->
TopEnv
a
->
TopEnv
a
>
qualRebindTopEnv
x
y
(
TopEnv
env
)
=
>
TopEnv
(
Map
.
insert
x
(
rebindLocal
(
entities
x
env
))
env
)
>
where
rebindLocal
[]
=
internalError
"qualRebindTopEnv"
>
where
rebindLocal
[]
=
internalError
"
TopEnv.
qualRebindTopEnv"
>
rebindLocal
((
Local
,
_
)
:
ys
)
=
(
Local
,
y
)
:
ys
>
rebindLocal
((
Import
ms
,
y'
)
:
ys
)
=
(
Import
ms
,
y'
)
:
rebindLocal
ys
...
...
@@ -118,7 +118,7 @@ imported.
>
unbindTopEnv
x
(
TopEnv
env
)
=
>
TopEnv
(
Map
.
insert
x'
(
unbindLocal
(
entities
x'
env
))
env
)
>
where
x'
=
qualify
x
>
unbindLocal
[]
=
internalError
"unbindTopEnv"
>
unbindLocal
[]
=
internalError
"
TopEnv.
unbindTopEnv"
>
unbindLocal
((
Local
,
_
)
:
ys
)
=
ys
>
unbindLocal
((
Import
ms
,
y
)
:
ys
)
=
(
Import
ms
,
y
)
:
unbindLocal
ys
...
...
src/Env/Value.lhs
View file @
6081fb44
...
...
@@ -13,10 +13,14 @@ are considered equal if their original names match.
>
module
Env.Value
>
(
ValueEnv
,
ValueInfo
(
..
),
bindGlobalInfo
,
bindFun
,
rebindFun
,
bindLabel
>
,
lookupValue
,
qualLookupValue
,
qualLookupCons
,
lookupTuple
,
tupleDCs
>
,
initDCEnv
)
where
>
,
initDCEnv
,
ppTypes
)
where
>
import
Text.PrettyPrint
(
Doc
,
vcat
)
>
import
Curry.Base.Ident
>
import
Curry.Syntax
>
import
Base.CurryTypes
(
fromQualType
)
>
import
Base.Types
>
import
Base.Utils
((
++!
))
...
...
@@ -124,3 +128,22 @@ TODO: Match other patterns?
>
constrType
(
ForAll
n
ty
)
n'
=
ForAllExist
n
n'
.
foldr
TypeArrow
ty
\end{verbatim}
The function \texttt{ppTypes} is used for pretty-printing the types
from the type environment.
\begin{verbatim}
>
ppTypes
::
ModuleIdent
->
ValueEnv
->
Doc
>
ppTypes
mid
valueEnv
=
ppTypes'
mid
(
localBindings
valueEnv
)
>
where
>
ppTypes'
::
ModuleIdent
->
[(
Ident
,
ValueInfo
)]
->
Doc
>
ppTypes'
m
=
vcat
.
map
(
ppIDecl
.
mkDecl
)
.
filter
(
isValue
.
snd
)
>
where
mkDecl
(
v
,
Value
_
(
ForAll
_
ty
))
=
>
IFunctionDecl
undefined
(
qualify
v
)
(
arrowArity
ty
)
>
(
fromQualType
m
ty
)
>
mkDecl
_
=
error
"Modules.ppTypes.mkDecl: no pattern match"
>
isValue
(
DataConstructor
_
_
)
=
False
>
isValue
(
NewtypeConstructor
_
_
)
=
False
>
isValue
(
Value
_
_
)
=
True
>
isValue
(
Label
_
_
_
)
=
False
\end{verbatim}
src/Exports.lhs
View file @
6081fb44
...
...
@@ -181,7 +181,7 @@ identifiers.
>
in
case
lookupValue
(
head
ls
)
tyEnv
of
>
[
Label
_
r'
_
]
->
if
r
==
r'
then
ExportTypeWith
r
ls
>
else
ExportTypeWith
r
[]
>
_
->
internalError
"exportType"
>
_
->
internalError
"
Exports.
exportType"
>
|
otherwise
=
ExportTypeWith
(
origName
t
)
(
constrs
t
)
>
exportRecord
::
TypeInfo
->
[
Export
]
...
...
@@ -247,7 +247,7 @@ exported function.
>
iInfixDecl
m
pEnv
op
ds
=
case
qualLookupP
op
pEnv
of
>
[]
->
ds
>
[
PrecInfo
_
(
OpPrec
fix
pr
)]
->
IInfixDecl
NoPos
fix
pr
(
qualUnqualify
m
op
)
:
ds
>
_
->
internalError
"infixDecl"