Fakultas Ilmu Komputer UI
Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
Ari Angga Nugraha
ariangganugraha-funpro2020-lambda
Commits
3a94b6c4
Commit
3a94b6c4
authored
Jan 07, 2017
by
Sean Gillespie
Browse files
Update SystemF Type checker
Add rules for application and type abstraction
parent
8c853941
Changes
2
Hide whitespace changes
Inline
Side-by-side
src/Language/SystemF/TypeCheck.hs
View file @
3a94b6c4
...
...
@@ -3,28 +3,31 @@ module Language.SystemF.TypeCheck where
import
Data.Map
import
Prelude
hiding
(
lookup
)
import
Language.Lambda.Util.PrettyPrint
import
Language.SystemF.Expression
type
UniqueSupply
n
=
[
n
]
type
Context
n
t
=
Map
n
t
typecheck
::
(
Ord
n
,
Eq
t
)
typecheck
::
(
Ord
n
,
Eq
t
,
PrettyPrint
t
)
=>
UniqueSupply
t
->
Context
n
(
Ty
t
)
->
SystemFExpr
n
t
->
Either
String
(
Ty
t
)
typecheck
uniqs
ctx
(
Var
v
)
=
tcVar
uniqs
ctx
v
typecheck
uniqs
ctx
(
Abs
n
t
body
)
=
tcAbs
uniqs
ctx
n
t
body
typecheck
uniqs
ctx
(
App
e1
e2
)
=
tcApp
uniqs
ctx
e1
e2
typecheck
uniqs
ctx
(
TyAbs
t
body
)
=
tcTyAbs
uniqs
ctx
t
body
typecheck
_
_
_
=
undefined
tcVar
::
(
Ord
n
,
Eq
t
)
tcVar
::
(
Ord
n
,
Eq
t
,
PrettyPrint
t
)
=>
UniqueSupply
t
->
Context
n
(
Ty
t
)
->
n
->
Either
String
(
Ty
t
)
tcVar
uniqs
ctx
var
=
maybe
(
TyVar
<$>
unique
uniqs
)
return
(
lookup
var
ctx
)
tcAbs
::
(
Ord
n
,
Eq
t
)
tcAbs
::
(
Ord
n
,
Eq
t
,
PrettyPrint
t
)
=>
UniqueSupply
t
->
Context
n
(
Ty
t
)
->
n
...
...
@@ -34,8 +37,46 @@ tcAbs :: (Ord n, Eq t)
tcAbs
uniqs
ctx
name
ty
body
=
TyArrow
ty
<$>
typecheck
uniqs
ctx'
body
where
ctx'
=
insert
name
ty
ctx
tcApp
::
(
Ord
n
,
Eq
t
,
PrettyPrint
t
)
=>
UniqueSupply
t
->
Context
n
(
Ty
t
)
->
SystemFExpr
n
t
->
SystemFExpr
n
t
->
Either
String
(
Ty
t
)
tcApp
uniqs
ctx
e1
e2
=
do
t1
<-
typecheck
uniqs
ctx
e1
t2
<-
typecheck
uniqs
ctx
e2
-- Unwrap t1; Should be (t2 -> *)
(
t2'
,
t3
)
<-
either
genMismatchVar
return
(
arrow
t1
)
if
t2'
==
t2
then
return
t3
else
Left
$
tyMismatchMsg
(
TyArrow
t2
t3
)
(
TyArrow
t1
t3
)
where
genMismatchVar
expected
=
tyMismatchMsg
expected
<$>
unique
uniqs
>>=
Left
arrow
(
TyArrow
t1
t2
)
=
return
(
t1
,
t2
)
arrow
t
=
Left
t
tcTyAbs
::
(
Ord
n
,
Eq
t
,
PrettyPrint
t
)
=>
UniqueSupply
t
->
Context
n
(
Ty
t
)
->
t
->
SystemFExpr
n
t
->
Either
String
(
Ty
t
)
tcTyAbs
uniqs
ctx
ty
body
=
undefined
-- Utilities
unique
::
UniqueSupply
t
->
Either
String
t
unique
(
u
:
_
)
=
return
u
unique
_
=
fail
"Unique supply ran out"
tyMismatchMsg
::
(
PrettyPrint
t
,
PrettyPrint
t'
)
=>
t
->
t'
->
String
tyMismatchMsg
expected
actual
=
"Couldn't match expected type "
++
prettyPrint
expected
++
" with actual type "
++
prettyPrint
actual
test/Language/SystemF/TypeCheckSpec.hs
View file @
3a94b6c4
module
Language.SystemF.TypeCheckSpec
(
spec
)
where
import
Data.Either
import
Data.Map
import
Test.Hspec
...
...
@@ -20,3 +21,33 @@ spec = describe "typecheck" $ do
it
"typechecks simple abstractions"
$
tc
[]
[]
(
Abs
"x"
(
TyVar
"A"
)
(
Var
"x"
))
`
shouldBe
`
Right
(
TyArrow
(
TyVar
"A"
)
(
TyVar
"A"
))
it
"typechecks simple applications"
$
do
let
ctx
=
[
(
"f"
,
TyArrow
(
TyVar
"T"
)
(
TyVar
"U"
)),
(
"a"
,
TyVar
"T"
)
]
tc
[]
ctx
(
App
(
Var
"f"
)
(
Var
"a"
))
`
shouldBe
`
Right
(
TyVar
"U"
)
it
"apply variable to variable fails"
$
do
let
ctx
=
[
(
"a"
,
TyVar
"A"
),
(
"b"
,
TyVar
"B"
)
]
tc
[
"C"
]
ctx
(
App
(
Var
"a"
)
(
Var
"b"
))
`
shouldSatisfy
`
isLeft
it
"apply arrow to variable of wrong type fails"
$
do
let
ctx
=
[
(
"f"
,
TyArrow
(
TyVar
"F"
)
(
TyVar
"G"
)),
(
"b"
,
TyVar
"B"
)
]
tc
[]
ctx
(
App
(
Var
"f"
)
(
Var
"b"
))
`
shouldSatisfy
`
isLeft
it
"typechecks simple type abstractions"
$
do
pendingWith
"Not implemented"
tc
[
"A"
]
[]
(
TyAbs
"X"
(
Var
"x"
))
`
shouldBe
`
Right
(
TyForAll
"X"
(
TyVar
"A"
))
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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