Refactoring

src/action.ml

@@ -53,91 +53,120 @@ let expand_prog ctx ~dir ~f template =
       |> String.concat ~sep:" "
       |> resolve
 
-module Ast = struct
+module Outputs = struct
-  type outputs =
+  include Action_intf.Outputs
-    | Stdout
-    | Stderr
-    | Outputs (* Both Stdout and Stderr *)
 
-  let string_of_outputs = function
+  let to_string = function
     | Stdout -> "stdout"
     | Stderr -> "stderr"
     | Outputs -> "outputs"
+end
 
-  type ('a, 'path) t =
+module type Sexpable = sig
-    | Run            of 'path * 'a list
+  type t
-    | Chdir          of 'path * ('a, 'path) t
+  val t : t Sexp.Of_sexp.t
-    | Setenv         of 'a * 'a * ('a, 'path) t
+  val sexp_of_t : t Sexp.To_sexp.t
-    | Redirect       of outputs * 'path * ('a, 'path) t
+end
-    | Ignore         of outputs * ('a, 'path) t
-    | Progn          of ('a, 'path) t list
-    | Echo           of 'a
-    | Create_file    of 'path
-    | Cat            of 'path
-    | Copy           of 'path * 'path
-    | Symlink        of 'path * 'path
-    | Copy_and_add_line_directive of 'path * 'path
-    | System         of 'a
-    | Bash           of 'a
-    | Update_file    of 'path * 'a
-    | Rename         of 'path * 'path
-    | Remove_tree    of 'path
 
-  let rec t a p sexp =
+module Make_ast
+    (Path   : Sexpable)
+    (String : Sexpable)
+    (Ast : Action_intf.Ast
+     with type path   := Path.t
+     with type string := String.t) =
+struct
+  include Ast
+
+  let rec t sexp =
+    let path = Path.t and string = String.t in
     sum
-      [ cstr_rest "run" (p @> nil) a             (fun prog args -> Run (prog, args))
+      [ cstr_rest "run" (path @> nil) string             (fun prog args -> Run (prog, args))
-      ; cstr "chdir"    (p @> t a p @> nil)        (fun dn t -> Chdir (dn, t))
+      ; cstr "chdir"    (path @> t @> nil)        (fun dn t -> Chdir (dn, t))
-      ; cstr "setenv"   (a @> a @> t a p @> nil)   (fun k v t -> Setenv (k, v, t))
+      ; cstr "setenv"   (string @> string @> t @> nil)   (fun k v t -> Setenv (k, v, t))
-      ; cstr "with-stdout-to"  (p @> t a p @> nil) (fun fn t -> Redirect (Stdout, fn, t))
+      ; cstr "with-stdout-to"  (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t))
-      ; cstr "with-stderr-to"  (p @> t a p @> nil) (fun fn t -> Redirect (Stderr, fn, t))
+      ; cstr "with-stderr-to"  (path @> t @> nil) (fun fn t -> Redirect (Stderr, fn, t))
-      ; cstr "with-outputs-to" (p @> t a p @> nil) (fun fn t -> Redirect (Outputs, fn, t))
+      ; cstr "with-outputs-to" (path @> t @> nil) (fun fn t -> Redirect (Outputs, fn, t))
-      ; cstr "ignore-stdout"   (t a p @> nil)      (fun t -> Ignore (Stdout, t))
+      ; cstr "ignore-stdout"   (t @> nil)      (fun t -> Ignore (Stdout, t))
-      ; cstr "ignore-stderr"   (t a p @> nil)      (fun t -> Ignore (Stderr, t))
+      ; cstr "ignore-stderr"   (t @> nil)      (fun t -> Ignore (Stderr, t))
-      ; cstr "ignore-outputs"  (t a p @> nil)      (fun t -> Ignore (Outputs, t))
+      ; cstr "ignore-outputs"  (t @> nil)      (fun t -> Ignore (Outputs, t))
-      ; cstr_rest "progn"      nil (t a p)         (fun l -> Progn l)
+      ; cstr_rest "progn"      nil t         (fun l -> Progn l)
-      ; cstr "echo"           (a @> nil)         (fun x -> Echo x)
+      ; cstr "echo"           (string @> nil)         (fun x -> Echo x)
-      ; cstr "cat"            (p @> nil)         (fun x -> Cat x)
+      ; cstr "cat"            (path @> nil)         (fun x -> Cat x)
-      ; cstr "create-file"    (p @> nil)         (fun x -> Create_file x)
+      ; cstr "create-file"    (path @> nil)         (fun x -> Create_file x)
-      ; cstr "copy" (p @> p @> nil)              (fun src dst -> Copy (src, dst))
+      ; cstr "copy" (path @> path @> nil)              (fun src dst -> Copy (src, dst))
       (*
          (* We don't expose symlink to the user yet since this might complicate things *)
          ; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
       *)
-      ; cstr "copy-and-add-line-directive" (p @> p @> nil) (fun src dst ->
+      ; cstr "copy-and-add-line-directive" (path @> path @> nil) (fun src dst ->
           Copy_and_add_line_directive (src, dst))
-      ; cstr "system" (a @> nil) (fun cmd -> System cmd)
+      ; cstr "system" (string @> nil) (fun cmd -> System cmd)
-      ; cstr "bash"   (a @> nil) (fun cmd -> Bash   cmd)
+      ; cstr "bash"   (string @> nil) (fun cmd -> Bash   cmd)
       ]
       sexp
 
-  let rec sexp_of_t f g : _ -> Sexp.t = function
+  let rec sexp_of_t : _ -> Sexp.t =
-    | Run (a, xs) -> List (Atom "run" :: g a :: List.map xs ~f)
+    let path = Path.sexp_of_t and string = String.sexp_of_t in
-    | Chdir (a, r) -> List [Atom "chdir" ; g a ; sexp_of_t f g r]
+    function
-    | Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f g r]
+    | Run (a, xs) -> List (Atom "run" :: path a :: List.map xs ~f:string)
+    | Chdir (a, r) -> List [Atom "chdir" ; path a ; sexp_of_t r]
+    | Setenv (k, v, r) -> List [Atom "setenv" ; string k ; string v ; sexp_of_t r]
     | Redirect (outputs, fn, r) ->
-      List [ Atom (sprintf "with-%s-to" (string_of_outputs outputs))
+      List [ Atom (sprintf "with-%s-to" (Outputs.to_string outputs))
-           ; g fn
+           ; path fn
-           ; sexp_of_t f g r
+           ; sexp_of_t r
            ]
     | Ignore (outputs, r) ->
-      List [ Atom (sprintf "ignore-%s" (string_of_outputs outputs))
+      List [ Atom (sprintf "ignore-%s" (Outputs.to_string outputs))
-           ; sexp_of_t f g r
+           ; sexp_of_t r
            ]
-    | Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f g))
+    | Progn l -> List (Atom "progn" :: List.map l ~f:sexp_of_t)
-    | Echo x -> List [Atom "echo"; f x]
+    | Echo x -> List [Atom "echo"; string x]
-    | Cat x -> List [Atom "cat"; g x]
+    | Cat x -> List [Atom "cat"; path x]
-    | Create_file x -> List [Atom "create-file"; g x]
+    | Create_file x -> List [Atom "create-file"; path x]
     | Copy (x, y) ->
-      List [Atom "copy"; g x; g y]
+      List [Atom "copy"; path x; path y]
     | Symlink (x, y) ->
-      List [Atom "symlink"; g x; g y]
+      List [Atom "symlink"; path x; path y]
     | Copy_and_add_line_directive (x, y) ->
-      List [Atom "copy-and-add-line-directive"; g x; g y]
+      List [Atom "copy-and-add-line-directive"; path x; path y]
-    | System x -> List [Atom "system"; f x]
+    | System x -> List [Atom "system"; string x]
-    | Bash   x -> List [Atom "bash"; f x]
+    | Bash   x -> List [Atom "bash"; string x]
-    | Update_file (x, y) -> List [Atom "update-file"; g x; f y]
+    | Update_file (x, y) -> List [Atom "update-file"; path x; string y]
-    | Rename (x, y) -> List [Atom "rename"; g x; g y]
+    | Rename (x, y) -> List [Atom "rename"; path x; path y]
-    | Remove_tree x -> List [Atom "remove-tree"; g x]
+    | Remove_tree x -> List [Atom "remove-tree"; path x]
+end
+
+module type Ast = Action_intf.Ast
+  with type path   := Path.t
+  with type string := String.t
+module rec Ast : Ast = Ast
+
+include Make_ast
+    (Path)
+    (struct
+      type t = string
+      let t = Sexp.Of_sexp.string
+      let sexp_of_t = Sexp.To_sexp.string
+    end)
+    (Ast)
+
+type action = t
+
+module Unexpanded = struct
+  module type Ast = Action_intf.Ast
+    with type path   := String_with_vars.t
+    with type string := String_with_vars.t
+  module rec Ast : Ast = Ast
+
+  include Make_ast(String_with_vars)(String_with_vars)(Ast)
+
+  let t sexp =
+    match sexp with
+    | Atom _ ->
+      of_sexp_errorf sexp
+        "if you meant for this to be executed with bash, write (bash \"...\") instead"
+    | List _ -> t sexp
 
   let rec fold t ~init:acc ~f =
     match t with
@@ -159,99 +188,11 @@ module Ast = struct
     | Rename (x, y) -> f (f acc x) y
     | Remove_tree x -> f acc x
 
-  let fold_one_step t ~init:acc ~f =
-    match t with
-    | Chdir (_, t)
-    | Setenv (_, _, t)
-    | Redirect (_, _, t)
-    | Ignore (_, t) -> f acc t
-    | Progn l -> List.fold_left l ~init:acc ~f
-    | Run _
-    | Echo _
-    | Cat _
-    | Create_file _
-    | Copy _
-    | Symlink _
-    | Copy_and_add_line_directive _
-    | System _
-    | Bash _
-    | Update_file _
-    | Rename _
-    | Remove_tree _ -> acc
-
-  let rec map
-    : 'a 'b 'c 'd. ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t
-    = fun t ~f1 ~f2 ->
-      match t with
-      | Run (prog, args) ->
-        Run (f2 prog, List.map args ~f:f1)
-      | Chdir (fn, t) ->
-        Chdir (f2 fn, map t ~f1 ~f2)
-      | Setenv (var, value, t) ->
-        Setenv (f1 var, f1 value, map t ~f1 ~f2)
-      | Redirect (outputs, fn, t) ->
-        Redirect (outputs, f2 fn, map t ~f1 ~f2)
-      | Ignore (outputs, t) ->
-        Ignore (outputs, map t ~f1 ~f2)
-      | Progn l -> Progn (List.map l ~f:(fun t -> map t ~f1 ~f2))
-      | Echo x -> Echo (f1 x)
-      | Cat x -> Cat (f2 x)
-      | Create_file x -> Create_file (f2 x)
-      | Copy (x, y) -> Copy (f2 x, f2 y)
-      | Symlink (x, y) ->
-        Symlink (f2 x, f2 y)
-      | Copy_and_add_line_directive (x, y) ->
-        Copy_and_add_line_directive (f2 x, f2 y)
-      | System x -> System (f1 x)
-      | Bash x -> Bash (f1 x)
-      | Update_file (x, y) -> Update_file (f2 x, f1 y)
-      | Rename (x, y) -> Rename (f2 x, f2 y)
-      | Remove_tree x -> Remove_tree (f2 x)
-end
-open Ast
-
-type t = (string, Path.t) Ast.t
-let t = Ast.t string Path.t
-let sexp_of_t = Ast.sexp_of_t Sexp.To_sexp.string Path.sexp_of_t
-
-let updated_files =
-  let rec loop acc t =
-    let acc =
-      match t with
-      | Update_file (fn, _) -> Path.Set.add fn acc
-      | _ -> acc
-    in
-    Ast.fold_one_step t ~init:acc ~f:loop
-  in
-  fun t -> loop Path.Set.empty t
-
-let chdirs =
-  let rec loop acc t =
-    let acc =
-      match t with
-      | Chdir (dir, _) -> Path.Set.add dir acc
-      | _ -> acc
-    in
-    Ast.fold_one_step t ~init:acc ~f:loop
-  in
-  fun t -> loop Path.Set.empty t
-
-module Unexpanded = struct
-  type t = (String_with_vars.t, String_with_vars.t) Ast.t
-  let sexp_of_t = Ast.sexp_of_t String_with_vars.sexp_of_t String_with_vars.sexp_of_t
-
-  let t sexp =
-    match sexp with
-    | Atom _ ->
-      of_sexp_errorf sexp
-        "if you meant for this to be executed with bash, write (bash \"...\") instead"
-    | List _ -> Ast.t String_with_vars.t String_with_vars.t sexp
-
   let fold_vars t ~init ~f =
-    Ast.fold t ~init ~f:(fun acc pat ->
+    fold t ~init ~f:(fun acc pat ->
       String_with_vars.fold ~init:acc pat ~f)
 
-  let rec expand ctx dir t ~f : (string, Path.t) Ast.t =
+  let rec expand ctx dir t ~f : action =
     match t with
     | Run (prog, args) ->
       Run (expand_prog ctx ~dir ~f prog,
@@ -285,6 +226,75 @@ module Unexpanded = struct
       Remove_tree (expand_path ~dir ~f x)
 end
 
+let fold_one_step t ~init:acc ~f =
+  match t with
+  | Chdir (_, t)
+  | Setenv (_, _, t)
+  | Redirect (_, _, t)
+  | Ignore (_, t) -> f acc t
+  | Progn l -> List.fold_left l ~init:acc ~f
+  | Run _
+  | Echo _
+  | Cat _
+  | Create_file _
+  | Copy _
+  | Symlink _
+  | Copy_and_add_line_directive _
+  | System _
+  | Bash _
+  | Update_file _
+  | Rename _
+  | Remove_tree _ -> acc
+
+let rec map t ~fs ~fp =
+    match t with
+    | Run (prog, args) ->
+      Run (fp prog, List.map args ~f:fs)
+    | Chdir (fn, t) ->
+      Chdir (fp fn, map t ~fs ~fp)
+    | Setenv (var, value, t) ->
+      Setenv (fs var, fs value, map t ~fs ~fp)
+    | Redirect (outputs, fn, t) ->
+      Redirect (outputs, fp fn, map t ~fs ~fp)
+    | Ignore (outputs, t) ->
+      Ignore (outputs, map t ~fs ~fp)
+    | Progn l -> Progn (List.map l ~f:(fun t -> map t ~fs ~fp))
+    | Echo x -> Echo (fs x)
+    | Cat x -> Cat (fp x)
+    | Create_file x -> Create_file (fp x)
+    | Copy (x, y) -> Copy (fp x, fp y)
+    | Symlink (x, y) ->
+      Symlink (fp x, fp y)
+    | Copy_and_add_line_directive (x, y) ->
+      Copy_and_add_line_directive (fp x, fp y)
+    | System x -> System (fs x)
+    | Bash x -> Bash (fs x)
+    | Update_file (x, y) -> Update_file (fp x, fs y)
+    | Rename (x, y) -> Rename (fp x, fp y)
+    | Remove_tree x -> Remove_tree (fp x)
+
+let updated_files =
+  let rec loop acc t =
+    let acc =
+      match t with
+      | Update_file (fn, _) -> Path.Set.add fn acc
+      | _ -> acc
+    in
+    fold_one_step t ~init:acc ~f:loop
+  in
+  fun t -> loop Path.Set.empty t
+
+let chdirs =
+  let rec loop acc t =
+    let acc =
+      match t with
+      | Chdir (dir, _) -> Path.Set.add dir acc
+      | _ -> acc
+    in
+    fold_one_step t ~init:acc ~f:loop
+  in
+  fun t -> loop Path.Set.empty t
+
 open Future
 
 let get_std_output : _ -> Future.std_output_to = function
@@ -421,14 +431,14 @@ let exec ~targets ?context t =
     ~stdout_to:None ~stderr_to:None
 
 let sandbox t ~sandboxed ~deps ~targets =
-  Ast.Progn
+  Progn
-    [ Ast.Progn (List.filter_map deps ~f:(fun path ->
+    [ Progn (List.filter_map deps ~f:(fun path ->
         if Path.is_local path then
           Some (Ast.Symlink (path, sandboxed path))
         else
           None))
-    ; Ast.map t ~f1:(fun x -> x) ~f2:sandboxed
+    ; map t ~fs:(fun x -> x) ~fp:sandboxed
-    ; Ast.Progn (List.filter_map targets ~f:(fun path ->
+    ; Progn (List.filter_map targets ~f:(fun path ->
         if Path.is_local path then
           Some (Ast.Rename (sandboxed path, path))
         else

src/action.mli

@@ -6,36 +6,12 @@ type var_expansion =
   | Paths of Path.t list
   | Str   of string
 
-module Ast : sig
+module Outputs : module type of struct include Action_intf.Outputs end
-  type outputs =
-    | Stdout
-    | Stderr
-    | Outputs (** Both Stdout and Stderr *)
 
-  type ('a, 'path) t =
+include Action_intf.Ast
-    | Run            of 'path * 'a list
+  with type path   := Path.t
-    | Chdir          of 'path * ('a, 'path) t
+  with type string := string
-    | Setenv         of 'a * 'a * ('a, 'path) t
-    | Redirect       of outputs * 'path * ('a, 'path) t
-    | Ignore         of outputs * ('a, 'path) t
-    | Progn          of ('a, 'path) t list
-    | Echo           of 'a
-    | Create_file    of 'path
-    | Cat            of 'path
-    | Copy           of 'path * 'path
-    | Symlink        of 'path * 'path
-    | Copy_and_add_line_directive of 'path * 'path
-    | System         of 'a
-    | Bash           of 'a
-    | Update_file    of 'path * 'a
-    | Rename         of 'path * 'path
-    | Remove_tree    of 'path
 
-  val t : 'a Sexp.Of_sexp.t -> 'b Sexp.Of_sexp.t -> ('a, 'b) t Sexp.Of_sexp.t
-  val sexp_of_t : 'a Sexp.To_sexp.t -> 'b Sexp.To_sexp.t -> ('a, 'b) t Sexp.To_sexp.t
-end
-
-type t = (string, Path.t) Ast.t
 val t : t Sexp.Of_sexp.t
 val sexp_of_t : t Sexp.To_sexp.t
 
@@ -46,13 +22,17 @@ val updated_files : t -> Path.Set.t
 val chdirs : t -> Path.Set.t
 
 module Unexpanded : sig
-  type desc = t
+  type action = t
-  type t = (String_with_vars.t, String_with_vars.t) Ast.t
+
+  include Action_intf.Ast
+    with type path   := String_with_vars.t
+    with type string := String_with_vars.t
+
   val t : t Sexp.Of_sexp.t
   val sexp_of_t : t Sexp.To_sexp.t
   val fold_vars : t -> init:'a -> f:('a -> Loc.t -> string -> 'a) -> 'a
-  val expand : Context.t -> Path.t -> t -> f:(string -> var_expansion) -> desc
+  val expand : Context.t -> Path.t -> t -> f:(string -> var_expansion) -> action
-end with type desc := t
+end with type action := t
 
 val exec : targets:Path.Set.t -> ?context:Context.t -> t -> unit Future.t
 

src/action_intf.ml

@@ -27,7 +27,5 @@ module type Ast = sig
     | Update_file    of path * string
     | Rename         of path * path
     | Remove_tree    of path
-    | Try_run        of path * string list * t
-    | Located_error  of path * int * int * int * string
 end
 

src/build.ml

@@ -207,21 +207,21 @@ let run ~context ?(dir=context.Context.build_dir) ?stdout_to ?(extra_targets=[])
       | None      -> action
       | Some path -> Redirect (Stdout, path, action)
     in
-    Action.Ast.Chdir (dir, action))
+    Action.Chdir (dir, action))
 
 let action ?dir ~targets action =
   Targets targets
   >>^ fun _ ->
   match dir with
   | None -> action
-  | Some dir -> Action.Ast.Chdir (dir, action)
+  | Some dir -> Action.Chdir (dir, action)
 
 let action_dyn ?dir ~targets () =
   Targets targets
   >>^ fun action ->
   match dir with
   | None -> action
-  | Some dir -> Action.Ast.Chdir (dir, action)
+  | Some dir -> Action.Chdir (dir, action)
 
 let update_file fn s =
   action ~targets:[fn] (Update_file (fn, s))
@@ -229,7 +229,7 @@ let update_file fn s =
 let update_file_dyn fn =
   Targets [fn]
   >>^ fun s ->
-  Action.Ast.Update_file (fn, s)
+  Action.Update_file (fn, s)
 
 let copy ~src ~dst =
   path src >>>
@@ -243,8 +243,8 @@ let create_file fn =
   action ~targets:[fn] (Create_file fn)
 
 let remove_tree dir =
-  arr (fun _ -> Action.Ast.Remove_tree dir)
+  arr (fun _ -> Action.Remove_tree dir)
 
 let progn ts =
   all ts >>^ fun actions ->
-  Action.Ast.Progn actions
+  Action.Progn actions