Permalink
Browse files

pa_alist_patt example for syntax extension post

  • Loading branch information...
1 parent d67f2bf commit 6bd34e4535955bacb45219fbe97388235330eb55 Jake Donham committed Sep 7, 2010
View
6 _code/camlp4-syntax-extensions/pa_alist_patt/META
@@ -0,0 +1,6 @@
+name="pa_alist_patt"
+version="0.1"
+description = "Syntax extension for alist patterns"
+requires = "camlp4"
+archive(syntax,preprocessor) = "pa_alist_patt.cmo"
+archive(syntax,toploop) = "pa_alist_patt.cmo"
View
11 _code/camlp4-syntax-extensions/pa_alist_patt/Makefile
@@ -0,0 +1,11 @@
+all:
+ ocamlbuild pa_alist_patt.cmo
+
+install:
+ ocamlfind install pa_alist_patt META _build/pa_alist_patt.cmo
+
+uninstall:
+ ocamlfind remove pa_alist_patt
+
+clean:
+ ocamlbuild -clean
View
1 _code/camlp4-syntax-extensions/pa_alist_patt/_tags
@@ -0,0 +1 @@
+<pa_alist_patt.ml> : syntax_camlp4o,pkg_camlp4.quotations.o,pkg_camlp4.extend
View
86 _code/camlp4-syntax-extensions/pa_alist_patt/myocamlbuild.ml
@@ -0,0 +1,86 @@
+open Ocamlbuild_plugin
+(* open Command -- no longer needed for OCaml >= 3.10.2 *)
+
+(* these functions are not really officially exported *)
+let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
+let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
+
+let split s ch =
+ let x = ref [] in
+ let rec go s =
+ let pos = String.index s ch in
+ x := (String.before s pos)::!x;
+ go (String.after s (pos + 1))
+ in
+ try
+ go s
+ with Not_found -> !x
+
+let split_nl s = split s '\n'
+
+let before_space s =
+ try
+ String.before s (String.index s ' ')
+ with Not_found -> s
+
+(* this lists all supported packages *)
+let find_packages () =
+ List.map before_space (split_nl & run_and_read "ocamlfind list")
+
+(* this is supposed to list available syntaxes, but I don't know how to do it. *)
+let find_syntaxes () = ["camlp4o"; "camlp4r"]
+
+(* ocamlfind command *)
+let ocamlfind x = S[A"ocamlfind"; x]
+
+let _ = dispatch begin function
+ | Before_options ->
+ (* by using Before_options one let command line options have an higher priority *)
+ (* on the contrary using After_options will guarantee to have the higher priority *)
+
+ (* override default commands by ocamlfind ones *)
+ Options.ocamlc := ocamlfind & A"ocamlc";
+ Options.ocamlopt := ocamlfind & A"ocamlopt";
+ Options.ocamldep := ocamlfind & A"ocamldep";
+ Options.ocamldoc := ocamlfind & A"ocamldoc";
+ Options.ocamlmktop := ocamlfind & A"ocamlmktop"
+
+ | After_rules ->
+
+ (* When one link an OCaml library/binary/package, one should use -linkpkg *)
+ flag ["ocaml"; "link"; "program"] & A"-linkpkg";
+
+ (* For each ocamlfind package one inject the -package option when
+ * compiling, computing dependencies, generating documentation and
+ * * linking. *)
+ List.iter begin fun pkg ->
+ flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ end (find_packages ());
+
+ (* Like -package but for extensions syntax. Morover -syntax is useless
+ * when linking. *)
+ List.iter begin fun syntax ->
+ flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+ flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+ flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+ flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+ end (find_syntaxes ());
+
+ (* The default "thread" tag is not compatible with ocamlfind.
+ Indeed, the default rules add the "threads.cma" or "threads.cmxa"
+ options when using this tag. When using the "-linkpkg" option with
+ ocamlfind, this module will then be added twice on the command line.
+
+ To solve this, one approach is to add the "-thread" option when using
+ the "threads" package using the previous plugin.
+ *)
+ flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
+ flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
+ flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
+
+ | _ -> ()
+end
View
110 _code/camlp4-syntax-extensions/pa_alist_patt/pa_alist_patt.ml
@@ -0,0 +1,110 @@
+open Camlp4
+
+module Id : Sig.Id =
+struct
+ let name = "pa_alist_patt"
+ let version = "0.1"
+end
+
+module Make1 (Syntax : Sig.Camlp4Syntax) =
+struct
+ open Sig
+ include Syntax
+
+ EXTEND Gram
+ patt: LEVEL "simple"
+ [LEFTA [
+ "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
+end
+
+module Make2 (AstFilters : Camlp4.Sig.AstFilters) =
+struct
+ open AstFilters (* for Ast module *)
+
+ let fresh =
+ let id = ref 0 in
+ fun () ->
+ incr id;
+ "__pa_alist_patt_" ^ string_of_int !id
+
+ let rewrite _loc p w e =
+ let k = ref (fun s f -> s) in
+ let map =
+ object
+ inherit Ast.map as super
+
+ method patt p =
+ match super#patt p with
+ | <:patt< $uid:"alist"$ $l$ >> ->
+ let id = fresh () in
+ let l =
+ List.map
+ (function
+ | Ast.PaOlbi (_, _, p, e) -> p, e
+ | _ -> assert false)
+ (Ast.list_of_patt l []) in
+ let vs =
+ List.map
+ (fun (_, e) ->
+ <:expr<
+ try Some (List.assoc $e$ $lid:id$)
+ with Not_found -> None
+ >>)
+ l in
+ let ps =
+ List.map
+ (fun (p, _) -> <:patt< Some $p$ >>)
+ l in
+ let vt =
+ match vs with
+ | [] -> <:expr< () >>
+ | [ v ] -> v
+ | _ -> <:expr< $tup:Ast.exCom_of_list vs$ >> in
+ let pt =
+ match ps with
+ | [] -> <:patt< () >>
+ | [ p ] -> p
+ | _ -> <:patt< $tup:Ast.paCom_of_list ps$ >> in
+ let k' = !k in
+ k :=
+ (fun s f ->
+ <:expr<
+ match $vt$ with
+ | $pt$ -> $k' s f$
+ | _ -> $f$
+ >>);
+ <:patt< $lid:id$ >>
+ | p -> p
+ end in
+ let p = map#patt p in
+ let w = match w with <:expr< >> -> <:expr< true >> | _ -> w in
+ let w = !k w <:expr< false >> in
+ let e = !k e <:expr< assert false >> in
+ <:match_case< $p$ when $w$ -> $e$ >>
+
+ let filter =
+ let map =
+ object
+ inherit Ast.map as super
+
+ method match_case mc =
+ match super#match_case mc with
+ | <:match_case@_loc< $p$ when $w$ -> $e$ >> ->
+ rewrite _loc p w e
+ | e -> e
+ end in
+ map#str_item
+
+ let _ = AstFilters.register_str_item_filter filter
+end
+
+module M1 = Register.OCamlSyntaxExtension(Id)(Make1)
+module M2 = Camlp4.Register.AstFilter(Id)(Make2)

0 comments on commit 6bd34e4

Please sign in to comment.