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
1b5211c8
Commit
1b5211c8
authored
Nov 05, 2019
by
André Pacak
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
fixed type checker and the current transformations
parent
34ba88d4
Changes
6
Show whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
49 additions
and
50 deletions
+49
-50
haskell/src/ADTypes/Base.hs
haskell/src/ADTypes/Base.hs
+6
-9
haskell/src/ADTypes/ContinueAfterFail.hs
haskell/src/ADTypes/ContinueAfterFail.hs
+8
-12
haskell/src/ADTypes/EliminateTypeArgumentOfCheck.hs
haskell/src/ADTypes/EliminateTypeArgumentOfCheck.hs
+27
-17
haskell/src/ADTypes/ErrorList.hs
haskell/src/ADTypes/ErrorList.hs
+6
-10
haskell/test/ADTypes/SharedSpecs.hs
haskell/test/ADTypes/SharedSpecs.hs
+1
-1
haskell/test/ADTypes/TestCases.hs
haskell/test/ADTypes/TestCases.hs
+1
-1
No files found.
haskell/src/ADTypes/Base.hs
View file @
1b5211c8
...
...
@@ -109,7 +109,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType
ctx
tymap
t1
Bool
checkType
ctx
tymap
t2
Bool
return
Bool
inferType
ctx
_
(
Var
name
_
)
=
lookupVar
ctx
name
inferType
ctx
tymap
(
Var
name
_
)
=
do
ty
<-
lookupVar
ctx
name
matchTypeVar
tymap
ty
inferType
ctx
tymap
(
Let
name
t
body
_
)
=
do
tyt
<-
inferType
ctx
tymap
t
inferType
(
Bind
ctx
name
tyt
)
tymap
body
...
...
@@ -159,14 +161,9 @@ checkType ctx tymap (Match m cases _) ty = do
let
casechecks
=
map
(
\
c
->
do
tys
<-
liftMaybe
(
M
.
lookup
(
labelOfCase
c
)
cotrs
)
"Could not find constructor"
::
Infer
[
Type
]
if
length
(
bindingsOfCase
c
)
==
length
tys
then
if
not
(
null
(
bindingsOfCase
c
))
then
do
let
bindchecks
=
map
(
\
(
b
,
bty
)
->
checkType
(
Bind
ctx
b
bty
)
tymap
(
termOfCase
c
)
ty
)
$
zip
(
bindingsOfCase
c
)
tys
foldl
(
>>
)
(
return
()
)
bindchecks
else
checkType
ctx
tymap
(
termOfCase
c
)
ty
let
ctx'
=
foldl
(
\
r
(
b
,
bty
)
->
Bind
r
b
bty
)
ctx
(
zip
(
bindingsOfCase
c
)
tys
)
checkType
ctx'
tymap
(
termOfCase
c
)
ty
else
fail
"number of bindings does not match number of args of constructor"
)
cases
foldl
(
>>
)
(
return
()
)
casechecks
...
...
haskell/src/ADTypes/ContinueAfterFail.hs
View file @
1b5211c8
...
...
@@ -131,7 +131,6 @@ lookupCotr (Bind c x ty) y = case ty of
else
lookupCotr
c
y
_
->
lookupCotr
c
y
inferType
::
Ctx
->
TypeMap
->
Term
->
Infer
Type
inferType
_
_
(
Zero
_
)
=
return
Nat
inferType
ctx
tymap
(
Succ
t
_
)
=
do
...
...
@@ -158,7 +157,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType
ctx
tymap
t1
Bool
checkType
ctx
tymap
t2
Bool
return
Bool
inferType
ctx
_
(
Var
name
_
)
=
lookupVar
ctx
name
inferType
ctx
tymap
(
Var
name
_
)
=
do
ty
<-
lookupVar
ctx
name
matchTypeVar
tymap
ty
inferType
ctx
tymap
(
Let
name
t
body
_
)
=
do
tyt
<-
inferType
ctx
tymap
t
inferType
(
Bind
ctx
name
tyt
)
tymap
body
...
...
@@ -182,10 +183,10 @@ inferType ctx tymap (Cotr n ts p) = do
if
length
ts
==
length
tys
then
do
-- check types accordingly to definition
let
subchecks
=
map
(
\
(
t
,
ty
)
->
do
let
subchecks
=
zipWith
(
\
t
ty
->
do
ty'
<-
matchTypeVar
tymap
ty
checkType
ctx
tymap
t
ty'
)
(
zip
ts
tys
)
-- basically a map over the [(Term, Type)] and apply check ctx
)
ts
tys
-- basically a map over the [(Term, Type)] and apply check ctx
foldl
(
>>
)
(
return
()
)
subchecks
return
adty
else
fail
[
"Expected number of arguments violated for "
++
show
(
Cotr
n
ts
p
)]
...
...
@@ -208,14 +209,9 @@ checkType ctx tymap (Match m cases _) ty = do
let
casechecks
=
map
(
\
c
->
do
tys
<-
liftMaybe
(
M
.
lookup
(
labelOfCase
c
)
cotrs
)
"Could not find constructor"
::
Infer
[
Type
]
if
length
(
bindingsOfCase
c
)
==
length
tys
then
if
not
(
null
(
bindingsOfCase
c
))
then
do
let
bindchecks
=
map
(
\
(
b
,
bty
)
->
checkType
(
Bind
ctx
b
bty
)
tymap
(
termOfCase
c
)
ty
)
$
zip
(
bindingsOfCase
c
)
tys
foldl
(
>>
)
(
return
()
)
bindchecks
else
checkType
ctx
tymap
(
termOfCase
c
)
ty
let
ctx'
=
foldl
(
\
r
(
b
,
bty
)
->
Bind
r
b
bty
)
ctx
(
zip
(
bindingsOfCase
c
)
tys
)
checkType
ctx'
tymap
(
termOfCase
c
)
ty
else
fail
[
"number of bindings does not match number of args of constructor"
]
)
cases
foldl
(
>>
)
(
return
()
)
casechecks
...
...
haskell/src/ADTypes/EliminateTypeArgumentOfCheck.hs
View file @
1b5211c8
...
...
@@ -133,7 +133,6 @@ lookupCotr (Bind c x ty) y = case ty of
else
lookupCotr
c
y
_
->
lookupCotr
c
y
inferType
::
Ctx
->
TypeMap
->
Term
->
Infer
Type
inferType
_
_
(
Zero
_
)
=
return
Nat
inferType
ctx
tymap
(
Succ
t
_
)
=
do
...
...
@@ -160,7 +159,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType
ctx
tymap
t1
checkType
ctx
tymap
t2
return
Bool
inferType
ctx
_
(
Var
name
_
)
=
lookupVar
ctx
name
inferType
ctx
tymap
(
Var
name
_
)
=
do
ty
<-
lookupVar
ctx
name
matchTypeVar
tymap
ty
inferType
ctx
tymap
(
Let
name
t
body
_
)
=
do
tyt
<-
inferType
ctx
tymap
t
inferType
(
Bind
ctx
name
tyt
)
tymap
body
...
...
@@ -179,14 +180,15 @@ inferType ctx tymap (LetData n adty t _) =
inferType
ctx
tymap
(
Cotr
n
ts
p
)
=
do
-- TODO find better solution
-- PROBLEM we need to find the binding that contains the constructor
(
adty
,
tys
)
<-
lookupCotr
tymap
n
if
length
ts
==
length
tys
then
do
-- check types accordingly to definition
let
subchecks
=
map
(
\
(
t
,
ty
)
->
do
let
subchecks
=
zipWith
(
\
t
ty
->
do
ty'
<-
matchTypeVar
tymap
ty
checkType
ctx
tymap
t
)
(
zip
ts
tys
)
-- basically a map over the [(Term, Type)] and apply check ctx
)
ts
tys
-- basically a map over the [(Term, Type)] and apply check ctx
foldl
(
>>
)
(
return
()
)
subchecks
return
adty
else
fail
[
"Expected number of arguments violated for "
++
show
(
Cotr
n
ts
p
)]
...
...
@@ -212,14 +214,9 @@ checkType ctx tymap p@(Match m cases _) = do
let
casechecks
=
map
(
\
c
->
do
tys
<-
liftMaybe
(
M
.
lookup
(
labelOfCase
c
)
cotrs
)
"Could not find constructor"
::
Infer
[
Type
]
if
length
(
bindingsOfCase
c
)
==
length
tys
then
if
not
(
null
(
bindingsOfCase
c
))
then
do
let
bindchecks
=
map
(
\
(
b
,
bty
)
->
checkType
(
Bind
ctx
b
bty
)
tymap
(
termOfCase
c
)
)
$
zip
(
bindingsOfCase
c
)
tys
foldl
(
>>
)
(
return
()
)
bindchecks
else
checkType
ctx
tymap
(
termOfCase
c
)
let
ctx'
=
foldl
(
\
r
(
b
,
bty
)
->
Bind
r
b
bty
)
ctx
(
zip
(
bindingsOfCase
c
)
tys
)
checkType
ctx'
tymap
(
termOfCase
c
)
else
fail
[
"number of bindings does not match number of args of constructor"
]
)
cases
foldl
(
>>
)
(
return
()
)
casechecks
...
...
@@ -270,9 +267,22 @@ requiredType ctx tymap term = case parent term of
(
_
,
cotrs
)
<-
matchADT
mty'
(
show
m
)
if
length
cases
==
length
cotrs
then
do
-- throw away ctx extension if bindingsOfCase c != null
-- let x = find (\c -> term == termOfCase c) cases
let
(
Bind
ctx'
_
_
)
=
ctx
requiredType
ctx'
tymap
p
else
fail
[
"cases do not match number of constructors of"
++
show
m
]
let
maybeCase
=
find
(
\
c
->
termOfCase
c
==
term
)
cases
case
maybeCase
of
Just
c
->
do
tys
<-
liftMaybe
(
M
.
lookup
(
labelOfCase
c
)
cotrs
)
"Could not find constructor"
::
Infer
[
Type
]
let
ctx'
=
foldl
(
\
r
(
b
,
bty
)
->
let
(
Bind
r'
_
_
)
=
r
in
r'
)
ctx
(
zip
(
bindingsOfCase
c
)
tys
)
ty
<-
requiredType
ctx'
tymap
p
return
ty
Nothing
->
fail
[
"could not find corresponding case"
]
-- let casechecks = map (\c -> do
-- tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type]
-- if length (bindingsOfCase c) == length tys
-- then do
-- let ctx' = foldl (\r (b, bty) -> Bind r b bty) ctx (zip (bindingsOfCase c) tys)
-- checkType ctx' tymap (termOfCase c)
-- else fail ["number of bindings does not match number of args of constructor"]
-- ) cases
-- foldl (>>) (return ()) casechecks
else
fail
[
""
]
_
->
fail
[
"Could not determine required type"
]
haskell/src/ADTypes/ErrorList.hs
View file @
1b5211c8
...
...
@@ -82,7 +82,6 @@ lookupCotr (Bind c x ty) y = case ty of
else
lookupCotr
c
y
_
->
lookupCotr
c
y
inferType
::
Ctx
->
TypeMap
->
Term
->
Infer
Type
inferType
_
_
(
Zero
_
)
=
return
Nat
inferType
ctx
tymap
(
Succ
t
_
)
=
do
...
...
@@ -109,7 +108,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType
ctx
tymap
t1
Bool
checkType
ctx
tymap
t2
Bool
return
Bool
inferType
ctx
_
(
Var
name
_
)
=
lookupVar
ctx
name
inferType
ctx
tymap
(
Var
name
_
)
=
do
ty
<-
lookupVar
ctx
name
matchTypeVar
tymap
ty
inferType
ctx
tymap
(
Let
name
t
body
_
)
=
do
tyt
<-
inferType
ctx
tymap
t
inferType
(
Bind
ctx
name
tyt
)
tymap
body
...
...
@@ -159,14 +160,9 @@ checkType ctx tymap (Match m cases _) ty = do
let
casechecks
=
map
(
\
c
->
do
tys
<-
liftMaybe
(
M
.
lookup
(
labelOfCase
c
)
cotrs
)
"Could not find constructor"
::
Infer
[
Type
]
if
length
(
bindingsOfCase
c
)
==
length
tys
then
if
not
(
null
(
bindingsOfCase
c
))
then
do
let
bindchecks
=
map
(
\
(
b
,
bty
)
->
checkType
(
Bind
ctx
b
bty
)
tymap
(
termOfCase
c
)
ty
)
$
zip
(
bindingsOfCase
c
)
tys
foldl
(
>>
)
(
return
()
)
bindchecks
else
checkType
ctx
tymap
(
termOfCase
c
)
ty
let
ctx'
=
foldl
(
\
r
(
b
,
bty
)
->
Bind
r
b
bty
)
ctx
(
zip
(
bindingsOfCase
c
)
tys
)
checkType
ctx'
tymap
(
termOfCase
c
)
ty
else
fail
"number of bindings does not match number of args of constructor"
)
cases
foldl
(
>>
)
(
return
()
)
casechecks
...
...
haskell/test/ADTypes/SharedSpecs.hs
View file @
1b5211c8
...
...
@@ -52,7 +52,7 @@ sharedSpec inferType = do
it
"should infer match with single binds"
$
do
let
res
=
convert
$
inferType
tOkMatchTwo
in
res
`
shouldBe
`
B
.
Inferred
boolADT
it
"should infer match with multiple binds"
$
do
let
res
=
convert
$
inferType
tOkMatchWithMultiplebinds
in
res
`
shouldBe
`
B
.
Inferred
Nat
let
res
=
convert
$
inferType
tOkMatchWithMultiplebinds
in
res
`
shouldBe
`
B
.
Inferred
expADT
it
"should infer match for simple adt (bool)"
$
do
let
res
=
convert
$
inferType
tOkMatchSingle
in
res
`
shouldBe
`
B
.
Inferred
boolADT
...
...
haskell/test/ADTypes/TestCases.hs
View file @
1b5211c8
...
...
@@ -26,7 +26,7 @@ tOkCotrSingleArg = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("F
tOkCotrTwoArg
=
root
(
letdata
"Bool"
(
ADT
"Bool"
(
fromList
[(
"True"
,
[]
),
(
"False"
,
[]
)]))
(
letdata
"Exp"
(
ADT
"Exp"
(
fromList
[(
"BoolExp"
,
[
TypeVar
"Bool"
]),
(
"AndExp"
,
[
TypeVar
"Exp"
,
TypeVar
"Exp"
]),
(
"NotExp"
,
[
TypeVar
"Exp"
])]))
(
cotr2
"AndExp"
(
cotr1
"BoolExp"
(
cotr0
"True"
))
(
cotr1
"BoolExp"
(
cotr0
"False"
)))))
tOkMatchSingle
=
root
(
letdata
"Bool"
(
ADT
"Bool"
(
fromList
[(
"True"
,
[]
),
(
"False"
,
[]
)]))
(
anno
boolADT
(
match2
(
cotr0
"True"
)
(
case'
"True"
[]
(
cotr0
"False"
))
(
case'
"False"
[]
(
cotr0
"True"
)))))
tOkMatchTwo
=
root
(
letdata
"Bool"
(
ADT
"Bool"
(
fromList
[(
"True"
,
[]
),
(
"False"
,
[]
)]))
(
anno
boolADT
(
match2
(
cotr0
"True"
)
(
case'
"True"
[]
(
cotr0
"False"
))
(
case'
"False"
[]
(
cotr0
"True"
)))))
tOkMatchWithMultiplebinds
=
root
(
letdata
"Bool"
(
ADT
"Bool"
(
fromList
[(
"True"
,
[]
),
(
"False"
,
[]
)]))
(
letdata
"Exp"
(
ADT
"Exp"
(
fromList
[(
"BoolExp"
,
[
TypeVar
"Bool"
]),
(
"AndExp"
,
[
TypeVar
"Exp"
,
TypeVar
"Exp"
]),
(
"NotExp"
,
[
TypeVar
"Exp"
])]))
(
anno
Nat
(
match3
((
cotr2
"AndExp"
(
cotr1
"BoolExp"
(
cotr0
"True"
))
(
cotr1
"BoolExp"
(
cotr0
"False"
))))
(
case'
"BoolExp"
[
"x"
]
zero
)
(
case'
"AndExp"
[
"x"
,
"y"
]
(
succ
(
succ
zero
)))
(
case'
"NotExp"
[
"x"
]
(
succ
zero
))))))
tOkMatchWithMultiplebinds
=
root
(
letdata
"Bool"
(
ADT
"Bool"
(
fromList
[(
"True"
,
[]
),
(
"False"
,
[]
)]))
(
letdata
"Exp"
(
ADT
"Exp"
(
fromList
[(
"BoolExp"
,
[
TypeVar
"Bool"
]),
(
"AndExp"
,
[
TypeVar
"Exp"
,
TypeVar
"Exp"
]),
(
"NotExp"
,
[
TypeVar
"Exp"
])]))
(
anno
expADT
(
match3
((
cotr2
"AndExp"
(
cotr1
"BoolExp"
(
cotr0
"True"
))
(
cotr1
"BoolExp"
(
cotr0
"False"
))))
(
case'
"BoolExp"
[
"x"
]
(
cotr1
"NotExp"
(
cotr1
"BoolExp"
(
var
"x"
))))
(
case'
"AndExp"
[
"x"
,
"y"
]
(
cotr2
"AndExp"
(
var
"y"
)
(
var
"x"
)))
(
case'
"NotExp"
[
"x"
]
(
var
"x"
))))))
tFailArithmetic
=
root
$
(
add
(
succ
$
succ
zero
)
(
mult
(
anno
(
Fun
Nat
Nat
)
(
lam
"f"
(
var
"f"
)))
(
succ
$
succ
$
succ
$
succ
zero
)))
tFailLambdaNoAnno
=
root
$
(
anno
Nat
(
app
(
lam
"b"
(
add
(
var
"b"
)
zero
))
(
succ
$
succ
zero
)))
...
...
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