diff options
Diffstat (limited to 'Annex/View.hs')
| -rw-r--r-- | Annex/View.hs | 141 |
1 files changed, 55 insertions, 86 deletions
diff --git a/Annex/View.hs b/Annex/View.hs index 78b4da589..9d1a763e2 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -5,11 +5,10 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Annex.View where import Common.Annex +import Annex.View.ViewedFile import Types.View import Types.MetaData import qualified Git @@ -28,22 +27,16 @@ import Annex.Link import Annex.CatFile import Logs.MetaData import Logs.View +import Utility.Glob import Utility.FileMode import Types.Command import Config import CmdLine.Action import qualified Data.Set as S -import System.Path.WildMatch +import qualified Data.Map as M import "mtl" Control.Monad.Writer -#ifdef WITH_TDFA -import Text.Regex.TDFA -import Text.Regex.TDFA.String -#else -import Text.Regex -#endif - {- Each visible ViewFilter in a view results in another level of - subdirectory nesting. When a file matches multiple ways, it will appear - in multiple subdirectories. This means there is a bit of an exponential @@ -127,42 +120,13 @@ combineViewFilter old@(FilterValues olds) (FilterValues news) combineViewFilter (FilterValues _) newglob@(FilterGlob _) = (newglob, Widening) combineViewFilter (FilterGlob oldglob) new@(FilterValues s) - | all (matchGlob (compileGlob oldglob) . fromMetaValue) (S.toList s) = (new, Narrowing) + | all (matchGlob (compileGlob oldglob CaseInsensative) . fromMetaValue) (S.toList s) = (new, Narrowing) | otherwise = (new, Widening) combineViewFilter (FilterGlob old) newglob@(FilterGlob new) | old == new = (newglob, Unchanged) - | matchGlob (compileGlob old) new = (newglob, Narrowing) + | matchGlob (compileGlob old CaseInsensative) new = (newglob, Narrowing) | otherwise = (newglob, Widening) -{- Converts a filepath used in a reference branch to the - - filename that will be used in the view. - - - - No two filepaths from the same branch should yeild the same result, - - so all directory structure needs to be included in the output file - - in some way. However, the branch's directory structure is not relevant - - in the view. - - - - So, from dir/subdir/file.foo, generate file_{dir;subdir}.foo - - - - (To avoid collisions with a filename that already contains {foo}, - - that is doubled to {{foo}}.) - -} -fileViewFromReference :: MkFileView -fileViewFromReference f = concat - [ double base - , if null dirs then "" else "_{" ++ double (intercalate ";" dirs) ++ "}" - , double $ concat extensions - ] - where - (path, basefile) = splitFileName f - dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path) - (base, extensions) = splitShortExtensions basefile - - double = replace "{" "{{" . replace "}" "}}" - -fileViewReuse :: MkFileView -fileViewReuse = takeFileName - {- Generates views for a file from a branch, based on its metadata - and the filename used in the branch. - @@ -176,10 +140,10 @@ fileViewReuse = takeFileName - evaluate this function with the view parameter and reuse - the result. The globs in the view will then be compiled and memoized. -} -fileViews :: View -> MkFileView -> FilePath -> MetaData -> [FileView] -fileViews view = +viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile] +viewedFiles view = let matchers = map viewComponentMatcher (viewComponents view) - in \mkfileview file metadata -> + in \mkviewedfile file metadata -> let matches = map (\m -> m metadata) matchers in if any isNothing matches then [] @@ -187,8 +151,8 @@ fileViews view = let paths = pathProduct $ map (map toViewPath) (visible matches) in if null paths - then [mkfileview file] - else map (</> mkfileview file) paths + then [mkviewedfile file] + else map (</> mkviewedfile file) paths where visible = map (fromJust . snd) . filter (viewVisible . fst) . @@ -205,31 +169,9 @@ viewComponentMatcher viewcomponent = \metadata -> matcher = case viewFilter viewcomponent of FilterValues s -> \values -> S.intersection s values FilterGlob glob -> - let regex = compileGlob glob + let cglob = compileGlob glob CaseInsensative in \values -> - S.filter (matchGlob regex . fromMetaValue) values - -compileGlob :: String -> Regex -compileGlob glob = -#ifdef WITH_TDFA - case compile (defaultCompOpt {caseSensitive = False}) defaultExecOpt regex of - Right r -> r - Left _ -> error $ "failed to compile regex: " ++ regex -#else - mkRegexWithOpts regex False True -#endif - where - regex = '^':wildToRegex glob - -matchGlob :: Regex -> String -> Bool -matchGlob regex val = -#ifdef WITH_TDFA - case execute regex val of - Right (Just _) -> True - _ -> False -#else - isJust $ matchRegex regex val -#endif + S.filter (matchGlob cglob . fromMetaValue) values toViewPath :: MetaValue -> FilePath toViewPath = concatMap escapeslash . fromMetaValue @@ -268,23 +210,28 @@ pathProduct (l:ls) = foldl combinel l ls where combinel xs ys = [combine x y | x <- xs, y <- ys] -{- Extracts the metadata from a fileview, based on the view that was used - - to construct it. -} -fromView :: View -> FileView -> MetaData -fromView view f = foldr (uncurry updateMetaData) newMetaData (zip fields values) +{- Extracts the metadata from a ViewedFile, based on the view that was used + - to construct it. + - + - Derived metadata is excluded. + -} +fromView :: View -> ViewedFile -> MetaData +fromView view f = MetaData $ + M.fromList (zip fields values) `M.difference` derived where visible = filter viewVisible (viewComponents view) fields = map viewField visible - paths = splitDirectories $ dropFileName f - values = map fromViewPath paths + paths = splitDirectories (dropFileName f) + values = map (S.singleton . fromViewPath) paths + MetaData derived = getViewedFileMetaData f {- Constructing a view that will match arbitrary metadata, and applying - - it to a file yields a set of FileViews which all contain the same + - it to a file yields a set of ViewedFile which all contain the same - MetaFields that were present in the input metadata - (excluding fields that are not visible). -} prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool prop_view_roundtrips f metadata visible = null f || viewTooLarge view || - all hasfields (fileViews view fileViewFromReference f metadata) + all hasfields (viewedFiles view viewedFileFromReference f metadata) where view = View (Git.Ref "master") $ map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible) @@ -292,11 +239,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' fileViewFromReference 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 @@ -304,18 +272,18 @@ applyView view = applyView' fileViewFromReference view - in view, not any others. -} narrowView :: View -> Annex Git.Branch -narrowView = applyView' fileViewReuse +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. - - Look up the metadata of annexed files, and generate any FileViews, + - Look up the metadata of annexed files, and generate any ViewedFiles, - and stage them. - - Currently only works in indirect mode. Must be run from top of - repository. -} -applyView' :: MkFileView -> View -> Annex Git.Branch -applyView' mkfileview 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 @@ -329,10 +297,11 @@ applyView' mkfileview view = do void $ stopUpdateIndex uh void clean where - genfileviews = fileViews view mkfileview -- enables memoization + genviewedfiles = viewedFiles view mkviewedfile -- enables memoization go uh hasher f (Just (k, _)) = do metadata <- getCurrentMetaData k - forM_ (genfileviews f metadata) $ \fv -> do + let metadata' = getfilemetadata f `unionMetaData` metadata + forM_ (genviewedfiles f metadata') $ \fv -> do stagesymlink uh hasher fv =<< inRepo (gitAnnexLink fv k) go uh hasher f Nothing | "." `isPrefixOf` f = do @@ -381,7 +350,7 @@ updateView view ref oldref = genViewBranch view $ do - Note that removes must be handled before adds. This is so - that moving a file from x/foo/ to x/bar/ adds back the metadata for x. -} -withViewChanges :: (FileView -> Key -> CommandStart) -> (FileView -> Key -> CommandStart) -> Annex () +withViewChanges :: (ViewedFile -> Key -> CommandStart) -> (ViewedFile -> Key -> CommandStart) -> Annex () withViewChanges addmeta removemeta = do makeabs <- flip fromTopFilePath <$> gitRepo (diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef |