Initialize repository

6 files changed, 553 insertions, 0 deletions

diff --git a/bin/dune b/bin/dune
new file mode 100644
index 0000000..2a56b29
--- /dev/null
+++ b/bin/dune
@@ -0,0 +1,14 @@
+(executable
+ (public_name mininix)
+ (name main)
+ (preprocess
+  (pps ppx_let))
+ (libraries
+  nix
+  core
+  core_unix.command_unix
+  linenoise
+  mininix
+  sexp_pretty
+  stdio
+  ppx_let))
diff --git a/bin/main.ml b/bin/main.ml
new file mode 100644
index 0000000..e4ca4b9
--- /dev/null
+++ b/bin/main.ml
@@ -0,0 +1,26 @@
+open Core
+
+let repl =
+  Command.basic ~summary:"run the Mininix REPL" (Command.Param.return Repl.run)
+
+let eval =
+  Command.basic ~summary:"run a Nix file"
+    (let%map_open.Command filename = anon ("FILENAME" %: string)
+     and strict = flag "strict" no_arg ~doc:"use deep evaluation strategy"
+     and importsdef =
+       flag "importsdef" (optional string) ~doc:"import tree definition file"
+     in
+     fun () ->
+       Settings.opts.eval_strategy := if strict then `Deep else `Shallow;
+       Settings.opts.imports_def_file := importsdef;
+       let ok =
+         if String.(filename = "-") then Run.eval_stdin ()
+         else Run.eval_file filename
+       in
+       if ok then exit 0 else exit 1)
+
+let main =
+  Command.group ~summary:"the Mininix interpreter"
+    [ ("repl", repl); ("eval", eval) ]
+
+let () = Command_unix.run main
diff --git a/bin/repl.ml b/bin/repl.ml
new file mode 100644
index 0000000..092c503
--- /dev/null
+++ b/bin/repl.ml
@@ -0,0 +1,52 @@
+open Core
+open Option.Let_syntax
+
+let ok = ref true
+let opts = Settings.opts
+
+let rec user_input cb =
+  let prompt = (if !ok then "[okay]" else "[fail]") ^ " (mini)nix> " in
+  try
+    match LNoise.linenoise prompt with
+    | None -> ()
+    | Some v ->
+        cb v;
+        user_input cb
+  with Sys_unix.Break ->
+    printf "\n%!";
+    user_input cb
+
+let split_cmd_prefix cmd =
+  let%bind cmd = String.chop_prefix ~prefix:":" cmd in
+  let cmd' = Repl_cmd.lstrip_space cmd in
+  let space = String.chop_suffix_exn cmd ~suffix:cmd' in
+  return (":" ^ space, cmd')
+
+let handle_cmd cmd =
+  let cmd = Repl_cmd.strip_space cmd in
+  (match split_cmd_prefix cmd with
+  | Some (_, cmd) -> ok := Repl_cmd.invoke cmd
+  | None ->
+      if String.(strip cmd <> "") then
+        ok := Run.eval_expr cmd ~origin:Interactive);
+  printf "\n%!"
+
+let run () =
+  LNoise.set_multiline true;
+  LNoise.history_load ~filename:"mininix_history" |> ignore;
+  LNoise.history_set ~max_length:500 |> ignore;
+  LNoise.set_hints_callback (fun line ->
+      let%bind _, cmd = split_cmd_prefix line in
+      let%bind hint = Repl_cmd.hint cmd in
+      return (hint, LNoise.Yellow, true));
+  LNoise.set_completion_callback (fun line_so_far completions ->
+      match split_cmd_prefix line_so_far with
+      | Some (prefix, cmd_so_far) ->
+          Repl_cmd.complete cmd_so_far
+          |> List.map ~f:(String.append prefix)
+          |> List.iter ~f:(LNoise.add_completion completions)
+      | None -> ());
+  user_input (fun from_user ->
+      LNoise.history_add from_user |> ignore;
+      LNoise.history_save ~filename:"mininix_history" |> ignore;
+      handle_cmd from_user)
diff --git a/bin/repl_cmd.ml b/bin/repl_cmd.ml
new file mode 100644
index 0000000..9ebeae7
--- /dev/null
+++ b/bin/repl_cmd.ml
@@ -0,0 +1,178 @@
+open Core
+open Option.Let_syntax
+
+let join_str_list ~sep = function
+  | [] -> ""
+  | s :: ss -> List.fold ss ~init:s ~f:(fun acc s -> acc ^ sep ^ s)
+
+type cmd = {
+  args : string;
+  opts : unit -> string list;
+  next : (string -> (string, cmd) Either.t) option;
+  call : string list -> bool;
+}
+
+let set_opt_cmd opt setting =
+  {
+    args = "<option value>";
+    opts = (fun () -> Settings.allowed_values setting);
+    next = None;
+    call =
+      (fun args ->
+        match Settings.set_to setting args with
+        | None -> true
+        | Some msg ->
+            printf "Failed to set option %s: %s\n%!" opt msg;
+            false);
+  }
+
+let set_cmd =
+  {
+    args = "<option name> <option value>";
+    opts = (fun () -> Map.keys Settings.settings);
+    next =
+      Some
+        (fun opt ->
+          match Map.find Settings.settings opt with
+          | Some setting -> Second (set_opt_cmd opt setting)
+          | None -> First (sprintf "Unknown option '%s'" opt));
+    call =
+      (fun _ ->
+        printf "Missing option argument value\n%!";
+        false);
+  }
+
+let settings_cmd =
+  {
+    args = "";
+    opts = (fun () -> []);
+    next = None;
+    call =
+      (function
+      | [] ->
+          Settings.print ();
+          true
+      | _ ->
+          printf "Expected no arguments\n%!";
+          false);
+  }
+
+let run_cmd =
+  {
+    args = "<filename>";
+    opts = (fun () -> []);
+    next = None;
+    call =
+      (function
+      | [ filename ] -> Run.eval_file filename
+      | _ ->
+          printf "Expected one argument (the filename)\n%!";
+          false);
+  }
+
+let quit_cmd =
+  { args = ""; opts = (fun () -> []); next = None; call = (fun _ -> exit 0) }
+
+let commands =
+  Map.of_alist_exn
+    (module String)
+    [
+      ("quit", quit_cmd);
+      ("set", set_cmd);
+      ("settings", settings_cmd);
+      ("run", run_cmd);
+    ]
+
+let root_cmd =
+  {
+    args = "<command>";
+    opts = (fun () -> Map.keys commands);
+    next =
+      Some
+        (fun cmd_name ->
+          match Map.find commands cmd_name with
+          | Some cmd -> Second cmd
+          | None ->
+              First
+                (sprintf "Unknown command '%s' (expected one of {%s})" cmd_name
+                   (Map.keys commands |> join_str_list ~sep:", ")));
+    call =
+      (fun _ ->
+        printf "Missing command!\n%!";
+        false);
+  }
+
+let is_space = Char.( = ) ' '
+let strip_space = String.strip ~drop:is_space
+let lstrip_space = String.lstrip ~drop:is_space
+
+let clean_str_list ss =
+  ss |> List.map ~f:strip_space
+  |> List.filter ~f:(fun s -> not (String.is_empty s))
+
+let words s = s |> String.split ~on:' ' |> clean_str_list
+let unwords ss = clean_str_list ss |> join_str_list ~sep:" "
+
+let rec call cmd args =
+  match args with
+  | [] -> cmd.call []
+  | arg0 :: argn -> (
+      match cmd.next with
+      | None -> cmd.call args
+      | Some next -> (
+          match next arg0 with
+          | First msg ->
+              printf "%s\n%!" msg;
+              false
+          | Second cmd' -> call cmd' argn))
+
+let try_lsplit2_space s =
+  match String.lsplit2 s ~on:' ' with Some (l, r) -> (l, r) | None -> (s, "")
+
+let lsplit2_space' s =
+  let%bind l, r = String.lsplit2 s ~on:' ' in
+  (* s = l ^ " " ^ r *)
+  let r' = lstrip_space r in
+  let space = " " ^ String.chop_suffix_exn r ~suffix:r' in
+  (* s = l ^ space ^ r' *)
+  return (l, space, r')
+
+let rec completions cmd args =
+  (* cmd|<TAB> -> options
+     cmd|abc<TAB> -> options with prefix 'abc'
+     cmd|abc .*<TAB> -> subcommand 'abc' options, pass .* *)
+  if String.(args = "") then cmd.opts ()
+  else
+    match lsplit2_space' args with
+    | None -> cmd.opts () |> List.filter ~f:(String.is_prefix ~prefix:args)
+    | Some (arg0, space, argn) -> (
+        match cmd.next with
+        | None -> []
+        | Some next -> (
+            match next arg0 with
+            | First _ -> []
+            | Second cmd' ->
+                completions cmd' argn
+                |> List.map ~f:(String.append (arg0 ^ space))))
+
+let rec hints cmd args =
+  (* cmd: "" -> " <args>"
+     cmd: "<space>+" -> "<args>"
+     cmd: "<space>+<subcmd>" -> "<hints for subcmd>"
+     cmd: "<space>+<subcmd> .*" -> "<hints for subcmd with .*>" *)
+  if String.(args = "") then Some (" " ^ cmd.args)
+  else if String.(strip_space args = "") then Some cmd.args
+  else
+    let args = lstrip_space args in
+    let%bind next = cmd.next in
+    match lsplit2_space' args with
+    | None ->
+        let%bind cmd' = next args |> Either.Second.to_option in
+        hints cmd' ""
+    | Some (arg0, space, argn) ->
+        let%bind cmd' = next arg0 |> Either.Second.to_option in
+        hints cmd' (space ^ argn)
+
+let invoke cmd = call root_cmd (words cmd)
+let complete cmd = completions root_cmd cmd
+let hint cmd = hints root_cmd cmd
diff --git a/bin/run.ml b/bin/run.ml
new file mode 100644
index 0000000..f39997c
--- /dev/null
+++ b/bin/run.ml
@@ -0,0 +1,163 @@
+open Core
+
+let opts = Settings.opts
+
+module Origin = struct
+  type t = Filename of string | Stdin | Interactive
+
+  let to_string = function
+    | Filename name -> name
+    | Stdin -> "<stdin>"
+    | Interactive -> "<interactive>"
+end
+
+(* [dir] must be an absolute path *)
+let rec find_imports_file dir : (string, string) result =
+  let def_filename = Filename.concat dir "importdef.sexp" in
+  match Core_unix.access def_filename [ `Read ] with
+  | Ok () -> Ok def_filename
+  | Error (Core_unix.Unix_error (ENOENT, _, _))
+  | Error (Core_unix.Unix_error (EACCES, _, _)) ->
+      let parent = Filename.dirname dir in
+      if String.(parent = dir) then Error "Could not find importdef.sexp file"
+      else find_imports_file (Filename.dirname dir)
+  | Error _ -> Error "Could not find importdef.sexp file"
+
+let load_imports ~for_ =
+  let cwd = Core_unix.getcwd () in
+  let filename =
+    match !(opts.imports_def_file) with
+    | None -> (
+        let dir =
+          match for_ with
+          | Origin.Filename filename ->
+              Filename.to_absolute_exn
+                (Filename.dirname filename)
+                ~relative_to:cwd
+          | Origin.Stdin | Origin.Interactive -> cwd
+        in
+        match find_imports_file dir with
+        | Error _ ->
+            printf
+              "Note: no importdef.sexp was found / could be accessed; imports \
+               will not work\n\
+               %!";
+            None
+        | Ok filename ->
+            let relative =
+              if Filename.is_absolute filename then
+                Filename.of_absolute_exn filename ~relative_to:cwd
+              else filename
+            in
+            printf "Imports definition found at %s\n%!" relative;
+            Some filename)
+    | Some filename -> Some filename
+  in
+  match filename with
+  | None -> Ok []
+  | Some filename -> (
+      (* User-provided filenames may not be absolute *)
+      let filename_abs = Filename.to_absolute_exn filename ~relative_to:cwd in
+      try
+        Ok
+          (In_channel.read_all filename
+          |> Sexp.of_string |> Mininix.Sexp.import_forest_of_sexp
+          |> Mininix.Import.materialize
+               ~relative_to:(Filename.dirname filename_abs))
+      with Sys_error err -> Error ("Failed to read imports definition: " ^ err))
+
+let eval_expr_with_imports ~origin ~imports data =
+  let cwd = Core_unix.getcwd () in
+  let config = Sexp_pretty.Config.default
+  and formatter = Stdlib.Format.formatter_of_out_channel stdout in
+  try
+    if !(opts.print_input) then printf "==> Input Nix:\n%s\n\n%!" data;
+    let nexp = Nix.parse ~filename:(Origin.to_string origin) data in
+    if !(opts.print_parsed) then (
+      print_string "==> Parsed Nix:\n";
+      Nix.Printer.print stdout nexp;
+      printf "\n\n%!");
+    let nnexp =
+      Nix.elaborate
+        ~dir:
+          (Some
+             (match origin with
+             | Filename name ->
+                 Filename.to_absolute_exn ~relative_to:cwd
+                   (Filename.dirname name)
+             | Stdin | Interactive -> cwd))
+        nexp
+    in
+    if !(opts.print_elaborated) then (
+      print_string "==> Parsed, elaborated Nix:\n";
+      Nix.Printer.print stdout nnexp;
+      printf "\n\n%!");
+    if !(opts.print_nix_sexp) then (
+      let nsexp = Nix.Ast.sexp_of_expr nnexp in
+      print_string "==> Nix S-expr:\n";
+      Sexp_pretty.pp_formatter config formatter nsexp;
+      printf "\n%!");
+    let mnexp = Mininix.Nix2mininix.from_nix nnexp in
+    if !(opts.print_mininix_sexp) then (
+      let mnsexp = Mininix.Sexp.expr_to_sexp mnexp in
+      print_string "==> Mininix S-expr:\n";
+      Sexp_pretty.pp_formatter config formatter mnsexp;
+      printf "\n%!");
+    let mnwpexp = Mininix.apply_prelude mnexp in
+    if !(opts.print_mininix_sexp_w_prelude) then (
+      let mnwpsexp = Mininix.Sexp.expr_to_sexp mnwpexp in
+      print_string "==> Mininix S-expr (+ prelude):\n";
+      Sexp_pretty.pp_formatter config formatter mnwpsexp;
+      printf "\n%!");
+    let res =
+      Mininix.interp_tl ~fuel:!(opts.fuel_amount) ~mode:!(opts.eval_strategy)
+        ~imports mnwpexp
+    in
+    if !(opts.print_result_mininix_sexp) then (
+      let ressexp = Mininix.Sexp.val_res_to_sexp res in
+      print_string "==> Evaluation result (Mininix S-exp):\n";
+      Sexp_pretty.pp_formatter config formatter ressexp;
+      printf "\n%!");
+    match res with
+    | Res (Some v) ->
+        let nixv = Mininix.Mininix2nix.from_val v in
+        if !(opts.print_result_nix_sexp) then (
+          let nixvsexp = Nix.Ast.sexp_of_expr nixv in
+          print_string "==> Evaluation result (Nix S-exp):\n";
+          Sexp_pretty.pp_formatter config formatter nixvsexp;
+          printf "\n%!");
+        print_string "==> Evaluation result (Nix):\n";
+        Nix.Printer.print stdout nixv;
+        printf "\n%!";
+        true
+    | Res None ->
+        printf "Failed to evaluate\n%!";
+        false
+    | _ ->
+        printf "Ran out of fuel\n%!";
+        false
+  with
+  | Nix.ParseError msg ->
+      printf "Failed to parse: %s\n%!" msg;
+      false
+  | Nix.ElaborateError msg ->
+      printf "Elaboration failed: %s\n%!" msg;
+      false
+  | Mininix.Nix2mininix.FromNixError msg ->
+      printf "Failed to convert Nix to Mininix: %s\n%!" msg;
+      false
+
+let eval_expr ~origin data =
+  match load_imports ~for_:origin with
+  | Ok imports -> eval_expr_with_imports ~origin ~imports data
+  | Error msg ->
+      print_endline msg;
+      false
+
+let eval_ch ~origin ch = In_channel.input_all ch |> eval_expr ~origin
+
+let eval_file filename =
+  In_channel.with_file filename ~binary:true
+    ~f:(eval_ch ~origin:(Filename filename))
+
+let eval_stdin () = eval_ch In_channel.stdin ~origin:Stdin
diff --git a/bin/settings.ml b/bin/settings.ml
new file mode 100644
index 0000000..55699ee
--- /dev/null
+++ b/bin/settings.ml
@@ -0,0 +1,120 @@
+open Core
+
+type fuel_amount = [ `Limited | `Unlimited ]
+type eval_strategy = [ `Shallow | `Deep ]
+
+type options = {
+  eval_strategy : eval_strategy ref;
+  fuel_amount : fuel_amount ref;
+  imports_def_file : string option ref;
+  print_input : bool ref;
+  print_parsed : bool ref;
+  print_elaborated : bool ref;
+  print_nix_sexp : bool ref;
+  print_mininix_sexp : bool ref;
+  print_mininix_sexp_w_prelude : bool ref;
+  print_result_mininix_sexp : bool ref;
+  print_result_nix_sexp : bool ref;
+}
+
+let opts =
+  {
+    eval_strategy = ref `Deep;
+    fuel_amount = ref `Unlimited;
+    imports_def_file = ref None;
+    print_input = ref false;
+    print_parsed = ref false;
+    print_elaborated = ref false;
+    print_nix_sexp = ref false;
+    print_mininix_sexp = ref false;
+    print_mininix_sexp_w_prelude = ref false;
+    print_result_mininix_sexp = ref false;
+    print_result_nix_sexp = ref false;
+  }
+
+type 'a setter = 'a -> unit
+
+type setting =
+  | BoolSetting of bool ref
+  | EvalStrategySetting of eval_strategy ref
+  | FilenameOptionSetting of string option ref
+  | FuelAmountSetting of fuel_amount ref
+
+let allowed_values s =
+  match s with
+  | BoolSetting _ -> [ "true"; "false" ]
+  | EvalStrategySetting _ -> [ "shallow"; "deep" ]
+  | FilenameOptionSetting _ -> [ "none"; "some " ]
+  | FuelAmountSetting _ -> [ "limited"; "unlimited" ]
+
+let set_to s v =
+  match s with
+  | BoolSetting vref -> (
+      match v with
+      | [ "true" ] ->
+          vref := true;
+          None
+      | [ "false" ] ->
+          vref := false;
+          None
+      | _ -> Some "expected one argument: 'true' or 'false'")
+  | EvalStrategySetting vref -> (
+      match v with
+      | [ "shallow" ] ->
+          vref := `Shallow;
+          None
+      | [ "deep" ] ->
+          vref := `Deep;
+          None
+      | _ -> Some "expected one argument: 'shallow' or 'deep'")
+  | FilenameOptionSetting vref -> (
+      match v with
+      | [ "none" ] ->
+          vref := None;
+          None
+      | [ "some"; filename ] ->
+          vref := Some (String.strip filename);
+          None
+      | _ -> Some "expected 'none' or 'some <filename>'")
+  | FuelAmountSetting vref -> (
+      match v with
+      | [ "limited" ] ->
+          vref := `Limited;
+          None
+      | [ "unlimited" ] ->
+          vref := `Unlimited;
+          None
+      | _ -> Some "expected 'limited' or 'unlimited'")
+
+let to_string s =
+  match s with
+  | BoolSetting vref -> Bool.to_string !vref
+  | EvalStrategySetting vref -> (
+      match !vref with `Shallow -> "shallow" | `Deep -> "deep")
+  | FilenameOptionSetting vref -> (
+      match !vref with None -> "none" | Some v -> "some " ^ v)
+  | FuelAmountSetting vref -> (
+      match !vref with `Limited -> "limited" | `Unlimited -> "unlimited")
+
+let settings =
+  Map.of_alist_exn
+    (module String)
+    [
+      ("print_input", BoolSetting opts.print_input);
+      ("print_parsed", BoolSetting opts.print_parsed);
+      ("print_elaborated", BoolSetting opts.print_elaborated);
+      ("print_nix_sexp", BoolSetting opts.print_nix_sexp);
+      ("print_mininix_sexp", BoolSetting opts.print_mininix_sexp);
+      ( "print_mininix_sexp_w_prelude",
+        BoolSetting opts.print_mininix_sexp_w_prelude );
+      ("print_result_mininix_sexp", BoolSetting opts.print_result_mininix_sexp);
+      ("print_result_nix_sexp", BoolSetting opts.print_result_nix_sexp);
+      ("eval_strategy", EvalStrategySetting opts.eval_strategy);
+      ("fuel_amount", FuelAmountSetting opts.fuel_amount);
+      ("imports_def_file", FilenameOptionSetting opts.imports_def_file);
+    ]
+
+let print () =
+  printf "==> Settings:\n";
+  Map.iteri settings ~f:(fun ~key:name ~data:setting ->
+      printf "  %s: %s\n" name (to_string setting))