random hacking (#617)

* some support for using Frenetic in the OCaml toplevel (make utop)
* better ppx syntax extension: now support [%nk "code"] and [%nk {| code |}] syntax
* better ppx tests based on jane streets inline tests (make updatetests will update regression tests)
* filter keyword for embedding predicates into policies is now optional

Makefile

@@ -3,7 +3,7 @@ INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
 build:
 	time -p jbuilder build @install
 
-install:
+install: build
 	jbuilder install $(INSTALL_ARGS)
 
 uninstall:
@@ -18,8 +18,14 @@ doc:
 	jbuilder build @doc
 
 test:
-	jbuilder build @runtest
+	jbuilder runtest
+
+updatetest:
+	jbuilder runtest --auto-promote
 
 all: build test doc
 
-.PHONY: build install uninstall reinstall clean doc test all
+utop: install
+	utop-full -short-paths -init ocamlinit
+
+.PHONY: build install uninstall reinstall clean doc test all utop updatetest

frenetic.opam

@@ -28,6 +28,7 @@ depends: [
   "menhir"
   "mparser"
   "ocamlgraph" {>= "1.8.7"}
+  "open"
   "ppxlib"
   "ppx_compare"
   "ppx_cstruct"

ocamlinit

@@ -0,0 +1,23 @@
+(******************************************************************************
+ Custom ocamlinit to make experimenting with Frenetic in the OCaml 
+ toplevel/REPL a joy.
+
+ Simply run `make utop`, or, if you prefer doing things by hand, run
+ ```
+   {ocaml/utop-full} -init ocamlinit
+ ```
+*******************************************************************************)
+
+(* load Frenetic, including syntax extension *)
+#use "topfind"
+#require "frenetic"
+#require "frenetic.ppx"
+open Frenetic;;
+
+(* install some pretty printers *)
+#install_printer Netkat.Pretty.format_policy
+#install_printer Netkat.Pretty.format_pred
+let print_auto fmt x = Netkat.Global_compiler.Automaton.render x;;
+let print_fdd fmt x = Netkat.Local_compiler.FDD.render x;;
+#install_printer print_auto
+#install_printer print_fdd

src/lib/jbuild

@@ -9,4 +9,4 @@
      frenetic.async
      frenetic.kernel)
   )
-))
+))

src/lib/kernel/Util.ml

@@ -45,35 +45,6 @@ let map_snd lst ~f =
   List.map lst ~f:(fun (x,y) -> (x, f y))
 
 
-(*===========================================================================*)
-(* open files with default application                                       *)
-(*===========================================================================*)
-
-type os =
-  | MacOS
-  | Linux
-
-let detect_os () : os =
-  let open Caml in
-  let ic = Unix.open_process_in "uname" in
-  let uname = input_line ic in
-  close_in ic;
-  match uname with
-  | "Darwin" -> MacOS
-  | "Linux" -> Linux
-  | _ -> failwith "unknown operating system"
-
-let open_cmd =
-  match detect_os () with
-  | MacOS -> "open"
-  | Linux -> "xdg-open"
-
-let open_file f =
-  let silence = "&> /dev/null" in
-  Format.sprintf "%s %s % s" open_cmd f silence
-  |> Caml.Unix.system
-  |> ignore
-
 (*===========================================================================*)
 (* Graphviz                                                                  *)
 (*===========================================================================*)
@@ -88,7 +59,8 @@ let compile_dot ?(format="pdf") ?(engine="dot") ?(title=engine) data : string =
 
 let show_dot ?format ?title ?engine data : unit =
   compile_dot ?format ?title ?engine data
-  |> open_file
+  |> Open.in_default_app
+  |> ignore
 
 let show_dot_file ?format ?title ?engine file : unit =
   In_channel.read_all file

src/lib/kernel/Util.mli

@@ -11,10 +11,6 @@ val pp_exceptions : unit -> unit
 val map_fst : ('a * 'b) list -> f:('a -> 'c) -> ('c * 'b) list
 val map_snd : ('a * 'b) list -> f:( 'b -> 'c) -> ('a * 'c) list
 
-(** Opens file with associated default application.
-    This uses `open` on MacOS and `xdg-open` on Linux. *)
-val open_file : string -> unit
-
 (* Compiles provided dot-string using `graphviz` and dumps the output into a
    temporary file. The temporary file is returned.
    Requires graphviz to be installed and on the PATH.

src/lib/kernel/jbuild

@@ -9,6 +9,7 @@
      base64
      cstruct
      ocamlgraph
+     open
      tcpip
      yojson
      ipaddr

src/lib/netkat/Parser.cppo.mly

@@ -68,6 +68,8 @@ open Core
 #endif
 
 (* precedence and associativity - from lowest to highest *)
+%nonassoc low
+%nonassoc RPAR END
 %nonassoc IN (* let meta := 1 in p + q == let meta := 1 in (p + q) *)
 %left PLUS
 %left SEMICOLON
@@ -104,7 +106,15 @@ pol:
       PPX( id )
   | DUP
       BOTH( Dup )
-  | FILTER; a=pred
+  | a=pred
+      AST( Filter a )
+      PPX( Filter [%e a] )
+      %prec low /* make predicates as big as possible */
+
+  /* the filter keyword is optional, but needed if one wants to use
+     antiquotations with predicates
+  */
+  | FILTER; a=pred_aq
       AST( Filter a )
       PPX( Filter [%e a] )
   | hv=header_val(ASSIGN)
@@ -131,31 +141,37 @@ pol:
   | sw1=int64; AT; pt1=int64; VLINK; sw2=int64; AT; pt2=int64
       AST( VLink (sw1, pt1, sw2, pt2) )
       PPX( VLink ([%e sw1], [%e pt1], [%e sw2], [%e pt2]) )
-  | IF; a=pred; THEN; p=pol; ELSE; q=pol 
+  | IF; a=pred_aq; THEN; p=pol; ELSE; q=pol 
       AST( Union (Seq (Filter a, p)          , Seq (Filter (Neg a)     , q)) )
       PPX( Union (Seq (Filter [%e a], [%e p]), Seq (Filter (Neg [%e a]), [%e q])) )
-  | WHILE; a=pred; DO; p=pol
+  | WHILE; a=pred_aq; DO; p=pol
       AST( Seq (Star (Seq (Filter a, p))          , Filter (Neg a)) )
       PPX( Seq (Star (Seq (Filter [%e a], [%e p])), Filter (Neg [%e a])) )
-  | LPAR; p=pol; RPAR
-      { p }
+  | LPAR; p=pol; RPAR 
   | BEGIN p=pol; END
       { p }
   AQ
-#ifdef MAKE_PPX
-  | code=IVERSON {
-    let phi = parse_ocaml_expr code in
-    PPX_( if [%e phi] then id else drop )
-  }
-#endif
   ;
 
 %inline
 letexp:
   | LET BOTH( false )
   | VAR BOTH( true )
+  ;
 
+
+
+/* predicates without antiquotations */
 pred:
+  | a=_pred_(pred) { a }
+
+/* predicates with antiquotations */
+pred_aq:
+  | a=_pred_(pred_aq) { a }
+  AQ
+
+%inline
+_pred_(pred):
   | FALSE
       AST( False )
       PPX( False )
@@ -175,17 +191,14 @@ pred:
       AST( And(a, b) )
       PPX( And([%e a], [%e b]) )
   | LPAR; a=pred; RPAR
-      { a }
   | BEGIN a=pred; END
       { a }
-  AQ
 #ifdef MAKE_PPX
   | code=IVERSON {
     let phi = parse_ocaml_expr code in
     PPX_( if [%e phi] then True else False )
   }
 #endif
-  ;
 
 
 (*********************** HEADER VALUES *************************)

src/lib/netkat/jbuild

@@ -71,10 +71,3 @@
   (flags (:standard -safe-string))
  )
 )
-
-;; TODO: toplevel
-;; (executable
-;;  ((name       mytoplevel)
-;;   (libraries  (compiler-libs.toplevel mylib))
-;;   (link_flags (-linkall))
-;;   (modes      (byte))))

src/syntax/jbuild

@@ -11,10 +11,21 @@
  ((flags (--external-tokens Frenetic_netkat.Lexer))
   (modules (Ppx_parser))))
 
-(library
- ((name frenetic_ppx)
+(library (
+  (name frenetic_ppx)
   (public_name frenetic.ppx)
+  (modules (ppx Ppx_parser))
   (kind ppx_rewriter)
   (libraries (ppxlib base frenetic.netkat))
   (ppx_runtime_libraries (frenetic.netkat))
-  (preprocess (pps (ppxlib.metaquot)))))
+  (preprocess (pps (ppxlib.metaquot)))
+))
+
+;; see https://blog.janestreet.com/repeatable-exploratory-programming/
+(library (
+  (name test)
+  (modules (test))
+  (libraries (core expect_test_helpers_kernel frenetic))
+  (inline_tests)
+  (preprocess (pps (ppx_jane frenetic.ppx)))
+))

src/syntax/ppx.ml

@@ -36,25 +36,49 @@ let expand_let_decl ~loc ~path:_ ~pred bindings =
   B.(pstr_value Nonrecursive (List.map bindings ~f:(expand_binding ~pred)))
 
 (* expands `let%nk <bindings> in body` *)
-let expand_let_expr ~loc ~path:_ ~pred bindings body =
+let expand_let_expr ~loc ~pred bindings body =
   let module B = Ast_builder.Make(struct let loc = loc end) in
   B.(pexp_let Nonrecursive (List.map bindings ~f:(expand_binding ~pred)) body)
 
+module Match = struct
+  open Ast_pattern
+
+  let let_decl =
+    pstr (pstr_value nonrecursive __ ^:: nil)
+
+  let let_expr =
+    pexp_let nonrecursive __ __
+
+  let str_expr =
+    (* allow {| code |} and "code" *)
+    alt (some (string "")) none
+    |> pconst_string __
+    |> pexp_constant
+end
+
+
 (* declare `let%nk x = e` extension *)
 let nk_ext_struct pred =
   Extension.V2.declare
     (if pred then ext_keyw_pred else ext_keyw)
     Extension.Context.structure_item
-    Ast_pattern.(pstr (pstr_value nonrecursive __ ^:: nil))
+    Match.let_decl
     (expand_let_decl ~pred)
 
-(* declare `let%nk x = e in b` extension *)
 let nk_ext_expr pred =
   Extension.declare
     (if pred then ext_keyw_pred else ext_keyw)
     Extension.Context.expression
-    Ast_pattern.(single_expr_payload (pexp_let nonrecursive __ __))
-    (expand_let_expr ~pred)
+    Ast_pattern.(single_expr_payload (
+      begin
+        Match.let_expr
+        |> map' ~f:(fun loc _ -> expand_let_expr ~loc ~pred)
+      end ||| begin
+        Match.str_expr
+        |> map' ~f:(fun loc _ -> expand_nk_string ~loc ~pred)
+      end
+    ))
+    (fun ~loc ~path -> ())
 ;;
 
 Driver.register_transformation "netkat"