Refactoring, errors are not thrown anymore
This commit is contained in:
elvis
@ -3,48 +3,55 @@ open Types;;
|
||||
|
||||
Random.self_init ()
|
||||
|
||||
let rec evaluate_type (program: t_exp) context =
|
||||
let (let*) = Result.bind
|
||||
|
||||
let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) : (ftype, error) result =
|
||||
match program with
|
||||
Integer _ -> IntegerType
|
||||
| Boolean _ -> BooleanType
|
||||
| Variable x -> (match VariableMap.find_opt x context with
|
||||
None -> raise (AbsentAssignment ("The variable " ^ x ^ " is not defined."))
|
||||
| Some t -> t)
|
||||
Integer _ -> Ok IntegerType
|
||||
| Boolean _ -> Ok BooleanType
|
||||
| Variable x -> (
|
||||
match VariableMap.find_opt x context with
|
||||
None -> Error (`AbsentAssignment ("The variable " ^ x ^ " is not defined."))
|
||||
| Some t -> Ok t
|
||||
)
|
||||
| Function (xs, typef, fbody) -> (
|
||||
match typef with
|
||||
FunctionType (tin, tout) -> (
|
||||
if List.length xs != List.length tin then
|
||||
raise (WrongTypeSpecification "Type specification for function has wrong arity.")
|
||||
if List.length xs <> List.length tin then
|
||||
Error (`WrongTypeSpecification "Type specification for function has wrong arity.")
|
||||
else
|
||||
let context1 = List.fold_left2 (fun acc x t -> VariableMap.add x t acc) context xs tin in
|
||||
match (evaluate_type fbody context1 = tout) with
|
||||
(false) -> raise (WrongTypeSpecification "Function does not return specified type.")
|
||||
| (true) -> typef
|
||||
let* typefbody = evaluate_type fbody context1 in
|
||||
match (typefbody = tout) with
|
||||
(false) -> Error (`WrongTypeSpecification "Function does not return specified type.")
|
||||
| (true) -> Ok typef
|
||||
)
|
||||
| _ -> raise (WrongTypeSpecification "Specification of function is not a function type.")
|
||||
| _ -> Error (`WrongTypeSpecification "Specification of function is not a function type.")
|
||||
)
|
||||
| Application (f, xs) -> (
|
||||
match evaluate_type f context with
|
||||
let* evalf = evaluate_type f context in
|
||||
match evalf with
|
||||
FunctionType (tin, tout) -> (
|
||||
let rec helper params typeparams =
|
||||
match (params, typeparams) with
|
||||
([], _) -> typeparams
|
||||
| (_, []) -> raise (WrongArity ("Function application has arity " ^
|
||||
(List.length tin |> string_of_int) ^
|
||||
", but was applied to " ^
|
||||
(List.length xs |> string_of_int) ^
|
||||
" parameters"))
|
||||
([], _) -> Ok typeparams
|
||||
| (_, []) -> Error (`WrongArity ("Function application has arity " ^
|
||||
(List.length tin |> string_of_int) ^
|
||||
", but was applied to " ^
|
||||
(List.length xs |> string_of_int) ^
|
||||
" parameters"))
|
||||
| (p::tlparams, v::tltypeparams) ->
|
||||
if evaluate_type p context = v then
|
||||
if evaluate_type p context = Ok v then
|
||||
helper tlparams tltypeparams
|
||||
else
|
||||
raise (WrongType "Argument with wrong type.")
|
||||
Error (`WrongType "Argument with wrong type.")
|
||||
in
|
||||
match helper xs tin with
|
||||
[] -> tout
|
||||
| t -> FunctionType (t, tout)
|
||||
let* typesremaining = helper xs tin in
|
||||
match typesremaining with
|
||||
[] -> Ok tout
|
||||
| t -> Ok (FunctionType (t, tout))
|
||||
)
|
||||
| _ -> raise (WrongType "Applying to a non function type")
|
||||
| _ -> Error (`WrongType "Applying to a non function type")
|
||||
)
|
||||
| Plus (x, y)
|
||||
| Minus (x, y)
|
||||
@ -52,74 +59,90 @@ let rec evaluate_type (program: t_exp) context =
|
||||
| Division (x, y)
|
||||
| Modulo (x, y)
|
||||
| Power (x, y) -> (
|
||||
match (evaluate_type x context, evaluate_type y context) with
|
||||
| (IntegerType, IntegerType) -> IntegerType
|
||||
| (IntegerType, _) -> raise (WrongType "Second term is not an integer.")
|
||||
| (_, _) -> raise (WrongType "First term is not an integer.")
|
||||
let* typex = evaluate_type x context in
|
||||
let* typey = evaluate_type y context in
|
||||
match typex, typey with
|
||||
| (IntegerType, IntegerType) -> Ok IntegerType
|
||||
| (IntegerType, _) -> Error (`WrongType "Second term is not an integer.")
|
||||
| (_, _) -> Error (`WrongType "First term is not an integer.")
|
||||
)
|
||||
| PowerMod (x, y, z) -> (
|
||||
match (evaluate_type x context, evaluate_type y context, evaluate_type z context) with
|
||||
| (IntegerType, IntegerType, IntegerType) -> IntegerType
|
||||
| (IntegerType, IntegerType, _) -> raise (WrongType "Third term is not an integer.")
|
||||
| (IntegerType, _, _) -> raise (WrongType "Second term is not an integer.")
|
||||
| (_, _, _) -> raise (WrongType "First term is not an integer.")
|
||||
let* typex = evaluate_type x context in
|
||||
let* typey = evaluate_type y context in
|
||||
let* typez = evaluate_type z context in
|
||||
match typex, typey, typez with
|
||||
| (IntegerType, IntegerType, IntegerType) -> Ok IntegerType
|
||||
| (IntegerType, IntegerType, _) -> Error (`WrongType "Third term is not an integer.")
|
||||
| (IntegerType, _, _) -> Error (`WrongType "Second term is not an integer.")
|
||||
| (_, _, _) -> Error (`WrongType "First term is not an integer.")
|
||||
)
|
||||
| Rand (x) -> (
|
||||
match (evaluate_type x context) with
|
||||
| (IntegerType) -> IntegerType
|
||||
| (_) -> raise (WrongType "Term is not an integer.")
|
||||
let* typex = evaluate_type x context in
|
||||
match typex with
|
||||
| (IntegerType) -> Ok IntegerType
|
||||
| (_) -> Error (`WrongType "Term is not an integer.")
|
||||
)
|
||||
| BAnd (x, y)
|
||||
| BOr (x, y) -> (
|
||||
match (evaluate_type x context, evaluate_type y context) with
|
||||
| (BooleanType, BooleanType) -> BooleanType
|
||||
| (BooleanType, _) -> raise (WrongType "Second term is not a boolean.")
|
||||
| (_, _) -> raise (WrongType "First term is not a boolean.")
|
||||
let* typex = evaluate_type x context in
|
||||
let* typey = evaluate_type y context in
|
||||
match typex, typey with
|
||||
| (BooleanType, BooleanType) -> Ok BooleanType
|
||||
| (BooleanType, _) -> Error (`WrongType "Second term is not a boolean.")
|
||||
| (_, _) -> Error (`WrongType "First term is not a boolean.")
|
||||
)
|
||||
| BNot (x) -> (
|
||||
match (evaluate_type x context) with
|
||||
| (BooleanType) -> BooleanType
|
||||
| (_) -> raise (WrongType "Term is not a boolean.")
|
||||
let* typex = evaluate_type x context in
|
||||
match typex with
|
||||
| (BooleanType) -> Ok BooleanType
|
||||
| (_) -> Error (`WrongType "Term is not a boolean.")
|
||||
)
|
||||
| Cmp (x, y)
|
||||
| CmpLess (x, y)
|
||||
| CmpLessEq (x, y)
|
||||
| CmpGreater (x, y)
|
||||
| CmpGreaterEq (x, y) -> (
|
||||
match (evaluate_type x context, evaluate_type y context) with
|
||||
| (IntegerType, IntegerType) -> BooleanType
|
||||
| (IntegerType, _) -> raise (WrongType "Second term is not an integer.")
|
||||
| (_, _) -> raise (WrongType "First term is not an integer.")
|
||||
let* typex = evaluate_type x context in
|
||||
let* typey = evaluate_type y context in
|
||||
match typex, typey with
|
||||
| (IntegerType, IntegerType) -> Ok BooleanType
|
||||
| (IntegerType, _) -> Error (`WrongType "Second term is not an integer.")
|
||||
| (_, _) -> Error (`WrongType "First term is not an integer.")
|
||||
)
|
||||
| IfThenElse (guard, if_exp, else_exp) -> (
|
||||
match (evaluate_type guard context, evaluate_type if_exp context, evaluate_type else_exp context) with
|
||||
let* typeguard = evaluate_type guard context in
|
||||
let* typeif_exp = evaluate_type if_exp context in
|
||||
let* typeelse_exp = evaluate_type else_exp context in
|
||||
match typeguard, typeif_exp, typeelse_exp with
|
||||
(BooleanType, t1, t2) -> (
|
||||
if t1 = t2 then
|
||||
t1
|
||||
Ok t1
|
||||
else
|
||||
raise (WrongType "If branches do not have the same type.")
|
||||
Error (`WrongType "If branches do not have the same type.")
|
||||
)
|
||||
| (_, _, _) -> raise (WrongType "If guard is not a boolean.")
|
||||
| (_, _, _) -> Error (`WrongType "If guard is not a boolean.")
|
||||
)
|
||||
| LetIn (x, xval, rest) ->
|
||||
let typex = evaluate_type xval context in
|
||||
let* typex = evaluate_type xval context in
|
||||
evaluate_type rest (VariableMap.add x typex context)
|
||||
| LetFun (f, xs, typef, fbody, rest) ->
|
||||
match typef with
|
||||
FunctionType (tin, tout) -> (
|
||||
if List.length xs != List.length tin then
|
||||
raise (WrongArity "Type specification for function has wrong arity.")
|
||||
if List.length xs <> List.length tin then
|
||||
Error (`WrongArity "Type specification for function has wrong arity.")
|
||||
else
|
||||
let context1 = VariableMap.add f typef context in
|
||||
let context2 = List.fold_left2 (fun acc x t -> VariableMap.add x t acc) context1 xs tin in
|
||||
match (evaluate_type fbody context2 = tout, evaluate_type rest context1) with
|
||||
(false, _) -> raise (WrongTypeSpecification "Function does not return specified type."
|
||||
)
|
||||
| (true, t) -> t
|
||||
let* typefbody = evaluate_type fbody context2 in
|
||||
let* typerest = evaluate_type rest context1 in
|
||||
match (typefbody = tout, typerest) with
|
||||
(false, _) -> Error (`WrongTypeSpecification "Function does not return specified type.")
|
||||
| (true, t) -> Ok t
|
||||
)
|
||||
| _ -> raise (WrongTypeSpecification "Specification of function is not a function type.")
|
||||
| _ -> Error (`WrongTypeSpecification "Specification of function is not a function type.")
|
||||
|
||||
let typecheck (program: t_exp) =
|
||||
match evaluate_type program VariableMap.empty with
|
||||
FunctionType ([IntegerType], IntegerType) -> true
|
||||
| _ -> raise (WrongType "Program is not a function from int to int.")
|
||||
let typecheck (program: t_exp) : (ftype, error) result =
|
||||
let* typeprogram = evaluate_type program VariableMap.empty in
|
||||
match typeprogram with
|
||||
FunctionType ([IntegerType], IntegerType) -> Ok (FunctionType ([IntegerType], IntegerType))
|
||||
| _ -> Error (`WrongType "Program is not a function from int to int.")
|
||||
|
||||
Reference in New Issue
Block a user