1
0
Fork 0

nested application

This commit is contained in:
Mylloon 2024-04-30 13:36:12 +02:00
parent 5daa03cb1a
commit dc1efb51e2
Signed by: Anri
GPG key ID: A82D63DFF8D1317F
4 changed files with 62 additions and 22 deletions

View file

@ -27,7 +27,10 @@ let typeof t =
(match TypeSubstitution.find id env' with (match TypeSubstitution.find id env' with
| Some ty -> Some ty, env' | Some ty -> Some ty, env'
| None -> None, env') | None -> None, env')
| _ -> None, env) (* Directly the type *)
| Some ty, _ -> Some ty, env
(* Bad typed *)
| None, _ -> None, env)
| Term.Fun (id, body) -> | Term.Fun (id, body) ->
let arg = TypeSubstitution.singleton id (Type.Var id) in let arg = TypeSubstitution.singleton id (Type.Var id) in
(match infer (TypeSubstitution.compose arg env) body with (match infer (TypeSubstitution.compose arg env) body with
@ -39,14 +42,21 @@ let typeof t =
| Term.App (t1, t2) -> | Term.App (t1, t2) ->
(* Infer the type of t1 and t2 *) (* Infer the type of t1 and t2 *)
(match infer env t1, infer env t2 with (match infer env t1, infer env t2 with
| (Some (Type.Arrow (ty_param, _)), _), (Some ty_args, _) -> | (Some (Type.Arrow (ty_param, ty_fn)), _), (Some ty_args, _) ->
(* Check if the argument type matches the parameter type *) (* Check if the argument type matches the parameter type *)
(match Unification.unify ty_param ty_args with (match Unification.unify ty_param ty_args with
| Some env' -> | Some env' ->
(* Infer again now that we have some extra typing infos *) let rec nested_infer oldenv currenv final =
(match infer env' t1 with if TypeSubstitution.equal oldenv currenv
| Some (Type.Arrow (_, ty_fn)), env'' -> Some ty_fn, env'' then Some final, currenv
| _ -> None, env) else (
match infer currenv t1 with
| Some (Type.Arrow (_, ty_fn)), newenv ->
nested_infer currenv newenv ty_fn
| _ -> None, currenv)
in
(* Nested *)
nested_infer env env' ty_fn
| None -> None, env) | None -> None, env)
(* | (Some (Type.Var _ as ty1), _), _ -> (* | (Some (Type.Var _ as ty1), _), _ ->
(* On this case we may have a function represented as a variable *) (* On this case we may have a function represented as a variable *)

View file

@ -24,7 +24,6 @@ let rec apply subst = function
(** Compose two substitutions, last with priority *) (** Compose two substitutions, last with priority *)
let compose s2 s1 = let compose s2 s1 =
let merger =
IdentifierMap.merge IdentifierMap.merge
(* ID type_s1 type_s2 *) (* ID type_s1 type_s2 *)
(fun _ ty1 ty2 -> (fun _ ty1 ty2 ->
@ -38,8 +37,6 @@ let compose s2 s1 =
| None, None -> None) | None, None -> None)
s1 s1
s2 s2
in
merger
;; ;;
let to_string map = let to_string map =
@ -57,3 +54,24 @@ let to_string map =
;; ;;
let find = IdentifierMap.find_opt let find = IdentifierMap.find_opt
let equal map1 map2 =
let l_map1 = List.length (IdentifierMap.bindings map1) in
let l_map2 = List.length (IdentifierMap.bindings map2) in
if l_map1 = l_map2 && l_map1 = 0
then (* Two empty maps *)
true
else (
(* Iterate over the largest map *)
let map_forall, map_find = if l_map1 > l_map2 then map1, map2 else map2, map1 in
IdentifierMap.for_all
(fun key value ->
match IdentifierMap.find_opt key map_find with
| Some value' ->
(* Equality between the two keys *)
value = value'
| _ ->
(* Key in map_find doesn't exists in map_forall *)
false)
map_forall)
;;

View file

@ -8,3 +8,4 @@ val empty : t
val singleton : Identifier.t -> Type.t -> t val singleton : Identifier.t -> Type.t -> t
val find : Identifier.t -> t -> Type.t option val find : Identifier.t -> t -> Type.t option
val to_string : t -> string val to_string : t -> string
val equal : t -> t -> bool

View file

@ -51,6 +51,17 @@ let tests_typeof =
, Term.( , Term.(
App (App (Fun (x, Fun (y, Binop (Var x, Plus, Var y))), IntConst 3), IntConst 4)) App (App (Fun (x, Fun (y, Binop (Var x, Plus, Var y))), IntConst 3), IntConst 4))
, Some Type.Int ) , Some Type.Int )
; (* Function with nested pair *)
( "(fun x -> fst x) (1, 2)"
, Term.(App (Fun (x, Proj (First, Var x)), Pair (IntConst 1, IntConst 2)))
, Some Type.Int )
; (* Function application with nested pair and projection *)
( "(fun x -> fst (snd x)) ((1, 2), 3)"
, Term.(
App
( Fun (x, Proj (First, Proj (Second, Var x)))
, Pair (Pair (IntConst 1, IntConst 2), IntConst 3) ))
, Some Type.Int )
] ]
;; ;;