module Testing = struct
  type result = Pass | Fail | Skip

  let testing = ref false
  let test_only = ref []
  let test_results = ref []

  let rec should_skip test =
    match List.assoc_opt test !test_results with
      Some Fail
    | Some Skip -> true
    | _         -> false

  let test name ?(depends = []) run =
    let test_only = !test_only in
    if (test_only = [] && !testing) || List.exists (String.equal name) test_only then begin
      Printf.printf "Test '%s':  " name;
      let res = if List.exists should_skip depends then begin
        Printf.printf "Skip\n%!";
        Skip
      end else begin
        try
          run ();
          Printf.printf "Pass\n%!";
          Pass
        with e ->
          Printf.printf "FAIL\n%!";
          if test_only <> [] then begin
            let msg = Printexc.to_string e
            and stack = Printexc.get_backtrace () in
              Printf.printf "exception thrown: %s%s\n\n%!" msg stack
          end;
          Fail
      end; in
      test_results := (name, res) :: !test_results
    end

  let () =
    let rec proc args =
      begin match args with
        []                  -> ()
      | "--run-tests" :: tl ->
          testing := true;
          proc tl
      | "--run-test" :: test :: tl ->
          testing := false;
          test_only := test :: !test_only;
          proc tl
      | hd :: tl ->
          proc tl
      end
    in proc @@ Array.to_list Sys.argv
end
let test = Testing.test


module PC = struct
  type severity = Style | Warning | Error

  type parse_error = {
    severity: severity;
    pos: int;
    message: string;
    expected: string list option;
    found: string option;
    other_case: parse_error option;
  }

  type src_info = {
    source: string;
    path: string;
  }

  type off2lres = {
    line: int;    (* 0-indexed *)
    col:  int;    (* 0-indexed *)
    lstr: string;
  }

  let num_occ s f =
    let num = ref 0 in
    s |> Seq.iter begin fun x ->
      if f x then
        num := !num + 1
    end;
    !num

  let rec off2l (s:string) (p:int) =
    let e = match String.index_from_opt s p '\n' with
      Some(lb) -> lb
    | None -> String.length s
    in
    match String.rindex_from_opt s p '\n' with
      Some(lb) -> {
        line = num_occ (Seq.take lb (String.to_seq s)) (fun x -> x = '\n');
        col = p - lb;
        lstr = String.sub s (lb + 1) (e - lb - 1) }
    | None -> {
        line = 0;
        col = p;
        lstr = String.sub s 0 e }

  let str_before s c =
    match String.index_opt s c with
      Some(x) -> String.sub s 0 (x - 1)
    | None    -> s

  let limitw len s =
    let s = str_before s '\n' in
    if String.length s > len then
      (String.sub s 0 (len - 3)) ^ "..."
    else s

  let rec pp_err s out e =
    let open Format in
    fprintf out "[%s] @[" begin match e.severity with
      Style   -> "style"
    | Warning -> "warn "
    | Error   -> "error"
    end;
    fprintf out "%s@]\n" e.message;
    let where = off2l s.source e.pos in
    fprintf out "     in @[%s@]\n" s.path;
    fprintf out "     at %i:%i\n\n" where.line where.col;
    fprintf out "%3d: %s\n" where.line where.lstr;
    fprintf out "     ";
    for _ = 0 to where.col - 2 do
      fprintf out " "
    done;
    fprintf out "^\n";
    begin match e.expected with
      Some([]) -> fprintf out "expected: nothing\nbut "
    | Some(li) -> fprintf out "expected: @[%a@]\nbut "
                    (Format.pp_print_list Format.pp_print_text) li
    | None     -> fprintf out "unexpected\n"
    end;
    fprintf out "got '@[";
    begin match e.found with
    | Some(x) -> fprintf out "%s" @@ limitw 22 x
    | None    -> fprintf out "something else"
    end;
    fprintf out "@]'\n";

    begin match e.other_case with
      Some(c) -> begin
        fprintf out "\n  ^^^\n";
        fprintf out "  \\\ === OR tried alternative parser === \\\\\\\n";
        fprintf out "                                         \\/\n\n";
        pp_err s out c
      end
    | None -> () end

  let pp_errli s out e =
    let open Format in
    let first = ref true in
    e |> List.iter begin fun e ->
      if not !first then begin
        fprintf out "\n"
      end;
      first := false;
      pp_err s out e
    end

  type cursor = { source: string; pos: int }
  let head c =
    if String.length c.source > 0 then
      Some(String.get c.source 0)
    else
      None

  let create src = { source = src; pos = 0 }

  let expected c str =
    {
      severity = Error;
      pos = c.pos;
      message  = "";
      expected = Some([str]);
      found    = Some(c.source);
      other_case = None;
    }

  let seek num c =
    { source =
        String.sub c.source num ((String.length c.source) - num);
      pos = c.pos + num }

  type parse_result = {
    cursor: cursor;
    errors: parse_error list
  }

  let merge a b =
    { cursor = b.cursor;
      errors = a.errors @ b.errors }

  let ok c = { cursor = c; errors = [] }
  let put_err err res = { res with errors = res.errors @ [err] }
  let err c e = put_err e (ok c)

  exception Parser_Cant_Recover of parse_result
  exception Parser_No_Progress of cursor

  let single_inline_white c =
    match head c with
      Some(' ')  |
      Some('\b') |
      Some('\t') ->
        ((), ok (seek 1 c))
    | _ -> raise (Parser_Cant_Recover (err c (expected c "inline whitespace")))

  let single_white c =
    match head c with
      Some(' ')  |
      Some('\b') |
      Some('\t') |
      Some('\r') |
      Some('\n') ->
        ((), ok (seek 1 c))
    | _ -> raise (Parser_Cant_Recover (err c (expected c "whitespace")))

  let any c =
    match head c with
      Some(x) -> (x, ok (seek 1 c))
    | None    -> raise (Parser_Cant_Recover (err c (expected c "any")))

  (* at lest 0 times *)
  let rec repeat p c =
    try
      let (v, res) = p c in
      if res.cursor.pos = c.pos then
        raise (Parser_No_Progress c)
      else
        let (v2, res2) = repeat p res.cursor in
        (v :: v2, merge res res2)
    with Parser_Cant_Recover _ ->
      ([], ok c)

  (* at least 1 times *)
  let many p c =
    let (av, ar) = p c in
    let (bv, br) = repeat p (ar.cursor) in
    (av :: bv, merge ar br)

  let rec until endp p c =
    try
      let (_, res) = endp c in
      ([], res)
    with Parser_Cant_Recover _ ->
      let (v, res) = p c in
      if res.cursor.pos = c.pos then
        raise (Parser_No_Progress c)
      else
        let (v2, res2) = until endp p res.cursor in
        (v :: v2, merge res res2)

  let map fn p c =
    let (v, res) = p c in
    ((fn v), res)

  let set v p c =
    let (_, res) = p c in
    (v, res)

  let opt p c =
    try
      map (fun x -> Some(x)) p c
    with Parser_Cant_Recover _ ->
      (None, ok c)

  (* if the given parser succeeds, this parser will fail, and the other way around *)
  let inv p c =
    let fail = (try
      let (_, r) = p c in
      Some(r)
    with Parser_Cant_Recover _ ->
      None) in

    let rec ouch r =
      match r with
        [] -> None
      | head :: tail ->
          let h = (match head.expected with
            Some(x) -> Some( List.map (fun x -> "not " ^ x) x )
          | None -> None
          ) in
          let t = ouch tail in
          match h, t with
            Some(x), Some(y) -> Some(x @ y)
          | Some(x), None    -> Some(x)
          | None,    Some(y) -> Some(y)
          | None,    None    -> None
    in

    match fail with
      Some(r) -> raise (Parser_Cant_Recover (err c {
        severity = Error;
        pos = c.pos;
        message = "inverted parser matched";
        expected = ouch r.errors;
        found = Some(c.source);
        other_case = None
      }))
    | None -> ((), ok c)

  (* requires that both parsers parse successfully at the same loc,
   * but only uses first parser for progressing and returning result.
   * combines warnings / errors from both parsers *)
  let also a b c =
    let (av, ar) = a c in
    let (_, br) = b c in
    (av, merge br ar)

  exception Recursive_Parser_Used_Before_Created

  let recursive (prod:'a->'c-> 'v * 'r) (c:cursor) =
    let future = ref None in
    let par = prod (fun c -> match !future with
      None    -> raise Recursive_Parser_Used_Before_Created
    | Some(p) -> p c) in
    future := Some(par);
    par c

  let just str c =
    if String.starts_with ~prefix:str c.source then
      (str, ok (seek (String.length str) c))
    else
      raise (Parser_Cant_Recover (err c (expected c str)))

  let ex_end c =
    if (String.length c.source) > 0 then
      raise (Parser_Cant_Recover (err c (expected c "end of file")))
    else
      ((), ok c)

  let chain a b c =
    let ar = a c in
    let br = b (snd ar).cursor in
    ((fst ar, fst br), merge (snd ar) (snd br))

  let ignore_then a b c =
    let ar = a c in
    let br = b (snd ar).cursor in
    ((fst br), merge (snd ar) (snd br))

  let then_ignore a b c =
    let ar = a c in
    let br = b (snd ar).cursor in
    ((fst ar), merge (snd ar) (snd br))

  (* only take value of 2nd parser of resulting 3 chained parsers *)
  let nd_of3 a b c =
    then_ignore (ignore_then a b) c

  (* only take values of outer two parsers of resulting 3 chained parsers *)
  let outer_of3 a b c =
    chain (then_ignore a b) c

  let ignore p c =
    let (_, r) = p c in
    ((), r)

  let either a b c =
    try a c
    with Parser_Cant_Recover ar ->
      try b c
      with Parser_Cant_Recover br ->
        raise (Parser_Cant_Recover {
          cursor = ar.cursor;
          errors = [{ (List.hd ar.errors) with
                     other_case = Some(List.hd br.errors) }]
        })

  let match_hd label fn c =
    match head c with
      Some(x) when fn x ->
        (x, ok (seek 1 c))
    | _ -> raise (Parser_Cant_Recover (err c (expected c label)))

  let hd_oneof label li =
    match_hd label (fun x ->
      Seq.exists (fun t->t=x) li)

  let digitch =
    (hd_oneof "digit"
      (String.to_seq "0123456789"))

  let digit =
    map (fun x -> Char.code x - Char.code '0')
      digitch

  let lower =
    hd_oneof "lowercase letter"
      (String.to_seq "abcdefghijklmnopqrstuvwxyz")

  let upper =
    hd_oneof "uppercase letter"
      (String.to_seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ")

  let alpha = either lower upper
  let alnum = either alpha digitch

  let p_int =
    map (fun digits ->
      List.fold_right (fun x acc -> acc*10 + x) (List.rev digits) 0
    ) (many digit)

  let p_flt =
    let fract =
      map (fun digits ->
        List.fold_right 
          (fun x (acc,d) -> (acc +. (Float.of_int x) /. d), d *. 10.0 )
          (List.rev digits)
          (0.0,10.0)
      ) (many digit)
    in outer_of3 p_int (just ".") fract
    |> map (fun (a,(b,_)) -> (Float.of_int a) +. b)

  let doparse f (src:src_info) parsr =
    let (v,r) = try
      let (v,r) = parsr (create src.source) in
      (Some(v), r)
    with Parser_Cant_Recover r ->
      (None, r)
    in
    pp_errli src f r.errors;
    v
end


module SExpr = struct
  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
        (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 = []
end


module SExprMacroExp = struct
  exception Misformated_Macro of SExpr.t
  exception Macro_Doesnt_App
  exception FIXME of SExpr.t

  let assoc_all k li =
    li
    |> List.find_all (fun (x, _) -> x = k)
    |> List.map (fun (_, v) -> v)

  let () = test "SExprMacroExp.assoc_all" @@ begin fun () ->
    let li = [
      "asye","v4";
      "key","v1";
      "notkey","v2";
      "key","v3"
    ] in
    assert (assoc_all "key" li = ["v1";"v3"])
  end

  let rec eval (ctx: (string * (SExpr.t * SExpr.t)) list) s =
    let open SExpr in
    let s, ctx = if is_list s then
      aggr_flat_map eval ctx s
    else
      s, ctx
    in
    check_expands_while ctx s
  (* expr -> list(new exprs) * bool:changed * ctx *)
  and check_expands ctx s =
    let open SExpr in
    match s with
      Cons(Id(":macro"), r) -> begin
        let a = match r with
          Cons(Id(l), Cons(a,b)) -> l, (a,b)
        | _ -> raise @@ Misformated_Macro s
        in
        let ctx = (a :: ctx)
          |> List.sort (fun a b -> macro_req_score (fst (snd b)) - macro_req_score (fst (snd a)))
        in
        Nil, false, ctx
      end
    | Cons(Id(i), r) when String.starts_with ~prefix:":" i ->
        let i = String.sub i 1 ((String.length i) - 1) in
        check_expands_macro i ctx r s
    | Cons(_) ->
        check_expands_macro "@" ctx s s
    | s -> li1 s, false, ctx
  and check_expands_macro i ctx r s =
    let open SExpr in
    let rec test opt ctx =
      begin match opt with
        [] -> li1 s, false, ctx
      | hd :: tl ->
          try
            expand_macro r hd, true, ctx
          with Macro_Doesnt_App ->
            test tl ctx
      end
    in
    test (assoc_all i ctx) ctx
  and check_expands_while ctx s =
    let s', c, ctx' = check_expands ctx s in
    if c then
      SExpr.aggr_flat_map check_expands_while ctx' s'
    else
      s', ctx'
  and match_macro_arg args margs =
    let open SExpr in
    match args, margs with
      Nil,        Nil                               -> []
    | Cons(_),    Cons(Id(".."), Cons(Id(rem),Nil)) -> [rem, args]
    | Cons(v,rl), Cons(Id(k), rr)                   -> [k,li1 v] @ match_macro_arg rl rr
    | _                                             -> raise Macro_Doesnt_App
  and macro_req_score args =
    let open SExpr in
    match args with
      Nil                               -> 0
    | Cons(Id(".."), Cons(Id(rem),Nil)) -> 1
    | Cons(Id _, rr)                    -> 100 + macro_req_score rr
    | _                                 -> raise Not_SExpr_List
  and expand_macro_eval expr defs =
    let open SExpr in
    let perfm expr =
      begin match expr with
        Id(i) when String.starts_with ~prefix:"'" i ->
          li1 @@ Id(String.sub i 1 (String.length i - 1))
      | Id(i) -> begin match List.assoc_opt i defs with
          Some x -> x
        | None   -> li1 expr
        end
      | x when is_list x -> li1 (expand_macro_eval x defs)
      | x -> li1 x
      end
    in
    if is_list expr then
      flat_map perfm expr
    else
      perfm expr
  and expand_macro args macro =
    let (margs, mbody) = macro in
    let defs = match_macro_arg args margs in
    expand_macro_eval mbody defs
  let do_eval s =
    eval [] s
    |> fst

  (* only use this for testing! *)
  let sparse src =
    PC.doparse
      Format.err_formatter
      { source = src; path = "top" }
      (SExpr.parse_top ())
    |> Option.get

  let () = test "SExprMacroExp.do_eval.unchanged_num" @@ begin fun () ->
    let open SExpr in
    let a = Int 1 in
    assert (do_eval a = li1 a)
  end

  let () = test "SExprMacroExp.do_eval.unchanged_list" ~depends:["SExprMacroExp.do_eval.unchanged_num"] @@ begin fun () ->
    let open SExpr in
    let a = Cons(Int 1, Cons(Int 2, Nil)) in
    assert (do_eval a = li1 a)
  end

  let () = test "SExprMacroExp.do_eval.unchanged_nested_list" ~depends:["SExprMacroExp.do_eval.unchanged_list"] @@ begin fun () ->
    let open SExpr in
    let a = Cons(Int 1, Cons( Cons(Int 10, Cons(Int 20, Nil)), Cons(Int 3, Nil))) in
    assert (do_eval a = li1 a)
  end

  let () = test "SExprMacroExp.do_eval.macro_no_body" ~depends:SExpr.parser_tests @@ begin fun () ->
    let open SExpr in
    let a = "(:macro one()) (:one)"
    and p = "()" in
    assert (do_eval (sparse a) = sparse p)
  end

  let () = test "SExprMacroExp.do_eval.macro_body" ~depends:SExpr.parser_tests @@ begin fun () ->
    let open SExpr in
    let a = "(:macro a() 1 2) (:a)"
    and p = "(1 2)" in
    assert (do_eval (sparse a) = sparse p)
  end

  let () = test "SExprMacroExp.do_eval.macro_arg" ~depends:SExpr.parser_tests @@ begin fun () ->
    let open SExpr in
    let a = "(:macro a(arg) 1 arg) (:a 2)"
    and p = "(1 2)" in
    assert (do_eval (sparse a) = sparse p)
  end

  let () = test "SExprMacroExp.do_eval.macro_args" ~depends:SExpr.parser_tests @@ begin fun () ->
    let open SExpr in
    let a = "(:macro a(arg arg2) arg2 1 arg) (:a 2 0)"
    and p = "(0 1 2)" in
    assert (do_eval (sparse a) = sparse p)
  end

  let () = test "SExprMacroExp.do_eval.macro_varargs" ~depends:SExpr.parser_tests @@ begin fun () ->
    let open SExpr in
    let a = "(:macro a(arg .. rem) arg 1 rem) (:a 0 2 3)"
    and p = "(0 1 2 3)" in
    assert (do_eval (sparse a) = sparse p)
  end

  let () = test "SExprMacroExp.do_eval.macro_varargs_notmatch_none" ~depends:SExpr.parser_tests @@ begin fun () ->
    let open SExpr in
    let a = "(:macro a(arg .. rem) arg 1 rem) (:a 0)"
    and p = "((:a 0))" in
    assert (do_eval (sparse a) = sparse p)
  end

  let () = test "SExprMacroExp.do_eval.macro_body_paren" ~depends:SExpr.parser_tests @@ begin fun () ->
    let open SExpr in
    let a = "(:macro a() (1)) (:a)"
    and p = "((1))" in
    assert (do_eval (sparse a) = sparse p)
  end
end


let read_all_stdin () =
  let buf = Buffer.create 4096 in
  try
    while true do
      let line = input_line stdin in
      Buffer.add_string buf line;
      Buffer.add_char buf '\n';
    done;
    Buffer.contents buf
  with End_of_file ->
    Buffer.contents buf


let () =
  let parsr = SExpr.parse_top () in
  let src = read_all_stdin () in
  let v = PC.doparse
    Format.err_formatter
    { source = src; path = "top" }
    parsr in
  let v = Option.get v in
  let v = SExprMacroExp.do_eval v in

  Format.set_margin 40;
  Format.printf "%a@.@?" SExpr.pp_t v;

  exit 0