Browse files

code for implementation quotations post

  • Loading branch information...
1 parent 1796d3a commit b8a4128d56b7ff0f85e01befb1116da0ea57ff67 Jake Donham committed Jul 31, 2010
View
7 _code/camlp4-implementing-quotations/META
@@ -0,0 +1,7 @@
+name = "json_quot"
+version = "0.1"
+description = "JSON quotations"
+archive(byte) = "json_quot.cma"
+archive(native) = "json_quot.cmxa"
+archive(syntax,toploop) = "json_quot.cma,jq_top.cmo"
+archive(syntax,preprocessor) = "json_quot.cma"
View
20 _code/camlp4-implementing-quotations/Makefile
@@ -0,0 +1,20 @@
+FILES=\
+json_quot.cma \
+jq_ast.mli jq_ast.cmi \
+jq_parser.mli jq_parser.cmi \
+jq_printer.mli jq_printer.cmi \
+jq_top.cmo
+
+BFILES=$(addprefix _build/,$(FILES))
+
+all:
+ ocamlbuild json_quot.cma jq_top.cmo
+
+install:
+ ocamlfind install json_quot META $(BFILES)
+
+uninstall:
+ ocamlfind remove json_quot
+
+clean:
+ ocamlbuild -clean
View
3 _code/camlp4-implementing-quotations/_tags
@@ -0,0 +1,3 @@
+<jq_parser.ml*>: syntax_camlp4o,pkg_camlp4.extend
+<jq_quotations.ml*>: syntax_camlp4o,pkg_camlp4.quotations,pkg_camlp4.extend
+<jq_ast.ml*>: syntax_camlp4o,pkg_camlp4.quotations,pkg_camlp4.metagenerator
View
28 _code/camlp4-implementing-quotations/jq_ast.ml
@@ -0,0 +1,28 @@
+module Jq_ast =
+struct
+ type float' = float
+
+ type t =
+ | Jq_null
+ | Jq_bool of bool
+ | Jq_number of float'
+ | Jq_string of string
+ | Jq_array of t list
+ | Jq_object of (string * t) list
+end
+
+include Jq_ast
+
+open Camlp4.PreCast (* for Ast refs in generated code *)
+
+module MetaExpr =
+struct
+ let meta_float' _loc f = <:expr< $`flo:f$ >>
+ include Camlp4Filters.MetaGeneratorExpr(Jq_ast)
+end
+
+module MetaPatt =
+struct
+ let meta_float' _loc f = <:patt< $`flo:f$ >>
+ include Camlp4Filters.MetaGeneratorPatt(Jq_ast)
+end
View
19 _code/camlp4-implementing-quotations/jq_ast.mli
@@ -0,0 +1,19 @@
+open Camlp4.PreCast
+
+type t =
+ | Jq_null
+ | Jq_bool of bool
+ | Jq_number of float
+ | Jq_string of string
+ | Jq_array of t list
+ | Jq_object of (string * t) list
+
+module MetaExpr :
+sig
+ val meta_t : Ast.loc -> t -> Ast.expr
+end
+
+module MetaPatt :
+sig
+ val meta_t : Ast.loc -> t -> Ast.patt
+end
View
25 _code/camlp4-implementing-quotations/jq_parser.ml
@@ -0,0 +1,25 @@
+open Camlp4.PreCast
+open Jq_ast
+
+module Gram = MakeGram(Lexer)
+let json = Gram.Entry.mk "json"
+
+;;
+
+EXTEND Gram
+ json: [[
+ "null" -> Jq_null
+ | "true" -> Jq_bool true
+ | "false" -> Jq_bool false
+ | i = INT -> Jq_number (float_of_string i)
+ | f = FLOAT -> Jq_number (float_of_string f)
+ | s = STRING -> Jq_string s
+ | "["; es = LIST0 json SEP ","; "]" -> Jq_array es
+ | "{";
+ kvs =
+ LIST0
+ [ s = STRING; ":"; j = json -> (s, j) ]
+ SEP ",";
+ "}" -> Jq_object kvs
+ ]];
+END
View
5 _code/camlp4-implementing-quotations/jq_parser.mli
@@ -0,0 +1,5 @@
+module Gram : Camlp4.Sig.Grammar.Static
+ with module Loc = Camlp4.PreCast.Loc
+ and module Token = Camlp4.PreCast.Token
+
+val json : Jq_ast.t Gram.Entry.t
View
17 _code/camlp4-implementing-quotations/jq_printer.ml
@@ -0,0 +1,17 @@
+open Format
+open Jq_ast
+
+let rec list f ppf = function
+ | [] -> ()
+ | [ e ] -> f ppf e
+ | e :: es -> fprintf ppf "%a,@;<1 2>" f e; list f ppf es
+
+let rec t ppf = function
+ | Jq_null -> fprintf ppf "null"
+ | Jq_bool b -> fprintf ppf "%B" b
+ | Jq_number n -> fprintf ppf "%g" n
+ | Jq_string s -> fprintf ppf "%S" s
+ | Jq_array ts -> fprintf ppf "@[<hv>[@;<1 2>%a@ ]@]" (list t) ts
+ | Jq_object ts -> fprintf ppf "@[<hv>{@;<1 2>%a@ }@]" (list kv) ts
+
+and kv ppf (k, v) = fprintf ppf "@[<h>%S@ :@ %a@]" k t v
View
1 _code/camlp4-implementing-quotations/jq_printer.mli
@@ -0,0 +1 @@
+val t : Format.formatter -> Jq_ast.t -> unit
View
29 _code/camlp4-implementing-quotations/jq_quotations.ml
@@ -0,0 +1,29 @@
+open Camlp4.PreCast
+
+module Q = Syntax.Quotation
+
+let json_eoi = Jq_parser.Gram.Entry.mk "json_eoi"
+
+EXTEND Jq_parser.Gram
+ json_eoi: [[ x = Jq_parser.json; EOI -> x ]];
+END;;
+
+let parse_quot_string loc s =
+ Jq_parser.Gram.parse_string json_eoi loc s
+
+let expand_expr loc _ s =
+ Jq_ast.MetaExpr.meta_t loc (parse_quot_string loc s)
+
+let expand_str_item loc _ s =
+ let exp_ast = expand_expr loc None s in
+ <:str_item@loc< $exp:exp_ast$ >>
+
+let expand_patt loc _ s =
+ Jq_ast.MetaPatt.meta_t loc (parse_quot_string loc s)
+
+;;
+
+Q.add "json" Q.DynAst.expr_tag expand_expr;
+Q.add "json" Q.DynAst.patt_tag expand_patt;
+Q.add "json" Q.DynAst.str_item_tag expand_str_item;
+Q.default := "json"
View
9 _code/camlp4-implementing-quotations/jq_top.ml
@@ -0,0 +1,9 @@
+(* following Ocamlnet's netstring_top.ml *)
+
+let exec s =
+ let l = Lexing.from_string s in
+ let ph = !Toploop.parse_toplevel_phrase l in
+ assert(Toploop.execute_phrase false Format.err_formatter ph)
+;;
+
+exec "#install_printer Jq_printer.t;;";;
View
4 _code/camlp4-implementing-quotations/json_quot.mllib
@@ -0,0 +1,4 @@
+Jq_ast
+Jq_parser
+Jq_printer
+Jq_quotations
View
67 _code/camlp4-implementing-quotations/myocamlbuild.ml
@@ -0,0 +1,67 @@
+open Ocamlbuild_plugin
+open Command
+open Ocamlbuild_pack.Ocaml_compiler
+open Ocamlbuild_pack.Ocaml_utils
+open Ocamlbuild_pack.Tools
+
+;;
+
+(* ocamlfind integration following http://www.nabble.com/forum/ViewPost.jtp?post=15979274 *)
+
+(* 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
+
+(* this lists all supported packages *)
+let find_packages () =
+ blank_sep_strings &
+ Lexing.from_string &
+ run_and_read "ocamlfind list | cut -d' ' -f1"
+
+(* 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]
+
+;;
+
+dispatch begin function
+ | Before_options ->
+
+ (* 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";
+
+ | After_rules ->
+
+ flag ["ocaml"; "compile"; "dtypes"] & A"-dtypes";
+
+ (* When one link an OCaml library/binary/package, one should use -linkpkg *)
+ flag ["ocaml"; "byte"; "link"] & A"-linkpkg";
+ flag ["ocaml"; "native"; "link"] & 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];
+ 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];
+ end (find_syntaxes ());
+
+ | _ -> ()
+end
+
+;;

0 comments on commit b8a4128

Please sign in to comment.