Refactor

lib/miniFun/TypeChecker.ml

@@ -0,0 +1,125 @@
+module Utility = Utility
+open Types;;
+
+Random.self_init ()
+
+let rec evaluate_type (program: t_exp) context =
+  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)
+  | 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.")
+          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
+        )
+      | _ -> raise (WrongTypeSpecification "Specification of function is not a function type.")
+    )
+  | Application (f, xs) -> (
+      match evaluate_type f context 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"))
+            | (p::tlparams, v::tltypeparams) ->
+              if evaluate_type p context = v then
+                helper tlparams tltypeparams
+              else
+                raise (WrongType "Argument with wrong type.")
+          in
+          match helper xs tin with
+            [] -> tout
+          | t -> FunctionType (t, tout)
+        )
+      | _ -> raise (WrongType "Applying to a non function type")
+    )
+  | Plus (x, y)
+  | Minus (x, y)
+  | Times (x, y)
+  | 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.")
+    )
+  | 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.")
+    )
+  | Rand (x) -> (
+      match (evaluate_type x context) with
+      | (IntegerType) -> IntegerType
+      | (_) -> raise (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.")
+    )
+  | BNot (x) -> (
+      match (evaluate_type x context) with
+      | (BooleanType) -> BooleanType
+      | (_) -> raise (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.")
+    )
+  | IfThenElse (guard, if_exp, else_exp) -> (
+      match (evaluate_type guard context, evaluate_type if_exp context, evaluate_type else_exp context) with
+        (BooleanType, t1, t2) -> (
+          if t1 = t2 then
+            t1
+          else
+            raise (WrongType "If branches do not have the same type.")
+        )
+      | (_, _, _) -> raise (WrongType "If guard is not a boolean.")
+    )
+  | LetIn (x, xval, rest) ->
+    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.")
+        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
+      )
+    | _ -> raise (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.")