-- | How to complete arguments
{-# LANGUAGE NamedFieldPuns #-}
module Darcs.UI.Completion
    ( fileArgs
    , knownFileArgs
    , unknownFileArgs
    , modifiedFileArgs
    , noArgs
    , Pref(..) -- re-export
    , 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
    ( Pref(..), getPreflist
    )
import Darcs.Repository.Job
    ( RepoJob(..)
    , withRepository
    )
import Darcs.Repository.State
    ( readPristineAndPending
    , readUnrecordedFiltered
    , unrecordedChanges
    , restrictDarcsdir
    , applyTreeFilter
    , TreeFilter(..)
    )

import Darcs.UI.Flags ( DarcsFlag )
import qualified Darcs.UI.Flags as Flags
import Darcs.UI.Options ( (?) )
import qualified Darcs.UI.Options.All as O

import Darcs.Util.File
    ( doesDirectoryReallyExist
    )
import Darcs.Util.Global
    ( darcsdir
    )
import Darcs.Util.Path
    ( AnchoredPath, realPath
    , AbsolutePath, toPath, floatSubPath, makeSubPathOf
    )
import Darcs.Util.Tree as Tree
    ( Tree, ItemType(..)
    , expand, expandPath, list, findTree, itemType, emptyTree
    )
import Darcs.Util.Tree.Plain ( readPlainTree )

-- | Return all files available under the original working
-- directory regardless of their repo state.
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 a b. (a -> b) -> IO a -> IO b
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)

-- | Return all files available under the original working directory that
-- are unknown to darcs but could be added.
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 lfa :: LookForAdds
lfa = if PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
O.includeBoring PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags then LookForAdds
O.EvenLookForBoring else LookForAdds
O.YesLookForAdds
      dopts :: DiffOpts
dopts = [DarcsFlag] -> DiffOpts
Flags.diffingOpts [DarcsFlag]
flags
  RepoTrees {Tree IO
have :: Tree IO
have :: forall (m :: * -> *). RepoTrees m -> Tree m
have, Tree IO
known :: Tree IO
known :: forall (m :: * -> *). RepoTrees m -> Tree m
known} <- DiffOpts -> IO (RepoTrees IO)
repoTrees DiffOpts
dopts {O.lookForAdds = lfa}
  [(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 a. a -> IO a
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

-- | Return all files available under the original working directory that
-- are known to darcs (either recorded or pending).
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
  RepoTrees {Tree IO
known :: forall (m :: * -> *). RepoTrees m -> Tree m
known :: Tree IO
known} <- DiffOpts -> IO (RepoTrees IO)
repoTrees ([DarcsFlag] -> DiffOpts
Flags.diffingOpts [DarcsFlag]
flags)
  ((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

-- | Return all files available under the original working directory that
-- are modified (relative to the recorded state).
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
  RepoTrees {[AnchoredPath]
new :: [AnchoredPath]
new :: forall (m :: * -> *). RepoTrees m -> [AnchoredPath]
new} <- DiffOpts -> IO (RepoTrees IO)
repoTrees ([DarcsFlag] -> DiffOpts
Flags.diffingOpts [DarcsFlag]
flags)
  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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just SubPath
here ->
      [String] -> IO [String]
forall a. a -> IO a
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 AnchoredPath -> String
realPath [AnchoredPath]
new

-- | Return the available prefs of the given kind.
prefArgs :: Pref
         -> (AbsolutePath, AbsolutePath)
         -> [DarcsFlag]
         -> [String]
         -> IO [String]
prefArgs :: Pref
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [String]
prefArgs Pref
name (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = Pref -> IO [String]
getPreflist Pref
name

-- | Return an empty list.
noArgs :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String]
noArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- * unexported helper functions

data RepoTrees m = RepoTrees
  { forall (m :: * -> *). RepoTrees m -> Tree m
have  :: Tree m       -- ^ working tree
  , forall (m :: * -> *). RepoTrees m -> Tree m
known :: Tree m       -- ^ recorded and pending
  , forall (m :: * -> *). RepoTrees m -> [AnchoredPath]
new :: [AnchoredPath] -- ^ unrecorded paths
  }

repoTrees :: O.DiffOpts -> IO (RepoTrees IO)
repoTrees :: DiffOpts -> IO (RepoTrees IO)
repoTrees dopts :: DiffOpts
dopts@O.DiffOpts {DiffAlgorithm
UseIndex
LookForMoves
LookForReplaces
LookForAdds
lookForAdds :: DiffOpts -> LookForAdds
withIndex :: UseIndex
lookForAdds :: LookForAdds
lookForReplaces :: LookForReplaces
lookForMoves :: LookForMoves
diffAlg :: DiffAlgorithm
withIndex :: DiffOpts -> UseIndex
lookForReplaces :: DiffOpts -> LookForReplaces
lookForMoves :: DiffOpts -> LookForMoves
diffAlg :: DiffOpts -> DiffAlgorithm
..} = do
  Bool
inDarcsRepo <- String -> IO Bool
doesDirectoryReallyExist String
darcsdir
  if Bool
inDarcsRepo then
    UseCache -> RepoJob 'RO (RepoTrees IO) -> IO (RepoTrees IO)
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository UseCache
NoUseCache (RepoJob 'RO (RepoTrees IO) -> IO (RepoTrees IO))
-> RepoJob 'RO (RepoTrees IO) -> IO (RepoTrees IO)
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO (RepoTrees IO) -> RepoJob 'RO (RepoTrees IO)
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO (RepoTrees IO) -> RepoJob 'RO (RepoTrees IO))
-> TreePatchJob 'RO (RepoTrees IO) -> RepoJob 'RO (RepoTrees IO)
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
r -> do
      Tree IO
known <- Repository 'RO p wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending Repository 'RO p wU wR
r
      Tree IO
have <- Repository 'RO p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository 'RO p wU wR
r UseIndex
withIndex LookForAdds
lookForAdds LookForMoves
lookForMoves Maybe [AnchoredPath]
forall a. Maybe a
Nothing
      [AnchoredPath]
new <- FL (PrimOf p) wR wU -> [AnchoredPath]
forall wX wY. FL (PrimOf p) wX wY -> [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
<$> DiffOpts
-> Repository 'RO p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges DiffOpts
dopts Repository 'RO p wU wR
r Maybe [AnchoredPath]
forall a. Maybe a
Nothing
      RepoTrees IO -> IO (RepoTrees IO)
forall a. a -> IO a
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 {[AnchoredPath]
Tree IO
have :: Tree IO
known :: Tree IO
new :: [AnchoredPath]
known :: Tree IO
have :: Tree IO
new :: [AnchoredPath]
..}
  else
    RepoTrees IO -> IO (RepoTrees IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = []}

-- this is for completion which should give us everything under the original wd
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 (String -> AnchoredPath)
-> (AnchoredPath -> AnchoredPath)
-> Either String AnchoredPath
-> AnchoredPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> AnchoredPath
forall a. HasCallStack => String -> a
error AnchoredPath -> AnchoredPath
forall a. a -> a
id (Either String AnchoredPath -> AnchoredPath)
-> (SubPath -> Either String AnchoredPath)
-> SubPath
-> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> Either String 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree IO)
forall a. Maybe a
Nothing -- here is no subtree of the repo
    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 a. a -> IO a
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 :: forall (m :: * -> *). 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
_) = AnchoredPath -> String
realPath 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
"/"

-- | Turn an action that creates all possible completions into one
-- that removes already given arguments.
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 a. a -> IO a
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