refactor getCurrentBranch

Both Command.Sync and Annex.Ingest had their own versions of this.

The one in Annex.Ingest used Git.Branch.currentUnsafe, but does not seem
to need it. That is only checking to see if it's in an adjusted unlocked
branch, and when in an adjusted branch, the branch does in fact exist,
so the added check that Git.Branch.current does is fine.

This commit was sponsored by Denis Dzyubenko on Patreon.

Annex.hs

@@ -65,6 +65,7 @@ import Types.NumCopies
 import Types.LockCache
 import Types.DesktopNotify
 import Types.CleanupActions
+import Types.AdjustedBranch
 import qualified Database.Keys.Handle as Keys
 import Utility.InodeCache
 import Utility.Url
@@ -144,7 +145,7 @@ data AnnexState = AnnexState
 	, activekeys :: TVar (M.Map Key ThreadId)
 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
 	, keysdbhandle :: Maybe Keys.DbHandle
-	, cachedcurrentbranch :: Maybe Git.Branch
+	, cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment))
 	, cachedgitenv :: Maybe [(String, String)]
 	, urloptions :: Maybe UrlOptions
 	}

Annex/AdjustedBranch.hs

@@ -11,6 +11,7 @@ module Annex.AdjustedBranch (
 	Adjustment(..),
 	LinkAdjustment(..),
 	PresenceAdjustment(..),
+	adjustmentHidesFiles,
 	OrigBranch,
 	AdjBranch(..),
 	originalToAdjusted,
@@ -29,6 +30,8 @@ module Annex.AdjustedBranch (
 ) where
 
 import Annex.Common
+import Types.AdjustedBranch
+import Annex.AdjustedBranch.Name
 import qualified Annex
 import Git
 import Git.Types
@@ -59,46 +62,6 @@ 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
-	deriving (Show, Eq)
-
-data PresenceAdjustment
-	= HideMissingAdjustment
-	| ShowMissingAdjustment
-	deriving (Show, Eq)
-
--- 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 FixAdjustment = UnFixAdjustment
-	reverseAdjustment UnFixAdjustment = FixAdjustment
-
-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)
@@ -156,9 +119,6 @@ adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
 			<$> hashSymlink linktarget
 	Nothing -> return (Just ti)
 
-type OrigBranch = Branch
-newtype AdjBranch = AdjBranch { adjBranch :: Branch }
-
 -- This is a hidden branch ref, that's used as the basis for the AdjBranch,
 -- since pushes can overwrite the OrigBranch at any time. So, changes
 -- are propigated from the AdjBranch to the head of the BasisBranch.
@@ -170,62 +130,6 @@ basisBranch :: AdjBranch -> BasisBranch
 basisBranch (AdjBranch adjbranch) = BasisBranch $
 	Ref ("refs/basis/" ++ fromRef (Git.Ref.base adjbranch))
 
-adjustedBranchPrefix :: String
-adjustedBranchPrefix = "refs/heads/adjusted/"
-
-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 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 $
-	adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")"
-  where
-	base = fromRef (Git.Ref.base orig)
-
-adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)
-adjustedToOriginal b
-	| adjustedBranchPrefix `isPrefixOf` bs = do
-		let (base, as) = separate (== '(') (drop prefixlen bs)
-		adj <- deserialize (takeWhile (/= ')') as)
-		Just (adj, Git.Ref.branchRef (Ref base))
-	| otherwise = Nothing
-  where
-	bs = fromRef b
-	prefixlen = length adjustedBranchPrefix
-
 getAdjustment :: Branch -> Maybe Adjustment
 getAdjustment = fmap fst . adjustedToOriginal
 

Annex/AdjustedBranch/Name.hs

@@ -0,0 +1,83 @@
+{- adjusted branch names
+ -
+ - Copyright 2016-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Annex.AdjustedBranch.Name (
+	originalToAdjusted,
+	adjustedToOriginal,
+	AdjBranch(..),
+	OrigBranch,
+) where
+
+import Types.AdjustedBranch
+import Git
+import qualified Git.Ref
+import Utility.Misc
+
+import Control.Applicative
+import Data.List
+
+adjustedBranchPrefix :: String
+adjustedBranchPrefix = "refs/heads/adjusted/"
+
+class SerializeAdjustment t where
+	serializeAdjustment :: t -> String
+	deserializeAdjustment :: String -> Maybe t
+
+instance SerializeAdjustment Adjustment where
+	serializeAdjustment (LinkAdjustment l) =
+		serializeAdjustment l
+	serializeAdjustment (PresenceAdjustment p Nothing) =
+		serializeAdjustment p
+	serializeAdjustment (PresenceAdjustment p (Just l)) = 
+		serializeAdjustment p ++ "-" ++ serializeAdjustment l
+	deserializeAdjustment s = 
+		(LinkAdjustment <$> deserializeAdjustment s)
+			<|>
+		(PresenceAdjustment <$> deserializeAdjustment s1 <*> pure (deserializeAdjustment s2))
+			<|>
+		(PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing)
+	  where
+		(s1, s2) = separate (== '-') s
+
+instance SerializeAdjustment LinkAdjustment where
+	serializeAdjustment UnlockAdjustment = "unlocked"
+	serializeAdjustment LockAdjustment = "locked"
+	serializeAdjustment FixAdjustment = "fixed"
+	serializeAdjustment UnFixAdjustment = "unfixed"
+	deserializeAdjustment "unlocked" = Just UnlockAdjustment
+	deserializeAdjustment "locked" = Just UnlockAdjustment
+	deserializeAdjustment "fixed" = Just FixAdjustment
+	deserializeAdjustment "unfixed" = Just UnFixAdjustment
+	deserializeAdjustment _ = Nothing
+
+instance SerializeAdjustment PresenceAdjustment where
+	serializeAdjustment HideMissingAdjustment = "hidemissing"
+	serializeAdjustment ShowMissingAdjustment = "showmissing"
+	deserializeAdjustment "hidemissing" = Just HideMissingAdjustment
+	deserializeAdjustment "showmissing" = Just ShowMissingAdjustment
+	deserializeAdjustment _ = Nothing
+
+newtype AdjBranch = AdjBranch { adjBranch :: Branch }
+
+originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
+originalToAdjusted orig adj = AdjBranch $ Ref $
+	adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")"
+  where
+	base = fromRef (Git.Ref.base orig)
+
+type OrigBranch = Branch
+
+adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)
+adjustedToOriginal b
+	| adjustedBranchPrefix `isPrefixOf` bs = do
+		let (base, as) = separate (== '(') (drop prefixlen bs)
+		adj <- deserializeAdjustment (takeWhile (/= ')') as)
+		Just (adj, Git.Ref.branchRef (Ref base))
+	| otherwise = Nothing
+  where
+	bs = fromRef b
+	prefixlen = length adjustedBranchPrefix

Annex/CurrentBranch.hs

@@ -0,0 +1,41 @@
+{- currently checked out branch
+ -
+ - Copyright 2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Annex.CurrentBranch where
+
+import Annex.Common
+import Types.AdjustedBranch
+import Annex.AdjustedBranch.Name
+import qualified Annex
+import qualified Git
+import qualified Git.Branch
+
+type CurrBranch = (Maybe Git.Branch, Maybe Adjustment)
+
+{- Gets the currently checked out branch.
+ - When on an adjusted branch, gets the original branch, and the adjustment.
+ -
+ - Cached for speed.
+ -
+ - Until a commit is made in a new repository, no branch is checked out.
+ - Since git-annex may make the first commit, this does not cache
+ - the absence of a branch.
+ -}
+getCurrentBranch :: Annex CurrBranch
+getCurrentBranch = maybe cache return
+	=<< Annex.getState Annex.cachedcurrentbranch
+  where
+	cache = inRepo Git.Branch.current >>= \case
+		Just b -> do
+			let v = case adjustedToOriginal b of 
+                        	Nothing -> (Just b, Nothing) 
+                                Just (adj, origbranch) -> 
+                                	(Just origbranch, Just adj)
+			Annex.changeState $ \s ->
+				s { Annex.cachedcurrentbranch = Just v }
+			return v
+		Nothing -> return (Nothing, Nothing)

Annex/Ingest.hs

@@ -32,12 +32,12 @@ import Annex.Content.Direct
 import Annex.Perms
 import Annex.Link
 import Annex.MetaData
+import Annex.CurrentBranch
 import Annex.Version
 import Logs.Location
 import qualified Annex
 import qualified Annex.Queue
 import qualified Database.Keys
-import qualified Git
 import qualified Git.Branch
 import Config
 import Utility.InodeCache
@@ -329,26 +329,14 @@ addUnlocked = isDirect <||>
 	(versionSupportsUnlockedPointers <&&>
 	 ((not . coreSymlinks <$> Annex.getGitConfig) <||>
 	  (annexAddUnlocked <$> Annex.getGitConfig) <||>
-	  (maybe False (isadjustedunlocked . getAdjustment) <$> cachedCurrentBranch)
+	  (maybe False isadjustedunlocked . snd <$> getCurrentBranch)
 	 )
 	)
   where
-	isadjustedunlocked (Just (LinkAdjustment UnlockAdjustment)) = True
-	isadjustedunlocked (Just (PresenceAdjustment _ (Just UnlockAdjustment))) = True
+	isadjustedunlocked (LinkAdjustment UnlockAdjustment) = True
+	isadjustedunlocked (PresenceAdjustment _ (Just UnlockAdjustment)) = True
 	isadjustedunlocked _ = False
 
-cachedCurrentBranch :: Annex (Maybe Git.Branch)
-cachedCurrentBranch = maybe cache (return . Just)
-	=<< Annex.getState Annex.cachedcurrentbranch
-  where
-	cache :: Annex (Maybe Git.Branch)
-	cache = inRepo Git.Branch.currentUnsafe >>= \case
-		Nothing -> return Nothing
-		Just b -> do
-			Annex.changeState $ \s ->
-				s { Annex.cachedcurrentbranch = Just b }
-			return (Just b)
-
 {- Adds a file to the work tree for the key, and stages it in the index.
  - The content of the key may be provided in a temp file, which will be
  - moved into place.

Assistant/Sync.hs

@@ -25,6 +25,7 @@ import qualified Annex.Branch
 import Annex.UUID
 import Annex.TaggedPush
 import Annex.Ssh
+import Annex.CurrentBranch
 import qualified Config
 import Git.Config
 import Config.DynamicConfig
@@ -79,8 +80,7 @@ reconnectRemotes rs = void $ do
 	{- No local branch exists yet, but we can try pulling. -}
 	sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes
 	go = do
-		(failed, diverged) <- sync
-			=<< liftAnnex (join Command.Sync.getCurrBranch)
+		(failed, diverged) <- sync =<< liftAnnex getCurrentBranch
 		addScanRemotes diverged =<<
 			filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs
 		return failed
@@ -127,7 +127,7 @@ pushToRemotes' now remotes = do
 		Annex.Branch.commit =<< Annex.Branch.commitMessage
 		(,,)
 			<$> gitRepo
-			<*> join Command.Sync.getCurrBranch
+			<*> getCurrentBranch
 			<*> getUUID
 	ret <- go True branch g u remotes
 	return ret

Assistant/Threads/Committer.hs

@@ -32,6 +32,7 @@ import Annex.Link
 import Annex.CatFile
 import Annex.InodeSentinal
 import Annex.Version
+import Annex.CurrentBranch
 import qualified Annex
 import Utility.InodeCache
 import Annex.Content.Direct
@@ -228,7 +229,7 @@ commitStaged msg = do
 		Right _ -> do
 			ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg
 			when ok $
-				Command.Sync.updateSyncBranch =<< join Command.Sync.getCurrBranch
+				Command.Sync.updateSyncBranch =<< getCurrentBranch
 			return ok
 
 {- OSX needs a short delay after a file is added before locking it down,

Assistant/Threads/Exporter.hs

@@ -12,6 +12,7 @@ import Assistant.Commits
 import Assistant.Pushes
 import Assistant.DaemonStatus
 import Annex.Concurrent
+import Annex.CurrentBranch
 import Utility.ThreadScheduler
 import qualified Annex
 import qualified Remote
@@ -64,7 +65,7 @@ exportToRemotes rs = do
 			Annex.changeState $ \st -> st { Annex.errcounter = 0 }
 			start <- liftIO getCurrentTime
 			void $ Command.Sync.seekExportContent rs
-				=<< join Command.Sync.getCurrBranch
+				=<< getCurrentBranch
 			-- Look at command error counter to see if the export
 			-- didn't work.
 			failed <- (> 0) <$> Annex.getState Annex.errcounter

Assistant/Threads/Merger.hs

@@ -13,6 +13,7 @@ import Assistant.BranchChange
 import Assistant.Sync
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
+import Annex.CurrentBranch
 import qualified Annex.Branch
 import qualified Git
 import qualified Git.Branch
@@ -71,7 +72,7 @@ onChange file
 	changedbranch = fileToBranch file
 
 	mergecurrent =
-		mergecurrent' =<< liftAnnex (join Command.Sync.getCurrBranch)
+		mergecurrent' =<< liftAnnex getCurrentBranch
 	mergecurrent' currbranch@(Just b, _)
 		| changedbranch `isRelatedTo` b =
 			whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do

Assistant/WebApp/Configurators/Local.hs

@@ -20,7 +20,6 @@ import qualified Annex
 import qualified Git
 import qualified Git.Config
 import qualified Git.Command
-import qualified Command.Sync
 import Config.Files
 import Utility.FreeDesktop
 import Utility.DiskFree
@@ -30,6 +29,7 @@ import Utility.Mounts
 import Utility.DataUnits
 import Remote (prettyUUID)
 import Annex.UUID
+import Annex.CurrentBranch
 import Types.StandardGroups
 import Logs.PreferredContent
 import Logs.UUID
@@ -212,7 +212,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
  - immediately pulling from it. Also spawns a sync to push to it as well. -}
 immediateSyncRemote :: Remote -> Assistant ()
 immediateSyncRemote r = do
-	currentbranch <- liftAnnex $ join Command.Sync.getCurrBranch
+	currentbranch <- liftAnnex $ getCurrentBranch
 	void $ manualPull currentbranch [r]
 	syncRemote r
 

Command/Merge.hs

@@ -9,7 +9,8 @@ module Command.Merge where
 
 import Command
 import qualified Annex.Branch
-import Command.Sync (prepMerge, mergeLocal, getCurrBranch, mergeConfig)
+import Annex.CurrentBranch
+import Command.Sync (prepMerge, mergeLocal, mergeConfig)
 
 cmd :: Command
 cmd = command "merge" SectionMaintenance
@@ -33,4 +34,4 @@ mergeBranch = do
 mergeSynced :: CommandStart
 mergeSynced = do
 	prepMerge
-	mergeLocal mergeConfig def =<< join getCurrBranch
+	mergeLocal mergeConfig def =<< getCurrentBranch

Command/PostReceive.hs

@@ -11,7 +11,8 @@ import Command
 import qualified Annex
 import Git.Types
 import Annex.UpdateInstead
-import Command.Sync (mergeLocal, prepMerge, mergeConfig, getCurrBranch)
+import Annex.CurrentBranch
+import Command.Sync (mergeLocal, prepMerge, mergeConfig)
 
 -- This does not need to modify the git-annex branch to update the 
 -- work tree, but auto-initialization might change the git-annex branch.
@@ -48,4 +49,4 @@ fixPostReceiveHookEnv = do
 updateInsteadEmulation :: CommandStart
 updateInsteadEmulation = do
 	prepMerge
-	mergeLocal mergeConfig def =<< join getCurrBranch
+	mergeLocal mergeConfig def =<< getCurrentBranch

Command/Sync.hs

@@ -9,7 +9,6 @@
 module Command.Sync (
 	cmd,
 	CurrBranch,
-	getCurrBranch,
 	mergeConfig,
 	merge,
 	prepMerge,
@@ -60,6 +59,7 @@ import Annex.UpdateInstead
 import Annex.Export
 import Annex.LockFile
 import Annex.TaggedPush
+import Annex.CurrentBranch
 import qualified Database.Export as Export
 import Utility.Bloom
 import Utility.OptParse
@@ -162,8 +162,7 @@ seek :: SyncOptions -> CommandSeek
 seek o = allowConcurrentOutput $ do
 	prepMerge
 
-	getbranch <- getCurrBranch 
-	let withbranch a = a =<< getbranch
+	let withbranch a = a =<< getCurrentBranch
 
 	remotes <- syncRemotes (syncWith o)
 	let gitremotes = filter Remote.gitSyncableRemote remotes
@@ -188,7 +187,7 @@ seek o = allowConcurrentOutput $ do
 				]
 			
 			whenM shouldsynccontent $ do
-				syncedcontent <- seekSyncContent o dataremotes
+				syncedcontent <- withbranch $ seekSyncContent o dataremotes
 				exportedcontent <- withbranch $ seekExportContent exportremotes
 				-- Transferring content can take a while,
 				-- and other changes can be pushed to the
@@ -209,35 +208,6 @@ seek o = allowConcurrentOutput $ do
 		<||> pure (not (null (contentOfOption o)))
 		<||> (pure (not (noContentOption o)) <&&> getGitConfigVal annexSyncContent)
 
-type CurrBranch = (Maybe Git.Branch, Maybe Adjustment)
-
-{- There may not be a branch checked out until after the commit,
- - or perhaps after it gets merged from the remote, or perhaps
- - never.
- -
- - So only look it up once it's needed, and once there is a
- - branch, cache it.
- -
- - When on an adjusted branch, gets the original branch, and the adjustment.
- -}
-getCurrBranch :: Annex (Annex CurrBranch)
-getCurrBranch = do
-	mvar <- liftIO newEmptyMVar
-	return $ ifM (liftIO $ isEmptyMVar mvar)
-		( do
-			currbranch <- inRepo Git.Branch.current
-			case currbranch of
-				Nothing -> return (Nothing, Nothing)
-				Just b -> do
-					let v = case adjustedToOriginal b of
-						Nothing -> (Just b, Nothing)
-						Just (adj, origbranch) ->
-							(Just origbranch, Just adj)
-					liftIO $ putMVar mvar v
-					return v
-		, liftIO $ readMVar mvar
-		)
-
 {- Merging may delete the current directory, so go to the top
  - of the repo. This also means that sync always acts on all files in the
  - repository, not just on a subdirectory. -}
@@ -568,8 +538,11 @@ newer remote b = do
 		, return True
 		)
 
-{- Without --all, only looks at files in the work tree. With --all,
- - makes 2 passes, first looking at the work tree and then all keys.
+{- Without --all, only looks at files in the work tree.
+ - (Or, when in an ajusted branch where some files are hidden, at files in
+ - the original branch.)
+ -
+ - With --all, makes a second pass over all keys.
  - This ensures that preferred content expressions that match on
  - filenames work, even when in --all mode.
  -
@@ -577,15 +550,19 @@ newer remote b = do
  -
  - When concurrency is enabled, files are processed concurrently.
  -}
-seekSyncContent :: SyncOptions -> [Remote] -> Annex Bool
-seekSyncContent o rs = do
+seekSyncContent :: SyncOptions -> [Remote] -> CurrBranch -> Annex Bool
+seekSyncContent o rs currbranch = do
 	mvar <- liftIO newEmptyMVar
 	bloom <- case keyOptions o of
 		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])
-		_ -> do
-			l <- workTreeItems (contentOfOption o)
-			seekworktree mvar l (const noop)
-			pure Nothing
+		_ -> case currbranch of
+			(origbranch, Just adj) | adjustmentHidesFiles adj -> do
+				seekbranch origbranch (contentOfOption o)
+				pure Nohing
+			_ = do
+				l <- workTreeItems (contentOfOption o)
+				seekworktree mvar l (const noop)
+				pure Nothing
 	withKeyOptions' (keyOptions o) False
 		(return (seekkeys mvar bloom))
 		(const noop)
@@ -595,7 +572,11 @@ seekSyncContent o rs = do
   where
 	seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>=
 		mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (AssociatedFile (Just f))) noop)
+
+	seekbranch origbranch l = 
+
 	seekkeys mvar bloom (k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k
+
 	go ebloom mvar af k = commandAction $ do
 		whenM (syncFile ebloom rs af k) $
 			void $ liftIO $ tryPutMVar mvar ()

Types/AdjustedBranch.hs

@@ -0,0 +1,53 @@
+{- adjusted branch types
+ -
+ - Copyright 2016-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Types.AdjustedBranch where
+
+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
+	deriving (Show, Eq)
+
+data PresenceAdjustment
+	= HideMissingAdjustment
+	| ShowMissingAdjustment
+	deriving (Show, Eq)
+
+-- 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 FixAdjustment = UnFixAdjustment
+	reverseAdjustment UnFixAdjustment = FixAdjustment
+
+instance ReversableAdjustment PresenceAdjustment where
+	reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
+	reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
+
+adjustmentHidesFiles :: Adjustment -> Bool
+adjustmentHidesFiles (PresenceAdjustment HideMissingAdjustment _) = True
+adjustmentHidesFiles _ = False
+

git-annex.cabal

@@ -595,6 +595,7 @@ Executable git-annex
     Annex
     Annex.Action
     Annex.AdjustedBranch
+    Annex.AdjustedBranch.Name
     Annex.AutoMerge
     Annex.BloomFilter
     Annex.Branch
@@ -610,6 +611,7 @@ Executable git-annex
     Annex.Content.Direct
     Annex.Content.LowLevel
     Annex.Content.PointerFile
+    Annex.CurrentBranch
     Annex.Difference
     Annex.DirHashes
     Annex.Direct
@@ -942,6 +944,7 @@ Executable git-annex
     Test.Framework
     Types
     Types.ActionItem
+    Types.AdjustedBranch
     Types.Availability
     Types.Backend
     Types.BranchState