942 lines
26 KiB
OCaml
942 lines
26 KiB
OCaml
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
|
|
| 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 Not_Valid_Macro_Arg_Syntax
|
|
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 aggr_eval ctx s = begin
|
|
let s, (ch,ctx) = aggr_flat_map (fun aggr s ->
|
|
let ch1, ctx = aggr in
|
|
let s, ch2, ctx = eval ctx s in
|
|
s, ((ch1 || ch2), ctx)
|
|
) (false, ctx) s in
|
|
s, ch, ctx
|
|
end in
|
|
let s, ch1, ctx = match s with
|
|
Cons(Id ":macro", Cons(name, Cons(margs, rr))) ->
|
|
let rr, ch, ctx = aggr_eval ctx rr in
|
|
Cons(Id ":macro", Cons(name, Cons(margs, rr))), ch, ctx
|
|
| s when is_list s -> begin
|
|
aggr_eval ctx s
|
|
end
|
|
| _ ->
|
|
s, false, ctx
|
|
in
|
|
let s, ch2, ctx = check_expands ctx s in
|
|
s, (ch1 || ch2), ctx
|
|
(* 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 ":atm-to-str", Cons(Id x, Nil))
|
|
| Cons(Id ":atm-to-str", Cons(Str x, Nil)) ->
|
|
li1 (Str x), true, ctx
|
|
| Cons(Id ":atm-to-str", Cons(Int x, Nil)) ->
|
|
li1 (Str (Int.to_string x)), true, ctx
|
|
| Cons(Id ":atm-to-str", Cons(Flt x, Nil)) ->
|
|
li1 (Str (Float.to_string x)), true, ctx
|
|
| Cons(Id ":str-cat", Cons(Str l, Cons(Str r, Nil))) ->
|
|
li1 (Str (l ^ r)), true, ctx
|
|
| Cons(Id ":unpack", Cons(x, Nil)) when is_list x ->
|
|
x, true, ctx
|
|
| Cons(Id ":c-eq", Cons(l, Cons(r, Nil))) when l = r ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-li0-eq", Cons( Cons(l, _) , Cons( r , Nil))) when l = r ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-int", Cons(Int _, Nil)) ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-float", Cons(Flt _, Nil)) ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-num", Cons(Int _, Nil))
|
|
| Cons(Id ":c-num", Cons(Flt _, Nil)) ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-str", Cons(Str _, Nil)) ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-id", Cons(Id _, Nil)) ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-colon-id", Cons(Id x, Nil)) when String.contains x ':' ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-list", Cons(x, Nil)) when is_list x ->
|
|
Nil, true, ctx
|
|
| Cons(Id ":c-atm", Cons(Int _, Nil))
|
|
| Cons(Id ":c-atm", Cons(Flt _, Nil))
|
|
| Cons(Id ":c-atm", Cons(Str _, Nil))
|
|
| Cons(Id ":c-atm", Cons(Id _, Nil)) ->
|
|
Nil, true, ctx
|
|
| 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 ctx, true, ctx
|
|
with Macro_Doesnt_App ->
|
|
test tl ctx
|
|
end
|
|
in
|
|
test (assoc_all i ctx) ctx
|
|
and match_macro_arg args margs ctx =
|
|
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 ctx
|
|
| Cons(v,rl), Cons(Cons(Id k, Cons(cst, Nil)), rr) ->
|
|
let cst_exp = expand_macro_eval cst ["_", li1 v] in
|
|
let cst_exp, _ = eval_while ctx cst_exp in
|
|
if cst_exp <> Nil then
|
|
raise Macro_Doesnt_App;
|
|
[k, li1 v] @ match_macro_arg rl rr ctx
|
|
| _ -> 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
|
|
| Cons(Cons(Id _, Cons(_,Nil)), rr) -> 110 + macro_req_score rr
|
|
| _ -> raise Not_Valid_Macro_Arg_Syntax
|
|
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 ctx =
|
|
let margs, mbody = macro in
|
|
let defs = match_macro_arg args margs ctx in
|
|
expand_macro_eval mbody defs
|
|
and eval_while ctx s = begin
|
|
let s, ch, ctx = eval ctx s in
|
|
if ch then
|
|
SExpr.aggr_flat_map eval_while ctx s
|
|
else
|
|
s, ctx
|
|
end
|
|
and eval_root_while ctx s = begin
|
|
let s, ch, ctx = eval ctx s in
|
|
if ch then
|
|
SExpr.aggr_flat_map eval_root_while ctx s
|
|
else
|
|
s, ctx
|
|
end
|
|
|
|
let do_eval s =
|
|
eval_root_while [] s |> fst
|
|
|
|
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 src = read_all_stdin () in
|
|
let v = SExprMacroExp.sparse src in
|
|
let v = SExprMacroExp.do_eval v in
|
|
|
|
Format.set_margin 40;
|
|
Format.printf "%a@.@?" SExpr.pp_t v;
|
|
|
|
exit 0
|