From 4ee5973bb4a88db453f398fb5d9503a1100eb83d Mon Sep 17 00:00:00 2001 From: Jay Lee Date: Sun, 2 Jun 2024 01:49:42 +0900 Subject: [PATCH] :technologist: Enhance CLI --- bin/dune | 4 ++- bin/main.ml | 71 ++++++++++++++++++++++++++------------------- dune-project | 2 +- lib/compiler.ml | 5 ++-- lib/dune | 2 +- lib/graph.ml | 2 +- lib/lexer.mll | 76 +++++++++++++++++++++---------------------------- lib/program.ml | 3 +- stappl.opam | 1 + 9 files changed, 85 insertions(+), 81 deletions(-) diff --git a/bin/dune b/bin/dune index 1eee1a5..d6e2341 100644 --- a/bin/dune +++ b/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))) diff --git a/bin/main.ml b/bin/main.ml index ba34671..318c5f3 100644 --- a/bin/main.ml +++ b/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 ("", 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 diff --git a/dune-project b/dune-project index bc9eadd..800f78a 100644 --- a/dune-project +++ b/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) diff --git a/lib/compiler.ml b/lib/compiler.ml index f89d995..a572401 100644 --- a/lib/compiler.ml +++ b/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 diff --git a/lib/dune b/lib/dune index dd68249..eff854d 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,5 @@ (library - (name project) + (name stappl) (libraries str core) (preprocess (pps ppx_jane))) diff --git a/lib/graph.ml b/lib/graph.ml index 8b42c1c..965f20f 100644 --- a/lib/graph.ml +++ b/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 diff --git a/lib/lexer.mll b/lib/lexer.mll index 418b653..435fcf2 100644 --- a/lib/lexer.mll +++ b/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 } diff --git a/lib/program.ml b/lib/program.ml index a4cdd9e..e5bcc5b 100644 --- a/lib/program.ml +++ b/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 diff --git a/stappl.opam b/stappl.opam index 86bbec4..b832e28 100644 --- a/stappl.opam +++ b/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}