#use "reader.ml";;

type constant =
  | Sexpr of sexpr
  | Void

type expr =
  | Const of constant
  | Var of string
  | If of expr * expr * expr
  | Seq of expr list
  | Set of expr * expr
  | Def of expr * expr
  | Or of expr list
  | LambdaSimple of string list * expr
  | LambdaOpt of string list * string * expr
  | Applic of expr * (expr list);;

let rec expr_eq e1 e2 =
  match e1, e2 with
  | Const Void, Const Void -> true
  | Const(Sexpr s1), Const(Sexpr s2) -> sexpr_eq s1 s2
  | Var(v1), Var(v2) -> String.equal v1 v2
  | If(t1, th1, el1), If(t2, th2, el2) -> (expr_eq t1 t2) &&
                                            (expr_eq th1 th2) &&
                                              (expr_eq el1 el2)
  | (Seq(l1), Seq(l2)
    | Or(l1), Or(l2)) -> List.for_all2 expr_eq l1 l2
  | (Set(var1, val1), Set(var2, val2)
    | Def(var1, val1), Def(var2, val2)) -> (expr_eq var1 var2) &&
                                             (expr_eq val1 val2)
  | LambdaSimple(vars1, body1), LambdaSimple(vars2, body2) ->
     (List.for_all2 String.equal vars1 vars2) &&
       (expr_eq body1 body2)
  | LambdaOpt(vars1, var1, body1), LambdaOpt(vars2, var2, body2) ->
     (String.equal var1 var2) &&
       (List.for_all2 String.equal vars1 vars2) &&
         (expr_eq body1 body2)
  | Applic(e1, args1), Applic(e2, args2) ->
     (expr_eq e1 e2) &&
       (List.for_all2 expr_eq args1 args2)
  | _ -> false;;


exception X_syntax_error;;

module type TAG_PARSER = sig
  val tag_parse_expression : sexpr -> expr
  val tag_parse_expressions : sexpr list -> expr list
end;; (* signature TAG_PARSER *)

module Tag_Parser : TAG_PARSER = struct

let reserved_word_list =
  ["and"; "begin"; "cond"; "define"; "else";
   "if"; "lambda"; "let"; "let*"; "letrec"; "or";
   "quasiquote"; "quote"; "set!"; "unquote";
   "unquote-splicing"];;

(* work on the tag parser starts here *)
let rec pairsToList=(function
| Pair(Symbol(x),y) -> x::(pairsToList y)
| Nil -> [];
| _ -> raise X_no_match
);;

let rec pairsToListDotted=(function
| Pair(Symbol(x),y) -> x::(pairsToListDotted y)
| Symbol(x) -> [];
| _ -> raise X_no_match
);;
let rec lastOneInListDotted=(function
| Pair(Symbol(x),y) -> lastOneInListDotted y
| Symbol(x) -> x;
| _ -> raise X_no_match
);;
let rec hasLastOneInListDotted=(function
| Pair(Symbol(x),y) -> hasLastOneInListDotted y
| Symbol(x) -> true
| _ -> false
);;

(* let lastElementInList =function  *)

let rec tag_parse s= (function
| Number(x) -> Const(Sexpr(Number(x)))
| Bool(x) -> Const(Sexpr(Bool(x)))
| Char(x) -> Const(Sexpr(Char(x)))
| String(x) -> Const(Sexpr(String(x)))
| TagRef(x) -> Const(Sexpr(TagRef(x)))
| TaggedSexpr(name, Pair(x,Pair(y, Nil))) -> Const(Sexpr(TaggedSexpr (name, y)))
| Pair(Symbol("if"), Pair(test, Pair(dit, Pair(dif, Nil))))-> If(tag_parse test, tag_parse dit, tag_parse dif)
| Pair(Symbol("if"), Pair(test, Pair(dit, Nil)))-> If(tag_parse test, tag_parse dit, Const(Void))
| Pair(Symbol("quote"), Pair(x, Nil)) -> Const(Sexpr(x))
| Pair(Symbol("lambda"), Pair(Symbol(arg), Pair(body,Nil)))-> LambdaOpt([], arg, tag_parse body)
| Pair(Symbol("lambda"), Pair(Symbol(arg), body))-> LambdaOpt([], arg, tag_parse (Pair(Symbol "begin", body)))
| Pair(Symbol("lambda"), Pair(args, Pair(body,Nil)))-> if(hasLastOneInListDotted args)
                                                            then LambdaOpt(pairsToListDotted args, lastOneInListDotted args, tag_parse body)
                                                            else LambdaSimple(pairsToList args, tag_parse body)
| Pair(Symbol("lambda"), Pair(args, body))-> if(hasLastOneInListDotted args)
                                                            then LambdaOpt(pairsToListDotted args, lastOneInListDotted args, tag_parse (Pair(Symbol "begin", body)))
                                                            else LambdaSimple(pairsToList args, tag_parse (Pair(Symbol "begin", body)))
| Pair(Symbol("define"), Pair(Pair(Symbol(name), args), body))-> Def (Var(name),tag_parse (Pair(Symbol("lambda"), Pair(args, body))))
| Pair(Symbol("define"), Pair(Symbol(name), Pair(body, Nil)))-> Def (Var(name),tag_parse body)
| Pair(Symbol("set!"), Pair(Symbol(name), Pair(body, Nil)))-> Set (Var(name),tag_parse body)
| Pair(Symbol("begin"), Nil)-> Const(Void)
| Pair(Symbol("begin"), Pair(name,Nil))-> tag_parse name
| Pair(Symbol("begin"), args)-> Seq(taggedList args)
| Pair(Symbol("or"), Nil)-> Const(Sexpr(Bool(false)))
| Pair(Symbol("or"), Pair(arg,Nil))-> tag_parse arg
| Pair(Symbol("or"), args)-> Or(taggedList args)
| Pair(Symbol("cond"), Pair(rib1, ribs))-> tag_parse(condMaker (rib1,ribs))
| Pair(Symbol("let"), Pair(args, Pair(body,Nil)))-> tag_parse (Pair(Pair(Symbol "lambda", Pair(leftSideLet args, body)), rightSideLet args))
| Pair(Symbol("let*"), Pair(Nil, body))-> tag_parse (Pair(Symbol("let"), Pair(Nil, Pair(body,Nil))))
| Pair(Symbol("let*"), Pair(Pair(arg,Nil) , Pair(body,Nil))) -> tag_parse (Pair(Symbol("let"), Pair(Pair(arg,Nil), Pair(body,Nil))))
| Pair(Symbol("let*"), Pair(Pair(arg,args), body)) ->  tag_parse (Pair(Symbol "let",Pair(Pair(arg,Nil),Pair(Pair(Symbol "let*",Pair (args,Pair(body,Nil))),Nil))))
| Pair(Symbol("and"), Nil)-> Const(Sexpr(Bool(true)))
| Pair(Symbol("and"), Pair(arg,Nil))-> tag_parse arg
| Pair(Symbol("and"), Pair(arg,args))-> If(tag_parse arg, tag_parse(Pair (Symbol("and"),args)), Const(Sexpr(Bool(false))))
(* | Pair(Symbol("letrec"), Pair(args, Pair(body,Nil)))-> tag_parse (Pair(Symbol("let"),Pair(letrecLeft (leftSideLet args), setMaker(leftSideLet args,rightSideLetrec args,body)))) *)
| Pair(Symbol("quasiquote"), Pair(arg,Nil))-> tag_parse(quasiMaker(arg))


(* (Tag_Parser. tag_parse_expression (Pair (Symbol "lambda",Pair (Pair (Symbol "x", Pair (Symbol "y", Nil)),Pair (Pair (Symbol "+", Pair (Symbol "x", Pair (Symbol "y", Nil))),Pair (Pair (Symbol "*", Pair (Symbol "x", Pair (Symbol "y", Nil))), Nil)))))); *)
| Pair(x,y) -> Applic((tag_parse x),taggedList y)
| Symbol(x) -> Var(x)
| _ -> raise X_no_match
) s
and taggedList s=(function
| Pair(x,y) -> (tag_parse x)::(taggedList y)
| Nil -> [];
| _ -> raise X_no_match
) s

and quasiMaker s = (function
| Pair(Symbol "unquote",Pair(arg, Nil)) -> arg
| Pair(Symbol "unquote-splicing",Pair(arg, Nil)) -> raise X_no_match
| Pair(Pair(Symbol "unquote-splicing",arg), args) -> Pair(Symbol "append",Pair(Pair(Symbol "begin", arg), Pair(quasiMaker args,Nil)))
| Pair(arg, Pair(Symbol "unquote-splicing",args)) -> Pair(Symbol "cons",Pair(quasiMaker arg, args))
| Pair(arg,args) ->Pair(Symbol "cons",Pair(quasiMaker arg, Pair(quasiMaker args,Nil)))
| Nil -> Pair(Symbol "quote", Pair(Nil,Nil))
| (Symbol arg) -> Pair(Symbol "quote", Pair(Symbol arg,Nil))
| arg -> arg
) s
and condMaker s= (function
| (Pair(value,Pair(Symbol("=>"),body)),Pair(rest1,rest2)) ->
  Pair (Symbol "let",Pair(
  Pair (Pair (Symbol "value", Pair(value,Nil)),
    Pair(Pair (Symbol "f",Pair (Pair (Symbol "lambda", Pair (Nil,body)),Nil)),
     Pair(Pair (Symbol "rest",Pair(Pair (Symbol "lambda", Pair(Nil, Pair(condMaker(rest1,rest2),Nil))), Nil)),Nil))),
  Pair (Symbol "if",Pair (Symbol "value",Pair (Pair (Pair (Symbol "f", Nil), Pair (Symbol "value", Nil)),Pair (Pair (Symbol "rest", Nil), Nil))))))

| (Pair(value,Pair(Symbol("=>"),body)),Nil) ->
(Pair (Symbol "let",Pair(
Pair (Pair (Symbol "value",Pair (value, Nil)),
Pair(Pair (Symbol "f", Pair(Pair(Symbol "lambda", Pair (Nil, body)), Nil)),Nil)),
Pair (Symbol "if",Pair (Symbol "value",Pair (Pair (Pair (Symbol "f", Nil), Pair(Symbol "value", Nil)), Nil))))))
| (Pair(Symbol "else",body),rest)-> Pair(Symbol "begin",body)
| (Pair(test,body),Pair(rest1,rest2)) -> Pair(Symbol("if"), Pair(test, Pair(Pair(Symbol "begin",body), Pair(condMaker (rest1,rest2), Nil))))
| (Pair(test,body),Nil) -> Pair(Symbol("if"), Pair(test, Pair(Pair(Symbol "begin",body), Nil)))
| _ -> raise X_no_match
) s
and leftSideLet s=(function
| Nil -> Nil
| Pair(Pair(x,y),Nil) -> Pair(x, Nil)
| Pair(Pair(x,y),z) -> Pair(x, (leftSideLet z))
| _ -> raise X_no_match
) s
and rightSideLet s=(function
| Nil -> Nil
| Pair(Pair(x,y),Nil) -> y
| Pair(Pair(x,y),z) -> Pair(y ,(rightSideLet z))
| _ -> raise X_no_match
)s
and rightSideLetrec s=(function
| Pair(Pair(x,Pair(y,Nil)),Nil) -> [y]
| Pair(Pair(x,Pair(y,Nil)),z) -> y:: (rightSideLetrec z)
| _ -> raise X_no_match
)s
and letrecLeft s =(function
| [] -> Nil
| a :: b -> Pair (Pair(Symbol a, Pair(Symbol "'whatever",Nil)), letrecLeft b)
)s
and setMaker s =(function
| ([],[],body) -> Pair(Pair(Symbol("let"), Pair(Nil, body)),Nil)
| (a :: b,c::d,body) -> Pair (Pair (Symbol "set!", Pair (Symbol a, Pair (c, Nil))), setMaker (b,d,body))
| _ -> Nil
)s
;;

let tag_parse_expression sexpr = tag_parse sexpr;;

let tag_parse_expressions sexpr = List.map tag_parse_expression sexpr;;


end;; (* struct Tag_Parser *)


(* Pair (Symbol "cond", Pair(Pair (Symbol "t",Pair (Number (Int 1), Pair (Number (Int 2), Pair (Number (Int 3), Nil)))),Nil)) *)

(* Pair (Symbol "cond",Pair(Pair (Symbol "t",Pair(Pair (Number (Int 1), Pair (Number (Int 2), Pair (Number (Int 3), Nil))),Nil)),Nil)) *)
(* Pair (Symbol "cond", Pair(Pair (Symbol "t",Pair (Pair (Number (Int 1), Nil), Pair (Pair (Number (Int 2), Nil), Pair (Pair (Number (Int 3), Nil), Nil)))),Nil)) *)

(* Pair (Symbol "cond", Pair (Pair (Bool true, Pair (Number (Int 1), Pair (Number (Int 2), Pair (Number (Int 3), Nil)))),Nil)) *)

let rec is_proper_list sexpr =
match sexpr with
| Pair(a,Nil) -> true
| Pair(a,b) -> is_proper_list b
| _-> raise X_syntax_error

and pair_to_string sexpr =
  let rec proper_list list =
    match list with
    | Pair(a,Nil) -> sexpr_to_string_literal a
    | Pair(a,b) -> (sexpr_to_string_literal a)^" "^(proper_list b) in
    let rec improper_list list =
      match list with
      | Pair(a,b) -> " "^(sexpr_to_string_literal a)^(proper_list b)
      | _-> " . "^(sexpr_to_string_literal list) in
    if(is_proper_list sexpr) then "("^(proper_list sexpr)^")"
    else "("^(improper_list sexpr)^")"

and sexpr_to_string_literal sexpr =
  match sexpr with
| Bool(b) -> string_of_bool b
| Number(Int(n)) -> string_of_int n
| Number(Float(f)) -> string_of_float f
| Nil -> "()"
| Char(c) -> list_to_string [c]
| String(s) -> s
| Symbol(s) -> s
| Pair(a,b) -> pair_to_string sexpr
| TaggedSexpr(a,b) -> "#{"^a^"}="^sexpr_to_string_literal b
| TagRef(s) -> s;;