diff --git a/dune-project b/dune-project index 5bfddd0..9581dfa 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,5 @@ -(lang dune 1.8) +(lang dune 2.7) + +(cram enable) + (name angstrom) diff --git a/lib_test/ULC.ml b/lib_test/ULC.ml new file mode 100644 index 0000000..f7e53a7 --- /dev/null +++ b/lib_test/ULC.ml @@ -0,0 +1,62 @@ + +open Angstrom + +module Lam = struct + type t = Var of char | App of t * t | Abs of char * t + [@@deriving show { with_path = false }] + + let var x = Var x + let abs x l = Abs (x, l) + let app l r = App (l, r) + + let rec pp ppf = + let open Format in + function + | Var c -> fprintf ppf "%c" c + | App (l, r) -> + fprintf ppf "(%a %a)" pp l pp r + | Abs (x, b) -> fprintf ppf "(\\%c . %a)" x pp b + +end + +let is_space = function ' ' | '\t' -> true | _ -> false +let spaces = skip_while is_space +let varname = satisfy (function 'a' .. 'z' -> true | _ -> false) + +let conde = function + | [] -> fail "empty conde" + | h :: tl -> List.fold_left ( <|> ) h tl + +type dispatch = { + apps : dispatch -> Lam.t Angstrom.t; + single : dispatch -> Lam.t Angstrom.t; +} + +let parse_lam = + let single pack = + fix (fun _ -> + conde + [ + char '(' *> pack.apps pack <* char ')'; + ( (string "λ" <|> string "\\") *> spaces *> varname + <* spaces <* char '.' + >>= fun var -> + pack.apps pack >>= fun b -> return (Lam.Abs (var, b)) ); + (varname <* spaces >>= fun c -> return (Lam.Var c)); + ]) + in + let apps pack = + many1 (spaces *> pack.single pack <* spaces) >>= function + | [] -> fail "bad syntax" + | x :: xs -> return @@ List.fold_left (fun l r -> Lam.App (l, r)) x xs + in + { single; apps } + +let parse_optimistically str = + Result.get_ok + @@ Angstrom.parse_string (parse_lam.apps parse_lam) str + ~consume:Angstrom.Consume.All + +let _ = + Format.printf "%a%!\n" Lam.pp (parse_optimistically "a a "); + \ No newline at end of file diff --git a/lib_test/ULC.t b/lib_test/ULC.t new file mode 100644 index 0000000..6c2ed4f --- /dev/null +++ b/lib_test/ULC.t @@ -0,0 +1,2 @@ + $ ./ULC.exe + (a a) diff --git a/lib_test/dune b/lib_test/dune index 6e00fe3..5180922 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -6,7 +6,8 @@ (preprocess (per_module (future_syntax test_let_syntax_native) - ((pps ppx_let) test_let_syntax_ppx)))) + ((pps ppx_let) + test_let_syntax_ppx)))) (executables (libraries alcotest angstrom angstrom_test) @@ -18,10 +19,18 @@ (modules test_json) (names test_json)) -(alias - (name runtest) +(executables + (libraries angstrom) + (modules ULC) + (names ULC)) + +(rule + (alias runtest) (package angstrom) (deps (:< test_angstrom.exe)) (action - (run %{<}))) \ No newline at end of file + (run %{<}))) + +(cram + (deps ./ULC.exe ./test_angstrom.exe))