[Do not merge yet] A test about untyped lambda calculus. Regression demo (stack overflow)

dune-project

@@ -1,2 +1,5 @@
-(lang dune 1.8)
+(lang dune 2.7)
+
+(cram enable)
+
 (name angstrom)

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   ");
+

lib_test/ULC.t

@@ -0,0 +1,2 @@
+  $ ./ULC.exe
+  (a a)

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 %{<})))
+  (run %{<})))
+
+(cram
+ (deps ./ULC.exe ./test_angstrom.exe))