views: add automatically constructed file location metadata

When constructing views, metadata is available about the location of the
file in the view's reference branch. Allows incorporating parts of the
directory hierarchy in a view.

For example `git annex view tag=* podcasts/=*` makes a view in the form
tag/showname.

Performance impact: I benchmarked git annex view tag=* in the conference
proceedings repo to take 6.459s before this change, and 6.544s after.

FWIW, I considered making the syntax for this be podcasts/*, which might
be easier for the user to learn. However, I think it's not as good:

* The user has to then juggle two different syntaxes, and podcasts/* will
  be expanded by the shell so they also need to quote it, while podcasts/=*
  is unlikely to be expanded by the shell.
* It would allow for things like podcasts/*/* and *.mp3 which do not
  map well into views.

This commit was sponsored by Aurélien Pinceaux.

1 files changed, 29 insertions, 5 deletions

diff --git a/Annex/View.hs b/Annex/View.hs
index 0985e930f..ece5d099e 100644
--- a/Annex/View.hs
+++ b/Annex/View.hs
@@ -34,6 +34,7 @@ import Config
 import CmdLine.Action
 
 import qualified Data.Set as S
+import qualified Data.Map as M
 import "mtl" Control.Monad.Writer
 
 {- Each visible ViewFilter in a view results in another level of
@@ -233,11 +234,32 @@ prop_view_roundtrips f metadata visible = null f || viewTooLarge view ||
 	visiblefields = sort (map viewField $ filter viewVisible (viewComponents view))
 	hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
 
+{- A directory foo/bar/baz/ is turned into metadata fields
+ - /=foo, foo/=bar, foo/bar/=baz.
+ -
+ - Note that this may generate MetaFields that legalField rejects.
+ - This is necessary to have a 1:1 mapping between directory names and
+ - fields. So this MetaData cannot safely be serialized. -}
+getDirMetaData :: FilePath -> MetaData
+getDirMetaData d = MetaData $ M.fromList $ zip fields values
+  where
+	dirs = splitDirectories d
+	fields = map (MetaField . addTrailingPathSeparator . joinPath)
+		(inits dirs)
+	values = map (S.singleton . toMetaValue . fromMaybe "" . headMaybe)
+		(tails dirs)
+
+getWorkTreeMetaData :: FilePath -> MetaData
+getWorkTreeMetaData = getDirMetaData . dropFileName
+
+getViewedFileMetaData :: FilePath -> MetaData
+getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName
+
 {- Applies a view to the currently checked out branch, generating a new
  - branch for the view.
  -}
 applyView :: View -> Annex Git.Branch
-applyView view = applyView' viewedFileFromReference view
+applyView view = applyView' viewedFileFromReference getWorkTreeMetaData view
 
 {- Generates a new branch for a View, which must be a more narrow
  - version of the View originally used to generate the currently
@@ -245,7 +267,7 @@ applyView view = applyView' viewedFileFromReference view
  - in view, not any others.
  -}
 narrowView :: View -> Annex Git.Branch
-narrowView = applyView' viewedFileReuse
+narrowView = applyView' viewedFileReuse getViewedFileMetaData
 
 {- Go through each file in the currently checked out branch.
  - If the file is not annexed, skip it, unless it's a dotfile in the top.
@@ -255,8 +277,8 @@ narrowView = applyView' viewedFileReuse
  - Currently only works in indirect mode. Must be run from top of
  - repository.
  -}
-applyView' :: MkViewedFile -> View -> Annex Git.Branch
-applyView' mkviewedfile view = do
+applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch
+applyView' mkviewedfile getfilemetadata view = do
 	top <- fromRepo Git.repoPath
 	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
 	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
@@ -273,7 +295,9 @@ applyView' mkviewedfile view = do
 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
 	go uh hasher f (Just (k, _)) = do
 		metadata <- getCurrentMetaData k
-		forM_ (genviewedfiles f metadata) $ \fv -> do
+		let dirmetadata = getfilemetadata f
+		let metadata' = unionMetaData dirmetadata metadata
+		forM_ (genviewedfiles f metadata') $ \fv -> do
 			stagesymlink uh hasher fv =<< inRepo (gitAnnexLink fv k)
 	go uh hasher f Nothing
 		| "." `isPrefixOf` f = do