--  Copyright (C) 2002-2003,2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE OverloadedStrings #-}

module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where

import Prelude ()
import Darcs.Prelude

import System.Exit ( exitSuccess )
import Data.List.Ordered ( nubSort, isect )
import Data.Maybe ( fromJust )
import Control.Monad ( when, unless )
import Control.Exception ( catch, IOException )

import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath, simpleSubPath )
import Darcs.Util.Printer
    ( Doc, putDocLnWith, text, redText, debugDocLn, vsep, (<+>), ($$) )
import Darcs.Util.Printer.Color ( fancyPrinters )
import Darcs.Util.Text ( pathlist )

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putInfo )
import Darcs.UI.Commands.Util ( filterExistingPaths )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
    ( DarcsFlag, diffingOpts, verbosity, dryRun, umask
    , useCache, fixSubPaths )
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O

import Darcs.Repository.Flags ( UpdateWorking (..) )
import Darcs.Repository
    ( withRepoLock
    , RepoJob(..)
    , addToPending
    , applyToWorking
    , readRepo
    , unrecordedChanges )

import Darcs.Patch ( invert, listTouchedFiles, effectOnFilePaths )
import Darcs.Patch.Show
import Darcs.Patch.TouchesFiles ( chooseTouching )
import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
import Darcs.Repository.Resolution ( patchsetConflictResolutions )

-- * The mark-conflicts command

markconflictsDescription :: String
markconflictsDescription :: String
markconflictsDescription =
 "Mark unresolved conflicts in working tree, for manual resolution."

markconflictsHelp :: String
markconflictsHelp :: String
markconflictsHelp = [String] -> String
unlines
 ["Darcs requires human guidance to unify changes to the same part of a"
 ,"source file.  When a conflict first occurs, darcs will add the"
 ,"initial state and both choices to the working tree, delimited by the"
 ,"markers `v v v`, `=====`,  `* * *` and `^ ^ ^`, as follows:"
 ,""
 ,"    v v v v v v v"
 ,"    Initial state."
 ,"    ============="
 ,"    First choice."
 ,"    *************"
 ,"    Second choice."
 ,"    ^ ^ ^ ^ ^ ^ ^"
 ,""
 ,"However, you might revert or manually delete these markers without"
 ,"actually resolving the conflict.  In this case, `darcs mark-conflicts`"
 ,"is useful to show where are the unresolved conflicts.  It is also"
 ,"useful if `darcs apply` or `darcs pull` is called with"
 ,"`--allow-conflicts`, where conflicts aren't marked initially."
 ,""
 ,"Unless you use the `--dry-run` flag, any unrecorded changes to the"
 ,"affected files WILL be lost forever when you run this command!"
 ,"You will be prompted for confirmation before this takes place."
 ]

markconflicts :: DarcsCommand [DarcsFlag]
markconflicts :: DarcsCommand [DarcsFlag]
markconflicts = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "mark-conflicts"
    , commandHelp :: String
commandHelp = String
markconflictsHelp
    , commandDescription :: String
commandDescription = String
markconflictsDescription
    , commandExtraArgs :: Int
commandExtraArgs = -1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
knownFileArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
markconflictsAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (UseIndex
   -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (UseIndex
   -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (UseIndex
   -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
markconflictsOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
markconflictsOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
markconflictsOpts
    }
  where
    markconflictsBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (UseIndex
   -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
  UseIndex
PrimDarcsOption UseIndex
O.useIndex
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
  UseIndex
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> DryRun -> XmlOutput -> a)
     (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> DryRun -> XmlOutput -> a)
     (UseIndex
      -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> DryRun -> XmlOutput -> a)
  (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
PrimDarcsOption (Maybe String)
O.repoDir
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> DryRun -> XmlOutput -> a)
  (UseIndex
   -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DryRun -> XmlOutput -> a)
     (DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DryRun -> XmlOutput -> a)
     (UseIndex
      -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (DryRun -> XmlOutput -> a)
  (DiffAlgorithm -> DryRun -> XmlOutput -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DryRun -> XmlOutput -> a)
  (UseIndex
   -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DryRun -> XmlOutput -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (UseIndex
      -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (DryRun -> XmlOutput -> a)
forall a. DarcsOption a (DryRun -> XmlOutput -> a)
O.dryRunXml
    markconflictsAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
markconflictsAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
    markconflictsOpts :: DarcsOption
  a
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
markconflictsOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (UseIndex
   -> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (UseIndex
   -> Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (UseIndex
      -> Maybe String
      -> DiffAlgorithm
      -> DryRun
      -> XmlOutput
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> UMask
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (UMask -> UseCache -> HooksConfig -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
markconflictsAdvancedOpts

markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts args :: [String]
args = do
  Only [SubPath]
paths <- if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args then Only [SubPath] -> IO (Only [SubPath])
forall (m :: * -> *) a. Monad m => a -> m a
return Only [SubPath]
forall a. Only a
Everything else [SubPath] -> Only [SubPath]
sps2ps ([SubPath] -> Only [SubPath])
-> IO [SubPath] -> IO (Only [SubPath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
args -- Applicative IO
  Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
paths
  DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
umask (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask)
-> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> 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 ())
-> RepoJob ()
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 ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do

{-
    What we do here:
    * read the unrecorded changes (all of them)
    * extract functions representing path rename effects from unrecorded
    * convert argument paths to pre-pending
    * read conflict resolutions that touch pre-pending argument paths
    * affected paths = intersection of paths touched by resolutions
                       and pre-pending argument paths
    * for these paths, revert pending changes
    * apply the (filtered, see above) conflict resolutions

    Technical side-note:
    Ghc can't handle pattern bindings for existentials. So 'let' is out,
    one has to use 'case expr of var ->' or 'do var <- return expr'.
    Case is clearer but do-notation does not increase indentation depth.
    So we use case for small-scope bindings and <-/return when the scope
    is a long do block.
-}

    let (useidx :: UseIndex
useidx, scan :: ScanKnown
scan, _) = [DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts
        verb :: Verbosity
verb = PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
    Only ([SubPath], [SubPath])
classified_paths <-
      ([SubPath] -> IO ([SubPath], [SubPath]))
-> Only [SubPath] -> IO (Only ([SubPath], [SubPath]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Repository rt p wR wU wR
-> Verbosity
-> UseIndex
-> ScanKnown
-> LookForMoves
-> [SubPath]
-> IO ([SubPath], [SubPath])
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Verbosity
-> UseIndex
-> ScanKnown
-> LookForMoves
-> [SubPath]
-> IO ([SubPath], [SubPath])
filterExistingPaths Repository rt p wR wU wR
repository Verbosity
verb UseIndex
useidx ScanKnown
scan LookForMoves
O.NoLookForMoves) Only [SubPath]
paths

    FL (PrimOf p) wR wU
unrecorded <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT wU)
unrecordedChanges ([DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts)
      LookForMoves
O.NoLookForMoves LookForReplaces
O.NoLookForReplaces
      Repository rt p wR wU wR
repository (Only [SubPath] -> Maybe [SubPath]
forall a. Only a -> Maybe a
fromOnly Only [SubPath]
forall a. Only a
Everything)

    let forward_renames :: Only [SubPath] -> Only [SubPath]
forward_renames = ([String] -> [String]) -> Only [SubPath] -> Only [SubPath]
liftToPathSet (FL (PrimOf p) wR wU -> [String] -> [String]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [String] -> [String]
effectOnFilePaths FL (PrimOf p) wR wU
unrecorded)
        backward_renames :: Only [SubPath] -> Only [SubPath]
backward_renames = ([String] -> [String]) -> Only [SubPath] -> Only [SubPath]
liftToPathSet (FL (PrimOf p) wU wR -> [String] -> [String]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [String] -> [String]
effectOnFilePaths (FL (PrimOf p) wR wU -> FL (PrimOf p) wU wR
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wR wU
unrecorded))
        existing_paths :: Only [SubPath]
existing_paths = (([SubPath], [SubPath]) -> [SubPath])
-> Only ([SubPath], [SubPath]) -> Only [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([SubPath], [SubPath]) -> [SubPath]
forall a b. (a, b) -> b
snd Only ([SubPath], [SubPath])
classified_paths
        pre_pending_paths :: Only [SubPath]
pre_pending_paths = Only [SubPath] -> Only [SubPath]
backward_renames Only [SubPath]
existing_paths
    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: pre_pending_paths =" Doc -> Doc -> Doc
<+> (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
pre_pending_paths

    PatchSet rt p Origin wR
r <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
    Sealed res :: FL (PrimOf p) wR wX
res <- case PatchSet rt p Origin wR -> Sealed (FL (PrimOf p) wR)
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
PatchSet rt p Origin wX -> Sealed (FL (PrimOf p) wX)
patchsetConflictResolutions PatchSet rt p Origin wR
r of
      Sealed raw_res :: FL (PrimOf p) wR wX
raw_res -> do
        let raw_res_paths :: Only [SubPath]
raw_res_paths = [String] -> Only [SubPath]
fps2ps (FL (PrimOf p) wR wX -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL (PrimOf p) wR wX
raw_res)
        Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: raw_res_paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
raw_res_paths
        Sealed (FL (PrimOf p) wR) -> IO (Sealed (FL (PrimOf p) wR))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wR) -> IO (Sealed (FL (PrimOf p) wR)))
-> Sealed (FL (PrimOf p) wR) -> IO (Sealed (FL (PrimOf p) wR))
forall a b. (a -> b) -> a -> b
$ Maybe [String] -> FL (PrimOf p) wR wX -> Sealed (FL (PrimOf p) wR)
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [String] -> FL p wX wY -> Sealed (FL p wX)
chooseTouching (Only [SubPath] -> Maybe [String]
ps2fps Only [SubPath]
pre_pending_paths) FL (PrimOf p) wR wX
raw_res
    let res_paths :: Only [SubPath]
res_paths = [String] -> Only [SubPath]
fps2ps (FL (PrimOf p) wR wX -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL (PrimOf p) wR wX
res)
    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: res_paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
res_paths

    let affected_paths :: Only [SubPath]
affected_paths = Only [SubPath] -> Only [SubPath] -> Only [SubPath]
isectPathSet Only [SubPath]
res_paths Only [SubPath]
pre_pending_paths
    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: affected_paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
affected_paths

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Only [SubPath]
affected_paths Only [SubPath] -> Only [SubPath] -> Bool
forall a. Eq a => a -> a -> Bool
== [SubPath] -> Only [SubPath]
forall a. a -> Only a
Only []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "No conflicts to mark."
      IO ()
forall a. IO a
exitSuccess

    FL (PrimOf p) wR wU
to_revert <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT wU)
unrecordedChanges ([DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts)
      LookForMoves
O.NoLookForMoves LookForReplaces
O.NoLookForReplaces
      Repository rt p wR wU wR
repository (Only [SubPath] -> Maybe [SubPath]
forall a. Only a -> Maybe a
fromOnly Only [SubPath]
affected_paths)

    let post_pending_affected_paths :: Only [SubPath]
post_pending_affected_paths = Only [SubPath] -> Only [SubPath]
forward_renames Only [SubPath]
affected_paths
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "Marking conflicts in:" Doc -> Doc -> Doc
<+> Only [SubPath] -> Doc
showPathSet Only [SubPath]
post_pending_affected_paths Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> "."

    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: to_revert =" Doc -> Doc -> Doc
$$ [Doc] -> Doc
vsep ((forall wW wZ. PrimOf p wW wZ -> Doc)
-> FL (PrimOf p) wR wU -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. PrimOf p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wR wU
to_revert)
    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: res = " Doc -> Doc -> Doc
$$ [Doc] -> Doc
vsep ((forall wW wZ. PrimOf p wW wZ -> Doc)
-> FL (PrimOf p) wR wX -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. PrimOf p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wR wX
res)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "Conflicts will not be marked: this is a dry run."
        IO ()
forall a. IO a
exitSuccess

    Repository rt p wR wR wR
repository' <- case FL (PrimOf p) wR wU
to_revert of
      NilFL -> Repository rt p wR wU wR -> IO (Repository rt p wR wU wR)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository rt p wR wU wR
repository
      _ -> do
        -- TODO:
        -- (1) create backups for all files where we revert changes
        -- (2) try to add the reverted stuff to the unrevert bundle
        -- after (1) and (2) is done we can soften the warning below
        Printers -> Doc -> IO ()
putDocLnWith Printers
fancyPrinters (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
          "Warning: This will revert all unrecorded changes in:"
          Doc -> Doc -> Doc
<+> Only [SubPath] -> Doc
showPathSet Only [SubPath]
post_pending_affected_paths Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> "."
          Doc -> Doc -> Doc
$$ String -> Doc
redText "These changes will be LOST."
        Bool
confirmed <- String -> IO Bool
promptYorn "Are you sure? "
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
confirmed IO ()
forall a. IO a
exitSuccess

{-      -- copied from Revert.hs, see comment (2) above
        debugMessage "About to write the unrevert file."
        case commute (norevert:>p) of
          Just (p':>_) -> writeUnrevert repository p' recorded NilFL
          Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL
        debugMessage "About to apply to the working directory."
-}

        let to_add :: FL (PrimOf p) wU wR
to_add = FL (PrimOf p) wR wU -> FL (PrimOf p) wU wR
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wR wU
to_revert
        Repository rt p wR wU wR
-> UpdateWorking -> FL (PrimOf p) wU wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository UpdateWorking
YesUpdateWorking FL (PrimOf p) wU wR
to_add
        Repository rt p wR wU wR
-> Verbosity
-> FL (PrimOf p) wU wR
-> IO (Repository rt p wR wR wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wU wR
repository (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wR
to_add IO (Repository rt p wR wR wR)
-> (IOException -> IO (Repository rt p wR wR wR))
-> IO (Repository rt p wR wR wR)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
           String -> IO (Repository rt p wR wR wR)
forall a. String -> a
bug ("Can't undo pending changes!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e)
    IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      do Repository rt p wR wR wR
-> UpdateWorking -> FL (PrimOf p) wR wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wR wR
repository' UpdateWorking
YesUpdateWorking FL (PrimOf p) wR wX
res
         Repository rt p wR wX wR
_ <- Repository rt p wR wR wR
-> Verbosity
-> FL (PrimOf p) wR wX
-> IO (Repository rt p wR wX wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wR wR
repository' (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wR wX
res IO (Repository rt p wR wX wR)
-> (IOException -> IO (Repository rt p wR wX wR))
-> IO (Repository rt p wR wX wR)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
             String -> IO (Repository rt p wR wX wR)
forall a. String -> a
bug ("Problem marking conflicts in mark-conflicts!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e)
         () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Finished marking conflicts."

-- * Generic 'PathSet' support

{- $SupportCode

What follows is generic support code for working with argument path lists
that are used to restrict operations to a subset of the working or pristine
tree. The rest of Darcs uses two types for this:

 * @'Maybe' ['SubPath']@

 * @'Maybe' ['FilePath']@

The problem with both is the contra-intuitive name 'Nothing', which here
stands for 'Everything'. To make the intended use clearer, we use the 'Only'
type instead (which is is isomorphic to 'Maybe') and the synonym 'PathSet'
defined below.

These abstractions should get their own module (or become integrated into
Darcs.Util.Path) if and when someone decides to reuse it elsewhere. The
functionality provided is intentionally minimal and light-weight.
-}

-- | 'Only' is isomorphic to 'Maybe' but with the opposite semantics.
--
-- About the name: I like the data constructor names, they are pretty
-- suggestive. The data type name is up for grabs; a possible alternative
-- is @AtMost@.
data Only a = Everything | Only a deriving (Only a -> Only a -> Bool
(Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool) -> Eq (Only a)
forall a. Eq a => Only a -> Only a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Only a -> Only a -> Bool
$c/= :: forall a. Eq a => Only a -> Only a -> Bool
== :: Only a -> Only a -> Bool
$c== :: forall a. Eq a => Only a -> Only a -> Bool
Eq, Eq (Only a)
Eq (Only a) =>
(Only a -> Only a -> Ordering)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Only a)
-> (Only a -> Only a -> Only a)
-> Ord (Only a)
Only a -> Only a -> Bool
Only a -> Only a -> Ordering
Only a -> Only a -> Only a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Only a)
forall a. Ord a => Only a -> Only a -> Bool
forall a. Ord a => Only a -> Only a -> Ordering
forall a. Ord a => Only a -> Only a -> Only a
min :: Only a -> Only a -> Only a
$cmin :: forall a. Ord a => Only a -> Only a -> Only a
max :: Only a -> Only a -> Only a
$cmax :: forall a. Ord a => Only a -> Only a -> Only a
>= :: Only a -> Only a -> Bool
$c>= :: forall a. Ord a => Only a -> Only a -> Bool
> :: Only a -> Only a -> Bool
$c> :: forall a. Ord a => Only a -> Only a -> Bool
<= :: Only a -> Only a -> Bool
$c<= :: forall a. Ord a => Only a -> Only a -> Bool
< :: Only a -> Only a -> Bool
$c< :: forall a. Ord a => Only a -> Only a -> Bool
compare :: Only a -> Only a -> Ordering
$ccompare :: forall a. Ord a => Only a -> Only a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Only a)
Ord, Int -> Only a -> String -> String
[Only a] -> String -> String
Only a -> String
(Int -> Only a -> String -> String)
-> (Only a -> String)
-> ([Only a] -> String -> String)
-> Show (Only a)
forall a. Show a => Int -> Only a -> String -> String
forall a. Show a => [Only a] -> String -> String
forall a. Show a => Only a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Only a] -> String -> String
$cshowList :: forall a. Show a => [Only a] -> String -> String
show :: Only a -> String
$cshow :: forall a. Show a => Only a -> String
showsPrec :: Int -> Only a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Only a -> String -> String
Show)

instance Functor Only where
  fmap :: (a -> b) -> Only a -> Only b
fmap _ Everything = Only b
forall a. Only a
Everything
  fmap f :: a -> b
f (Only x :: a
x) = b -> Only b
forall a. a -> Only a
Only (a -> b
f a
x)

instance Foldable Only where
  foldMap :: (a -> m) -> Only a -> m
foldMap _ Everything = m
forall a. Monoid a => a
mempty
  foldMap f :: a -> m
f (Only x :: a
x) = a -> m
f a
x

instance Traversable Only where
  traverse :: (a -> f b) -> Only a -> f (Only b)
traverse _ Everything = Only b -> f (Only b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Only b
forall a. Only a
Everything
  traverse f :: a -> f b
f (Only x :: a
x) = b -> Only b
forall a. a -> Only a
Only (b -> Only b) -> f b -> f (Only b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x

-- | This is mostly for conversion to legacy APIs
fromOnly :: Only a -> Maybe a
fromOnly :: Only a -> Maybe a
fromOnly Everything = Maybe a
forall a. Maybe a
Nothing
fromOnly (Only x :: a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

{- | A set of repository paths. 'Everything' means every path in the repo, it
usually originates from an empty list of path arguments. The list of
'SubPath's is always kept in sorted order with no duplicates and normalised
(as in 'FilePath.normalise'). This has the nice effect of getting rid of the
idiotic "./" that Darcs insists on prepending to repo paths (which can make
things like comparing paths returned from different parts of the code base a
nightmare).

It uses 'SubPath' for easier compatibility and lists because the number of
elements is expected to be small.
-}
type PathSet = Only [SubPath]

-- | Intersection of two 'PathSet's
isectPathSet :: PathSet -> PathSet -> PathSet
isectPathSet :: Only [SubPath] -> Only [SubPath] -> Only [SubPath]
isectPathSet Everything ys :: Only [SubPath]
ys = Only [SubPath]
ys
isectPathSet xs :: Only [SubPath]
xs Everything = Only [SubPath]
xs
isectPathSet (Only xs :: [SubPath]
xs) (Only ys :: [SubPath]
ys) = [SubPath] -> Only [SubPath]
forall a. a -> Only a
Only ([SubPath] -> [SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a] -> [a]
isect [SubPath]
xs [SubPath]
ys)

{-
-- | Union of two 'PathSet's
union :: PathSet -> PathSet -> PathSet
union Everything ys = Everything
union xs Everything = Everything
union (Only xs) (Only ys) = Only (union xs ys)
-}

-- | Convert a list of 'SubPath's to a 'PathSet'.
sps2ps :: [SubPath] -> PathSet
sps2ps :: [SubPath] -> Only [SubPath]
sps2ps = [SubPath] -> Only [SubPath]
forall a. a -> Only a
Only ([SubPath] -> Only [SubPath])
-> ([SubPath] -> [SubPath]) -> [SubPath] -> Only [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a]
nubSort

-- | Convert a list of repo paths to a 'PathSet'.
-- Partial function! Use only with repo paths.
fps2ps :: [FilePath] -> PathSet
fps2ps :: [String] -> Only [SubPath]
fps2ps = [SubPath] -> Only [SubPath]
sps2ps ([SubPath] -> Only [SubPath])
-> ([String] -> [SubPath]) -> [String] -> Only [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SubPath) -> [String] -> [SubPath]
forall a b. (a -> b) -> [a] -> [b]
map String -> SubPath
fp2sp

-- | Convert a 'PathSet' to something that e.g. 'chooseTouching'
-- takes as parameter.
ps2fps :: PathSet -> Maybe [FilePath]
ps2fps :: Only [SubPath] -> Maybe [String]
ps2fps = ([SubPath] -> [String]) -> Maybe [SubPath] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
sp2fp) (Maybe [SubPath] -> Maybe [String])
-> (Only [SubPath] -> Maybe [SubPath])
-> Only [SubPath]
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> Maybe [SubPath]
forall a. Only a -> Maybe a
fromOnly

-- | Convert a 'PathSet' to a 'Doc'. Uses the English module
-- to generate a nicely readable list of file names.
showPathSet :: Only [SubPath] -> Doc
showPathSet :: Only [SubPath] -> Doc
showPathSet Everything = String -> Doc
text "all paths"
showPathSet (Only xs :: [SubPath]
xs) = [String] -> Doc
pathlist ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
sp2fp [SubPath]
xs)

-- | Lift a function transforming a list of 'FilePath' to one that
-- transforms a 'PathSet'.
liftToPathSet :: ([FilePath] -> [FilePath]) -> PathSet -> PathSet
liftToPathSet :: ([String] -> [String]) -> Only [SubPath] -> Only [SubPath]
liftToPathSet f :: [String] -> [String]
f = ([SubPath] -> [SubPath]) -> Only [SubPath] -> Only [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a]
nubSort ([SubPath] -> [SubPath])
-> ([SubPath] -> [SubPath]) -> [SubPath] -> [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SubPath) -> [String] -> [SubPath]
forall a b. (a -> b) -> [a] -> [b]
map String -> SubPath
fp2sp ([String] -> [SubPath])
-> ([SubPath] -> [String]) -> [SubPath] -> [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
f ([String] -> [String])
-> ([SubPath] -> [String]) -> [SubPath] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
sp2fp)

-- | Convert a 'FilePath' to a 'SubPath'.
--
-- Note: Should call this only with paths we get from the repository.
-- This guarantees that they are relative (to the repo dir).
fp2sp :: FilePath -> SubPath
fp2sp :: String -> SubPath
fp2sp = Maybe SubPath -> SubPath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SubPath -> SubPath)
-> (String -> Maybe SubPath) -> String -> SubPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe SubPath
simpleSubPath

-- | Convert a 'SubPath' to a 'FilePath'. Same as 'toFilePath' and
-- only here for symmetry.
sp2fp :: SubPath -> FilePath
sp2fp :: SubPath -> String
sp2fp = SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath