l4/pkg/ocaml/contrib/ocamlbuild/ocaml_arch.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12
  13 (* Original author: Nicolas Pouillard *)
  14 open My_std
  15 open Command
  16 open Pathname.Operators
  17
  18 type 'a arch =
  19   | Arch_dir of string * 'a * 'a arch list
  20   | Arch_dir_pack of string * 'a * 'a arch list
  21   | Arch_file of string * 'a
  22
  23 let dir name contents = Arch_dir(name, (), contents)
  24 let dir_pack name contents = Arch_dir_pack(name, (), contents)
  25 let file name = Arch_file(name, ())
  26
  27 type info =
  28 {
  29   current_path : string;
  30   include_dirs : string list;
  31   for_pack     : string;
  32 }
  33
  34 let join_pack parent base =
  35   if parent = "" then base else parent ^ "." ^ base
  36
  37 let annotate arch =
  38   let rec self arch acc =
  39     match arch with
  40     | Arch_dir_pack(name, _, contents) ->
  41         let acc = { (acc) with for_pack = join_pack acc.for_pack name } in
  42         let (_, _, i, new_contents) = self_contents name contents acc in
  43         ([], Arch_dir_pack(name, i, List.rev new_contents))
  44     | Arch_dir(name, _, contents) ->
  45         let (current_path, include_dirs, i, new_contents) = self_contents name contents acc in
  46         (current_path :: include_dirs, Arch_dir(name, i, List.rev new_contents))
  47     | Arch_file(name, _) ->
  48         ([], Arch_file(name, acc))
  49   and self_contents name contents acc =
  50     let current_path = acc.current_path/name in
  51     let include_dirs = if current_path = "" then acc.include_dirs else current_path :: acc.include_dirs in
  52     let i = { (acc) with current_path = current_path; include_dirs = include_dirs } in
  53     let (include_dirs, new_contents) =
  54       List.fold_left begin fun (include_dirs, new_contents) x ->
  55         let j = { (i) with include_dirs = include_dirs @ i.include_dirs } in
  56         let (include_dirs', x') = self x j in
  57         (include_dirs @ include_dirs', x' :: new_contents)
  58       end ([], []) contents in
  59     (current_path, include_dirs, i, new_contents) in
  60   let init = { current_path = ""; include_dirs = []; for_pack = "" } in
  61   snd (self arch init)
  62
  63 let rec print print_info f =
  64   let rec print_contents f =
  65     function
  66     | [] -> ()
  67     | x :: xs -> Format.fprintf f "@ %a%a" (print print_info) x print_contents xs in
  68   function
  69   | Arch_dir(name, info, contents) ->
  70       Format.fprintf f "@[<v2>dir %S%a%a@]" name print_info info print_contents contents
  71   | Arch_dir_pack(name, info, contents) ->
  72       Format.fprintf f "@[<v2>dir_pack %S%a%a@]" name print_info info print_contents contents
  73   | Arch_file(name, info) ->
  74       Format.fprintf f "@[<2>file %S%a@]" name print_info info
  75
  76 let print_include_dirs = List.print String.print
  77
  78 let print_info f i =
  79   Format.fprintf f "@ @[<v2>{ @[<2>current_path =@ %S@];@\
  80                             \ @[<2>include_dirs =@ %a@];@\
  81                             \ @[<2>for_pack =@ %S@] }@]"
  82                  i.current_path print_include_dirs i.include_dirs i.for_pack
  83
  84 let rec iter_info f =
  85   function
  86   | Arch_dir_pack(_, i, xs) | Arch_dir(_, i, xs) ->
  87       f i; List.iter (iter_info f) xs
  88   | Arch_file(_, i) -> f i
  89
  90 let rec fold_info f arch acc =
  91   match arch with
  92   | Arch_dir_pack(_, i, xs) | Arch_dir(_, i, xs) ->
  93       List.fold_right (fold_info f) xs (f i acc)
  94   | Arch_file(_, i) -> f i acc
  95
  96 module SS = Set.Make(String)
  97
  98 let iter_include_dirs arch =
  99   let set = fold_info (fun i -> List.fold_right SS.add i.include_dirs) arch SS.empty in
 100   fun f -> SS.iter f set
 101
 102 let forpack_flags_of_pathname = ref (fun _ -> N)
 103
 104 let print_table print_value f table =
 105   Format.fprintf f "@[<hv0>{:@[<hv0>";
 106   Hashtbl.iter begin fun k v ->
 107     if k <> "" then
 108       Format.fprintf f "@ @[<2>%S =>@ %a@];" k print_value v;
 109   end table;
 110   Format.fprintf f "@]@ :}@]"
 111
 112 let print_tables f (include_dirs_table, for_pack_table) =
 113   Format.fprintf f "@[<2>@[<2>include_dirs_table:@ %a@];@ @[<2>for_pack_table: %a@]@]"
 114      (print_table (List.print String.print)) include_dirs_table
 115      (print_table String.print) for_pack_table
 116
 117 let mk_tables arch =
 118   let include_dirs_table = Hashtbl.create 17
 119   and for_pack_table = Hashtbl.create 17 in
 120   iter_info begin fun i ->
 121     Hashtbl.replace include_dirs_table i.current_path i.include_dirs;
 122     Hashtbl.replace for_pack_table i.current_path i.for_pack
 123   end arch;
 124   let previous_forpack_flags_of_pathname = !forpack_flags_of_pathname in
 125   forpack_flags_of_pathname := begin fun m ->
 126     let m' = Pathname.dirname m in
 127     try
 128       let for_pack = Hashtbl.find for_pack_table m' in
 129       if for_pack = "" then N else S[A"-for-pack"; A for_pack]
 130     with Not_found -> previous_forpack_flags_of_pathname m
 131   end;
 132   (* Format.eprintf "@[<2>%a@]@." print_tables (include_dirs_table, for_pack_table); *)
 133   (include_dirs_table, for_pack_table)
 134
 135 let forpack_flags_of_pathname m = !forpack_flags_of_pathname m