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
cc84f0ac
Commit
cc84f0ac
authored
Sep 06, 2011
by
Björn Peemöller
Browse files
cosmetics
parent
01e12774
Changes
6
Hide whitespace changes
Inline
Side-by-side
src/Base/CurryTypes.lhs
View file @
cc84f0ac
...
...
@@ -37,7 +37,8 @@ order of type variables in the left hand side of a type declaration.
>
where
newInTy
=
[
tv
|
tv
<-
nub
(
fv
ty
),
tv
`
notElem
`
tvs
]
>
toTypes
::
[
Ident
]
->
[
CS
.
TypeExpr
]
->
[
Type
]
>
toTypes
tvs
tys
=
map
(
toType'
(
Map
.
fromList
$
zip
(
tvs
++
newInTys
)
[
0
..
]))
tys
>
toTypes
tvs
tys
=
map
>
(
toType'
(
Map
.
fromList
$
zip
(
tvs
++
newInTys
)
[
0
..
]))
tys
>
where
newInTys
=
[
tv
|
tv
<-
nub
(
concatMap
fv
tys
),
tv
`
notElem
`
tvs
]
>
toType'
::
Map
.
Map
Ident
Int
->
CS
.
TypeExpr
->
Type
...
...
@@ -78,8 +79,10 @@ order of type variables in the left hand side of a type declaration.
>
fromType
(
TypeVariable
tv
)
=
CS
.
VariableType
>
(
if
tv
>=
0
then
identSupply
!!
tv
else
mkIdent
(
'_'
:
show
(
-
tv
)))
>
fromType
(
TypeConstrained
tys
_
)
=
fromType
(
head
tys
)
>
fromType
(
TypeArrow
ty1
ty2
)
=
CS
.
ArrowType
(
fromType
ty1
)
(
fromType
ty2
)
>
fromType
(
TypeSkolem
k
)
=
CS
.
VariableType
$
mkIdent
$
"_?"
++
show
k
>
fromType
(
TypeArrow
ty1
ty2
)
=
>
CS
.
ArrowType
(
fromType
ty1
)
(
fromType
ty2
)
>
fromType
(
TypeSkolem
k
)
=
>
CS
.
VariableType
$
mkIdent
$
"_?"
++
show
k
>
fromType
(
TypeRecord
fs
rty
)
=
CS
.
RecordType
>
(
map
(
\
(
l
,
ty
)
->
([
l
],
fromType
ty
))
fs
)
>
((
fromType
.
TypeVariable
)
`
fmap
`
rty
)
src/Base/TopEnv.lhs
View file @
cc84f0ac
...
...
@@ -73,17 +73,20 @@ imported.
>
Just
_
->
internalError
"TopEnv.predefTopEnv"
>
Nothing
->
TopEnv
$
Map
.
insert
x
[(
Import
[]
,
y
)]
env
>
importTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
->
TopEnv
a
>
importTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
>
->
TopEnv
a
>
importTopEnv
m
x
y
(
TopEnv
env
)
=
>
TopEnv
$
Map
.
insert
x'
(
mergeImport
m
y
(
entities
x'
env
))
env
>
where
x'
=
qualify
x
>
qualImportTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
->
TopEnv
a
>
qualImportTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
>
->
TopEnv
a
>
qualImportTopEnv
m
x
y
(
TopEnv
env
)
=
>
TopEnv
$
Map
.
insert
x'
(
mergeImport
m
y
(
entities
x'
env
))
env
>
where
x'
=
qualifyWith
m
x
>
mergeImport
::
Entity
a
=>
ModuleIdent
->
a
->
[(
Source
,
a
)]
->
[(
Source
,
a
)]
>
mergeImport
::
Entity
a
=>
ModuleIdent
->
a
->
[(
Source
,
a
)]
>
->
[(
Source
,
a
)]
>
mergeImport
m
x
[]
=
[(
Import
[
m
],
x
)]
>
mergeImport
m
x
(
loc
@
(
Local
,
_
)
:
xs
)
=
loc
:
mergeImport
m
x
xs
>
mergeImport
m
x
(
imp
@
(
Import
ms
,
x'
)
:
xs
)
=
case
merge
x
x'
of
...
...
@@ -107,9 +110,10 @@ 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
"TopEnv.qualRebindTopEnv"
>
rebindLocal
((
Local
,
_
)
:
ys
)
=
(
Local
,
y
)
:
ys
>
rebindLocal
(
imported
:
ys
)
=
imported
:
rebindLocal
ys
>
where
>
rebindLocal
[]
=
internalError
"TopEnv.qualRebindTopEnv"
>
rebindLocal
((
Local
,
_
)
:
ys
)
=
(
Local
,
y
)
:
ys
>
rebindLocal
(
imported
:
ys
)
=
imported
:
rebindLocal
ys
>
unbindTopEnv
::
Ident
->
TopEnv
a
->
TopEnv
a
>
unbindTopEnv
x
(
TopEnv
env
)
=
...
...
src/Base/Typing.lhs
View file @
cc84f0ac
...
...
@@ -366,8 +366,8 @@ checker.
>
unifyTypes
(
TypeVariable
a1
)
>
(
TypeVariable
a2
)
>
(
foldr
(
unifyTypedLabels
fs1
)
theta
fs2
)
>
unifyTypes
ty1
ty2
_
=
>
internalError
(
"Base.Typing.unify: ("
++
show
ty1
++
") ("
++
show
ty2
++
")"
)
>
unifyTypes
ty1
ty2
_
=
internalError
$
>
"Base.Typing.unify: ("
++
show
ty1
++
") ("
++
show
ty2
++
")"
>
unifyTypedLabels
::
[(
Ident
,
Type
)]
->
(
Ident
,
Type
)
->
TypeSubst
->
TypeSubst
>
unifyTypedLabels
fs1
(
l
,
ty
)
theta
=
...
...
src/Checks.hs
View file @
cc84f0ac
...
...
@@ -70,7 +70,8 @@ precCheck env (Module m es is ds)
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck
::
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
typeCheck
env
mdl
@
(
Module
_
_
_
ds
)
=
(
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
},
mdl
)
typeCheck
env
mdl
@
(
Module
_
_
_
ds
)
=
(
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
},
mdl
)
where
(
tcEnv'
,
tyEnv'
)
=
TC
.
typeCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
ds
...
...
src/Checks/SyntaxCheck.lhs
View file @
cc84f0ac
...
...
@@ -1024,7 +1024,7 @@ Error messages.
>
errIllegalLabel
::
Ident
->
QualIdent
->
Message
>
errIllegalLabel
l
r
=
posErr
l
$
>
"Label `"
++
name
l
++
"` is not defined in record `"
>
++ name (unqualify r) ++ "`"
>
++
name
(
unqualify
r
)
++
"`"
>
errIllegalRecordId
::
Ident
->
Message
>
errIllegalRecordId
r
=
posErr
r
$
"Record identifier `"
++
name
r
...
...
src/Imports.hs
View file @
cc84f0ac
...
...
@@ -94,14 +94,16 @@ importInterface m q is i env = env
,
valueEnv
=
importEntities
m
q
vs
id
mTyEnv
$
valueEnv
env
,
arityEnv
=
importEntities
m
q
as
id
mAEnv
$
arityEnv
env
}
where
mPEnv
=
intfEnv
bindPrec
i
-- all operator precedences
mTCEnv
=
intfEnv
bindTC
i
-- all type constructors
mTyEnv
=
intfEnv
bindTy
i
-- all values
mAEnv
=
intfEnv
bindA
i
-- all arities
expandedSpec
=
maybe
[]
(
expandSpecs
m
mTCEnv
mTyEnv
)
is
-- all imported type constructors / values
ts
=
isVisible
is
(
Set
.
fromList
$
foldr
addType
[]
expandedSpec
)
vs
=
isVisible
is
(
Set
.
fromList
$
foldr
addValue
[]
expandedSpec
)
as
=
isVisible
is
(
Set
.
fromList
$
foldr
addArity
[]
expandedSpec
)
where
mPEnv
=
intfEnv
bindPrec
i
-- all operator precedences
mTCEnv
=
intfEnv
bindTC
i
-- all type constructors
mTyEnv
=
intfEnv
bindTy
i
-- all values
mAEnv
=
intfEnv
bindA
i
-- all arities
-- all imported type constructors / values
expandedSpec
=
maybe
[]
(
expandSpecs
m
mTCEnv
mTyEnv
)
is
ts
=
isVisible
is
(
Set
.
fromList
$
foldr
addType
[]
expandedSpec
)
vs
=
isVisible
is
(
Set
.
fromList
$
foldr
addValue
[]
expandedSpec
)
as
=
isVisible
is
(
Set
.
fromList
$
foldr
addArity
[]
expandedSpec
)
isVisible
::
Maybe
ImportSpec
->
Set
.
Set
Ident
->
Ident
->
Bool
isVisible
(
Just
(
Importing
_
_
))
xs
=
(`
Set
.
member
`
xs
)
...
...
@@ -278,14 +280,19 @@ expandSpecs m tcEnv tyEnv (Hiding _ is) =
concatMap
(
expandHiding
m
tcEnv
tyEnv
)
is
expandImport
::
ModuleIdent
->
ExpTCEnv
->
ExpValueEnv
->
Import
->
[
Import
]
expandImport
m
tcEnv
tyEnv
(
Import
x
)
=
expandThing
m
tcEnv
tyEnv
x
expandImport
m
tcEnv
_
(
ImportTypeWith
tc
cs
)
=
[
expandTypeWith
m
tcEnv
tc
cs
]
expandImport
m
tcEnv
_
(
ImportTypeAll
tc
)
=
[
expandTypeAll
m
tcEnv
tc
]
expandImport
m
tcEnv
tyEnv
(
Import
x
)
=
expandThing
m
tcEnv
tyEnv
x
expandImport
m
tcEnv
_
(
ImportTypeWith
tc
cs
)
=
[
expandTypeWith
m
tcEnv
tc
cs
]
expandImport
m
tcEnv
_
(
ImportTypeAll
tc
)
=
[
expandTypeAll
m
tcEnv
tc
]
expandHiding
::
ModuleIdent
->
ExpTCEnv
->
ExpValueEnv
->
Import
->
[
Import
]
expandHiding
m
tcEnv
tyEnv
(
Import
x
)
=
expandHide
m
tcEnv
tyEnv
x
expandHiding
m
tcEnv
_
(
ImportTypeWith
tc
cs
)
=
[
expandTypeWith
m
tcEnv
tc
cs
]
expandHiding
m
tcEnv
_
(
ImportTypeAll
tc
)
=
[
expandTypeAll
m
tcEnv
tc
]
expandHiding
m
tcEnv
_
(
ImportTypeWith
tc
cs
)
=
[
expandTypeWith
m
tcEnv
tc
cs
]
expandHiding
m
tcEnv
_
(
ImportTypeAll
tc
)
=
[
expandTypeAll
m
tcEnv
tc
]
-- try to expand as type constructor
expandThing
::
ModuleIdent
->
ExpTCEnv
->
ExpValueEnv
->
Ident
->
[
Import
]
...
...
@@ -294,7 +301,8 @@ expandThing m tcEnv tyEnv tc = case Map.lookup tc tcEnv of
Nothing
->
expandThing'
m
tyEnv
tc
Nothing
-- try to expand as function / data constructor
expandThing'
::
ModuleIdent
->
ExpValueEnv
->
Ident
->
Maybe
[
Import
]
->
[
Import
]
expandThing'
::
ModuleIdent
->
ExpValueEnv
->
Ident
->
Maybe
[
Import
]
->
[
Import
]
expandThing'
m
tyEnv
f
tcImport
=
case
Map
.
lookup
f
tyEnv
of
Just
v
|
isConstr
v
->
fromMaybe
(
errorAt'
$
importDataConstr
m
f
)
tcImport
...
...
@@ -312,15 +320,16 @@ expandHide m tcEnv tyEnv tc = case Map.lookup tc tcEnv of
Nothing
->
expandHide'
m
tyEnv
tc
Nothing
-- try to hide as function / data constructor
expandHide'
::
ModuleIdent
->
ExpValueEnv
->
Ident
->
Maybe
[
Import
]
->
[
Import
]
expandHide'
::
ModuleIdent
->
ExpValueEnv
->
Ident
->
Maybe
[
Import
]
->
[
Import
]
expandHide'
m
tyEnv
f
tcImport
=
case
Map
.
lookup
f
tyEnv
of
Just
_
->
Import
f
:
fromMaybe
[]
tcImport
Nothing
->
fromMaybe
(
errorAt'
$
undefinedEntity
m
f
)
tcImport
expandTypeWith
::
ModuleIdent
->
ExpTCEnv
->
Ident
->
[
Ident
]
->
Import
expandTypeWith
m
tcEnv
tc
cs
=
case
Map
.
lookup
tc
tcEnv
of
Just
(
DataType
_
_
cs'
)
->
ImportTypeWith
tc
(
map
(
checkConstr
[
c
|
Just
(
DataConstr
c
_
_
)
<-
cs'
])
cs
)
Just
(
DataType
_
_
cs'
)
->
ImportTypeWith
tc
(
map
(
checkConstr
[
c
|
Just
(
DataConstr
c
_
_
)
<-
cs'
])
cs
)
Just
(
RenamingType
_
_
(
DataConstr
c
_
_
))
->
ImportTypeWith
tc
(
map
(
checkConstr
[
c
])
cs
)
Just
_
->
errorAt'
$
nonDataType
tc
...
...
@@ -369,11 +378,12 @@ importUnifyData cEnv = cEnv { tyConsEnv = importUnifyData' $ tyConsEnv cEnv }
importUnifyData'
::
TCEnv
->
TCEnv
importUnifyData'
tcEnv
=
fmap
(
setInfo
allTyCons
)
tcEnv
where
setInfo
tcs
t
=
fromJust
$
Map
.
lookup
(
origName
t
)
tcs
allTyCons
=
foldr
(
mergeData
.
snd
)
Map
.
empty
$
allImports
tcEnv
mergeData
t
tcs
=
Map
.
insert
tc
(
maybe
t
(
fromJust
.
merge
t
)
$
Map
.
lookup
tc
tcs
)
tcs
where
tc
=
origName
t
where
setInfo
tcs
t
=
fromJust
$
Map
.
lookup
(
origName
t
)
tcs
allTyCons
=
foldr
(
mergeData
.
snd
)
Map
.
empty
$
allImports
tcEnv
mergeData
t
tcs
=
Map
.
insert
tc
(
maybe
t
(
fromJust
.
merge
t
)
$
Map
.
lookup
tc
tcs
)
tcs
where
tc
=
origName
t
-- ---------------------------------------------------------------------------
...
...
@@ -416,11 +426,11 @@ importInterfaceIntf i@(Interface m _ _) env = env
,
valueEnv
=
importEntities
m
True
(
const
True
)
id
mTyEnv
$
valueEnv
env
,
arityEnv
=
importEntities
m
True
(
const
True
)
id
mAEnv
$
arityEnv
env
}
where
mPEnv
=
intfEnv
bindPrec
i
-- all operator precedences
m
TC
Env
=
intfEnv
bind
TCHidden
i
-- all
type constructor
s
mT
y
Env
=
intfEnv
bindT
y
i
-- all
value
s
m
A
Env
=
intfEnv
bind
A
i
-- all
ariti
es
where
m
P
Env
=
intfEnv
bind
Prec
i
-- all
operator precedence
s
mT
C
Env
=
intfEnv
bindT
CHidden
i
-- all
type constructor
s
m
Ty
Env
=
intfEnv
bind
Ty
i
-- all
valu
es
mAEnv
=
intfEnv
bindA
i
-- all arities
-- Error messages:
...
...
Write
Preview
Markdown
is supported
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