Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
A
alphaLib
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
POTTIER Francois
alphaLib
Commits
5b1e10de
Commit
5b1e10de
authored
Feb 03, 2017
by
POTTIER Francois
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Build an export environment into the typechecker, and add a few tests.
parent
6a32b989
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
98 additions
and
31 deletions
+98
-31
demos/system-F-type/FTypeChecker.ml
demos/system-F-type/FTypeChecker.ml
+29
-23
demos/system-F-type/Main.ml
demos/system-F-type/Main.ml
+69
-8
No files found.
demos/system-F-type/FTypeChecker.ml
View file @
5b1e10de
...
...
@@ -47,42 +47,42 @@ let extend_with_tyvar (env : env) (a : tyvar) : env =
(* Destructors. *)
exception
NotAnArrow
of
nominal
_typ
exception
NotAnArrow
of
raw
_typ
let
as_arrow
ty
:
nominal_typ
*
nominal_typ
=
let
as_arrow
xenv
ty
:
nominal_typ
*
nominal_typ
=
match
ty
with
|
TyArrow
(
ty1
,
ty2
)
->
ty1
,
ty2
|
_
->
raise
(
NotAnArrow
ty
)
raise
(
NotAnArrow
(
export_typ
xenv
ty
)
)
exception
NotAProduct
of
nominal
_typ
exception
NotAProduct
of
raw
_typ
let
as_product
ty
:
nominal_typ
*
nominal_typ
=
let
as_product
xenv
ty
:
nominal_typ
*
nominal_typ
=
match
ty
with
|
TyProduct
(
ty1
,
ty2
)
->
ty1
,
ty2
|
_
->
raise
(
NotAProduct
ty
)
raise
(
NotAProduct
(
export_typ
xenv
ty
)
)
exception
NotAForall
of
nominal
_typ
exception
NotAForall
of
raw
_typ
let
as_forall
ty
:
tyvar
*
nominal_typ
=
let
as_forall
xenv
ty
:
tyvar
*
nominal_typ
=
match
ty
with
|
TyForall
(
a
,
ty
)
->
a
,
ty
|
_
->
raise
(
NotAForall
ty
)
raise
(
NotAForall
(
export_typ
xenv
ty
)
)
(* -------------------------------------------------------------------------- *)
(* An equality test. *)
exception
TypeMismatch
of
nominal_typ
*
nominal
_typ
exception
TypeMismatch
of
raw_typ
*
raw
_typ
let
(
--
)
ty1
ty2
=
let
equate
xenv
ty1
ty2
=
if
not
(
equiv_typ
ty1
ty2
)
then
raise
(
TypeMismatch
(
ty1
,
ty2
))
raise
(
TypeMismatch
(
export_typ
xenv
ty1
,
export_typ
xenv
ty2
))
(* -------------------------------------------------------------------------- *)
...
...
@@ -99,7 +99,12 @@ let (--) ty1 ty2 =
(* Postcondition: if [typeof env t] returns a type [ty], then the bound variables
of [ty] are disjoint with [env.tyvars], and [ty] has no shadowing. *)
let
rec
typeof
env
(
t
:
nominal_term
)
:
nominal_typ
=
(* As we go down, we build an export environment [xenv], which is used when a
type error is encountered. The problematic types are then exported, so that
a type error message can be printed. This export environment is enriched
when we enter a \Lambda. *)
let
rec
typeof
xenv
env
(
t
:
nominal_term
)
:
nominal_typ
=
(* Test the preconditions stated above. *)
assert
(
guq_term
t
);
assert
(
avoids_term
env
.
tyvars
t
);
...
...
@@ -113,19 +118,20 @@ let rec typeof env (t : nominal_term) : nominal_typ =
|
TeVar
x
->
lookup
env
x
|
TeAbs
(
x
,
ty1
,
t
)
->
let
ty2
=
typeof
(
extend_with_tevar
env
x
ty1
)
t
in
let
ty2
=
typeof
xenv
(
extend_with_tevar
env
x
ty1
)
t
in
TyArrow
(
ty1
,
ty2
)
|
TeApp
(
t
,
u
)
->
let
ty1
,
ty2
=
as_arrow
(
typeof
env
t
)
in
typeof
env
u
--
ty1
;
let
ty1
,
ty2
=
as_arrow
xenv
(
typeof
xenv
env
t
)
in
equate
xenv
(
typeof
xenv
env
u
)
ty1
;
ty2
|
TeLet
(
x
,
t
,
u
)
->
let
env
=
extend_with_tevar
env
x
(
typeof
env
t
)
in
typeof
env
u
let
env
=
extend_with_tevar
env
x
(
typeof
xenv
env
t
)
in
typeof
xenv
env
u
|
TeTyAbs
(
a
,
t
)
->
TyForall
(
a
,
typeof
(
extend_with_tyvar
env
a
)
t
)
let
_
,
xenv
=
KitExport
.
extend
a
xenv
in
TyForall
(
a
,
typeof
xenv
(
extend_with_tyvar
env
a
)
t
)
|
TeTyApp
(
t
,
ty2
)
->
let
a
,
ty1
=
as_forall
(
typeof
env
t
)
in
let
a
,
ty1
=
as_forall
xenv
(
typeof
xenv
env
t
)
in
(* We need ba(ty1) # [ty2/a] for this substitution to be safe. *)
(* We have ba(ty1) # a because the type a.ty1 satisfies no-shadowing. *)
assert
(
not
(
Atom
.
Set
.
mem
a
(
ba_typ
ty1
)));
...
...
@@ -138,10 +144,10 @@ let rec typeof env (t : nominal_term) : nominal_typ =
[ty2] when grafting: *)
(* subst_TyVar_typ1 (fun ty2 -> ty2) ty2 a (copy_typ ty1) *)
|
TePair
(
t1
,
t2
)
->
TyProduct
(
typeof
env
t1
,
typeof
env
t2
)
TyProduct
(
typeof
xenv
env
t1
,
typeof
xenv
env
t2
)
|
TeProj
(
i
,
t
)
->
assert
(
i
=
1
||
i
=
2
);
let
ty1
,
ty2
=
as_product
(
typeof
env
t
)
in
let
ty1
,
ty2
=
as_product
xenv
(
typeof
xenv
env
t
)
in
if
i
=
1
then
ty1
else
ty2
in
(* Test the postcondition stated above. *)
...
...
@@ -149,4 +155,4 @@ let rec typeof env (t : nominal_term) : nominal_typ =
ty
let
typeof
=
typeof
empty
typeof
KitExport
.
empty
empty
demos/system-F-type/Main.ml
View file @
5b1e10de
...
...
@@ -3,23 +3,84 @@ open AlphaLib
open
F
open
FTypeChecker
(* -------------------------------------------------------------------------- *)
(* Typechecking a term. *)
let
check
(
t
:
raw_term
)
=
printf
"Raw term:
\n
%a
\n
"
Print
.
term
t
;
Print
.
term
t
;
let
t
:
nominal_term
=
import_term
KitImport
.
empty
t
in
printf
"Imported (and reexported) term:
\n
%a
\n
"
Print
.
term
(
export_term
KitExport
.
empty
t
);
let
ty
:
nominal_typ
=
typeof
t
in
printf
"Inferred type:
\n
%a
\n
"
Print
.
typ
(
export_typ
KitExport
.
empty
ty
)
Print
.
term
(
export_term
KitExport
.
empty
t
)
;
match
typeof
t
with
|
ty
->
printf
"Inferred type:
\n
%a
\n
"
Print
.
typ
(
export_typ
KitExport
.
empty
ty
)
|
exception
NotAnArrow
ty
->
printf
"Type error: this is not a function type:
\n
%a
\n
"
Print
.
typ
ty
|
exception
NotAProduct
ty
->
printf
"Type error: this is not a product type:
\n
%a
\n
"
Print
.
typ
ty
|
exception
NotAForall
ty
->
printf
"Type error: this is not a universal type:
\n
%a
\n
"
Print
.
typ
ty
(* -------------------------------------------------------------------------- *)
(* Sample well-typed terms. *)
let
identity
=
TeTyAbs
(
"A"
,
TeAbs
(
"x"
,
TyVar
"A"
,
TeVar
"x"
))
let
terms
:
raw_term
list
=
[
TeTyAbs
(
"A"
,
TeAbs
(
"x"
,
TyVar
"A"
,
TeVar
"x"
));
identity
;
TeTyAbs
(
"A"
,
TeAbs
(
"x"
,
TyVar
"A"
,
TeApp
(
TeTyApp
(
identity
,
TyVar
"A"
)
,
TeVar
"x"
)
));
TeTyAbs
(
"A"
,
TeAbs
(
"x"
,
TyVar
"A"
,
TeTyAbs
(
"B"
,
TeAbs
(
"y"
,
TyVar
"B"
,
TeLet
(
"id"
,
identity
,
TePair
(
TeApp
(
TeTyApp
(
TeVar
"id"
,
TyVar
"A"
)
,
TeVar
"x"
)
,
TeApp
(
TeTyApp
(
TeVar
"id"
,
TyVar
"B"
)
,
TeVar
"y"
)
)
)
))));
]
let
()
=
List
.
iter
check
terms
(* -------------------------------------------------------------------------- *)
(* Sample ill-typed terms. *)
let
ill_typed
:
raw_term
list
=
[
TeTyAbs
(
"A"
,
TeAbs
(
"x"
,
TyVar
"A"
,
TeApp
(
TeVar
"x"
,
TeVar
"x"
)));
TeProj
(
1
,
identity
);
TeTyAbs
(
"A"
,
TeLet
(
"id"
,
TeAbs
(
"x"
,
TyVar
"A"
,
TeVar
"x"
)
,
TeTyApp
(
TeVar
"id"
,
TyVar
"A"
)
)
);
]
let
()
=
List
.
iter
check
ill_typed
(* TEMPORARY report unbound term variables, with locations. *)
(* TEMPORARY report unbound type variables, with locations. *)
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