Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry
curry-frontend
Commits
2ca9420d
Commit
2ca9420d
authored
Oct 21, 2014
by
Jan Rasmus Tikovsky
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Removed record extensions
parent
c7db669b
Changes
21
Hide whitespace changes
Inline
Side-by-side
Showing
21 changed files
with
114 additions
and
160 deletions
+114
-160
src/Base/CurryTypes.hs
src/Base/CurryTypes.hs
+3
-9
src/Base/Expr.hs
src/Base/Expr.hs
+1
-1
src/Base/TypeSubst.hs
src/Base/TypeSubst.hs
+2
-9
src/Base/Types.hs
src/Base/Types.hs
+12
-17
src/Base/Typing.hs
src/Base/Typing.hs
+9
-9
src/Checks/ExportCheck.hs
src/Checks/ExportCheck.hs
+4
-4
src/Checks/InterfaceCheck.hs
src/Checks/InterfaceCheck.hs
+1
-1
src/Checks/InterfaceSyntaxCheck.hs
src/Checks/InterfaceSyntaxCheck.hs
+2
-3
src/Checks/KindCheck.hs
src/Checks/KindCheck.hs
+4
-10
src/Checks/SyntaxCheck.hs
src/Checks/SyntaxCheck.hs
+3
-5
src/Checks/TypeCheck.hs
src/Checks/TypeCheck.hs
+22
-24
src/Checks/WarnCheck.hs
src/Checks/WarnCheck.hs
+9
-11
src/Exports.hs
src/Exports.hs
+5
-6
src/Generators/GenAbstractCurry.hs
src/Generators/GenAbstractCurry.hs
+7
-16
src/Generators/GenFlatCurry.hs
src/Generators/GenFlatCurry.hs
+10
-10
src/Html/SyntaxColoring.hs
src/Html/SyntaxColoring.hs
+1
-2
src/Imports.hs
src/Imports.hs
+5
-5
src/ModuleSummary.hs
src/ModuleSummary.hs
+5
-8
src/Transformations/CurryToIL.hs
src/Transformations/CurryToIL.hs
+4
-4
src/Transformations/Desugar.hs
src/Transformations/Desugar.hs
+4
-4
src/Transformations/Qual.hs
src/Transformations/Qual.hs
+1
-2
No files found.
src/Base/CurryTypes.hs
View file @
2ca9420d
...
...
@@ -67,15 +67,10 @@ 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
rty
)
=
TypeRecord
fs'
rty'
toType'
tvs
(
CS
.
RecordType
fs
)
=
TypeRecord
fs'
where
fs'
=
concatMap
(
\
(
ls
,
ty
)
->
map
(
\
l
->
(
l
,
toType'
tvs
ty
))
ls
)
fs
rty'
=
case
rty
of
Nothing
->
Nothing
Just
ty
->
case
toType'
tvs
ty
of
TypeVariable
tv
->
Just
tv
_
->
internalError
$
"Base.CurryTypes.toType' "
++
show
ty
fromQualType
::
ModuleIdent
->
Type
->
CS
.
TypeExpr
fromQualType
m
=
fromType
.
unqualifyType
m
...
...
@@ -95,9 +90,8 @@ fromType (TypeArrow ty1 ty2) =
CS
.
ArrowType
(
fromType
ty1
)
(
fromType
ty2
)
fromType
(
TypeSkolem
k
)
=
CS
.
VariableType
$
mkIdent
$
"_?"
++
show
k
fromType
(
TypeRecord
fs
rty
)
=
CS
.
RecordType
fromType
(
TypeRecord
fs
)
=
CS
.
RecordType
(
map
(
\
(
l
,
ty
)
->
([
l
],
fromType
ty
))
fs
)
((
fromType
.
TypeVariable
)
`
fmap
`
rty
)
-- The following functions implement pretty-printing for types.
ppType
::
ModuleIdent
->
Type
->
Doc
...
...
src/Base/Expr.hs
View file @
2ca9420d
...
...
@@ -180,7 +180,7 @@ 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
rty
)
=
maybe
[]
fv
rty
++
fv
(
map
snd
fs
)
fv
(
RecordType
fs
)
=
fv
(
map
snd
fs
)
filterBv
::
QuantExpr
e
=>
e
->
[
Ident
]
->
[
Ident
]
filterBv
e
=
filter
(`
Set
.
notMember
`
Set
.
fromList
(
bv
e
))
...
...
src/Base/TypeSubst.hs
View file @
2ca9420d
...
...
@@ -45,11 +45,7 @@ instance SubstType Type where
subst
sigma
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
subst
sigma
ty1
)
(
subst
sigma
ty2
)
subst
_
ts
@
(
TypeSkolem
_
)
=
ts
subst
sigma
(
TypeRecord
fs
rv
)
=
case
rv
of
Nothing
->
TypeRecord
fs'
Nothing
Just
r'
->
case
substVar
sigma
r'
of
TypeVariable
tv
->
TypeRecord
fs'
(
Just
tv
)
ty
->
ty
subst
sigma
(
TypeRecord
fs
)
=
TypeRecord
fs'
where
fs'
=
map
(
\
(
l
,
ty
)
->
(
l
,
subst
sigma
ty
))
fs
instance
SubstType
TypeScheme
where
...
...
@@ -87,10 +83,7 @@ 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
rv
)
=
case
rv
of
Nothing
->
TypeRecord
fs'
Nothing
Just
r'
->
let
(
TypeVariable
tv
)
=
expandAliasType
tys
$
TypeVariable
r'
in
TypeRecord
fs'
(
Just
tv
)
expandAliasType
tys
(
TypeRecord
fs
)
=
TypeRecord
fs'
where
fs'
=
map
(
\
(
l
,
ty
)
->
(
l
,
expandAliasType
tys
ty
))
fs
normalize
::
Type
->
Type
...
...
src/Base/Types.hs
View file @
2ca9420d
...
...
@@ -57,7 +57,7 @@ data Type
|
TypeArrow
Type
Type
|
TypeConstrained
[
Type
]
Int
|
TypeSkolem
Int
|
TypeRecord
[(
Ident
,
Type
)]
(
Maybe
Int
)
|
TypeRecord
[(
Ident
,
Type
)]
deriving
(
Eq
,
Show
)
-- The function 'isArrowType' checks whether a type is a function
...
...
@@ -93,8 +93,7 @@ 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
rtv
)
tvs
=
foldr
vars
(
maybe
tvs
(
:
tvs
)
rtv
)
(
map
snd
fs
)
vars
(
TypeRecord
fs
)
tvs
=
foldr
vars
tvs
(
map
snd
fs
)
typeConstrs
::
Type
->
[
QualIdent
]
typeConstrs
ty
=
constrs
ty
[]
where
...
...
@@ -103,7 +102,7 @@ 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
)
constrs
(
TypeRecord
fs
)
tcs
=
foldr
constrs
tcs
(
map
snd
fs
)
typeSkolems
::
Type
->
[
Int
]
typeSkolems
ty
=
skolems
ty
[]
where
...
...
@@ -112,7 +111,7 @@ 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
)
skolems
(
TypeRecord
fs
)
sks
=
foldr
skolems
sks
(
map
snd
fs
)
-- The function 'equTypes' computes whether two types are equal modulo
-- renaming of type variables.
...
...
@@ -135,14 +134,10 @@ 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
(
Just
r1
))
(
TypeRecord
fs2
(
Just
r2
))
=
let
(
res1
,
is1
)
=
equVar
is
r1
r2
(
res2
,
is2
)
=
equRecords
is1
fs1
fs2
in
(
res1
&&
res2
,
is2
)
equ
is
(
TypeRecord
fs1
Nothing
)
(
TypeRecord
fs2
Nothing
)
=
equRecords
is
fs1
fs2
equ
is
_
_
=
(
False
,
is
)
equ
is
(
TypeRecord
fs1
)
(
TypeRecord
fs2
)
=
equRecords
is
fs1
fs2
equ
is
_
_
=
(
False
,
is
)
equVar
is
i1
i2
=
case
lookup
i1
is
of
Nothing
->
(
True
,
(
i1
,
i2
)
:
is
)
...
...
@@ -182,8 +177,8 @@ 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
rty
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
qualifyType
m
ty
))
fs
)
rty
qualifyType
m
(
TypeRecord
fs
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
qualifyType
m
ty
))
fs
)
unqualifyType
::
ModuleIdent
->
Type
->
Type
unqualifyType
m
(
TypeConstructor
tc
tys
)
=
...
...
@@ -194,8 +189,8 @@ 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
rty
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
unqualifyType
m
ty
))
fs
)
rty
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.
...
...
src/Base/Typing.hs
View file @
2ca9420d
...
...
@@ -197,8 +197,8 @@ 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
[
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
...
...
@@ -273,8 +273,8 @@ exprType (Case _ _ _ alts) = freshTypeVar >>= flip altType alts
exprType
(
RecordConstr
fs
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
(
TypeRecord
fts'
_
,
tys
)
<-
instType'
n
rty
[
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
...
...
@@ -285,8 +285,8 @@ exprType (RecordConstr fs) = do
exprType
(
RecordSelection
e
l
)
=
do
recInfo
<-
getRecordInfo
l
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
(
TypeRecord
fts
_
,
tys
)
<-
instType'
n
rty
[
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
...
...
@@ -300,8 +300,8 @@ exprType (RecordSelection e l) = do
exprType
(
RecordUpdate
fs
e
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
(
TypeRecord
fts'
_
,
tys
)
<-
instType'
n
rty
[
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
)
...
...
@@ -402,7 +402,7 @@ 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
Nothing
)
(
TypeRecord
fs2
Nothing
)
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
++
")"
...
...
src/Checks/ExportCheck.hs
View file @
2ca9420d
...
...
@@ -224,8 +224,8 @@ constrs (RenamingType _ _ (DataConstr c _ _)) = [c]
constrs
(
AliasType
_
_
_
)
=
[]
labels
::
TypeInfo
->
[
Ident
]
labels
(
AliasType
_
_
(
TypeRecord
fs
_
))
=
map
fst
fs
labels
_
=
[]
labels
(
AliasType
_
_
(
TypeRecord
fs
))
=
map
fst
fs
labels
_
=
[]
isDataType
::
TypeInfo
->
Bool
isDataType
(
DataType
_
_
_
)
=
True
...
...
@@ -233,8 +233,8 @@ isDataType (RenamingType _ _ _) = True
isDataType
(
AliasType
_
_
_
)
=
False
isRecordType
::
TypeInfo
->
Bool
isRecordType
(
AliasType
_
_
(
TypeRecord
_
_
))
=
True
isRecordType
_
=
False
isRecordType
(
AliasType
_
_
(
TypeRecord
_
))
=
True
isRecordType
_
=
False
-- ---------------------------------------------------------------------------
-- Error messages
...
...
src/Checks/InterfaceCheck.hs
View file @
2ca9420d
...
...
@@ -106,7 +106,7 @@ checkImport (HidingDataDecl p tc tvs)
|
tc
==
tc'
&&
length
tvs
==
n'
=
Just
ok
check
(
RenamingType
tc'
n'
_
)
|
tc
==
tc'
&&
length
tvs
==
n'
=
Just
ok
check
(
AliasType
tc'
n'
(
TypeRecord
_
_
))
check
(
AliasType
tc'
n'
(
TypeRecord
_
))
|
tc
==
tc'
&&
length
tvs
==
n'
=
Just
ok
check
_
=
Nothing
checkImport
(
IDataDecl
p
tc
tvs
cs
)
=
checkTypeInfo
"data type"
check
p
tc
...
...
src/Checks/InterfaceSyntaxCheck.hs
View file @
2ca9420d
...
...
@@ -79,7 +79,7 @@ bindType (INewtypeDecl _ tc _ nc) = qualBindTopEnv "" tc (Data tc [nconstr nc]
-- jrt 2014-10-16: record types are handled like data declarations; this is
-- necessary because type constructors of record types are not expanded anymore
-- and can occur in interfaces
bindType
(
ITypeDecl
_
tc
_
(
RecordType
_
_
))
=
qualBindTopEnv
""
tc
(
Data
tc
[]
)
bindType
(
ITypeDecl
_
tc
_
(
RecordType
_
))
=
qualBindTopEnv
""
tc
(
Data
tc
[]
)
bindType
(
ITypeDecl
_
tc
_
_
)
=
qualBindTopEnv
""
tc
(
Alias
tc
)
bindType
(
IFunctionDecl
_
_
_
_
)
=
id
...
...
@@ -141,8 +141,7 @@ checkType (VariableType tv) = checkType (ConstructorType (qualify tv) [])
checkType
(
TupleType
tys
)
=
liftM
TupleType
(
mapM
checkType
tys
)
checkType
(
ListType
ty
)
=
liftM
ListType
(
checkType
ty
)
checkType
(
ArrowType
ty1
ty2
)
=
liftM2
ArrowType
(
checkType
ty1
)
(
checkType
ty2
)
checkType
(
RecordType
fs
mty
)
=
liftM2
RecordType
(
mapM
checkField
fs
)
(
liftMaybe
checkType
mty
)
checkType
(
RecordType
fs
)
=
liftM
RecordType
(
mapM
checkField
fs
)
where
checkField
(
l
,
ty
)
=
checkType
ty
>>=
\
ty'
->
return
(
l
,
ty'
)
checkTypeConstructor
::
QualIdent
->
[
TypeExpr
]
->
ISC
TypeExpr
...
...
src/Checks/KindCheck.hs
View file @
2ca9420d
...
...
@@ -258,14 +258,11 @@ checkType (TupleType tys) = TupleType `liftM` mapM checkType tys
checkType
(
ListType
ty
)
=
ListType
`
liftM
`
checkType
ty
checkType
(
ArrowType
ty1
ty2
)
=
liftM2
ArrowType
(
checkType
ty1
)
(
checkType
ty2
)
checkType
(
RecordType
fs
r
)
=
do
checkType
(
RecordType
fs
)
=
do
fs'
<-
forM
fs
$
\
(
l
,
ty
)
->
do
ty'
<-
checkType
ty
return
(
l
,
ty'
)
r'
<-
case
r
of
Nothing
->
return
Nothing
Just
ar
->
Just
`
liftM
`
checkType
ar
return
$
RecordType
fs'
r'
return
$
RecordType
fs'
checkClosed
::
[
Ident
]
->
TypeExpr
->
KCM
TypeExpr
checkClosed
tvs
(
ConstructorType
tc
tys
)
=
...
...
@@ -279,14 +276,11 @@ checkClosed tvs (ListType ty) =
ListType
`
liftM
`
checkClosed
tvs
ty
checkClosed
tvs
(
ArrowType
ty1
ty2
)
=
liftM2
ArrowType
(
checkClosed
tvs
ty1
)
(
checkClosed
tvs
ty2
)
checkClosed
tvs
(
RecordType
fs
r
)
=
do
checkClosed
tvs
(
RecordType
fs
)
=
do
fs'
<-
forM
fs
$
\
(
l
,
ty
)
->
do
ty'
<-
checkClosed
tvs
ty
return
(
l
,
ty'
)
r'
<-
case
r
of
Nothing
->
return
Nothing
Just
ar
->
Just
`
liftM
`
checkClosed
tvs
ar
return
$
RecordType
fs'
r'
return
$
RecordType
fs'
-- ---------------------------------------------------------------------------
-- Auxiliary definitions
...
...
src/Checks/SyntaxCheck.hs
View file @
2ca9420d
...
...
@@ -206,7 +206,7 @@ renameInfo _ (DataConstructor qid a _) = Constr qid a
renameInfo
_
(
NewtypeConstructor
qid
_
)
=
Constr
qid
1
renameInfo
_
(
Value
qid
a
_
)
=
GlobalVar
qid
a
renameInfo
tcEnv
(
Label
_
r
_
)
=
case
qualLookupTC
r
tcEnv
of
[
AliasType
_
_
(
TypeRecord
fs
_
)]
->
RecordLabel
r
$
map
fst
fs
[
AliasType
_
_
(
TypeRecord
fs
)]
->
RecordLabel
r
$
map
fst
fs
_
->
internalError
$
"SyntaxCheck.renameInfo: ambiguous record "
++
show
r
bindGlobal
::
ModuleIdent
->
Ident
->
RenameInfo
->
RenameEnv
->
RenameEnv
...
...
@@ -221,7 +221,7 @@ bindLocal = bindNestEnv
bindTypeDecl
::
Decl
->
SCM
()
bindTypeDecl
(
DataDecl
_
_
_
cs
)
=
mapM_
bindConstr
cs
bindTypeDecl
(
NewtypeDecl
_
_
_
nc
)
=
bindNewConstr
nc
bindTypeDecl
(
TypeDecl
_
t
_
(
RecordType
fs
_
))
=
do
bindTypeDecl
(
TypeDecl
_
t
_
(
RecordType
fs
))
=
do
m
<-
getModuleIdent
others
<-
qualLookupVar
(
qualifyWith
m
t
)
`
liftM
`
getRenameEnv
when
(
any
isConstr
others
)
$
report
$
errIllegalRecordId
t
...
...
@@ -332,10 +332,8 @@ checkExtension (KnownExtension _ e) = enableExtension e
checkExtension
(
UnknownExtension
p
e
)
=
report
$
errUnknownExtension
p
e
checkTypeDecl
::
Decl
->
SCM
Decl
checkTypeDecl
rec
@
(
TypeDecl
_
r
_
(
RecordType
fs
rty
))
=
do
checkTypeDecl
rec
@
(
TypeDecl
_
r
_
(
RecordType
fs
))
=
do
checkRecordExtension
$
idPosition
r
when
(
isJust
rty
)
$
internalError
"SyntaxCheck.checkTypeDecl: illegal record type"
when
(
null
fs
)
$
report
$
errEmptyRecord
$
idPosition
r
return
rec
checkTypeDecl
d
=
return
d
...
...
src/Checks/TypeCheck.hs
View file @
2ca9420d
...
...
@@ -31,7 +31,7 @@ import qualified Control.Monad.State as S (State, execState, gets, modify)
import
Data.List
(
nub
,
partition
)
import
qualified
Data.Map
as
Map
(
Map
,
delete
,
empty
,
insert
,
lookup
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
,
listToMaybe
,
maybeToList
)
(
catMaybes
,
fromMaybe
)
import
qualified
Data.Set
as
Set
(
Set
,
fromList
,
member
,
notMember
,
unions
)
...
...
@@ -205,8 +205,7 @@ ft _ (VariableType _) tcs = tcs
ft
m
(
TupleType
tys
)
tcs
=
foldr
(
ft
m
)
tcs
tys
ft
m
(
ListType
ty
)
tcs
=
ft
m
ty
tcs
ft
m
(
ArrowType
ty1
ty2
)
tcs
=
ft
m
ty1
$
ft
m
ty2
$
tcs
ft
m
(
RecordType
fs
rty
)
tcs
=
foldr
(
ft
m
)
(
maybe
tcs
(
\
ty
->
ft
m
ty
tcs
)
rty
)
(
map
snd
fs
)
ft
m
(
RecordType
fs
)
tcs
=
foldr
(
ft
m
)
tcs
(
map
snd
fs
)
-- The type constructor environment 'tcEnv' maintains all types
-- in fully expanded form (except for record types).
...
...
@@ -282,7 +281,7 @@ bindLabels' :: TCEnv -> ValueEnv -> ValueEnv
bindLabels'
tcEnv
tyEnv
=
foldr
(
bindFieldLabels
.
snd
)
tyEnv
$
localBindings
tcEnv
where
bindFieldLabels
(
AliasType
r
_
(
TypeRecord
fs
_
))
env
=
bindFieldLabels
(
AliasType
r
_
(
TypeRecord
fs
))
env
=
foldr
(
bindField
r
)
env
fs
bindFieldLabels
_
env
=
env
...
...
@@ -341,11 +340,10 @@ nameType (ListType ty) tvs = (ListType ty', tvs')
nameType
(
ArrowType
ty1
ty2
)
tvs
=
(
ArrowType
ty1'
ty2'
,
tvs''
)
where
(
ty1'
,
tvs'
)
=
nameType
ty1
tvs
(
ty2'
,
tvs''
)
=
nameType
ty2
tvs'
nameType
(
RecordType
fs
rty
)
tvs
=
(
RecordType
(
zip
ls
tys'
)
(
listToMaybe
rty'
)
,
tvs
)
nameType
(
RecordType
fs
)
tvs
=
(
RecordType
(
zip
ls
tys'
),
tvs
)
where
(
ls
,
tys
)
=
unzip
fs
(
tys'
,
_
)
=
nameTypes
tys
tvs
(
rty'
,
_
)
=
nameTypes
(
maybeToList
rty
)
tvs
nameType
(
VariableType
_
)
[]
=
internalError
"TypeCheck.nameType: empty ident list"
...
...
@@ -624,8 +622,8 @@ tcPattern p (InfixFuncPattern t1 op t2) =
tcPattern
p
r
@
(
RecordPattern
fs
_
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
_
),
tys
)
<-
inst'
(
ForAll
n
rty
)
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
),
tys
)
<-
inst'
(
ForAll
n
rty
)
fts
<-
mapM
(
tcFieldPatt
tcPattern
)
fs
unifyLabels
p
"record pattern"
(
ppPattern
0
r
)
fts'
rty'
fts
theta
<-
getTypeSubst
...
...
@@ -717,8 +715,8 @@ tcPatternFP p (InfixFuncPattern t1 op t2) =
tcPatternFP
p
r
@
(
RecordPattern
fs
_
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
_
),
tys
)
<-
inst'
(
ForAll
n
rty
)
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
),
tys
)
<-
inst'
(
ForAll
n
rty
)
fts
<-
mapM
(
tcFieldPatt
tcPattern
)
fs
unifyLabels
p
"record pattern"
(
ppPattern
0
r
)
fts'
rty'
fts
theta
<-
getTypeSubst
...
...
@@ -935,8 +933,8 @@ tcExpr p (Case _ _ e alts) = do
tcExpr
p
r
@
(
RecordConstr
fs
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
_
),
tys
)
<-
inst'
(
ForAll
n
rty
)
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
),
tys
)
<-
inst'
(
ForAll
n
rty
)
fts
<-
mapM
tcFieldExpr
fs
unifyLabels
p
"record construction"
(
ppExpr
0
r
)
fts'
rty'
fts
theta
<-
getTypeSubst
...
...
@@ -946,9 +944,9 @@ tcExpr p r@(RecordConstr fs) = do
tcExpr
p
r
@
(
RecordSelection
e
l
)
=
do
recInfo
<-
getRecordInfo
l
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
ety
<-
tcExpr
p
e
(
TypeRecord
fts
_
,
tys
)
<-
inst'
(
ForAll
n
rty
)
(
TypeRecord
fts
,
tys
)
<-
inst'
(
ForAll
n
rty
)
let
rtc
=
TypeConstructor
qi
tys
case
lookup
l
fts
of
Just
lty
->
do
...
...
@@ -961,8 +959,8 @@ tcExpr p r@(RecordSelection e l) = do
tcExpr
p
r
@
(
RecordUpdate
fs
e
)
=
do
recInfo
<-
getFieldIdent
fs
>>=
getRecordInfo
case
recInfo
of
[
AliasType
qi
n
rty
@
(
TypeRecord
_
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
_
),
tys
)
<-
inst'
(
ForAll
n
rty
)
[
AliasType
qi
n
rty
@
(
TypeRecord
_
)]
->
do
(
rty'
@
(
TypeRecord
fts'
),
tys
)
<-
inst'
(
ForAll
n
rty
)
-- Type check field updates
fts
<-
mapM
tcFieldExpr
fs
unifyLabels
p
"record update"
(
ppExpr
0
r
)
fts'
rty'
fts
...
...
@@ -1080,7 +1078,7 @@ unifyTypes m (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =
unifyTypeLists
m
[
ty11
,
ty12
]
[
ty21
,
ty22
]
unifyTypes
_
(
TypeSkolem
k1
)
(
TypeSkolem
k2
)
|
k1
==
k2
=
Right
idSubst
unifyTypes
m
(
TypeRecord
fs1
Nothing
)
tr2
@
(
TypeRecord
fs2
Nothing
)
unifyTypes
m
(
TypeRecord
fs1
)
tr2
@
(
TypeRecord
fs2
)
|
length
fs1
==
length
fs2
=
unifyTypedLabels
m
fs1
tr2
unifyTypes
m
ty1
ty2
=
Left
(
errIncompatibleTypes
m
ty1
ty2
)
...
...
@@ -1137,8 +1135,8 @@ unifyLabel p what doc fs rty (l, ty) = case lookup l fs of
unifyTypedLabels
::
ModuleIdent
->
[(
Ident
,
Type
)]
->
Type
->
Either
Doc
TypeSubst
unifyTypedLabels
_
[]
(
TypeRecord
_
_
)
=
Right
idSubst
unifyTypedLabels
m
((
l
,
ty
)
:
fs1
)
tr
@
(
TypeRecord
fs2
_
)
=
unifyTypedLabels
_
[]
(
TypeRecord
_
)
=
Right
idSubst
unifyTypedLabels
m
((
l
,
ty
)
:
fs1
)
tr
@
(
TypeRecord
fs2
)
=
either
Left
(
\
r
->
maybe
(
Left
(
errMissingLabel
m
l
tr
))
...
...
@@ -1288,12 +1286,12 @@ expandType :: ModuleIdent -> TCEnv -> Type -> Type
expandType
m
tcEnv
(
TypeConstructor
tc
tys
)
=
case
qualLookupTC
tc
tcEnv
of
[
DataType
tc'
_
_
]
->
TypeConstructor
tc'
tys'
[
RenamingType
tc'
_
_
]
->
TypeConstructor
tc'
tys'
[
AliasType
tc'
_
(
TypeRecord
_
_
)]
->
TypeConstructor
tc'
tys'
[
AliasType
tc'
_
(
TypeRecord
_
)]
->
TypeConstructor
tc'
tys'
[
AliasType
_
_
ty
]
->
expandAliasType
tys'
ty
_
->
case
qualLookupTC
(
qualQualify
m
tc
)
tcEnv
of
[
DataType
tc'
_
_
]
->
TypeConstructor
tc'
tys'
[
RenamingType
tc'
_
_
]
->
TypeConstructor
tc'
tys'
[
AliasType
tc'
_
(
TypeRecord
_
_
)]
->
TypeConstructor
tc'
tys'
[
AliasType
tc'
_
(
TypeRecord
_
)]
->
TypeConstructor
tc'
tys'
[
AliasType
_
_
ty
]
->
expandAliasType
tys'
ty
_
->
internalError
$
"TypeCheck.expandType "
++
show
tc
where
tys'
=
map
(
expandType
m
tcEnv
)
tys
...
...
@@ -1302,8 +1300,8 @@ expandType _ _ tc@(TypeConstrained _ _) = tc
expandType
m
tcEnv
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
expandType
m
tcEnv
ty1
)
(
expandType
m
tcEnv
ty2
)
expandType
_
_
ts
@
(
TypeSkolem
_
)
=
ts
expandType
m
tcEnv
(
TypeRecord
fs
rv
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
expandType
m
tcEnv
ty
))
fs
)
rv
expandType
m
tcEnv
(
TypeRecord
fs
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
expandType
m
tcEnv
ty
))
fs
)
-- The functions 'fvEnv' and 'fsEnv' compute the set of free type variables
-- and free skolems of a type environment, respectively. We ignore the types
...
...
src/Checks/WarnCheck.hs
View file @
2ca9420d
...
...
@@ -253,9 +253,7 @@ checkTypeExpr (VariableType v) = visitTypeId v
checkTypeExpr
(
TupleType
tys
)
=
mapM_
checkTypeExpr
tys
checkTypeExpr
(
ListType
ty
)
=
checkTypeExpr
ty
checkTypeExpr
(
ArrowType
ty1
ty2
)
=
mapM_
checkTypeExpr
[
ty1
,
ty2
]
checkTypeExpr
(
RecordType
fs
rty
)
=
do
mapM_
checkTypeExpr
(
map
snd
fs
)
maybe
ok
checkTypeExpr
rty
checkTypeExpr
(
RecordType
fs
)
=
mapM_
checkTypeExpr
(
map
snd
fs
)
-- Checks locally declared identifiers (i.e. functions and logic variables)
-- for shadowing
...
...
@@ -549,8 +547,8 @@ getAllLabels l = do
[
Label
_
r
_
]
->
do
tcEnv
<-
gets
tyConsEnv
case
qualLookupTC
r
tcEnv
of
[
AliasType
_
_
(
TypeRecord
fs
_
)]
->
return
(
r
,
map
fst
fs
)
_
->
internalError
$
[
AliasType
_
_
(
TypeRecord
fs
)]
->
return
(
r
,
map
fst
fs
)
_
->
internalError
$
"Checks.WarnCheck.getAllLabels: "
++
show
r
_
->
internalError
$
"Checks.WarnCheck.getAllLabels: "
++
show
l
...
...
@@ -717,7 +715,7 @@ getTyCons _ (TypeConstructor tc _) = do
[
RenamingType
_
_
nc
]
->
[
nc
]
err
->
internalError
$
"Checks.WarnCheck.getTyCons: "
++
show
tc
++
' '
:
show
err
++
'
\n
'
:
show
tcEnv
getTyCons
q
(
TypeRecord
fs
_
)
=
return
[
DataConstr
(
unqualify
q
)
(
length
fs
)
(
map
snd
fs
)]
getTyCons
q
(
TypeRecord
fs
)
=
return
[
DataConstr
(
unqualify
q
)
(
length
fs
)
(
map
snd
fs
)]
getTyCons
_
_
=
internalError
"Checks.WarnCheck.getTyCons"
-- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'.
...
...
@@ -739,9 +737,9 @@ tidyPat p@(ConstructorPattern c ps)
|
otherwise
=
do
ty
<-
getConTy
c
case
ty
of
TypeRecord
fs
_
->
flip
RecordPattern
Nothing
`
liftM
`
zipWithM
mkFieldPat
fs
ps
_
->
return
p
TypeRecord
fs
->
flip
RecordPattern
Nothing
`
liftM
`
zipWithM
mkFieldPat
fs
ps
_
->
return
p
where
isFiniteList
(
ConstructorPattern
d
[]
)
=
d
==
qNilId
isFiniteList
(
ConstructorPattern
d
[
_
,
e2
])
|
d
==
qConsId
=
isFiniteList
e2
...
...
@@ -908,9 +906,9 @@ insertTypeExpr (ConstructorType _ tys) = mapM_ insertTypeExpr tys
insertTypeExpr
(
TupleType
tys
)
=
mapM_
insertTypeExpr
tys
insertTypeExpr
(
ListType
ty
)
=
insertTypeExpr
ty
insertTypeExpr
(
ArrowType
ty1
ty2
)
=
mapM_
insertTypeExpr
[
ty1
,
ty2
]
insertTypeExpr
(
RecordType
_
rty
)
=
d
o
insertTypeExpr
(
RecordType
_
)
=
o
k
--mapM_ insertVar (concatMap fst fs)
maybe
(
return
()
)
insertTypeExpr
rty
--
maybe (return ()) insertTypeExpr rty
insertConstrDecl
::
ConstrDecl
->
WCM
()
insertConstrDecl
(
ConstrDecl
_
_
c
_
)
=
insertConsId
c
...
...
src/Exports.hs
View file @
2ca9420d
...
...
@@ -91,8 +91,8 @@ typeDecl m tcEnv (ExportTypeWith tc cs) ds = case qualLookupTC tc tcEnv of
where
tvs
=
take
n'
(
drop
n
identSupply
)
ty'
=
fromQualType
m
ty
[
AliasType
tc'
n
ty
]
->
case
ty
of
TypeRecord
fs
_
->
let
ty'
=
TypeRecord
(
filter
(
\
(
l
,
_
)
->
elem
l
cs
)
fs
)
Nothing
TypeRecord
fs
->
let
ty'
=
TypeRecord
(
filter
(
\
(
l
,
_
)
->
elem
l
cs
)
fs
)
in
iTypeDecl
ITypeDecl
m
tc'
n
(
fromQualType
m
ty'
)
:
ds
_
->
iTypeDecl
ITypeDecl
m
tc'
n
(
fromQualType
m
ty
)
:
ds
_
->
internalError
"Exports.typeDecl"
...
...
@@ -168,8 +168,7 @@ identsType (VariableType _) xs = xs
identsType
(
TupleType
tys
)
xs
=
foldr
identsType
xs
tys
identsType
(
ListType
ty
)
xs
=
identsType
ty
xs
identsType
(
ArrowType
ty1
ty2
)
xs
=
identsType
ty1
(
identsType
ty2
xs
)
identsType
(
RecordType
fs
rty
)
xs
=
foldr
identsType
(
maybe
xs
(
\
ty
->
identsType
ty
xs
)
rty
)
(
map
snd
fs
)
identsType
(
RecordType
fs
)
xs
=
foldr
identsType
xs
(
map
snd
fs
)
-- After the interface declarations have been computed, the compiler
-- eventually must add hidden (data) type declarations to the interface
...
...
@@ -220,8 +219,8 @@ usedTypesType (TupleType tys) tcs = foldr usedTypesType tcs tys
usedTypesType
(
ListType
ty
)
tcs
=
usedTypesType
ty
tcs
usedTypesType
(
ArrowType
ty1
ty2
)
tcs
=
usedTypesType
ty1
(
usedTypesType
ty2
tcs
)
usedTypesType
(
RecordType
fs
rty
)
tcs
=
foldr
usedTypesType
(
maybe
tcs
(
\
ty
->
usedTypesType
ty
tcs
)
rty
)
(
map
snd
fs
)
usedTypesType
(
RecordType
fs
)
tcs
=
foldr
usedTypesType
tcs
(
map
snd
fs
)
definedTypes
::
[
IDecl
]
->
[
QualIdent
]
definedTypes
ds
=
foldr
definedType
[]
ds
...
...
src/Generators/GenAbstractCurry.hs
View file @
2ca9420d
...
...
@@ -192,16 +192,7 @@ genTypeExpr env (ListType ty)
genTypeExpr
env
(
ArrowType
ty1
ty2
)
=
(
env2
,
CFuncType
ty1'
ty2'
)
where
(
env1
,
ty1'
)
=
genTypeExpr
env
ty1
(
env2
,
ty2'
)
=
genTypeExpr
env1
ty2
genTypeExpr
env
(
RecordType
fss
mr
)
=
case
mr
of
Nothing
->
(
env1
,
CRecordType
(
zip
ls'
ts'
)
Nothing
)
Just
tvar
@
(
VariableType
_
)
->
let
(
env2
,
CTVar
iname
)
=
genTypeExpr
env1
tvar
in
(
env2
,
CRecordType
(
zip
ls'
ts'
)
(
Just
iname
))
Just
r
@
(
RecordType
_
_
)
->
let
(
env2
,
CRecordType
fields
rbase
)
=
genTypeExpr
env1
r
fields'
=
foldr
(
uncurry
insertEntry
)
fields
(
zip
ls'
ts'
)
in
(
env2
,
CRecordType
fields'
rbase
)
_
->
internalError
"GenAbstractCurry.gegnTypeExpr: illegal record base"
genTypeExpr
env
(
RecordType
fss
)
=
(
env1
,
CRecordType
(
zip
ls'
ts'
))
where
(
ls
,
ts
)
=
unzip
$
concatMap
(
\
(
ls1
,
ty
)
->
map
(
\
l
->
(
l
,
ty
))
ls1
)
fss
(
env1
,
ts'
)
=
mapAccumL
genTypeExpr
env
ts
...
...
@@ -284,7 +275,7 @@ genFuncDecl isLocal env (ident, decls)
compArityFromType
(
CTVar
_
)
=
0
compArityFromType
(
CFuncType
_
t2
)
=
1
+
compArityFromType
t2
compArityFromType
(
CTCons
_
_
)
=
0
compArityFromType
(
CRecordType
_
_
)
=
compArityFromType
(
CRecordType
_
)
=
internalError
"GenAbstractCurry.genFuncDecl.compArityFromType: record type"
compRule
_
[]
Nothing
=
internalError
$
"GenAbstractCurry.compRule: "
...
...
@@ -912,11 +903,11 @@ simplifyRhsLocals (GuardedRhs _ locals) = locals
-- Insert a value under a key into an association list. If the list
-- already contains a value for that key, the old value is replaced.
insertEntry
::
Eq
a
=>
a
->
b
->
[(
a
,
b
)]
->
[(
a
,
b
)]
insertEntry
k
v
[]
=
[(
k
,
v
)]
insertEntry
k
v
((
l
,
w
)
:
kvs
)
|
k
==
l
=
(
k
,
v
)
:
kvs
|
otherwise
=
(
l
,
w
)
:
insertEntry
k
v
kvs
--
insertEntry :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
--
insertEntry k v [] = [(k, v)]
--
insertEntry k v ((l, w) : kvs)
--
| k == l = (k, v) : kvs
--
| otherwise = (l, w) : insertEntry k v kvs
-- Return 'True' iff a list is a singleton list (contains exactly one element)
isSingleton
::
[
a
]
->
Bool
...
...
src/Generators/GenFlatCurry.hs
View file @
2ca9420d
...
...
@@ -659,7 +659,7 @@ genRecordTypes = records >>= mapM genRecordType
--
genRecordType
::
CS
.
IDecl
->
FlatState
TypeDecl
genRecordType
(
CS
.
ITypeDecl
_
qid
params
(
CS
.
RecordType
fs
_
))
=
do
genRecordType
(
CS
.
ITypeDecl
_
qid
params
(
CS
.
RecordType
fs
))
=
do