Skip to content
Browse files

alist patterns

  • Loading branch information...
1 parent f5fad75 commit e01ecc22cb1882c329d846bdda09e25cbfa66176 Jake Donham committed Sep 7, 2010
View
2 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
View
4 applications/alist/Makefile
@@ -0,0 +1,4 @@
+SYNTAX_EXTENSION := pa_alist.ml
+TESTS := alist_tests.ml alist_tests_revised.ml
+
+include ../Makefile.application
View
28 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!"
View
17 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 ();
+
View
35 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

0 comments on commit e01ecc2

Please sign in to comment.
Something went wrong with that request. Please try again.