(* reader.ml
 * A compiler from Scheme to x86/64
 *
 * Programmer: Mayer Goldberg, 2018
*)

#use "pc.ml";;
open PC;;


exception X_not_yet_implemented;;
exception X_this_should_not_happen;;
type number =
    | Int of int
    | Float of float;;

type sexpr =
    | Bool of bool
    | Nil
    | Number of number
    | Char of char
    | String of string
    | Symbol of string
    | Some of char
    | Pair of sexpr * sexpr
    | Vector of sexpr list;;

let rec sexpr_eq s1 s2 =
  match s1, s2 with
    | Bool(b1), Bool(b2) -> b1 = b2
    | Nil, Nil -> true
    | Number(Float f1), Number(Float f2) -> abs_float(f1 -. f2) < 0.001
    | Number(Int n1), Number(Int n2) -> n1 = n2
    | Char(c1), Char(c2) -> c1 = c2
    | String(s1), String(s2) -> s1 = s2
    | Symbol(s1), Symbol(s2) -> s1 = s2
    | Pair(car1, cdr1), Pair(car2, cdr2) -> (sexpr_eq car1 car2) && (sexpr_eq cdr1 cdr2)
    | Vector(l1), Vector(l2) -> List.for_all2 sexpr_eq l1 l2
    | _ -> false;;


let nt_digit_0_to_9 =
  pack (const (fun ch -> '0' <= ch && ch <= '9'))
    (fun ch -> (int_of_char ch) - 48);;

let nt_natural =
  let rec make_nt_natural () =
    pack (caten nt_digit_0_to_9
            (disj (delayed make_nt_natural)
               nt_epsilon))
      (function (a, s) -> a :: s) in
    pack (make_nt_natural())
      (fun s ->
         (List.fold_left
            (fun a b -> 10 * a + b)
            0
            s));;

let nt_digit_a_to_f =
  pack (const (fun ch -> 'a' <= ch && ch <= 'f'))
    (fun ch -> (int_of_char ch) - 87);;

let nt_digit_A_to_F =
  pack (const (fun ch -> 'A' <= ch && ch <= 'F'))
    (fun ch -> (int_of_char ch) - 55);;

let nt_hex =
  let rec make_nt_hex () =
    pack (caten (disj (disj nt_digit_0_to_9 nt_digit_a_to_f) nt_digit_A_to_F)
            (disj (delayed make_nt_hex)
               nt_epsilon))
      (function (a, s) -> a :: s) in
    pack (pack (caten  (caten (caten (char '#') (char_ci 'x')) (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
      | None -> 1
      | (Some('+')) -> 1
      | (Some('-')) -> -1
      | l -> 8))) (make_nt_hex())) (function (((a,b),c),d) -> List.map (fun (x) -> c*x) d))
      (fun s ->
         (List.fold_left
            (fun a b -> 16 * a + b)
            0
            s));;
let nt_little_float =
  let rec make_nt_natural () =
    pack (caten nt_digit_0_to_9
            (disj (delayed make_nt_natural)
               nt_epsilon))
      (function (a, s) -> a :: s) in
    pack (pack (make_nt_natural()) (fun (x) -> List.map float_of_int x))
      (fun (s) ->
         (List.fold_right
            (fun a b -> b /. 10.  +. a /. 10.)
            s
            0.));;
let nt_hexdigit = disj (disj nt_digit_0_to_9 nt_digit_a_to_f) nt_digit_A_to_F;;
let nt_hex_natural = pack (pack (plus nt_hexdigit) (fun (a) -> List.map float_of_int a)) (fun (s) ->
      (List.fold_right
        (fun a b -> b /. 16.  +. a /. 16.)
        s
        0.));;


let nt_hex_for_float =
  let rec make_nt_hex () =
    pack (caten (disj (disj nt_digit_0_to_9 nt_digit_a_to_f) nt_digit_A_to_F)
            (disj (delayed make_nt_hex)
                nt_epsilon))
      (function (a, s) -> a :: s) in
    pack (make_nt_hex())
      (fun s ->
          (List.fold_left
            (fun a b -> 16 * a + b)
            0
            s));;

let nt_hexfloat =
  pack (caten (caten (caten  (caten (caten (char '#') (char_ci 'x')) (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
              | None -> 1.
              | (Some('+')) -> 1.
              | (Some('-')) -> -1.
              | l -> 8.))) (pack nt_hex_for_float  (fun (a) ->  float_of_int a))) (char '.')) nt_hex_natural) (fun (((((a,b),c),d),e),f) -> c*.(d+.f));;


let nt_float =
  let rec make_nt_natural () =
    pack (caten nt_digit_0_to_9
            (disj (delayed make_nt_natural)
               nt_epsilon))
      (function (a, s) -> a :: s) in
    pack (pack (caten (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
          | None -> 1.
          | (Some('+')) -> 1.
          | (Some('-')) -> -1.
          | l -> 8.)) (caten (pack (make_nt_natural()) (fun (x) -> List.map float_of_int x)) (char '.'))) (nt_little_float)) (fun ((a,(b,c)),d) -> ((List.map (fun (x) -> a*.x) b),a*.d)))
      (fun (s,d) ->
         (List.fold_left
            (fun a b -> 10. *. a +. b)
            0.
            s)+.d);;



let nt_plusminusinteger num =
  let m= disj (caten (char '-')   (pack nt_natural (fun s -> -1*s))) (caten  (pack (maybe (char '+')) (fun l -> match l with
      | None -> '+'
      | (Some('+')) -> '+'
      | l -> 'f' )) nt_natural) num in
    (fun ((e,s),c) -> (s,c)) m;;

let nt_integer num =
  nt_plusminusinteger num;;

let nt_scientific_int =  pack (caten (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
            | None -> '0'
            | (Some('+')) -> '0'
            | (Some('-')) -> '-'
            | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b)) (pack (caten (char_ci 'e') (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
            | None -> '0'
            | (Some('+')) -> '0'
            | (Some('-')) -> '-'
            | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b))) (fun (a,b) -> List.append (a::[]) b)))
                           (fun (a,b) -> float_of_string (list_to_string (List.append a b)));;

let nt_scientific_float =  pack (caten (pack (caten (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
                  | None -> '0'
                  | (Some('+')) -> '0'
                  | (Some('-')) -> '-'
                  | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b)) (pack (caten (char '.') (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b))) (fun (a,b) -> List.append a b)) (pack (caten (char_ci 'e') (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
                                            | None -> '0'
                                            | (Some('+')) -> '0'
                                            | (Some('-')) -> '-'
                                            | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b) )) (fun (a,b) -> List.append (a::[]) b)))
                             (fun (a,b) -> float_of_string (list_to_string (List.append a b)));;

let nt_charprefix = (word "#\\");;
let nt_visiblechar = const (fun ch -> (int_of_char ch)>32 && (int_of_char ch)<=127);;
let nt_namedchar = disj_list [(pack (word_ci "newline") (fun (a) -> '\010'));(pack (word_ci "page") (fun (a) -> '\012'));(pack (word_ci "space") (fun (a) -> ' '));(pack (word_ci "nul") (fun (a) -> '\000'));(pack (word_ci "return") (fun (a) -> '\013'));(pack (word_ci "tab") (fun (a) -> '\009'))];;
let nt_hexchar = pack (caten (char_ci 'x') (plus nt_hexdigit)) (fun (d,c) -> char_of_int
          (List.fold_left
            (fun a b -> 16 * a + b)
            0
            c));;



let nt_stringlitteralchar = pack (diff nt_any (one_of "\\\"")) (fun (a) -> a::[]);;

let nt_string_meta_f = pack (word "\\f") (fun _ -> '\012'::[]);;
let nt_string_meta_bkslsh = pack (word "\\\\") (fun _ -> '\\'::[]);;
let nt_string_meta_quote = pack (word "\\\"") (fun _ -> '\"'::[]);;
let nt_string_meta_t = pack (word "\\t") (fun _ -> '\t'::[]);;
let nt_string_meta_n = pack (word "\\n") (fun _ -> '\n'::[]);;
let nt_string_meta_r = pack (word "\\r") (fun _ -> '\r'::[]);;

let nt_stringmetachar = disj_list [nt_string_meta_f ; nt_string_meta_bkslsh ; nt_string_meta_quote ; nt_string_meta_t ; nt_string_meta_n ; nt_string_meta_r];;
let nt_stringhexchar = pack (caten (caten (word_ci "\\x") (pack (plus nt_hexdigit)
      (fun (c) -> (char_of_int
                    (List.fold_left
                        (fun a b -> 16 * a + b)
                        0
                        c))))) (char ';')) (fun ((a,b),c) -> b::[]);;

let nt_string_char = disj_list [nt_stringmetachar;nt_stringlitteralchar;nt_stringhexchar];;

let nt_symbolchar = disj_list [(range '0' '9');(range_ci 'a' 'z'); (const (fun ch -> ch=='!' ||ch=='$' ||ch=='^' ||ch=='*' ||ch=='-' ||ch=='_' ||ch=='=' ||ch=='+' ||ch=='<' ||ch=='>' ||ch=='?' ||ch=='/' ||ch==':' ))];;
let which_quote x = match x with
  | "\'" -> "quote"
  | "`" -> "quasiquote"
  | "," -> "unquote"
  | ",@" -> "unquote-splicing"
  | x -> "no"


let nt_symbol = pack (plus nt_symbolchar) (fun (a) -> ( list_to_string (List.map lowercase_ascii a)));;
let nt_string = pack (caten (caten (char '\"') (star nt_string_char)) (char '\"')) (fun ((a,b),c) -> list_to_string (List.flatten b));;
let nt_number = disj (pack (disj_list [nt_scientific_int;nt_scientific_float;nt_float;nt_hexfloat]) (fun (a) -> Float(a))) (pack (disj nt_plusminusinteger nt_hex) (fun (a) -> Int(a)));;
let nt_char = pack (caten nt_charprefix (disj_list [nt_hexchar;nt_namedchar;nt_visiblechar])) (fun (a,b) -> b);;
(*let nt_char = not_followed_by (nt_char) (disj_list [nt_symbol]);;*)

(* line comment impl *)
let nt_smcol = char ';';;
let nt_nwln = char '\n';;
let nt_end_inp = pack nt_end_of_input (fun _ -> ' ');;

let nt_notend = const (fun ch -> ch != '\n');;
let nt_skip = pack (star nt_notend) (fun l -> ' ');;
let nt_line_comm = pack (caten_list [nt_smcol;nt_skip;(disj nt_nwln nt_end_inp)]) (fun a -> ' ');;

(* let nt_comment = pack nt_line_comm (fun _ -> Nil);;*) (* disj sexpr_comment *)

(* Parsers without spaces from right & left   AND   sexp conversion *)
let _whitespaces_ = star (disj nt_whitespace nt_line_comm);;
let nts_symbol = pack (caten (caten _whitespaces_ nt_symbol) _whitespaces_) (fun ((l,p),r) -> Symbol p);;
let nts_string = pack (caten (caten _whitespaces_ nt_string) _whitespaces_) (fun ((l,p),r) -> String p);;
let nts_char = pack (caten (caten _whitespaces_ nt_char) _whitespaces_) (fun ((l,p),r) -> Char p);;
let nts_number = pack (caten (caten _whitespaces_ nt_number) _whitespaces_)  (fun ((l,p),r) -> Number p);;

let nt_bool =
  let istrue = pack (word_ci "#t") (fun _ -> Bool true) in
  let isfalse = pack (word_ci "#f") (fun _ -> Bool false) in
    not_followed_by (disj istrue isfalse) (disj_list [nts_symbol;nts_string]);;
let nts_bool = pack (caten (caten _whitespaces_ nt_bool) _whitespaces_)  (fun ((l,p),r) -> p);;

let lp = char '(';;
let rp = char ')';;
let lbp = char '[';;
let rbp = char ']';;
(* sexprs disjoint impl *)
let rec nts_sexpr = fun a -> (disj_list [nts_vector;nts_dot_list;nts_list;nts_bracket;(*nt_sexpr_comment;nt_comment;*)nts_bool;nts_nil;nts_quote;nts_number;nts_symbol;nts_string;nts_char]) a
and nts_sexprs = fun a -> (star nts_sexpr) a
(*and nt_comment = fun a -> (disj nt_line_comm nt_sexpr_comment) a *)

and shortened_sexpr s =
  let x = star (const (fun ch -> ch > ' ')) in
  let x = caten x nts_sexpr in
  x s
and nt_sexpr_comment s =
  let x = pack (caten (word "#;") shortened_sexpr) (fun (a,b) -> Nil) in
  x s
and nt_dot_list s =
  let nt_dotted_list = (caten (plus nts_sexpr) (caten (char '.') nts_sexpr)) in
  let nt_dotted_list = pack (caten (caten lp nt_dotted_list) rp) (fun ((l,p),r) -> p) in
  let nt_dotted_list = pack nt_dotted_list (fun (l,(c,r)) -> List.fold_right (fun a b -> Pair(a,b)) l r) in
    nt_dotted_list s
and nts_dot_list = fun b -> (pack (caten (caten _whitespaces_ nt_dot_list) _whitespaces_) (fun ((l,p),r) -> p)) b
and nt_list s =
  let x = pack (caten (caten lp (star nts_sexpr)) rp) (fun ((l,p),r) -> p) in
  let x = pack x (fun l -> List.fold_right (fun a b -> Pair(a,b)) l Nil) in
    x s
and nts_list = fun b -> (pack (caten (caten _whitespaces_ nt_list) _whitespaces_) (fun ((l,p),r) -> p)) b
and nt_bracket s =
  let x = pack (caten (caten lbp (star nts_sexpr)) rbp) (fun ((l,p),r) -> p) in
  let x = pack x (fun l -> List.fold_right (fun a b -> Pair(a,b)) l Nil) in
    x s
and nts_bracket = fun b -> (pack (caten (caten _whitespaces_ nt_bracket) _whitespaces_) (fun ((l,p),r) -> p)) b
and nt_vector s =
  let x = pack (caten (caten lp (star nts_sexpr)) rp) (fun ((l,p),r) -> p) in
  let x = pack (caten (char '#') x) (fun (a, l) -> Vector l) in
    x s
and nts_vector = fun c -> (pack (caten (caten _whitespaces_ nt_vector) _whitespaces_) (fun ((l,p),r) -> p)) c
and nts_nil = fun d -> (pack (caten (caten lp _whitespaces_) rp) (fun _ -> Nil)) d
and nts_quote = fun a -> (pack (caten (disj_list [(word "\'");(word "`");(word ",@");(word ",")]) (nts_sexpr))
                            (fun (a,b) -> Pair(Symbol((which_quote (list_to_string a))), Pair(b,Nil)))) a;;


let pack_final nt s =
  let (e, s) = (nt s) in
    e;;

module Reader: sig
  val read_sexpr : string -> sexpr
  val read_sexprs : string -> sexpr list
end

= struct
  let normalize_scheme_symbol str =
    let s = string_to_list str in
      if (andmap
            (fun ch -> (ch = (lowercase_ascii ch)))
            s) then str
      else Printf.sprintf "|%s|" str;;



  let read_sexpr string =
    pack_final nts_sexpr (string_to_list string);;

  let read_sexprs string = pack_final nts_sexprs (string_to_list string);;
end;; (* struct Reader *)