pc and testing -> seperate files

pc.ml

@@ -0,0 +1,407 @@
+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 cursor = { source: string; pos: int }
+
+type parse_result = {
+  cursor: cursor;
+  errors: parse_error list
+}
+
+type 'a parsr = cursor -> 'a * parse_result
+
+type off2lres = {
+  line: int;    (** 0-indexed *)
+  col:  int;    (** 0-indexed *)
+  lstr: string;
+};;
+
+exception Parser_Cant_Recover of parse_result
+exception Parser_No_Progress of cursor
+
+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:src_info) out (e:parse_error) =
+  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
+;;
+
+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 };;
+
+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)
+;;
+
+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")))
+;;
+
+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)
+;;
+
+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)
+;;
+
+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)
+;;
+
+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))
+;;
+
+let nd_of3 a b c =
+  then_ignore (ignore_then a b) c;;
+
+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 sign c =
+  match head c with
+    Some '+' -> ( 1, ok (seek 1 c))
+  | Some '-' -> (-1, ok (seek 1 c))
+  | _        -> ( 1, ok (seek 1 c))
+;;
+
+let p_uint =
+  map (fun digits ->
+    List.fold_right (fun x acc -> acc*10 + x) (List.rev digits) 0
+  ) (many digit)
+;;
+
+let p_int =
+  chain sign p_uint
+  |> map (fun (sign,d) -> sign * d)
+;;
+
+let p_uflt =
+  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 p_flt =
+  chain sign p_uflt
+  |> map (fun (sign,d) -> Float.of_int sign *. d)
+;;
+
+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
+;;

pc.mli

@@ -0,0 +1,85 @@
+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 cursor = { source: string; pos: int }
+
+type parse_result = {
+  cursor: cursor;
+  errors: parse_error list
+}
+
+val pp_err   : src_info -> Format.formatter -> parse_error -> unit
+val pp_errli : src_info -> Format.formatter -> parse_error list -> unit
+
+val create : string -> cursor
+
+exception Parser_Cant_Recover of parse_result
+exception Parser_No_Progress of cursor
+
+type 'a parsr = cursor -> 'a * parse_result
+
+val single_inline_white : unit parsr
+val single_white        : unit parsr
+val any     : char parsr
+val just    : string -> string parsr
+val ex_end  : unit parsr
+val digitch : char parsr
+val digit   : int  parsr
+val lower   : char parsr
+val upper   : char parsr
+val alpha   : char parsr
+val alnum   : char parsr
+val sign    : int  parsr   (** '+'->1, '-'->-1, _->1 *)
+val p_uint  : int  parsr
+val p_int   : int  parsr
+val p_uflt  : float parsr
+val p_flt   : float parsr
+
+
+val repeat : 'a parsr -> 'a list parsr (** at lest 0 times *)
+val many   : 'a parsr -> 'a list parsr (** at least 1 times *)
+
+
+(** repeat 'x parsr, as long as 'e parsr fails *)
+val until : 'e parsr -> 'x parsr -> 'x list parsr
+
+val opt : 'x parsr -> 'x option parsr
+
+val map : ('i -> 'o) -> 'i parsr -> 'o parsr
+val set : 'o -> 'i parsr -> 'o parsr
+
+
+(** if the given parser succeeds, this parser will fail, val the other way around *)
+val inv : 'x parsr -> unit parsr
+
+(** requires that both parsers parse successfully at the same loc,
+    but only uses first parser for progressing val returning result.
+    combines warnings / errors from both parsers *)
+val also : 'a parsr -> 'b parsr -> 'a parsr
+
+exception Recursive_Parser_Used_Before_Created
+val recursive : ('v parsr -> 'v parsr) -> 'v parsr
+
+val chain       : 'a parsr -> 'b parsr -> ('a * 'b) parsr
+val ignore_then : 'a parsr -> 'b parsr -> 'b parsr
+val then_ignore : 'a parsr -> 'b parsr -> 'a parsr
+val nd_of3      : 'a parsr -> 'b parsr -> 'c parsr -> 'b parsr
+val outer_of3   : 'a parsr -> 'b parsr -> 'c parsr -> ('a * 'c) parsr
+val ignore      : 'a parsr -> unit parsr
+val either      : 'a parsr -> 'a parsr -> 'a parsr
+
+
+val doparse : Format.formatter -> src_info -> 'a parsr -> 'a option

sexpr.ml

@@ -1,437 +1,5 @@
-module type Testing = sig
-  val test : string -> ?depends:(string list) -> (unit -> unit) -> unit;;
-end;;
-
-module Testing : 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
@@ -581,8 +149,8 @@ module SExpr = struct
         | _   -> fprintf out "@ ");
         pp_closed out b
 
-  let parse_inline () : PC.cursor -> t * PC.parse_result =
+  let parse_inline () : Pc.cursor -> t * Pc.parse_result =
-    let open PC in
+    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
@@ -655,11 +223,11 @@ module SExpr = struct
     )
 
   let parse_inline_end () =
-    let open PC in
+    let open Pc in
     then_ignore (parse_inline ()) ex_end
 
   let parse_top () =
-    let open PC in
+    let open Pc in
     parse_inline ()
       |> until ex_end
       |> map (fun li ->
@@ -848,7 +416,7 @@ module SExprMacroExp = struct
     eval_root_while [] s |> fst
 
   let sparse src =
-    PC.doparse
+    Pc.doparse
       Format.err_formatter
       { source = src; path = "top" }
       (SExpr.parse_top ())

testing.ml

@@ -0,0 +1,51 @@
+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;;

testing.mli

@@ -0,0 +1,4 @@
+val test :  string
+         -> ?depends:(string list)
+         -> (unit -> unit)
+         -> unit;;