alexander.nutz/ocaml-sexpr
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

pc and testing -> seperate files

Browse Source
This commit is contained in:
Alexander Nutz
2025-09-03 13:13:31 +02:00
parent dea16908a6
commit afd552bd09
5 changed files with 552 additions and 437 deletions
Download Patch File Download Diff File Expand all files Collapse all files

442
sexpr.ml
View File

@@ -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 ())