From afd552bd097219743fd56d6b0bc0bdc5a5718e7f Mon Sep 17 00:00:00 2001 From: alex-s168 Date: Wed, 3 Sep 2025 13:13:31 +0200 Subject: [PATCH] pc and testing -> seperate files --- pc.ml | 407 +++++++++++++++++++++++++++++++++++++++++++++++ pc.mli | 85 ++++++++++ sexpr.ml | 442 +--------------------------------------------------- testing.ml | 51 ++++++ testing.mli | 4 + 5 files changed, 552 insertions(+), 437 deletions(-) create mode 100644 pc.ml create mode 100644 pc.mli create mode 100644 testing.ml create mode 100644 testing.mli diff --git a/pc.ml b/pc.ml new file mode 100644 index 0000000..43f7129 --- /dev/null +++ b/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 +;; diff --git a/pc.mli b/pc.mli new file mode 100644 index 0000000..57d07de --- /dev/null +++ b/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 diff --git a/sexpr.ml b/sexpr.ml index bb4dddc..f9a804d 100644 --- a/sexpr.ml +++ b/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 open PC in + 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 @@ -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 ()) diff --git a/testing.ml b/testing.ml new file mode 100644 index 0000000..de6b257 --- /dev/null +++ b/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;; diff --git a/testing.mli b/testing.mli new file mode 100644 index 0000000..6832ae8 --- /dev/null +++ b/testing.mli @@ -0,0 +1,4 @@ +val test : string + -> ?depends:(string list) + -> (unit -> unit) + -> unit;;