improve types to allow combining some adjustments

Combinations like --hide-misssing --unlocked seem very useful. On the
other hand, combining --fix with --unlock doesn't make sense because a
file can be either unlocked or a symlink that can be fixed, but not
both.

Changed the serialization of HideMissingAdjustment in passing, but it
has not actually been used yet so nothing will be broken.

This commit was sponsored by Trenton Cronholm on Patreon.

Annex/AdjustedBranch.hs

@@ -1,14 +1,16 @@
 {- adjusted branch
  -
- - Copyright 2016 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2018 Joey Hess <id@joeyh.name>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
  -}
 
 {-# LANGUAGE BangPatterns #-}
 
 module Annex.AdjustedBranch (
 	Adjustment(..),
+	LinkAdjustment(..),
+	PresenceAdjustment(..),
 	OrigBranch,
 	AdjBranch(..),
 	originalToAdjusted,
@@ -58,36 +60,72 @@ import Config
 import qualified Data.Map as M
 
 data Adjustment
+	= LinkAdjustment LinkAdjustment
+	| PresenceAdjustment PresenceAdjustment (Maybe LinkAdjustment)
+	deriving (Show, Eq)
+
+-- Doesn't make sense to combine unlock with fix.
+data LinkAdjustment
 	= UnlockAdjustment
 	| LockAdjustment
 	| FixAdjustment
 	| UnFixAdjustment
-	| HideMissingAdjustment
+	deriving (Show, Eq)
+
+data PresenceAdjustment
+	= HideMissingAdjustment
 	| ShowMissingAdjustment
 	deriving (Show, Eq)
 
-reverseAdjustment :: Adjustment -> Adjustment
+-- Adjustments have to be able to be reversed, so that commits made to the
-reverseAdjustment UnlockAdjustment = LockAdjustment
+-- adjusted branch can be reversed to the commit that would have been made
-reverseAdjustment LockAdjustment = UnlockAdjustment
+-- without the adjustment and applied to the original branch.
-reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
+class ReversableAdjustment t where
-reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
+	reverseAdjustment :: t -> t
-reverseAdjustment FixAdjustment = UnFixAdjustment
-reverseAdjustment UnFixAdjustment = FixAdjustment
 
-{- How to perform various adjustments to a TreeItem. -}
+instance ReversableAdjustment Adjustment where
-adjustTreeItem :: Adjustment -> TreeItem -> Annex (Maybe TreeItem)
+	reverseAdjustment (LinkAdjustment l) = 
-adjustTreeItem UnlockAdjustment = ifSymlink adjustToPointer noAdjust
+		LinkAdjustment (reverseAdjustment l)
-adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink
+	reverseAdjustment (PresenceAdjustment p ml) =
-adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust
+		PresenceAdjustment (reverseAdjustment p) (fmap reverseAdjustment ml)
-adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust
+
-adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) ->
+instance ReversableAdjustment LinkAdjustment where
-	catKey s >>= \case
+	reverseAdjustment UnlockAdjustment = LockAdjustment
-		Just k -> ifM (inAnnex k)
+	reverseAdjustment LockAdjustment = UnlockAdjustment
-			( return (Just ti)
+	reverseAdjustment FixAdjustment = UnFixAdjustment
-			, return Nothing
+	reverseAdjustment UnFixAdjustment = FixAdjustment
-			)
+
-		Nothing -> return (Just ti)
+instance ReversableAdjustment PresenceAdjustment where
-adjustTreeItem ShowMissingAdjustment = noAdjust
+	reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
+	reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
+
+-- How to perform various adjustments to a TreeItem.
+class AdjustTreeItem t where
+	adjustTreeItem :: t -> TreeItem -> Annex (Maybe TreeItem)
+
+instance AdjustTreeItem Adjustment where
+	adjustTreeItem (LinkAdjustment l) t = adjustTreeItem l t
+	adjustTreeItem (PresenceAdjustment p Nothing) t = adjustTreeItem p t
+	adjustTreeItem (PresenceAdjustment p (Just l)) t =
+		adjustTreeItem p t >>= \case
+			Nothing -> return Nothing
+			Just t' -> adjustTreeItem l t'
+
+instance AdjustTreeItem LinkAdjustment where
+	adjustTreeItem UnlockAdjustment = ifSymlink adjustToPointer noAdjust
+	adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink
+	adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust
+	adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust
+
+instance AdjustTreeItem PresenceAdjustment where
+	adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) ->
+		catKey s >>= \case
+			Just k -> ifM (inAnnex k)
+				( return (Just ti)
+				, return Nothing
+				)
+			Nothing -> return (Just ti)
+	adjustTreeItem ShowMissingAdjustment = noAdjust
 
 ifSymlink :: (TreeItem -> Annex a) -> (TreeItem -> Annex a) -> TreeItem -> Annex a
 ifSymlink issymlink notsymlink ti@(TreeItem _f m _s)
@@ -135,21 +173,41 @@ basisBranch (AdjBranch adjbranch) = BasisBranch $
 adjustedBranchPrefix :: String
 adjustedBranchPrefix = "refs/heads/adjusted/"
 
-serialize :: Adjustment -> String
+class SerializeAdjustment t where
-serialize UnlockAdjustment = "unlocked"
+	serialize :: t -> String
-serialize LockAdjustment = "locked"
+	deserialize :: String -> Maybe t
-serialize HideMissingAdjustment = "present"
-serialize ShowMissingAdjustment = "showmissing"
-serialize FixAdjustment = "fixed"
-serialize UnFixAdjustment = "unfixed"
 
-deserialize :: String -> Maybe Adjustment
+instance SerializeAdjustment Adjustment where
-deserialize "unlocked" = Just UnlockAdjustment
+	serialize (LinkAdjustment l) = serialize l
-deserialize "locked" = Just UnlockAdjustment
+	serialize (PresenceAdjustment p Nothing) = serialize p
-deserialize "present" = Just HideMissingAdjustment
+	serialize (PresenceAdjustment p (Just l)) = 
-deserialize "fixed" = Just FixAdjustment
+		serialize p ++ "-" ++ serialize l
-deserialize "unfixed" = Just UnFixAdjustment
+	deserialize s = 
-deserialize _ = Nothing
+		(LinkAdjustment <$> deserialize s)
+			<|>
+		(PresenceAdjustment <$> deserialize s1 <*> pure (deserialize s2))
+			<|>
+		(PresenceAdjustment <$> deserialize s <*> pure Nothing)
+	  where
+		(s1, s2) = separate (== '-') s
+
+instance SerializeAdjustment LinkAdjustment where
+	serialize UnlockAdjustment = "unlocked"
+	serialize LockAdjustment = "locked"
+	serialize FixAdjustment = "fixed"
+	serialize UnFixAdjustment = "unfixed"
+	deserialize "unlocked" = Just UnlockAdjustment
+	deserialize "locked" = Just UnlockAdjustment
+	deserialize "fixed" = Just FixAdjustment
+	deserialize "unfixed" = Just UnFixAdjustment
+	deserialize _ = Nothing
+
+instance SerializeAdjustment PresenceAdjustment where
+	serialize HideMissingAdjustment = "hidemissing"
+	serialize ShowMissingAdjustment = "showmissing"
+	deserialize "hidemissing" = Just HideMissingAdjustment
+	deserialize "showmissing" = Just ShowMissingAdjustment
+	deserialize _ = Nothing
 
 originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
 originalToAdjusted orig adj = AdjBranch $ Ref $
@@ -227,7 +285,7 @@ adjustToCrippledFileSystem = do
 			, Param "-m"
 			, Param "commit before entering adjusted unlocked branch"
 			]
-	unlessM (enterAdjustedBranch UnlockAdjustment) $
+	unlessM (enterAdjustedBranch (LinkAdjustment UnlockAdjustment)) $
 		warning "Failed to enter adjusted branch!"
 
 setBasisBranch :: BasisBranch -> Ref -> Annex ()

Annex/Ingest.hs

@@ -329,9 +329,13 @@ addUnlocked = isDirect <||>
 	(versionSupportsUnlockedPointers <&&>
 	 ((not . coreSymlinks <$> Annex.getGitConfig) <||>
 	  (annexAddUnlocked <$> Annex.getGitConfig) <||>
-	  (maybe False (\b -> getAdjustment b == Just UnlockAdjustment) <$> cachedCurrentBranch)
+	  (maybe False (isadjustedunlocked . getAdjustment) <$> cachedCurrentBranch)
 	 )
 	)
+  where
+	isadjustedunlocked (Just (LinkAdjustment UnlockAdjustment)) = True
+	isadjustedunlocked (Just (PresenceAdjustment _ (Just UnlockAdjustment))) = True
+	isadjustedunlocked _ = False
 
 cachedCurrentBranch :: Annex (Maybe Git.Branch)
 cachedCurrentBranch = maybe cache (return . Just)

Command/Adjust.hs

@@ -17,16 +17,16 @@ cmd = notBareRepo $ notDirect $ noDaemonRunning $
 
 optParser :: CmdParamsDesc -> Parser Adjustment
 optParser _ = 
-	flag' UnlockAdjustment
+	flag' (LinkAdjustment UnlockAdjustment)
 		( long "unlock"
 		<> help "unlock annexed files"
 		)
-	<|> flag' FixAdjustment
+	<|> flag' (LinkAdjustment FixAdjustment)
 		( long "fix"
 		<> help "fix symlinks to annnexed files"
 		)
 	{- Not ready yet
-	<|> flag' HideMissingAdjustment
+	<|> flag' (PresenseAdjustment HideMissingAdjustment)
 		( long "hide-missing"
 		<> help "omit annexed files whose content is not present"
 		)

Upgrade/V5.hs

@@ -56,7 +56,7 @@ upgrade automatic = do
 		{- Create adjusted branch where all files are unlocked.
 		 - This should have the same content for each file as
 		 - have been staged in upgradeDirectWorkTree. -}
-		AdjBranch b <- adjustBranch UnlockAdjustment cur
+		AdjBranch b <- adjustBranch (LinkAdjustment UnlockAdjustment) cur
 		{- Since the work tree was already set up by
 		 - upgradeDirectWorkTree, and contains unlocked file
 		 - contents too, don't use git checkout to check out the