driver/rule.ml

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