Add dune compute to call internal functions

Signed-off-by: Rudi Horn <[email protected]>
Signed-off-by: Jeremie Dimino <[email protected]>

Author: Rudi Horn

CHANGES.md

@@ -33,6 +33,9 @@ unreleased
 - Get the correct environment node for multi project workspaces (#1648,
   @rgrinberg)
 
+- Add `dune compute` to call internal memoized functions (#1528,
+  @rudihorn, @diml)
+
 1.6.2 (05/12/2018)
 ------------------
 

bin/main.ml

@@ -363,6 +363,71 @@ let external_lib_deps =
   in
   (term, Term.info "external-lib-deps" ~doc ~man)
 
+let compute =
+  let doc = "Compute internal function." in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|Run a registered memoize function with the given input and
+           print the output. |}
+    ; `P {|This should only be used for debugging dune.|}
+    ; `Blocks Common.help_secs
+    ]
+  in
+  let term =
+    let%map common = Common.term
+    and fn =
+      Arg.(required
+           & pos 0 (some string) None
+           & info [] ~docv:"FUNCTION"
+               ~doc:"Compute $(docv) for a given input.")
+    and inp =
+      Arg.(required
+           & pos 1 (some string) None
+           & info [] ~docv:"INPUT"
+               ~doc:"Use $(docv) as the input to the function.")
+    in
+    Common.set_common common ~targets:[];
+    let log = Log.create common in
+    let res =
+      Scheduler.go ~log ~common
+        (Main.setup ~log common ~external_lib_deps_mode:true
+         >>= fun _setup ->
+         let sexp =
+           Dune_lang.parse_string
+             ~fname:"<command-line>"
+             ~mode:Dune_lang.Parser.Mode.Single inp
+         in
+         Memo.call fn sexp)
+    in
+    Format.printf "%a\n%!" Sexp.pp res
+  in
+  (term, Term.info "compute" ~doc ~man)
+
+let list_functions =
+  let doc = "List internal functions." in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|Print the list of internal functions that can be used with
+           $(b,dune compute).|}
+    ; `Blocks Common.help_secs
+    ]
+  in
+  let term =
+    let%map common = Common.term in
+    Common.set_common common ~targets:[];
+    let log = Log.create common in
+    let _setup =
+      Scheduler.go ~log ~common
+        (Main.setup ~log common ~external_lib_deps_mode:true)
+    in
+    let fns = Memo.registered_functions () in
+    let longest = String.longest_map fns ~f:(fun info -> info.name) in
+    List.iter fns ~f:(fun { Memo.Function_info.name; doc } ->
+      Printf.printf "%-*s : %s\n" longest name doc);
+    flush stdout
+  in
+  (term, Term.info "list-functions" ~doc ~man)
+
 let rules =
   let doc = "Dump internal rules." in
   let man =
@@ -1187,6 +1252,8 @@ let all =
   ; printenv
   ; Help.help
   ; fmt
+  ; compute
+  ; list_functions
   ]
 
 let default =

doc/dune.inc

@@ -17,6 +17,15 @@
  (package dune)
  (files   dune-clean.1))
 
+(rule
+ (with-stdout-to dune-compute.1
+  (run dune compute --help=groff)))
+
+(install
+ (section man)
+ (package dune)
+ (files   dune-compute.1))
+
 (rule
  (with-stdout-to dune-exec.1
   (run dune exec --help=groff)))
@@ -62,6 +71,15 @@
  (package dune)
  (files   dune-installed-libraries.1))
 
+(rule
+ (with-stdout-to dune-list-functions.1
+  (run dune list-functions --help=groff)))
+
+(install
+ (section man)
+ (package dune)
+ (files   dune-list-functions.1))
+
 (rule
  (with-stdout-to dune-printenv.1
   (run dune printenv --help=groff)))

src/build_system.ml

@@ -89,6 +89,11 @@ module Internal_rule = struct
 
   let loc ~file_tree ~dir t  = rule_loc ~file_tree ~dir ~loc:t.loc
 
+  let decode : t Dune_lang.Decoder.t =
+    let open Dune_lang.Decoder in
+    loc >>= fun loc ->
+    Errors.fail loc "<not-implemented>"
+
   let to_sexp t : Sexp.t =
     Sexp.Encoder.record
       [ "id", Id.to_sexp t.id
@@ -382,7 +387,10 @@ module Action_and_deps = struct
 end
 
 module Rule_fn = Memo.Make(Internal_rule)
-module Path_fn = Memo.Make(Path)
+module Path_fn = Memo.Make(struct
+    include Path
+    let decode = Path_dune_lang.decode
+  end)
 
 type t =
   { (* File specification by targets *)
@@ -1354,15 +1362,18 @@ let create ~contexts ~file_tree ~hook =
   in
   Fdecl.set t.prepare_rule_def
     (Rule_fn.create "prepare-rule" (module Action_and_deps) (prepare_rule t)
+       ~doc:"Evaluate the build arrow part of a rule."
      |> Rule_fn.exec);
   Fdecl.set t.build_rule_def
-    (Rule_fn.create "build-rule" (module Action_and_deps) (build_rule t));
+    (Rule_fn.create "build-rule" (module Action_and_deps) (build_rule t)
+       ~doc:"Execute a rule.");
   Fdecl.set t.build_rule_internal_def
     (Rule_fn.create "build-rule-internal" (module Unit)
-       (build_rule_internal t)
+       (build_rule_internal t) ~doc:"-"
      |> Rule_fn.exec);
   Fdecl.set t.build_file_def
-    (Path_fn.create "build-file" (module Unit) (build_file t));
+    (Path_fn.create "build-file" (module Unit) (build_file t)
+       ~doc:"Build a file.");
   Hooks.End_of_build.once (fun () -> finalize t);
   t
 

src/memo/dune

@@ -1,4 +1,4 @@
 (library
  (name memo)
- (libraries stdune dag fiber)
+ (libraries stdune dune_lang dag fiber)
  (synopsis "Function memoizer"))

src/memo/memo.ml

@@ -1,7 +1,8 @@
 open !Stdune
 open Fiber.O
 
-module type Data = Memo_intf.Data
+module type Input = Memo_intf.Input
+module type Output = Memo_intf.Output
 
 module Function_name = Interned.Make(struct
     let initial_size = 1024
@@ -15,10 +16,22 @@ module Spec = struct
   type ('a, 'b) t =
     { name : Function_name.t
     ; allow_cutoff : bool
-    ; input : (module Data with type t = 'a)
-    ; output : (module Data with type t = 'b)
+    ; input : (module Input with type t = 'a)
+    ; output : (module Output with type t = 'b)
     ; witness : 'a witness
+    ; f : 'a -> 'b Fiber.t
+    ; doc : string
     }
+
+  type packed = T : (_, _) t -> packed [@@unboxed]
+
+  let by_name = Function_name.Table.create ~default_value:None
+
+  let register t =
+    Function_name.Table.set by_name ~key:t.name ~data:(Some (T t))
+
+  let find name =
+    Function_name.Table.get by_name name
 end
 
 module Id = Id.Make()
@@ -104,7 +117,7 @@ module Cached_value = struct
 
   let dep_changed (type a) (node : (_, a) Dep_node.t) prev_output curr_output =
     if node.spec.allow_cutoff then
-      let (module Output : Data with type t = a) = node.spec.output in
+      let (module Output : Output with type t = a) = node.spec.output in
       not (Output.equal prev_output curr_output)
     else
       true
@@ -154,7 +167,7 @@ module Cached_value = struct
 end
 
 let ser_input (type a) (node : (a, _) Dep_node.t) =
-  let (module Input : Data with type t = a) = node.spec.input in
+  let (module Input : Input with type t = a) = node.spec.input in
   Input.to_sexp node.input
 
 let dag_node (dep_node : _ Dep_node.t) = Lazy.force dep_node.dag_node
@@ -209,13 +222,12 @@ let dump_stack v =
   )
   >>| (fun _ -> v)
 
-module Make(Input : Data) : S with type input := Input.t = struct
+module Make(Input : Input) : S with type input := Input.t = struct
   module Table = Hashtbl.Make(Input)
 
   type 'a t =
     { spec  : (Input.t, 'a) Spec.t
     ; cache : (Input.t, 'a) Dep_node.t Table.t
-    ; f     : Input.t -> 'a Fiber.t
     }
 
   type _ Spec.witness += W : Input.t Spec.witness
@@ -242,17 +254,27 @@ module Make(Input : Data) : S with type input := Input.t = struct
       Some (List.map cv.deps ~f:(fun (Last_dep.T (n,_u)) ->
         (Function_name.to_string n.spec.name, ser_input n)))
 
-  let create name ?(allow_cutoff=true) output f =
+  let create name ?(allow_cutoff=true) ~doc output f =
     let name = Function_name.make name in
+    let spec =
+      { Spec.
+        name
+      ; input = (module Input); output
+      ; allow_cutoff
+      ; witness = W
+      ; f
+      ; doc
+      }
+    in
+    Spec.register spec;
     { cache = Table.create 1024
-    ; spec = { name; input = (module Input); output; allow_cutoff; witness = W }
-    ; f
+    ; spec
     }
 
   let compute t inp ivar dep_node =
     (* define the function to update / double check intermediate result *)
     (* set context of computation then run it *)
-    push_stack_frame (T dep_node) (t.f inp) >>= fun res ->
+    push_stack_frame (T dep_node) (t.spec.f inp) >>= fun res ->
     (* update the output cache with the correct value *)
     let deps =
       Dag.children (dag_node dep_node)
@@ -336,3 +358,35 @@ module Make(Input : Data) : S with type input := Input.t = struct
       dep_node.spec.name = of_.spec.name
   end
 end
+
+let call name input =
+  match
+    let open Option.O in
+    Function_name.get name >>= Spec.find
+  with
+  | None -> Exn.fatalf "@{<error>Error@}: function %s doesn't exist!" name
+  | Some (Spec.T spec) ->
+    let (module Input : Input with type t = _) = spec.input in
+    let (module Output : Output with type t = _) = spec.output in
+    let input = Dune_lang.Decoder.parse Input.decode Univ_map.empty input in
+    spec.f input >>| fun output ->
+    Output.to_sexp output
+
+module Function_info = struct
+  type t =
+    { name : string
+    ; doc  : string
+    }
+
+  let of_spec (Spec.T spec) =
+    { name = Function_name.to_string spec.name
+    ; doc = spec.doc
+    }
+end
+
+let registered_functions () =
+  Function_name.all ()
+  |> List.filter_map ~f:(Function_name.Table.get Spec.by_name)
+  |> List.map ~f:Function_info.of_spec
+  |> List.sort ~compare:(fun a b ->
+    String.compare a.Function_info.name b.Function_info.name)

src/memo/memo.mli

@@ -28,9 +28,10 @@ end
 val reset : unit -> unit
 
 module type S = Memo_intf.S with type stack_frame := Stack_frame.t
-module type Data = Memo_intf.Data
+module type Input = Memo_intf.Input
+module type Output = Memo_intf.Output
 
-module Make(Input : Data) : S with type input := Input.t
+module Make(Input : Input) : S with type input := Input.t
 
 (** Print the memoized call stack during execution. This is useful for debugging purposes.
     Example code:
@@ -45,3 +46,16 @@ val dump_stack : 'a -> 'a Fiber.t
 
 (** Get the memoized call stack during the execution of a memoized function. *)
 val get_call_stack : Stack_frame.t list Fiber.t
+
+(** Call a memoized function by name *)
+val call : string -> Dune_lang.Ast.t -> Sexp.t Fiber.t
+
+module Function_info : sig
+  type t =
+    { name : string
+    ; doc  : string
+    }
+end
+
+(** Return the list of registered functions *)
+val registered_functions : unit -> Function_info.t list

src/memo/memo_intf.ml

@@ -7,6 +7,13 @@ module type Data = sig
   val to_sexp : t -> Sexp.t
 end
 
+module type Input = sig
+  include Data
+  val decode : t Dune_lang.Decoder.t
+end
+
+module type Output = Data
+
 module type S = sig
   type input
 
@@ -27,7 +34,8 @@ module type S = sig
   val create
     :  string
     -> ?allow_cutoff:bool
-    -> (module Data with type t = 'a)
+    -> doc:string
+    -> (module Output with type t = 'a)
     -> (input -> 'a Fiber.t)
     -> 'a t
 

src/stdune/interned.ml

@@ -5,6 +5,7 @@ module type S = sig
   val pp: t Fmt.t
   val make : string -> t
   val get : string -> t option
+  val all : unit -> t list
   module Set : sig
     include Set.S with type elt = t
     val make : string list -> t
@@ -89,6 +90,8 @@ module Make(R : Settings)()
 
   let to_string t = Table.get names t
 
+  let all () = List.init ~len:!next ~f:(fun t -> t)
+
   module T = struct
     type nonrec t = int
 
@@ -118,10 +121,12 @@ module No_interning(R : Settings)() = struct
   type t = string
 
   let compare = String.compare
-  let make s = s
+  let all = ref String.Set.empty
+  let make s = all := String.Set.add !all s; s
   let to_string s = s
   let pp fmt s = Format.fprintf fmt "%S" (to_string s)
   let get s = Some s
+  let all () = String.Set.to_list !all
 
   module Set = struct
     include String.Set