67fd06af76
(And a vpop command, which is still a bit buggy.) Still need to do vadd and vrm, though this also adds their documentation. Currently not very happy with the view log data serialization. I had to lose the TDFA regexps temporarily, so I can have Read/Show instances of View. I expect the view log format will change in some incompatable way later, probably adding last known refs for the parent branch to View or something like that. Anyway, it basically works, although it's a bit slow looking up the metadata. The actual git branch construction is about as fast as it can be using the current git plumbing. This commit was sponsored by Peter Hogg.
88 lines
2.4 KiB
Haskell
88 lines
2.4 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2014 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.View where
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import qualified Git
|
|
import qualified Git.Command
|
|
import qualified Git.Ref
|
|
import qualified Git.Branch
|
|
import Types.MetaData
|
|
import Types.View
|
|
import Annex.View
|
|
import Logs.View
|
|
|
|
def :: [Command]
|
|
def = [notBareRepo $ notDirect $
|
|
command "view" paramView seek SectionUtility "enter a view branch"]
|
|
|
|
seek :: CommandSeek
|
|
seek = withWords start
|
|
|
|
start :: [String] -> CommandStart
|
|
start [] = error "Specify metadata to include in view"
|
|
start params = do
|
|
showStart "view" ""
|
|
view <- mkView params
|
|
go view =<< currentView
|
|
where
|
|
go view Nothing = next $ perform view
|
|
go view (Just v)
|
|
| v == view = stop
|
|
| otherwise = error "Already in a view. Use 'git annex vadd' to further refine this view."
|
|
|
|
perform :: View -> CommandPerform
|
|
perform view = do
|
|
showSideAction "calculating"
|
|
branch <- applyView view
|
|
next $ checkoutViewBranch view branch
|
|
|
|
paramView :: String
|
|
paramView = paramPair (paramRepeating "FIELD=VALUE") (paramRepeating "TAG")
|
|
|
|
parseViewParam :: String -> (MetaField, String)
|
|
parseViewParam s = case separate (== '=') s of
|
|
(tag, []) -> (tagMetaField, tag)
|
|
(field, wanted) -> either error (\f -> (f, wanted)) (mkMetaField field)
|
|
|
|
mkView :: [String] -> Annex View
|
|
mkView params = do
|
|
v <- View <$> viewbranch <*> pure []
|
|
return $ calc v $ reverse params
|
|
where
|
|
calc v [] = v
|
|
calc v (p:ps) =
|
|
let (v', _) = uncurry (refineView v) (parseViewParam p)
|
|
in calc v' ps
|
|
viewbranch = fromMaybe (error "not on any branch!")
|
|
<$> inRepo Git.Branch.current
|
|
|
|
checkoutViewBranch :: View -> Git.Branch -> CommandCleanup
|
|
checkoutViewBranch view branch = do
|
|
ok <- inRepo $ Git.Command.runBool
|
|
[ Param "checkout"
|
|
, Param (show $ Git.Ref.base branch)
|
|
]
|
|
when ok $ do
|
|
setView view
|
|
top <- fromRepo Git.repoPath
|
|
cwd <- liftIO getCurrentDirectory
|
|
{- A git repo can easily have empty directories in it,
|
|
- and this pollutes the view, so remove them. -}
|
|
liftIO $ removeemptydirs top
|
|
unlessM (liftIO $ doesDirectoryExist cwd) $
|
|
showLongNote (cwdmissing top)
|
|
return ok
|
|
where
|
|
removeemptydirs top = mapM_ (tryIO . removeDirectory)
|
|
=<< dirTreeRecursiveSkipping (".git" `isSuffixOf`) top
|
|
cwdmissing top = unlines
|
|
[ "This view does not include the subdirectory you are currently in."
|
|
, "Perhaps you should: cd " ++ top
|
|
]
|