alist patterns

applications/Makefile

@@ -1,4 +1,4 @@
-DIRS=lazy object negative conjunctive n+k combination
+DIRS=lazy object negative conjunctive n+k alist combination
 
 all:
 	@for d in $(DIRS); do (cd $$d && $(MAKE)); done

applications/alist/Makefile

@@ -0,0 +1,4 @@
+SYNTAX_EXTENSION := pa_alist.ml
+TESTS := alist_tests.ml alist_tests_revised.ml
+
+include ../Makefile.application

applications/alist/alist_tests.ml

@@ -0,0 +1,28 @@
+(*pp camlp4of -I ../.. traverse.cmo patterns.cmo pa_alist.cmo *)
+(* Tests for lazy patterns *)
+
+
+let passed = ref true
+
+let test thunk = 
+  try Lazy.force thunk
+  with Assert_failure (msg, line, chr) ->
+    passed := false;
+    Printf.fprintf stderr "Test failed: %d:%d (%s)\n" line chr msg;
+    flush stderr
+
+module Tests (S : sig end) =
+struct
+  let foo = ["foo", 5; "bar", 6; "baz", 7] in
+
+  test
+    (lazy
+       (assert
+          (match foo with
+             | alist [ "bar", x; "foo", y ] ->
+                 x - y = 1)))
+end
+
+let _ =
+  let module T = Tests(struct end) in
+    if !passed then print_endline "alist tests (original syntax) succeeded!"

applications/alist/alist_tests_revised.ml

@@ -0,0 +1,17 @@
+(*pp camlp4rf -I ../.. traverse.cmo patterns.cmo pa_alist.cmo *)
+(* Tests for lazy patterns *)
+value passed = ref True;
+value test thunk =
+  try Lazy.force thunk
+  with
+  [ Assert_failure msg line chr ->
+      (passed.val := False;
+       Printf.fprintf stderr "Test failed: %d:%d (%s)\n" line chr msg;
+       flush stderr) ];
+module Tests (S : sig  end) =
+  struct
+  end;
+(*   object bindings + lazy patterns disallowed (no test)*)
+  let module T = Tests(struct  end)
+  in if passed.val then print_endline "lazy tests (revised syntax) succeeded!" else ();
+

applications/alist/pa_alist.ml

@@ -0,0 +1,35 @@
+(*pp camlp4of -loc loc -I ../.. traverse.cmo patterns.cmo *)
+
+open Camlp4.PreCast.Syntax
+
+EXTEND Gram
+  patt: LEVEL "simple"
+  [LEFTA [
+     (* PaOlbi happens to be a patt node containing a patt and expr, so we use it *)
+     "alist"; "["; l = LIST0 [ e = expr LEVEL "simple"; ","; p = patt LEVEL "simple" -> Ast.PaOlbi (loc, "", p, e) ] SEP ";"; "]" ->
+       <:patt< $uid:"alist"$ $Ast.paSem_of_list l$ >>
+  ]];
+END
+
+object
+  inherit Patterns.extension
+  method translate v = function
+    | <:patt@loc< $uid:"alist"$ $l$ >> ->
+      let l = Ast.list_of_patt l [] in
+      let vs =
+        List.map
+          (function
+             | Ast.PaOlbi (_, _, _, e) ->
+                 <:expr< try Some (List.assoc $e$ $v$) with Not_found -> None >>
+             | _ -> assert false)
+          l in
+      let ps =
+        List.map
+          (function
+             | Ast.PaOlbi (_, _, p, _) ->
+                 <:patt< Some $p$ >>
+             | _ -> assert false)
+          l in
+      Some (<:expr< ($tup:Ast.exCom_of_list vs$) >>, <:patt< ($tup:Ast.paCom_of_list ps$) >>)
+    | _ -> None
+end