Don't allow entering a view with staged or unstaged changes.

In some cases, unstaged changes are safe, eg dotfiles in the top which
are not affected by a view. Or non-annexed files in general which would
prevent view branch checkout from proceeding. But in other cases,
particularly unstaged changes to annexed files, entering a view would wipe
out those changes! And so don't allow entering a view with any unstaged
changes.

Staged changes are not safe when entering a view, because the changes get
committed to the view branch, and so the user is unlikely to remember them
when they exit the view, and so will effectively lose them, even if they're
still present in the view branch.

Also, improved the git status parser, although the improvement turned out
to not really be needed.

This commit was sponsored by Eric Drechsel on Patreon.

CHANGELOG

@@ -1,8 +1,7 @@
 git-annex (6.20180510) UNRELEASED; urgency=medium
 
   * view, vadd: Fix crash when a git submodule has a name starting with a dot.
-  * Improve handling of unstaged modifications to dotfiles when entering a
-    view.
+  * Don't allow entering a view with staged or unstaged changes.
 
  -- Joey Hess <id@joeyh.name>  Mon, 14 May 2018 13:42:41 -0400
 

Command/Status.hs

@@ -43,8 +43,8 @@ start :: StatusOptions -> [FilePath] -> CommandStart
 start o locs = do
 	(l, cleanup) <- inRepo $ getStatus ps locs
 	getstatus <- ifM isDirect
-		( return statusDirect
-		, return $ \s -> pure (Just s)
+		( return (maybe (pure Nothing) statusDirect . simplifiedStatus)
+		, return (pure . simplifiedStatus)
 		)
 	forM_ l $ \s -> maybe noop displayStatus =<< getstatus s
 	ifM (liftIO cleanup)
@@ -56,8 +56,14 @@ start o locs = do
 		Nothing -> []
 		Just s -> [Param $ "--ignore-submodules="++s]
 
+-- Prefer to show unstaged status in this simplified status.
+simplifiedStatus :: StagedUnstaged Status -> Maybe Status
+simplifiedStatus (StagedUnstaged { unstaged = Just s }) = Just s
+simplifiedStatus (StagedUnstaged { staged = Just s }) = Just s
+simplifiedStatus _ = Nothing
+
 displayStatus :: Status -> Annex ()
--- renames not shown in this simplified status
+-- Renames not shown in this simplified status
 displayStatus (Renamed _ _) = noop
 displayStatus s = do
 	let c = statusChar s

Command/View.hs

@@ -14,6 +14,7 @@ import qualified Git.Ref
 import qualified Git.Branch
 import qualified Git.LsFiles as LsFiles
 import Git.FilePath
+import Git.Status
 import Types.View
 import Annex.View
 import Logs.View
@@ -30,14 +31,43 @@ start :: [String] -> CommandStart
 start [] = giveup "Specify metadata to include in view"
 start ps = do
 	showStart' "view" Nothing
+	ifM safeToEnterView
+		( do
 			view <- mkView ps
 			go view  =<< currentView
+		, giveup "Not safe to enter view."
+		)
   where
 	go view Nothing = next $ perform view
 	go view (Just v)
 		| v == view = stop
 		| otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view."
 
+safeToEnterView :: Annex Bool
+safeToEnterView = do
+	(l, cleanup) <- inRepo $ getStatus [] []
+	case filter dangerous l of
+		[] -> liftIO cleanup
+		_ -> do
+			warning "Your uncommitted changes would be lost when entering a view."
+			void $ liftIO cleanup
+			return False
+  where
+	dangerous (StagedUnstaged { staged = Nothing, unstaged = Nothing }) = False
+	-- Untracked files will not be affected by entering a view,
+	-- so are not dangerous.
+	dangerous (StagedUnstaged { staged = Just (Untracked _), unstaged = Nothing }) = False
+	dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Nothing }) = False
+	dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Just (Untracked _) }) = False
+	-- Staged changes would have their modifications either be 
+	-- lost when entering a view, or committed as part of the view.
+	-- Either is dangerous because upon leaving the view; the staged
+	-- changes would be lost.
+	dangerous (StagedUnstaged { staged = Just _ }) = True
+	-- Unstaged changes to annexed files would get lost when entering a
+	-- view.
+	dangerous (StagedUnstaged { unstaged = Just _ }) = True
+
 perform :: View -> CommandPerform
 perform view = do
 	showAction "searching"

Git/Status.hs

@@ -1,6 +1,6 @@
 {- git status interface
  -
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -20,6 +20,11 @@ data Status
 	| TypeChanged TopFilePath
 	| Untracked TopFilePath
 
+data StagedUnstaged a = StagedUnstaged
+	{ staged :: Maybe a
+	, unstaged :: Maybe a
+	}
+
 statusChar :: Status -> Char
 statusChar (Modified _) = 'M'
 statusChar (Deleted _) = 'D'
@@ -36,35 +41,32 @@ statusFile (Renamed _oldf newf) = newf
 statusFile (TypeChanged f) = f
 statusFile (Untracked f) = f
 
-parseStatusZ :: [String] -> [Status]
+parseStatusZ :: [String] -> [StagedUnstaged Status]
 parseStatusZ = go []
   where
 	go c [] = reverse c
 	go c (x:xs) = case x of
-		(sindex:sworktree:' ':f) -> 
-			-- Look at both the index and worktree status,
-			-- preferring worktree.
-			case cparse sworktree <|> cparse sindex of
-				Just mks -> go (mks (asTopFilePath f) : c) xs
-				Nothing -> if sindex == 'R'
-					-- In -z mode, the name the
-					-- file was renamed to comes
-					-- first, and the next component
-					-- is the old filename.
-					then case xs of
-						(oldf:xs') -> go (Renamed (asTopFilePath oldf) (asTopFilePath f) : c) xs'
-						_ -> go c []
-					else go c xs
+		(sstaged:sunstaged:' ':f) -> 
+			case (cparse sstaged f xs, cparse sunstaged f xs) of
+				((vstaged, xs1), (vunstaged, xs2)) ->
+					let v = StagedUnstaged
+						{ staged = vstaged
+						, unstaged = vunstaged
+						}
+					    xs' = fromMaybe xs (xs1 <|> xs2)
+					in go (v : c) xs'
 		_ -> go c xs
 
-	cparse 'M' = Just Modified
-	cparse 'A' = Just Added
-	cparse 'D' = Just Deleted
-	cparse 'T' = Just TypeChanged
-	cparse '?' = Just Untracked
-	cparse _ = Nothing
+	cparse 'M' f _ = (Just (Modified (asTopFilePath f)), Nothing)
+	cparse 'A' f _ = (Just (Added (asTopFilePath f)), Nothing)
+	cparse 'D' f _ = (Just (Deleted (asTopFilePath f)), Nothing)
+	cparse 'T' f _ = (Just (TypeChanged (asTopFilePath f)), Nothing)
+	cparse '?' f _ = (Just (Untracked (asTopFilePath f)), Nothing)
+	cparse 'R' f (oldf:xs) =
+		(Just (Renamed (asTopFilePath oldf) (asTopFilePath f)), Just xs)
+	cparse _ _ _ = (Nothing, Nothing)
 
-getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([Status], IO Bool)
+getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool)
 getStatus ps fs r = do
 	(ls, cleanup) <- pipeNullSplit ps' r
 	return (parseStatusZ ls, cleanup)