Assoc only Pathspec Patterns

doc/unison-manual.tex

@@ -1721,6 +1721,11 @@
 \begin{verbatim}
     unison profile -merge 'Name *.txt -> echo SKIP'
 \end{verbatim}
+Note that unsetting the merge preference by \verb|-merge 'del Name *.txt'| is
+not exactly the same: in the case where the preference \verb|prefer| or
+\verb|preferpartial| for the path is set, this extra setting does not make the
+path be skipped but let it be updated without merging; the preference
+\verb|preferpartial| can be unset at the same time to avoid that.
 
 If the \verb|confirmmerge| preference is set and Unison is not run in
 batch mode, then Unison will always ask for confirmation before
@@ -1845,14 +1850,14 @@
 \end{alltt}
 adds \ARG{pattern} to the list of patterns to be ignored.
 
-\item Each \ARG{pattern} can have one of three forms.  The most
+\item Each \ARG{pattern} can have one of seven forms.  The most
 general form is a Posix extended regular expression introduced by the
 keyword \verb|Regex|.  (The collating sequences and character classes of
 full Posix regexps are not currently supported).
 \begin{alltt}
                  Regex \ARG{regexp}
 \end{alltt}
-For convenience, three other styles of pattern are also recognized:
+For convenience, three other styles of globbing patterns are also recognized:
 \begin{alltt}
                  Name \ARG{name}
 \end{alltt}
@@ -1877,17 +1882,62 @@
 \item a \verb|?| matches any single character except \verb|/| (and leading
   \verb|.|)
 \item \verb|[xyz]| matches any character from the set $\{{\tt x},
-  {\tt y}, {\tt z} \}$
+  {\tt y}, {\tt z} \}$ (you can negate the set by the forms \verb|[!xyz]| or
+  \verb|[^xyz]| and you can give ranges of the form \verb|[x-z]|)
 \item \verb|{a,bb,ccc}| matches any one of \verb|a|, \verb|bb|, or
   \verb|ccc|.  (Be careful not to put extra spaces after the commas:
   these will be interpreted literally as part of the strings to be matched!)
+\item a \verb|\| escapes the following character
 \end{itemize}
+To match fixed string names three other styles of string patterns are
+recognized, maching a fixed string against the same path components as the
+corresponding globbing pattern:
+\begin{alltt}
+                 NameString \ARG{string}
+                 String \ARG{string}
+                 BelowString \ARG{string}
+                 String '\ARG{string}'
+\end{alltt}
+If the given string is surrounded by single quotes, they are removed and not
+matched against; they can protect leading and trailing whitespace.
 \item
 The path separator in path patterns is always the
 forward-slash character ``/'' --- even when the client or server is
 running under Windows, where the normal separator character is a
 backslash.  This makes it possible to use the same set of path
 patterns for both Unix and Windows file systems.
+\item
+The matching of a path by preceding patterns can be removed by a negative
+pattern, that is any pattern prefixed by \texttt{del} separated exactly by one
+space.  Any subsequent (positive) pattern can select the path again.  A
+negative pattern is similar to a positive pattern in the corresponding
+negative preference (one whose name ends with \texttt{not}), except that the
+matched paths can be selected again by following (positive) patterns.  However
+a negative pattern in a negative preference can only make a path selected by a
+positive preference if the path has also been explicitely selected with the
+positive preference.
+
+A negative pattern does not remove the string associated with a path, so that
+this string need not be given again when reenabling a path.  For example:
+\begin{verbatim}
+        preferpartial = Name *.txt -> /local/path
+        preferpartial = del Path prefix*.txt
+        preferpartial = Path prefix.txt
+\end{verbatim}
+\item
+An associated string can also be defined and recorded without setting the
+corresponding preference by an assoc pattern, that is any pattern prefixed by
+\texttt{assoc} separated exactly by one space.  Any (preceding or following)
+(positive) pattern can set the preference independently without having to
+specify an associated string.
+
+For example one can define a generic merge command without enbaling the
+\verb|merge| preference, then select some paths to merge without having to give
+the merge command again and again:
+\begin{verbatim}
+        merge = assoc Name *.txt -> mergecmd CURRENT1 CURRENT2
+        merge = Path prefix*.txt
+\end{verbatim}
 \end{itemize}
 Some examples of path patterns appear in \sectionref{ignore}{Ignoring
   Paths}.

src/pred.ml

@@ -36,25 +36,33 @@ type t =
 let error_msg s =
    Printf.sprintf "bad pattern: %s\n\
     A pattern must be introduced by one of the following keywords:\n\
- \032   Name, Path, BelowPath or Regex." s
-
-(* [select str [(p1, f1), ..., (pN, fN)] fO]: (roughly) *)
-(* match str with                                       *)
-(*  p1 p' -> f1 p'                                      *)
-(*  ...		       	       	       	       	       	*)
-(*  pN p' -> fN p'   					*)
-(*  otherwise -> fO str	       	       	       	        *)
-let rec select str l f =
+ \032   Regex, Name, Path, BelowPath, NameString, String, BelowString\n\
+ \032   (or add <KEYWORD> or del <KEYWORD> or assoc <KEYWORD>)." s
+
+let addPref = "add "
+let delPref = "del "
+let assocPref = "assoc "
+
+(* [select_pattern str [(p1, f1), ..., (pN, fN)] fO]: (roughly) *)
+(* match str with                                               *)
+(*  p1 p' -> f1 p'                                              *)
+(*  ...                                                         *)
+(*  pN p' -> fN p'                                              *)
+(*  otherwise -> fO str                                         *)
+let rec select_pattern str l err =
+  let rest realpref g =
+    let l = String.length realpref in
+    let s =
+      Util.trimWhitespace (String.sub str l (String.length str - l)) in
+    g (Util.trimWhitespace realpref) ((Case.ops())#normalizePattern s) in
   match l with
-    [] -> f str
+    [] -> err str
   | (pref, g)::r ->
-      if Util.startswith str pref then
-        let l = String.length pref in
-        let s =
-          Util.trimWhitespace (String.sub str l (String.length str - l)) in
-        g ((Case.ops())#normalizePattern s)
-      else
-        select str r f
+      if Util.startswith str pref then `Alt (rest pref g)
+      else if Util.startswith str (addPref^pref) then `Alt (rest (addPref^pref) g)
+      else if Util.startswith str (delPref^pref) then `Dif (rest (delPref^pref) g)
+      else if Util.startswith str (assocPref^pref) then `Nul (rest (assocPref^pref) g)
+      else select_pattern str r err
 
 let mapSeparator = "->"
 
@@ -70,25 +78,36 @@ let compile_pattern clause =
                   ^ "Only one instance of " ^ mapSeparator ^ " allowed.")) in
   let compiled =
     begin try
-      select p
-        [("Name ", fun str -> Rx.seq [Rx.rx "(.*/)?"; Rx.globx str]);
-         ("Path ", fun str ->
-            if str<>"" && str.[0] = '/' then
-              raise (Prefs.IllegalValue
-                       ("Malformed pattern: "
-                        ^ "\"" ^ p ^ "\"\n"
-                        ^ "'Path' patterns may not begin with a slash; "
-                        ^ "only relative paths are allowed."));
+      let checkpath prefix str =
+        let msg =
+          "Malformed pattern: \"" ^ p ^ "\"\n"
+          ^ "'" ^ prefix ^ "' patterns may not begin with a slash; "
+          ^ "only relative paths are allowed." in
+        if str<>"" && str.[0] = '/' then
+          raise (Prefs.IllegalValue msg) in
+      let name rx = Rx.seq [Rx.rx "(.*/)?"; rx]
+      and below rx = Rx.seq [rx; Rx.rx "(/.*)?"]
+      and del_quotes c str =
+        let l = String.length str in
+        if l >= 2 && str.[0] = c && str.[l-1] = c
+        then String.sub str 1 (l-2)
+        else str
+      in
+      select_pattern p
+        [("Name ", fun realpref str -> checkpath realpref str;
+            name (Rx.globx str));
+         ("Path ", fun realpref str -> checkpath realpref str;
             Rx.globx str);
-         ("BelowPath ", fun str ->
-            if str<>"" && str.[0] = '/' then
-              raise (Prefs.IllegalValue
-                       ("Malformed pattern: "
-                        ^ "\"" ^ p ^ "\"\n"
-                        ^ "'BelowPath' patterns may not begin with a slash; "
-                        ^ "only relative paths are allowed."));
-            Rx.seq [Rx.globx str; Rx.rx "(/.*)?"]);
-         ("Regex ", Rx.rx)]
+         ("BelowPath ", fun realpref str -> checkpath realpref str;
+            below (Rx.globx str));
+         ("NameString ", fun realpref str -> checkpath realpref (del_quotes '\'' str);
+            name (Rx.str (del_quotes '\'' str)));
+         ("String ", fun realpref str -> checkpath realpref (del_quotes '\'' str);
+            Rx.str (del_quotes '\'' str));
+         ("BelowString ", fun realpref str -> checkpath realpref (del_quotes '\'' str);
+            below (Rx.str (del_quotes '\'' str)));
+         ("Regex ", fun realpref str -> checkpath realpref str;
+            Rx.rx str)]
         (fun str -> raise (Prefs.IllegalValue (error_msg p)))
     with
       Rx.Parse_error | Rx.Not_supported ->
@@ -116,19 +135,37 @@ let addDefaultPatterns p pats =
 let alias p n = Prefs.alias p.pref n
 
 let recompile mode p =
+  (* Accumulate consecutive pathspec regexps with the same sign and discard
+     null patterns *)
+  let rev_acc_alt_or_dif acc r =
+    match acc, r with
+      (`Alt rl :: t), `Alt rx -> `Alt (rx::rl) :: t
+    | (`Dif rl :: t), `Dif rx -> `Dif (rx::rl) :: t
+    | _             , `Alt rx -> `Alt [rx]     :: acc
+    | _             , `Dif rx -> `Dif [rx]     :: acc
+    | _             , `Nul rx ->                  acc
+  (* Combine newer positive or negative pathspec regexps with the older ones *)
+  and combine_alt_or_dif rx = function
+      `Alt rl -> Rx.alt [Rx.alt rl; rx]
+    | `Dif rl -> Rx.diff rx (Rx.alt rl)
+        (* A negative pattern is diff'ed from the former ones only *)
+  in
   let pref = Prefs.read p.pref in
-  let compiledList = Safelist.map compile_pattern (Safelist.append p.default pref) in
-  let compiled = Rx.alt (Safelist.map fst compiledList) in
+  let compiledList = Safelist.append p.default pref
+    |> Safelist.rev_map compile_pattern in
+  let compiled = Safelist.rev compiledList
+    |> Safelist.fold_left (fun a (r, _) -> rev_acc_alt_or_dif a r) []
+    |> Safelist.fold_left combine_alt_or_dif Rx.empty in
+         (* The patterns are processed in order of appearance so that later
+            preferences override the previous ones. *)
   let handleCase rx =
     if (Case.ops())#caseInsensitiveMatch then Rx.case_insensitive rx
     else rx
   in
-  let strings = Safelist.filterMap
-                  (fun (rx,vo) ->
-                     match vo with
-                       None -> None
-                     | Some v -> Some (handleCase rx,v))
-                  compiledList in
+  let nodif_string = function
+      `Alt rx, Some v | `Nul rx, Some v -> Some (handleCase rx, v)
+    | _ -> None in
+  let strings = Safelist.rev_filterMap nodif_string compiledList in
   p.compiled <- handleCase compiled;
   p.associated_strings <- strings;
   p.last_pref <- pref;

src/pred.mli

@@ -19,10 +19,26 @@
      <TYPE> <PAT> [ -> <ASSOCIATED STRING> ]
    The associated string is ignored by [test] but can be looked up by [assoc].
 
-   Three forms of <TYPE>/<PAT> are recognized:
+   Four forms of <TYPE>/<PAT> are recognized:
    "Name <name>": ..../<name> (using globx)
    "Path <path>": <path>, not starting with "/" (using globx)
+   "BelowPath <path>": <path>, not starting with "/" (using globx)
    "Regex <regex>": <regex> (using rx)
+
+   Three additional forms of <TYPE>/<FIXED_STRING> are recognized:
+   "NameString <name>": ..../<name> (using fixed string)
+   "String <path>": <path>, not starting with "/" (using fixed string)
+   "BelowString <path>": <path>, not starting with "/" (using fixed string)
+
+   Seven negative patterns "del <TYPE>" are also recognized that prevent a
+   matching string from matching a former pattern.
+
+   Seven assoc only patterns "assoc <TYPE>" are also recognized that record the
+   associated string but do not set the preference for the paths matching the
+   given pattern.
+
+   Seven patterns "add <TYPE>" are also recognized that are equivalent to the
+   non prefixed patterns.
 *)
 
 

src/ubase/rx.ml

@@ -784,10 +784,12 @@ let glob_parse init s =
           Sequence [beg_start; Set (csingle c)]),
        if c = '/' then init else Mid)
   and bracket s =
-    if s <> [] && accept ']' then s else begin
+    if s <> [] && accept ']' then s
+    else begin
       let c = char () in
       if accept '-' then begin
-        if accept ']' then (cadd c (cadd '-' s)) else begin
+        if accept ']' then (cadd c (cadd '-' s))
+        else begin
           let c' = char () in
           bracket (cunion (cseq c c') s)
         end

src/ubase/rx.mli

@@ -8,6 +8,8 @@ val rx : string -> t
 
 (* File globbing *)
 val glob : string -> t
+   (* Recognize ?, * and [] (which supports ranges - and negations ! and ^)
+      with the escape \ *)
 val glob' : bool -> string -> t
    (* Same, but allows to choose whether dots at the beginning of a
       file name need to be explicitly matched (true) or not (false) *)

src/ubase/safelist.ml

@@ -24,26 +24,30 @@ let filterBoth f l =
       else loop r1 (hd::r2) tl
   in loop [] [] l
 
-let filterMap f l =
+let rev_filterMap f l =
   let rec loop r = function
-    [] -> List.rev r
+    [] -> r
   | hd::tl -> begin
       match f hd with
         None -> loop r tl
       | Some x -> loop (x::r) tl
     end
   in loop [] l
+let filterMap f l =
+  List.rev (rev_filterMap f l)
 
-let filterMap2 f l =
+let rev_filterMap2 f l =
   let rec loop r s = function
-    [] -> List.rev r, List.rev s
+    [] -> r, s
   | hd::tl -> begin
       let (a, b) = f hd in
       let r' = match a with None -> r | Some x -> x::r in
       let s' = match b with None -> s | Some x -> x::s in
       loop r' s' tl
     end
   in loop [] [] l
+let filterMap2 f l =
+  match rev_filterMap2 f l with r, s -> List.rev r, List.rev s
 
 (* These are tail-recursive versions of the standard ones from the
    List module *)

src/ubase/safelist.mli

@@ -38,7 +38,9 @@ val sort : ('a -> 'a -> int) -> 'a list -> 'a list
 
 (* Other useful list-processing functions *)
 val filterMap : ('a -> 'b option) -> 'a list -> 'b list
+val rev_filterMap : ('a -> 'b option) -> 'a list -> 'b list
 val filterMap2 : ('a -> 'b option * 'c option) -> 'a list -> 'b list * 'c list
+val rev_filterMap2 : ('a -> 'b option * 'c option) -> 'a list -> 'b list * 'c list
 val transpose : 'a list list -> 'a list list
 val filterBoth : ('a -> bool) -> 'a list -> ('a list * 'a list)
 val allElementsEqual : 'a list -> bool

src/uicommon.ml

@@ -356,7 +356,10 @@ let dangerousPathMsg dangerousPaths =
                   Useful patterns for ignoring paths
  **********************************************************************)
 
-let quote s =
+(* Generate a glob pattern (string) that matches only the input fixed string *)
+(* Note: The newer String pathspec patterns are deliberately not generated
+   below to keep compatibility with unison <= 2.51. *)
+let globx_quote s =
   let len = String.length s in
   let buf = Bytes.create (2 * len) in
   let pos = ref 0 in
@@ -369,11 +372,11 @@ let quote s =
   done;
   "{" ^ String.sub buf 0 !pos ^ "}"
 
-let ignorePath path = "Path " ^ quote (Path.toString path)
+let ignorePath path = "Path " ^ globx_quote (Path.toString path)
 
 let ignoreName path =
   match Path.finalName path with
-    Some name -> "Name " ^ quote (Name.toString name)
+    Some name -> "Name " ^ globx_quote (Name.toString name)
   | None      -> assert false
 
 let ignoreExt path =
@@ -383,9 +386,9 @@ let ignoreExt path =
       begin try
         let pos = String.rindex str '.' in
         let ext = String.sub str pos (String.length str - pos) in
-        "Name {,.}*" ^ quote ext
+        "Name {,.}*" ^ globx_quote ext
       with Not_found -> (* str does not contain '.' *)
-        "Name " ^ quote str
+        "Name " ^ globx_quote str
       end
   | None ->
       assert false