236 lines
6.3 KiB
OCaml
236 lines
6.3 KiB
OCaml
let test = Testing.test
|
|
|
|
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
|
|
(padded (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 = []
|