[SOLVED] CS open Types

open Types

exception ImplementMe

type token = TRUE
| FALSE
| NUM of int
| FUN
| VAR of string
| ARROW
| LET
| EQUAL
| IN
| IF
| THEN
| ELSE
| APP
| TO
| PLUS
| MINUS
| TIMES
| DIV
| LT
| GT
| LE
| GE
| EQOP
| AND
| OR

type loc = int * int (* line, column *)
type tl = token * loc

let token_of_string s =
match s with
| true -> TRUE
| false -> FALSE
| fun -> FUN
| -> -> ARROW
| let -> LET
| = -> EQUAL
| in -> IN
| if -> IF
| then -> THEN
| else -> ELSE
| app -> APP
| to -> TO
| (+) -> PLUS
| (-) -> MINUS
| (*) -> TIMES
| (/) -> DIV
| (<)” -> LT
| (>) -> GT
| (<=)” -> LE
| (>=) -> GE
| (=) -> EQOP
| (&&) -> AND
| (||) -> OR
| _ ->
(match int_of_string_opt s with
| Some n -> NUM n
| None -> VAR s)

let string_of_token =
function TRUE -> true
| FALSE -> false
| NUM n -> string_of_int n
| FUN -> fun
| VAR x -> x
| ARROW -> ->
| LET -> let
| EQUAL -> =
| IN -> in
| IF -> if
| THEN -> then
| ELSE -> else
| APP -> app
| TO -> to
| PLUS -> (+)
| MINUS -> (-)
| TIMES -> (*)
| DIV -> (/)
| LT -> (<)” | GT -> (>)
| LE -> (<=)” | GE -> (>=)
| EQOP -> (=)
| AND -> (&&)
| OR -> (||)

let implode l = String.init (List.length l) (List.nth l)

let is_ws c = match c with
| | t |
-> true
| _ -> false

let rec lex chars curr stream (currline, currcol) lastloc =
let curr_token curr =
if List.length curr > 0 then
(* We have a nonempty token *)
Some (token_of_string (implode (List.rev curr)), lastloc)
else
None
in
match chars with
| [] -> (match curr_token curr with
| Some t -> List.rev (t::stream)
| None -> List.rev stream)
| []::lines ->
(* Whitespace ends tokens *)
(match curr_token curr with
| Some tok ->
lex lines [] (tok::stream) (currline + 1, 0) (currline + 1, 0)
| None -> lex lines [] stream (currline + 1, 0) (currline + 1, 0))
| (c::t)::lines ->
let chars = t::lines in
if is_ws c then
(* Whitespace ends tokens *)
(match curr_token curr with
| Some tok ->
lex chars [] (tok::stream) (currline, currcol + 1)
(currline, currcol + 1)
| None -> lex chars [] stream (currline, currcol + 1)
(currline, currcol + 1))
else
lex chars (c::curr) stream (currline, currcol + 1) lastloc
;;

exception SyntaxError of loc option * string

let is_op (t: token) : bool =
match t with
| PLUS | MINUS | TIMES | DIV | LT | GT | LE | GE | EQOP | AND | OR -> true
| _ -> false

(*>* Problem 2.6 *>*)
let is_const (t: token) : bool =
raise ImplementMe

let is_first_val (t: token) : bool =
raise ImplementMe

let parse_const (tokens : tl list) : const * tl list =
match tokens with
| [] -> raise (SyntaxError (None, expected constant))
| (TRUE, _)::t -> (True, t)
| (FALSE, _)::t -> (False, t)
| (NUM n, _)::t -> (Int n, t)
| (_, l)::t -> raise (SyntaxError (Some l, expected constant))

(*>* Problem 2.7 *>*)
let parse_var (tokens : tl list) : var * tl list =
raise ImplementMe

let parse_op (tokens : tl list) : op * tl list =
let op_of_token (t, l) =
match t with
| PLUS -> Plus | MINUS -> Minus | TIMES -> Times | DIV -> Div | LT -> Lt
| GT -> Gt | LE -> Le | GE -> Ge | EQOP -> Eq | AND -> And | OR -> Or
| _ -> raise (SyntaxError (Some l, expected operator))
in
raise ImplementMe

(*>* Problem 2.8 *>*)
let parse_exact (t: token) (tokens: tl list) : tl list =
raise ImplementMe

(*>* Problem 2.9 *>*)
let rec parse_value (tokens : tl list) : value * tl list =
match tokens with
| [] -> raise (SyntaxError (None, expected value))
| (FUN, _)::t -> let (v, t) = parse_var t in
let t = parse_exact ARROW t in
let (e, t) = parse_exp t in
(Fun (v, e), t)
| (h, l)::t ->
(if is_op h then raise ImplementMe
else if is_const h then raise ImplementMe
else raise (SyntaxError (Some l, expected value))
)

and parse_exp (tokens : tl list) : exp * tl list =
raise ImplementMe

let rec explode n s =
if n >= String.length s then
[]
else
(String.get s n)::(explode (n + 1) s)

let parse (s: string list) : exp =
match parse_exp (lex (List.map (explode 0) s) [] [] (1, 0) (1, 0)) with
| (e, []) -> e
| _ -> raise (SyntaxError (None, expected EOF))

let string_of_file f =
let ic = open_in f in
let rec read_it l =
try read_it ((input_line ic)::l)
with End_of_file -> List.rev l
in
let s = read_it [] in
let _ = close_in ic in
s

let parse_file f =
parse (string_of_file f)

let _ = assert (parse [let f = fun x -> app x to x in app f to f] =
Let (f, Value (Fun (x, App (Var x, Var x))),
App (Var f, Var f)))