{-# LANGUAGE NamedFieldPuns #-}
module Darcs.UI.Completion
( fileArgs, knownFileArgs, unknownFileArgs, modifiedFileArgs
, noArgs, prefArgs
) where
import Darcs.Prelude
import Data.List ( (\\), stripPrefix )
import Data.List.Ordered ( nubSort, minus )
import Data.Maybe ( mapMaybe )
import Darcs.Patch ( listTouchedFiles )
import Darcs.Repository.Flags
( UseCache(..)
)
import Darcs.Repository.Prefs
( getPreflist
)
import Darcs.Repository.Job
( RepoJob(..)
, withRepository
)
import Darcs.Repository.State
( readRecordedAndPending
, readUnrecordedFiltered
, unrecordedChanges
, restrictDarcsdir
, applyTreeFilter
, TreeFilter(..)
)
import Darcs.UI.Flags ( DarcsFlag )
import qualified Darcs.UI.Flags as Flags
import qualified Darcs.UI.Options.All as O
import Darcs.Util.File
( doesDirectoryReallyExist
)
import Darcs.Util.Global
( darcsdir
)
import Darcs.Util.Path
( AnchoredPath, anchorPath
, AbsolutePath, toPath, floatSubPath, makeSubPathOf
)
import Darcs.Util.Tree as Tree
( Tree, ItemType(..)
, expand, expandPath, list, findTree, itemType, emptyTree
)
import Darcs.Util.Tree.Plain ( readPlainTree )
fileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [FilePath]
fileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
fileArgs (AbsolutePath
_, AbsolutePath
orig) [DarcsFlag]
_flags [String]
args =
[String] -> IO [String] -> IO [String]
notYetListed [String]
args (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$
(Tree IO -> [String]) -> IO (Tree IO) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((AnchoredPath, ItemType) -> String)
-> [(AnchoredPath, ItemType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath, ItemType) -> String
anchoredToFilePath ([(AnchoredPath, ItemType)] -> [String])
-> (Tree IO -> [(AnchoredPath, ItemType)]) -> Tree IO -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> [(AnchoredPath, ItemType)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, ItemType)]
listItems) (IO (Tree IO) -> IO [String]) -> IO (Tree IO) -> IO [String]
forall a b. (a -> b) -> a -> b
$
Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
Tree.expand (Tree IO -> IO (Tree IO))
-> (Tree IO -> Tree IO) -> Tree IO -> IO (Tree IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
forall (m :: * -> *). TreeFilter m
restrictDarcsdir (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Tree IO)
readPlainTree (AbsolutePath -> String
forall a. FilePathOrURL a => a -> String
toPath AbsolutePath
orig)
unknownFileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [FilePath]
unknownFileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
unknownFileArgs (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
flags [String]
args = [String] -> IO [String] -> IO [String]
notYetListed [String]
args (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ do
let sk :: ScanKnown
sk = if [DarcsFlag] -> Bool
Flags.includeBoring [DarcsFlag]
flags then ScanKnown
O.ScanBoring else ScanKnown
O.ScanAll
lfm :: LookForMoves
lfm = [DarcsFlag] -> LookForMoves
Flags.lookForMoves [DarcsFlag]
flags
lfr :: LookForReplaces
lfr = [DarcsFlag] -> LookForReplaces
Flags.lookForReplaces [DarcsFlag]
flags
RepoTrees {Tree IO
have :: forall (m :: * -> *). RepoTrees m -> Tree m
have :: Tree IO
have, Tree IO
known :: forall (m :: * -> *). RepoTrees m -> Tree m
known :: Tree IO
known} <- UseIndex
-> ScanKnown
-> LookForMoves
-> LookForReplaces
-> IO (RepoTrees IO)
repoTrees UseIndex
O.UseIndex ScanKnown
sk LookForMoves
lfm LookForReplaces
lfr
[(AnchoredPath, ItemType)]
known_paths <- Tree IO
-> (AbsolutePath, AbsolutePath) -> IO [(AnchoredPath, ItemType)]
listHere Tree IO
known (AbsolutePath, AbsolutePath)
fps
[(AnchoredPath, ItemType)]
have_paths <- Tree IO
-> (AbsolutePath, AbsolutePath) -> IO [(AnchoredPath, ItemType)]
listHere Tree IO
have (AbsolutePath, AbsolutePath)
fps
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ((AnchoredPath, ItemType) -> String)
-> [(AnchoredPath, ItemType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath, ItemType) -> String
anchoredToFilePath ([(AnchoredPath, ItemType)] -> [String])
-> [(AnchoredPath, ItemType)] -> [String]
forall a b. (a -> b) -> a -> b
$ [(AnchoredPath, ItemType)] -> [(AnchoredPath, ItemType)]
forall a. Ord a => [a] -> [a]
nubSort [(AnchoredPath, ItemType)]
have_paths [(AnchoredPath, ItemType)]
-> [(AnchoredPath, ItemType)] -> [(AnchoredPath, ItemType)]
forall a. Ord a => [a] -> [a] -> [a]
`minus` [(AnchoredPath, ItemType)] -> [(AnchoredPath, ItemType)]
forall a. Ord a => [a] -> [a]
nubSort [(AnchoredPath, ItemType)]
known_paths
knownFileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [FilePath]
knownFileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
knownFileArgs (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
flags [String]
args = [String] -> IO [String] -> IO [String]
notYetListed [String]
args (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ do
let (UseIndex
ui, ScanKnown
sk, DiffAlgorithm
_) = [DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
Flags.diffingOpts [DarcsFlag]
flags
lfm :: LookForMoves
lfm = [DarcsFlag] -> LookForMoves
Flags.lookForMoves [DarcsFlag]
flags
lfr :: LookForReplaces
lfr = [DarcsFlag] -> LookForReplaces
Flags.lookForReplaces [DarcsFlag]
flags
RepoTrees {Tree IO
known :: Tree IO
known :: forall (m :: * -> *). RepoTrees m -> Tree m
known} <- UseIndex
-> ScanKnown
-> LookForMoves
-> LookForReplaces
-> IO (RepoTrees IO)
repoTrees UseIndex
ui ScanKnown
sk LookForMoves
lfm LookForReplaces
lfr
((AnchoredPath, ItemType) -> String)
-> [(AnchoredPath, ItemType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath, ItemType) -> String
anchoredToFilePath ([(AnchoredPath, ItemType)] -> [String])
-> IO [(AnchoredPath, ItemType)] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree IO
-> (AbsolutePath, AbsolutePath) -> IO [(AnchoredPath, ItemType)]
listHere Tree IO
known (AbsolutePath, AbsolutePath)
fps
modifiedFileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [FilePath]
modifiedFileArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
modifiedFileArgs (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
flags [String]
args = [String] -> IO [String] -> IO [String]
notYetListed [String]
args (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ do
let (UseIndex
ui, ScanKnown
sk, DiffAlgorithm
_) = [DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
Flags.diffingOpts [DarcsFlag]
flags
lfm :: LookForMoves
lfm = [DarcsFlag] -> LookForMoves
Flags.lookForMoves [DarcsFlag]
flags
lfr :: LookForReplaces
lfr = [DarcsFlag] -> LookForReplaces
Flags.lookForReplaces [DarcsFlag]
flags
RepoTrees {[AnchoredPath]
new :: forall (m :: * -> *). RepoTrees m -> [AnchoredPath]
new :: [AnchoredPath]
new} <- UseIndex
-> ScanKnown
-> LookForMoves
-> LookForReplaces
-> IO (RepoTrees IO)
repoTrees UseIndex
ui ScanKnown
sk LookForMoves
lfm LookForReplaces
lfr
case (AbsolutePath -> AbsolutePath -> Maybe SubPath)
-> (AbsolutePath, AbsolutePath) -> Maybe SubPath
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry AbsolutePath -> AbsolutePath -> Maybe SubPath
makeSubPathOf (AbsolutePath, AbsolutePath)
fps of
Maybe SubPath
Nothing -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just SubPath
here ->
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> String -> Maybe String
stripPathPrefix (SubPath -> String
forall a. FilePathOrURL a => a -> String
toPath SubPath
here)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath String
"") [AnchoredPath]
new
prefArgs :: String
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [String]
prefArgs :: String
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [String]
prefArgs String
name (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = String -> IO [String]
getPreflist String
name
noArgs :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String]
noArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
data RepoTrees m = RepoTrees
{ RepoTrees m -> Tree m
have :: Tree m
, RepoTrees m -> Tree m
known :: Tree m
, RepoTrees m -> [AnchoredPath]
new :: [AnchoredPath]
}
repoTrees :: O.UseIndex -> O.ScanKnown -> O.LookForMoves -> O.LookForReplaces
-> IO (RepoTrees IO)
repoTrees :: UseIndex
-> ScanKnown
-> LookForMoves
-> LookForReplaces
-> IO (RepoTrees IO)
repoTrees UseIndex
ui ScanKnown
sk LookForMoves
lfm LookForReplaces
lfr = do
Bool
inDarcsRepo <- String -> IO Bool
doesDirectoryReallyExist String
darcsdir
if Bool
inDarcsRepo then
UseCache -> RepoJob (RepoTrees IO) -> IO (RepoTrees IO)
forall a. UseCache -> RepoJob a -> IO a
withRepository UseCache
NoUseCache (RepoJob (RepoTrees IO) -> IO (RepoTrees IO))
-> RepoJob (RepoTrees IO) -> IO (RepoTrees IO)
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (RepoTrees IO))
-> RepoJob (RepoTrees IO)
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (RepoTrees IO))
-> RepoJob (RepoTrees IO))
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (RepoTrees IO))
-> RepoJob (RepoTrees IO)
forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
r -> do
Tree IO
known <- Repository rt p wR wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wR
r
Tree IO
have <- Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository rt p wR wU wR
r UseIndex
ui ScanKnown
sk LookForMoves
lfm Maybe [AnchoredPath]
forall a. Maybe a
Nothing
[AnchoredPath]
new <- FL (PrimOf p) wR wU -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles (FL (PrimOf p) wR wU -> [AnchoredPath])
-> IO (FL (PrimOf p) wR wU) -> IO [AnchoredPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges (UseIndex
ui, ScanKnown
sk, DiffAlgorithm
O.MyersDiff) LookForMoves
lfm LookForReplaces
lfr Repository rt p wR wU wR
r Maybe [AnchoredPath]
forall a. Maybe a
Nothing
RepoTrees IO -> IO (RepoTrees IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (RepoTrees IO -> IO (RepoTrees IO))
-> RepoTrees IO -> IO (RepoTrees IO)
forall a b. (a -> b) -> a -> b
$ RepoTrees :: forall (m :: * -> *).
Tree m -> Tree m -> [AnchoredPath] -> RepoTrees m
RepoTrees {[AnchoredPath]
Tree IO
new :: [AnchoredPath]
have :: Tree IO
known :: Tree IO
new :: [AnchoredPath]
known :: Tree IO
have :: Tree IO
..}
else
RepoTrees IO -> IO (RepoTrees IO)
forall (m :: * -> *) a. Monad m => a -> m a
return RepoTrees :: forall (m :: * -> *).
Tree m -> Tree m -> [AnchoredPath] -> RepoTrees m
RepoTrees {have :: Tree IO
have = Tree IO
forall (m :: * -> *). Tree m
emptyTree, known :: Tree IO
known = Tree IO
forall (m :: * -> *). Tree m
emptyTree, new :: [AnchoredPath]
new = []}
subtreeHere :: Tree IO -> (AbsolutePath, AbsolutePath) -> IO (Maybe (Tree IO))
subtreeHere :: Tree IO -> (AbsolutePath, AbsolutePath) -> IO (Maybe (Tree IO))
subtreeHere Tree IO
tree (AbsolutePath, AbsolutePath)
fps =
case SubPath -> AnchoredPath
floatSubPath (SubPath -> AnchoredPath) -> Maybe SubPath -> Maybe AnchoredPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath -> AbsolutePath -> Maybe SubPath)
-> (AbsolutePath, AbsolutePath) -> Maybe SubPath
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry AbsolutePath -> AbsolutePath -> Maybe SubPath
makeSubPathOf (AbsolutePath, AbsolutePath)
fps of
Maybe AnchoredPath
Nothing -> do
Maybe (Tree IO) -> IO (Maybe (Tree IO))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree IO)
forall a. Maybe a
Nothing
Just AnchoredPath
here -> do
(Tree IO -> AnchoredPath -> Maybe (Tree IO))
-> AnchoredPath -> Tree IO -> Maybe (Tree IO)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tree IO -> AnchoredPath -> Maybe (Tree IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree AnchoredPath
here (Tree IO -> Maybe (Tree IO))
-> IO (Tree IO) -> IO (Maybe (Tree IO))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree IO -> AnchoredPath -> IO (Tree IO)
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> m (Tree m)
expandPath Tree IO
tree AnchoredPath
here
listHere :: Tree IO
-> (AbsolutePath, AbsolutePath)
-> IO [(AnchoredPath, ItemType)]
listHere :: Tree IO
-> (AbsolutePath, AbsolutePath) -> IO [(AnchoredPath, ItemType)]
listHere Tree IO
tree (AbsolutePath, AbsolutePath)
fps = do
Maybe (Tree IO)
msubtree <- Tree IO -> (AbsolutePath, AbsolutePath) -> IO (Maybe (Tree IO))
subtreeHere Tree IO
tree (AbsolutePath, AbsolutePath)
fps
case Maybe (Tree IO)
msubtree of
Maybe (Tree IO)
Nothing -> [(AnchoredPath, ItemType)] -> IO [(AnchoredPath, ItemType)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Tree IO
subtree -> Tree IO -> [(AnchoredPath, ItemType)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, ItemType)]
listItems (Tree IO -> [(AnchoredPath, ItemType)])
-> IO (Tree IO) -> IO [(AnchoredPath, ItemType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
subtree
listItems :: Tree m -> [(AnchoredPath, ItemType)]
listItems :: Tree m -> [(AnchoredPath, ItemType)]
listItems = ((AnchoredPath, TreeItem m) -> (AnchoredPath, ItemType))
-> [(AnchoredPath, TreeItem m)] -> [(AnchoredPath, ItemType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(AnchoredPath
p, TreeItem m
i) -> (AnchoredPath
p, TreeItem m -> ItemType
forall (m :: * -> *). TreeItem m -> ItemType
itemType TreeItem m
i)) ([(AnchoredPath, TreeItem m)] -> [(AnchoredPath, ItemType)])
-> (Tree m -> [(AnchoredPath, TreeItem m)])
-> Tree m
-> [(AnchoredPath, ItemType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
Tree.list
anchoredToFilePath :: (AnchoredPath, ItemType) -> [Char]
anchoredToFilePath :: (AnchoredPath, ItemType) -> String
anchoredToFilePath (AnchoredPath
path, ItemType
TreeType) = String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
path
anchoredToFilePath (AnchoredPath
path, ItemType
BlobType) = String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
path
stripPathPrefix :: FilePath -> FilePath -> Maybe FilePath
stripPathPrefix :: String -> String -> Maybe String
stripPathPrefix = String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String -> String -> Maybe String)
-> (String -> String) -> String -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addSlash where
addSlash :: String -> String
addSlash [] = []
addSlash String
xs = String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
notYetListed :: [String] -> IO [String] -> IO [String]
notYetListed :: [String] -> IO [String] -> IO [String]
notYetListed [String]
already IO [String]
complete = do
[String]
possible <- IO [String]
complete
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String]
possible [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
already