fix: $cwd not always absolute

MILESTONES.md

@@ -41,6 +41,7 @@
 
 ## next
 - [x] Feature: Process.forkInherit()
+- [x] bug: $cwd is NOT always absolute
 
 ## v0.1 - initially tagged version
 - [x] Language versioning

bin/native_test.ml

@@ -1,6 +1,6 @@
 let map_some cb = function Some v -> cb v | None -> failwith "Nope!"
 let map_none cb = function None -> cb () | Some _ -> failwith "Nope!"
-let map_ok cb = function Ok () -> cb () | Error _ -> failwith "Nope!"
+let map_ok cb = function Ok v -> cb v | Error _ -> failwith "Nope!"
 let map_error cb = function Ok _ -> failwith "Nope!" | Error msg -> cb msg
 
 let () =
@@ -12,4 +12,4 @@ let () =
   |> map_error (fun msg ->
       Printf.printf "CD-ing to /nosuchdir returned \"%s\"\n" msg);
   Sn.Native.chdir "/"
-  |> map_ok (fun () -> print_endline "CD-ing to / succeeded.")
+  |> map_ok (fun () -> Printf.printf "CD-ing to / succeeded.\n")

lib/common/common.ml

@@ -26,6 +26,7 @@ let wrap_error cb =
   | CompileError msg -> Error msg
   | RuntimeError msg -> Error msg
 
+(* TODO: why is this different from `internal_failure` above? *)
 let option_value opt ~message =
   match opt with Some v -> v | None -> raise @@ InternalFailure message
 

lib/interpreter/dune

@@ -1,5 +1,11 @@
 (library
  (name interpreter)
- (libraries compiler core_unix sloth_common core_unix.sys_unix)
+ (libraries
+  compiler
+  core_unix
+  sloth_common
+  core_unix.sys_unix
+  core_unix.filename_unix)
+ (modules_without_implementation native_sig)
  (preprocess
   (pps ppx_jane)))

lib/interpreter/globals.ml

@@ -1,7 +1,7 @@
 open Core
 
 type t = {
-  l : (module Native.Sig);
+  l : (module Native_sig.Sig);
   identifiers : Runtime.t Identifiers.t;
   context_ids : Runtime.t Context.t;
   (* We need to store these at the top level so that we can find these for
@@ -26,7 +26,7 @@ let push_frame t next_func pos =
 
 (* TODO memoize *)
 let make_globals m src script_path ~argv ~env ~version =
-  let module M = (val m : Native.Sig) in
+  let module M = (val m : Native_sig.Sig) in
   let classes = Hashtbl.create (module String) in
   let identifiers : Runtime.t Identifiers.t = Identifiers.create () in
   let context_ids = Context.create () in

lib/interpreter/interpret.ml

@@ -740,11 +740,13 @@ and interpret_expr globals (expr : Compiler.Optimizer.expr) =
       let middleware name prev next =
         match name with
         | "$cwd" ->
+            let cd_wrapper p =
+              match M.chdir p with
+              | Ok _ -> ()
+              | Error msg -> fail ~globals pos msg
+            in
             (match Runtime.string_of_val next with
-            | Some s -> (
-                match M.chdir s with
-                | Ok () -> ()
-                | Error msg -> fail ~globals pos msg)
+            | Some s -> cd_wrapper s
             | None ->
                 fail ~globals pos
                 @@ Printf.sprintf
@@ -753,22 +755,17 @@ and interpret_expr globals (expr : Compiler.Optimizer.expr) =
             post_block_hook :=
               Some
                 (fun () ->
-                  let unit_res =
-                    Runtime.string_of_val prev
-                    |> option_value ~message:__LOC__
-                    |> M.chdir
-                  in
-                  match unit_res with
-                  | Ok () -> ()
-                  | Error msg -> fail ~globals pos msg)
+                  Runtime.string_of_val prev
+                  |> option_value ~message:__LOC__
+                  |> cd_wrapper)
         | _ -> ()
       in
 
       let _, either =
         List.fold assignments ~init:(inner_globals, First ())
           ~f:(fun prev (name, expr) ->
             prev >>= fun globals () ->
-            interpret_expr globals expr >>= fun globals next_path ->
+            interpret_expr globals expr >>= fun globals next_value ->
             let prev =
               match Context.get globals.context_ids name with
               | Some prev -> prev
@@ -777,10 +774,22 @@ and interpret_expr globals (expr : Compiler.Optimizer.expr) =
                     name
                   |> fail ~globals pos
             in
-            middleware name prev next_path;
-            (match Context.reassign globals.context_ids name next_path with
-            | Some () -> ()
-            | None -> internal_failure __LOC__);
+            let next_value =
+              match name with
+              | "$cwd" -> (
+                  match Runtime.string_of_val next_value with
+                  | Some path -> Runtime.String (M.realpath path)
+                  | None ->
+                      fail ~globals pos
+                      @@ Printf.sprintf
+                           "Cannot assign %s to $cwd because it must be a \
+                            `String`"
+                      @@ Runtime.to_s next_value)
+              | _ -> next_value
+            in
+            Context.reassign globals.context_ids name next_value
+            |> option_value ~message:__LOC__;
+            middleware name prev next_value;
             (globals, First ()))
         >>= fun globals () -> (globals, interpret_block globals block)
       in
@@ -1152,7 +1161,7 @@ and cast_to_file_descriptor ~globals ~pos ~mode ~m t :
   match t with
   | FileDescriptor fd -> First fd
   | File { path } -> (
-      let module M = (val m : Native.Sig) in
+      let module M = (val m : Native_sig.Sig) in
       match M.open_file ~mode path with
       | Ok fd -> First fd
       | Error msg -> failure_obj ~globals ~pos msg)

lib/interpreter/native.ml

@@ -1,47 +1,8 @@
 open Core
 open Sloth_common.Common
+open Native_sig
 
-type processMode =
-  | BlockInherit (* proc! -> null *)
-  | ForkInherit (* ? -> ProcessHandle *)
-  | ForkBuffer (* proc& -> ProcessHandle *)
-  | BlockBuffer (* proc&! -> ProcessResult *)
-
-module type Sig = sig
-  (* TODO we should never be returning Runtime.t, but more specific types *)
-
-  val file_read_all : string -> string
-  val fd_read_all : Core_unix.File_descr.t -> (Runtime.t, string) Result.t
-  val fd_write_all : Core_unix.File_descr.t -> string -> (unit, string) Result.t
-
-  (* TODO does this type of `data` need to be more generic to support binary? *)
-  val write : Core_unix.File_descr.t -> data:string -> (unit, string) Result.t
-  val read : Core_unix.File_descr.t -> (Runtime.t, string) Result.t
-  val wait : Runtime.process_handle -> (Runtime.t, string) Result.t
-
-  val pipe : unit -> Core_unix.File_descr.t * Core_unix.File_descr.t
-  (** unit -> read * write *)
-
-  val open_file :
-    mode:Core_unix.open_flag list ->
-    string ->
-    (Core_unix.File_descr.t, string) Result.t
-
-  val close : Core_unix.File_descr.t -> (unit, string) Result.t
-
-  val proc_exec :
-    mode:processMode ->
-    Runtime.process ->
-    string array ->
-    (Runtime.t, string) Result.t
-
-  val chdir : string -> (unit, string) Result.t
-  val directory_exists : string -> bool
-  val file_exists : string -> bool
-  val mkdir : string -> unit
-end
-
-module Prod : Sig = struct
+module Prod : Native_sig.Sig = struct
   let pipe = Core_unix.pipe ~close_on_exec:true
   let file_read_all = In_channel.read_all
 
@@ -102,6 +63,9 @@ module Prod : Sig = struct
       let err_msg = Core_unix.Error.message err in
       Error (Printf.sprintf "`chdir(%s)` failed with \"%s\"" path err_msg)
 
+  (** TODO make a Result.t *)
+  let realpath path = Filename_unix.realpath path
+
   let mkdir = Core_unix.mkdir ~perm:0o775
 
   let file_exists path =
@@ -435,7 +399,10 @@ module Make_test () : TestSig = struct
 
   let proc_expectations : Mock_process.spec option ref = ref None
   let chdir _ = Ok ()
-  (* This function only exists to cause OS side-effects, no-op in tests *)
+  (* Note: this function only exists to cause side effects *)
+
+  let realpath _ = "TODO normalize test realpath"
+  (* TODO: write test normalization algorithm? *)
 
   let mkdir path =
     match Hashtbl.add path_to_entity ~key:path ~data:Directory with

lib/interpreter/native.mli

@@ -1,43 +1,8 @@
 open Core
-
-type processMode =
-  | BlockInherit (* proc! -> null *)
-  | ForkInherit (* ? -> ProcessHandle *)
-  | ForkBuffer (* proc& -> ProcessHandle *)
-  | BlockBuffer (* proc&! -> ProcessResult *)
-
-module type Sig = sig
-  val file_read_all : string -> string
-  val fd_read_all : Core_unix.File_descr.t -> (Runtime.t, string) Result.t
-  val fd_write_all : Core_unix.File_descr.t -> string -> (unit, string) Result.t
-  val write : Core_unix.File_descr.t -> data:string -> (unit, string) Result.t
-  val read : Core_unix.File_descr.t -> (Runtime.t, string) Result.t
-  val wait : Runtime.process_handle -> (Runtime.t, string) Result.t
-  val pipe : unit -> Core_unix.File_descr.t * Core_unix.File_descr.t
-
-  val open_file :
-    mode:Core_unix.open_flag list ->
-    string ->
-    (Core_unix.File_descr.t, string) Result.t
-
-  val close : Core_unix.File_descr.t -> (unit, string) Result.t
-
-  val proc_exec :
-    mode:processMode ->
-    Runtime.process ->
-    string array ->
-    (Runtime.t, string) Result.t
-
-  val chdir : string -> (unit, string) Result.t
-  val directory_exists : string -> bool
-  val file_exists : string -> bool
-  val mkdir : string -> unit
-end
-
-module Prod : Sig
+module Prod : Native_sig.Sig
 
 module type TestSig = sig
-  include Sig
+  include Native_sig.Sig
 
   type fs_entity = File of string ref * Core_unix.File_descr.t | Directory
 

lib/interpreter/native_sig.mli

@@ -0,0 +1,45 @@
+open Core
+
+(* This is its own, interface-only module to work around:
+  https://discuss.ocaml.org/t/why-do-i-need-to-repeat-type-declarations-between-interfaces-and-implementations-or-how-do-i-get-around-this/3350 *)
+
+type processMode =
+  | BlockInherit (* proc! -> null *)
+  | ForkInherit (* ? -> ProcessHandle *)
+  | ForkBuffer (* proc& -> ProcessHandle *)
+  | BlockBuffer (* proc&! -> ProcessResult *)
+
+module type Sig = sig
+  (* TODO we should never be returning Runtime.t, but more specific types *)
+
+  val file_read_all : string -> string
+  val fd_read_all : Core_unix.File_descr.t -> (Runtime.t, string) Result.t
+  val fd_write_all : Core_unix.File_descr.t -> string -> (unit, string) Result.t
+
+  (* TODO does this type of `data` need to be more generic to support binary? *)
+  val write : Core_unix.File_descr.t -> data:string -> (unit, string) Result.t
+  val read : Core_unix.File_descr.t -> (Runtime.t, string) Result.t
+  val wait : Runtime.process_handle -> (Runtime.t, string) Result.t
+
+  val pipe : unit -> Core_unix.File_descr.t * Core_unix.File_descr.t
+  (** unit -> read * write *)
+
+  val open_file :
+    mode:Core_unix.open_flag list ->
+    string ->
+    (Core_unix.File_descr.t, string) Result.t
+
+  val close : Core_unix.File_descr.t -> (unit, string) Result.t
+
+  val proc_exec :
+    mode:processMode ->
+    Runtime.process ->
+    string array ->
+    (Runtime.t, string) Result.t
+
+  val chdir : string -> (unit, string) Result.t
+  val directory_exists : string -> bool
+  val file_exists : string -> bool
+  val mkdir : string -> unit
+  val realpath : string -> string
+end

lib/interpreter/stdlib_impl.ml

@@ -37,7 +37,7 @@ let make_method ~arity ~name cb =
  fun self -> Ok (make_native_func ~arity ~name (cb self))
 
 let make_ids m =
-  let module M = (val m : Native.Sig) in
+  let module M = (val m : Native_sig.Sig) in
   [
     ( "print",
       make_native_func ~arity:(Some 1) ~name:"print" (fun ctx _ args ->
@@ -114,7 +114,7 @@ let make_ids m =
   ]
 
 let make_protos m =
-  let module M = (val m : Native.Sig) in
+  let module M = (val m : Native_sig.Sig) in
   [
     {
       name = "List";
@@ -365,7 +365,7 @@ let make_protos m =
                              `HashMap[String]String`, but got %s"
                          @@ Runtime.to_s env)
                 in
-                match M.proc_exec ~mode:Native.ForkBuffer self env with
+                match M.proc_exec ~mode:Native_sig.ForkBuffer self env with
                 | Ok t' -> First t'
                 | Error err -> Second (Runtime.Error (None, String err))) );
           ( "forkInherit",
@@ -388,7 +388,7 @@ let make_protos m =
                              `HashMap[String]String`, but got %s"
                          @@ Runtime.to_s env)
                 in
-                match M.proc_exec ~mode:Native.ForkInherit self env with
+                match M.proc_exec ~mode:Native_sig.ForkInherit self env with
                 | Ok t' -> First t'
                 | Error err -> Second (Runtime.Error (None, String err))) );
           ( "blockBuffer",
@@ -411,7 +411,7 @@ let make_protos m =
                              `HashMap[String]String`, but got %s"
                          @@ Runtime.to_s env)
                 in
-                match M.proc_exec ~mode:Native.BlockBuffer self env with
+                match M.proc_exec ~mode:Native_sig.BlockBuffer self env with
                 | Ok t' -> First t'
                 | Error err -> Second (Runtime.Error (None, String err))) );
           ( "blockInherit",
@@ -434,7 +434,7 @@ let make_protos m =
                              `HashMap[String]String`, but got %s"
                          @@ Runtime.to_s env)
                 in
-                match M.proc_exec ~mode:Native.BlockInherit self env with
+                match M.proc_exec ~mode:Native_sig.BlockInherit self env with
                 | Ok t' -> First t'
                 | Error err -> Second (Runtime.Error (None, String err))) );
           ( "stdout",

lib/interpreter/stdlib_impl.mli

@@ -5,8 +5,8 @@ type proto_t = {
   static_getters : (string * (Runtime.t -> (Runtime.t, string) Result.t)) list;
 }
 
-val make_ids : (module Native.Sig) -> (string * Runtime.t) list
-val make_protos : (module Native.Sig) -> proto_t list
+val make_ids : (module Native_sig.Sig) -> (string * Runtime.t) list
+val make_protos : (module Native_sig.Sig) -> proto_t list
 
 val context_ids :
   cwd:string ->