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
3ff76be4
Commit
3ff76be4
authored
Feb 17, 2015
by
Jan Rasmus Tikovsky
Browse files
The type constructor environment now stores information for all constructors of a data type
parent
c50feaff
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/Checks/InterfaceCheck.hs
View file @
3ff76be4
...
...
@@ -108,17 +108,14 @@ checkImport (HidingDataDecl p tc tvs)
check
(
RenamingType
tc'
n'
_
)
|
tc
==
tc'
&&
length
tvs
==
n'
=
Just
ok
check
_
=
Nothing
checkImport
(
IDataDecl
p
tc
tvs
cs
hs
)
=
checkTypeInfo
"data type"
check
p
tc
checkImport
(
IDataDecl
p
tc
tvs
cs
_
)
=
checkTypeInfo
"data type"
check
p
tc
where
check
(
DataType
tc'
n'
cs'
)
|
tc
==
tc'
&&
length
tvs
==
n'
&&
(
null
cs
||
length
cs
==
length
cs'
)
&&
and
(
zipWith
isVisible
cs
(
fmap
(
fmap
constrIdent
)
cs'
))
(
null
cs
||
map
constrId
cs
==
map
constrIdent
cs'
)
=
Just
(
mapM_
(
checkConstrImport
tc
tvs
)
cs
)
check
(
RenamingType
tc'
n'
_
)
|
tc
==
tc'
&&
length
tvs
==
n'
&&
null
cs
=
Just
ok
check
_
=
Nothing
isVisible
c
(
Just
c'
)
=
constrId
c
==
c'
isVisible
c
Nothing
=
(
constrId
c
)
`
elem
`
hs
checkImport
(
INewtypeDecl
p
tc
tvs
nc
_
)
=
checkTypeInfo
"newtype"
check
p
tc
where
check
(
RenamingType
tc'
n'
nc'
)
...
...
src/Checks/TypeCheck.hs
View file @
3ff76be4
...
...
@@ -254,7 +254,7 @@ bindTypes ds = do
bindTC
::
ModuleIdent
->
TCEnv
->
Decl
->
TCEnv
->
TCEnv
bindTC
m
tcEnv
(
DataDecl
_
tc
tvs
cs
)
=
bindTypeInfo
DataType
m
tc
tvs
(
map
(
Just
.
mkData
)
cs
)
bindTypeInfo
DataType
m
tc
tvs
(
map
mkData
cs
)
where
mkData
(
ConstrDecl
_
evs
c
tys
)
=
mkData'
evs
c
tys
mkData
(
ConOpDecl
_
evs
ty1
op
ty2
)
=
mkData'
evs
op
[
ty1
,
ty2
]
...
...
@@ -330,11 +330,6 @@ bindLabels = do
tcEnv
<-
getTyConsEnv
modifyValueEnv
$
bindLabels'
m
tcEnv
-- bindLabels :: TCM ()
-- bindLabels = do
-- tcEnv <- getTyConsEnv
-- modifyValueEnv $ bindLabels' tcEnv
bindLabels'
::
ModuleIdent
->
TCEnv
->
ValueEnv
->
ValueEnv
bindLabels'
m
tcEnv
tyEnv
=
foldr
(
bindData
.
snd
)
tyEnv
$
localBindings
tcEnv
...
...
@@ -359,18 +354,6 @@ bindLabels' m tcEnv tyEnv = foldr (bindData . snd) tyEnv
(
ForAll
n
(
TypeArrow
lty
ty
))
constrType'
tc
n
=
TypeConstructor
tc
$
map
TypeVariable
[
0
..
n
-
1
]
-- bindLabels' :: TCEnv -> ValueEnv -> ValueEnv
-- bindLabels' tcEnv tyEnv = foldr (bindFieldLabels . snd) tyEnv
-- $ localBindings tcEnv
-- where
-- bindFieldLabels (AliasType r _ (TypeRecord fs)) env =
-- foldr (bindField r) env fs
-- bindFieldLabels _ env = env
--
-- bindField r (l, ty) env = case lookupValue l env of
-- [] -> bindLabel l r (polyType ty) env
-- _ -> env
-- Type Signatures:
-- The type checker collects type signatures in a flat environment. All
-- anonymous variables occurring in a signature are replaced by fresh
...
...
@@ -1071,11 +1054,11 @@ gen gvs ty = ForAll (length tvs)
constrType
::
ModuleIdent
->
QualIdent
->
ValueEnv
->
ExistTypeScheme
constrType
m
c
tyEnv
=
case
qualLookupValue
c
tyEnv
of
[
DataConstructor
_
_
sigma
]
->
sigma
[
NewtypeConstructor
_
sigma
]
->
sigma
[
DataConstructor
_
_
_
sigma
]
->
sigma
[
NewtypeConstructor
_
_
sigma
]
->
sigma
_
->
case
qualLookupValue
(
qualQualify
m
c
)
tyEnv
of
[
DataConstructor
_
_
sigma
]
->
sigma
[
NewtypeConstructor
_
sigma
]
->
sigma
[
DataConstructor
_
_
_
sigma
]
->
sigma
[
NewtypeConstructor
_
_
sigma
]
->
sigma
_
->
internalError
$
"TypeCheck.constrType "
++
show
c
varArity
::
Ident
->
ValueEnv
->
Int
...
...
@@ -1106,7 +1089,8 @@ labelType m l tyEnv = case qualLookupValue l tyEnv of
[
Label
_
_
sigma
]
->
sigma
_
->
case
qualLookupValue
(
qualQualify
m
l
)
tyEnv
of
[
Label
_
_
sigma
]
->
sigma
_
->
internalError
$
"TypeCheck.labelType "
++
show
l
++
", more precisely "
++
show
(
unqualify
l
)
_
->
internalError
$
"TypeCheck.labelType "
++
show
l
++
", more precisely "
++
show
(
unqualify
l
)
-- The function 'expandType' expands all type synonyms in a type
-- and also qualifies all type constructors with the name of the module
...
...
src/Checks/WarnCheck.hs
View file @
3ff76be4
...
...
@@ -706,10 +706,10 @@ getTyCons _ (TypeConstructor tc _) = do
tc'
<-
unAlias
tc
tcEnv
<-
gets
tyConsEnv
return
$
case
lookupTC
(
unqualify
tc
)
tcEnv
of
[
DataType
_
_
cs
]
->
catMaybes
cs
[
DataType
_
_
cs
]
->
cs
[
RenamingType
_
_
nc
]
->
[
nc
]
_
->
case
qualLookupTC
tc'
tcEnv
of
[
DataType
_
_
cs
]
->
catMaybes
cs
[
DataType
_
_
cs
]
->
cs
[
RenamingType
_
_
nc
]
->
[
nc
]
err
->
internalError
$
"Checks.WarnCheck.getTyCons: "
++
show
tc
++
' '
:
show
err
++
'
\n
'
:
show
tcEnv
...
...
src/Env/TypeConstructor.hs
View file @
3ff76be4
...
...
@@ -53,7 +53,7 @@ import Base.Types
import
Base.Utils
((
++!
))
data
TypeInfo
=
DataType
QualIdent
Int
[
Maybe
DataConstr
]
=
DataType
QualIdent
Int
[
DataConstr
]
|
RenamingType
QualIdent
Int
DataConstr
|
AliasType
QualIdent
Int
Type
deriving
Show
...
...
@@ -64,10 +64,8 @@ instance Entity TypeInfo where
origName
(
AliasType
tc
_
_
)
=
tc
merge
(
DataType
tc
n
cs
)
(
DataType
tc'
_
cs'
)
|
tc
==
tc'
=
Just
$
DataType
tc
n
$
mergeData
cs
cs'
where
mergeData
ds
[]
=
ds
mergeData
[]
ds
=
ds
mergeData
(
d
:
ds
)
(
d'
:
ds'
)
=
d
`
mplus
`
d'
:
mergeData
ds
ds'
|
tc
==
tc'
&&
(
null
cs
||
null
cs'
||
cs
==
cs'
)
=
Just
$
DataType
tc
n
(
if
null
cs
then
cs'
else
cs
)
merge
(
DataType
tc
n
_
)
(
RenamingType
tc'
_
nc
)
|
tc
==
tc'
=
Just
(
RenamingType
tc
n
nc
)
merge
l
@
(
RenamingType
tc
_
_
)
(
DataType
tc'
_
_
)
...
...
@@ -76,10 +74,6 @@ instance Entity TypeInfo where
|
tc
==
tc'
=
Just
l
merge
l
@
(
AliasType
tc
_
_
)
(
AliasType
tc'
_
_
)
|
tc
==
tc'
=
Just
l
merge
l
@
(
AliasType
tc
_
(
TypeRecord
_
))
(
DataType
tc'
_
_
)
|
tc
==
tc'
=
Just
l
merge
(
DataType
tc'
_
_
)
r
@
(
AliasType
tc
_
(
TypeRecord
_
))
|
tc
==
tc'
=
Just
r
merge
_
_
=
Nothing
tcArity
::
TypeInfo
->
Int
...
...
@@ -126,12 +120,12 @@ initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
type
TypeEnv
=
TopEnv
TypeKind
data
TypeKind
=
Data
QualIdent
[
Ident
]
=
Data
QualIdent
[
Ident
]
|
Alias
QualIdent
deriving
(
Eq
,
Show
)
typeKind
::
TypeInfo
->
TypeKind
typeKind
(
DataType
tc
_
cs
)
=
Data
tc
[
c
|
Just
(
DataConstr
c
_
_
)
<-
cs
]
typeKind
(
DataType
tc
_
cs
)
=
Data
tc
(
map
constrIdent
cs
)
typeKind
(
RenamingType
tc
_
(
DataConstr
c
_
_
))
=
Data
tc
[
c
]
typeKind
(
AliasType
tc
_
_
)
=
Alias
tc
...
...
src/Imports.hs
View file @
3ff76be4
...
...
@@ -178,24 +178,18 @@ bindTCHidden m d = bindTC m d
-- type constructors
bindTC
::
ModuleIdent
->
IDecl
->
ExpTCEnv
->
ExpTCEnv
bindTC
m
(
IDataDecl
_
tc
tvs
cs
hs
)
mTCEnv
bindTC
m
(
IDataDecl
_
tc
tvs
cs
_
)
mTCEnv
|
unqualify
tc
`
Map
.
member
`
mTCEnv
=
mTCEnv
|
otherwise
=
bindType
DataType
m
tc
tvs
(
map
mkData
cs
)
mTCEnv
where
mkData
(
ConstrDecl
_
evs
c
tys
)
|
c
`
elem
`
hs
=
Nothing
|
otherwise
=
Just
$
DataConstr
c
(
length
evs
)
(
toQualTypes
m
tvs
tys
)
mkData
(
ConOpDecl
_
evs
ty1
c
ty2
)
|
c
`
elem
`
hs
=
Nothing
|
otherwise
=
Just
$
DataConstr
c
(
length
evs
)
(
toQualTypes
m
tvs
[
ty1
,
ty2
])
mkData
(
RecordDecl
_
evs
c
fs
)
|
c
`
elem
`
hs
=
Nothing
|
otherwise
=
Just
$
RecordConstr
c
(
length
evs
)
labels'
tys'
mkData
(
ConstrDecl
_
evs
c
tys
)
=
DataConstr
c
(
length
evs
)
(
toQualTypes
m
tvs
tys
)
mkData
(
ConOpDecl
_
evs
ty1
c
ty2
)
=
DataConstr
c
(
length
evs
)
(
toQualTypes
m
tvs
[
ty1
,
ty2
])
mkData
(
RecordDecl
_
evs
c
fs
)
=
RecordConstr
c
(
length
evs
)
labels
(
toQualTypes
m
tvs
tys
)
where
(
labels
,
tys
)
=
unzip
[(
l
,
ty
)
|
FieldDecl
_
ls
ty
<-
fs
,
l
<-
ls
]
labels'
=
filter
(`
notElem
`
hs
)
labels
tys'
=
toQualTypes
m
tvs
tys
bindTC
m
(
INewtypeDecl
_
tc
tvs
newCons
_
)
mTCEnv
=
bindType
RenamingType
m
tc
tvs
(
mkData
newCons
)
mTCEnv
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment