diff options
author | Jérôme Vouillon <vouillon@pps.jussieu.fr> | 2009-07-08 16:29:44 +0000 |
---|---|---|
committer | Jérôme Vouillon <vouillon@pps.jussieu.fr> | 2009-07-08 16:29:44 +0000 |
commit | cd2c0928e21058fd032ae6d8170dc9565ada3dd1 (patch) | |
tree | 6948ca0f6f9d5adf1de5d567632c369337ca0c72 /src | |
parent | 34ad46e46c7e854824e37bc8611cb8ae0660ad38 (diff) | |
download | unison-cd2c0928e21058fd032ae6d8170dc9565ada3dd1.zip unison-cd2c0928e21058fd032ae6d8170dc9565ada3dd1.tar.gz unison-cd2c0928e21058fd032ae6d8170dc9565ada3dd1.tar.bz2 |
* Allow partial transfer of a directory when there was an error deep
inside this directory during update detection. At the moment, this
is only activated with the text and GTK UIs, which have been
modified so that they show that the transfer is going to be partial
and so that they can display all errors.
* Changed types Common.replicaContent and Common.replicas to use
records rather than tuples, as this is more readable and easier to
extend.
Diffstat (limited to 'src')
-rw-r--r-- | src/RECENTNEWS | 12 | ||||
-rw-r--r-- | src/common.ml | 62 | ||||
-rw-r--r-- | src/common.mli | 27 | ||||
-rw-r--r-- | src/copy.ml | 10 | ||||
-rw-r--r-- | src/mkProjectInfo.ml | 1 | ||||
-rw-r--r-- | src/recon.ml | 152 | ||||
-rw-r--r-- | src/recon.mli | 9 | ||||
-rw-r--r-- | src/sortri.ml | 7 | ||||
-rw-r--r-- | src/transport.ml | 16 | ||||
-rw-r--r-- | src/uicommon.ml | 66 | ||||
-rw-r--r-- | src/uicommon.mli | 6 | ||||
-rw-r--r-- | src/uigtk2.ml | 252 | ||||
-rw-r--r-- | src/uimacbridge.ml | 24 | ||||
-rw-r--r-- | src/uimacbridgenew.ml | 35 | ||||
-rw-r--r-- | src/uitext.ml | 57 | ||||
-rw-r--r-- | src/update.ml | 4 |
16 files changed, 435 insertions, 305 deletions
diff --git a/src/RECENTNEWS b/src/RECENTNEWS index cb2f090..4be808d 100644 --- a/src/RECENTNEWS +++ b/src/RECENTNEWS @@ -1,5 +1,17 @@ CHANGES FROM VERSION 2.36.-27 +* Allow partial transfer of a directory when there was an error deep + inside this directory during update detection. At the moment, this + is only activated with the text and GTK UIs, which have been + modified so that they show that the transfer is going to be partial + and so that they can display all errors. +* Changed types Common.replicaContent and Common.replicas to use + records rather than tuples, as this is more readable and easier to + extend. + +------------------------------- +CHANGES FROM VERSION 2.36.-27 + * Bumped version number: incompatible protocol changes * Partial transfer of directories. If an error occurs while diff --git a/src/common.ml b/src/common.ml index b1286e3..e069293 100644 --- a/src/common.ml +++ b/src/common.ml @@ -109,7 +109,11 @@ type status = | `Created | `Unchanged ] -type replicaContent = Fileinfo.typ * status * Props.t * updateItem +type replicaContent = + { typ : Fileinfo.typ; + status : status; + desc : Props.t; + ui : updateItem } type direction = Conflict @@ -123,13 +127,17 @@ let direction2string = function | Replica1ToReplica2 -> "replica1 to replica2" | Replica2ToReplica1 -> "replica2 to replica1" +type difference = + { rc1 : replicaContent; + rc2 : replicaContent; + errors1 : string list; + errors2 : string list; + mutable direction : direction; + default_direction : direction } + type replicas = - Problem of string (* There was a problem during update detection *) - | Different (* Replicas differ *) - of replicaContent (* - content of first replica *) - * replicaContent (* - content of second replica *) - * direction ref (* - action to take *) - * direction (* - default action to take *) + Problem of string (* There was a problem during update detection *) + | Different of difference (* Replicas differ *) type reconItem = {path : Path.t; @@ -144,8 +152,8 @@ let uiLength = function Updates(uc,_) -> ucLength uc | _ -> Uutil.Filesize.zero -let riAction (_, s, _, _) (_, s', _, _) = - match s, s' with +let riAction rc rc' = + match rc.status, rc'.status with `Deleted, _ -> `Delete | (`Unchanged | `PropsChanged), (`Unchanged | `PropsChanged) -> @@ -153,16 +161,16 @@ let riAction (_, s, _, _) (_, s', _, _) = | _ -> `Copy -let rcLength ((_, _, p, _) as rc) rc' = +let rcLength rc rc' = if riAction rc rc' = `SetProps then Uutil.Filesize.zero else - Props.length p + Props.length rc.desc let riLength ri = match ri.replicas with - Different(rc1, rc2, dir, _) -> - begin match !dir with + Different {rc1 = rc1; rc2 = rc2; direction = dir} -> + begin match dir with Replica1ToReplica2 -> rcLength rc1 rc2 | Replica2ToReplica1 -> rcLength rc2 rc1 | Conflict -> Uutil.Filesize.zero @@ -193,26 +201,32 @@ let fileInfos ui1 ui2 = let problematic ri = match ri.replicas with - Problem _ -> true - | Different (_,_,d,_) -> (!d = Conflict) + Problem _ -> true + | Different diff -> diff.direction = Conflict + +let partiallyProblematic ri = + match ri.replicas with + Problem _ -> + true + | Different diff -> + diff.direction = Conflict || diff.errors1 <> [] || diff.errors2 <> [] let isDeletion ri = match ri.replicas with - Different(rc1, rc2, rDir, _) -> - (match (!rDir, rc1, rc2) with - (Replica1ToReplica2, (`ABSENT, _, _, _), _) -> true - | (Replica2ToReplica1, _, (`ABSENT, _, _, _)) -> true + Different {rc1 = rc1; rc2 = rc2; direction = rDir} -> + (match rDir, rc1.typ, rc2.typ with + Replica1ToReplica2, `ABSENT, _ -> true + | Replica2ToReplica1, _, `ABSENT -> true | _ -> false) | _ -> false -let rcType (fi, _, _, _) = - Fileinfo.type2string fi +let rcType rc = Fileinfo.type2string rc.typ let riFileType ri = match ri.replicas with - Different(rc1, rc2, dir, _) -> - begin match !dir with + Different {rc1 = rc1; rc2 = rc2; default_direction = dir} -> + begin match dir with Replica2ToReplica1 -> rcType rc2 - | _ -> rcType rc1 + | _ -> rcType rc1 end | _ -> "nonexistent" diff --git a/src/common.mli b/src/common.mli index b358d09..b00f7c9 100644 --- a/src/common.mli +++ b/src/common.mli @@ -87,7 +87,11 @@ type status = | `Unchanged ] (* Variable name prefix: "rc" *) -type replicaContent = Fileinfo.typ * status * Props.t * updateItem +type replicaContent = + { typ : Fileinfo.typ; + status : status; + desc : Props.t; + ui : updateItem } type direction = Conflict @@ -97,15 +101,19 @@ type direction = val direction2string : direction -> string +type difference = + { rc1 : replicaContent; (* - content of first replica *) + rc2 : replicaContent; (* - content of second replica *) + errors1 : string list; (* - deep errors in first replica *) + errors2 : string list; (* - deep errors in second replica *) + mutable direction : direction; (* - action to take (it's mutable so that + the user interface can change it) *) + default_direction : direction } (* - default action to take *) + (* Variable name prefix: "rplc" *) type replicas = - Problem of string (* There was a problem during update detection *) - | Different (* Replicas differ *) - of replicaContent (* - content of first replica *) - * replicaContent (* - content of second replica *) - * direction ref (* - action to take (it's a ref so that the - user interface can change it) *) - * direction (* - default action to take *) + Problem of string (* There was a problem during update detection *) + | Different of difference (* Replicas differ *) (* Variable name prefix: "ri" *) type reconItem = @@ -124,4 +132,7 @@ val fileInfos : (* True if the ri's type is Problem or if it is Different and the direction is Conflict *) val problematic : reconItem -> bool +(* True if the ri is problematic or if it has some deep errors in a + directory *) +val partiallyProblematic : reconItem -> bool val isDeletion : reconItem -> bool diff --git a/src/copy.ml b/src/copy.ml index ddd9c30..6063652 100644 --- a/src/copy.ml +++ b/src/copy.ml @@ -661,11 +661,13 @@ let transferFileLocal connFrom (* File is already fully transferred (from some interrupted previous transfer). *) (* Make sure permissions are right. *) - Trace.log (Printf.sprintf - "%s/%s has already been transferred\n" - (Fspath.toDebugString fspathTo) (Path.toString pathTo)); + let msg = + Printf.sprintf + "%s/%s has already been transferred\n" + (Fspath.toDebugString fspathTo) (Path.toString pathTo) + in setFileinfo fspathTo pathTo realPathTo update desc; - Lwt.return (`DONE (Success info, None)) + Lwt.return (`DONE (Success info, Some msg)) end else match tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id diff --git a/src/mkProjectInfo.ml b/src/mkProjectInfo.ml index 8e97031..1c82709 100644 --- a/src/mkProjectInfo.ml +++ b/src/mkProjectInfo.ml @@ -166,3 +166,4 @@ Printf.printf "NAME=%s\n" projectName;; + diff --git a/src/recon.ml b/src/recon.ml index 6dcfbbf..2c68424 100644 --- a/src/recon.ml +++ b/src/recon.ml @@ -25,39 +25,37 @@ let debug = Trace.debug "recon" let setDirection ri dir force = match ri.replicas with - Different(rc1,rc2,d,default) when force=`Force || default=Conflict -> + Different + ({rc1 = rc1; rc2 = rc2; direction = d; default_direction = default } as diff) + when force=`Force || default=Conflict -> if dir=`Replica1ToReplica2 then - d := Replica1ToReplica2 + diff.direction <- Replica1ToReplica2 else if dir=`Replica2ToReplica1 then - d := Replica2ToReplica1 - else if dir=`Merge then - if Globals.shouldMerge ri.path then d := Merge else () - else (* dir = `Older or dir = `Newer *) - let (_,s1,p1,_) = rc1 in - let (_,s2,p2,_) = rc2 in - if s1<>`Deleted && s2<>`Deleted then begin - let comp = (Props.time p1) -. (Props.time p2) in + diff.direction <- Replica2ToReplica1 + else if dir=`Merge then begin + if Globals.shouldMerge ri.path then diff.direction <- Merge + end else (* dir = `Older or dir = `Newer *) + if rc1.status<>`Deleted && rc2.status<>`Deleted then begin + let comp = Props.time rc1.desc -. Props.time rc2.desc in let comp = if dir=`Newer then -. comp else comp in if comp = 0.0 then () else if comp<0.0 then - d := Replica1ToReplica2 + diff.direction <- Replica1ToReplica2 else - d := Replica2ToReplica1 - end else if s1=`Deleted && dir=`Newer then begin - d := Replica2ToReplica1 - end else if s2=`Deleted && dir=`Newer then begin - d := Replica1ToReplica2 + diff.direction <- Replica2ToReplica1 + end else if rc1.status=`Deleted && dir=`Newer then begin + diff.direction <- Replica2ToReplica1 + end else if rc2.status=`Deleted && dir=`Newer then begin + diff.direction <- Replica1ToReplica2 end | _ -> () let revertToDefaultDirection ri = match ri.replicas with - Different(_,_,d,default) -> - d := default - | _ -> - () + Different diff -> diff.direction <- diff.default_direction + | _ -> () (* Find out which direction we need to propagate changes if we want to *) (* consider the given root to be the "truth" *) @@ -213,16 +211,34 @@ let rec checkForError ui = | Absent | File _ | Symlink _ -> () +let rec collectErrors ui rem = + match ui with + NoUpdates -> + rem + | Error err -> + err :: rem + | Updates (uc, _) -> + match uc with + Dir (_, children, _, _) -> + Safelist.fold_right + (fun (_, uiSub) rem -> collectErrors uiSub rem) children rem + | Absent | File _ | Symlink _ -> + rem + (* lifting errors in individual updates to replica problems *) -let propagateErrors (rplc: Common.replicas): Common.replicas = +let propagateErrors allowPartial (rplc: Common.replicas): Common.replicas = match rplc with Problem _ -> rplc - | Different ((_, _, _, ui1), (_, _, _, ui2), _, _) -> + | Different diff when allowPartial -> + Different { diff with + errors1 = collectErrors diff.rc1.ui []; + errors2 = collectErrors diff.rc2.ui [] } + | Different diff -> try - checkForError ui1; + checkForError diff.rc1.ui; try - checkForError ui2; + checkForError diff.rc2.ui; rplc with UpdateError err -> Problem ("[root 2]: " ^ err) @@ -235,29 +251,29 @@ let update2replicaContent (conflict: bool) ui ucNew oldType: Common.replicaContent = match ucNew with Absent -> - (`ABSENT, `Deleted, Props.dummy, ui) + {typ = `ABSENT; status = `Deleted; desc = Props.dummy; ui = ui} | File (desc, ContentsSame) -> - (`FILE, `PropsChanged, desc, ui) + {typ = `FILE; status = `PropsChanged; desc = desc; ui = ui} | File (desc, _) when oldType <> `FILE -> - (`FILE, `Created, desc, ui) + {typ = `FILE; status = `Created; desc = desc; ui = ui} | File (desc, ContentsUpdated _) -> - (`FILE, `Modified, desc, ui) + {typ = `FILE; status = `Modified; desc = desc; ui = ui} | Symlink l when oldType <> `SYMLINK -> - (`SYMLINK, `Created, Props.dummy, ui) + {typ = `SYMLINK; status = `Created; desc = Props.dummy; ui = ui} | Symlink l -> - (`SYMLINK, `Modified, Props.dummy, ui) + {typ = `SYMLINK; status = `Modified; desc = Props.dummy; ui = ui} | Dir (desc, _, _, _) when oldType <> `DIRECTORY -> - (`DIRECTORY, `Created, desc, ui) + {typ = `DIRECTORY; status = `Created; desc = desc; ui = ui} | Dir (desc, _, PropsUpdated, _) -> - (`DIRECTORY, `PropsChanged, desc, ui) + {typ = `DIRECTORY; status = `PropsChanged; desc = desc; ui = ui} | Dir (desc, _, PropsSame, _) when conflict -> (* Special case: the directory contents has been modified and the *) (* directory is in conflict. (We don't want to display a conflict *) (* between an unchanged directory and a file, for instance: this would *) (* be rather puzzling to the user) *) - (`DIRECTORY, `Modified, desc, ui) + {typ = `DIRECTORY; status = `Modified; desc = desc; ui = ui} | Dir (desc, _, PropsSame, _) -> - (`DIRECTORY, `Unchanged, desc, ui) + {typ = `DIRECTORY; status = `Unchanged; desc =desc; ui = ui} let oldType (prev: Common.prevState): Fileinfo.typ = match prev with @@ -277,24 +293,28 @@ let describeUpdate ui Updates (ucNewStatus, prev) -> let typ = oldType prev in (update2replicaContent false ui ucNewStatus typ, - (typ, `Unchanged, oldDesc prev, NoUpdates)) + {typ = typ; status = `Unchanged; desc = oldDesc prev; ui = NoUpdates}) | _ -> assert false (* Computes the reconItems when only one side has been updated. (We split *) (* this out into a separate function to avoid duplicating all the symmetric *) (* cases.) *) -let rec reconcileNoConflict ui whatIsUpdated +let rec reconcileNoConflict allowPartial ui whatIsUpdated (result: (Name.t, Common.replicas) Tree.u) : (Name.t, Common.replicas) Tree.u = let different() = let rcUpdated, rcNotUpdated = describeUpdate ui in match whatIsUpdated with Rep2Updated -> - Different(rcNotUpdated, rcUpdated, - ref Replica2ToReplica1, Replica2ToReplica1) + Different {rc1 = rcNotUpdated; rc2 = rcUpdated; + direction = Replica2ToReplica1; + default_direction = Replica2ToReplica1; + errors1 = []; errors2 = []} | Rep1Updated -> - Different(rcUpdated, rcNotUpdated, - ref Replica1ToReplica2, Replica1ToReplica2) in + Different {rc1 = rcUpdated; rc2 = rcNotUpdated; + direction = Replica1ToReplica2; + default_direction = Replica1ToReplica2; + errors1 = []; errors2 = []} in match ui with | NoUpdates -> result | Error err -> @@ -307,11 +327,11 @@ let rec reconcileNoConflict ui whatIsUpdated Safelist.fold_left (fun result (theName, uiChild) -> Tree.leave - (reconcileNoConflict + (reconcileNoConflict allowPartial uiChild whatIsUpdated (Tree.enter result theName))) r children | Updates _ -> - Tree.add result (propagateErrors (different ())) + Tree.add result (propagateErrors allowPartial (different ())) (* [combineChildrn children1 children2] combines two name-sorted lists of *) (* type [(Name.t * Common.updateItem) list] to a single list of type *) @@ -361,32 +381,32 @@ let add_equal (counter, archiveUpdated) equal v = (* Tree.u *) (* unequals: (Name.t, Common.replicas) Tree.u *) (* -- *) -let rec reconcile path ui1 ui2 counter equals unequals = +let rec reconcile allowPartial path ui1 ui2 counter equals unequals = let different uc1 uc2 oldType equals unequals = (equals, Tree.add unequals - (propagateErrors - (Different(update2replicaContent true ui1 uc1 oldType, - update2replicaContent true ui2 uc2 oldType, - ref Conflict, - Conflict)))) in + (propagateErrors allowPartial + (Different {rc1 = update2replicaContent true ui1 uc1 oldType; + rc2 = update2replicaContent true ui2 uc2 oldType; + direction = Conflict; default_direction = Conflict; + errors1 = []; errors2 = []}))) in let toBeMerged uc1 uc2 oldType equals unequals = (equals, Tree.add unequals - (propagateErrors - (Different(update2replicaContent true ui1 uc1 oldType, - update2replicaContent true ui2 uc2 oldType, - ref Merge, - Merge)))) in + (propagateErrors allowPartial + (Different {rc1 = update2replicaContent true ui1 uc1 oldType; + rc2 = update2replicaContent true ui2 uc2 oldType; + direction = Merge; default_direction = Merge; + errors1 = []; errors2 = []}))) in match (ui1, ui2) with (Error s, _) -> (equals, Tree.add unequals (Problem s)) | (_, Error s) -> (equals, Tree.add unequals (Problem s)) | (NoUpdates, _) -> - (equals, reconcileNoConflict ui2 Rep2Updated unequals) + (equals, reconcileNoConflict allowPartial ui2 Rep2Updated unequals) | (_, NoUpdates) -> - (equals, reconcileNoConflict ui1 Rep1Updated unequals) + (equals, reconcileNoConflict allowPartial ui1 Rep1Updated unequals) | (Updates (Absent, _), Updates (Absent, _)) -> (add_equal counter equals (Absent, Absent), unequals) | (Updates (Dir (desc1, children1, propsChanged1, _) as uc1, prevState1), @@ -407,15 +427,16 @@ let rec reconcile path ui1 ui2 counter equals unequals = (equals, Tree.add unequals (Different - (update2replicaContent false ui1 uc1 `DIRECTORY, - update2replicaContent false ui2 uc2 `DIRECTORY, - ref action, action))) + {rc1 = update2replicaContent false ui1 uc1 `DIRECTORY; + rc2 = update2replicaContent false ui2 uc2 `DIRECTORY; + direction = action; default_direction = action; + errors1 = []; errors2 = []})) in (* Apply reconcile on children. *) Safelist.fold_left (fun (equals, unequals) (name,ui1,ui2) -> let (eq, uneq) = - reconcile (Path.child path name) ui1 ui2 counter + reconcile allowPartial (Path.child path name) ui1 ui2 counter (Tree.enter equals name) (Tree.enter unequals name) in (Tree.leave eq, Tree.leave uneq)) @@ -481,8 +502,9 @@ let dangerousPath u1 u2 = (* The second component of the return value is true if there is at least one *) (* file that is updated in the same way on both roots *) -let reconcileList (pathUpdatesList: (Path.t * Common.updateItem list) list) - : Common.reconItem list * bool * Path.t list = +let reconcileList allowPartial + (pathUpdatesList: (Path.t * Common.updateItem list) list) + : Common.reconItem list * bool * Path.t list = let counter = ref 0 in let archiveUpdated = ref false in let (equals, unequals, dangerous) = @@ -491,7 +513,7 @@ let reconcileList (pathUpdatesList: (Path.t * Common.updateItem list) list) match updatesList with [ui1; ui2] -> let (equals, unequals) = - reconcile path ui1 ui2 (counter, archiveUpdated) + reconcile allowPartial path ui1 ui2 (counter, archiveUpdated) (enterPath path equals) (enterPath path unequals) in (leavePath path equals, leavePath path unequals, @@ -516,12 +538,10 @@ let reconcileList (pathUpdatesList: (Path.t * Common.updateItem list) list) according to the roots and paths of synchronization, builds the corresponding reconItem list. A second component indicates whether there is any file updated in the same way on both sides. *) -let reconcileAll (ONEPERPATH(updatesListList)) = +let reconcileAll ?(allowPartial = false) (ONEPERPATH(updatesListList)) = Trace.status "Reconciling changes"; debug (fun() -> Util.msg "reconcileAll\n"); let pathList = Prefs.read Globals.paths in let pathUpdatesList = sortPaths (Safelist.combine pathList updatesListList) in - reconcileList pathUpdatesList - -let reconcileTwo p ui ui' = reconcileList [(p, [ui; ui'])] + reconcileList allowPartial pathUpdatesList diff --git a/src/recon.mli b/src/recon.mli index 9640231..42fcfad 100644 --- a/src/recon.mli +++ b/src/recon.mli @@ -2,16 +2,13 @@ (* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *) val reconcileAll : - Common.updateItem list Common.oneperpath + ?allowPartial:bool (* whether we allow partial synchronization + of directories (default to false) *) + -> Common.updateItem list Common.oneperpath (* one updateItem per replica, per path *) -> Common.reconItem list (* List of updates that need propagated *) * bool (* Any file updated equally on all roots*) * Path.t list (* Paths which have been emptied on one side*) -(* --------------- *) - -val reconcileTwo : Path.t -> Common.updateItem -> Common.updateItem -> - Common.reconItem list * bool * Path.t list - (* Use the current values of the '-prefer <ROOT>' and '-force <ROOT>' *) (* preferences to override the reconciler's choices *) diff --git a/src/sortri.ml b/src/sortri.ml index adbd172..00a7be2 100644 --- a/src/sortri.ml +++ b/src/sortri.ml @@ -104,14 +104,14 @@ let shouldSortFirst ri = let shouldSortLast ri = Pred.test sortlast (Path.toString ri.path) -let newItem ri = +let newItem ri = let newItem1 ri = match ri.replicas with - Different((_, `Created, _, _), _, _, _) -> true + Different diff -> diff.rc1.status = `Created | _ -> false in let newItem2 ri = match ri.replicas with - Different(_, (_, `Created, _, _), _, _) -> true + Different diff -> diff.rc2.status = `Created | _ -> false in newItem1 ri || newItem2 ri @@ -130,6 +130,7 @@ let compareReconItems () = let cmp = combineCmp [ pred problematic; + pred partiallyProblematic; pred shouldSortFirst; invertCmp (pred shouldSortLast); if newfirst then pred newItem else 0; diff --git a/src/transport.ml b/src/transport.ml index 970f163..4f33410 100644 --- a/src/transport.ml +++ b/src/transport.ml @@ -88,7 +88,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id = Trace.statusDetail (Path.toString path); Remote.Thread.unwindProtect (fun () -> match fromContents, toContents with - (`ABSENT, _, _, _), (_, _, _, uiTo) -> + {typ = `ABSENT}, {ui = uiTo} -> logLwtNumbered ("Deleting " ^ Path.toString path ^ "\n from "^ root2string toRoot) @@ -97,8 +97,8 @@ let doAction (fromRoot,toRoot) path fromContents toContents id = (* No need to transfer the whole directory/file if there were only property modifications on one side. (And actually, it would be incorrect to transfer a directory in this case.) *) - | (_, (`Unchanged | `PropsChanged), fromProps, uiFrom), - (_, (`Unchanged | `PropsChanged), toProps, uiTo) -> + | {status= `Unchanged | `PropsChanged; desc= fromProps; ui= uiFrom}, + {status= `Unchanged | `PropsChanged; desc= toProps; ui = uiTo} -> logLwtNumbered ("Copying properties for " ^ Path.toString path ^ "\n from " ^ root2string fromRoot ^ "\n to " ^ @@ -107,7 +107,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id = (fun () -> Files.setProp fromRoot path toRoot path fromProps toProps uiFrom uiTo) - | (`FILE, _, _, uiFrom), (`FILE, _, _, uiTo) -> + | {typ = `FILE; ui = uiFrom}, {typ = `FILE; ui = uiTo} -> logLwtNumbered ("Updating file " ^ Path.toString path ^ "\n from " ^ root2string fromRoot ^ "\n to " ^ @@ -116,7 +116,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id = (fun () -> Files.copy (`Update (fileSize uiFrom uiTo)) fromRoot path uiFrom toRoot path uiTo id) - | (_, _, _, uiFrom), (_, _, _, uiTo) -> + | {ui = uiFrom}, {ui = uiTo} -> logLwtNumbered ("Copying " ^ Path.toString path ^ "\n from " ^ root2string fromRoot ^ "\n to " ^ @@ -137,8 +137,8 @@ let propagate root1 root2 reconItem id showMergeFn = Trace.log (Printf.sprintf "[ERROR] Skipping %s\n %s\n" (Path.toString path) p); return () - | Different(rc1,rc2,dir,_) -> - match !dir with + | Different {rc1 = rc1; rc2 = rc2; direction = dir} -> + match dir with Conflict -> Trace.log (Printf.sprintf "[CONFLICT] Skipping %s\n" (Path.toString path)); @@ -149,7 +149,7 @@ let propagate root1 root2 reconItem id showMergeFn = doAction (root2, root1) path rc2 rc1 id | Merge -> begin match (rc1,rc2) with - (`FILE, _, _, ui1), (`FILE, _, _, ui2) -> + {typ = `FILE; ui = ui1}, {typ = `FILE; ui = ui2} -> Files.merge root1 root2 path id ui1 ui2 showMergeFn; return () | _ -> raise (Util.Transient "Can only merge two existing files") diff --git a/src/uicommon.ml b/src/uicommon.ml index 43f97d0..f0952dc 100644 --- a/src/uicommon.ml +++ b/src/uicommon.ml @@ -187,17 +187,16 @@ let prevProps newprops ui = (* || Props.similar newprops oldprops *) " (was: "^(Props.toString oldprops)^")" -let replicaContent2string rc sep = - let (typ, status, desc, ui) = rc in - let d s = s ^ sep ^ Props.toString desc ^ prevProps desc ui in - match typ, status with +let replicaContent2string rc sep = + let d s = s ^ sep ^ Props.toString rc.desc ^ prevProps rc.desc rc.ui in + match rc.typ, rc.status with `ABSENT, `Unchanged -> "absent" | _, `Unchanged -> "unchanged " - ^(Util.truncateString (Fileinfo.type2string typ) 7) + ^(Util.truncateString (Fileinfo.type2string rc.typ) 7) ^ sep - ^(Props.toString desc) + ^(Props.toString rc.desc) | `ABSENT, `Deleted -> "deleted" | `FILE, `Created -> d (choose "new file " "file ") @@ -223,8 +222,7 @@ let replicaContent2string rc sep = assert false let replicaContent2shortString rc = - let (typ, status, _, _) = rc in - match typ, status with + match rc.typ, rc.status with _, `Unchanged -> " " | `ABSENT, `Deleted -> "deleted " | `FILE, `Created -> choose "new file" "file " @@ -255,7 +253,7 @@ let details2string theRi sep = match theRi.replicas with Problem s -> Printf.sprintf "Error: %s\n" s - | Different(rc1, rc2, _, _) -> + | Different {rc1 = rc1; rc2 = rc2} -> let root1str, root2str = roots2niceStrings 12 (Globals.roots()) in Printf.sprintf "%s : %s\n%s : %s" @@ -286,25 +284,39 @@ let roots2string () = let replica1, replica2 = roots2niceStrings 12 (Globals.roots()) in (Printf.sprintf "%s %s " replica1 replica2) -let direction2niceString = function - Conflict -> "<-?->" - | Replica1ToReplica2 -> "---->" - | Replica2ToReplica1 -> "<----" - | Merge -> "<-M->" +type action = AError | ASkip of bool | ALtoR of bool | ARtoL of bool | AMerge + +let direction2action partial dir = + match dir with + Conflict -> ASkip partial + | Replica1ToReplica2 -> ALtoR partial + | Replica2ToReplica1 -> ARtoL partial + | Merge -> AMerge + +let action2niceString action = + match action with + AError -> "error" + | ASkip _ -> "<-?->" + | ALtoR false -> "---->" + | ALtoR true -> "--?->" + | ARtoL false -> "<----" + | ARtoL true -> "<-?--" + | AMerge -> "<-M->" + +let reconItem2stringList oldPath theRI = + match theRI.replicas with + Problem s -> + (" ", AError, " ", displayPath oldPath theRI.path) + | Different diff -> + let partial = diff.errors1 <> [] || diff.errors2 <> [] in + (replicaContent2shortString diff.rc1, + direction2action partial diff.direction, + replicaContent2shortString diff.rc2, + displayPath oldPath theRI.path) let reconItem2string oldPath theRI status = - let theLine = - match theRI.replicas with - Problem s -> - " error " ^ status - | Different(rc1, rc2, dir, _) -> - let signs = - Printf.sprintf "%s %s %s" - (replicaContent2shortString rc1) - (direction2niceString (!dir)) - (replicaContent2shortString rc2) in - Printf.sprintf "%s %s" signs status in - Printf.sprintf "%s %s" theLine (displayPath oldPath theRI.path) + let (r1, action, r2, path) = reconItem2stringList oldPath theRI in + Format.sprintf "%s %s %s %s %s" r1 (action2niceString action) r2 status path let exn2string = function Sys.Break -> "Terminated!" @@ -319,7 +331,7 @@ let showDiffs ri printer errprinter id = Problem _ -> errprinter "Can't diff files: there was a problem during update detection" - | Different((`FILE, _, _, ui1), (`FILE, _, _, ui2), _, _) -> + | Different {rc1 = {typ = `FILE; ui = ui1}; rc2 = {typ = `FILE; ui = ui2}} -> let (root1,root2) = Globals.roots() in begin try Files.diff root1 p ui1 root2 p ui2 printer id diff --git a/src/uicommon.mli b/src/uicommon.mli index 9e98b34..af2ccc1 100644 --- a/src/uicommon.mli +++ b/src/uicommon.mli @@ -59,6 +59,12 @@ val roots2string : unit -> string initial components that are the same as the previous path *) val reconItem2string : Path.t -> Common.reconItem -> string -> string +type action = AError | ASkip of bool | ALtoR of bool | ARtoL of bool | AMerge + +(* Same as previous function, but returns a tuple of strings *) +val reconItem2stringList : + Path.t -> Common.reconItem -> string * action * string * string + (* Format an exception for display *) val exn2string : exn -> string diff --git a/src/uigtk2.ml b/src/uigtk2.ml index cc2b35f..3dd9c45 100644 --- a/src/uigtk2.ml +++ b/src/uigtk2.ml @@ -795,9 +795,7 @@ let getPassword rootName msg = (Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in - (* FIX: DIALOG_AUTHENTICATION is way better but is not available - in the current release of LablGTK2... *) - ignore (GMisc.image ~stock:(*`DIALOG_AUTHENTICATION*)`DIALOG_QUESTION ~icon_size:`DIALOG + ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG ~yalign:0. ~packing:h1#pack ()); let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in ignore(GMisc.label ~markup:(header ^ "\n\n" ^ @@ -1198,6 +1196,8 @@ let displayWaitMessage () = (* ------ *) +type status = NoStatus | Done | Failed + let rec createToplevelWindow () = let toplevelWindow = getMyWindow() in (* There is already a default icon under Windows, and transparent @@ -1218,8 +1218,16 @@ let rec createToplevelWindow () = let grDiff = ref [] in let grGo = ref [] in let grRescan = ref [] in + let grDetail = ref [] in let grAdd gr w = gr := w#misc::!gr in let grSet gr st = Safelist.iter (fun x -> x#set_sensitive st) !gr in + let grDisactivateAll () = + grSet grAction false; + grSet grDiff false; + grSet grGo false; + grSet grRescan false; + grSet grDetail false + in (********************************************************************* Create the menu bar @@ -1349,64 +1357,82 @@ let rec createToplevelWindow () = Create the details window *********************************************************************) - let (showDetailsButton, detailsWindow) = + let showDetCommand () = + let details = + match !current with + None -> + None + | Some row -> + match !theState.(row).whatHappened with + Some (Util.Failed _, Some det) -> + let path = Path.toString !theState.(row).ri.path in + Some ("Merge execution details for file" ^ + transcodeFilename path, + det) + | _ -> + match !theState.(row).ri.replicas with + Problem _ -> + None + | Different diff -> + let prefix s l = + Safelist.map (fun err -> Format.sprintf "%s%s\n" s err) l + in + let errors = + Safelist.append + (prefix "[root 1]: " diff.errors1) + (prefix "[root 2]: " diff.errors2) + in + let path = Path.toString !theState.(row).ri.path in + Some ("Errors for file " ^ transcodeFilename path, + String.concat "\n" errors) + in + match details with + None -> ((* Should not happen *)) + | Some (title, details) -> messageBox ~title (transcode details) + in + + let detailsWindow = let sw = GBin.frame ~packing:(toplevelVBox#pack ~expand:false) ~shadow_type:`IN (*~hpolicy:`AUTOMATIC ~vpolicy:`NEVER*) () in - let hb =GPack.hbox ~packing:sw#add () in - (GButton.button ~label:"View details..." - ~show:false ~packing:(hb#pack ~expand:false) (), - GText.view ~editable:false ~wrap_mode:`NONE ~packing:hb#add ()) - + GText.view ~editable:false ~wrap_mode:`NONE ~packing:sw#add () in detailsWindow#misc#modify_font (Lazy.force fontMonospaceMediumPango); detailsWindow#misc#set_size_chars ~height:3 ~width:112 (); detailsWindow#misc#set_can_focus false; - let showDetCommand () = - let details = - match !current with - None -> "[No details available]" - | Some row -> - (match !theState.(row).whatHappened with - Some (Util.Failed _, Some det) -> det - | _ -> "[No details available]") in - messageBox ~title:"Merge execution details" details - in - ignore (showDetailsButton#connect#clicked ~callback:showDetCommand); - + let updateButtons () = match !current with None -> grSet grAction false; grSet grDiff false; - showDetailsButton#misc#hide () + grSet grDetail false | Some row -> - let (details, activate1, activate2) = - match !theState.(row).whatHappened, !theState.(row).ri.replicas with - | None, Different((`FILE, _, _, _),(`FILE, _, _, _), _, _) -> - (false, true, true) - | Some res, Different((`FILE, _, _, _),(`FILE, _, _, _), _, _) -> - (match res with - Util.Succeeded, _ -> (false, false, true) - | Util.Failed s, None -> (false, false, true) - | Util.Failed s, Some dText -> (true, false, false) - ) - | Some res, _ -> - (match res with - Util.Succeeded, _ -> (false, false, false) - | Util.Failed s, None -> (false, false, false) - | Util.Failed s, Some dText -> (true, false, false) - ) - | None, _ -> - (false, true, false) in + let details = + begin match !theState.(row).ri.replicas with + Different diff -> diff.errors1 <> [] || diff.errors2 <> [] + | Problem _ -> false + end + || + begin match !theState.(row).whatHappened with + Some (Util.Failed _, Some dText) -> true + | _ -> false + end + in + grSet grDetail details; if not !busy then begin - grSet grAction activate1; - grSet grDiff activate2 + let activateAction = !theState.(row).whatHappened = None in + let activateDiff = + activateAction && + match !theState.(row).ri.replicas with + Different {rc1 = {typ = `FILE}; rc2 = {typ = `FILE}} -> + true + | _ -> + false + in + grSet grAction activateAction; + grSet grDiff activateDiff end; - if details then - showDetailsButton#misc#show () - else - showDetailsButton#misc#hide () in let makeRowVisible row = @@ -1498,8 +1524,8 @@ let rec createToplevelWindow () = let rec loop i = if i < l then match !theState.(i).ri.replicas with - Different (_, _, dir, _) - when not (Prefs.read Uicommon.auto) || !dir = Conflict -> + Different {direction = dir} + when not (Prefs.read Uicommon.auto) || dir = Conflict -> select i | _ -> loop (i + 1) in @@ -1510,27 +1536,24 @@ let rec createToplevelWindow () = let columnsOf i = let oldPath = if i = 0 then Path.empty else !theState.(i-1).ri.path in let status = - match !theState.(i).whatHappened with - None -> " " - | Some conf -> - match !theState.(i).ri.replicas with - Different(_,_,{contents=Conflict},_) | Problem _ -> - " " - | _ -> - match conf with - Util.Succeeded, _ -> "done " - | Util.Failed _, _ -> "failed" in - let s = Uicommon.reconItem2string oldPath !theState.(i).ri status in - (* FIX: This is ugly *) - (String.sub s 0 8, - String.sub s 9 5, - String.sub s 15 8, - String.sub s 25 6, - String.sub s 32 (String.length s - 32)) in + match !theState.(i).ri.replicas with + Different {direction = Conflict} | Problem _ -> + NoStatus + | _ -> + match !theState.(i).whatHappened with + None -> NoStatus + | Some (Util.Succeeded, _) -> Done + | Some (Util.Failed _, _) -> Failed + in + let (r1, action, r2, path) = + Uicommon.reconItem2stringList oldPath !theState.(i).ri in + (r1, action, r2, status, path) + in let greenPixel = "00dd00" in let redPixel = "ff2040" in let lightbluePixel = "8888FF" in + let orangePixel = "ff9303" in (* let yellowPixel = "999900" in let blackPixel = "000000" in @@ -1540,11 +1563,14 @@ let rec createToplevelWindow () = let buildPixmaps f c1 = (buildPixmap (f c1), buildPixmap (f lightbluePixel)) in + let doneIcon = buildPixmap Pixmaps.success in + let failedIcon = buildPixmap Pixmaps.failure in let rightArrow = buildPixmaps Pixmaps.copyAB greenPixel in let leftArrow = buildPixmaps Pixmaps.copyBA greenPixel in + let orangeRightArrow = buildPixmaps Pixmaps.copyAB orangePixel in + let orangeLeftArrow = buildPixmaps Pixmaps.copyBA orangePixel in let ignoreAct = buildPixmaps Pixmaps.ignore redPixel in - let doneIcon = buildPixmap Pixmaps.success in - let failedIcon = buildPixmap Pixmaps.failure in + let failedIcons = (failedIcon, failedIcon) in let mergeLogo = buildPixmaps Pixmaps.mergeLogo greenPixel in (* let rightArrowBlack = buildPixmap (Pixmaps.copyAB blackPixel) in @@ -1554,23 +1580,29 @@ let rec createToplevelWindow () = let displayArrow i j action = let changedFromDefault = match !theState.(j).ri.replicas with - Different(_,_,{contents=curr},default) -> curr<>default + Different diff -> diff.direction <> diff.default_direction | _ -> false in let sel pixmaps = if changedFromDefault then snd pixmaps else fst pixmaps in - match action with - "<-?->" -> mainWindow#set_cell ~pixmap:(sel ignoreAct) i 1 - | "<-M->" -> mainWindow#set_cell ~pixmap:(sel mergeLogo) i 1 - | "---->" -> mainWindow#set_cell ~pixmap:(sel rightArrow) i 1 - | "<----" -> mainWindow#set_cell ~pixmap:(sel leftArrow) i 1 - | "error" -> mainWindow#set_cell ~pixmap:failedIcon i 1 - | _ -> assert false in + let pixmaps = + match action with + Uicommon.AError -> failedIcons + | Uicommon.ASkip _ -> ignoreAct + | Uicommon.ALtoR false -> rightArrow + | Uicommon.ALtoR true -> orangeRightArrow + | Uicommon.ARtoL false -> leftArrow + | Uicommon.ARtoL true -> orangeLeftArrow + | Uicommon.AMerge -> mergeLogo + in + mainWindow#set_cell ~pixmap:(sel pixmaps) i 1 + in + let displayStatusIcon i status = match status with - | "failed" -> mainWindow#set_cell ~pixmap:failedIcon i 3 - | "done " -> mainWindow#set_cell ~pixmap:doneIcon i 3 - | _ -> mainWindow#set_cell ~text:status i 3 in + | Failed -> mainWindow#set_cell ~pixmap:failedIcon i 3 + | Done -> mainWindow#set_cell ~pixmap:doneIcon i 3 + | NoStatus -> mainWindow#set_cell ~text:" " i 3 in let displayMain() = (* The call to mainWindow#clear below side-effect current, @@ -1589,8 +1621,9 @@ lst_store#set ~row ~column:c_status status; lst_store#set ~row ~column:c_path path; *) ignore (mainWindow#prepend - [ r1; ""; r2; status; transcodeFilename path ]); - displayArrow 0 i action + [ r1; ""; r2; ""; transcodeFilename path ]); + displayArrow 0 i action; + displayStatusIcon i status done; debug (fun()-> Util.msg "reset current to %s\n" (match savedCurrent with None->"None" | Some(i) -> string_of_int i)); @@ -1609,11 +1642,10 @@ lst_store#set ~row ~column:c_path path; mainWindow#set_cell ~text:r2 i 2; displayStatusIcon i status; mainWindow#set_cell ~text:(transcodeFilename path) i 4; - if status = "failed" then begin + if status = Failed then mainWindow#set_cell ~text:(transcodeFilename path ^ - " [failed: click on this line for details]") i 4 - end; + " [failed: click on this line for details]") i 4; mainWindow#thaw (); if !current = Some i then updateDetails (); updateButtons () in @@ -1621,11 +1653,10 @@ lst_store#set ~row ~column:c_path path; let fastRedisplay i = let (r1, action, r2, status, path) = columnsOf i in displayStatusIcon i status; - if status = "failed" then begin + if status = Failed then mainWindow#set_cell ~text:(transcodeFilename path ^ - " [failed: click on this line for details]") i 4 - end; + " [failed: click on this line for details]") i 4; if !current = Some i then updateDetails (); in @@ -1685,8 +1716,8 @@ lst_store#set ~row ~column:c_path path; showGlobalProgress bytes; gtk_sync false; begin match item.ri.replicas with - Different (_, _, dir, _) -> - begin match !dir with + Different diff -> + begin match diff.direction with Replica1ToReplica2 -> if root2IsLocal then clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes @@ -1745,10 +1776,7 @@ lst_store#set ~row ~column:c_path path; ******************************************************************) let detectUpdatesAndReconcile () = - grSet grAction false; - grSet grDiff false; - grSet grGo false; - grSet grRescan false; + grDisactivateAll (); mainWindow#clear(); detailsWindow#buffer#set_text ""; @@ -1763,7 +1791,7 @@ lst_store#set ~row ~column:c_path path; updates in let reconcile updates = let t = Trace.startTimer "Reconciling" in - let reconRes = Recon.reconcileAll updates in + let reconRes = Recon.reconcileAll ~allowPartial:true updates in Trace.showTimer t; reconRes in let (reconItemList, thereAreEqualUpdates, dangerousPaths) = @@ -1871,10 +1899,7 @@ lst_store#set ~row ~column:c_path path; if Array.length !theState = 0 then Trace.status "Nothing to synchronize" else begin - grSet grAction false; - grSet grDiff false; - grSet grGo false; - grSet grRescan false; + grDisactivateAll (); Trace.status "Propagating changes"; Transport.logStart (); @@ -2035,8 +2060,8 @@ lst_store#set ~row ~column:c_path path; Some i -> let theSI = !theState.(i) in begin match theSI.whatHappened, theSI.ri.replicas with - None, Different(_, _, dir, _) -> - f dir; + None, Different diff -> + f diff; redisplay i; nextInteresting () | _ -> @@ -2044,10 +2069,12 @@ lst_store#set ~row ~column:c_path path; end | None -> () in - let leftAction _ = doAction (fun dir -> dir := Replica2ToReplica1) in - let rightAction _ = doAction (fun dir -> dir := Replica1ToReplica2) in - let questionAction _ = doAction (fun dir -> dir := Conflict) in - let mergeAction _ = doAction (fun dir -> dir := Merge) in + let leftAction _ = + doAction (fun diff -> diff.direction <- Replica2ToReplica1) in + let rightAction _ = + doAction (fun diff -> diff.direction <- Replica1ToReplica2) in + let questionAction _ = doAction (fun diff -> diff.direction <- Conflict) in + let mergeAction _ = doAction (fun diff -> diff.direction <- Merge) in actionBar#insert_space (); grAdd grAction @@ -2107,6 +2134,15 @@ lst_store#set ~row ~column:c_path path; ~callback:mergeCmd ()); *) (********************************************************************* + Detail button + *********************************************************************) + actionBar#insert_space (); + grAdd grDetail (actionBar#insert_button ~text:"Details" + ~icon:((GMisc.image ~stock:`INFO ())#coerce) + ~tooltip:"Show details" + ~callback:showDetCommand ()); + + (********************************************************************* Keyboard commands *********************************************************************) ignore @@ -2299,10 +2335,7 @@ lst_store#set ~row ~column:c_path path; | Some(Util.Succeeded, _) -> false) || match !theState.(i).ri.replicas with Problem _ -> true - | Different(rc1,rc2,dir,_) -> - (match !dir with - Conflict -> true - | _ -> false) in + | Different diff -> diff.direction = Conflict in if notok then loop (i+1) (i::acc) else loop (i+1) (acc) in let failedindices = loop 0 [] in @@ -2393,10 +2426,7 @@ lst_store#set ~row ~column:c_path path; (********************************************************************* Finish up *********************************************************************) - grSet grAction false; - grSet grDiff false; - grSet grGo false; - grSet grRescan false; + grDisactivateAll (); ignore (toplevelWindow#event#connect#delete ~callback: (fun _ -> safeExit (); true)); diff --git a/src/uimacbridge.ml b/src/uimacbridge.ml index b777287..fe5fa63 100644 --- a/src/uimacbridge.ml +++ b/src/uimacbridge.ml @@ -268,8 +268,8 @@ Callback.register "unisonRiToDetails" unisonRiToDetails;; let unisonRiToPath ri = Path.toString ri.ri.path;; Callback.register "unisonRiToPath" unisonRiToPath;; -let rcToString (_,status,_,_) = - match status with +let rcToString rc = + match rc.status with `Deleted -> "Deleted" | `Modified -> "Modified" | `PropsChanged -> "PropsChanged" @@ -278,12 +278,12 @@ let rcToString (_,status,_,_) = let unisonRiToLeft ri = match ri.ri.replicas with Problem _ -> "" - | Different(rc,_,_,_) -> rcToString rc;; + | Different diff -> rcToString diff.rc1;; Callback.register "unisonRiToLeft" unisonRiToLeft;; let unisonRiToRight ri = match ri.ri.replicas with Problem _ -> "" - | Different(_,rc,_,_) -> rcToString rc;; + | Different diff -> rcToString diff.rc2;; Callback.register "unisonRiToRight" unisonRiToRight;; let direction2niceString = function (* from Uicommon where it's not exported *) @@ -294,28 +294,28 @@ let direction2niceString = function (* from Uicommon where it's not exported *) let unisonRiToDirection ri = match ri.ri.replicas with Problem _ -> "XXXXX" - | Different(_,_,d,_) -> direction2niceString !d;; + | Different diff -> direction2niceString diff.direction;; Callback.register "unisonRiToDirection" unisonRiToDirection;; let unisonRiSetLeft ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Replica2ToReplica1;; + | Different diff -> diff.direction <- Replica2ToReplica1;; Callback.register "unisonRiSetLeft" unisonRiSetLeft;; let unisonRiSetRight ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Replica1ToReplica2;; + | Different diff -> diff.direction <- Replica1ToReplica2;; Callback.register "unisonRiSetRight" unisonRiSetRight;; let unisonRiSetConflict ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Conflict;; + | Different diff -> diff.direction <- Conflict;; Callback.register "unisonRiSetConflict" unisonRiSetConflict;; let unisonRiSetMerge ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Merge;; + | Different diff -> diff.direction <- Merge;; Callback.register "unisonRiSetMerge" unisonRiSetMerge;; let unisonRiForceOlder ri = Recon.setDirection ri.ri `Older `Force;; @@ -328,7 +328,7 @@ let unisonRiToProgress ri = match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with (None,None,_) -> "" | (Some s,None,_) -> s - | (_,_,Different(_,_,{contents=Conflict},_)) -> "" + | (_,_,Different {direction = Conflict}) -> "" | (_,_,Problem _) -> "" | (_,Some Util.Succeeded,_) -> "done" | (_,Some (Util.Failed s),_) -> "FAILED";; @@ -469,12 +469,12 @@ Callback.register "unisonSecondRootString" unisonSecondRootString;; the current setting is Conflict *) let unisonRiIsConflict ri = match ri.ri.replicas with - | Different(_,_,_,Conflict) -> true + | Different {default_direction = Conflict} -> true | _ -> false;; Callback.register "unisonRiIsConflict" unisonRiIsConflict;; let unisonRiRevert ri = match ri.ri.replicas with - | Different(_,_,d,d0) -> d := d0 + | Different diff -> diff.direction <- diff.default_direction | _ -> ();; Callback.register "unisonRiRevert" unisonRiRevert;; diff --git a/src/uimacbridgenew.ml b/src/uimacbridgenew.ml index 9742d85..892eb5f 100644 --- a/src/uimacbridgenew.ml +++ b/src/uimacbridgenew.ml @@ -64,7 +64,7 @@ external displayStatus : string -> unit = "displayStatus";; let callbackThreadCreate() = let tCode () = bridgeThreadWait 1; - in Thread.create tCode (); Thread.create tCode (); + in ignore (Thread.create tCode ()); ignore (Thread.create tCode ()); let tid = Thread.create tCode () in Thread.join tid; ;; @@ -337,8 +337,8 @@ Callback.register "unisonRiToDetails" unisonRiToDetails;; let unisonRiToPath ri = Path.toString ri.ri.path;; Callback.register "unisonRiToPath" unisonRiToPath;; -let rcToString (_,status,_,_) = - match status with +let rcToString rc = + match rc.status with `Deleted -> "Deleted" | `Modified -> "Modified" | `PropsChanged -> "PropsChanged" @@ -347,12 +347,12 @@ let rcToString (_,status,_,_) = let unisonRiToLeft ri = match ri.ri.replicas with Problem _ -> "" - | Different(rc,_,_,_) -> rcToString rc;; + | Different {rc1 = rc} -> rcToString rc;; Callback.register "unisonRiToLeft" unisonRiToLeft;; let unisonRiToRight ri = match ri.ri.replicas with Problem _ -> "" - | Different(_,rc,_,_) -> rcToString rc;; + | Different {rc2 = rc} -> rcToString rc;; Callback.register "unisonRiToRight" unisonRiToRight;; let unisonRiToFileSize ri = @@ -371,28 +371,28 @@ let direction2niceString = function (* from Uicommon where it's not exported *) let unisonRiToDirection ri = match ri.ri.replicas with Problem _ -> "XXXXX" - | Different(_,_,d,_) -> direction2niceString !d;; + | Different diff -> direction2niceString diff.direction;; Callback.register "unisonRiToDirection" unisonRiToDirection;; let unisonRiSetLeft ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Replica2ToReplica1;; + | Different diff -> diff.direction <- Replica2ToReplica1;; Callback.register "unisonRiSetLeft" unisonRiSetLeft;; let unisonRiSetRight ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Replica1ToReplica2;; + | Different diff -> diff.direction <- Replica1ToReplica2;; Callback.register "unisonRiSetRight" unisonRiSetRight;; let unisonRiSetConflict ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Conflict;; + | Different diff -> diff.direction <- Conflict;; Callback.register "unisonRiSetConflict" unisonRiSetConflict;; let unisonRiSetMerge ri = match ri.ri.replicas with Problem _ -> () - | Different(_,_,d,_) -> d := Merge;; + | Different diff -> diff.direction <- Merge;; Callback.register "unisonRiSetMerge" unisonRiSetMerge;; let unisonRiForceOlder ri = Recon.setDirection ri.ri `Older `Force;; @@ -405,7 +405,7 @@ let unisonRiToProgress ri = match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with (None,None,_) -> "" | (Some s,None,_) -> s - | (_,_,Different(_,_,{contents=Conflict},_)) -> "" + | (_,_,Different {direction = Conflict}) -> "" | (_,_,Problem _) -> "" | (_,Some Util.Succeeded,_) -> "done" | (_,Some (Util.Failed s),_) -> "FAILED";; @@ -435,7 +435,8 @@ let filesAreDifferent status1 status2 = let canDiff ri = match ri.ri.replicas with Problem _ -> false - | Different((`FILE, status1, _, _),(`FILE, status2, _, _), _, _) -> + | Different {rc1 = {typ = `FILE; status = status1}; + rc2 = {typ = `FILE; status = status2}} -> filesAreDifferent status1 status2 | Different _ -> false;; Callback.register "canDiff" canDiff;; @@ -448,7 +449,9 @@ let showDiffs ri printer errprinter id = Problem _ -> errprinter "Can't diff files: there was a problem during update detection" - | Different((`FILE, status1, _, ui1), (`FILE, status2, _, ui2), _, _) -> + | Different + {rc1 = {typ = `FILE; status = status1; ui = ui1}; + rc2 = {typ = `FILE; status = status2; ui = ui2}} -> if filesAreDifferent status1 status2 then (let (root1,root2) = Globals.roots() in begin @@ -619,7 +622,7 @@ Callback.register "unisonSecondRootString" unisonSecondRootString;; the current setting is Conflict *) let unisonRiIsConflict ri = match ri.ri.replicas with - | Different(_,_,_,Conflict) -> true + | Different {default_direction = Conflict} -> true | _ -> false;; Callback.register "unisonRiIsConflict" unisonRiIsConflict;; @@ -628,13 +631,13 @@ Callback.register "unisonRiIsConflict" unisonRiIsConflict;; the reconItems table *) let changedFromDefault ri = match ri.ri.replicas with - Different(_,_,{contents=curr},default) -> curr<>default + Different diff -> diff.direction <> diff.default_direction | _ -> false;; Callback.register "changedFromDefault" changedFromDefault;; let unisonRiRevert ri = match ri.ri.replicas with - | Different(_,_,d,d0) -> d := d0 + | Different diff -> diff.direction <- diff.default_direction | _ -> ();; Callback.register "unisonRiRevert" unisonRiRevert;; diff --git a/src/uitext.ml b/src/uitext.ml index 7cb6abb..a75653c 100644 --- a/src/uitext.ml +++ b/src/uitext.ml @@ -171,26 +171,45 @@ let rec selectAction batch actions tryagain = getInput () | Some i -> i) +let alwaysDisplayErrors prefix l = + List.iter + (fun err -> alwaysDisplay (Format.sprintf "%s%s\n" prefix err)) l + let alwaysDisplayDetails ri = - alwaysDisplay ((Uicommon.details2string ri " ") ^ "\n") + alwaysDisplay ((Uicommon.details2string ri " ") ^ "\n"); + match ri.replicas with + Problem _ -> + () + | Different diff -> + alwaysDisplayErrors "[root 1]: " diff.errors1; + alwaysDisplayErrors "[root 2]: " diff.errors2 let displayDetails ri = if not (Prefs.read silent) then alwaysDisplayDetails ri let displayri ri = - let s = Uicommon.reconItem2string Path.empty ri "" ^ " " in - let s = + let (r1, action, r2, path) = Uicommon.reconItem2stringList Path.empty ri in + let forced = match ri.replicas with - Different(_,_,d,def) when !d<>def -> - let s = Util.replacesubstring s "<-?->" "<=?=>" in - let s = Util.replacesubstring s "---->" "====>" in - let s = Util.replacesubstring s "<----" "<====" in - s - | _ -> s in + Different diff -> diff.direction <> diff.default_direction + | Problem _ -> false + in + let (defaultAction, forcedAction) = + match action with + Uicommon.AError -> ("error", "error") + | Uicommon.ASkip _ -> ("<-?->", "<=?=>") + | Uicommon.ALtoR false -> ("---->", "====>") + | Uicommon.ALtoR true -> ("--?->", "==?=>") + | Uicommon.ARtoL false -> ("<----", "<====") + | Uicommon.ARtoL true -> ("<-?--", "<=?==") + | Uicommon.AMerge -> ("<-M->", "<=M=>") + in + let action = if forced then forcedAction else defaultAction in + let s = Format.sprintf "%s %s %s %s " r1 action r2 path in match ri.replicas with Problem _ -> alwaysDisplay s - | Different (_,_,d,_) when !d=Conflict -> + | Different {direction = d} when d=Conflict -> alwaysDisplay s | _ -> display s @@ -225,8 +244,8 @@ let interact rilist = displayri ri; match ri.replicas with Problem s -> display "\n"; display s; display "\n"; next() - | Different(rc1,rc2,dir,_) -> - if Prefs.read Uicommon.auto && !dir<>Conflict then begin + | Different ({rc1 = rc1; rc2 = rc2; direction = dir} as diff) -> + if Prefs.read Uicommon.auto && dir<>Conflict then begin display "\n"; next() end else let (descr, descl) = @@ -243,14 +262,14 @@ let interact rilist = end; selectAction (if Prefs.read Globals.batch then Some " " else None) - [((if !dir=Conflict && not (Prefs.read Globals.batch) + [((if dir=Conflict && not (Prefs.read Globals.batch) then ["f"] (* Offer no default behavior if we've got a conflict and we're in interactive mode *) else ["";"f";" "]), ("follow " ^ Uutil.myName ^ "'s recommendation (if any)"), fun ()-> newLine (); - if !dir = Conflict && not (Prefs.read Globals.batch) + if dir = Conflict && not (Prefs.read Globals.batch) then begin display "No default action [type '?' for help]\n"; repeat() @@ -274,7 +293,7 @@ let interact rilist = (["m"], ("merge the versions"), (fun () -> - dir := Merge; + diff.direction <- Merge; redisplayri(); next())); (["d"], @@ -332,19 +351,19 @@ let interact rilist = (["/"], ("skip"), (fun () -> - dir := Conflict; + diff.direction <- Conflict; redisplayri(); next())); ([">";"."], ("propagate from " ^ descr), (fun () -> - dir := Replica1ToReplica2; + diff.direction <- Replica1ToReplica2; redisplayri(); next())); (["<";","], ("propagate from " ^ descl), (fun () -> - dir := Replica2ToReplica1; + diff.direction <- Replica2ToReplica1; redisplayri(); next())) ] @@ -612,7 +631,7 @@ let synchronizeOnce() = Util.set_infos ""; let (reconItemList, anyEqualUpdates, dangerousPaths) = - Recon.reconcileAll updates in + Recon.reconcileAll ~allowPartial:true updates in if reconItemList = [] then begin (if anyEqualUpdates then diff --git a/src/update.ml b/src/update.ml index c90d0f1..61af151 100644 --- a/src/update.ml +++ b/src/update.ml @@ -1646,8 +1646,10 @@ let commitUpdates () = (* the result of patching [archive] using [ui] *) let rec updateArchiveRec ui archive = match ui with - NoUpdates | Error _ -> + NoUpdates -> archive + | Error _ -> + NoArchive | Updates (uc, _) -> match uc with Absent -> |