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)

2
lib/miniFun/TypeChecker.mli
View File

@ -1 +1,3 @@
val typecheck : Types.t_exp -> (Types.ftype, [> Types.typechecking_error]) result
val typecheck_polymorphic : Types.t_exp -> (Types.type_f, [> Types.typechecking_error]) result

77
lib/miniFun/Types.ml
View File

@ -5,18 +5,79 @@ let globalIdentifier = ref 1
module VariableMap = Map.Make(String)
module VariableSet = Set.Make(String)
type ftype =
(* -------------------------------------------------------------------------- *)
(* polimporphic type checking types *)
(* -------------------------------------------------------------------------- *)
type id = int
type level = int
type type_f =
IntegerTypeP
| BooleanTypeP
| TupleTypeP of type_f * type_f
| VariableTypeP of variable_type ref
| FunctionTypeP of type_f * type_f
| ApplicationP of type_f * type_f
and variable_type =
Unbound of id * level
| Link of type_f
| Generic of id
type env = type_f VariableMap.t
module IntegerMap = Map.Make(Int)
let pp_type_f (ty: type_f) : string =
let id_name_map = ref IntegerMap.empty in
let count = ref 0 in
let next_name () =
let i = !count in
incr count;
Utility.from_int_to_string i
in
let rec aux is_simple ty =
match ty with
| IntegerTypeP -> "Int"
| BooleanTypeP -> "Bool"
| TupleTypeP (ty1, ty2) ->
"(" ^ aux is_simple ty1 ^ ", " ^ aux is_simple ty2 ^ ")"
| ApplicationP (ty, ty_arg) ->
aux true ty ^ "(" ^ aux false ty_arg ^ ")"
| FunctionTypeP (ty_arg, ty) ->
let ty_arg_str = aux true ty_arg in
let ty_str = aux false ty in
let str = ty_arg_str ^ " -> " ^ ty_str in
if is_simple then "(" ^ str ^ ")" else str
| VariableTypeP {contents = Generic id} -> (
match IntegerMap.find_opt id !id_name_map with
| Some a -> a
| None ->
let name = next_name () in
id_name_map := IntegerMap.add id name !id_name_map;
name
)
| VariableTypeP {contents = Unbound (id, _)} ->
"_" ^ string_of_int id
| VariableTypeP {contents = Link ty} ->
aux is_simple ty
in
let ty_str = aux false ty in
if !count > 0 then
let var_names =
IntegerMap.fold (fun _ value acc -> value :: acc) !id_name_map []
in
"∀ " ^ (String.concat " " (List.sort String.compare var_names))
^ ", " ^ ty_str
else
ty_str
(* -------------------------------------------------------------------------- *)
type ftype = (* type used for specification *)
IntegerType
| BooleanType
| TupleType of ftype * ftype
| PolimorphicType of string
| FunctionType of ftype * ftype
type fsubstitution = (* goes from polimorphic types to types *)
ftype VariableMap.t
type fenvironment = (* goes from variables to types *)
ftype VariableMap.t
type typingshape = (* tuple of a simple type environment and a simple type *)
fenvironment * ftype
type t_exp =
Integer of int (* x := a *)

130
lib/miniFun/Types.mli
View File

@ -5,73 +5,81 @@ val globalIdentifier : int ref
module VariableMap : Map.S with type key = variable
module VariableSet : Set.S with type elt = string
type ftype =
(* -------------------------------------------------------------------------- *)
(* polimporphic type checking types *)
(* -------------------------------------------------------------------------- *)
type id = int
type level = int
type type_f =
IntegerTypeP
| BooleanTypeP
| TupleTypeP of type_f * type_f
| VariableTypeP of variable_type ref
| FunctionTypeP of type_f * type_f
| ApplicationP of type_f * type_f
and variable_type =
Unbound of id * level
| Link of type_f
| Generic of id
type env = type_f VariableMap.t
module IntegerMap : Map.S with type key = int
val pp_type_f : type_f -> string
(* module VariableTypeMap : Map.S with type key = variable_type *)
(* type substitution = (\* from variable types to politypes *\) *)
(* politype VariableTypeMap.t *)
(* type prefix = *)
(* | Lambda *)
(* | Let *)
(* | LetRec *)
(* type typed_prefix = *)
(* (\* list of free variables in the context and the associated type *\) *)
(* (prefix * politype) VariableMap.t *)
(* -------------------------------------------------------------------------- *)
type ftype = (* type used for specification *)
IntegerType
| BooleanType
| TupleType of ftype * ftype
| PolimorphicType of variable
| FunctionType of ftype * ftype
type fsubstitution = (* goes from polimorphic types to types *)
ftype VariableMap.t
type fenvironment = (* goes from variables to types *)
ftype VariableMap.t
type typingshape = (* tuple of a simple type environment and a simple type *)
fenvironment * ftype
type intermediaryType =
IInteger
| IBoolean
| IVariable of variable
| IFunction of variable list * ftype list * intermediaryType
| IApplication of intermediaryType * intermediaryType list
| IPlus of intermediaryType * intermediaryType
| IMinus of intermediaryType * intermediaryType
| ITimes of intermediaryType * intermediaryType
| IDivision of intermediaryType * intermediaryType
| IModulo of intermediaryType * intermediaryType
| IPower of intermediaryType * intermediaryType
| IPowerMod of intermediaryType * intermediaryType * intermediaryType
| IRand of intermediaryType
| IBAnd of intermediaryType * intermediaryType
| IBOr of intermediaryType * intermediaryType
| IBNot of intermediaryType
| ICmp of intermediaryType * intermediaryType
| ICmpLess of intermediaryType * intermediaryType
| ICmpLessEq of intermediaryType * intermediaryType
| ICmpGreater of intermediaryType * intermediaryType
| ICmpGreaterEq of intermediaryType * intermediaryType
| IIfThenElse of intermediaryType * intermediaryType * intermediaryType
| ILetIn of variable * ftype * intermediaryType * intermediaryType
| ILetFun of variable * ftype * variable list * ftype list * intermediaryType * intermediaryType
type t_exp =
Integer of int (* x := a *)
| Boolean of bool (* v *)
| Variable of variable (* x *)
| Tuple of t_exp * t_exp (* (a, b) *)
| Function of variable * ftype * t_exp (* lambda x: t. x *)
| Application of t_exp * t_exp (* x x *)
| Plus of t_exp * t_exp (* x + x *)
| Minus of t_exp * t_exp (* x - x *)
| Times of t_exp * t_exp (* x * x *)
| Division of t_exp * t_exp (* x / x *)
| Modulo of t_exp * t_exp (* x % x *)
| Power of t_exp * t_exp (* x ^ x *)
| PowerMod of t_exp * t_exp * t_exp (* (x ^ x) % x *)
| Rand of t_exp (* rand(0, x) *)
| BAnd of t_exp * t_exp (* x && x *)
| BOr of t_exp * t_exp (* x || x *)
| BNot of t_exp (* not x *)
| First of t_exp (* fst x *)
| Second of t_exp (* scn x *)
| Cmp of t_exp * t_exp (* x == x *)
| CmpLess of t_exp * t_exp (* x < x *)
| CmpLessEq of t_exp * t_exp (* x <= x *)
| CmpGreater of t_exp * t_exp (* x > x *)
| CmpGreaterEq of t_exp * t_exp (* x >= x *)
| IfThenElse of t_exp * t_exp * t_exp (* if b then c else c *)
| LetIn of variable * t_exp * t_exp (* let x = x in x *)
| LetFun of variable * variable * ftype * t_exp * t_exp (* let rec x. y: t. x in x*)
Integer of int (* x := a *)
| Boolean of bool (* v *)
| Variable of variable (* x *)
| Tuple of t_exp * t_exp (* (a, b) *)
| Function of variable * ftype * t_exp (* lambda x: t. x *)
| Application of t_exp * t_exp (* x x *)
| Plus of t_exp * t_exp (* x + x *)
| Minus of t_exp * t_exp (* x - x *)
| Times of t_exp * t_exp (* x * x *)
| Division of t_exp * t_exp (* x / x *)
| Modulo of t_exp * t_exp (* x % x *)
| Power of t_exp * t_exp (* x ^ x *)
| PowerMod of t_exp * t_exp * t_exp (* (x ^ x) % x *)
| Rand of t_exp (* rand(0, x) *)
| BAnd of t_exp * t_exp (* x && x *)
| BOr of t_exp * t_exp (* x || x *)
| BNot of t_exp (* not x *)
| First of t_exp (* fst x *)
| Second of t_exp (* scn x *)
| Cmp of t_exp * t_exp (* x == x *)
| CmpLess of t_exp * t_exp (* x < x *)
| CmpLessEq of t_exp * t_exp (* x <= x *)
| CmpGreater of t_exp * t_exp (* x > x *)
| CmpGreaterEq of t_exp * t_exp (* x >= x *)
| IfThenElse of t_exp * t_exp * t_exp (* if b then c else c *)
| LetIn of variable * t_exp * t_exp (* let x = x in x *)
| LetFun of variable * variable * ftype * t_exp * t_exp
(* let rec x. y: t. x in x*)
type permitted_values =
IntegerPermitted of int

2
lib/miniFun/dune
View File

@ -5,7 +5,7 @@
(explain true)
(infer true)
(flags --dump --table)
)
)
(library
(name miniFun)

2
lib/miniImp/dune
View File

@ -5,7 +5,7 @@
(explain true)
(infer true)
(flags --dump --table)
)
)
(library
(name miniImp)