Merge branch 'jalon3'
This commit is contained in:
commit
f552e4177b
GPG key ID:
A82D63DFF8D1317F
1 changed files with 587 additions and 67 deletions
|
|
@ -5,98 +5,618 @@ open HopixAST
|
|||
(** Error messages *)
|
||||
|
||||
let invalid_instantiation pos given expected =
|
||||
HopixTypes.type_error pos (
|
||||
Printf.sprintf
|
||||
"Invalid number of types in instantiation: \
|
||||
%d given while %d were expected." given expected
|
||||
)
|
||||
HopixTypes.type_error
|
||||
pos
|
||||
(Printf.sprintf
|
||||
"Invalid number of types in instantiation: %d given while %d were expected."
|
||||
given
|
||||
expected)
|
||||
;;
|
||||
|
||||
let check_equal_types pos ~expected ~given =
|
||||
if expected <> given
|
||||
then
|
||||
HopixTypes.(type_error pos
|
||||
Printf.(sprintf
|
||||
"Type mismatch.\nExpected:\n %s\nGiven:\n %s"
|
||||
(string_of_aty expected)
|
||||
(string_of_aty given)))
|
||||
HopixTypes.(
|
||||
type_error
|
||||
pos
|
||||
Printf.(
|
||||
sprintf
|
||||
"Type mismatch.\nExpected:\n %s\nGiven:\n %s"
|
||||
(string_of_aty expected)
|
||||
(string_of_aty given)))
|
||||
;;
|
||||
|
||||
(** Linearity-checking code for patterns *)
|
||||
|
||||
let rec check_pattern_linearity
|
||||
: identifier list -> pattern Position.located -> identifier list
|
||||
= fun vars Position.{ value; position; } ->
|
||||
failwith "Students! This is your job!"
|
||||
: identifier list -> pattern Position.located -> identifier list
|
||||
=
|
||||
fun vars Position.{ value; position = _ } ->
|
||||
match value with
|
||||
| PWildcard -> vars
|
||||
| PLiteral _ -> vars
|
||||
| PVariable v -> linearity_variable v vars
|
||||
| PTypeAnnotation (p, _) ->
|
||||
(* Pour les deux matchs qui suivent, on fait la même chose :
|
||||
On regarde récursivement chaque pattern de chaque liste, et on effectue le
|
||||
check de linéarité pour chaque pattern.
|
||||
|
||||
Seulement, pour PRecord qui est un (label located * pattern located),
|
||||
on doit séparer en deux matchs distinct pour "ouvrir" la paire de PRecord *)
|
||||
check_pattern_linearity vars p
|
||||
| PTaggedValue (_, _, plist) | PTuple plist | POr plist | PAnd plist ->
|
||||
linearity_pattern_list plist vars
|
||||
| PRecord (plist, _) -> linearity_precord_list plist vars
|
||||
|
||||
and linearity_variable v vars =
|
||||
if List.mem v.value vars
|
||||
then (
|
||||
match v.value with
|
||||
| Id i ->
|
||||
HopixTypes.type_error
|
||||
v.position
|
||||
(Printf.sprintf "The variable %s has already appeared in this pattern." i))
|
||||
else v.value :: vars
|
||||
|
||||
and linearity_pattern_list plist vars =
|
||||
List.fold_left (fun vars pat -> check_pattern_linearity vars pat) vars plist
|
||||
|
||||
and linearity_precord_list plist vars =
|
||||
List.fold_left (fun vars (_, pat) -> check_pattern_linearity vars pat) vars plist
|
||||
;;
|
||||
|
||||
(** Type-checking code *)
|
||||
|
||||
let check_type_scheme :
|
||||
HopixTypes.typing_environment ->
|
||||
Position.t ->
|
||||
HopixAST.type_scheme ->
|
||||
HopixTypes.aty_scheme * HopixTypes.typing_environment
|
||||
= fun env pos (ForallTy (ts, ty)) ->
|
||||
failwith "Students! This is your job!"
|
||||
let check_type_scheme
|
||||
: HopixTypes.typing_environment -> Position.t -> HopixAST.type_scheme
|
||||
-> HopixTypes.aty_scheme * HopixTypes.typing_environment
|
||||
=
|
||||
fun env pos (ForallTy (ts, ty)) ->
|
||||
let ts = List.map Position.value ts in
|
||||
let env = HopixTypes.bind_type_variables pos env ts in
|
||||
HopixTypes.Scheme (ts, HopixTypes.internalize_ty env ty), env
|
||||
;;
|
||||
|
||||
let synth_literal : HopixAST.literal -> HopixTypes.aty =
|
||||
let rec check_pattern
|
||||
: HopixTypes.typing_environment -> HopixAST.pattern Position.located -> HopixTypes.aty
|
||||
-> HopixTypes.typing_environment
|
||||
=
|
||||
fun env Position.({ value = p; position = pos } as pat) expected ->
|
||||
failwith "Students! This is your job! (check_pattern)"
|
||||
;;
|
||||
|
||||
let rec synth_expression
|
||||
: HopixTypes.typing_environment -> HopixAST.expression Position.located
|
||||
-> HopixTypes.aty
|
||||
=
|
||||
fun env Position.{ value = e; position = _ } ->
|
||||
match e with
|
||||
| Literal l -> synth_literal l.value
|
||||
| Variable (id, tlist) -> synth_variable env id tlist
|
||||
| Tagged (cons, tlist, elist) -> synth_tagged env cons tlist elist
|
||||
| Apply (elist1, elist2) -> synth_apply env elist1 elist2
|
||||
| Record (field, tlist) -> synth_record env field tlist
|
||||
| Fun (FunctionDefinition (def, expr)) -> synth_fun env def expr
|
||||
| TypeAnnotation (expr, t) -> synth_tannot env expr t
|
||||
| Field (expr, lbl, tlist) -> synth_field env expr lbl tlist
|
||||
| Tuple elist -> synth_tuple env elist
|
||||
| Sequence elist -> synth_sequence env elist
|
||||
| Define (vdef, expr) -> synth_define env vdef expr
|
||||
| Ref expr -> synth_ref env expr
|
||||
| Assign (expr1, expr2) -> synth_assign env expr1 expr2
|
||||
| Read expr -> synth_read env expr
|
||||
| Case (expr, branches) -> synth_case env expr branches
|
||||
| IfThenElse (ecase, eif, eelse) -> synth_ifthenelse env ecase eif eelse
|
||||
| While (ecase, expr) -> synth_while env ecase expr
|
||||
| For (id, ecase, expr1, expr2) -> synth_for env id ecase expr1 expr2
|
||||
|
||||
and synth_literal : HopixAST.literal -> HopixTypes.aty =
|
||||
fun l ->
|
||||
failwith "Students! This is your job!"
|
||||
match l with
|
||||
| LInt _ -> HopixTypes.hint
|
||||
| LChar _ -> HopixTypes.hchar
|
||||
| LString _ -> HopixTypes.hstring
|
||||
|
||||
let rec check_pattern :
|
||||
HopixTypes.typing_environment ->
|
||||
HopixAST.pattern Position.located ->
|
||||
HopixTypes.aty ->
|
||||
HopixTypes.typing_environment
|
||||
= fun env Position.({ value = p; position = pos; } as pat) expected ->
|
||||
failwith "Students! This is your job!"
|
||||
and synth_pattern
|
||||
: HopixTypes.typing_environment -> HopixAST.pattern Position.located
|
||||
-> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun env Position.{ value = p; position = pos } ->
|
||||
match p with
|
||||
| PWildcard -> pattern_wildcard pos
|
||||
| PLiteral l -> pattern_literal env l
|
||||
| PVariable _ -> pattern_variable pos
|
||||
| PTypeAnnotation (p, ty) -> pattern_tannot env p ty
|
||||
| PTuple plist -> pattern_tuple env plist
|
||||
| POr plist -> pattern_or env plist
|
||||
| PAnd plist -> pattern_and env plist
|
||||
| PTaggedValue (cons, tlist, plist) -> pattern_tagval env cons tlist plist
|
||||
| PRecord (plist, tlist) -> pattern_record env plist tlist
|
||||
|
||||
and synth_pattern :
|
||||
HopixTypes.typing_environment ->
|
||||
HopixAST.pattern Position.located ->
|
||||
HopixTypes.aty * HopixTypes.typing_environment
|
||||
= fun env Position.{ value = p; position = pos; } ->
|
||||
failwith "Students! This is your job!"
|
||||
and pattern_wildcard : Position.t -> HopixTypes.aty * HopixTypes.typing_environment =
|
||||
fun pos -> HopixTypes.type_error pos "No types found."
|
||||
|
||||
let rec synth_expression :
|
||||
HopixTypes.typing_environment ->
|
||||
HopixAST.expression Position.located ->
|
||||
HopixTypes.aty
|
||||
= fun env Position.{ value = e; position = pos; } ->
|
||||
failwith "Students! This is your job!"
|
||||
and pattern_literal
|
||||
: HopixTypes.typing_environment -> HopixAST.literal Position.located
|
||||
-> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun tenv l -> synth_literal l.value, tenv
|
||||
|
||||
and check_expression :
|
||||
HopixTypes.typing_environment ->
|
||||
HopixAST.expression Position.located ->
|
||||
HopixTypes.aty ->
|
||||
unit
|
||||
= fun env (Position.{ value = e; position = pos; } as exp) expected ->
|
||||
failwith "Students! This is your job!"
|
||||
and pattern_variable : Position.t -> HopixTypes.aty * HopixTypes.typing_environment =
|
||||
fun pos -> HopixTypes.type_error pos "No types found."
|
||||
|
||||
and check_value_definition :
|
||||
HopixTypes.typing_environment ->
|
||||
HopixAST.value_definition ->
|
||||
HopixTypes.typing_environment
|
||||
= fun env def ->
|
||||
failwith "Students! This is your job!"
|
||||
and pattern_tannot
|
||||
: HopixTypes.typing_environment -> HopixAST.pattern Position.located
|
||||
-> HopixAST.ty Position.located -> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun tenv p ty ->
|
||||
let aty_of_ty = HopixTypes.internalize_ty tenv ty in
|
||||
match p.value with
|
||||
| PWildcard -> aty_of_ty, tenv
|
||||
| PVariable i ->
|
||||
( aty_of_ty
|
||||
, HopixTypes.bind_value i.value (HopixTypes.monomorphic_type_scheme aty_of_ty) tenv )
|
||||
| _ ->
|
||||
let pattern_type, tenv = synth_pattern tenv p in
|
||||
check_equal_types p.position ~expected:aty_of_ty ~given:pattern_type;
|
||||
pattern_type, tenv
|
||||
|
||||
and pattern_tuple
|
||||
: HopixTypes.typing_environment -> HopixAST.pattern Position.located list
|
||||
-> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun tenv plist ->
|
||||
let tys, tenv =
|
||||
List.fold_left
|
||||
(fun (tys, tenv) pat ->
|
||||
let ty, tenv = synth_pattern tenv pat in
|
||||
ty :: tys, tenv)
|
||||
([], tenv)
|
||||
plist
|
||||
in
|
||||
HopixTypes.ATyTuple (List.rev tys), tenv
|
||||
|
||||
and pattern_or
|
||||
: HopixTypes.typing_environment -> HopixAST.pattern Position.located list
|
||||
-> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun tenv plist ->
|
||||
let ty', tenv' = synth_pattern tenv (List.hd plist) in
|
||||
let tenv =
|
||||
List.fold_left
|
||||
(fun tenv pat ->
|
||||
let pattern_type, tenv = synth_pattern tenv pat in
|
||||
check_equal_types pat.position ~expected:pattern_type ~given:ty';
|
||||
tenv)
|
||||
tenv'
|
||||
plist
|
||||
in
|
||||
ty', tenv
|
||||
|
||||
(* TODO : Même code que pattern_or, à revoir ? *)
|
||||
and pattern_and
|
||||
: HopixTypes.typing_environment -> HopixAST.pattern Position.located list
|
||||
-> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun tenv plist ->
|
||||
let ty', tenv' = synth_pattern tenv (List.hd plist) in
|
||||
let tenv =
|
||||
List.fold_left
|
||||
(fun tenv pat ->
|
||||
let pattern_type, tenv = synth_pattern tenv pat in
|
||||
check_equal_types pat.position ~expected:pattern_type ~given:ty';
|
||||
tenv)
|
||||
tenv'
|
||||
plist
|
||||
in
|
||||
ty', tenv
|
||||
|
||||
and pattern_tagval
|
||||
: HopixTypes.typing_environment -> HopixAST.constructor Position.located
|
||||
-> HopixAST.ty Position.located list option -> HopixAST.pattern Position.located list
|
||||
-> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun tenv cons tlist plist ->
|
||||
let cons_scheme =
|
||||
try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with
|
||||
| HopixTypes.Unbound (pos, Constructor (KId c)) ->
|
||||
HopixTypes.type_error pos (Printf.sprintf "Unbound constructor `%s'." c)
|
||||
in
|
||||
let tys =
|
||||
List.map
|
||||
(fun x -> HopixTypes.internalize_ty tenv x)
|
||||
(match tlist with
|
||||
| Some t -> t
|
||||
| None -> HopixTypes.type_error cons.position "No types found.")
|
||||
in
|
||||
let tcons =
|
||||
try HopixTypes.instantiate_type_scheme cons_scheme tys with
|
||||
| HopixTypes.InvalidInstantiation { expected; given } ->
|
||||
invalid_instantiation cons.position expected given
|
||||
in
|
||||
let p_args, tenv = synth_list_pattern tenv plist in
|
||||
( (let expected_args, result =
|
||||
HopixTypes.destruct_function_type_maximally cons.position tcons
|
||||
in
|
||||
(try
|
||||
List.iter2
|
||||
(fun expected given -> check_equal_types cons.position ~expected ~given)
|
||||
expected_args
|
||||
p_args
|
||||
with
|
||||
| Invalid_argument _ ->
|
||||
(* 35-bad *)
|
||||
check_equal_types
|
||||
cons.position
|
||||
~expected:result
|
||||
~given:(HopixTypes.ATyArrow (result, result)));
|
||||
result)
|
||||
, tenv )
|
||||
|
||||
and synth_list_pattern tenv = function
|
||||
| [] -> [], tenv
|
||||
| p :: plist ->
|
||||
let ty, tenv = synth_pattern tenv p in
|
||||
let tys, tenv = synth_list_pattern tenv plist in
|
||||
ty :: tys, tenv
|
||||
|
||||
and pattern_record
|
||||
: HopixTypes.typing_environment
|
||||
-> (HopixAST.label Position.located * HopixAST.pattern Position.located) list
|
||||
-> HopixAST.ty Position.located list option
|
||||
-> HopixTypes.aty * HopixTypes.typing_environment
|
||||
=
|
||||
fun tenv plist tlist ->
|
||||
let label = fst (List.hd plist) in
|
||||
let type_cons, _, labels =
|
||||
let (LId label_name) = label.value in
|
||||
try HopixTypes.lookup_type_constructor_of_label label.position label.value tenv with
|
||||
| HopixTypes.Unbound (pos, Label (LId i)) ->
|
||||
HopixTypes.type_error
|
||||
pos
|
||||
(Printf.sprintf "There is no type definition for label `%s'." label_name)
|
||||
in
|
||||
let tlist' =
|
||||
match tlist with
|
||||
| Some tlist -> List.map (fun t -> HopixTypes.internalize_ty tenv t) tlist
|
||||
| None -> HopixTypes.type_error label.position "No types found."
|
||||
in
|
||||
let tenv =
|
||||
List.fold_left
|
||||
(fun tenv (Position.{ position = label_pos; value = label_val }, pat) ->
|
||||
let label_scheme =
|
||||
try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with
|
||||
| HopixTypes.Unbound (pos, Label (LId i)) ->
|
||||
HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
|
||||
in
|
||||
let instance_type_scheme =
|
||||
try HopixTypes.instantiate_type_scheme label_scheme tlist' with
|
||||
| HopixTypes.InvalidInstantiation { expected; given } ->
|
||||
invalid_instantiation (Position.position pat) expected given
|
||||
in
|
||||
let _, expected =
|
||||
HopixTypes.destruct_function_type label_pos instance_type_scheme
|
||||
in
|
||||
let given, tenv = synth_pattern tenv pat in
|
||||
check_equal_types label_pos ~expected ~given;
|
||||
tenv)
|
||||
tenv
|
||||
plist
|
||||
in
|
||||
ATyCon (type_cons, tlist'), tenv
|
||||
|
||||
and synth_variable
|
||||
: HopixTypes.typing_environment -> identifier Position.located
|
||||
-> ty Position.located list option -> HopixTypes.aty
|
||||
=
|
||||
fun tenv id tlist ->
|
||||
(* Get variable type *)
|
||||
let ty =
|
||||
try HopixTypes.lookup_type_scheme_of_identifier id.position id.value tenv with
|
||||
| HopixTypes.Unbound (pos, Identifier (Id i)) ->
|
||||
HopixTypes.type_error pos (Printf.sprintf "Unbound identifier `%s'." i)
|
||||
in
|
||||
match tlist with
|
||||
| None -> HopixTypes.instantiate_type_scheme ty []
|
||||
| Some tlist' ->
|
||||
(* Pas testé *)
|
||||
let atlist = List.map (fun t -> HopixTypes.internalize_ty tenv t) tlist' in
|
||||
(try HopixTypes.instantiate_type_scheme ty atlist with
|
||||
| HopixTypes.InvalidInstantiation { expected; given } ->
|
||||
invalid_instantiation id.position expected given)
|
||||
|
||||
and synth_tagged
|
||||
: HopixTypes.typing_environment -> constructor Position.located
|
||||
-> ty Position.located list option -> expression Position.located list -> HopixTypes.aty
|
||||
=
|
||||
fun tenv cons tlist e_args_list ->
|
||||
let cons_scheme =
|
||||
try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with
|
||||
| HopixTypes.Unbound (pos, Constructor (KId c)) ->
|
||||
HopixTypes.type_error pos (Printf.sprintf "Unbound constructor `%s'." c)
|
||||
in
|
||||
let tys =
|
||||
List.map
|
||||
(fun x -> HopixTypes.internalize_ty tenv x)
|
||||
(match tlist with
|
||||
| Some t -> t
|
||||
| None -> HopixTypes.type_error cons.position "No types found.")
|
||||
in
|
||||
let tcons =
|
||||
try HopixTypes.instantiate_type_scheme cons_scheme tys with
|
||||
| HopixTypes.InvalidInstantiation { expected; given } ->
|
||||
invalid_instantiation cons.position expected given
|
||||
in
|
||||
let targs = List.map (fun x -> synth_expression tenv x) e_args_list in
|
||||
let expected_args, result =
|
||||
HopixTypes.destruct_function_type_maximally cons.position tcons
|
||||
in
|
||||
(try
|
||||
List.iter2
|
||||
(fun expected given -> check_equal_types cons.position ~expected ~given)
|
||||
expected_args
|
||||
targs
|
||||
with
|
||||
| Invalid_argument _ ->
|
||||
(* 35-bad *)
|
||||
check_equal_types
|
||||
cons.position
|
||||
~expected:result
|
||||
~given:(HopixTypes.ATyArrow (result, result)));
|
||||
result
|
||||
|
||||
and synth_apply
|
||||
: HopixTypes.typing_environment -> expression Position.located
|
||||
-> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv f x ->
|
||||
let f_type = synth_expression tenv f in
|
||||
match f_type with
|
||||
| HopixTypes.ATyArrow (expected, droit) ->
|
||||
(* a' -> b' *)
|
||||
let given = synth_expression tenv x in
|
||||
check_equal_types x.position ~expected ~given;
|
||||
droit
|
||||
| _ -> HopixTypes.type_error f.position "Can't apply."
|
||||
|
||||
and synth_record
|
||||
: HopixTypes.typing_environment
|
||||
-> (label Position.located * expression Position.located) list
|
||||
-> ty Position.located list option -> HopixTypes.aty
|
||||
=
|
||||
fun tenv field tlist ->
|
||||
(* Translate the types *)
|
||||
let fl = fst (List.hd field) in
|
||||
let cons, _, _ =
|
||||
HopixTypes.lookup_type_constructor_of_label fl.position fl.value tenv
|
||||
in
|
||||
let tlist' =
|
||||
match tlist with
|
||||
| Some tlist -> List.map (fun t -> HopixTypes.internalize_ty tenv t) tlist
|
||||
| None -> HopixTypes.type_error fl.position "No types found."
|
||||
in
|
||||
(* Type checking *)
|
||||
List.iter
|
||||
(fun (Position.{ position = label_pos; value = label_val }, expr) ->
|
||||
let label_scheme =
|
||||
try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with
|
||||
| HopixTypes.Unbound (pos, Label (LId i)) ->
|
||||
HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
|
||||
in
|
||||
let arrow =
|
||||
try HopixTypes.instantiate_type_scheme label_scheme tlist' with
|
||||
| HopixTypes.InvalidInstantiation { expected; given } ->
|
||||
invalid_instantiation (Position.position expr) expected given
|
||||
in
|
||||
let _, expected = HopixTypes.destruct_function_type label_pos arrow in
|
||||
let given = synth_expression tenv expr in
|
||||
check_equal_types label_pos ~expected ~given)
|
||||
field;
|
||||
ATyCon (cons, tlist')
|
||||
|
||||
and synth_fun
|
||||
: HopixTypes.typing_environment -> pattern Position.located
|
||||
-> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv pat expr ->
|
||||
let pat_type, tenv = synth_pattern tenv pat in
|
||||
let expr_type = synth_expression tenv expr in
|
||||
ATyArrow (pat_type, expr_type)
|
||||
|
||||
and synth_tannot
|
||||
: HopixTypes.typing_environment -> expression Position.located -> ty Position.located
|
||||
-> HopixTypes.aty
|
||||
=
|
||||
fun tenv expr ty ->
|
||||
let ty' = synth_expression tenv expr in
|
||||
(* Pas sûr de ça *)
|
||||
check_equal_types expr.position ~expected:(HopixTypes.internalize_ty tenv ty) ~given:ty';
|
||||
ty'
|
||||
|
||||
and synth_field
|
||||
: HopixTypes.typing_environment -> expression Position.located
|
||||
-> label Position.located -> ty Position.located list option -> HopixTypes.aty
|
||||
=
|
||||
fun tenv expr lbl _tlist ->
|
||||
let expr_type = synth_expression tenv expr in
|
||||
match expr_type with
|
||||
| ATyCon (cons, atlist) ->
|
||||
let label_scheme =
|
||||
try HopixTypes.lookup_type_scheme_of_label lbl.position lbl.value tenv with
|
||||
| HopixTypes.Unbound (pos, Label (LId i)) ->
|
||||
HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
|
||||
in
|
||||
let arrow =
|
||||
try HopixTypes.instantiate_type_scheme label_scheme atlist with
|
||||
| HopixTypes.InvalidInstantiation { expected; given } ->
|
||||
invalid_instantiation (Position.position expr) expected given
|
||||
in
|
||||
(* Peut être inutile ? *)
|
||||
let _ = HopixTypes.lookup_fields_of_type_constructor lbl.position cons tenv in
|
||||
snd (HopixTypes.destruct_function_type lbl.position arrow)
|
||||
| _ as x -> x
|
||||
|
||||
and synth_tuple
|
||||
: HopixTypes.typing_environment -> expression Position.located list -> HopixTypes.aty
|
||||
=
|
||||
fun tenv elist ->
|
||||
let list_type = List.map (fun x -> synth_expression tenv x) elist in
|
||||
HopixTypes.ATyTuple list_type
|
||||
|
||||
and synth_sequence
|
||||
: HopixTypes.typing_environment -> expression Position.located list -> HopixTypes.aty
|
||||
=
|
||||
fun tenv elist ->
|
||||
match elist with
|
||||
| [] -> HopixTypes.type_error Position.dummy "Invalid sequence."
|
||||
| [ x ] -> synth_expression tenv x
|
||||
| x :: l ->
|
||||
let given = synth_expression tenv x in
|
||||
check_equal_types x.position ~expected:HopixTypes.hunit ~given;
|
||||
synth_sequence tenv l
|
||||
|
||||
and synth_define
|
||||
: HopixTypes.typing_environment -> value_definition -> expression Position.located
|
||||
-> HopixTypes.aty
|
||||
=
|
||||
fun tenv vdef expr ->
|
||||
let tenv = check_value_definition tenv vdef in
|
||||
synth_expression tenv expr
|
||||
|
||||
and synth_ref
|
||||
: HopixTypes.typing_environment -> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv expr -> HopixTypes.href (synth_expression tenv expr)
|
||||
|
||||
and synth_assign
|
||||
: HopixTypes.typing_environment -> expression Position.located
|
||||
-> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv ref expr ->
|
||||
let refty = synth_expression tenv ref in
|
||||
match HopixTypes.destruct_reference_type expr.position refty with
|
||||
| expected ->
|
||||
let given = synth_expression tenv expr in
|
||||
check_equal_types expr.position ~expected ~given;
|
||||
HopixTypes.hunit
|
||||
|
||||
and synth_read
|
||||
: HopixTypes.typing_environment -> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv ref ->
|
||||
let refty = synth_expression tenv ref in
|
||||
HopixTypes.destruct_reference_type ref.position refty
|
||||
|
||||
and synth_case
|
||||
: HopixTypes.typing_environment -> expression Position.located
|
||||
-> branch Position.located list -> HopixTypes.aty
|
||||
=
|
||||
fun tenv expr branches ->
|
||||
let casety = synth_expression tenv expr in
|
||||
(* Test les branches *)
|
||||
match List.fold_right (synth_branch tenv casety) branches None with
|
||||
| Some branchesty -> branchesty
|
||||
| None -> HopixTypes.type_error expr.position "No types found."
|
||||
|
||||
and synth_branch
|
||||
: HopixTypes.typing_environment -> HopixTypes.aty -> branch Position.located
|
||||
-> HopixTypes.aty option -> HopixTypes.aty option
|
||||
=
|
||||
fun tenv casety branch branchty ->
|
||||
let (Branch (p, e)) = branch.value in
|
||||
let given_case, tenv' = synth_pattern tenv p in
|
||||
check_equal_types p.position ~expected:casety ~given:given_case;
|
||||
let given_branch = synth_expression tenv' e in
|
||||
(match branchty with
|
||||
| None -> ()
|
||||
| Some ty' -> check_equal_types e.position ~expected:ty' ~given:given_branch);
|
||||
Some given_branch
|
||||
|
||||
and synth_ifthenelse
|
||||
: HopixTypes.typing_environment -> expression Position.located
|
||||
-> expression Position.located -> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv ecase eif eelse ->
|
||||
(* Pas testé !! *)
|
||||
let ecasety = synth_expression tenv ecase in
|
||||
check_equal_types ecase.position ~expected:HopixTypes.hbool ~given:ecasety;
|
||||
let eifty = synth_expression tenv eif in
|
||||
check_equal_types eif.position ~expected:HopixTypes.hunit ~given:eifty;
|
||||
let eelsety = synth_expression tenv eelse in
|
||||
check_equal_types eelse.position ~expected:HopixTypes.hunit ~given:eelsety;
|
||||
HopixTypes.hunit
|
||||
|
||||
and synth_while
|
||||
: HopixTypes.typing_environment -> expression Position.located
|
||||
-> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv ecase c ->
|
||||
let ecasety = synth_expression tenv ecase in
|
||||
check_equal_types ecase.position ~expected:HopixTypes.hbool ~given:ecasety;
|
||||
let exprty = synth_expression tenv c in
|
||||
check_equal_types c.position ~expected:HopixTypes.hunit ~given:exprty;
|
||||
HopixTypes.hunit
|
||||
|
||||
and synth_for
|
||||
: HopixTypes.typing_environment -> identifier Position.located
|
||||
-> expression Position.located -> expression Position.located
|
||||
-> expression Position.located -> HopixTypes.aty
|
||||
=
|
||||
fun tenv id estart eend expr ->
|
||||
let estart_ty = synth_expression tenv estart in
|
||||
check_equal_types estart.position ~expected:HopixTypes.hint ~given:estart_ty;
|
||||
let eend_ty = synth_expression tenv eend in
|
||||
check_equal_types eend.position ~expected:HopixTypes.hint ~given:eend_ty;
|
||||
let tenv' =
|
||||
HopixTypes.bind_value
|
||||
id.value
|
||||
(HopixTypes.monomorphic_type_scheme HopixTypes.hint)
|
||||
tenv
|
||||
in
|
||||
let e_ty = synth_expression tenv' expr in
|
||||
check_equal_types expr.position ~expected:HopixTypes.hunit ~given:e_ty;
|
||||
HopixTypes.hunit
|
||||
|
||||
and check_expression
|
||||
: HopixTypes.typing_environment -> HopixAST.expression Position.located
|
||||
-> HopixTypes.aty -> unit
|
||||
=
|
||||
fun env (Position.{ position = pos } as exp) expected ->
|
||||
let given = synth_expression env exp in
|
||||
check_equal_types pos ~expected ~given
|
||||
|
||||
and check_value_definition
|
||||
: HopixTypes.typing_environment -> HopixAST.value_definition
|
||||
-> HopixTypes.typing_environment
|
||||
=
|
||||
fun env -> function
|
||||
| SimpleValue (id, ty, ex) ->
|
||||
(match ty with
|
||||
| None -> HopixTypes.type_error ex.position "Type is missing."
|
||||
| Some ty' ->
|
||||
let tys, tenv = Position.located_pos (check_type_scheme env) ty' in
|
||||
check_expression tenv ex (HopixTypes.instantiate_type_scheme tys []);
|
||||
HopixTypes.bind_value (Position.value id) tys env)
|
||||
| RecFunctions _ ->
|
||||
(* Je crois que c'est galère et donc c'est pas grave si on arrive pas
|
||||
à faire les fonctions récursives *)
|
||||
failwith "Students! This is your job! (check_value_definition | RecFunctions)"
|
||||
;;
|
||||
|
||||
let check_definition env = function
|
||||
| DefineValue vdef ->
|
||||
check_value_definition env vdef
|
||||
|
||||
| DefineValue vdef -> check_value_definition env vdef
|
||||
| DefineType (t, ts, tdef) ->
|
||||
let ts = List.map Position.value ts in
|
||||
HopixTypes.bind_type_definition (Position.value t) ts tdef env
|
||||
|
||||
let ts = List.map Position.value ts in
|
||||
HopixTypes.bind_type_definition (Position.value t) ts tdef env
|
||||
| DeclareExtern (x, tys) ->
|
||||
let tys, _ = Position.located_pos (check_type_scheme env) tys in
|
||||
HopixTypes.bind_value (Position.value x) tys env
|
||||
let tys, _ = Position.located_pos (check_type_scheme env) tys in
|
||||
HopixTypes.bind_value (Position.value x) tys env
|
||||
;;
|
||||
|
||||
let typecheck env program =
|
||||
List.fold_left
|
||||
(fun env d -> Position.located (check_definition env) d)
|
||||
env program
|
||||
List.fold_left (fun env d -> Position.located (check_definition env) d) env program
|
||||
;;
|
||||
|
||||
type typing_environment = HopixTypes.typing_environment
|
||||
|
||||
let initial_typing_environment = HopixTypes.initial_typing_environment
|
||||
|
||||
let print_typing_environment = HopixTypes.string_of_typing_environment
|
||||
|
|
|
|||
Reference in a new issue