let test = Testing.test

type t =
  Nil
| Int  of int
| Flt  of float
| Cons of t * t
| Id   of string
| Str  of string

let li1 s =
  Cons(s, Nil)

exception Not_SExpr_List

let rec append tl hd =
  match hd with
    Nil          -> tl
  | Cons(x, rem) -> Cons(x, append tl rem)
  | _            -> raise Not_SExpr_List

let () = test "SExpr.append" @@ begin fun () ->
  let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil)))
  and b = Cons(Int 4, Cons(Int 5, Nil))
  and ab = Cons(Int 1, Cons(Int 2, Cons(Int 3, Cons(Int 4, Cons(Int 5, Nil))))) in
  assert (append b a = ab)
end

let rec rem_nil x =
  match x with
    Cons(x, Nil) -> rem_nil x
  | Cons(l, r)   -> Cons(l, rem_nil r)
  | x            -> x

let () = test "SExpr.rem_nil" @@ begin fun () ->
  let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil)))
  and p = Cons(Int 1, Cons(Int 2, Int 3)) in
  assert (rem_nil a = p)
end

let rec flat_map fn li =
  match li with
    Nil          -> Nil
  | Cons(x, rem) -> append (flat_map fn rem) (fn x)
  | _            -> raise Not_SExpr_List

let () = test "SExpr.flat_map.0" @@ begin fun () ->
  let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil)))
  and p = Nil in
  assert (flat_map (fun _ -> Nil) a = p)
end

let () = test "SExpr.flat_map.1" @@ begin fun () ->
  let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil)))
  and p = Cons(Int 2, Cons(Int 3, Cons(Int 4, Nil))) in
  assert (flat_map (fun x -> Cons((match x with Int(n) -> Int(n + 1) | x -> x) , Nil)) a = p)
end

let () = test "SExpr.flat_map.2" @@ begin fun () ->
  let a = Cons(Int 1, Cons(Int 2, Nil))
  and p = Cons(Int 1, Cons(Int 2, Cons(Int 2, Cons(Int 3, Nil)))) in
  assert (flat_map (fun x -> Cons(x, Cons((match x with Int(n) -> Int(n + 1) | x -> x) , Nil))) a = p)
end

let rec aggr_flat_map fn acc li =
  match li with
    Nil          -> Nil, acc
  | Cons(x, rem) ->
      let x, acc = fn acc x in
      let vv, acc = aggr_flat_map fn acc rem in
      append vv x, acc
  | _  -> raise Not_SExpr_List

let () = test "SExpr.aggr_flat_map.0" @@ begin fun () ->
  let a = Cons(Int 1, Cons(Int 2, Nil))
  and p = Cons(Int 1, Cons(Int 2, Cons(Int 2, Cons(Int 4, Nil)))) in
  assert (fst (aggr_flat_map (fun aggr x -> Cons(x, Cons((match x with Int(n) -> Int(n + aggr) | x -> x) , Nil)) , aggr + 1) 1 a) = p)
end

(* a "list" here is: 
 *   ( e1 . ( e2 . ( e3 . NIL ) ) )
 * or even just:
 *   NIL
 *)
let rec is_list s =
  match  s with
    Nil       -> true
  | Cons(a,b) -> is_list b
  | _         -> false

let needs_surround_pipes x =
     String.contains x ' '
  || String.contains x '\n'
  || String.contains x '\r'
  || String.contains x '\t'
  || String.contains x '\b'

let rec pp_t out (s:t) =
  let open Format in
  match s with
    Flt x -> fprintf out "%f" x
  | Int x -> fprintf out "%d" x
  | Str x ->
      fprintf out "\"";
      x |> String.iter begin fun x ->
        match x with
          '\\' -> fprintf out "\\\\"
        | '\r' -> fprintf out "\\r"
        | '\b' -> fprintf out "\\b"
        | '\n' -> fprintf out "\\n"
        | '\t' -> fprintf out "\\t"
        |  _   -> fprintf out "%c"  x
      end;
      fprintf out "\""
  | Id  x ->
      if needs_surround_pipes x then
        fprintf out "|%s|" x
      else
        fprintf out "%s" x
  | Nil -> fprintf out "()"
  | Cons(a,b) ->
      if is_list b then begin
        fprintf out "@[(@[";
        pp_closed out s
      end else begin
        fprintf out "@[(@[";
        pp_t out a;
        fprintf out "@ . ";
        pp_t out b;
        fprintf out "@[)@["
      end
and pp_closed out (s:t) =
  let open Format in
  match s with
    Flt x -> fprintf out "%f" x
  | Int x -> fprintf out "%d" x
  | Str x -> fprintf out "\"%s\"" x
  | Id  x ->
      if needs_surround_pipes x then
        fprintf out "|%s|" x
      else
        fprintf out "%s" x
  | Nil -> fprintf out "@])@]"
  | Cons(a,b) ->
      pp_t out a;
      (match b with
        Nil -> ()
      | _   -> fprintf out "@ ");
      pp_closed out b

let parse_inline () : Pc.cursor -> t * Pc.parse_result =
  let open Pc in
  let comment = chain (just ";") (repeat (also any (inv (just "\n")))) in
  let pad = either (ignore single_white) (ignore comment) in
  let pad = repeat pad in
  let padded p = (then_ignore (ignore_then pad p) pad) in
  recursive (fun expr ->
    let x_cons = nd_of3
         (just "(")
         begin
             chain expr (
                ignore_then
                  (just ".")
                  expr
                |> many)
         |> map (fun (head,tail) ->
             let li = List.rev (head :: tail) in
             let init = List.hd li in
             let others = List.rev(List.tl li) in
             List.fold_right (fun x acc -> Cons(x,acc)) others init)
         end
         (just ")")
    in
    let x_list = (nd_of3
      (padded (just "("))
      (repeat expr
      |> map (fun li ->
        List.fold_right (fun x acc -> Cons(x,acc)) li Nil))
      (just ")"))
    in
    let id_char = also any (inv begin
      (*-->> *) (ignore (just ";"))
      |> either (ignore single_white)
      |> either (ignore (just "("))
      |> either (ignore (just ")"))
      |> either (ignore (just "NIL"))
      |> either (ignore (just "|"))
      |> either (ignore (just "\""))
    end) in
    let escape = begin
      (*-->> *) also any (just "\"" |> inv)
      |> either (just "\\\\" |> set '\\')
      |> either (just "\\r"  |> set '\r')
      |> either (just "\\t"  |> set '\t')
      |> either (just "\\b"  |> set '\b')
      |> either (just "\\n"  |> set '\n')
    end in
        (* === expr === *)
    (*-->> *) (just "NIL" |> set Nil)
    |> either x_cons
    |> either x_list
    |> either (id_char |> many |> map
         (fun s -> Id(s |> List.to_seq |> String.of_seq )))
    |> either (nd_of3
         (just "|")
         begin also any (inv (just "|"))
            |> repeat
            |> map (fun s ->
              Id(s |> List.to_seq |> String.of_seq ))
         end
         (just "|")
       )
    |> either (p_int |> map (fun v -> Int(v)))
    |> either (p_flt |> map (fun v -> Flt(v)))
    |> either (nd_of3
         (just "\"")
         (escape
          |> repeat
          |> map (fun v -> Str(v |> List.to_seq |> String.of_seq)))
         (just "\""))
    |> padded
  )

let parse_inline_end () =
  let open Pc in
  then_ignore (parse_inline ()) ex_end

let parse_top () =
  let open Pc in
  parse_inline ()
    |> until ex_end
    |> map (fun li ->
        List.fold_right (fun x acc -> Cons(x,acc)) li Nil)

let parser_tests = []