[darcs-users] [patch421] getting rid of ComP constructor in Patch
Florent Becker
bugs at darcs.net
Thu Nov 11 20:37:13 UTC 2010
Florent Becker <florent.becker at ens-lyon.org> added the comment:
get rid of ComP
---------------
Ganesh Sittampalam <ganesh at earth.li>**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 <cthulu at 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 <bugs at darcs.net>
<http://bugs.darcs.net/patch421>
__________________________________
More information about the darcs-users
mailing list