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,28 +60,64 @@ 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
+-- adjusted branch can be reversed to the commit that would have been made
+-- without the adjustment and applied to the original branch.
+class ReversableAdjustment t where
+	reverseAdjustment :: t -> t
+
+instance ReversableAdjustment Adjustment where
+	reverseAdjustment (LinkAdjustment l) = 
+		LinkAdjustment (reverseAdjustment l)
+	reverseAdjustment (PresenceAdjustment p ml) =
+		PresenceAdjustment (reverseAdjustment p) (fmap reverseAdjustment ml)
+
+instance ReversableAdjustment LinkAdjustment where
 	reverseAdjustment UnlockAdjustment = LockAdjustment
 	reverseAdjustment LockAdjustment = UnlockAdjustment
-reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
-reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
 	reverseAdjustment FixAdjustment = UnFixAdjustment
 	reverseAdjustment UnFixAdjustment = FixAdjustment
 
-{- How to perform various adjustments to a TreeItem. -}
-adjustTreeItem :: Adjustment -> TreeItem -> Annex (Maybe TreeItem)
+instance ReversableAdjustment PresenceAdjustment where
+	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)
@@ -135,22 +173,42 @@ basisBranch (AdjBranch adjbranch) = BasisBranch $
 adjustedBranchPrefix :: String
 adjustedBranchPrefix = "refs/heads/adjusted/"
 
-serialize :: Adjustment -> String
+class SerializeAdjustment t where
+	serialize :: t -> String
+	deserialize :: String -> Maybe t
+
+instance SerializeAdjustment Adjustment where
+	serialize (LinkAdjustment l) = serialize l
+	serialize (PresenceAdjustment p Nothing) = serialize p
+	serialize (PresenceAdjustment p (Just l)) = 
+		serialize p ++ "-" ++ serialize l
+	deserialize s = 
+		(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 HideMissingAdjustment = "present"
-serialize ShowMissingAdjustment = "showmissing"
 	serialize FixAdjustment = "fixed"
 	serialize UnFixAdjustment = "unfixed"
-
-deserialize :: String -> Maybe Adjustment
 	deserialize "unlocked" = Just UnlockAdjustment
 	deserialize "locked" = Just UnlockAdjustment
-deserialize "present" = Just HideMissingAdjustment
 	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 $
 	adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")"
@@ -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