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
69d91016
Commit
69d91016
authored
Feb 19, 2015
by
Jan Rasmus Tikovsky
Browse files
Make frontend compile again
parent
78887d02
Changes
30
Hide whitespace changes
Inline
Side-by-side
src/Base/Expr.hs
View file @
69d91016
...
...
@@ -94,6 +94,8 @@ instance QualExpr Expression where
qfv
_
(
Constructor
_
)
=
[]
qfv
m
(
Paren
e
)
=
qfv
m
e
qfv
m
(
Typed
e
_
)
=
qfv
m
e
qfv
m
(
Record
_
fs
)
=
qfv
m
fs
qfv
m
(
RecordUpdate
e
fs
)
=
qfv
m
e
++
qfv
m
fs
qfv
m
(
Tuple
_
es
)
=
qfv
m
es
qfv
m
(
List
_
es
)
=
qfv
m
es
qfv
m
(
ListCompr
_
e
qs
)
=
foldr
(
qfvStmt
m
)
(
qfv
m
e
)
qs
...
...
@@ -111,8 +113,6 @@ instance QualExpr Expression where
qfv
m
(
Do
sts
e
)
=
foldr
(
qfvStmt
m
)
(
qfv
m
e
)
sts
qfv
m
(
IfThenElse
_
e1
e2
e3
)
=
qfv
m
e1
++
qfv
m
e2
++
qfv
m
e3
qfv
m
(
Case
_
_
e
alts
)
=
qfv
m
e
++
qfv
m
alts
qfv
m
(
RecordConstr
_
fs
)
=
qfv
m
fs
qfv
m
(
RecordUpdate
e
fs
)
=
qfv
m
e
++
qfv
m
fs
qfvStmt
::
ModuleIdent
->
Statement
->
[
Ident
]
->
[
Ident
]
qfvStmt
m
st
fvs
=
qfv
m
st
++
filterBv
st
fvs
...
...
@@ -147,13 +147,13 @@ instance QuantExpr Pattern where
bv
(
ConstructorPattern
_
ts
)
=
bv
ts
bv
(
InfixPattern
t1
_
t2
)
=
bv
t1
++
bv
t2
bv
(
ParenPattern
t
)
=
bv
t
bv
(
RecordPattern
_
fs
)
=
bv
fs
bv
(
TuplePattern
_
ts
)
=
bv
ts
bv
(
ListPattern
_
ts
)
=
bv
ts
bv
(
AsPattern
v
t
)
=
v
:
bv
t
bv
(
LazyPattern
_
t
)
=
bv
t
bv
(
FunctionPattern
_
ts
)
=
nub
$
bv
ts
bv
(
InfixFuncPattern
t1
_
t2
)
=
nub
$
bv
t1
++
bv
t2
bv
(
RecordPattern
_
fs
)
=
bv
fs
instance
QualExpr
Pattern
where
qfv
_
(
LiteralPattern
_
)
=
[]
...
...
@@ -162,6 +162,7 @@ instance QualExpr Pattern where
qfv
m
(
ConstructorPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
InfixPattern
t1
_
t2
)
=
qfv
m
[
t1
,
t2
]
qfv
m
(
ParenPattern
t
)
=
qfv
m
t
qfv
m
(
RecordPattern
_
fs
)
=
qfv
m
fs
qfv
m
(
TuplePattern
_
ts
)
=
qfv
m
ts
qfv
m
(
ListPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
AsPattern
_
ts
)
=
qfv
m
ts
...
...
@@ -170,7 +171,6 @@ instance QualExpr Pattern where
=
maybe
[]
return
(
localIdent
m
f
)
++
qfv
m
ts
qfv
m
(
InfixFuncPattern
t1
op
t2
)
=
maybe
[]
return
(
localIdent
m
op
)
++
qfv
m
[
t1
,
t2
]
qfv
m
(
RecordPattern
_
fs
)
=
qfv
m
fs
instance
Expr
TypeExpr
where
fv
(
ConstructorType
_
tys
)
=
fv
tys
...
...
src/Base/TopEnv.hs
View file @
69d91016
...
...
@@ -163,5 +163,5 @@ allLocalBindings :: TopEnv a -> [(QualIdent, a)]
allLocalBindings
(
TopEnv
env
)
=
[
(
x
,
y
)
|
(
x
,
ys
)
<-
Map
.
toList
env
,
(
Local
,
y
)
<-
ys
]
allEntities
::
TopEnv
a
->
[
(
QualIdent
,
a
)
]
allEntities
env
=
[
(
x
,
y
)
|
(
x
,
ys
)
<-
Map
.
toList
env
,
(
_
,
y
)
<-
ys
]
allEntities
::
TopEnv
a
->
[
a
]
allEntities
(
TopEnv
env
)
=
[
y
|
(
_
,
ys
)
<-
Map
.
toList
env
,
(
_
,
y
)
<-
ys
]
src/Base/TypeSubst.hs
View file @
69d91016
...
...
@@ -54,10 +54,10 @@ instance SubstType ExistTypeScheme where
ForAllExist
n
n'
(
subst
(
foldr
unbindSubst
sigma
[
0
..
n
+
n'
-
1
])
ty
)
instance
SubstType
ValueInfo
where
subst
_
dc
@
(
DataConstructor
_
_
_
)
=
dc
subst
_
nc
@
(
NewtypeConstructor
_
_
)
=
nc
subst
theta
(
Value
v
a
ty
)
=
Value
v
a
(
subst
theta
ty
)
subst
theta
(
Label
l
r
ty
)
=
Label
l
r
(
subst
theta
ty
)
subst
_
dc
@
(
DataConstructor
_
_
_
_
)
=
dc
subst
_
nc
@
(
NewtypeConstructor
_
_
_
)
=
nc
subst
theta
(
Value
v
a
ty
)
=
Value
v
a
(
subst
theta
ty
)
subst
theta
(
Label
l
r
ty
)
=
Label
l
r
(
subst
theta
ty
)
instance
SubstType
a
=>
SubstType
(
TopEnv
a
)
where
subst
=
fmap
.
subst
...
...
src/Base/Types.hs
View file @
69d91016
...
...
@@ -21,7 +21,8 @@ module Base.Types
Type
(
..
),
isArrowType
,
arrowArity
,
arrowArgs
,
arrowBase
,
arrowUnapply
,
typeVars
,
typeConstrs
,
typeSkolems
,
equTypes
,
qualifyType
,
unqualifyType
-- * Representation of Data Constructors
,
DataConstr
(
..
),
constrIdent
,
tupleData
,
DataConstr
(
..
),
constrIdent
,
constrTypes
,
recLabels
,
recLabelTypes
,
tupleData
-- * Representation of Quantification
,
TypeScheme
(
..
),
ExistTypeScheme
(
..
),
monoType
,
polyType
-- * Predefined types
...
...
@@ -180,7 +181,7 @@ unqualifyType _ skol@(TypeSkolem _) = skol
-- The type 'DataConstr' is used to represent value or record constructors
-- introduced by data or newtype declarations.
data
DataConstr
=
DataConstr
Ident
Int
[
Type
]
data
DataConstr
=
DataConstr
Ident
Int
[
Type
]
|
RecordConstr
Ident
Int
[
Ident
]
[
Type
]
deriving
(
Eq
,
Show
)
...
...
@@ -188,6 +189,18 @@ constrIdent :: DataConstr -> Ident
constrIdent
(
DataConstr
c
_
_
)
=
c
constrIdent
(
RecordConstr
c
_
_
_
)
=
c
constrTypes
::
DataConstr
->
[
Type
]
constrTypes
(
DataConstr
_
_
ty
)
=
ty
constrTypes
(
RecordConstr
_
_
_
ty
)
=
ty
recLabels
::
DataConstr
->
[
Ident
]
recLabels
(
DataConstr
_
_
_
)
=
[]
recLabels
(
RecordConstr
_
_
ls
_
)
=
ls
recLabelTypes
::
DataConstr
->
[
Type
]
recLabelTypes
(
DataConstr
_
_
_
)
=
[]
recLabelTypes
(
RecordConstr
_
_
_
tys
)
=
tys
-- We support two kinds of quantifications of types here, universally
-- quantified type schemes (forall alpha . tau(alpha)) and universally
-- and existentially quantified type schemes
...
...
src/Base/Typing.hs
View file @
69d91016
...
...
@@ -11,7 +11,7 @@
-}
module
Base.Typing
(
Typeable
(
..
)
,
argumentTypes
)
where
module
Base.Typing
(
Typeable
(
..
))
where
import
Control.Monad
import
qualified
Control.Monad.State
as
S
(
State
,
evalState
,
gets
,
modify
)
...
...
@@ -25,9 +25,7 @@ import Base.Types
import
Base.TypeSubst
import
Base.Utils
(
foldr2
)
import
Env.TypeConstructor
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
,
conType
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
-- During the transformation of Curry source code into the intermediate
-- language, the compiler has to recompute the types of expressions. This
...
...
@@ -92,16 +90,12 @@ import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue
data
TcState
=
TcState
{
valueEnv
::
ValueEnv
,
tyConsEnv
::
TCEnv
,
typeSubst
::
TypeSubst
,
nextId
::
Int
}
type
TCM
=
S
.
State
TcState
getTyConsEnv
::
TCM
TCEnv
getTyConsEnv
=
S
.
gets
tyConsEnv
getValueEnv
::
TCM
ValueEnv
getValueEnv
=
S
.
gets
valueEnv
...
...
@@ -117,12 +111,12 @@ getNextId = do
S
.
modify
$
\
s
->
s
{
nextId
=
succ
nid
}
return
nid
run
::
TCM
a
->
ValueEnv
->
TCEnv
->
a
run
m
tyEnv
tcEnv
=
S
.
evalState
m
initState
where
initState
=
TcState
tyEnv
tcEnv
idSubst
0
run
::
TCM
a
->
ValueEnv
->
a
run
m
tyEnv
=
S
.
evalState
m
initState
where
initState
=
TcState
tyEnv
idSubst
0
class
Typeable
a
where
typeOf
::
ValueEnv
->
TCEnv
->
a
->
Type
typeOf
::
ValueEnv
->
a
->
Type
instance
Typeable
Ident
where
typeOf
=
computeType
identType
...
...
@@ -136,8 +130,8 @@ instance Typeable Expression where
instance
Typeable
Rhs
where
typeOf
=
computeType
rhsType
computeType
::
(
a
->
TCM
Type
)
->
ValueEnv
->
TCEnv
->
a
->
Type
computeType
f
tyEnv
tcEnv
x
=
normalize
(
run
doComputeType
tyEnv
tcEnv
)
computeType
::
(
a
->
TCM
Type
)
->
ValueEnv
->
a
->
Type
computeType
f
tyEnv
x
=
normalize
(
run
doComputeType
tyEnv
)
where
doComputeType
=
do
ty
<-
f
x
...
...
@@ -276,7 +270,7 @@ rhsType (GuardedRhs es _) = freshTypeVar >>= flip condExprType es
fieldType
::
(
a
->
TCM
Type
)
->
Type
->
Field
a
->
TCM
Type
fieldType
tcheck
ty
(
Field
_
l
x
)
=
do
tyEnv
<-
getValueEnv
TypeArrow
ty1
ty2
<-
inst
Type
(
labelType
l
tyEnv
)
TypeArrow
ty1
ty2
<-
inst
Univ
(
labelType
l
tyEnv
)
unify
ty
ty1
lty
<-
tcheck
x
unify
ty2
lty
...
...
@@ -294,11 +288,6 @@ instType n ty = do
tys
<-
replicateM
n
freshTypeVar
return
(
expandAliasType
tys
ty
)
instType'
::
Int
->
Type
->
TCM
(
Type
,[
Type
])
instType'
n
ty
=
do
tys
<-
replicateM
n
freshTypeVar
return
(
expandAliasType
tys
ty
,
tys
)
instUniv
::
TypeScheme
->
TCM
Type
instUniv
(
ForAll
n
ty
)
=
instType
n
ty
...
...
@@ -357,24 +346,6 @@ unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta
unifyTypes
ty1
ty2
_
=
internalError
$
"Base.Typing.unify: ("
++
show
ty1
++
") ("
++
show
ty2
++
")"
-- The function argumentTypes returns the labels and the argument types
-- of a data constructor instantiated at a particular type. This
-- function is useful for desugaring record patterns and expressions,
-- where the compiler must compute the types of the omitted arguments.
-- Since the type annotation of record patterns and expressions applies
-- to the pattern or expression as a whole, the instance type is
-- unified with the constructor's result type and the resulting
-- substitution is applied to all argument types. Note that this is
-- sound because record fields cannot have existentially quantified
-- types and therefore all type variables appearing in their
-- types occur in the constructor's result type as well.
argumentTypes
::
TCEnv
->
Type
->
QualIdent
->
ValueEnv
->
([
Ident
],[
Type
])
argumentTypes
tcEnv
ty
c
tyEnv
=
(
ls
,
map
(
subst
(
unifyTypes
rty
ty
idSubst
))
tys
)
where
(
ls
,
ForAllExist
_
_
ty'
)
=
conType
c
tyEnv
(
tys
,
rty
)
=
arrowUnapply
ty'
-- The functions 'constrType', 'varType', and 'funType' are used for computing
-- the type of constructors, pattern variables, and variables.
...
...
@@ -396,7 +367,7 @@ funType f tyEnv = case qualLookupValue f tyEnv of
[
Value
_
_
sigma
]
->
sigma
_
->
internalError
$
"Base.Typing.funType: "
++
show
f
labelType
::
Ident
->
ValueEnv
->
TypeScheme
labelType
l
tyEnv
=
case
l
ookupValue
l
tyEnv
of
labelType
::
Qual
Ident
->
ValueEnv
->
TypeScheme
labelType
l
tyEnv
=
case
qualL
ookupValue
l
tyEnv
of
[
Label
_
_
sigma
]
->
sigma
_
->
internalError
$
"Base.Typing.labelType: "
++
show
l
src/Checks.hs
View file @
69d91016
...
...
@@ -57,8 +57,7 @@ syntaxCheck :: Monad m => Check m Module
syntaxCheck
opts
(
env
,
mdl
)
|
null
msgs
=
ok
(
env
{
extensions
=
exts
},
mdl'
)
|
otherwise
=
failMessages
msgs
where
((
mdl'
,
exts
),
msgs
)
=
SC
.
syntaxCheck
opts
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
where
((
mdl'
,
exts
),
msgs
)
=
SC
.
syntaxCheck
opts
(
valueEnv
env
)
mdl
-- |Check the precedences of infix operators.
--
...
...
src/Checks/ExportCheck.hs
View file @
69d91016
...
...
@@ -5,7 +5,7 @@ import Control.Monad (unless)
import
qualified
Control.Monad.State
as
S
(
State
,
runState
,
gets
,
modify
)
import
Data.List
(
nub
,
union
)
import
qualified
Data.Map
as
Map
import
Data.Maybe
(
catMaybes
,
fromMaybe
)
import
Data.Maybe
(
fromMaybe
)
import
qualified
Data.Set
as
Set
import
Curry.Base.Ident
...
...
@@ -136,7 +136,7 @@ expandTypeWith tc xs = do
case
qualLookupTC
tc
tcEnv
of
[]
->
report
(
errUndefinedType
tc
)
>>
return
[]
[
t
@
(
DataType
_
_
cs
)]
->
do
mapM_
(
checkElement
(
concatMap
visibleElems
(
catMaybes
cs
))
)
xs'
mapM_
(
checkElement
(
concatMap
visibleElems
cs
))
xs'
return
[
ExportTypeWith
(
origName
t
)
xs'
]
[
t
@
(
RenamingType
_
_
c
)]
->
do
mapM_
(
checkElement
(
visibleElems
c
))
xs'
...
...
@@ -250,21 +250,25 @@ exportType t = ExportTypeWith tc xs
-- in the interface, we convert an individual export of a label @l@ into
-- the form @T(l)@ whenever its type @T@ occurs in the export list as well.
canonExports
::
[
Export
]
->
[
Export
]
canonExports
es
=
map
(
canonExport
(
canonLabels
tcEnv
es
))
es
canonExports
::
TCEnv
->
[
Export
]
->
[
Export
]
canonExports
tcEnv
es
=
map
(
canonExport
(
canonLabels
tcEnv
es
))
es
canonExport
::
Map
.
Map
QualIdent
Export
->
Export
->
Export
canonExport
ls
(
Export
x
)
=
fromMaybe
(
Export
x
)
(
Map
.
lookup
x
ls
)
canonExport
_
(
ExportTypeWith
tc
xs
)
=
ExportTypeWith
tc
xs
canonExport
_
e
=
internalError
$
"Checks.ExportCheck.canonExport: "
++
show
e
canonLabels
::
TCEnv
->
[
Export
]
->
Map
.
Map
QualIdent
Export
canonLabels
tcEnv
es
=
foldr
bindLabels
Map
.
empty
(
allEntities
tcEnv
)
where
tcs
=
[
tc
|
ExportTypeWith
tc
_
<-
es
]
bindLabels
t
ls
|
tc
`
elem
`
tcs
=
foldr
(
bindLabel
tc
)
ls
(
elements
t
)
|
otherwise
=
ls
where
tc
=
origName
t
bindLabel
tc
x
=
Map
.
insert
(
qualifyLike
tc
x
)
(
ExportTypeWith
tc
[
x
])
where
tcs
=
[
tc
|
ExportTypeWith
tc
_
<-
es
]
bindLabels
t
ls
|
tc'
`
elem
`
tcs
=
foldr
(
bindLabel
tc'
)
ls
(
elements
t
)
|
otherwise
=
ls
where
tc'
=
origName
t
bindLabel
tc
x
=
Map
.
insert
(
qualifyLike
tc
x
)
(
ExportTypeWith
tc
[
x
])
-- The expanded list of exported entities may contain duplicates. These
-- are removed by the function joinExports. In particular, this
...
...
@@ -299,7 +303,7 @@ joinFun export _ = internalError $
-- constrs (AliasType _ _ _) = []
elements
::
TypeInfo
->
[
Ident
]
elements
(
DataType
_
_
cs
)
=
concatMap
visibleElems
$
catMaybes
cs
elements
(
DataType
_
_
cs
)
=
concatMap
visibleElems
cs
elements
(
RenamingType
_
_
c
)
=
visibleElems
c
elements
(
AliasType
_
_
_
)
=
[]
...
...
@@ -320,9 +324,9 @@ errUndefinedType :: QualIdent -> Message
errUndefinedType
tc
=
posMessage
tc
$
hsep
$
map
text
[
"Type"
,
qualName
tc
,
"in export list is not defined"
]
errUndefinedElement
::
Ident
->
Ident
->
Message
errUndefinedElement
::
Qual
Ident
->
Ident
->
Message
errUndefinedElement
tc
c
=
posMessage
c
$
hsep
$
map
text
[
idName
c
,
"is not a constructor or label of type "
,
id
Name
tc
]
[
idName
c
,
"is not a constructor or label of type "
,
qual
Name
tc
]
errModuleNotImported
::
ModuleIdent
->
Message
errModuleNotImported
m
=
posMessage
m
$
hsep
$
map
text
...
...
src/Checks/InterfaceCheck.hs
View file @
69d91016
...
...
@@ -49,7 +49,7 @@ module Checks.InterfaceCheck (interfaceCheck) where
import
Control.Monad
(
unless
)
import
qualified
Control.Monad.State
as
S
import
Data.Maybe
(
catMaybes
,
fromMaybe
)
import
Data.Maybe
(
fromMaybe
)
import
Curry.Base.Ident
import
Curry.Base.Position
...
...
@@ -156,7 +156,7 @@ checkConstrImport tc tvs (ConOpDecl p evs ty1 op ty2) = do
checkConstrImport
tc
tvs
(
RecordDecl
p
evs
c
fs
)
=
do
m
<-
getModuleIdent
let
qc
=
qualifyLike
tc
c
(
ls
,
tys
)
=
unzip
[(
l
,
ty
)
|
FieldDecl
_
ls
ty
<-
fs
,
l
<-
ls
]
(
ls
,
tys
)
=
unzip
[(
l
,
ty
)
|
FieldDecl
_
labe
ls
ty
<-
fs
,
l
<-
labe
ls
]
checkConstr
(
DataConstructor
c'
_
ls'
(
ForAllExist
uqvs
eqvs
ty'
))
=
qc
==
c'
&&
length
evs
==
eqvs
&&
length
tvs
==
uqvs
&&
ls
==
ls'
&&
toQualTypes
m
tvs
tys
==
arrowArgs
ty'
...
...
src/Checks/InterfaceSyntaxCheck.hs
View file @
69d91016
...
...
@@ -25,8 +25,6 @@ module Checks.InterfaceSyntaxCheck (intfSyntaxCheck) where
import
Control.Monad
(
liftM
,
liftM2
)
import
qualified
Control.Monad.State
as
S
import
Data.List
(
nub
,
partition
)
import
Data.Maybe
(
catMaybes
)
import
qualified
Data.Traversable
as
T
(
mapM
)
import
Base.Expr
import
Base.Messages
(
Message
,
posMessage
,
internalError
)
...
...
@@ -63,16 +61,13 @@ intfSyntaxCheck (Interface n is ds) = (Interface n is ds', reverse $ errors s')
-- The latter must not occur in type expressions in interfaces.
bindType
::
IDecl
->
TypeEnv
->
TypeEnv
bindType
(
IInfixDecl
_
_
_
_
)
=
id
bindType
(
HidingDataDecl
_
tc
_
)
=
qualBindTopEnv
tc
(
Data
tc
[]
)
bindType
(
IDataDecl
_
tc
_
cs
)
=
qualBindTopEnv
tc
(
Data
tc
(
map
constr
(
catMaybes
cs
)))
where
constr
(
ConstrDecl
_
_
c
_
)
=
c
constr
(
ConOpDecl
_
_
_
op
_
)
=
op
bindType
(
INewtypeDecl
_
tc
_
nc
)
=
qualBindTopEnv
tc
(
Data
tc
[
nconstr
nc
])
where
nconstr
(
NewConstrDecl
_
_
c
_
)
=
c
bindType
(
ITypeDecl
_
tc
_
_
)
=
qualBindTopEnv
tc
(
Alias
tc
)
bindType
(
IFunctionDecl
_
_
_
_
)
=
id
bindType
(
IInfixDecl
_
_
_
_
)
=
id
bindType
(
HidingDataDecl
_
tc
_
)
=
qualBindTopEnv
tc
(
Data
tc
[]
)
bindType
(
IDataDecl
_
tc
_
cs
_
)
=
qualBindTopEnv
tc
(
Data
tc
(
map
constrId
cs
))
bindType
(
INewtypeDecl
_
tc
_
nc
_
)
=
qualBindTopEnv
tc
(
Data
tc
[
nconstrId
nc
])
bindType
(
ITypeDecl
_
tc
_
_
)
=
qualBindTopEnv
tc
(
Alias
tc
)
bindType
(
IFunctionDecl
_
_
_
_
)
=
id
-- The checks applied to the interface are similar to those performed
-- during syntax checking of type expressions.
...
...
@@ -82,18 +77,30 @@ checkIDecl (IInfixDecl p fix pr op) = return (IInfixDecl p fix pr op)
checkIDecl
(
HidingDataDecl
p
tc
tvs
)
=
do
checkTypeLhs
tvs
return
(
HidingDataDecl
p
tc
tvs
)
checkIDecl
(
IDataDecl
p
tc
tvs
cs
)
=
do
checkIDecl
(
IDataDecl
p
tc
tvs
cs
hs
)
=
do
checkTypeLhs
tvs
liftM
(
IDataDecl
p
tc
tvs
)
(
mapM
(
T
.
mapM
(
checkConstrDecl
tvs
))
cs
)
checkIDecl
(
INewtypeDecl
p
tc
tvs
nc
)
=
do
checkHidden
tc
(
cons
++
labels
)
hs
cs'
<-
mapM
(
checkConstrDecl
tvs
)
cs
return
$
IDataDecl
p
tc
tvs
cs'
hs
where
cons
=
map
constrId
cs
labels
=
nub
$
concatMap
recordLabels
cs
checkIDecl
(
INewtypeDecl
p
tc
tvs
nc
hs
)
=
do
checkTypeLhs
tvs
liftM
(
INewtypeDecl
p
tc
tvs
)
(
checkNewConstrDecl
tvs
nc
)
checkHidden
tc
(
con
:
labels
)
hs
nc'
<-
checkNewConstrDecl
tvs
nc
return
$
INewtypeDecl
p
tc
tvs
nc'
hs
where
con
=
nconstrId
nc
labels
=
nrecordLabels
nc
checkIDecl
(
ITypeDecl
p
tc
tvs
ty
)
=
do
checkTypeLhs
tvs
liftM
(
ITypeDecl
p
tc
tvs
)
(
checkClosedType
tvs
ty
)
checkIDecl
(
IFunctionDecl
p
f
n
ty
)
=
liftM
(
IFunctionDecl
p
f
n
)
(
checkType
ty
)
checkHidden
::
QualIdent
->
[
Ident
]
->
[
Ident
]
->
ISC
()
checkHidden
tc
csls
hs
=
mapM_
(
report
.
errNoElement
tc
)
$
nub
$
filter
(`
notElem
`
csls
)
hs
checkTypeLhs
::
[
Ident
]
->
ISC
()
checkTypeLhs
tvs
=
do
tyEnv
<-
getTypeEnv
...
...
@@ -120,7 +127,7 @@ checkConstrDecl tvs (RecordDecl p evs c fs) = do
checkFieldDecl
::
[
Ident
]
->
FieldDecl
->
ISC
FieldDecl
checkFieldDecl
tvs
(
FieldDecl
p
ls
ty
)
=
liftM
(
FieldDecl
p
ls
ty
)
(
checkClosedType
tvs
ty
)
liftM
(
FieldDecl
p
ls
)
(
checkClosedType
tvs
ty
)
checkNewConstrDecl
::
[
Ident
]
->
NewConstrDecl
->
ISC
NewConstrDecl
checkNewConstrDecl
tvs
(
NewConstrDecl
p
evs
c
ty
)
=
do
...
...
@@ -187,3 +194,9 @@ errUnboundVariable tv = posMessage tv $
errBadTypeSynonym
::
QualIdent
->
Message
errBadTypeSynonym
tc
=
posMessage
tc
$
text
"Synonym type"
<+>
text
(
qualName
tc
)
<+>
text
"in interface"
errNoElement
::
QualIdent
->
Ident
->
Message
errNoElement
tc
x
=
posMessage
tc
$
hsep
$
map
text
[
"Hidden constructor or label "
,
escName
x
,
" is not defined for type "
,
qualName
tc
]
\ No newline at end of file
src/Checks/KindCheck.hs
View file @
69d91016
...
...
@@ -54,7 +54,7 @@ import Env.TypeConstructor (TCEnv, tcArity)
kindCheck
::
TCEnv
->
Module
->
(
Module
,
[
Message
])
kindCheck
tcEnv
mdl
@
(
Module
_
m
_
_
ds
)
=
case
findMultiples
$
map
typeConstr
tds
of
[]
->
runKCM
(
mapM
checkModule
mdl
)
state
[]
->
runKCM
(
checkModule
mdl
)
state
tss
->
(
mdl
,
map
errMultipleDeclaration
tss
)
where
tds
=
filter
isTypeDecl
ds
kEnv
=
foldr
(
bindKind
m
)
(
fmap
tcArity
tcEnv
)
tds
...
...
@@ -104,7 +104,7 @@ qualLookupKind :: QualIdent -> KindEnv -> [Int]
qualLookupKind
=
qualLookupTopEnv
checkModule
::
Module
->
KCM
Module
checkModule
(
Module
ps
m
es
is
ds
)
=
Module
ps
m
es
is
`
liftM
`
mapM
checkDecl
ds
checkModule
(
Module
ps
m
es
is
ds
)
=
Module
ps
m
es
is
<$>
mapM
checkDecl
ds
-- When type declarations are checked, the compiler will allow anonymous
-- type variables on the left hand side of the declaration, but not on
...
...
@@ -156,7 +156,7 @@ checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
evs'
<-
checkTypeLhs
evs
ty'
<-
checkClosedType
(
evs'
++
tvs
)
ty
return
$
NewConstrDecl
p
evs'
c
ty'
checkNewConstrDecl
tvs
(
NewRecordDecl
p
evs
c
(
l
,
ty
))
checkNewConstrDecl
tvs
(
NewRecordDecl
p
evs
c
(
l
,
ty
))
=
do
evs'
<-
checkTypeLhs
evs
ty'
<-
checkClosedType
(
evs'
++
tvs
)
ty
return
$
NewRecordDecl
p
evs'
c
(
l
,
ty'
)
...
...
src/Checks/PrecCheck.hs
View file @
69d91016
...
...
@@ -33,7 +33,7 @@ import Curry.Syntax
import
Base.Expr
import
Base.Messages
(
Message
,
posMessage
)
import
Base.Utils
(
constrId
,
findDouble
)
import
Base.Utils
(
findDouble
)
import
Env.OpPrec
(
OpPrecEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
,
mkPrec
,
qualLookupP
)
...
...
src/Checks/SyntaxCheck.hs
View file @
69d91016
...
...
@@ -26,11 +26,10 @@
module
Checks.SyntaxCheck
(
syntaxCheck
)
where
import
Control.Applicative
((
<$>
),
(
<*>
))
import
Control.Monad
(
forM_
,
unless
,
when
)
import
Control.Monad
(
unless
,
when
)
import
qualified
Control.Monad.State
as
S
(
State
,
runState
,
gets
,
modify
)
import
Data.List
((
\\
),
insertBy
,
intersect
,
nub
,
partition
)
import
Data.Maybe
(
fromJust
,
isJust
,
isNothing
,
maybeToList
)
import
Data.List
(
insertBy
,
intersect
,
nub
,
partition
)
import
Data.Maybe
(
isJust
,
isNothing
)
import
qualified
Data.Set
as
Set
(
empty
,
insert
,
member
)
import
Curry.Base.Ident
...
...
@@ -42,10 +41,8 @@ import Curry.Syntax.Pretty (ppPattern)
import
Base.Expr
import
Base.Messages
(
Message
,
posMessage
,
internalError
)
import
Base.NestEnv
import
Base.Types
import
Base.Utils
((
++!
),
findDouble
,
findMultiples
)
import
Env.TypeConstructor
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
))
import
CompilerOpts
...
...
@@ -59,15 +56,15 @@ import CompilerOpts
-- generated. Finally, all declarations are checked within the resulting
-- environment. In addition, this process will also rename the local variables.
syntaxCheck
::
Options
->
ValueEnv
->
TCEnv
->
Module
syntaxCheck
::
Options
->
ValueEnv
->
Module
->
((
Module
,
[
KnownExtension
]),
[
Message
])
syntaxCheck
opts
tyEnv
tcEnv
mdl
@
(
Module
_
m
_
_
ds
)
=
case
findMultiples
$
concatMap
constr
Id
tds
of
syntaxCheck
opts
tyEnv
mdl
@
(
Module
_
m
_
_
ds
)
=
case
findMultiples
$
concatMap
constr
s
tds
of
[]
->
runSC
(
checkModule
mdl
)
state
css
->
((
mdl
,
exts
),
map
errMultipleDataConstructor
css
)
where
tds
=
filter
isTypeDecl
ds
rEnv
=
globalEnv
$
fmap
(
renameInfo
tcEnv
)
tyEnv
rEnv
=
globalEnv
$
fmap
renameInfo
tyEnv
state
=
initState
exts
m
rEnv
exts
=
optExtensions
opts
...
...
@@ -206,10 +203,10 @@ ppRenameInfo (LocalVar n _) = text (escName n)
-- Furthermore, it is not allowed to declare a label more than once.
renameInfo
::
ValueInfo
->
RenameInfo
renameInfo
(
DataConstructor
qid
a
_
)
=
Constr
qid
a
renameInfo
(
NewtypeConstructor
qid
_
)
=
Constr
qid
1
renameInfo
(
Value
qid
a
_
)
=
GlobalVar
qid
a
renameInfo
(
Label
qid
cs
_
)
=
RecordLabel
qid
cs
renameInfo
(
DataConstructor
qid
a
_
_
)
=
Constr
qid
a
renameInfo
(
NewtypeConstructor
qid
_
_
)
=
Constr
qid
1
renameInfo
(
Value
qid
a
_
)
=
GlobalVar
qid
a
renameInfo
(
Label
qid
cs
_
)
=
RecordLabel
qid
cs
bindGlobal
::
ModuleIdent
->
Ident
->
RenameInfo
->
RenameEnv
->
RenameEnv
bindGlobal
m
c
r
=
bindNestEnv
c
r
.
qualBindNestEnv
(
qualifyWith
m
c
)
r
...
...
@@ -221,7 +218,7 @@ bindLocal = bindNestEnv
-- |Bind type constructor information and record label information
bindTypeDecl
::
Decl
->
SCM
()
bindTypeDecl
(
DataDecl
_
_
_
cs
)
=
mapM_
bindConstr
cs
>>
bindLabels
cs
bindTypeDecl
(
DataDecl
_
_
_
cs
)
=
mapM_
bindConstr
cs
>>
bind
Record
Labels
cs
bindTypeDecl
(
NewtypeDecl
_
_
_
nc
)
=
bindNewConstr
nc
bindTypeDecl
_
=
return
()
...
...
@@ -234,7 +231,6 @@ bindConstr (ConOpDecl _ _ _ op _) = do
modifyRenameEnv
$
bindGlobal
m
op
(
Constr
(
qualifyWith
m
op
)
2
)
bindConstr
(
RecordDecl
_
_
c
fs
)
=
do
m
<-
getModuleIdent
mapM_
bindRecordLabel
labels
modifyRenameEnv
$
bindGlobal
m
c
(
Constr
(
qualifyWith
m
c
)
(
length
labels
))
where
labels
=
[
l
|
FieldDecl
_
ls
_
<-
fs
,
l
<-
ls
]
...
...
@@ -251,10 +247,10 @@ bindRecordLabels :: [ConstrDecl] -> SCM ()
bindRecordLabels
cs
=
mapM_
bindRecordLabel
[(
l
,
constr
l
)
|
l
<-
nub
(
concatMap
recordLabels
cs
)]
where
constr
l
=
[
constrId
c
|
c
<-
cs
,
l
`
elem
`
recordLabels
c
]
bindRecordLabel
::
(
Ident
,
[
Ident
])
->
SCM
()
bindRecordLabel
(
l
,
cs
)
=
do
m
<-
getModuleIdent
m
<-
getModuleIdent
new
<-
(
null
.
lookupVar
l
)
<$>
getRenameEnv
unless
new
$
report
$
errDuplicateDefinition
l
modifyRenameEnv
$
bindGlobal
m
l
$
...
...
@@ -331,7 +327,7 @@ checkModule (Module ps m es is ds) = do
ds'
<-
(
tds
++
)
<$>
checkTopDecls
vds
exts
<-
getExtensions
return
(
Module
ps
m
es
is
ds'
,
exts
)
where
(
tds
,
vds
)
=
partition
isTypeDecl
d
ecl
s
where
(
tds
,
vds
)
=
partition
isTypeDecl
ds
checkPragma
::
ModulePragma
->
SCM
()
checkPragma
(
LanguagePragma
_
exts
)
=
mapM_
checkExtension
exts
...
...
@@ -505,8 +501,9 @@ checkDeclRhs _ d = return d
-- jrt: added for Haskell's record syntax
checkDeclLabels
::
ConstrDecl
->
SCM
ConstrDecl
checkDeclLabels
rd
@
(
RecordDecl
p
evs
c
fs
)
=
do
onJust
(
report
.
errDuplicateLabel
"declaration"
)
(
findDouble
labels
)
checkDeclLabels
rd
@
(
RecordDecl
_
_
_
fs
)
=
do
onJust
(
report
.
errDuplicateLabel
"declaration"
)
(
findDouble
$
map
qualify
labels
)
return
rd
where
onJust
=
maybe
(
return
()
)
...
...
@@ -550,6 +547,8 @@ checkParenPattern o (InfixPattern t1 op t2) =
++
checkParenPattern
Nothing
t1
++
checkParenPattern
Nothing
t2
checkParenPattern
_
(
ParenPattern
t
)
=
checkParenPattern
Nothing
t
checkParenPattern
_
(
RecordPattern
_
fs
)
=
concatMap
(
\
(
Field
_
_
t
)
->
checkParenPattern
Nothing
t
)
fs
checkParenPattern
_
(
TuplePattern
_
ts
)
=
concatMap
(
checkParenPattern
Nothing
)
ts
checkParenPattern
_
(
ListPattern
_
ts
)
=
...
...
@@ -563,8 +562,6 @@ checkParenPattern _ (FunctionPattern _ ts) =
checkParenPattern
o
(
InfixFuncPattern
t1
op
t2
)
=
maybe
[]
(
\
c
->
[(
c
,
op
)])
o
++
checkParenPattern
Nothing
t1
++
checkParenPattern
Nothing
t2
checkParenPattern
_
(
RecordPattern
_
fs
)
=
concatMap
(
\
(
Field
_
_
t
)
->
checkParenPattern
Nothing
t
)
fs
checkPattern
::
Position
->
Pattern
->
SCM
Pattern
checkPattern
_
(
LiteralPattern
l
)
=
...
...
@@ -580,6 +577,8 @@ checkPattern p (InfixPattern t1 op t2) =
checkInfixPattern
p
t1
op
t2
checkPattern
p
(
ParenPattern
t
)
=
ParenPattern
<$>
checkPattern
p
t
checkPattern
p
(
RecordPattern
c
fs
)
=
checkRecordPattern
p
c
fs
checkPattern
p
(
TuplePattern
pos
ts
)
=
TuplePattern
pos
<$>
mapM
(
checkPattern
p
)
ts
checkPattern
p
(
ListPattern
pos
ts
)
=
...
...
@@ -588,8 +587,6 @@ checkPattern p (AsPattern v t) = do
AsPattern
<$>
checkVar
"@ pattern"
v
<*>
checkPattern
p
t
checkPattern
p
(
LazyPattern
pos
t
)
=
LazyPattern
pos
<$>
checkPattern
p
t
checkPattern
p
(
RecordPattern
c
fs
)
=
checkRecordPattern
p
c
fs
checkPattern
_
(
FunctionPattern
_
_
)
=
internalError
$
"SyntaxCheck.checkPattern: function pattern not defined"
checkPattern
_
(
InfixFuncPattern
_
_
_
)
=
internalError
$
...
...
@@ -669,7 +666,7 @@ checkRecordPattern p c fs = do
case
qualLookupVar
c
env
of
[
Constr
c'
_
]
->
processRecPat
(
Just
c'
)
fs
rs
->
case
qualLookupVar
(
qualQualify
m
c
)
env
of
[