Implements command generator

diff --git a/driver/rule.ml b/driver/rule.ml
index ddb121d..0258565 100644 (file)
--- a/driver/rule.ml
+++ b/driver/rule.ml
@@ -2,31 +2,37 @@ open Base
 exception NoRuleFailure
 type filetype = string
 type filename = string
-type file = filename * filetype
-
-type 'a cmd = 'a -> filename -> string list
 
 type node =
     One of filetype
   | Many  of filetype list
-
+type ('a,'b) cmd =
+    'a -> 'b -> filename -> string list
 type 'a rule = {
   src : node;
-  dest: node;
-  cmd : 'a -> filename list -> filename list
+  dest: filetype;
+  cmd : 'a -> filename list -> filename -> string list
 }
 type 'a t  = 'a rule
 
+let one_to_one src dest cmd = {
+  src  = One src;
+  dest = dest;
+  cmd  = (fun a -> function [x] -> cmd a x | _ -> invalid_arg "")
+}
+
+let many_to_one src dest cmd = {
+  src  = Many src;
+  dest = dest;
+  cmd  = cmd
+}
+
 let is_reach dest {dest=dest'} =
-  match dest,dest' with
-      One x, One y ->
-       x = y
-    | Many xs, Many ys ->
-       xs = ys
-    | One _ , Many _ ->
-       false
-    | Many xs, One y ->
-       xs = [y]
+  match dest with
+      One x ->
+       x = dest'
+    | Many xs ->
+       xs = [dest']
 
 let reachable dest rs =
   rs +> List.filter (is_reach dest)
@@ -41,24 +47,62 @@ let minimum_by f xs =
        List.fold_left min y ys
 
 let rec route rs src dest =
-  if src = dest then
-    Some []
-  else
-    let routes =
-      reachable dest rs +>
-       HList.concat_map (fun r ->
-                           match route rs src r.src with
-                               None -> []
-                             | Some rs -> [r::rs]) in
-      if routes = [] then
-       None
-      else
-       Some (minimum_by (fun a b -> List.length a < List.length b) routes)
+  match src,dest with
+      One x,One y when x = y ->
+       Some []
+    | One x,Many ys when [x] = ys ->
+       Some []
+    | One _,One _ | Many _,Many _| One _,Many _ | Many _,One _ ->
+       let routes =
+         reachable dest rs +>
+           HList.concat_map (fun r ->
+                               match route rs src r.src with
+                                   None -> []
+                                 | Some rs -> [r::rs]) in
+         if routes = [] then
+           None
+         else
+           Some (minimum_by (fun a b -> List.length a < List.length b) routes)
 
 let rules = [
-  {src=One ".c";dest=One ".o";cmd=fun _ _ -> []};
-  {src=Many [".c"];dest=One ".s";cmd=fun _ _ -> []};
-  {src=Many [".o"];dest=One ".s";cmd=fun _ _ -> []};
-  {src=Many [".c";".o"];dest=One ".s";cmd=fun _ _ -> []};
-  {src=One ".s";dest=One ".exe";cmd=fun _ _ -> []};
+  {src=One ".c";dest=".o";cmd=fun _ _ _ -> []};
+  {src=Many [".c"];dest=".s";cmd=fun _ _ _ -> []};
+  {src=Many [".o"];dest=".s";cmd=fun _ _ _-> []};
+  {src=Many [".c";".o"];dest=".s";cmd=fun _ _ _-> []};
+  {src=One ".s";dest=".exe";cmd=fun _ _ _-> []};
 ]
+
+let suffix x =
+  let regexp =
+    Str.regexp ".*\\.\\(.*\\)$" in
+    if Str.string_match regexp x 0 then
+      Str.matched_group 1 x
+    else
+      invalid_arg "no suffix"
+
+
+let tmp name suffix =
+  Printf.sprintf "%s.%s" name suffix
+
+
+
+let comands ctx rs inputs output =
+  let src =
+    match inputs with
+       [x] ->
+         One (suffix x)
+      | xs  ->
+         Many (xs +> List.map suffix +> List.sort compare +>
+           ExtList.List.unique) in
+  let dest =
+    One (suffix output) in
+    match route rs src dest with
+       None ->
+         raise NoRuleFailure
+      | Some r ->
+         r +> map_accum_left
+           (fun inputs' {dest=dest; cmd=cmd} ->
+              [tmp output dest],cmd ctx inputs' @@ tmp output dest)
+           inputs +>
+           snd +>
+           List.concat

diff --git a/driver/rule.mli b/driver/rule.mli
index 7f56a63..f9d473b 100644 (file)
--- a/driver/rule.mli
+++ b/driver/rule.mli
@@ -1,5 +1,8 @@
 type filetype = string
 type filename = string
-type file = filename * filetype
+type ('a,'b) cmd = 'a -> 'b -> filename -> string list
 type 'a t
 
+val one_to_one : filetype -> filetype -> ('a,filename) cmd -> 'a t
+val many_to_one : filetype list -> filetype -> ('a,filename list) cmd -> 'a t
+val comands : 'a -> 'a t list -> filename list -> filename -> string list