l4/pkg/ocaml/ocaml/contrib/ocamlbuild/hygiene.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: Berke Durak *)
  14 (* Hygiene *)
  15 open My_std
  16 open Slurp
  17
  18 exception Exit_hygiene_violations
  19
  20 type rule =
  21 | Implies_not of pattern * pattern
  22 | Not of pattern
  23 and pattern = suffix
  24 and suffix = string
  25
  26 type penalty = Warn | Fail
  27
  28 type law = {
  29   law_name : string;
  30   law_rules : rule list;
  31   law_penalty : penalty
  32 }
  33
  34 let list_collect f l =
  35   let rec loop result = function
  36     | [] -> List.rev result
  37     | x :: rest ->
  38         match f x with
  39         | None -> loop result rest
  40         | Some y -> loop (y :: result) rest
  41   in
  42   loop [] l
  43
  44 let list_none_for_all f l =
  45   let rec loop = function
  46     | [] -> None
  47     | x :: rest ->
  48         match f x with
  49         | None -> loop rest
  50         | y -> y
  51   in
  52   loop l
  53
  54 let sf = Printf.sprintf
  55
  56 module SS = Set.Make(String);;
  57
  58 let check ?sanitize laws entry =
  59   let penalties = ref [] in
  60   let microbes = ref SS.empty in
  61   let () =
  62     match sanitize with
  63     | Some fn -> if sys_file_exists fn then sys_remove fn
  64     | None -> ()
  65   in
  66   let remove path name =
  67     if sanitize <> None then
  68       microbes := SS.add (filename_concat path name) !microbes
  69   in
  70   let check_rule = fun entries -> function
  71     | Not suffix ->
  72         list_collect
  73           begin function
  74             | File(path, name, _, true) ->
  75                 if Filename.check_suffix name suffix then
  76                   begin
  77                     remove path name;
  78                     Some(sf "File %s in %s has suffix %s" name path suffix)
  79                   end
  80                 else
  81                   None
  82             | File _ | Dir _| Error _ | Nothing -> None
  83           end
  84           entries
  85     | Implies_not(suffix1, suffix2) ->
  86         list_collect
  87           begin function
  88             | File(path, name, _, true) ->
  89                 if Filename.check_suffix name suffix1 then
  90                   begin
  91                     let base = Filename.chop_suffix name suffix1 in
  92                     let name' = base ^ suffix2 in
  93                     if List.exists
  94                        begin function
  95                          | File(_, name'', _, true) -> name' = name''
  96                          | File _ | Dir _ | Error _ | Nothing -> false
  97                        end
  98                        entries
  99                     then
 100                       begin
 101                         remove path name';
 102                         Some(sf "Files %s and %s should not be together in %s" name name' path)
 103                       end
 104                     else
 105                       None
 106                   end
 107                 else
 108                   None
 109             | File _ | Dir _ | Error _ | Nothing -> None
 110           end
 111           entries
 112   in
 113   let rec check_entry = function
 114     | Dir(_,_,_,true,entries) ->
 115         List.iter
 116           begin fun law ->
 117             match List.concat (List.map (check_rule !*entries) law.law_rules) with
 118             | [] -> ()
 119             | explanations ->
 120               penalties := (law, explanations) :: !penalties
 121           end
 122           laws;
 123         List.iter check_entry !*entries
 124     | Dir _ | File _ | Error _ | Nothing -> ()
 125   in
 126   check_entry entry;
 127   begin
 128     let microbes = !microbes in
 129     if not (SS.is_empty microbes) then
 130       begin
 131         match sanitize with
 132         | None ->
 133             Log.eprintf "sanitize: the following are files that should probably not be in your\n\
 134                          source tree:\n";
 135             SS.iter
 136               begin fun fn ->
 137                 Log.eprintf " %s" fn
 138               end
 139               microbes;
 140             Log.eprintf "Remove them manually, don't use the -no-sanitize option, use -no-hygiene, or\n\
 141                           define hygiene exceptions using the tags or plugin mechanism.\n";
 142             raise Exit_hygiene_violations
 143         | Some fn ->
 144             let m = SS.cardinal microbes in
 145             Log.eprintf
 146               "@[<hov 2>SANITIZE:@ a@ total@ of@ %d@ file%s@ that@ should@ probably\
 147                @ not@ be@ in@ your@ source@ tree@ has@ been@ found.\
 148                @ A@ script@ shell@ file@ %S@ is@ being@ created.\
 149                @ Check@ this@ script@ and@ run@ it@ to@ remove@ unwanted@ files\
 150                @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\
 151                @ or@ using@ the@ -no-hygiene@ option).@]"
 152                m (if m = 1 then "" else "s") fn;
 153             let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o755 fn in
 154             let fp = Printf.fprintf in
 155             fp oc "#!/bin/sh\n\
 156                    # File generated by ocamlbuild\n\
 157                    \n\
 158                    cd %s\n\
 159                    \n" (Shell.quote_filename_if_needed Pathname.pwd);
 160             SS.iter
 161               begin fun fn ->
 162                 fp oc "rm -f %s\n" (Shell.quote_filename_if_needed fn)
 163               end
 164               microbes;
 165             (* Also clean itself *)
 166             fp oc "# Also clean the script itself\n";
 167             fp oc "rm -f %s\n" (Shell.quote_filename_if_needed fn);
 168             close_out oc
 169       end;
 170     !penalties
 171   end
 172 ;;