module Darcs.Patch.TouchesFiles
( lookTouch
, chooseTouching
, deselectNotTouching
, selectNotTouching
) where
import Darcs.Prelude
import Data.List ( nub )
import Darcs.Patch.Apply
(Apply, ApplyState, applyToPaths)
import Darcs.Patch.Choices
(PatchChoices, Label, LabelledPatch, patchChoices, label,
getChoices, forceFirsts, forceLasts, unLabel)
import Darcs.Patch.Commute (Commute)
import Darcs.Patch.Inspect (PatchInspect)
import Darcs.Patch.Witnesses.Ordered
(FL(..), (:>)(..), mapFL_FL, (+>+))
import Darcs.Patch.Witnesses.Sealed (Sealed, seal)
import Darcs.Util.Path (AnchoredPath, isPrefix)
import Darcs.Util.Tree (Tree)
labelTouching
:: (Apply p, PatchInspect p, ApplyState p ~ Tree)
=> Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching :: forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
_ [AnchoredPath]
_ FL (LabelledPatch p) wX wY
NilFL = []
labelTouching Bool
wantTouching [AnchoredPath]
fs (LabelledPatch p wX wY
lp :>: FL (LabelledPatch p) wY wY
lps) =
case [AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
[AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
lookTouchOnlyEffect [AnchoredPath]
fs (LabelledPatch p wX wY -> p wX wY
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> p wX wY
unLabel LabelledPatch p wX wY
lp) of
(Bool
doesTouch, [AnchoredPath]
fs') ->
let rest :: [Label]
rest = Bool -> [AnchoredPath] -> FL (LabelledPatch p) wY wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
wantTouching [AnchoredPath]
fs' FL (LabelledPatch p) wY wY
lps
in (if Bool
doesTouch Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
wantTouching
then (LabelledPatch p wX wY -> Label
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> Label
label LabelledPatch p wX wY
lp Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:)
else [Label] -> [Label]
forall a. a -> a
id)
[Label]
rest
labelNotTouchingFM
:: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
=> [AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM :: forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
[AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM [AnchoredPath]
paths PatchChoices p wX wY
pc =
case PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY
getChoices PatchChoices p wX wY
pc of
FL (LabelledPatch p) wX wZ
fc :> FL (LabelledPatch p) wZ wZ
mc :> FL (LabelledPatch p) wZ wY
_ -> Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wZ -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
False [AnchoredPath]
paths (FL (LabelledPatch p) wX wZ
fc FL (LabelledPatch p) wX wZ
-> FL (LabelledPatch p) wZ wZ -> FL (LabelledPatch p) wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (LabelledPatch p) wZ wZ
mc)
selectTouching
:: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
=> Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY
selectTouching :: forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
selectTouching Maybe [AnchoredPath]
Nothing PatchChoices p wX wY
pc = PatchChoices p wX wY
pc
selectTouching (Just [AnchoredPath]
paths) PatchChoices p wX wY
pc = [Label] -> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wA wB.
Commute p =>
[Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceFirsts [Label]
xs PatchChoices p wX wY
pc
where
xs :: [Label]
xs =
case PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY
getChoices PatchChoices p wX wY
pc of
FL (LabelledPatch p) wX wZ
_ :> FL (LabelledPatch p) wZ wZ
mc :> FL (LabelledPatch p) wZ wY
lc -> Bool -> [AnchoredPath] -> FL (LabelledPatch p) wZ wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
True [AnchoredPath]
paths (FL (LabelledPatch p) wZ wZ
mc FL (LabelledPatch p) wZ wZ
-> FL (LabelledPatch p) wZ wY -> FL (LabelledPatch p) wZ wY
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (LabelledPatch p) wZ wY
lc)
deselectNotTouching
:: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
=> Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY
deselectNotTouching :: forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
deselectNotTouching Maybe [AnchoredPath]
Nothing PatchChoices p wX wY
pc = PatchChoices p wX wY
pc
deselectNotTouching (Just [AnchoredPath]
paths) PatchChoices p wX wY
pc =
[Label] -> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wA wB.
Commute p =>
[Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceLasts ([AnchoredPath] -> PatchChoices p wX wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
[AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM [AnchoredPath]
paths PatchChoices p wX wY
pc) PatchChoices p wX wY
pc
selectNotTouching
:: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
=> Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY
selectNotTouching :: forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
selectNotTouching Maybe [AnchoredPath]
Nothing PatchChoices p wX wY
pc = PatchChoices p wX wY
pc
selectNotTouching (Just [AnchoredPath]
paths) PatchChoices p wX wY
pc = [Label] -> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wA wB.
Commute p =>
[Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceFirsts ([AnchoredPath] -> PatchChoices p wX wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
[AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM [AnchoredPath]
paths PatchChoices p wX wY
pc) PatchChoices p wX wY
pc
chooseTouching
:: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
=> Maybe [AnchoredPath] -> FL p wX wY -> Sealed (FL p wX)
chooseTouching :: forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [AnchoredPath] -> FL p wX wY -> Sealed (FL p wX)
chooseTouching Maybe [AnchoredPath]
Nothing FL p wX wY
p = FL p wX wY -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL p wX wY
p
chooseTouching Maybe [AnchoredPath]
paths FL p wX wY
p =
case PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY
getChoices (PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY)
-> PatchChoices p wX wY
-> (:>)
(FL (LabelledPatch p))
(FL (LabelledPatch p) :> FL (LabelledPatch p))
wX
wY
forall a b. (a -> b) -> a -> b
$ Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
selectTouching Maybe [AnchoredPath]
paths (PatchChoices p wX wY -> PatchChoices p wX wY)
-> PatchChoices p wX wY -> PatchChoices p wX wY
forall a b. (a -> b) -> a -> b
$ FL p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wX wY. FL p wX wY -> PatchChoices p wX wY
patchChoices FL p wX wY
p of
FL (LabelledPatch p) wX wZ
fc :> FL (LabelledPatch p) wZ wZ
_ :> FL (LabelledPatch p) wZ wY
_ -> FL p wX wZ -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (FL p wX wZ -> Sealed (FL p wX)) -> FL p wX wZ -> Sealed (FL p wX)
forall a b. (a -> b) -> a -> b
$ (forall wW wY. LabelledPatch p wW wY -> p wW wY)
-> FL (LabelledPatch p) wX wZ -> FL p wX wZ
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL LabelledPatch p wW wY -> p wW wY
forall wW wY. LabelledPatch p wW wY -> p wW wY
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> p wX wY
unLabel FL (LabelledPatch p) wX wZ
fc
lookTouchOnlyEffect
:: (Apply p, ApplyState p ~ Tree)
=> [AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
lookTouchOnlyEffect :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
[AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
lookTouchOnlyEffect [AnchoredPath]
fs p wX wY
p = (Bool
wasTouched, [AnchoredPath]
fs')
where
(Bool
wasTouched, [AnchoredPath]
_, [AnchoredPath]
fs', [(AnchoredPath, AnchoredPath)]
_) = Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> p wX wY
-> (Bool, [AnchoredPath], [AnchoredPath],
[(AnchoredPath, AnchoredPath)])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> p wX wY
-> (Bool, [AnchoredPath], [AnchoredPath],
[(AnchoredPath, AnchoredPath)])
lookTouch Maybe [(AnchoredPath, AnchoredPath)]
forall a. Maybe a
Nothing [AnchoredPath]
fs p wX wY
p
lookTouch
:: (Apply p, ApplyState p ~ Tree)
=> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> p wX wY
-> (Bool, [AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
lookTouch :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> p wX wY
-> (Bool, [AnchoredPath], [AnchoredPath],
[(AnchoredPath, AnchoredPath)])
lookTouch Maybe [(AnchoredPath, AnchoredPath)]
renames [AnchoredPath]
fs p wX wY
p = (Bool
anyTouched, [AnchoredPath]
touchedFs, [AnchoredPath]
fs', [(AnchoredPath, AnchoredPath)]
renames')
where
touchedFs :: [AnchoredPath]
touchedFs = [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a]
nub ([AnchoredPath] -> [AnchoredPath])
-> ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath]
-> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredPath -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AnchoredPath -> [AnchoredPath]
fsAffectedBy ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ [AnchoredPath]
affected
fsAffectedBy :: AnchoredPath -> [AnchoredPath]
fsAffectedBy AnchoredPath
af = (AnchoredPath -> Bool) -> [AnchoredPath] -> [AnchoredPath]
forall a. (a -> Bool) -> [a] -> [a]
filter (AnchoredPath -> AnchoredPath -> Bool
affectedBy AnchoredPath
af) [AnchoredPath]
fs
anyTouched :: Bool
anyTouched = [AnchoredPath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnchoredPath]
touchedFs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
affectedBy :: AnchoredPath -> AnchoredPath -> Bool
AnchoredPath
touched affectedBy :: AnchoredPath -> AnchoredPath -> Bool
`affectedBy` AnchoredPath
f =
AnchoredPath
touched AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
f Bool -> Bool -> Bool
|| AnchoredPath
f AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
touched
([AnchoredPath]
affected, [AnchoredPath]
fs', [(AnchoredPath, AnchoredPath)]
renames') = p wX wY
-> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY
-> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
applyToPaths p wX wY
p Maybe [(AnchoredPath, AnchoredPath)]
renames [AnchoredPath]
fs