Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
PLMZ
iTypes
Commits
30a6f9c0
Commit
30a6f9c0
authored
Aug 23, 2019
by
André Pacak
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
variant type errorlist, continue after failure and type argument elimination transformation
parent
5d715e25
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
84 additions
and
4 deletions
+84
-4
haskell/src/SumTypes/ContinueAfterCheckFail.hs
haskell/src/SumTypes/ContinueAfterCheckFail.hs
+24
-0
haskell/src/SumTypes/EliminateTypeArgumentOfCheck.hs
haskell/src/SumTypes/EliminateTypeArgumentOfCheck.hs
+38
-4
haskell/src/SumTypes/ErrorList.hs
haskell/src/SumTypes/ErrorList.hs
+22
-0
No files found.
haskell/src/SumTypes/ContinueAfterCheckFail.hs
View file @
30a6f9c0
...
...
@@ -6,6 +6,7 @@ module SumTypes.ContinueAfterCheckFail where
import
Prelude
hiding
(
Monad
(
..
),
(
>=
),
(
<=
),
lookup
)
import
GHC.Exts
(
Constraint
)
import
qualified
Data.Map
as
Map
import
SumTypes.Language
import
Util.ErrorMessages
...
...
@@ -42,6 +43,8 @@ instance WithTop () where
instance
(
WithTop
a
,
WithTop
b
)
=>
WithTop
(
a
,
b
)
where
top
=
(
top
,
top
)
instance
(
WithTop
v
)
=>
WithTop
(
Map
.
Map
Name
v
)
where
top
=
Map
.
empty
-- Had to define an own monad type class.
-- It is not possible otherwise to get the type constraint WithTop a.
...
...
@@ -85,6 +88,14 @@ matchSum :: Type -> String -> Infer (Type, Type)
matchSum
(
Sum
ty1
ty2
)
_
=
return
(
ty1
,
ty2
)
matchSum
ty
err
=
fail
[
sumError
ty
err
]
matchVariant
::
Type
->
String
->
Infer
(
Map
.
Map
Name
Type
)
matchVariant
(
Variant
types
)
_
=
return
types
matchVariant
ty
err
=
fail
[
variantError
ty
err
]
liftMaybe
::
WithTop
a
=>
Maybe
a
->
String
->
Infer
a
liftMaybe
(
Just
a
)
_
=
return
a
liftMaybe
Nothing
err
=
fail
[
err
]
lookup
::
Ctx
->
Name
->
Infer
Type
lookup
Empty
x
=
fail
[
"Unbound variable "
++
show
x
]
lookup
(
Bind
c
x
t
)
y
|
x
==
y
=
return
t
...
...
@@ -132,6 +143,19 @@ checkType ctx p@(Case e n1 t1 n2 t2 _) ty = do
(
ty1
,
ty2
)
<-
matchSum
ety
(
show
e
)
checkType
(
Bind
ctx
n1
ty1
)
t1
ty
checkType
(
Bind
ctx
n2
ty2
)
t2
ty
checkType
ctx
p
@
(
Tag
n
t
_
)
ty
=
do
types
<-
matchVariant
ty
(
show
p
)
lty
<-
liftMaybe
(
Map
.
lookup
n
types
)
"Label not contained in Variant"
checkType
ctx
t
lty
checkType
ctx
p
@
(
Match
m
cases
_
)
ty
=
do
ety
<-
inferType
ctx
m
types
<-
matchVariant
ety
(
show
m
)
let
subchecks
=
map
(
\
(
l
,
x
,
t
)
->
do
lty
<-
liftMaybe
(
Map
.
lookup
l
types
)
"Could not find labeled type"
checkType
(
Bind
ctx
x
lty
)
t
ty
)
cases
foldl
(
>>
)
(
return
()
)
subchecks
checkType
ctx
t
ty
=
do
ty'
<-
inferType
ctx
t
matchType
ty
ty'
(
show
t
)
haskell/src/SumTypes/EliminateTypeArgumentOfCheck.hs
View file @
30a6f9c0
...
...
@@ -6,6 +6,7 @@ module SumTypes.EliminateTypeArgumentOfCheck where
import
Prelude
hiding
(
Monad
(
..
),
(
>=
),
(
<=
),
lookup
)
import
GHC.Exts
(
Constraint
)
import
qualified
Data.Map
as
Map
import
SumTypes.Language
import
Util.ErrorMessages
...
...
@@ -42,6 +43,9 @@ instance WithTop () where
instance
(
WithTop
a
,
WithTop
b
)
=>
WithTop
(
a
,
b
)
where
top
=
(
top
,
top
)
instance
(
WithTop
v
)
=>
WithTop
(
Map
.
Map
Name
v
)
where
top
=
Map
.
empty
-- Had to define an own monad type class.
-- It is not possible otherwise to get the type constraint WithTop a.
-- We use the extension ConstraintKinds to support this.
...
...
@@ -76,13 +80,21 @@ matchFun :: Type -> String -> Infer (Type, Type)
matchFun
(
Fun
ty1
ty2
)
_
=
return
(
ty1
,
ty2
)
matchFun
ty
err
=
fail
[
funError
ty
err
]
matchType
::
Type
->
Type
->
String
->
Check
matchType
ty1
ty2
_
|
ty1
>=
ty2
=
return
()
matchType
ty1
ty2
err
=
fail
[
generalError
(
show
ty1
)
ty2
err
]
matchSum
::
Type
->
String
->
Infer
(
Type
,
Type
)
matchSum
(
Sum
ty1
ty2
)
_
=
return
(
ty1
,
ty2
)
matchSum
ty
err
=
fail
[
sumError
ty
err
]
matchType
::
Type
->
Type
->
String
->
Check
matchType
ty1
ty2
_
|
ty1
>=
ty2
=
return
()
matchType
ty1
ty2
err
=
fail
[
generalError
(
show
ty1
)
ty2
err
]
matchVariant
::
Type
->
String
->
Infer
(
Map
.
Map
Name
Type
)
matchVariant
(
Variant
types
)
_
=
return
types
matchVariant
ty
err
=
fail
[
variantError
ty
err
]
liftMaybe
::
WithTop
a
=>
Maybe
a
->
String
->
Infer
a
liftMaybe
(
Just
a
)
_
=
return
a
liftMaybe
Nothing
err
=
fail
[
err
]
lookup
::
Ctx
->
Name
->
Infer
Type
lookup
Empty
x
=
fail
[
"Unbound variable "
++
show
x
]
...
...
@@ -136,7 +148,22 @@ checkType ctx p@(Case e n1 t1 n2 t2 _) = do
ty
<-
requiredType
ctx
p
checkType
(
Bind
ctx
n1
ty1
)
t1
checkType
(
Bind
ctx
n2
ty2
)
t2
checkType
ctx
p
@
(
Tag
n
t
_
)
=
do
ty
<-
requiredType
ctx
p
types
<-
matchVariant
ty
(
show
p
)
let
lty
=
Map
.
lookup
n
types
lty
<-
liftMaybe
(
Map
.
lookup
n
types
)
"Label not contained in Variant"
checkType
ctx
t
checkType
ctx
p
@
(
Match
m
cases
_
)
=
do
ety
<-
inferType
ctx
m
types
<-
matchVariant
ety
(
show
m
)
ty
<-
requiredType
ctx
p
let
subchecks
=
map
(
\
(
l
,
x
,
t
)
->
do
lty
<-
liftMaybe
(
Map
.
lookup
l
types
)
"Could not find labeled type"
checkType
(
Bind
ctx
x
lty
)
t
)
cases
foldl
(
>>
)
(
return
()
)
subchecks
checkType
ctx
t
=
do
ty
<-
requiredType
ctx
t
ty'
<-
inferType
ctx
t
...
...
@@ -183,4 +210,11 @@ requiredType ctx t = case parent t of
(
ty1
,
ty2
)
<-
matchSum
ety
(
show
e
)
ty
<-
requiredType
ctx'
p
return
ty
Just
p
@
(
Tag
n
t'
_
)
|
t
==
t'
->
do
ty
<-
requiredType
ctx
p
types
<-
matchVariant
ty
(
show
p
)
liftMaybe
(
Map
.
lookup
n
types
)
"Label not contained in Variant"
Just
p
@
(
Match
m
cases
_
)
->
do
ty
<-
requiredType
ctx
p
return
ty
_
->
fail
[
"Could not determine required type"
]
haskell/src/SumTypes/ErrorList.hs
View file @
30a6f9c0
...
...
@@ -2,6 +2,7 @@ module SumTypes.ErrorList where
import
Prelude
hiding
(
lookup
,
Ord
)
import
Data.List
(
find
)
import
qualified
Data.Map
as
Map
import
SumTypes.Language
import
Util.ErrorMessages
...
...
@@ -44,6 +45,14 @@ matchSum :: Type -> String -> Infer (Type, Type)
matchSum
(
Sum
ty1
ty2
)
_
=
return
(
ty1
,
ty2
)
matchSum
ty
err
=
fail
$
sumError
ty
err
matchVariant
::
Type
->
String
->
Infer
(
Map
.
Map
Name
Type
)
matchVariant
(
Variant
types
)
_
=
return
types
matchVariant
ty
err
=
fail
$
variantError
ty
err
liftMaybe
::
Monad
m
=>
Maybe
a
->
String
->
m
a
liftMaybe
(
Just
a
)
_
=
return
a
liftMaybe
Nothing
err
=
fail
err
lookup
::
Ctx
->
Name
->
Infer
Type
lookup
Empty
x
=
fail
$
"Unbound variable "
++
show
x
lookup
(
Bind
c
x
t
)
y
|
x
==
y
=
return
t
...
...
@@ -91,6 +100,19 @@ checkType ctx p@(Case e n1 t1 n2 t2 _) ty = do
(
ty1
,
ty2
)
<-
matchSum
ety
(
show
e
)
checkType
(
Bind
ctx
n1
ty1
)
t1
ty
checkType
(
Bind
ctx
n2
ty2
)
t2
ty
checkType
ctx
p
@
(
Tag
n
t
_
)
ty
=
do
types
<-
matchVariant
ty
(
show
p
)
let
lty
=
Map
.
lookup
n
types
(
maybe
(
fail
""
)
(
checkType
ctx
t
)
lty
)
checkType
ctx
p
@
(
Match
m
cases
_
)
ty
=
do
ety
<-
inferType
ctx
m
types
<-
matchVariant
ety
(
show
m
)
let
subchecks
=
map
(
\
(
l
,
x
,
t
)
->
do
lty
<-
liftMaybe
(
Map
.
lookup
l
types
)
"Could not find labeled type"
checkType
(
Bind
ctx
x
lty
)
t
ty
)
cases
foldl
(
>>
)
(
return
()
)
subchecks
checkType
ctx
t
ty
=
do
ty'
<-
inferType
ctx
t
matchType
ty
ty'
(
show
t
)
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