🧑‍💻 Enhance CLI

bin/dune

@@ -1,7 +1,9 @@
 (executable
  (public_name stappl)
  (name main)
- (libraries project)
+ (libraries core core_unix.command_unix core_unix.filename_unix stappl)
  (modes byte exe)
+ (preprocess
+  (pps ppx_jane))
  (flags
   (:standard -g)))

bin/main.ml

@@ -1,33 +1,44 @@
-open Project
-open Program
+open Core
+open Stappl
 
-let src = ref ""
-let opt_pp = ref false
-
-let lexbuf_contents lb =
+let print_position (outx : Out_channel.t) (lexbuf : Lexing.lexbuf) : unit =
   let open Lexing in
-  let pos = lb.lex_curr_pos in
-  let len = lb.lex_buffer_len - lb.lex_curr_pos in
-  Bytes.to_string (Bytes.sub lb.lex_buffer pos len)
+  let pos = lexbuf.lex_curr_p in
+  fprintf outx "%s:%d:%d" pos.pos_fname pos.pos_lnum
+    (pos.pos_cnum - pos.pos_bol + 1)
+
+let parse_with_error (lexbuf : Lexing.lexbuf) : Program.program =
+  Parser.program Lexer.start lexbuf
+
+let get_program (filename : string) : Program.program =
+  let filename, inx =
+    if String.(filename = "-") then ("<stdin>", In_channel.stdin)
+    else (filename, In_channel.create filename)
+  in
+  let lexbuf = Lexing.from_channel inx in
+  lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename };
+
+  match parse_with_error lexbuf with
+  | prog ->
+      In_channel.close inx;
+      prog
+  | exception Parser.Error ->
+      fprintf stderr "%a: syntax error\n" print_position lexbuf;
+      In_channel.close inx;
+      exit (-1)
+
+let command : Command.t =
+  Command.basic ~summary:"The STAPPL Compiler"
+    ~readme:(fun () ->
+      "STAPPL is a compiler for the STAtically typed Probabilistic Programming \
+       Language")
+    (let%map_open.Command filename =
+       anon (maybe_with_default "-" ("filename" %: Filename_unix.arg_type))
+     and pp = flag "-pp" no_arg ~doc:" Pretty print the program" in
+     fun () ->
+       if pp then get_program filename |> Program.pretty |> print_endline
+       else
+         get_program filename |> Compiler.compile |> fst |> Graph.pretty
+         |> print_endline)
 
-let () =
-  Arg.parse
-    [ ("-pp", Arg.Unit (fun _ -> opt_pp := true), "print pgm") ]
-    (fun x -> src := x)
-    ("Usage : " ^ Filename.basename Sys.argv.(0) ^ " [-option] [filename] ");
-  if !opt_pp then
-    let lexbuf =
-      Lexing.from_channel (if !src = "" then stdin else open_in !src)
-    in
-    try
-      let pgm = Parser.program Lexer.start lexbuf in
-      print_endline "=== Printing Input Program ===";
-      pp pgm;
-      let open Compiler in
-      let env = gather_functions pgm in
-      let graph, _de = compile env Pred.Empty pgm.exp in
-      print_endline "=== Printing Output Program ===";
-      Printf.printf "%s" (Graph.pp graph)
-    with Parsing.Parse_error ->
-      print_endline ("Parsing Error: " ^ lexbuf_contents lexbuf)
-  else print_endline "Please provide one of options! (-pp)"
+let () = Command_unix.run ~version:"0.1.0" ~build_info:"STAPPL" command

dune-project

@@ -25,9 +25,9 @@
  (description "STAPPL is a statically typed probabilistic programming language")
  (depends
   (core (>= 0.16.2))
+  (core_unix (>= 0.16.0))
   (ppx_jane (>= 0.16.0))
   (menhir (>= 20231231))))
-;(map_workspace_root false)
 
 (license MIT)
 

lib/compiler.ml

@@ -56,7 +56,8 @@ let gather_functions (prog : program) : Env.t =
 
 exception Not_closed_observation
 
-let compile (env : Env.t) (pred : Pred.t) (exp : Exp.t) : Graph.t * Det_exp.t =
+let compile (program : program) : Graph.t * Det_exp.t =
+  let env = gather_functions program in
   let rec compile pred =
     let compile' e = compile pred e in
     let open Graph in
@@ -215,4 +216,4 @@ let compile (env : Env.t) (pred : Pred.t) (exp : Exp.t) : Graph.t * Det_exp.t =
         in
         (g, Det_exp.Record des)
   in
-  compile pred exp
+  compile Pred.Empty program.exp

lib/dune

@@ -1,5 +1,5 @@
 (library
- (name project)
+ (name stappl)
  (libraries str core)
  (preprocess
   (pps ppx_jane)))

lib/graph.ml

@@ -39,5 +39,5 @@ let union g1 g2 =
           | `Both _ -> failwith "Graph.union: duplicate observation");
   }
 
-let pp (graph : t) : string = graph |> sexp_of_t |> Sexp.to_string_hum
 let ( @+ ) = union
+let pretty (graph : t) : string = graph |> sexp_of_t |> Sexp.to_string_hum

lib/lexer.mll

@@ -4,18 +4,6 @@ open Parser
 exception Eof
 exception LexicalError
 
-let verbose1 s =
-  print_string s;
-  print_newline ();
-  s
-
-let verbose2 s =
-  print_string s;
-  print_newline ();
-  ()
-
-(* let verbose1 s =  s
-   let verbose2 s =  () *)
 let keyword_tbl = Hashtbl.create 31
 
 let _ =
@@ -44,43 +32,43 @@ let newline = ['\n' '\r']+
 
 rule start = parse
       | blank { start lexbuf }
-      | int as i { INT (int_of_string (verbose1 i)) }
-      | real as r { REAL (float_of_string (verbose1 r)) }
-      | id as s { let id = verbose1 (String.lowercase_ascii s) in
+      | int as i { INT (int_of_string i) }
+      | real as r { REAL (float_of_string r) }
+      | id as s { let id = String.lowercase_ascii s in
                try Hashtbl.find keyword_tbl id
                with Not_found -> ID id
             }
-      | "#" {verbose2 "#"; comment lexbuf }
-      | "+" {verbose2 "+"; PLUS}
-      | "+." {verbose2 "+."; RPLUS}
-      | "-" {verbose2 "-"; MINUS}
-      | "-." {verbose2 "-."; RMINUS}
-      | "~-" {verbose2 "~"; NEG}
-      | "~-." {verbose2 "-."; RNEG}
-      | "*" {verbose2 "*"; MULT}
-      | "*." {verbose2 "*."; RMULT}
-      | "/" { verbose2 "/"; DIV}
-      | "/." { verbose2 "/."; RDIV}
-      | "=" { verbose2 "="; EQ}
-      | "!=" { verbose2 "!="; NOTEQ}
-      | "<" { verbose2 "<"; LESS}
-      | ">" { verbose2 ">"; GREAT}
-      | "&" { verbose2 "&"; AND}
-      | "|" { verbose2 "|"; OR}
-      | "!" { verbose2 "!"; NOT}
-      | "(" { verbose2 "("; LPAREN}
-      | ")" { verbose2 ")"; RPAREN}
-      | "[" { verbose2 "["; LSQUARE}
-      | "]" { verbose2 "]"; RSQUARE}
-      | "," { verbose2 ","; COMMA}
-      | "{" { verbose2 "{"; LBRACKET}
-      | "}" { verbose2 "}"; RBRACKET}
-      | ":" { verbose2 ":"; COLON}
-      | ";" { verbose2 ";"; SEMICOLON}
-      | eof { verbose2 "eof"; EOF }
+      | "#" { comment lexbuf }
+      | "+" { PLUS}
+      | "+." { RPLUS}
+      | "-" { MINUS}
+      | "-." { RMINUS}
+      | "~-" { NEG}
+      | "~-." { RNEG}
+      | "*" { MULT}
+      | "*." { RMULT}
+      | "/" {  DIV}
+      | "/." {  RDIV}
+      | "=" {  EQ}
+      | "!=" {  NOTEQ}
+      | "<" {  LESS}
+      | ">" {  GREAT}
+      | "&" {  AND}
+      | "|" {  OR}
+      | "!" {  NOT}
+      | "(" {  LPAREN}
+      | ")" {  RPAREN}
+      | "[" {  LSQUARE}
+      | "]" {  RSQUARE}
+      | "," {  COMMA}
+      | "{" {  LBRACKET}
+      | "}" {  RBRACKET}
+      | ":" {  COLON}
+      | ";" {  SEMICOLON}
+      | eof {  EOF }
       | _ as c { failwith (Printf.sprintf "unexpected character: %C" c) }
 
 and comment = parse
    | newline { start lexbuf }
-   | eof { verbose2 "eof"; EOF }
+   | eof {  EOF }
    | _   { comment lexbuf }

lib/program.ml

@@ -122,4 +122,5 @@ module Det_exp = struct
           ~f:(fun acc e -> Set.union acc (fv e))
 end
 
-let pp pgm = print_endline (sexp_of_program pgm |> Sexp.to_string_hum)
+let pretty (prog : program) : string =
+  prog |> sexp_of_program |> Sexp.to_string_hum

stappl.opam

@@ -11,6 +11,7 @@ bug-reports: "https://github.com/shapespeare/stappl/issues"
 depends: [
   "dune" {>= "3.4"}
   "core" {>= "0.16.2"}
+  "core_unix" {>= "0.16.0"}
   "ppx_jane" {>= "0.16.0"}
   "menhir" {>= "20231231"}
   "odoc" {with-doc}