ocaml type checker

namer.ml

(* Name: Alan Lin
   Assignment: Problem Set 6 -> Namer
*)

module Namer =
struct
   type typ = IntType | BoolType
   type value = BoolValue of int | IntValue of int
   type ast = Const of int * typ
            | App of string * ast list
            | If of ast * ast * ast
            | And of ast * ast
            | Or of ast * ast
            | Id of string
          | Block of (string * typ * ast) * ast

    exception Syntax of string
    exception RunTimeError of string

module Ast =
struct
   let rec toString ast =
      match ast with
        Id(e1) -> String.concat "" ["Id";"(";e1;")"]
        | Const(n, IntType) -> String.concat "" ["Int(";string_of_int(n);")"]
        | Const(n, BoolType) -> String.concat "" ["Bool(";string_of_int(n);")"]
        | App(id, arguments) -> let app_id = id and args = arguments in 
                                    let rec test a = match a with
                                        [] -> ""
                                        | n::[]  -> toString n
                                        | n::ns -> String.concat "" ([toString n] @ [","] @ [test ns])
                                        in String.concat "" ([app_id] @ ["("] @ [test args] @ [")"])
        | If(e1, e2, e3) -> String.concat "" ["If";"(";toString e1;",";toString e2;",";toString e3;")"]
        | And(e1, e2) -> String.concat "" ["And";"(";toString e1;",";toString e2;")"]
        | Or(e1, e2) -> String.concat "" ["Or";"(";toString e1;",";toString e2;")"]
        | Block((e1,IntType,e3), f1) -> String.concat "" ["Block";"(";e1;":";"int";"=";toString e3;";";toString f1;")"]
        | Block((e1,BoolType,e3), f1) -> String.concat "" ["Block";"(";e1;":";"bool";"=";toString e3;";";toString f1;")"]
end

    module StringOrder =
    struct
        type t = String.t
        let compare = String.compare
    end

    module Tenv = Map.Make(StringOrder)

    (*This is for our static basis*)
    let operatorNames = ["+"; "-"; "*"; "/"; "%"; "<"; "=="; "!"]

    let makeBasis names implementations =
        let pairs = List.combine names implementations in
            List.fold_right (fun (name, impl) -> (fun map -> Tenv.add name impl map)) pairs Tenv.empty

    let divByZeroCheck f =
        function [IntValue n1;IntValue n2] -> if(n2==0) then raise (RunTimeError("Divide by Zero")) else IntValue(f n1 n2)
        | _ -> raise (RunTimeError("intXint2bool: non integer argument."))

    let bool2bool f = function [BoolValue n1] -> BoolValue(f n1)
        | _ -> raise (RunTimeError("intXint2bool: non boolean argument."))

    let checkintXint2int f =
        function [Some(IntType); Some(IntType)] -> Some(IntType)
        | _ -> None

    let checkintXint2bool f =
        function [Some(IntType); Some(IntType)] -> Some(BoolType)
        | _ -> None

    let checkbool2bool f =
        function [Some(BoolType)] -> Some(BoolType)
        | _ -> None

   let typeIntXInt2IntList = [(fun x y -> x + y);
                            (fun x y -> x - y);
                            (fun x y -> x * y)]

   let typeIntXInt2IntDivision = [(fun x y -> x / y)]
   let typeIntXInt2IntMod = [(fun x y -> x mod y)]

   let typeIntXInt2BoolList = [(fun x y -> if x < y then 1 else 0);
                                (fun x y -> if x == y then 1 else 0)]

    let typeBool2BoolList = [(fun n -> if n == 1 then 0 else 1)]

    let makeCheckerImplementations() =
        let primsOfTypeIntXInt2Int = typeIntXInt2IntList in
        let primsOfTypeIntXInt2IntDivision = typeIntXInt2IntDivision in
        let primsOfTypeIntXInt2IntMod = typeIntXInt2IntMod in
        let primsOfTypeIntXInt2Bool = typeIntXInt2BoolList in
        let primsOfTypeBool2Bool = typeBool2BoolList in
        let checkedIntXInt2Ints = List.map checkintXint2int primsOfTypeIntXInt2Int in
        let checkedIntXInt2IntsDivision = List.map checkintXint2int primsOfTypeIntXInt2IntDivision in
        let checkedIntXInt2IntsMod = List.map checkintXint2int primsOfTypeIntXInt2IntMod in
        let checkedIntXInt2Bools = List.map checkintXint2bool primsOfTypeIntXInt2Bool in
        let checkedBools2Bools = List.map checkbool2bool primsOfTypeBool2Bool in
        checkedIntXInt2Ints @checkedIntXInt2IntsDivision @checkedIntXInt2IntsMod@
        checkedIntXInt2Bools @ checkedBools2Bools 

    let apply f args = f args

    let namerBaby tree =
        let check = makeCheckerImplementations() in
        let environment = makeBasis operatorNames check in
        let rec typeOf tenv ast =
            match ast with
                Id(e1) -> (try let typ = Tenv.find e1 tenv in Some(typ) with
                                Not_found -> None)

                | Const(n, t') -> Some(t')

                | Or(e1, e2) -> (match typeOf tenv e1 with
                                    Some(BoolType) -> (match typeOf tenv e2 with
                                                Some(BoolType) -> Some(BoolType)
                                                | _ -> None)
                                    | _ -> None)

                | And(e1, e2) -> (match typeOf tenv e1 with
                        Some(BoolType) -> (match typeOf tenv e2 with
                                               Some(BoolType) -> Some(BoolType)
                                               | _ -> None)
                        | _ -> None)

                | If(e1, e2, e3) -> (match typeOf tenv e1 with
                        Some(BoolType) -> (match typeOf tenv e2 with
                                            Some(t') -> (match typeOf tenv e3 with
                                                                Some(t'') -> if t' == t''
                                                                                then Some(t')
                                                                                else None
                                                                | _ -> None)
                                            | _ -> None)
                        | _ -> None)

                | Block((e1, t', e2), f1) ->  (match (typeOf tenv e2) with
                                                Some(t'') -> if t' == t''
                                                    then (typeOf (Tenv.add e1 t' tenv) f1)
                                                    else None
                                                | _ -> None)
        | App(id, arguments) ->
            let evaluatedArguments = List.map (typeOf tenv) arguments in
            let primop = Tenv.find id environment in
            apply primop evaluatedArguments

        in typeOf Tenv.empty tree

end