elvis/lci
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding simple Algorithm W implementation (no recursive functions)

Browse Source
This commit is contained in:
elvis
2025-01-31 03:15:58 +01:00
parent b54d088e59
commit 9991efafbf
12 changed files with 697 additions and 143 deletions
Download Patch File Download Diff File Expand all files Collapse all files

313
lib/miniFun/TypeChecker.ml
View File

@ -5,54 +5,256 @@ Random.self_init ()
let (let*) = Result.bind
let evaluate_type_polimorphic (_program: t_exp) (_context: typingshape)
: (typingshape, error) result =
failwith "Not implemented"
(* match program with *)
(* Integer _ -> Ok (VariableMap.empty, IntegerType) *)
(* | Boolean _ -> Ok (VariableMap.empty, BooleanType) *)
(* | Variable x -> ( *)
(* match (VariableMap.find_opt x (fst context)) with *)
(* (None) -> ( *)
(* let u = PolimorphicType (Utility.from_int_to_string !globalIdentifier) in *)
(* globalIdentifier := !globalIdentifier + 1; *)
(* Ok (VariableMap.singleton x u, u) *)
(* ) *)
(* | (Some u) -> Ok (VariableMap.singleton x u, u) *)
(* ) *)
(* | Function (xs, typef, fbody) -> failwith "Not Implemented" *)
(* | Application (f, xs) -> failwith "Not Implemented" *)
(* | Plus (x, y) *)
(* | Minus (x, y) *)
(* | Times (x, y) *)
(* | Division (x, y) *)
(* | Modulo (x, y) *)
(* | Power (x, y) -> ( *)
(* let* partialResx = evaluate_type x context in *)
(* let* partialResy = evaluate_type y context in *)
(* match (partialResx, partialResy) with *)
(* ((conx, IntegerType), (cony, IntegerType)) -> *)
(* Ok (VariableMap.union (fun _ x _ -> Some x) conx cony, *)
(* FunctionType ([IntegerType; IntegerType], IntegerType)) *)
(* | ((conx, PolimorphicType xv), (cony, IntegerType)) -> *)
(* Ok (unify ) *)
(* | ((_conx, IntegerType), (_cony, PolimorphicType _yv)) *)
(* | ((_conx, PolimorphicType _xv), (_cony, PolimorphicType _yv)) -> failwith "ads" *)
(* | (_, _) -> Error (`WrongType "The arguments are of the wrong type") *)
(* ) *)
(* | PowerMod (x, y, z) -> failwith "Not Implemented" *)
(* | Rand (x) -> failwith "Not Implemented" *)
(* | BAnd (x, y) *)
(* | BOr (x, y) -> failwith "Not Implemented" *)
(* | BNot (x) -> failwith "Not Implemented" *)
(* | Cmp (x, y) *)
(* | CmpLess (x, y) *)
(* | CmpLessEq (x, y) *)
(* | CmpGreater (x, y) *)
(* | CmpGreaterEq (x, y) -> failwith "Not Implemented" *)
(* | IfThenElse (guard, if_exp, else_exp) -> failwith "Not Implemented" *)
(* | LetIn (x, xval, rest) -> failwith "Not Implemented" *)
(* | LetFun (f, xs, typef, fbody, rest) -> failwith "Not Implemented" *)
(* -------------------------------------------------------------------------- *)
(* polimporphic type checking *)
(* -------------------------------------------------------------------------- *)
let global_type_id = ref 0
let new_global_id () =
let id = !global_type_id in
incr global_type_id;
id
let rec unify type_a type_b =
if type_a == type_b then Ok () else
match (type_a, type_b) with
| IntegerTypeP, IntegerTypeP
| BooleanTypeP, BooleanTypeP ->
Ok ()
| TupleTypeP (a1, a2), TupleTypeP (b1, b2)
| ApplicationP (a1, a2), ApplicationP (b1, b2)
| FunctionTypeP (a1, a2), FunctionTypeP (b1, b2) ->
let* _ = unify a1 b1 in
unify a2 b2
| VariableTypeP ({contents = Link a1}),
VariableTypeP ({contents = Link b1}) ->
unify a1 b1
| VariableTypeP ({contents = Link ty_link}), ty_rest
| ty_rest, VariableTypeP ({contents = Link ty_link})
when ty_link = ty_rest ->
Ok ()
| VariableTypeP ({contents = Unbound (a1, _)}),
VariableTypeP ({contents = Unbound (b1, _)})
when a1 = b1 ->
Error (`WrongType "Only a single instance of a type should be available.")
| type_ab, VariableTypeP ({contents = Unbound (_id, _level)} as tvar)
| VariableTypeP ({contents = Unbound (_id, _level)} as tvar), type_ab ->
tvar := Link type_ab;
Ok ()
| _, _ ->
Error (`WrongType "Cannot unify types.")
let rec unifyable type_a type_b =
if type_a == type_b then Ok () else
match (type_a, type_b) with
| IntegerTypeP, IntegerTypeP
| BooleanTypeP, BooleanTypeP ->
Ok ()
| TupleTypeP (a1, a2), TupleTypeP (b1, b2)
| ApplicationP (a1, a2), ApplicationP (b1, b2)
| FunctionTypeP (a1, a2), FunctionTypeP (b1, b2) ->
let* _ = unifyable a1 b1 in
unifyable a2 b2
| VariableTypeP ({contents = Link a1}),
VariableTypeP ({contents = Link b1}) ->
unifyable a1 b1
| VariableTypeP ({contents = Link ty_link}), ty_rest
| ty_rest, VariableTypeP ({contents = Link ty_link})
when ty_link = ty_rest ->
Ok ()
| VariableTypeP ({contents = Unbound (a1, _)}),
VariableTypeP ({contents = Unbound (b1, _)})
when a1 = b1 ->
Error (`WrongType "Only a single instance of a type should be available.")
| _type_ab, VariableTypeP ({contents = Unbound (_id, _level)})
| VariableTypeP ({contents = Unbound (_id, _level)}), _type_ab ->
Ok ()
| _, _ ->
Error (`WrongType "Cannot unify types.")
let rec generalize level ty =
match ty with
| VariableTypeP {contents = Unbound (id, o_level)} when o_level > level ->
VariableTypeP (ref (Generic id))
| ApplicationP (ty, ty_arg) ->
ApplicationP (generalize level ty, generalize level ty_arg)
| FunctionTypeP (ty_arg, ty) ->
FunctionTypeP (generalize level ty_arg, generalize level ty)
| TupleTypeP (ty1, ty2) ->
TupleTypeP (generalize level ty1, generalize level ty2)
| VariableTypeP {contents = Link ty} ->
generalize level ty
| VariableTypeP {contents = Generic _}
| VariableTypeP {contents = Unbound _}
| IntegerTypeP
| BooleanTypeP ->
ty
let instantiate level ty =
let var_map = ref IntegerMap.empty in
let rec aux ty =
match ty with
| IntegerTypeP
| BooleanTypeP ->
ty
| TupleTypeP (ty1, ty2) ->
TupleTypeP (aux ty1, aux ty2)
| VariableTypeP {contents = Link ty} ->
aux ty
| VariableTypeP {contents = Generic id} -> (
match IntegerMap.find_opt id !var_map with
| Some ty -> ty
| None ->
let var = VariableTypeP (ref (Unbound (new_global_id (), level))) in
var_map := IntegerMap.add id var !var_map;
var
)
| VariableTypeP {contents = Unbound _} ->
ty
| ApplicationP (ty, ty_arg) ->
ApplicationP (aux ty, aux ty_arg)
| FunctionTypeP (ty_arg, ty) ->
FunctionTypeP (aux ty_arg, aux ty)
in
aux ty
let rec evaluate_type_polimorphic program (env: env) level =
match program with
| Integer _ -> Ok (IntegerTypeP)
| Boolean _ -> Ok (BooleanTypeP)
| Tuple (a, b) ->
let* type_a = evaluate_type_polimorphic a env level in
let* type_b = evaluate_type_polimorphic b env level in
Ok (TupleTypeP (type_a, type_b))
| Variable (x) -> (
match VariableMap.find_opt x env with
| Some (ty) ->
Ok (instantiate level ty)
| None ->
Error (`AbsentAssignment ("Variable " ^ x ^ " is not assigned."))
)
| Function (x, _typef, fbody) ->
let param_type = VariableTypeP (ref (Unbound (new_global_id (), level))) in
let fn_env = VariableMap.add x param_type env in
let* body_type = evaluate_type_polimorphic fbody fn_env level in
Ok (FunctionTypeP (param_type, body_type))
| Application (f, xs) ->
let* type_f = evaluate_type_polimorphic f env level in
let rec aux =
function
| FunctionTypeP (type_f_arg, type_f) ->
Ok (type_f_arg, type_f)
| VariableTypeP {contents = Link ty} ->
aux ty
| VariableTypeP ({contents = Unbound(_id, level)} as tvar) ->
let param_ty = VariableTypeP (ref (Unbound (new_global_id (), level)))
in
let f_ty = VariableTypeP (ref (Unbound (new_global_id (), level))) in
tvar := Link ( FunctionTypeP (param_ty, f_ty) );
Ok (param_ty, f_ty)
| _ -> Error (`WrongType "Expecting a function to apply.")
in
let* param_ty, f_ty = aux type_f in
let* type_xs = evaluate_type_polimorphic xs env level in
let* _ = unify param_ty type_xs in
Ok f_ty
| Plus (a, b)
| Minus (a, b)
| Times (a, b)
| Division (a, b)
| Modulo (a, b)
| Power (a, b) ->
let* type_a = evaluate_type_polimorphic a env level in
let* type_b = evaluate_type_polimorphic b env level in
let* _ = unify type_a IntegerTypeP in
let* _ = unify type_b IntegerTypeP in
Ok (IntegerTypeP)
| First a -> (
let* type_a = evaluate_type_polimorphic a env level in
let* _ = unify type_a
(TupleTypeP(VariableTypeP (ref (Unbound (new_global_id (), level))),
VariableTypeP (ref (Unbound (new_global_id (), level)))))
in
match type_a with
| TupleTypeP (ty_a, _)
| VariableTypeP {contents = Link TupleTypeP (ty_a, _)} -> Ok ty_a
| _ -> Error (`WrongType "Applying First to non tuple type.")
)
| Second a -> (
let* type_a = evaluate_type_polimorphic a env level in
let* _ = unify type_a
(TupleTypeP(VariableTypeP (ref (Unbound (new_global_id (), level))),
VariableTypeP (ref (Unbound (new_global_id (), level)))))
in
match type_a with
| TupleTypeP (_, ty_a)
| VariableTypeP {contents = Link TupleTypeP (_, ty_a)} -> Ok ty_a
| _ -> Error (`WrongType "Applying Second to non tuple type.")
)
| PowerMod (x, y, z) ->
let* type_x = evaluate_type_polimorphic x env level in
let* type_y = evaluate_type_polimorphic y env level in
let* type_z = evaluate_type_polimorphic z env level in
let* _ = unify type_x IntegerTypeP in
let* _ = unify type_y IntegerTypeP in
let* _ = unify type_z IntegerTypeP in
Ok (IntegerTypeP)
| Rand (x) ->
let* type_x = evaluate_type_polimorphic x env level in
let* _ = unify type_x IntegerTypeP in
Ok (IntegerTypeP)
| BAnd (a, b)
| BOr (a, b) ->
let* type_a = evaluate_type_polimorphic a env level in
let* type_b = evaluate_type_polimorphic b env level in
let* _ = unify type_a BooleanTypeP in
let* _ = unify type_b BooleanTypeP in
Ok (BooleanTypeP)
| BNot (x) ->
let* type_x = evaluate_type_polimorphic x env level in
let* _ = unify type_x BooleanTypeP in
Ok (BooleanTypeP)
| Cmp (a, b)
| CmpLess (a, b)
| CmpLessEq (a, b)
| CmpGreater (a, b)
| CmpGreaterEq (a, b) ->
let* type_a = evaluate_type_polimorphic a env level in
let* type_b = evaluate_type_polimorphic b env level in
let* _ = unify type_a IntegerTypeP in
let* _ = unify type_b IntegerTypeP in
Ok (BooleanTypeP)
| IfThenElse (guard, if_exp, else_exp) ->
let* type_guard = evaluate_type_polimorphic guard env level in
let* type_if_exp = evaluate_type_polimorphic if_exp env level in
let* type_else_exp = evaluate_type_polimorphic else_exp env level in
let* _ = unify type_guard BooleanTypeP in
let* _ = unify type_if_exp type_else_exp in
Ok (type_if_exp)
| LetIn (x, xval, rest) ->
let* var_ty = evaluate_type_polimorphic xval env (level + 1) in
let generalized_ty = generalize level var_ty in
evaluate_type_polimorphic rest (VariableMap.add x generalized_ty env) level
| LetFun (_f, _xs, _typef, _fbody, _rest) -> failwith "Not Implemented"
(* -------------------------------------------------------------------------- *)
let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) :
(ftype, [> typechecking_error]) result =
@ -201,10 +403,19 @@ let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) :
| _ -> Error (`WrongTypeSpecification
"Specification of function is not a function type.")
let typecheck (program: t_exp) : (ftype, [> typechecking_error]) result =
let* typeprogram = evaluate_type program VariableMap.empty in
match typeprogram with
FunctionType (IntegerType, IntegerType) -> (
Ok (typeprogram)
)
FunctionType (IntegerType, IntegerType) -> Ok (typeprogram)
| _ -> Error (`WrongType "Program is not a function from int to int.")
let typecheck_polymorphic (program: t_exp)
: (type_f, [> typechecking_error]) result =
global_type_id := 0;
let* type_program = evaluate_type_polimorphic program VariableMap.empty 0 in
let* _ = unifyable type_program (FunctionTypeP (IntegerTypeP, IntegerTypeP))
in
let generalized_ty = generalize (-1) type_program in
Ok (generalized_ty)