pred.ml (6716B)
1 (* Unison file synchronizer: src/pred.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 19 let debug = Util.debug "pred" 20 21 (********************************************************************) 22 (* TYPES *) 23 (********************************************************************) 24 25 type t = 26 { pref: string list Prefs.t; 27 name: string; (* XXX better to get it from Prefs! *) 28 mutable default: string list; 29 mutable last_pref : string list; 30 mutable last_def : string list; 31 mutable last_mode : Case.mode; 32 mutable compiled: Rx.t; 33 mutable associated_strings : (Rx.t * string) list; 34 } 35 36 let error_msg s = 37 Printf.sprintf "bad pattern: %s\n\ 38 A pattern must be introduced by one of the following keywords:\n\ 39 \032 Name, Path, BelowPath or Regex." s 40 41 (* [select str [(p1, f1), ..., (pN, fN)] fO]: (roughly) *) 42 (* match str with *) 43 (* p1 p' -> f1 p' *) 44 (* ... *) 45 (* pN p' -> fN p' *) 46 (* otherwise -> fO str *) 47 let rec select str l f = 48 match l with 49 [] -> f str 50 | (pref, g)::r -> 51 if Util.startswith str pref then 52 let l = String.length pref in 53 let s = 54 Util.trimWhitespace (String.sub str l (String.length str - l)) in 55 g ((Case.ops())#normalizePattern s) 56 else 57 select str r f 58 59 let mapSeparator = "->" 60 61 (* Compile a pattern (in string form) to a regular expression *) 62 let compile_pattern clause = 63 let (p,v) = 64 let sep = " "^mapSeparator^" " in 65 (* Surround by spaces to make it less likely to appear in a pathspec *) 66 match Util.splitAtString ~reverse:true (" "^clause^" ") sep with 67 (* Actually find "(^| )mapSep( |$)" (by surrounding [clause] by spaces 68 possibly removed by previous trimming) to detect an empty pattern 69 and/or an empty string *) 70 ("", _) -> raise (Prefs.IllegalValue "Empty pattern") 71 | (p, None) -> (p, None) 72 | (p, Some v) -> (p, Some (Util.trimWhitespace v)) in 73 let compiled = 74 begin try 75 select (String.sub p 1 ((String.length p)-1)) (* Remove prepended space *) 76 [("Name ", fun str -> Rx.seq [Rx.rx "(.*/)?"; Rx.globx str]); 77 ("Path ", fun str -> 78 if str<>"" && str.[0] = '/' then 79 raise (Prefs.IllegalValue 80 ("Malformed pattern: " 81 ^ "\"" ^ p ^ "\"\n" 82 ^ "'Path' patterns may not begin with a slash; " 83 ^ "only relative paths are allowed.")); 84 Rx.globx str); 85 ("BelowPath ", fun str -> 86 if str<>"" && str.[0] = '/' then 87 raise (Prefs.IllegalValue 88 ("Malformed pattern: " 89 ^ "\"" ^ p ^ "\"\n" 90 ^ "'BelowPath' patterns may not begin with a slash; " 91 ^ "only relative paths are allowed.")); 92 Rx.seq [Rx.globx str; Rx.rx "(/.*)?"]); 93 ("Regex ", Rx.rx)] 94 (fun str -> raise (Prefs.IllegalValue (error_msg p))) 95 with 96 Rx.Parse_error | Rx.Not_supported -> 97 raise (Prefs.IllegalValue ("Malformed pattern \"" ^ p ^ "\".")) 98 end in 99 (compiled, v) 100 101 let create name ~category ?(local=false) ?send ?(initial = []) fulldoc = 102 let pref = 103 Prefs.create name ~category ~local ?send initial 104 ("add a pattern to the " ^ name ^ " list") 105 fulldoc 106 (fun oldList string -> 107 ignore (compile_pattern string); (* Check well-formedness *) 108 string :: oldList) 109 (fun l -> l) Umarshal.(list string) in 110 {pref = pref; name = name; 111 last_pref = []; default = []; last_def = []; last_mode = (Case.ops())#mode; 112 compiled = Rx.empty; associated_strings = []} 113 114 let addDefaultPatterns p pats = 115 p.default <- Safelist.append pats p.default 116 117 let alias p n = Prefs.alias p.pref n 118 119 let recompile mode p = 120 let pref = Prefs.read p.pref in 121 let compiledList = Safelist.map compile_pattern (Safelist.append p.default pref) in 122 let compiled = Rx.alt (Safelist.map fst compiledList) in 123 let handleCase rx = 124 if (Case.ops())#caseInsensitiveMatch then Rx.case_insensitive rx 125 else rx 126 in 127 let strings = Safelist.filterMap 128 (fun (rx,vo) -> 129 match vo with 130 None -> None 131 | Some v -> Some (handleCase rx,v)) 132 compiledList in 133 p.compiled <- handleCase compiled; 134 p.associated_strings <- strings; 135 p.last_pref <- pref; 136 p.last_def <- p.default; 137 p.last_mode <- mode 138 139 let recompile_if_needed p = 140 let mode = (Case.ops())#mode in 141 if 142 p.last_mode <> mode || 143 p.last_pref != Prefs.read p.pref || 144 p.last_def != p.default 145 then 146 recompile mode p 147 148 (********************************************************************) 149 (* IMPORT / EXPORT *) 150 (********************************************************************) 151 152 let intern p regexpStringList = Prefs.set p.pref regexpStringList 153 154 let extern p = Prefs.read p.pref 155 156 let extern_associated_strings p = 157 recompile_if_needed p; 158 Safelist.map snd p.associated_strings 159 160 (********************************************************************) 161 (* TESTING *) 162 (********************************************************************) 163 164 let test p s = 165 recompile_if_needed p; 166 let res = Rx.match_string p.compiled ((Case.ops())#normalizeMatchedString s) in 167 debug (fun() -> Util.msg "%s '%s' = %b\n" p.name s res); 168 res 169 170 let assoc p s = 171 recompile_if_needed p; 172 let s = (Case.ops())#normalizeMatchedString s in 173 snd (Safelist.find (fun (rx,v) -> Rx.match_string rx s) p.associated_strings) 174 175 let assoc_all p s = 176 recompile_if_needed p; 177 let s = (Case.ops())#normalizeMatchedString s in 178 Safelist.map snd 179 (Safelist.filter (fun (rx,v) -> Rx.match_string rx s) p.associated_strings)