-- Copyright (C) 2002-2004 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. 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 :: 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 :: [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 :: 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 :: 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 :: 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 :: 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 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 :: [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 :: 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 (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