-- 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. -- | The purpose of this module is to deal with many of the common -- cases that come up when choosing a subset of a group of patches. -- -- The idea is to divide a sequence of candidate patches into an initial -- section named 'InFirst', a final section named 'InLast', and between them a -- third section of not yet decided patches named 'InMiddle'. The reason for the -- neutral terminology 'InFirst', 'InMiddle', and 'InLast', is that which of 'InFirst' -- and 'InLast' counts as @selected@ or @deselected@ depends on -- what we want to achive, that is, on the command and its options. -- See "Darcs.UI.SelectChanges" for examples of how to use the functions from -- this module. -- -- Obviously if there are dependencies between the patches that will put a -- constraint on how you can choose to divide them up. Unless stated otherwise, -- functions that move patches from one section to another pull all dependent -- patches with them. -- -- Internally, we don't necessarily reorder patches immediately, but merely -- tag them with the desired status, and thus postpone the actual commutation. -- This saves a lot of unnecessary work, especially when choices are made -- interactively, where the user can revise earlier decisions. module Darcs.Patch.Choices ( -- * Choosing patches PatchChoices , Slot(..) -- ** Constructing , patchChoices , mkPatchChoices -- ** Querying , patchSlot , getChoices , separateFirstMiddleFromLast , separateFirstFromMiddleLast -- ** Forcing patches into a given 'Slot' , forceMatchingFirst , forceFirsts , forceFirst , forceMatchingLast , forceLasts , forceLast , forceMiddle , makeEverythingSooner , makeEverythingLater -- ** Operations on 'InMiddle' patches , selectAllMiddles , refineChoices -- ** Substitution , substitute -- * Labelling patches , LabelledPatch , Label , label , unLabel , labelPatches , getLabelInt ) where import Darcs.Prelude import Darcs.Patch.Invert ( Invert, invert ) import Darcs.Patch.Commute ( Commute, commute, commuteRL ) import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles, hunkMatches ) import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) , (:>)(..), (:||:)(..) , zipWithFL, mapFL_FL, concatFL , (+>+), reverseRL, anyFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -- | 'Label' @mp i@ acts as a temporary identifier to help us keep track of patches -- during the selection process. These are useful for finding patches that -- may have moved around during patch selection (being pushed forwards or -- backwards as dependencies arise). -- -- The identifier is implemented as a tuple @Label mp i@. The @i@ is an -- integer, expected to be unique within the patches being -- scrutinised. The @mp@ is motivated by patch splitting; it -- provides a convenient way to generate a new identifier from the patch -- being split. For example, if we split a patch identified as @Label Nothing -- 5@, the resulting sub-patches could be identified as -- @Label (Just (Label Nothing 5))1@, @Label (Just (Label Nothing 5)) 2@, etc. -- -- IOW, 'Label' is a non-empty, reversed list of 'Int's. data Label = Label (Maybe Label) Int deriving Eq -- | A patch with a 'Label' attached to it. data LabelledPatch p wX wY = LP Label (p wX wY) -- | This internal type tags a 'LabelledPatch' with a 'Bool', to distinguish -- 'InMiddle' from 'InLast' patches. data PatchChoice p wX wY = PC { pcPatch :: (LabelledPatch p wX wY) -- ^ the 'LabelledPatch' in question , _pcIsLast :: Bool -- ^ 'False' = 'InMiddle', 'True' = 'InLast' } -- | Internal function to tag a 'LabelledPatch' as 'InMiddle' or 'InLast'. pcSetLast :: Bool -> LabelledPatch p wX wY -> PatchChoice p wX wY pcSetLast = flip PC -- TODO pcsFirsts should be an 'RL', not an 'FL'. -- | A sequence of 'LabelledPatch'es where each patch is either -- 'InFirst', 'InMiddle', or 'InLast'. The representation is -- optimized for the case where we start chosing patches from the left -- of the sequence: patches that are 'InFirst' are commuted to the head -- immediately, but patches that are 'InMiddle' or 'InLast' are mixed -- together; when a patch is marked 'InLast', its dependencies are -- not updated until we retrieve the final result. data PatchChoices p wX wY where PCs :: { pcsFirsts :: FL (LabelledPatch p) wX wM , pcsMiddleLasts :: FL (PatchChoice p) wM wY} -> PatchChoices p wX wY -- | See module documentation for "Darcs.Patch.Choices". data Slot = InFirst | InMiddle | InLast label :: LabelledPatch p wX wY -> Label label (LP tg _) = tg getLabelInt :: Label -> Int getLabelInt (Label _ i) = i unLabel :: LabelledPatch p wX wY -> p wX wY unLabel (LP _ p) = p -- This is dangerous if two patches from different labelled series are compared -- ideally Label (and hence LabelledPatch/PatchChoices) would have a witness type -- to represent the originally labelled sequence. compareLabels :: LabelledPatch p wA wB -> LabelledPatch p wC wD -> EqCheck (wA, wB) (wC, wD) compareLabels (LP l1 _) (LP l2 _) = if l1 == l2 then unsafeCoerceP IsEq else NotEq instance Invert p => Invert (LabelledPatch p) where invert (LP t p) = LP t (invert p) instance Commute p => Commute (LabelledPatch p) where commute (LP l1 p1 :> LP l2 p2) = do p2' :> p1' <- commute (p1 :> p2) return (LP l2 p2' :> LP l1 p1') instance PatchInspect p => PatchInspect (LabelledPatch p) where listTouchedFiles = listTouchedFiles . unLabel hunkMatches f = hunkMatches f . unLabel instance Commute p => Commute (PatchChoice p) where commute (PC p1 c1 :> PC p2 c2) = do p2' :> p1' <- commute (p1 :> p2) return (PC p2' c2 :> PC p1' c1) instance PatchInspect p => PatchInspect (PatchChoice p) where listTouchedFiles = listTouchedFiles . pcPatch hunkMatches f = hunkMatches f . pcPatch -- | Create a 'PatchChoices' from a sequence of patches, so that -- all patches are initially 'InMiddle'. patchChoices :: FL p wX wY -> PatchChoices p wX wY patchChoices = mkPatchChoices . labelPatches Nothing -- | Label a sequence of patches, maybe using the given parent label. labelPatches :: Maybe Label -> FL p wX wY -> FL (LabelledPatch p) wX wY labelPatches tg ps = zipWithFL LP (map (Label tg) [1..]) ps -- | Create a 'PatchChoices' from an already labelled sequence of patches, -- so that all patches are initially 'InMiddle'. mkPatchChoices :: FL (LabelledPatch p) wX wY -> PatchChoices p wX wY mkPatchChoices = PCs NilFL . mapFL_FL (pcSetLast False) -- | Like 'getChoices' but lumps together 'InMiddle' and 'InLast' patches. -- This is more efficient than using 'getChoices' and then catenating 'InMiddle' -- and 'InLast' sections because we have to commute less. -- (This is what 'PatchChoices' are optimized for.) -- -- prop> separateFirstFromMiddleLast c == case getChoices c of f:>m:>l -> f:>m+>+l separateFirstFromMiddleLast :: PatchChoices p wX wZ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ separateFirstFromMiddleLast (PCs f ml) = f :> mapFL_FL pcPatch ml -- | Like 'getChoices' but lumps together 'InFirst' and 'InMiddle' patches. -- -- prop> separateFirstMiddleFromLast c == case getChoices c of f:>m:>l -> f+>+m:>l separateFirstMiddleFromLast :: Commute p => PatchChoices p wX wZ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ separateFirstMiddleFromLast (PCs f l) = case pushLasts l of (m :> l') -> f +>+ m :> l' -- | Retrieve the resulting sections from a 'PatchChoice'. The result is a -- triple @first:>middle:>last@, such that all patches in @first@ are -- 'InFirst', all patches in @middle@ are 'InMiddle', and all patches in @last@ -- are 'InLast'. getChoices :: Commute p => PatchChoices p wX wY -> (FL (LabelledPatch p) :> FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY getChoices (PCs f ml) = case pushLasts ml of (m :> l') -> f :> m :> l' -- | Internal function to commute patches in the common 'pcsMiddleLasts' segment -- so that all 'InLast' patches are behind 'InMiddle' ones. Patches 'InMiddle' -- that depend on any 'InLast' are promoted to 'InLast'. pushLasts :: Commute p => FL (PatchChoice p) wX wY -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY pushLasts NilFL = NilFL :> NilFL pushLasts (PC lp False :>: pcs) = case pushLasts pcs of (m :> l) -> (lp :>: m) :> l pushLasts (PC lp True :>: pcs) = case pushLasts pcs of (m :> l) -> case commuteWhatWeCanFL (lp :> m) of (m' :> lp' :> deps) -> m' :> (lp' :>: deps +>+ l) -- TODO for the way we use this function it is too restrictive IMO: it does not -- allow the user to select anything that doesn't match the pre-filters. -- | Use the given monadic 'PatchChoices' transformer on the 'InMiddle' section -- of a 'PatchChoices', then fold the result back into the original 'PatchChoices'. refineChoices :: (Commute p, Monad m) => (forall wU wV . FL (LabelledPatch p) wU wV -> PatchChoices p wU wV -> m (PatchChoices p wU wV)) -> PatchChoices p wX wY -> m (PatchChoices p wX wY) refineChoices act ps = case getChoices ps of (f :> m :> l) -> do (PCs f' l') <- act m (mkPatchChoices m) return . PCs (f +>+ f') $ l' +>+ mapFL_FL (pcSetLast True) l -- | Given a 'LabelledPatch' determine to which section of the given -- 'PatchChoices' it belongs. This is not trivial to compute, since a patch -- tagged as 'InMiddle' may be forced to actually be 'InLast' by dependencies. We -- return a possibly re-ordered 'PatchChoices' so as not to waste the -- commutation effort. patchSlot :: forall p wA wB wX wY. Commute p => LabelledPatch p wA wB -> PatchChoices p wX wY -> (Slot, PatchChoices p wX wY) patchSlot (LP t _) pc@(PCs f ml) | foundIn f = (InFirst, pc) | otherwise = psLast f NilRL NilRL ml where foundIn = anyFL ((== t) . label) psLast :: forall wM wC wL . FL (LabelledPatch p) wX wM -> RL (LabelledPatch p) wM wC -> RL (LabelledPatch p) wC wL -> FL (PatchChoice p) wL wY -> (Slot, PatchChoices p wX wY) psLast firsts middles bubble (PC lp True :>: ls) | label lp == t = (InLast , PCs { pcsFirsts = firsts , pcsMiddleLasts = settleM middles +>+ settleB bubble +>+ PC lp True :>: ls}) psLast firsts middles bubble (PC lp False :>: ls) | label lp == t = case commuteRL (bubble :> lp) of Just (lp' :> bubble') -> (InMiddle, PCs { pcsFirsts = firsts , pcsMiddleLasts = settleM middles +>+ PC lp' False :>: settleB bubble' +>+ ls}) Nothing -> (InLast, PCs { pcsFirsts = firsts , pcsMiddleLasts = settleM middles +>+ settleB bubble +>+ PC lp True :>: ls}) psLast firsts middles bubble (PC lp True :>: ls) = psLast firsts middles (bubble :<: lp) ls psLast firsts middles bubble (PC lp False :>: ls) = case commuteRL (bubble :> lp) of Just (lp' :> bubble') -> psLast firsts (middles :<: lp') bubble' ls Nothing -> psLast firsts middles (bubble :<: lp) ls psLast _ _ _ NilFL = error "impossible case" settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble -- | Force all patches matching the given predicate to be 'InFirst', -- pulling any dependencies with them. This even forces any patches -- that were already tagged 'InLast'. forceMatchingFirst :: forall p wA wB. Commute p => ( forall wX wY . LabelledPatch p wX wY -> Bool) -> PatchChoices p wA wB -> PatchChoices p wA wB forceMatchingFirst pred (PCs f0 ml) = fmfLasts f0 NilRL ml where fmfLasts :: FL (LabelledPatch p) wA wM -> RL (PatchChoice p) wM wN -> FL (PatchChoice p) wN wB -> PatchChoices p wA wB fmfLasts f l1 (a :>: l2) | pred_pc a = case commuteWhatWeCanRL (l1 :> a) of (deps :> a' :> l1') -> let f' = f +>+ mapFL_FL pcPatch (reverseRL deps) +>+ (pcPatch a' :>: NilFL) in fmfLasts f' l1' l2 fmfLasts f l1 (a :>: l2) = fmfLasts f (l1 :<: a) l2 fmfLasts f l1 NilFL = PCs { pcsFirsts = f , pcsMiddleLasts = reverseRL l1 } pred_pc :: forall wX wY . PatchChoice p wX wY -> Bool pred_pc (PC lp _) = pred lp -- | Force all patches labelled with one of the given labels to be 'InFirst', -- pulling any dependencies with them. This even forces any patches -- that were already tagged 'InLast'. forceFirsts :: Commute p => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB forceFirsts ps = forceMatchingFirst ((`elem` ps) . label) -- | Force a single patch labelled with the given label to be 'InFirst', -- pulling any dependencies with them. This even forces any patches -- that were already tagged 'InLast'. forceFirst :: Commute p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB forceFirst p = forceMatchingFirst ((== p) . label) --TODO: stop after having seen the patch we want to force first -- | Make all 'InMiddle' patches either 'InFirst' or 'InLast'. This does *not* -- modify any patches that are already determined to be 'InLast' by -- dependencies. selectAllMiddles :: forall p wX wY. Commute p => Bool -> PatchChoices p wX wY -> PatchChoices p wX wY selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l) where g (PC lp _) = PC lp True selectAllMiddles False (PCs f l) = samf f NilRL NilRL l where samf :: forall wM1 wM2 wM3 . FL (LabelledPatch p) wX wM1 -> RL (LabelledPatch p) wM1 wM2 -> RL (PatchChoice p) wM2 wM3 -> FL (PatchChoice p) wM3 wY -> PatchChoices p wX wY samf f1 f2 l1 (pc@(PC lp False) :>: l2) = case commuteRL (l1 :> pc) of Nothing -> samf f1 f2 (l1 :<: PC lp True) l2 Just ((PC lp' _) :> l1') -> samf f1 (f2 :<: lp') l1' l2 samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (l1 :<: PC lp True) l2 samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1) -- | Similar to 'forceMatchingFirst' only that patches are forced to be -- 'InLast' regardless of their previous status. forceMatchingLast :: Commute p => (forall wX wY . LabelledPatch p wX wY -> Bool) -> PatchChoices p wA wB -> PatchChoices p wA wB forceMatchingLast pred (PCs f ml) = forceMatchingMiddleOrLast pred True NilRL f ml -- | Internal function working directly on the constituent parts of a -- 'PatchChoices' and taking an accumulating 'RL' to build up a new 'InFirst' -- section. It forces patches to be 'InMiddle' or 'InLast', depending -- on the 'Bool' parameter ('True' means 'InLast', 'False' means 'InMiddle'). -- It does this regardless of the previous status of patches and also pulls -- any dependent patches with it. forceMatchingMiddleOrLast :: forall p wA wB wM1 wM2 . Commute p => (forall wX wY . LabelledPatch p wX wY -> Bool) -> Bool -> RL (LabelledPatch p) wA wM1 -- ^ accumulator for 'InFirst' patches -> FL (LabelledPatch p) wM1 wM2 -- ^ original 'InFirst' section -> FL (PatchChoice p) wM2 wB -- ^ original 'InMiddle' and 'InLast' section -> PatchChoices p wA wB forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml | pred a = case commuteWhatWeCanFL (a :> f2) of (f2' :> a' :> deps) -> let ml' = mapFL_FL (pcSetLast b) (a' :>: deps) +>+ ml in forceMatchingMiddleOrLast pred b f1 f2' ml' forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml = forceMatchingMiddleOrLast pred b (f1 :<: a) f2 ml forceMatchingMiddleOrLast pred b f1 NilFL ml = PCs { pcsFirsts = reverseRL f1 , pcsMiddleLasts = mapFL_FL choose ml } where choose (PC lp c) = (PC lp (if pred lp then b else c) ) -- | Force all patches labelled with one of the given labels to be 'InLast', -- pulling any dependencies with them. This even forces any patches -- that were previously tagged 'InFirst'. forceLasts :: Commute p => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB forceLasts ps = forceMatchingLast ((`elem` ps) . label) -- | Force a single patch labelled with the given label to be 'InLast', -- pulling any dependencies with them, regardless of their previous status. forceLast :: Commute p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB forceLast p = forceMatchingLast ((== p) . label) -- | Force a patch with the given 'Label' to be 'InMiddle', -- pulling any dependencies with it, regardless of their previous status. forceMiddle :: Commute p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB forceMiddle t (PCs f l) = forceMatchingMiddleOrLast ((== t) . label) False NilRL f l -- | Turn 'InFirst' patches into 'InMiddle' ones and 'InMiddle' into 'InLast' ones. makeEverythingLater :: PatchChoices p wX wY -> PatchChoices p wX wY makeEverythingLater (PCs f ml) = let m = mapFL_FL (pcSetLast False) f ml' = mapFL_FL (\(PC lp _) -> PC lp True) ml in PCs NilFL $ m +>+ ml' -- | Turn 'InMiddle' patches into 'InFirst' and 'InLast' patches into 'InMiddle'. -- Does *not* pull dependencies into 'InFirst', instead patches that -- cannot be commuted past 'InLast' patches stay 'InMiddle'. makeEverythingSooner :: forall p wX wY. Commute p => PatchChoices p wX wY -> PatchChoices p wX wY makeEverythingSooner (PCs f ml) = case mes NilRL NilRL ml of (m :> ml') -> PCs (f +>+ m) ml' where mes :: forall wM1 wM2 wM3 . RL (LabelledPatch p) wM1 wM2 -> RL (LabelledPatch p) wM2 wM3 -> FL (PatchChoice p) wM3 wY -> (FL (LabelledPatch p) :> FL (PatchChoice p)) wM1 wY mes middle bubble (PC lp True :>: mls) = mes middle (bubble :<: lp) mls mes middle bubble (PC lp False :>: mls) = case commuteRL (bubble :> lp) of Nothing -> mes middle (bubble :<: lp) mls Just (lp' :> bubble') -> mes (middle :<: lp') bubble' mls mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\lp -> PC lp False) (reverseRL bubble) -- | Substitute a single 'LabelledPatch' with an equivalent list of patches, -- preserving its status as 'InFirst', 'InMiddle' or 'InLast'). -- The patch is looked up using equality of 'Label's. substitute :: forall p wX wY . Sealed2 (LabelledPatch p :||: FL (LabelledPatch p)) -> PatchChoices p wX wY -> PatchChoices p wX wY substitute (Sealed2 (lp :||: new_lps)) (PCs f l) = PCs (concatFL $ mapFL_FL substLp f) (concatFL $ mapFL_FL substPc l) where substLp :: LabelledPatch p wA wB -> FL (LabelledPatch p) wA wB substLp lp' | IsEq <- compareLabels lp lp' = new_lps | otherwise = lp' :>: NilFL substPc :: PatchChoice p wA wB -> FL (PatchChoice p) wA wB substPc (PC lp' c) | IsEq <- compareLabels lp lp' = mapFL_FL (pcSetLast c) new_lps | otherwise = PC lp' c :>: NilFL