driver/rule.ml

   1 open Base
   2 exception NoRuleFailure
   3 type filetype = string
   4 type filename = string
   5
   6 type node =
   7     One of filetype
   8   | Many  of filetype list
   9 type ('a,'b) cmd =
  10     'a -> 'b -> filename -> string list
  11 type 'a rule = {
  12   src : node;
  13   dest: filetype;
  14   cmd : 'a -> filename list -> filename -> string list
  15 }
  16 type 'a t  = 'a rule
  17
  18 let one_to_one src dest cmd = {
  19   src  = One src;
  20   dest = dest;
  21   cmd  = (fun a -> function [x] -> cmd a x | _ -> invalid_arg "")
  22 }
  23
  24 let many_to_one src dest cmd = {
  25   src  = Many src;
  26   dest = dest;
  27   cmd  = cmd
  28 }
  29
  30 let is_reach dest {dest=dest'} =
  31   match dest with
  32       One x ->
  33         x = dest'
  34     | Many xs ->
  35         xs = [dest']
  36
  37 let reachable dest rs =
  38   rs +> List.filter (is_reach dest)
  39
  40 let minimum_by f xs =
  41   let min a b =
  42     if f a b then a else b in
  43     match xs with
  44       | [] ->
  45           invalid_arg "empty list"
  46     | y::ys ->
  47         List.fold_left min y ys
  48
  49 let rec shortest rs src dest =
  50   match src,dest with
  51       One x,One y when x = y ->
  52         Some []
  53     | One x,Many ys when [x] = ys ->
  54         Some []
  55     | One _,One _ | Many _,Many _| One _,Many _ | Many _,One _ ->
  56         let shortests =
  57           reachable dest rs +>
  58             HList.concat_map (fun r ->
  59                                 match shortest rs src r.src with
  60                                     None -> []
  61                                   | Some rs -> [r::rs]) in
  62           if shortests = [] then
  63             None
  64           else
  65             Some (minimum_by (fun a b -> List.length a < List.length b) shortests)
  66
  67 let suffix x =
  68   let regexp =
  69     Str.regexp ".*\\.\\(.*\\)$" in
  70     if Str.string_match regexp x 0 then
  71       Str.matched_group 1 x
  72     else
  73       invalid_arg "no suffix"
  74
  75 let tmp name s =
  76   Printf.sprintf "%s%s"
  77     (Filename.chop_suffix name (suffix name))
  78     s
  79
  80 let route rs inputs output =
  81   let src =
  82     match inputs with
  83         [x] ->
  84           One (suffix x)
  85       | xs  ->
  86           Many (xs +> List.map suffix +> List.sort compare +>
  87             ExtList.List.unique) in
  88   let dest =
  89     One (suffix output) in
  90     shortest rs src dest
  91
  92 let commands ctx rs inputs output =
  93   match route rs inputs output with
  94       None ->
  95         raise NoRuleFailure
  96     | Some r ->
  97         r +> List.rev +> map_accum_left
  98           (fun inputs' {dest=dest; cmd=cmd} ->
  99              [tmp output dest],cmd ctx inputs' @@ tmp output dest)
 100           inputs +>
 101           snd +>
 102           List.concat
 103
 104 let temp_files ctx rs inputs output =
 105   match route rs inputs output with
 106     | None | Some [] | Some [_] ->
 107         []
 108     | Some (_::rs) ->
 109         List.map
 110           (fun {dest=dest} ->
 111              tmp output dest) rs