Florent Becker <[email protected]> added the comment: get rid of ComP ---------------
Ganesh Sittampalam <[email protected]>**20101017104056 ======================================================================= New general stuff about patches, FLs and witnesses needed by the rest hunk ./src/Darcs/Witnesses/Ordered.hs 34 > nullFL, concatFL, concatRL, > consRLSealed, nullRL, toFL, > (:>>)(..), dropWhileFL, dropWhileRL, > - spanFL_M > + spanFL_M, > + eqFL, eqFLRev, eqFLUnsafe > ) where > > #include "impossible.h" Three new functions: eqFL forgets the last witnesses, eqFLRev the firsts, and eqFLUnsafe all. hunk ./src/Darcs/Witnesses/Ordered.hs 285 > +-- |Check that two 'FL's are equal element by element. > +-- This differs from the 'MyEq' instance for 'FL' which > +-- uses commutation. > +eqFL :: MyEq a => FL a C(x y) -> FL a C(x z) -> EqCheck C(y z) > +eqFL NilFL NilFL = IsEq > +eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq > +eqFL _ _ = NotEq > + > +eqFLRev :: MyEq a => FL a C(x z) -> FL a C(y z) -> EqCheck C(x y) > +eqFLRev NilFL NilFL = IsEq > +eqFLRev (x:>:xs) (y:>:ys) | IsEq <- eqFLRev xs ys, IsEq <- x =/\= y = IsEq > +eqFLRev _ _ = NotEq > + > +eqFLUnsafe :: MyEq a => FL a C(x y) -> FL a C(z w) -> Bool > +eqFLUnsafe NilFL NilFL = True > +eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys > +eqFLUnsafe _ _ = False hunk ./src/Darcs/Witnesses/Ordered.hs 95 > showString " :>: " . showsPrec (prec + 1) xs > where prec = 5 > > +instance Show2 a => Show1 (FL a C(x)) where > + showDict1 = ShowDictClass > + > instance Show2 a => Show2 (FL a) where > showDict2 = ShowDictClass > ok hunk ./src/Darcs/Patch/Permutations.hs 32 > headPermutationsFL, > removeSubsequenceFL, removeSubsequenceRL, > partitionConflictingFL, > - CommuteFn, selfCommuter, commuterIdRL, > + CommuteFn, selfCommuter, > + commuterIdFL, commuterFLId, > + commuterIdRL > ) where > > import Data.Maybe ( catMaybes ) hunk ./src/Darcs/Patch/Permutations.hs 269 > y' :> x'' <- commuter (x' :> y) > return ((y' :<: ys') :> x'') > > +commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2) > +commuterIdFL _ (x :> NilFL) = return (NilFL :> x) > +commuterIdFL commuter (x :> (y :>: ys)) > + = do y' :> x' <- commuter (x :> y) > + ys' :> x'' <- commuterIdFL commuter (x' :> ys) > + return ((y' :>: ys') :> x'') commutes a patch past a FL of patches, given a commute function > + > +commuterFLId :: CommuteFn p1 p2 -> CommuteFn (FL p1) p2 > +commuterFLId _ (NilFL :> y) = return (y :> NilFL) > +commuterFLId commuter ((x :>: xs) :> y) > + = do y' :> xs' <- commuterFLId commuter (xs :> y) > + y'' :> x' <- commuter (x :> y') > + return (y'' :> (x' :>: xs')) > + > -- |Partition a list into the patches that commute with the given patch and those that don't (including dependencies) > partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 C(x y) -> p2 C(x z) -> (FL p1 :> FL p1) C(x y) > partitionConflictingFL _ NilFL _ = (NilFL :> NilFL) commutes a FL of patches past a patch, given a commute function ======================================================================== Core modifications of the representation of V1 patches. hunk ./src/Darcs/Patch/Prim.lhs 1026 > instance ToFromPrim Prim where > toPrim = Just . id > > +instance FromPrim p => FromPrim (FL p) where > + fromPrim p = fromPrim p :>: NilFL > instance FromPrim p => FromPrims (FL p) where > fromPrims = mapFL_FL fromPrim > joinPatches = concatFL ok hunk ./src/Darcs/Patch/V1.hs 5 [imports] hunk ./src/Darcs/Patch/V1.hs 16 > > instance Patchy Patch > instance RepoPatchBase Patch > -instance RepoPatch Patch 'Patch'es are never seen in RepoPatches, only 'FL Patch'es. hunk ./src/Darcs/Patch/V1/Core.lhs 4 [exports] hunk ./src/Darcs/Patch/V1/Core.lhs 10 [imports] hunk ./src/Darcs/Patch/V1/Core.lhs 17 > > data Patch C(x y) where > PP :: Prim C(x y) -> Patch C(x y) > - ComP :: FL Patch C(x y) -> Patch C(x y) > - Merger :: Patch C(x y) > + Merger :: FL Patch C(x y) > -> RL Patch C(x b) > -> Patch C(c b) > -> Patch C(c d) > -> Patch C(x y) > - Regrem :: Patch C(x y) > + Regrem :: FL Patch C(x y) > -> RL Patch C(x b) > -> Patch C(c b) > -> Patch C(c a) Removal of ComP hunk ./src/Darcs/Patch/V1/Core.lhs 31 > instance FromPrim Patch where > fromPrim = PP > > -isNullPatch :: Patch C(x y) -> Bool > -nullP :: Patch C(x y) -> EqCheck C(x y) > ok hunk ./src/Darcs/Patch/V1/Core.lhs 36 > isMerger _ = False > > -mergerUndo :: Patch C(x y) -> Patch C(x y) > +mergerUndo :: Patch C(x y) -> FL Patch C(x y) > mergerUndo (Merger undo _ _ _) = undo > mergerUndo _ = impossible > ok hunk ./src/Darcs/Patch/V1/Core.lhs 40 > -\end{code} > - > -%Another nice thing to be able to do with composite patches is to `flatten' > -%them, that is, turn them into a simple list of patches (appropriately > -%ordered, of course), with all nested compositeness unnested. > - > -\begin{code} > +-- TODO this is a relic from the days in which Patch had a ComP constructor > +-- for nesting lists. It is likely completely useless now but is still used > +-- in a couple of places which need to be checked before removig it. > {- INLINE flattenFL -} > flattenFL :: Patch C(x y) -> FL Patch C(x y) noted hunk ./src/Darcs/Patch/V1/Core.lhs 45 > -flattenFL (ComP ps) = concatFL (mapFL_FL flattenFL ps) > flattenFL (PP Identity) = NilFL > flattenFL p = p :>: NilFL > ok hunk ./src/Darcs/Patch/V1/Core.lhs 48 > -joinPatchesFL :: FL Patch C(x y) -> Patch C(x y) > -joinPatchesFL ps = ComP $! ps > - ok hunk ./src/Darcs/Patch/V1/Apply.hs 12 [imports] hunk ./src/Darcs/Patch/V1/Apply.hs 19 > instance Apply Patch where > apply p = applyFL $ effect p > applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x > - applyAndTryToFixFL (ComP xs) = mapMaybeSnd (\xs' -> ComP xs' :>: NilFL) `fmap` applyAndTryToFix xs > applyAndTryToFixFL x = do apply x; return Nothing hunk ./src/Darcs/Patch/V1/Apply.hs 20 > - applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs > - applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x > - > + applyAndTryToFix (PP x) = do mapMaybeSnd PP `fmap` applyAndTryToFix x > + applyAndTryToFix x = do apply x; return Nothing ok hunk ./src/Darcs/Patch/V1/Commute.lhs 26 > #include "gadts.h" > > module Darcs.Patch.V1.Commute [exports] hunk ./src/Darcs/Patch/V1/Commute.lhs 45 hunk ./src/Darcs/Patch/V1/Commute.lhs 50 hunk ./src/Darcs/Patch/V1/Commute.lhs 62 [imports] hunk ./src/Darcs/Patch/V1/Commute.lhs 173 > p2_modifies = isFilepatchMerger p2 > > everythingElseCommute :: MaybeCommute -> CommuteFunction > -everythingElseCommute c x = eec x > +everythingElseCommute _ x = eec x > where > eec :: CommuteFunction > eec (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px) hunk ./src/Darcs/Patch/V1/Commute.lhs 178 > return (PP y' :< PP x') > - eec (ComP NilFL :< p1) = Succeeded (unsafeCoerceP p1 :< (ComP NilFL)) > - eec (p2 :< ComP NilFL) = Succeeded (ComP NilFL :< unsafeCoerceP p2) > - eec (ComP (p:>:ps) :< p1) = toPerhaps $ do > - (p1' :< p') <- c (p :< p1) > - (p1'' :< ComP ps') <- c (ComP ps :< p1') > - return (p1'' :< ComP (p':>:ps')) > - eec (patch2 :< ComP patches) = > - toPerhaps $ do (patches' :< patch2') <- ccr (patch2 :< reverseFL patches) > - return (ComP (reverseRL patches') :< patch2') > - where ccr :: FORALL(x y) (Patch :< RL Patch) C(x y) -> Maybe ((RL Patch :< Patch) C(x y)) > - ccr (p2 :< NilRL) = seq p2 $ return (NilRL :< p2) > - ccr (p2 :< p:<:ps) = do (p' :< p2') <- c (p2 :< p) > - (ps' :< p2'') <- ccr (p2' :< ps) > - return (p':<:ps' :< p2'') > eec _xx = > msum [ > cleverCommute commuteRecursiveMerger _xx removal of all ComP cases hunk ./src/Darcs/Patch/V1/Commute.lhs 234 > > instance PatchInspect Patch where > -- Recurse on everything, these are potentially spoofed patches > - listTouchedFiles (ComP ps) = nubsort $ concat $ mapFL listTouchedFiles ps > listTouchedFiles (Merger _ _ p1 p2) = nubsort $ listTouchedFiles p1 > ++ listTouchedFiles p2 > listTouchedFiles c@(Regrem _ _ _ _) = listTouchedFiles $ invert c ok hunk ./src/Darcs/Patch/V1/Commute.lhs 239 > listTouchedFiles (PP p) = listTouchedFiles p > > - hunkMatches f (ComP ps) = or $ mapFL (hunkMatches f) ps > hunkMatches f (Merger _ _ p1 p2) = hunkMatches f p1 || hunkMatches f p2 > hunkMatches f c@(Regrem _ _ _ _) = hunkMatches f $ invert c > hunkMatches f (PP p) = hunkMatches f p ok hunk ./src/Darcs/Patch/V1/Commute.lhs 256 > if f1 == f2 then return f1 else Nothing > isFilepatchMerger (Regrem und unw p1 p2) > = isFilepatchMerger (Merger und unw p1 p2) > -isFilepatchMerger (ComP _) = Nothing > > commuteRecursiveMerger :: (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) > commuteRecursiveMerger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ ok hunk ./src/Darcs/Patch/V1/Commute.lhs 259 > - do (_ :> pA') <- commute (pA :> undo) > - commute (pA' :> invert undo) > + do (_ :> pA') <- commuterIdFL selfCommuter (pA :> undo) > + commuterIdFL selfCommuter (pA' :> invert undo) > (_ :> pAmid) <- commute (pA :> unsafeCoercePStart (invert p1)) > (p1' :> pAx) <- commute (pAmid :> p1) > guard (pAx `unsafeCompare` pA) pA is now a FL hunk ./src/Darcs/Patch/V1/Commute.lhs 271 > then unsafeCoerceP p > else unsafeMerger "0.0" p1' p2' > undo' = mergerUndo p' > - (pAo :> _) <- commute (undo' :> pA') > + (pAo :> _) <- commuterFLId selfCommuter (undo' :> pA') > guard (pAo `unsafeCompare` pA) > return (pA' :< p') > where undo = mergerUndo p idem hunk ./src/Darcs/Patch/V1/Commute.lhs 280 > otherCommuteRecursiveMerger :: (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) > otherCommuteRecursiveMerger (pA':< p_old@(Merger _ _ p1' p2')) = > toPerhaps $ > - do (pA :> _) <- commute (mergerUndo p_old :> pA') > + do (pA :> _) <- commuterFLId selfCommuter (mergerUndo p_old :> pA') > (pAmid :> p1) <- commute (unsafeCoercePEnd p1' :> pA) > (_ :> pAmido) <- commute (pA :> invert p1) > guard (pAmido `unsafeCompare` pAmid) likewise hunk ./src/Darcs/Patch/V1/Commute.lhs 292 > else unsafeMerger "0.0" p1 p2 > undo = mergerUndo p > guard (not $ pA `unsafeCompare` p1) -- special case here... > - (_ :> pAo') <- commute (pA :> undo) > + (_ :> pAo') <- commuterIdFL selfCommuter (pA :> undo) > guard (pAo' `unsafeCompare` pA') > return (p :< pA) > otherCommuteRecursiveMerger _ = Unknown same hunk ./src/Darcs/Patch/V1/Commute.lhs 299 > > type CommuteFunction = FORALL(x y) (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) > type MaybeCommute = FORALL(x y) (Patch :< Patch) C(x y) -> Maybe ((Patch :< Patch) C(x y)) > + > +revCommuteFLId :: MaybeCommute -> (FL Patch :< Patch) C(x y) -> Maybe ((Patch :< FL Patch) C(x y)) > +revCommuteFLId _ (NilFL :< p) = return (p :< NilFL) > +revCommuteFLId commuter ((q :>: qs) :< p) = do > + p' :< q' <- commuter (q :< p) > + p'' :< qs' <- revCommuteFLId commuter (qs :< p') > + return (p'' :< (q' :>: qs')) > + Why not in Permutations.hs? hunk ./src/Darcs/Patch/V1/Commute.lhs 421 > > actualMerge :: (Patch :\/: Patch) C(x y) -> Sealed (Patch C(y)) > > -actualMerge (ComP the_p1s :\/: ComP the_p2s) = > - mapSeal joinPatchesFL $ mc (the_p1s :\/: the_p2s) > - where mc :: (FL Patch :\/: FL Patch) C(x y) -> Sealed (FL Patch C(y)) > - mc (NilFL :\/: (_:>:_)) = Sealed NilFL > - mc (p1s :\/: NilFL) = Sealed p1s > - mc (p1s :\/: (p2:>:p2s)) = case mergePatchesAfterPatch (p1s:\/:p2) of > - Sealed x -> mc (x:\/:p2s) > -actualMerge (ComP p1s :\/: p2) = seq p2 $ > - mapSeal joinPatchesFL $ mergePatchesAfterPatch (p1s:\/:p2) > -actualMerge (p1 :\/: ComP p2s) = seq p1 $ mergePatchAfterPatches (p1:\/:p2s) > - > actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of > Just (_ :/\: p1') -> Sealed p1' > Nothing -> merger "0.0" p2 p1 get rid of ComP cases hunk ./src/Darcs/Patch/V1/Commute.lhs 425 > > -mergePatchAfterPatches :: (Patch :\/: FL Patch) C(x y) -> Sealed (Patch C(y)) > -mergePatchAfterPatches (p :\/: (p1:>:p1s)) = > - case actualMerge (p:\/:p1) of > - Sealed x -> mergePatchAfterPatches (x :\/: p1s) > -mergePatchAfterPatches (p :\/: NilFL) = Sealed p > - > -mergePatchesAfterPatch :: (FL Patch :\/: Patch) C(x y) -> Sealed (FL Patch C(y)) > -mergePatchesAfterPatch (p2s :\/: p) = > - case mergePatchAfterPatches (p :\/: p2s) of > - Sealed x -> case commute (joinPatchesFL p2s :> x) of > - Just (_ :> ComP p2s') -> Sealed (unsafeCoercePStart p2s') > - _ -> impossible > \end{code} > now dead code hunk ./src/Darcs/Patch/V1/Commute.lhs 595 > where rcs :: FL Patch C(y w) -> RL Patch C(x y) -> [[Sealed (FL Prim C(w))]] > rcs _ NilRL = [] > rcs passedby (p@(Merger _ _ _ _):<:ps) = > - case commuteNoMerger (joinPatchesFL passedby:<p) of > + case revCommuteFLId commuteNoMerger (passedby:<p) of > Just (p'@(Merger _ _ p1 p2):<_) -> > (map Sealed $ nubBy unsafeCompare $ > effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : map (unsafeCoercePStart . unsafeUnseal) (unravel p')) passedby is now an FL hunk ./src/Darcs/Patch/V1/Commute.lhs 641 > undoit = > case (isMerger p1, isMerger p2) of > (True ,True ) -> case unwind p of > - Sealed (_:<:t) -> unsafeCoerceP $ joinPatchesFL $ invertRL t > + Sealed (_:<:t) -> unsafeCoerceP $ invertRL t > _ -> impossible ok hunk ./src/Darcs/Patch/V1/Commute.lhs 643 > - (False,False) -> unsafeCoerceP $ invert p1 > - (True ,False) -> unsafeCoerceP $ joinPatchesFL NilFL > - (False,True ) -> unsafeCoerceP $ joinPatchesFL (invert p1 :>: mergerUndo p2 :>: NilFL) > + (False,False) -> unsafeCoerceP $ invert p1 :>: NilFL > + (True ,False) -> unsafeCoerceP $ NilFL > + (False,True ) -> unsafeCoerceP $ invert p1 :>: mergerUndo p2 > merger g _ _ = > error $ "Cannot handle mergers other than version 0.0\n"++g > ++ "\nPlease use darcs optimize --modernize with an older darcs." ok hunk ./src/Darcs/Patch/V1/Commute.lhs 650 > > -glump09 :: Patch C(x y) -> Patch C(x z) -> Sealed (Patch C(y)) > -glump09 p1 p2 = mapSeal fromPrims $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2 > +glump09 :: Patch C(x y) -> Patch C(x z) -> Sealed (FL Patch C(y)) > +glump09 p1 p2 = mapSeal (mapFL_FL fromPrim) $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2 > ok. $ darcs annotate src/Patch/V1/Commute.lhs # Line added by [Copy-Paste from Necronomicon.hs # Cthulhu <cth...@r_lyeh.fm>**20101111183255 Ignore-this: b9ce3228c14d2daf198b3ec4337669fc ] … oh, right. hunk ./src/Darcs/Patch/V1/Commute.lhs 656 > effect p@(Regrem _ _ _ _) = invert $ effect $ invert p > - effect (ComP ps) = concatFL $ mapFL_FL effect ps > effect (PP p) = effect p > isHunk p = do PP p' <- return p > isHunk p' ok hunk ./src/Darcs/Patch/V1/Commute.lhs 660 > > -instance FromPrims Patch where > - fromPrims (p :>: NilFL) = PP p > - fromPrims ps = joinPatchesFL $ mapFL_FL PP ps > - joinPatches = joinPatchesFL > - > newUr :: Patch C(a b) -> RL Patch C(x y) -> [Sealed (RL Patch C(x))] > newUr p (Merger _ _ p1 p2 :<: ps) = > case filter (\(pp:<:_) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of removal: fromPrims yields a FL hunk ./src/Darcs/Patch/V1/Commute.lhs 681 > invert (Regrem undo unwindings p1 p2) > = Merger undo unwindings p1 p2 > invert (PP p) = PP (invert p) > - invert (ComP ps) = ComP $ invert ps > - identity = ComP NilFL > + identity = PP identity > ok hunk ./src/Darcs/Patch/V1/Commute.lhs 691 > > eqPatches :: Patch C(x y) -> Patch C(w z) -> Bool > eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2 > -eqPatches (ComP ps1) (ComP ps2) > - = eqFL eqPatches ps1 ps2 > -eqPatches (ComP NilFL) (PP Identity) = True > -eqPatches (PP Identity) (ComP NilFL) = True > eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) > = eqPatches p1a p2a && > eqPatches p1b p2b ok hunk ./src/Darcs/Patch/V1/Commute.lhs 699 > eqPatches p1b p2b > eqPatches _ _ = False > > -eqFL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) > - -> FL a C(x y) -> FL a C(w z) -> Bool > -eqFL _ NilFL NilFL = True > -eqFL f (x:>:xs) (y:>:ys) = f x y && eqFL f xs ys > -eqFL _ _ _ = False > - > \end{code} now in Witnesses ======================================================================== IO with V1 patches ======================================================================== hunk ./src/Darcs/Patch/V1/Read.hs 5 [imports] hunk ./src/Darcs/Patch/V1/Read.hs 23 > > instance ReadPatch Patch where > readPatch' want_eof > - = do mps <- bracketedFL (readPatch' False) '{' '}' > - case mps of > - Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps > - Nothing -> choice [ liftM (Just . seal) $ skipSpace >> readMerger True > - , liftM (Just . seal) $ skipSpace >> readMerger False > - , liftM (fmap (mapSeal PP)) $ readPatch' want_eof > - , return Nothing ] > + = choice [ liftM (Just . seal) $ skipSpace >> readMerger True > + , liftM (Just . seal) $ skipSpace >> readMerger False > + , liftM (fmap (mapSeal PP)) $ readPatch' want_eof > + , return Nothing ] This will fail if we do have a ComP, but will be corrected in a followup hunk ./src/Darcs/Patch/V1/Show.lhs 9 hunk ./src/Darcs/Patch/V1/Show.lhs 11 [imports] hunk ./src/Darcs/Patch/V1/Show.lhs 34 > > showPatch_ :: Patch C(a b) -> Doc > showPatch_ (PP p) = showPrim OldFormat p > -showPatch_ (ComP NilFL) = blueText "{" $$ blueText "}" > -showPatch_ (ComP ps) = blueText "{" > - $$ vcat (mapFL showPatch_ ps) > - $$ blueText "}" > showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2 > showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2 > \end{code} ok hunk ./src/Darcs/Patch/V1/Viewing.hs 6 hunk ./src/Darcs/Patch/V1/Viewing.hs 13 [imports] hunk ./src/Darcs/Patch/V1/Viewing.hs 18 > showPatch = showPatch_ > showContextPatch (PP x) | primIsHunk x = showContextHunk x > - showContextPatch (ComP NilFL) = return $ blueText "{" $$ blueText "}" > - showContextPatch (ComP ps) = > - do x <- showContextSeries ps > - return $ blueText "{" $$ x $$ blueText "}" > showContextPatch p = return $ showPatch p > summary = plainSummary > thing _ = "change" ok hunk ./src/Darcs/Patch/V1/Viewing.hs 21 > + showFLBehavior = ShowFLV1 > to be undone… ======================================================================== New IO for patches ======================================================================== hunk ./src/Darcs/Patch/V2/Real.hs 39 > showPrim, showPrimFL, FileNameFormat(NewFormat), > IsConflictedPrim(..), ConflictState(..) ) > import Darcs.Patch.Read ( readPrim, bracketedFL ) > +import Darcs.Patch.Show ( ShowFLBehavior(ShowFLV2) ) > import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..) > , PatchInspect(..) > , ReadPatch(..), ShowPatch(..) idem hunk ./src/Darcs/Patch/V2/Real.hs 737 > showNon p > showContextPatch (Normal p) = showContextPatch p > showContextPatch c = return $ showPatch c > + showFLBehavior = ShowFLV2 > > instance ReadPatch RealPatch where > readPatch' _ = skipSpace >> choice likewise hunk ./src/Darcs/Patch/Read.hs 40 [imports] hunk ./src/Darcs/Patch/Read.hs 58 > > > instance ReadPatch p => ReadPatch (FL p) where > - readPatch' want_eof = Just `liftM` read_patches > - where read_patches :: ParserM m => m (Sealed (FL p C(x ))) > - read_patches = do --tracePeek "starting FL read" > - mp <- readPatch' False > + readPatch' eof = Just `liftM` read_patches_braces eof > + where read_patches, read_patches_braces :: ParserM m => Bool -> m (Sealed (FL p C(x ))) > + read_patches want_eof > + = do --tracePeek "starting FL read" > + -- need to make sure that something is read, to avoid > + -- stack overflow when parsing FL (FL p) > + mp <- checkConsumes $ readPatch' False > case mp of > Just (Sealed p) -> do --tracePeek "found one patch" hunk ./src/Darcs/Patch/Read.hs 67 > - Sealed ps <- read_patches > + Sealed ps <- read_patches want_eof > return $ Sealed (p:>:ps) > Nothing -> if want_eof > then do --tracePeek "no more patches" hunk ./src/Darcs/Patch/Read.hs 76 > () -> return $ Sealed NilFL > else do --tracePeek "no more patches" > return $ Sealed NilFL > + read_patches_braces want_eof = > + do mps <- bracketedFL (readPatch' False) '{' '}' > + case mps of > + Just res -> if want_eof > + then do unit' <- lexEof > + case unit' of > + () -> return res > + else return res > + Nothing -> read_patches want_eof > + > -- tracePeek x = do y <- peekInput > -- traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return () > to be undone later… hunk ./src/Darcs/Patch/ReadMonads.hs 10 > option, choice, skipSpace, skipWhile, string, > lexChar, lexString, lexEof, takeTillChar, > myLex', anyChar, endOfInput, takeTill, > + checkConsumes, > linesStartingWith, linesStartingWithEndingWith) where > > import ByteStringUtils ( dropSpace, breakSpace, breakFirstPS, hunk ./src/Darcs/Patch/ReadMonads.hs 182 > choice :: Alternative f => [f a] -> f a > choice = foldr (<|>) empty > > +-- |Ensure that a parser consumes input when producing a result > +-- Causes the initial state of the input stream to be held on to while the > +-- parser runs, so use with caution. > +checkConsumes :: ParserM m => m (Maybe a) -> m (Maybe a) > +checkConsumes parser = do > + x <- B.length <$> peekInput > + res <- parser > + x' <- B.length <$> peekInput > + return $ if x' < x then res else Nothing > + > class (Functor m, Applicative m, Alternative m, Monad m, MonadPlus m) => ParserM m where > -- | Applies a parsing function inside the 'ParserM' monad. > work :: (B.ByteString -> Maybe (ParserState a)) -> m a ok hunk ./src/Darcs/Patch/Show.lhs 22 > -module Darcs.Patch.Show ( ShowPatch(..), showNamedPrefix ) > +module Darcs.Patch.Show ( ShowPatch(..), ShowFLBehavior(..), showNamedPrefix ) hunk ./src/Darcs/Patch/Show.lhs 53 > +-- | This type is used to tweak the way that 'FL p' is shown for a > +-- given 'Patch' type 'p'. It is needed to maintain backwards compatibility > +-- for V1 and V2 patches. > +data ShowFLBehavior p > + = ShowFLDefault -- ^braces around all lists > + | ShowFLV1 -- ^braces around all lists except singletons > + | ShowFLV2 -- ^no braces around lists > ShowFLDefault would be for debug output? hunk ./src/Darcs/Patch/Show.lhs 61 hunk ./src/Darcs/Patch/Show.lhs 79 > thing _ = "patch" > things :: p C(x y) -> String > things x = plural (Noun $ thing x) "" > + showFLBehavior :: ShowFLBehavior p > + showFLBehavior = ShowFLDefault > > \end{code} ok hunk ./src/Darcs/Patch/Viewing.hs 46 > Effect, IsConflictedPrim(IsC), ConflictState(..), > DirPatchType(..), FilePatchType(..) ) > import Darcs.Patch.Patchy ( Apply, ShowPatch(..), identity ) > -import Darcs.Patch.Show ( showNamedPrefix ) > +import Darcs.Patch.Show ( showNamedPrefix, ShowFLBehavior(..) ) > import Darcs.Patch.Info ( showPatchInfo, humanFriendly ) > import Darcs.Patch.Apply ( applyToTree ) > import Darcs.Patch.Named ( Named(..), patchcontents ) hunk ./src/Darcs/Patch/Viewing.hs 279 > showDict2 = ShowDictClass > > instance (Apply p, Effect p, ShowPatch p) => ShowPatch (FL p) where > - showPatch xs = vcat (mapFL showPatch xs) > + showPatch = showPatchInternal showFLBehavior > + where showPatchInternal :: ShowPatch q => ShowFLBehavior q -> FL q C(x y) -> Doc > + showPatchInternal ShowFLV2 xs = vcat (mapFL showPatch xs) > + showPatchInternal ShowFLV1 (x :>: NilFL) = showPatch x > + showPatchInternal _ NilFL = blueText "{" $$ blueText "}" > + showPatchInternal _ xs = blueText "{" $$ vcat (mapFL showPatch xs) $$ blueText "}" > + > showContextPatch = showContextSeries > description = vcat . mapFL description > summary = vcat . mapFL summary ok ======================================================================== Use the new patches in repositories ======================================================================== hunk ./src/Darcs/Repository.hs 165 > writeRepoFormat rf (darcsdir++"/format") > if formatHas HashedInventory rf > then writeBinFile (darcsdir++"/hashed_inventory") "" > - else DarcsRepo.writeInventory "." (PatchSet NilRL NilRL :: PatchSet Patch C(Origin Origin)) -- YUCK! > + else DarcsRepo.writeInventory "." (PatchSet NilRL NilRL :: PatchSet (FL Patch) C(Origin Origin)) -- YUCK! > > copyRepository :: RepoPatch p => Repository p C(r u t) -> IO () > copyRepository fromrepository@(Repo _ opts rf _) ok hunk ./src/Darcs/Repository.hs 213 > > copyOldrepoPatches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO () > copyOldrepoPatches opts repository@(Repo dir _ _ _) out = do > - Sealed patches <- DarcsRepo.readRepo "." :: IO (SealedPatchSet Patch C(Origin)) > + Sealed patches <- DarcsRepo.readRepo "." :: IO (SealedPatchSet (FL Patch) C(Origin)) > mpi <- if Partial `elem` opts > -- FIXME this should get last pinfo *before* > -- desired tag... ok hunk ./src/Darcs/Repository/Internal.hs 113 > allFL, filterFLFL, > reverseFL, mapFL_FL, concatFL ) > import Darcs.Patch ( RepoPatch, Patchy, Prim, merge, > - joinPatches, > listConflictedFiles, listTouchedFiles, > Named, patchcontents, > commuteRL, fromPrims, ok hunk ./src/Darcs/Repository/Internal.hs 227 > Nothing -> do cs <- getCaches opts url > return $ GoodRepository $ Repo url opts rf (DarcsRepository nopristine cs) > > -identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t)) > +identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository (FL Patch) C(r u t)) > identifyDarcs1Repository opts url = > do er <- maybeIdentifyRepository opts url > case er of we really should drop the 1 in identifyDarcs1Repository, given that it comes up in code paths for darcs2 repositories. hunk ./src/Darcs/Repository/Internal.hs 447 > checkUnrecordedConflicts opts pc = > do repository <- identifyDarcs1Repository opts "." > cuc repository > - where cuc :: Repository Patch C(r u t) -> IO Bool > + where cuc :: Repository (FL Patch) C(r u t) -> IO Bool > cuc r = do Sealed mpend <- readPending r :: IO (Sealed (FL Prim C(t))) > case mpend of > NilFL -> return False ok hunk ./src/Darcs/Repository/Internal.hs 661 > job2_ (Repo dir opts rf rt) > where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a > job1_ = job > - job2_ :: Repository Patch C(r u r) -> IO a > + job2_ :: Repository (FL Patch) C(r u r) -> IO a > job2_ = job > > ok hunk ./src/Darcs/Repository/Internal.hs 805 > withTentative repository@(Repo dir _ _ _) mk_dir f = > withRecorded repository mk_dir $ \d -> > do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine") > - apply $ joinPatches ps > + apply ps > f d > where read_patches :: FilePath -> IO (Sealed (FL p C(x))) > read_patches fil = do ps <- B.readFile fil ok hunk ./src/Darcs/Repository/LowLevel.hs 68 > return $ readPendingContents pend > > -- Wrapper around FL where printed format uses { } except around singletons > +-- Now that the Show behaviour of FL p can be customised (using showFLBehavior), > +-- we could instead change the general behaviour of FL Prim; but since the pending > +-- code can be kept nicely compartmentalised, it's nicer to do it this way. > newtype FLM p C(x y) = FLM { unFLM :: FL p C(x y) } > > instance ReadPatch p => ReadPatch (FLM p) where ok ======================================================================== Tests ======================================================================== hunk ./src/Darcs/Test/Patch/Test.hs 63 hunk ./src/Darcs/Test/Patch/Test.hs 66 [imports] hunk ./src/Darcs/Test/Patch/Test.hs 115 > instance Arbitrary (Sealed (Prim C(x))) where > arbitrary = arbitraryP > > -instance Arbitrary (Sealed (Patch C(x))) where > +instance Arbitrary (Sealed (FL Patch C(x))) where > arbitrary = arbitraryP > > instance Arbitrary (Sealed2 (Prim :> Prim)) where ok, idem from then on ======================================================================== Use of the new API in commands ======================================================================== hunk ./src/Darcs/Commands/Convert.lhs 53 hunk ./src/Darcs/Commands/Convert.lhs 62 hunk ./src/Darcs/Commands/Convert.lhs 78 [imports and includes] hunk ./src/Darcs/Commands/Convert.lhs 173 > -- unsatisfying. > > let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch) C(r u t) > - themrepo = unsafeCoerce# themrepobar :: Repository Patch C(r u t) > + themrepo = unsafeCoerce# themrepobar :: Repository (FL Patch) C(r u t) > theirstuff <- readRepo themrepo > let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff > inOrderTags = iot theirstuff ok hunk ./src/Darcs/Commands/Convert.lhs 202 > "lossy conversion of complicated conflict:" $$ > showPatch x) > fromPrims (effect x) > - | otherwise = case flattenFL x of > - NilFL -> NilFL > - (x':>:NilFL) -> fromPrims $ effect x' > - xs -> concatFL $ mapFL_FL convertOne xs > - convertNamed :: Named Patch C(x y) -> PatchInfoAnd (FL RealPatch) C(x y) > + convertOne (PP x) = fromPrim x :>: NilFL > + convertOne _ = impossible > + convertFL :: FL Patch C(x y) -> FL RealPatch C(x y) > + convertFL = concatFL . mapFL_FL convertOne > + convertNamed :: Named (FL Patch) C(x y) -> PatchInfoAnd (FL RealPatch) C(x y) > convertNamed n = n2pia $ > adddeps (infopatch (convertInfo $ patch2patchinfo n) $ ok hunk ./src/Darcs/Commands/Convert.lhs 209 > - convertOne $ patchcontents n) > + convertFL $ patchcontents n) > (map convertInfo $ concatMap fixDep $ getdeps n) > convertInfo n | n `elem` inOrderTags = n > | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n ok hunk ./src/Darcs/Commands/Get.lhs 59 [imports] hunk ./src/Darcs/Commands/Get.lhs 173 > Right x -> return x > if formatHas HashedInventory rf -- refactor this into repository > then writeBinFile (darcsdir++"/hashed_inventory") "" > - else writeInventory "." (PatchSet NilRL NilRL :: PatchSet Patch C(Origin Origin)) > + else writeInventory "." (PatchSet NilRL NilRL :: PatchSet (FL Patch) C(Origin Origin)) > > if not (null [p | OnePattern p <- opts]) -- --to-match given > && not (Partial `elem` opts) && not (Lazy `elem` opts) ok hunk ./src/Darcs/Commands/Get.lhs 333 > debugMessage "Copying patches..." > copyOldrepoPatches opts fromrepo "." > debugMessage "Patches copied" > - Sealed local_patches <- DR.readRepo "." :: IO (SealedPatchSet Patch C(Origin)) > + Sealed local_patches <- DR.readRepo "." :: IO (SealedPatchSet (FL Patch) C(Origin)) > debugMessage "Repo read" > repo_is_local <- doesDirectoryExist repodir > debugMessage $ "Repo local: " ++ formatPath (show repo_is_local) ok hunk ./src/Darcs/Commands/Record.lhs 355 > $$ text "" > $$ text "This patch contains the following changes:" > $$ text "" > - $$ summary (fromPrims chs :: Patch C(x y)) > + $$ summary (fromPrims chs :: FL Patch C(x y)) > > eod :: String > eod = "***END OF DESCRIPTION***" ok __________________________________ Darcs bug tracker <[email protected]> <http://bugs.darcs.net/patch421> __________________________________ _______________________________________________ darcs-users mailing list [email protected] http://lists.osuosl.org/mailman/listinfo/darcs-users
