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
99e0b121
Commit
99e0b121
authored
Mar 04, 2015
by
Jan Rasmus Tikovsky
Browse files
Merge branch 'records'
parents
efc6fb5a
e4a420e9
Changes
37
Expand all
Hide whitespace changes
Inline
Side-by-side
src/Base/CurryTypes.hs
View file @
99e0b121
...
...
@@ -3,6 +3,7 @@
Description : Conversion of type representation
Copyright : (c) Wolfgang Lux
2011 - 2012 Björn Peemöller
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -67,10 +68,6 @@ toType' tvs (CS.ListType ty)
=
TypeConstructor
(
qualify
listId
)
[
toType'
tvs
ty
]
toType'
tvs
(
CS
.
ArrowType
ty1
ty2
)
=
TypeArrow
(
toType'
tvs
ty1
)
(
toType'
tvs
ty2
)
toType'
tvs
(
CS
.
RecordType
fs
)
=
TypeRecord
fs'
where
fs'
=
concatMap
(
\
(
ls
,
ty
)
->
map
(
\
l
->
(
l
,
toType'
tvs
ty
))
ls
)
fs
fromQualType
::
ModuleIdent
->
Type
->
CS
.
TypeExpr
fromQualType
m
=
fromType
.
unqualifyType
m
...
...
@@ -90,8 +87,6 @@ fromType (TypeArrow ty1 ty2) =
CS
.
ArrowType
(
fromType
ty1
)
(
fromType
ty2
)
fromType
(
TypeSkolem
k
)
=
CS
.
VariableType
$
mkIdent
$
"_?"
++
show
k
fromType
(
TypeRecord
fs
)
=
CS
.
RecordType
(
map
(
\
(
l
,
ty
)
->
([
l
],
fromType
ty
))
fs
)
-- The following functions implement pretty-printing for types.
ppType
::
ModuleIdent
->
Type
->
Doc
...
...
src/Base/Expr.hs
View file @
99e0b121
...
...
@@ -3,6 +3,7 @@
Description : Extraction of free and bound variables
Copyright : (c) Wolfgang Lux
2011 - 2012 Björn Peemöller
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -93,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
...
...
@@ -110,9 +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
(
RecordSelection
e
_
)
=
qfv
m
e
qfv
m
(
RecordUpdate
fs
e
)
=
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
r
)
=
maybe
[]
bv
r
++
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
r
)
=
maybe
[]
(
qfv
m
)
r
++
qfv
m
fs
instance
Expr
TypeExpr
where
fv
(
ConstructorType
_
tys
)
=
fv
tys
...
...
@@ -180,7 +180,6 @@ instance Expr TypeExpr where
fv
(
TupleType
tys
)
=
fv
tys
fv
(
ListType
ty
)
=
fv
ty
fv
(
ArrowType
ty1
ty2
)
=
fv
ty1
++
fv
ty2
fv
(
RecordType
fs
)
=
fv
(
map
snd
fs
)
filterBv
::
QuantExpr
e
=>
e
->
[
Ident
]
->
[
Ident
]
filterBv
e
=
filter
(`
Set
.
notMember
`
Set
.
fromList
(
bv
e
))
...
...
src/Base/TopEnv.hs
View file @
99e0b121
...
...
@@ -43,6 +43,7 @@ module Base.TopEnv
,
bindTopEnv
,
qualBindTopEnv
,
rebindTopEnv
,
qualRebindTopEnv
,
unbindTopEnv
,
lookupTopEnv
,
qualLookupTopEnv
,
allImports
,
moduleImports
,
localBindings
,
allLocalBindings
,
allEntities
)
where
import
Control.Arrow
(
second
)
...
...
@@ -161,3 +162,6 @@ localBindings env = [ (x, y) | (x, (Local, y)) <- unqualBindings env ]
allLocalBindings
::
TopEnv
a
->
[(
QualIdent
,
a
)]
allLocalBindings
(
TopEnv
env
)
=
[
(
x
,
y
)
|
(
x
,
ys
)
<-
Map
.
toList
env
,
(
Local
,
y
)
<-
ys
]
allEntities
::
TopEnv
a
->
[
a
]
allEntities
(
TopEnv
env
)
=
[
y
|
(
_
,
ys
)
<-
Map
.
toList
env
,
(
_
,
y
)
<-
ys
]
src/Base/TypeSubst.hs
View file @
99e0b121
...
...
@@ -44,8 +44,6 @@ instance SubstType Type where
subst
sigma
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
subst
sigma
ty1
)
(
subst
sigma
ty2
)
subst
_
ts
@
(
TypeSkolem
_
)
=
ts
subst
sigma
(
TypeRecord
fs
)
=
TypeRecord
fs'
where
fs'
=
map
(
\
(
l
,
ty
)
->
(
l
,
subst
sigma
ty
))
fs
instance
SubstType
TypeScheme
where
subst
sigma
(
ForAll
n
ty
)
=
...
...
@@ -56,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
...
...
@@ -82,8 +80,6 @@ expandAliasType _ (TypeConstrained tys n) = TypeConstrained tys n
expandAliasType
tys
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
expandAliasType
tys
ty1
)
(
expandAliasType
tys
ty2
)
expandAliasType
_
tsk
@
(
TypeSkolem
_
)
=
tsk
expandAliasType
tys
(
TypeRecord
fs
)
=
TypeRecord
fs'
where
fs'
=
map
(
\
(
l
,
ty
)
->
(
l
,
expandAliasType
tys
ty
))
fs
normalize
::
Type
->
Type
normalize
ty
=
expandAliasType
[
TypeVariable
(
occur
tv
)
|
tv
<-
[
0
..
]]
ty
...
...
src/Base/Types.hs
View file @
99e0b121
...
...
@@ -3,6 +3,7 @@
Description : Internal representation of types
Copyright : (c) 2002 - 2004 Wolfgang Lux
Martin Engelke
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -17,10 +18,11 @@
module
Base.Types
(
-- * Representation of Types
Type
(
..
),
isArrowType
,
arrowArity
,
arrowArgs
,
arrowBase
,
typeVars
,
typeConstrs
,
typeSkolems
,
equTypes
,
qualifyType
,
unqualifyType
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
...
...
@@ -40,7 +42,6 @@ import Curry.Base.Ident
-- from the constraint list.
-- The case 'TypeSkolem' is used for handling skolem types, which
-- result from the use of existentially quantified data constructors.
-- Finally, 'TypeRecord' is used for records.
-- Type variables are represented with deBruijn style indices. Universally
-- quantified type variables are assigned indices in the order of their
...
...
@@ -57,7 +58,6 @@ data Type
|
TypeArrow
Type
Type
|
TypeConstrained
[
Type
]
Int
|
TypeSkolem
Int
|
TypeRecord
[(
Ident
,
Type
)]
deriving
(
Eq
,
Show
)
-- The function 'isArrowType' checks whether a type is a function
...
...
@@ -81,6 +81,11 @@ arrowBase :: Type -> Type
arrowBase
(
TypeArrow
_
ty
)
=
arrowBase
ty
arrowBase
ty
=
ty
arrowUnapply
::
Type
->
([
Type
],
Type
)
arrowUnapply
(
TypeArrow
ty1
ty2
)
=
(
ty1
:
tys
,
ty
)
where
(
tys
,
ty
)
=
arrowUnapply
ty2
arrowUnapply
ty
=
(
[]
,
ty
)
-- The functions 'typeVars', 'typeConstrs', 'typeSkolems' return a list of all
-- type variables, type constructors, or skolems occurring in a type t,
-- respectively. Note that 'TypeConstrained' variables are not included in the
...
...
@@ -93,7 +98,6 @@ typeVars ty = vars ty [] where
vars
(
TypeConstrained
_
_
)
tvs
=
tvs
vars
(
TypeArrow
ty1
ty2
)
tvs
=
vars
ty1
(
vars
ty2
tvs
)
vars
(
TypeSkolem
_
)
tvs
=
tvs
vars
(
TypeRecord
fs
)
tvs
=
foldr
vars
tvs
(
map
snd
fs
)
typeConstrs
::
Type
->
[
QualIdent
]
typeConstrs
ty
=
constrs
ty
[]
where
...
...
@@ -102,7 +106,6 @@ typeConstrs ty = constrs ty [] where
constrs
(
TypeConstrained
_
_
)
tcs
=
tcs
constrs
(
TypeArrow
ty1
ty2
)
tcs
=
constrs
ty1
(
constrs
ty2
tcs
)
constrs
(
TypeSkolem
_
)
tcs
=
tcs
constrs
(
TypeRecord
fs
)
tcs
=
foldr
constrs
tcs
(
map
snd
fs
)
typeSkolems
::
Type
->
[
Int
]
typeSkolems
ty
=
skolems
ty
[]
where
...
...
@@ -111,7 +114,6 @@ typeSkolems ty = skolems ty [] where
skolems
(
TypeConstrained
_
_
)
sks
=
sks
skolems
(
TypeArrow
ty1
ty2
)
sks
=
skolems
ty1
(
skolems
ty2
sks
)
skolems
(
TypeSkolem
k
)
sks
=
k
:
sks
skolems
(
TypeRecord
fs
)
sks
=
foldr
skolems
sks
(
map
snd
fs
)
-- The function 'equTypes' computes whether two types are equal modulo
-- renaming of type variables.
...
...
@@ -134,8 +136,6 @@ equTypes t1 t2 = fst (equ [] t1 t2)
in
(
res1
&&
res2
,
is2
)
equ
is
(
TypeSkolem
i1
)
(
TypeSkolem
i2
)
=
equVar
is
i1
i2
equ
is
(
TypeRecord
fs1
)
(
TypeRecord
fs2
)
=
equRecords
is
fs1
fs2
equ
is
_
_
=
(
False
,
is
)
...
...
@@ -143,15 +143,6 @@ equTypes t1 t2 = fst (equ [] t1 t2)
Nothing
->
(
True
,
(
i1
,
i2
)
:
is
)
Just
i2'
->
(
i2
==
i2'
,
is
)
equRecords
is
fs1
fs2
|
length
fs1
==
length
fs2
=
equrec
is
fs1
fs2
|
otherwise
=
(
False
,
is
)
equrec
is
[]
_
=
(
True
,
is
)
equrec
is
((
l1
,
ty1
)
:
fs1
)
fs2
=
let
(
res1
,
is1
)
=
maybe
(
False
,
is
)
(
equ
is
ty1
)
(
lookup
l1
fs2
)
(
res2
,
is2
)
=
equrec
is1
fs1
fs2
in
(
res1
&&
res2
,
is2
)
equs
is
[]
[]
=
(
True
,
is
)
equs
is
(
t1'
:
ts1
)
(
t2'
:
ts2
)
=
let
(
res1
,
is1
)
=
equ
is
t1'
t2'
...
...
@@ -177,8 +168,6 @@ qualifyType m (TypeConstrained tys tv) =
qualifyType
m
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
qualifyType
m
ty1
)
(
qualifyType
m
ty2
)
qualifyType
_
skol
@
(
TypeSkolem
_
)
=
skol
qualifyType
m
(
TypeRecord
fs
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
qualifyType
m
ty
))
fs
)
unqualifyType
::
ModuleIdent
->
Type
->
Type
unqualifyType
m
(
TypeConstructor
tc
tys
)
=
...
...
@@ -189,16 +178,28 @@ unqualifyType m (TypeConstrained tys tv) =
unqualifyType
m
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
unqualifyType
m
ty1
)
(
unqualifyType
m
ty2
)
unqualifyType
_
skol
@
(
TypeSkolem
_
)
=
skol
unqualifyType
m
(
TypeRecord
fs
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
unqualifyType
m
ty
))
fs
)
-- The type 'DataConstr' is used to represent value constructors introduced
-- by data or newtype declarations.
data
DataConstr
=
DataConstr
Ident
Int
[
Type
]
-- The type 'DataConstr' is used to represent value or record constructors
-- introduced by data or newtype declarations.
data
DataConstr
=
DataConstr
Ident
Int
[
Type
]
|
RecordConstr
Ident
Int
[
Ident
]
[
Type
]
deriving
(
Eq
,
Show
)
constrIdent
::
DataConstr
->
Ident
constrIdent
(
DataConstr
c
_
_
)
=
c
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
...
...
src/Base/Typing.hs
View file @
99e0b121
...
...
@@ -2,7 +2,7 @@
Module : $Header$
Description : Type computation of Curry expressions
Copyright : (c) 2003 - 2006 Wolfgang Lux
2014
Jan Tikovsky
2014
- 2015
Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -25,8 +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
)
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
...
...
@@ -91,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
...
...
@@ -116,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
...
...
@@ -135,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
...
...
@@ -176,6 +171,11 @@ argType (ConstructorPattern c ts) = do
argType
(
InfixPattern
t1
op
t2
)
=
argType
(
ConstructorPattern
op
[
t1
,
t2
])
argType
(
ParenPattern
t
)
=
argType
t
argType
(
RecordPattern
c
fs
)
=
do
tyEnv
<-
getValueEnv
ty
<-
liftM
arrowBase
$
instUnivExist
$
constrType
c
tyEnv
mapM_
(
fieldType
argType
ty
)
fs
return
ty
argType
(
TuplePattern
_
ts
)
|
null
ts
=
return
unitType
|
otherwise
=
liftM
tupleType
$
mapM
argType
ts
...
...
@@ -194,26 +194,6 @@ argType (FunctionPattern f ts) = do
where
flatten
(
TypeArrow
ty1
ty2
)
=
ty1
:
flatten
ty2
flatten
ty
=
[
ty
]
argType
(
InfixFuncPattern
t1
op
t2
)
=
argType
(
FunctionPattern
op
[
t1
,
t2
])
argType
(
RecordPattern
fs
_
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
TypeRecord
fts'
,
tys
)
<-
instType'
n
rty
fts
<-
mapM
fieldPattType
fs
theta
<-
getTypeSubst
let
theta'
=
foldr
(
unifyTypedLabels
fts'
)
theta
fts
modifyTypeSubst
(
const
theta'
)
return
(
subst
theta'
$
TypeConstructor
qi
tys
)
info
->
internalError
$
"Base.Typing.argType: Expected record type but got "
++
show
info
fieldPattType
::
Field
Pattern
->
TCM
(
Ident
,
Type
)
fieldPattType
(
Field
_
l
t
)
=
do
tyEnv
<-
getValueEnv
lty
<-
instUniv
(
labelType
l
tyEnv
)
ty
<-
argType
t
unify
lty
ty
return
(
l
,
lty
)
exprType
::
Expression
->
TCM
Type
exprType
(
Literal
l
)
=
litType
l
...
...
@@ -225,6 +205,15 @@ exprType (Constructor c) = do
instUnivExist
(
constrType
c
tyEnv
)
exprType
(
Typed
e
_
)
=
exprType
e
exprType
(
Paren
e
)
=
exprType
e
exprType
(
Record
c
fs
)
=
do
tyEnv
<-
getValueEnv
ty
<-
liftM
arrowBase
$
instUnivExist
$
constrType
c
tyEnv
mapM_
(
fieldType
exprType
ty
)
fs
return
ty
exprType
(
RecordUpdate
e
fs
)
=
do
ty
<-
exprType
e
mapM_
(
fieldType
exprType
ty
)
fs
return
ty
exprType
(
Tuple
_
es
)
|
null
es
=
return
unitType
|
otherwise
=
liftM
tupleType
$
mapM
exprType
es
...
...
@@ -270,50 +259,6 @@ exprType (Case _ _ _ alts) = freshTypeVar >>= flip altType alts
where
altType
ty
[]
=
return
ty
altType
ty
(
Alt
_
_
rhs
:
alts1
)
=
rhsType
rhs
>>=
unify
ty
>>
altType
ty
alts1
exprType
(
RecordConstr
fs
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
TypeRecord
fts'
,
tys
)
<-
instType'
n
rty
fts
<-
mapM
fieldExprType
fs
theta
<-
getTypeSubst
let
theta'
=
foldr
(
unifyTypedLabels
fts'
)
theta
fts
modifyTypeSubst
(
const
theta'
)
return
(
subst
theta'
$
TypeConstructor
qi
tys
)
info
->
internalError
$
"Base.Typing.exprType: Expected record type but got "
++
show
info
exprType
(
RecordSelection
e
l
)
=
do
recInfo
<-
getRecordInfo
l
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
TypeRecord
fts
,
tys
)
<-
instType'
n
rty
ety
<-
exprType
e
let
rtc
=
TypeConstructor
qi
tys
case
lookup
l
fts
of
Just
lty
->
do
unify
ety
rtc
theta
<-
getTypeSubst
return
(
subst
theta
lty
)
Nothing
->
internalError
"Base.Typing.exprType: Field not found."
info
->
internalError
$
"Base.Typing.exprType: Expected record type but got "
++
show
info
exprType
(
RecordUpdate
fs
e
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
TypeRecord
fts'
,
tys
)
<-
instType'
n
rty
-- Type check field updates
fts
<-
mapM
fieldExprType
fs
modifyTypeSubst
(
\
s
->
foldr
(
unifyTypedLabels
fts'
)
s
fts
)
-- Type check record expression to be updated
ety
<-
exprType
e
let
rtc
=
TypeConstructor
qi
tys
unify
ety
rtc
-- Return inferred type
theta
<-
getTypeSubst
return
(
subst
theta
rtc
)
info
->
internalError
$
"Base.Typing.exprType: Expected record type but got "
++
show
info
rhsType
::
Rhs
->
TCM
Type
rhsType
(
SimpleRhs
_
e
_
)
=
exprType
e
...
...
@@ -322,13 +267,14 @@ rhsType (GuardedRhs es _) = freshTypeVar >>= flip condExprType es
condExprType
ty
(
CondExpr
_
_
e
:
es1
)
=
exprType
e
>>=
unify
ty
>>
condExprType
ty
es1
field
Expr
Type
::
Field
Expression
->
TCM
(
Ident
,
Type
)
field
Expr
Type
(
Field
_
l
e
)
=
do
fieldType
::
(
a
->
TCM
Type
)
->
Type
->
Field
a
->
TCM
Type
fieldType
tcheck
ty
(
Field
_
l
x
)
=
do
tyEnv
<-
getValueEnv
lty
<-
instUniv
(
labelType
l
tyEnv
)
ty
<-
exprType
e
unify
lty
ty
return
(
l
,
lty
)
TypeArrow
ty1
ty2
<-
instUniv
(
labelType
l
tyEnv
)
unify
ty
ty1
lty
<-
tcheck
x
unify
ty2
lty
return
lty
-- In order to avoid name conflicts with non-generalized type variables
-- in a type we instantiate quantified type variables using non-negative
...
...
@@ -342,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
...
...
@@ -402,43 +343,9 @@ unifyTypes (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) theta =
unifyTypes
ty11
ty21
(
unifyTypes
ty12
ty22
theta
)
unifyTypes
(
TypeSkolem
k1
)
(
TypeSkolem
k2
)
theta
|
k1
==
k2
=
theta
unifyTypes
(
TypeRecord
fs1
)
(
TypeRecord
fs2
)
theta
|
length
fs1
==
length
fs2
=
foldr
(
unifyTypedLabels
fs1
)
theta
fs2
unifyTypes
ty1
ty2
_
=
internalError
$
"Base.Typing.unify: ("
++
show
ty1
++
") ("
++
show
ty2
++
")"
-- jrt 2014-10-20: Deactivated because the parser can not parse
-- record extensions, thus, these cases should never occur. If they do,
-- there must be an error somewhere ...
-- unifyTypes tr1@(TypeRecord fs1 Nothing) (TypeRecord fs2 (Just a2)) theta =
-- unifyTypes (TypeVariable a2)
-- tr1
-- (foldr (unifyTypedLabels fs1) theta fs2)
-- unifyTypes tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) theta =
-- unifyTypes tr2 tr1 theta
-- unifyTypes (TypeRecord fs1 (Just a1)) (TypeRecord fs2 (Just a2)) theta =
-- unifyTypes (TypeVariable a1)
-- (TypeVariable a2)
-- (foldr (unifyTypedLabels fs1) theta fs2)
unifyTypedLabels
::
[(
Ident
,
Type
)]
->
(
Ident
,
Type
)
->
TypeSubst
->
TypeSubst
unifyTypedLabels
fs1
(
l
,
ty
)
theta
=
maybe
theta
(
\
ty1
->
unifyTypes
ty1
ty
theta
)
(
lookup
l
fs1
)
getFieldIdent
::
[
Field
a
]
->
TCM
Ident
getFieldIdent
[]
=
internalError
"Base.Typing.getFieldIdent: empty field"
getFieldIdent
(
Field
_
i
_
:
_
)
=
return
i
-- Lookup record type for given field identifier
getRecordInfo
::
Ident
->
TCM
[
TypeInfo
]
getRecordInfo
i
=
do
tyEnv
<-
getValueEnv
tcEnv
<-
getTyConsEnv
case
lookupValue
i
tyEnv
of
[
Label
_
r
_
]
->
return
(
qualLookupTC
r
tcEnv
)
_
->
internalError
$
"Base.Typing.getRecordInfo: No record found for identifier "
++
show
i
-- The functions 'constrType', 'varType', and 'funType' are used for computing
-- the type of constructors, pattern variables, and variables.
...
...
@@ -446,21 +353,23 @@ getRecordInfo i = do
constrType
::
QualIdent
->
ValueEnv
->
ExistTypeScheme
constrType
c
tyEnv
=
case
qualLookupValue
c
tyEnv
of
[
DataConstructor
_
_
sigma
]
->
sigma
[
NewtypeConstructor
_
sigma
]
->
sigma
[
DataConstructor
_
_
_
sigma
]
->
sigma
[
NewtypeConstructor
_
_
sigma
]
->
sigma
_
->
internalError
$
"Base.Typing.constrType: "
++
show
c
varType
::
Ident
->
ValueEnv
->
TypeScheme
varType
v
tyEnv
=
case
lookupValue
v
tyEnv
of
[
Value
_
_
sigma
]
->
sigma
[
Label
_
_
sigma
]
->
sigma
_
->
internalError
$
"Base.Typing.varType: "
++
show
v
funType
::
QualIdent
->
ValueEnv
->
TypeScheme
funType
f
tyEnv
=
case
qualLookupValue
f
tyEnv
of
[
Value
_
_
sigma
]
->
sigma
[
Label
_
_
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 @
99e0b121
...
...
@@ -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 @
99e0b121
...
...
@@ -13,11 +13,12 @@
-}
module
Checks.ExportCheck
(
exportCheck
)
where
import
Control.Monad
(
liftM
,
unless
)
import
Control.Applicative
((
<$>
))
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
(
Map
,
elems
,
empty
,
insert
With
,
toList
)
import
qualified
Data.Map
as
Map
(
Map
,
elems
,
empty
,
insert
,
insertWith
,
lookup
,
toList
)
import
Data.Maybe
(
fromMaybe
)
import
qualified
Data.Set
as
Set
(
Set
,
empty
,
fromList
,
insert
,
member
,
toList
)
...
...
@@ -28,14 +29,14 @@ import Curry.Base.Pretty
import
Curry.Syntax
import
Base.Messages
(
Message
,
internalError
,
posMessage
)
import
Base.TopEnv
(
origName
,
localBindings
,
moduleImports
)
import
Base.Types
(
DataConstr
(
..
),
Type
(
..
))
import
Base.TopEnv
(
allEntities
,
origName
,
localBindings
,
moduleImports
)
import
Base.Types
(
DataConstr
(
..
),
ExistTypeScheme
(
..
),
Type
(
..
)
,
TypeScheme
(
..
),
arrowBase
,
constrIdent
,
recLabels
)
import
Base.Utils
(
findMultiples
)
import
Env.ModuleAlias
(
AliasEnv
)
import
Env.TypeConstructor
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
qualLookupValue
)
-- ---------------------------------------------------------------------------
-- Check and expansion of the export statement
...
...
@@ -47,7 +48,8 @@ exportCheck m aEnv tcEnv tyEnv spec = case expErrs of
[]
->
(
Just
$
Exporting
NoPos
exports
,
ambiErrs
)
ms
->
(
spec
,
ms
)
where
(
exports
,
expErrs
)
=
runECM
(
joinExports
`
liftM
`
expandSpec
spec
)
initState
(
exports
,
expErrs
)
=
runECM
((
joinExports
.
canonExports
tcEnv
)
<$>
expandSpec
spec
)
initState
initState
=
ECState
m
imported
tcEnv
tyEnv
[]
imported
=
Set
.
fromList
$
Map
.
elems
aEnv
...
...
@@ -87,9 +89,9 @@ report :: Message -> ECM ()
report
err
=
S
.
modify
(
\
s
->
s
{
errors
=
err
:
errors
s
})
-- While checking all export specifications, the compiler expands
-- specifications of the form @T(..)@ into @T(C_1,...,C_n)@,