% Copyright (C) 2002-2003,2007 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.
\begin{code}
#include "gadts.h"
module Darcs.Patch.Prim
( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim, showPrimFL, showHunk,
DirPatchType(..), FilePatchType(..),
CommuteFunction, Perhaps(..),
null_patch, nullP, isNullPatch,
isIdentity,
formatFileName, FileNameFormat(..),
adddir, addfile, binary, changepref,
hunk, move, rmdir, rmfile, tokreplace,
primIsAddfile, primIsHunk, primIsBinary, primIsSetpref,
isSimilar, primIsAdddir, is_filepatch,
canonize, tryToShrink, modernizePrim,
subcommutes, sortCoalesceFL, join, canonizeFL,
tryTokInternal,
tryShrinkingInverse,
nFn,
FromPrim(..), FromPrims(..), ToFromPrim(..),
Conflict(..), Effect(..), commuteNoConflictsFL, commuteNoConflictsRL
)
where
import Prelude hiding ( pi )
import Control.Monad ( MonadPlus, msum, mzero, mplus )
import Data.Maybe ( isNothing, listToMaybe, catMaybes )
import Data.Map ( elems, fromListWith, mapWithKey )
import ByteStringUtils ( substrPS, fromPS2Hex)
import qualified Data.ByteString as B (ByteString, length, null, head, take, concat, drop)
import qualified Data.ByteString.Char8 as BC (break, pack, head)
import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, normPath,
movedirfilename, encodeWhite )
import Darcs.Witnesses.Ordered
import Darcs.Witnesses.Sealed ( Sealed, unseal, Sealed2(..), unsafeUnseal2 )
import Darcs.Patch.Patchy ( Invert(..), Commute(..), toFwdCommute, toRevCommute )
import Darcs.Patch.Permutations ()
import Darcs.Witnesses.Show
import Darcs.Utils ( nubsort )
import Lcs ( getChanges )
import Darcs.Patch.RegChars ( regChars )
import Printer ( Doc, vcat, packedString, Color(Cyan,Magenta), lineColor,
text, userchunk, invisibleText, invisiblePS, blueText,
($$), (<+>), (<>), prefix, userchunkPS,
)
import GHC.Base (unsafeCoerce#)
#include "impossible.h"
data Prim C(x y) where
Move :: !FileName -> !FileName -> Prim C(x y)
DP :: !FileName -> !(DirPatchType C(x y)) -> Prim C(x y)
FP :: !FileName -> !(FilePatchType C(x y)) -> Prim C(x y)
Split :: FL Prim C(x y) -> Prim C(x y)
Identity :: Prim C(x x)
ChangePref :: !String -> !String -> !String -> Prim C(x y)
data FilePatchType C(x y) = RmFile | AddFile
| Hunk !Int [B.ByteString] [B.ByteString]
| TokReplace !String !String !String
| Binary B.ByteString B.ByteString
deriving (Eq,Ord)
data DirPatchType C(x y) = RmDir | AddDir
deriving (Eq,Ord)
instance MyEq FilePatchType where
unsafeCompare a b = a == unsafeCoerce# b
instance MyEq DirPatchType where
unsafeCompare a b = a == unsafeCoerce# b
null_patch :: Prim C(x x)
null_patch = Identity
isNullPatch :: Prim C(x y) -> Bool
isNullPatch (FP _ (Binary x y)) = B.null x && B.null y
isNullPatch (FP _ (Hunk _ [] [])) = True
isNullPatch Identity = True
isNullPatch _ = False
nullP :: Prim C(x y) -> EqCheck C(x y)
nullP = sloppyIdentity
isIdentity :: Prim C(x y) -> EqCheck C(x y)
isIdentity (FP _ (Binary old new)) | old == new = unsafeCoerce# IsEq
isIdentity (FP _ (Hunk _ old new)) | old == new = unsafeCoerce# IsEq
isIdentity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerce# IsEq
isIdentity (Move old new) | old == new = unsafeCoerce# IsEq
isIdentity Identity = IsEq
isIdentity _ = NotEq
isSimilar :: Prim C(x y) -> Prim C(a b) -> Bool
isSimilar (FP f _) (FP f' _) = f == f'
isSimilar (DP f _) (DP f' _) = f == f'
isSimilar _ _ = False
primIsAddfile :: Prim C(x y) -> Bool
primIsAddfile (FP _ AddFile) = True
primIsAddfile _ = False
primIsAdddir :: Prim C(x y) -> Bool
primIsAdddir (DP _ AddDir) = True
primIsAdddir _ = False
primIsHunk :: Prim C(x y) -> Bool
primIsHunk (FP _ (Hunk _ _ _)) = True
primIsHunk _ = False
primIsBinary :: Prim C(x y) -> Bool
primIsBinary (FP _ (Binary _ _)) = True
primIsBinary _ = False
primIsSetpref :: Prim C(x y) -> Bool
primIsSetpref (ChangePref _ _ _) = True
primIsSetpref _ = False
addfile :: FilePath -> Prim C(x y)
rmfile :: FilePath -> Prim C(x y)
adddir :: FilePath -> Prim C(x y)
rmdir :: FilePath -> Prim C(x y)
move :: FilePath -> FilePath -> Prim C(x y)
changepref :: String -> String -> String -> Prim C(x y)
hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> Prim C(x y)
tokreplace :: FilePath -> String -> String -> String -> Prim C(x y)
binary :: FilePath -> B.ByteString -> B.ByteString -> Prim C(x y)
evalargs :: (a -> b -> c) -> a -> b -> c
evalargs f x y = (f $! x) $! y
addfile f = FP (fp2fn $ nFn f) AddFile
rmfile f = FP (fp2fn $ nFn f) RmFile
adddir d = DP (fp2fn $ nFn d) AddDir
rmdir d = DP (fp2fn $ nFn d) RmDir
move f f' = Move (fp2fn $ nFn f) (fp2fn $ nFn f')
changepref p f t = ChangePref p f t
hunk f line old new = evalargs FP (fp2fn $ nFn f) (Hunk line old new)
tokreplace f tokchars old new =
evalargs FP (fp2fn $ nFn f) (TokReplace tokchars old new)
binary f old new = FP (fp2fn $! nFn f) $ Binary old new
nFn :: FilePath -> FilePath
nFn f = "./"++(fn2fp $ normPath $ fp2fn f)
instance Invert Prim where
invert Identity = Identity
invert (FP f RmFile) = FP f AddFile
invert (FP f AddFile) = FP f RmFile
invert (FP f (Hunk line old new)) = FP f $ Hunk line new old
invert (FP f (TokReplace t o n)) = FP f $ TokReplace t n o
invert (FP f (Binary o n)) = FP f $ Binary n o
invert (DP d RmDir) = DP d AddDir
invert (DP d AddDir) = DP d RmDir
invert (Move f f') = Move f' f
invert (ChangePref p f t) = ChangePref p t f
invert (Split ps) = Split $ invert ps
identity = Identity
sloppyIdentity Identity = IsEq
sloppyIdentity _ = NotEq
instance Show (Prim C(x y)) where
showsPrec d (Move fn1 fn2) = showParen (d > appPrec) $ showString "Move " .
showsPrec (appPrec + 1) fn1 . showString " " .
showsPrec (appPrec + 1) fn2
showsPrec d (DP fn dp) = showParen (d > appPrec) $ showString "DP " .
showsPrec (appPrec + 1) fn . showString " " .
showsPrec (appPrec + 1) dp
showsPrec d (FP fn fp) = showParen (d > appPrec) $ showString "FP " .
showsPrec (appPrec + 1) fn . showString " " .
showsPrec (appPrec + 1) fp
showsPrec d (Split l) = showParen (d > appPrec) $ showString "Split " .
showsPrec (appPrec + 1) l
showsPrec _ Identity = showString "Identity"
showsPrec d (ChangePref p f t) = showParen (d > appPrec) $ showString "ChangePref " .
showsPrec (appPrec + 1) p . showString " " .
showsPrec (appPrec + 1) f . showString " " .
showsPrec (appPrec + 1) t
instance Show2 Prim where
showDict2 = ShowDictClass
instance Show (FilePatchType C(x y)) where
showsPrec _ RmFile = showString "RmFile"
showsPrec _ AddFile = showString "AddFile"
showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new
= showParen (d > appPrec) $ showString "Hunk " .
showsPrec (appPrec + 1) line . showString " " .
showsPrecC old . showString " " .
showsPrecC new
where showsPrecC [] = showString "[]"
showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss)
showsPrec d (Hunk line old new) = showParen (d > appPrec) $ showString "Hunk " .
showsPrec (appPrec + 1) line . showString " " .
showsPrec (appPrec + 1) old . showString " " .
showsPrec (appPrec + 1) new
showsPrec d (TokReplace t old new) = showParen (d > appPrec) $ showString "TokReplace " .
showsPrec (appPrec + 1) t . showString " " .
showsPrec (appPrec + 1) old . showString " " .
showsPrec (appPrec + 1) new
showsPrec d (Binary old new) = showParen (d > appPrec) $ showString "Binary " .
showsPrec (appPrec + 1) old . showString " " .
showsPrec (appPrec + 1) new
instance Show (DirPatchType C(x y)) where
showsPrec _ RmDir = showString "RmDir"
showsPrec _ AddDir = showString "AddDir"
data FileNameFormat = OldFormat | NewFormat
formatFileName :: FileNameFormat -> FileName -> Doc
formatFileName OldFormat = packedString . fn2ps
formatFileName NewFormat = text . encodeWhite . fn2fp
showPrim :: FileNameFormat -> Prim C(a b) -> Doc
showPrim x (FP f AddFile) = showAddFile x f
showPrim x (FP f RmFile) = showRmFile x f
showPrim x (FP f (Hunk line old new)) = showHunk x f line old new
showPrim x (FP f (TokReplace t old new)) = showTok x f t old new
showPrim x (FP f (Binary old new)) = showBinary x f old new
showPrim x (DP d AddDir) = showAddDir x d
showPrim x (DP d RmDir) = showRmDir x d
showPrim x (Move f f') = showMove x f f'
showPrim _ (ChangePref p f t) = showChangePref p f t
showPrim x (Split ps) = showSplit x ps
showPrim _ Identity = blueText "{}"
showPrimFL :: FileNameFormat -> FL Prim C(a b) -> Doc
showPrimFL f xs = vcat (mapFL (showPrim f) xs)
\end{code}
\paragraph{Add file}
Add an empty file to the tree.
\verb!addfile filename!
\begin{code}
showAddFile :: FileNameFormat -> FileName -> Doc
showAddFile x f = blueText "addfile" <+> formatFileName x f
\end{code}
\paragraph{Remove file}
Delete a file from the tree.
\verb!rmfile filename!
\begin{code}
showRmFile :: FileNameFormat -> FileName -> Doc
showRmFile x f = blueText "rmfile" <+> formatFileName x f
\end{code}
\paragraph{Move}
Rename a file or directory.
\verb!move oldname newname!
\begin{code}
showMove :: FileNameFormat -> FileName -> FileName -> Doc
showMove x d d' = blueText "move" <+> formatFileName x d <+> formatFileName x d'
\end{code}
\paragraph{Change Pref}
Change one of the preference settings. Darcs stores a number of simple
string settings. Among these are the name of the test script and the name
of the script that must be called prior to packing in a make dist.
\begin{verbatim}
changepref prefname
oldval
newval
\end{verbatim}
\begin{code}
showChangePref :: String -> String -> String -> Doc
showChangePref p f t = blueText "changepref" <+> text p
$$ userchunk f
$$ userchunk t
\end{code}
\paragraph{Add dir}
Add an empty directory to the tree.
\verb!adddir filename!
\begin{code}
showAddDir :: FileNameFormat -> FileName -> Doc
showAddDir x d = blueText "adddir" <+> formatFileName x d
\end{code}
\paragraph{Remove dir}
Delete a directory from the tree.
\verb!rmdir filename!
\begin{code}
showRmDir :: FileNameFormat -> FileName -> Doc
showRmDir x d = blueText "rmdir" <+> formatFileName x d
\end{code}
\paragraph{Hunk}
Replace a hunk (set of contiguous lines) of text with a new
hunk.
\begin{verbatim}
hunk FILE LINE#
-LINE
...
+LINE
...
\end{verbatim}
\begin{code}
showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc
showHunk x f line old new =
blueText "hunk" <+> formatFileName x f <+> text (show line)
$$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old))
$$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS new))
\end{code}
\paragraph{Token replace}
Replace a token with a new token. Note that this format means that
whitespace must not be allowed within a token. If you know of a practical
application of whitespace within a token, let me know and I may change
this.
\begin{verbatim}
replace FILENAME [REGEX] OLD NEW
\end{verbatim}
\begin{code}
showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc
showTok x f t o n = blueText "replace" <+> formatFileName x f
<+> text "[" <> userchunk t <> text "]"
<+> userchunk o
<+> userchunk n
\end{code}
\paragraph{Binary file modification}
Modify a binary file
\begin{verbatim}
binary FILENAME
oldhex
*HEXHEXHEX
...
newhex
*HEXHEXHEX
...
\end{verbatim}
\begin{code}
showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc
showBinary x f o n =
blueText "binary" <+> formatFileName x f
$$ invisibleText "oldhex"
$$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex o)
$$ invisibleText "newhex"
$$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex n)
where makeprintable ps = invisibleText "*" <> invisiblePS ps
breakEvery :: Int -> B.ByteString -> [B.ByteString]
breakEvery n ps | B.length ps < n = [ps]
| otherwise = B.take n ps : breakEvery n (B.drop n ps)
\end{code}
\paragraph{Split patch [OBSOLETE!]}
A split patch is similar to a composite patch but rather than being
composed of several patches grouped together, it is created from one
patch that has been split apart, typically through a merge or
commutation.
\begin{verbatim}
(
(indented two)
)
\end{verbatim}
\begin{code}
showSplit :: FileNameFormat -> FL Prim C(x y) -> Doc
showSplit x ps = blueText "("
$$ vcat (mapFL (showPrim x) ps)
$$ blueText ")"
commuteSplit :: CommuteFunction
commuteSplit (Split patches :< patch) =
toPerhaps $ cs (patches :< patch) >>= sc
where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y))
cs (NilFL :< p1) = return (p1 :< NilFL)
cs (p:>:ps :< p1) = do p' :> p1' <- commute (p1 :> p)
p1'' :< ps' <- cs (ps :< p1')
return (p1'' :< p':>:ps')
sc :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y))
sc (p1 :< ps) = scFL $ p1 :< (sortCoalesceFL ps)
where scFL :: (Prim :< (FL Prim)) C(x y)
-> Maybe ((Prim :< Prim) C(x y))
scFL (p1' :< (p :>: NilFL)) = return (p1' :< p)
scFL (p1' :< ps') = return (p1' :< Split ps')
commuteSplit _ = Unknown
tryToShrink :: FL Prim C(x y) -> FL Prim C(x y)
tryToShrink = mapPrimFL tryHarderToShrink
mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y))
-> FL Prim C(w z) -> FL Prim C(w z)
mapPrimFL f x =
case mapM toSimpleSealed $ mapFL Sealed2 x of
Just sx -> concatFL $ unsealList $ elems $
mapWithKey (\ k p -> Sealed2 (f (fromSimples k (unsealList (p []))))) $
fromListWith (flip (.)) $
map (\ (a,b) -> (a,(b:))) sx
Nothing -> f x
where
unsealList :: [Sealed2 p] -> FL p C(a b)
unsealList [] = unsafeCoerceP NilFL
unsealList (x:xs) = unsafeUnseal2 x :>: unsealList xs
toSimpleSealed :: Sealed2 Prim -> Maybe (FileName, Sealed2 Simple)
toSimpleSealed (Sealed2 p) = fmap (\(fn, s) -> (fn, Sealed2 s)) (toSimple p)
data Simple C(x y) = SFP !(FilePatchType C(x y)) | SDP !(DirPatchType C(x y))
| SCP String String String
deriving ( Show )
toSimple :: Prim C(x y) -> Maybe (FileName, Simple C(x y))
toSimple (FP a b) = Just (a, SFP b)
toSimple (DP a AddDir) = Just (a, SDP AddDir)
toSimple (DP _ RmDir) = Nothing
toSimple (Move _ _) = Nothing
toSimple (Split _) = Nothing
toSimple Identity = Nothing
toSimple (ChangePref a b c) = Just (fp2fn "_darcs/prefs/prefs", SCP a b c)
fromSimple :: FileName -> Simple C(x y) -> Prim C(x y)
fromSimple a (SFP b) = FP a b
fromSimple a (SDP b) = DP a b
fromSimple _ (SCP a b c) = ChangePref a b c
fromSimples :: FileName -> FL Simple C(x y) -> FL Prim C(x y)
fromSimples a bs = mapFL_FL (fromSimple a) bs
tryHarderToShrink :: FL Prim C(x y) -> FL Prim C(x y)
tryHarderToShrink x = tryToShrink2 $ maybe x id (tryShrinkingInverse x)
tryToShrink2 :: FL Prim C(x y) -> FL Prim C(x y)
tryToShrink2 psold =
let ps = sortCoalesceFL psold
ps_shrunk = shrinkABit ps
in
if lengthFL ps_shrunk < lengthFL ps
then tryToShrink2 ps_shrunk
else ps_shrunk
tryShrinkingInverse :: FL Prim C(x y) -> Maybe (FL Prim C(x y))
tryShrinkingInverse (x:>:y:>:z)
| IsEq <- invert x =\/= y = Just z
| otherwise = case tryShrinkingInverse (y:>:z) of
Nothing -> Nothing
Just yz' -> Just $ case tryShrinkingInverse (x:>:yz') of
Nothing -> x:>:yz'
Just xyz' -> xyz'
tryShrinkingInverse _ = Nothing
shrinkABit :: FL Prim C(x y) -> FL Prim C(x y)
shrinkABit NilFL = NilFL
shrinkABit (p:>:ps) =
case tryOne NilRL p ps of
Nothing -> p :>: shrinkABit ps
Just ps' -> ps'
tryOne :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z)
-> Maybe (FL Prim C(w z))
tryOne _ _ NilFL = Nothing
tryOne sofar p (p1:>:ps) =
case coalesce (p1 :< p) of
Just p' -> Just (reverseRL sofar +>+ p':>:NilFL +>+ ps)
Nothing -> case commute (p :> p1) of
Nothing -> Nothing
Just (p1' :> p') -> tryOne (p1':<:sofar) p' ps
canonizeFL :: FL Prim C(x y) -> FL Prim C(x y)
canonizeFL = concatFL . mapFL_FL canonize . sortCoalesceFL .
concatFL . mapFL_FL canonize
sortCoalesceFL :: FL Prim C(x y) -> FL Prim C(x y)
sortCoalesceFL = mapPrimFL sortCoalesceFL2
sortCoalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y)
sortCoalesceFL2 NilFL = NilFL
sortCoalesceFL2 (x:>:xs) | IsEq <- nullP x = sortCoalesceFL2 xs
sortCoalesceFL2 (x:>:xs) | IsEq <- isIdentity x = sortCoalesceFL2 xs
sortCoalesceFL2 (x:>:xs) = either id id $ pushCoalescePatch x $ sortCoalesceFL2 xs
pushCoalescePatch :: Prim C(x y) -> FL Prim C(y z)
-> Either (FL Prim C(x z)) (FL Prim C(x z))
pushCoalescePatch new NilFL = Left (new:>:NilFL)
pushCoalescePatch new ps@(p:>:ps')
= case coalesce (p :< new) of
Just new' | IsEq <- nullP new' -> Right ps'
| otherwise -> Right $ either id id $ pushCoalescePatch new' ps'
Nothing -> if comparePrim new p == LT then Left (new:>:ps)
else case commute (new :> p) of
Just (p' :> new') ->
case pushCoalescePatch new' ps' of
Right r -> Right $ either id id $
pushCoalescePatch p' r
Left r -> Left (p' :>: r)
Nothing -> Left (new:>:ps)
isInDirectory :: FileName -> FileName -> Bool
isInDirectory d f = iid (fn2fp d) (fn2fp f)
where iid (cd:cds) (cf:cfs)
| cd /= cf = False
| otherwise = iid cds cfs
iid [] ('/':_) = True
iid [] [] = True
iid _ _ = False
data Perhaps a = Unknown | Failed | Succeeded a
instance Monad Perhaps where
(Succeeded x) >>= k = k x
Failed >>= _ = Failed
Unknown >>= _ = Unknown
Failed >> _ = Failed
(Succeeded _) >> k = k
Unknown >> k = k
return = Succeeded
fail _ = Unknown
instance MonadPlus Perhaps where
mzero = Unknown
Unknown `mplus` ys = ys
Failed `mplus` _ = Failed
(Succeeded x) `mplus` _ = Succeeded x
toMaybe :: Perhaps a -> Maybe a
toMaybe (Succeeded x) = Just x
toMaybe _ = Nothing
toPerhaps :: Maybe a -> Perhaps a
toPerhaps (Just x) = Succeeded x
toPerhaps Nothing = Failed
cleverCommute :: CommuteFunction -> CommuteFunction
cleverCommute c (p1:<p2) =
case c (p1 :< p2) of
Succeeded x -> Succeeded x
Failed -> Failed
Unknown -> case c (invert p2 :< invert p1) of
Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1')
Failed -> Failed
Unknown -> Unknown
speedyCommute :: CommuteFunction
speedyCommute (p1 :< p2)
| p1_modifies /= Nothing && p2_modifies /= Nothing &&
p1_modifies /= p2_modifies = Succeeded (unsafeCoerce# p2 :< unsafeCoerce# p1)
| otherwise = Unknown
where p1_modifies = is_filepatch p1
p2_modifies = is_filepatch p2
everythingElseCommute :: CommuteFunction
everythingElseCommute x = eec x
where
eec :: CommuteFunction
eec (ChangePref p f t :<p1) = Succeeded (unsafeCoerce# p1 :< ChangePref p f t)
eec (p2 :<ChangePref p f t) = Succeeded (ChangePref p f t :< unsafeCoerce# p2)
eec (Identity :< p1) = Succeeded (p1 :< Identity)
eec (p2 :< Identity) = Succeeded (Identity :< p2)
eec xx =
msum [
cleverCommute commuteFiledir xx
,cleverCommute commuteSplit xx
]
instance Commute Prim where
merge (y :\/: z) =
case elegantMerge (y:\/:z) of
Just (z' :/\: y') -> z' :/\: y'
Nothing -> error "Commute Prim merge"
commute x = toMaybe $ msum [toFwdCommute speedyCommute x,
toFwdCommute everythingElseCommute x
]
listTouchedFiles (Move f1 f2) = map fn2fp [f1, f2]
listTouchedFiles (Split ps) = nubsort $ concat $ mapFL listTouchedFiles ps
listTouchedFiles (FP f _) = [fn2fp f]
listTouchedFiles (DP d _) = [fn2fp d]
listTouchedFiles (ChangePref _ _ _) = []
listTouchedFiles Identity = []
hunkMatches f (FP _ (Hunk _ remove add)) = anyMatches remove || anyMatches add
where anyMatches = foldr ((||) . f) False
hunkMatches _ (FP _ _) = False
hunkMatches f (Split ps) = or $ mapFL (hunkMatches f) ps
hunkMatches _ (DP _ _) = False
hunkMatches _ (ChangePref _ _ _) = False
hunkMatches _ Identity = False
hunkMatches _ (Move _ _) = False
is_filepatch :: Prim C(x y) -> Maybe FileName
is_filepatch (FP f _) = Just f
is_filepatch _ = Nothing
isSuperdir :: FileName -> FileName -> Bool
isSuperdir d1 d2 = isd (fn2fp d1) (fn2fp d2)
where isd s1 s2 =
length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/"
commuteFiledir :: CommuteFunction
commuteFiledir (FP f1 p1 :< FP f2 p2) =
if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerce# p2) :< FP f1 (unsafeCoerce# p1) )
else commuteFP f1 (p1 :< p2)
commuteFiledir (DP d1 p1 :< DP d2 p2) =
if (not $ isInDirectory d1 d2) && (not $ isInDirectory d2 d1) &&
d1 /= d2
then Succeeded ( DP d2 (unsafeCoerce# p2) :< DP d1 (unsafeCoerce# p1) )
else Failed
commuteFiledir (DP d dp :< FP f fp) =
if not $ isInDirectory d f
then Succeeded (FP f (unsafeCoerce# fp) :< DP d (unsafeCoerce# dp))
else Failed
commuteFiledir (Move d d' :< FP f2 p2)
| f2 == d' = Failed
| (p2 == AddFile || p2 == RmFile) && d == f2 = Failed
| otherwise = Succeeded (FP (movedirfilename d d' f2) (unsafeCoerce# p2) :< Move d d')
commuteFiledir (Move d d' :< DP d2 p2)
| isSuperdir d2 d' || isSuperdir d2 d = Failed
| (p2 == AddDir || p2 == RmDir) && d == d2 = Failed
| d2 == d' = Failed
| otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerce# p2) :< Move d d')
commuteFiledir (Move d d' :< Move f f')
| f == d' || f' == d = Failed
| f == d || f' == d' = Failed
| d `isSuperdir` f && f' `isSuperdir` d' = Failed
| otherwise =
Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :<
Move (movedirfilename f' f d) (movedirfilename f' f d'))
commuteFiledir _ = Unknown
type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y))
subcommutes :: [(String, (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y)))]
subcommutes =
[("speedyCommute", speedyCommute),
("commuteFiledir", cleverCommute commuteFiledir),
("commuteFilepatches", cleverCommute commuteFilepatches),
("commutex", toPerhaps . toRevCommute commute)
]
elegantMerge :: (Prim :\/: Prim) C(x y)
-> Maybe ((Prim :/\: Prim) C(x y))
elegantMerge (p1 :\/: p2) =
do p1':>ip2' <- commute (invert p2 :> p1)
p1o:>_ <- commute (p2 :> p1')
IsEq <- return $ p1o =\/= p1
return (invert ip2' :/\: p1')
\end{code}
It can sometimes be handy to have a canonical representation of a given
patch. We achieve this by defining a canonical form for each patch type,
and a function ``{\tt canonize}'' which takes a patch and puts it into
canonical form. This routine is used by the diff function to create an
optimal patch (based on an LCS algorithm) from a simple hunk describing the
old and new version of a file.
\begin{code}
canonize :: Prim C(x y) -> FL Prim C(x y)
canonize (Split ps) = sortCoalesceFL ps
canonize p | IsEq <- isIdentity p = NilFL
canonize (FP f (Hunk line old new)) = canonizeHunk f line old new
canonize p = p :>: NilFL
\end{code}
A simpler, faster (and more generally useful) cousin of canonize is the
coalescing function. This takes two sequential patches, and tries to turn
them into one patch. This function is used to deal with ``split'' patches,
which are created when the commutation of a primitive patch can only be
represented by a composite patch. In this case the resulting composite
patch must return to the original primitive patch when the commutation is
reversed, which a split patch accomplishes by trying to coalesce its
contents each time it is commuted.
\begin{code}
coalesce :: (Prim :< Prim) C(x y) -> Maybe (Prim C(x y))
coalesce (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing
coalesce (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just null_patch
coalesce (FP f1 p1 :< FP _ p2) = coalesceFilePrim f1 (p1 :< p2)
coalesce (Identity :< p) = Just p
coalesce (p :< Identity) = Just p
coalesce (Split NilFL :< p) = Just p
coalesce (p :< Split NilFL) = Just p
coalesce (Move a b :< Move b' a') | a == a' = Just $ Move b' b
coalesce (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile
coalesce (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir
coalesce (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile
coalesce (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir
coalesce (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1
coalesce _ = Nothing
join :: (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))
join (x :> y) = coalesce (y :< x)
\end{code}
\subsection{File patches}
A file patch is a patch which only modifies a single
file. There are some rules which can be made about file patches in
general, which makes them a handy class.
For example, commutation of two filepatches is trivial if they modify
different files. If they happen to
modify the same file, we'll have to check whether or not they commutex.
\begin{code}
commuteFilepatches :: CommuteFunction
commuteFilepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2)
commuteFilepatches _ = Unknown
commuteFP :: FileName -> (FilePatchType :< FilePatchType) C(x y)
-> Perhaps ((Prim :< Prim) C(x y))
commuteFP f (Hunk line1 [] [] :< p2) =
seq f $ Succeeded (FP f (unsafeCoerceP p2) :< FP f (Hunk line1 [] []))
commuteFP f (p2 :< Hunk line1 [] []) =
seq f $ Succeeded (FP f (Hunk line1 [] []) :< FP f (unsafeCoerceP p2))
commuteFP f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = seq f $
toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :< Hunk line2 old2 new2)
commuteFP f (TokReplace t o n :< Hunk line2 old2 new2) = seq f $
case tryTokReplace t o n old2 of
Nothing -> Failed
Just old2' ->
case tryTokReplace t o n new2 of
Nothing -> Failed
Just new2' -> Succeeded (FP f (Hunk line2 old2' new2') :<
FP f (TokReplace t o n))
commuteFP f (TokReplace t o n :< TokReplace t2 o2 n2)
| seq f $ t /= t2 = Failed
| o == o2 = Failed
| n == o2 = Failed
| o == n2 = Failed
| n == n2 = Failed
| otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :<
FP f (TokReplace t o n))
commuteFP _ _ = Unknown
coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) C(x y)
-> Maybe (Prim C(x y))
coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2)
= coalesceHunk f line1 old1 new1 line2 old2 new2
coalesceFilePrim f (TokReplace _ _ _ :< AddFile) = Just $ FP f AddFile
coalesceFilePrim f (RmFile :< TokReplace _ _ _) = Just $ FP f RmFile
coalesceFilePrim f (TokReplace t1 o1 n1 :< TokReplace t2 o2 n2)
| t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1
coalesceFilePrim f (Binary m n :< Binary o m')
| m == m' = Just $ FP f $ Binary o n
coalesceFilePrim _ _ = Nothing
\end{code}
\subsection{Hunks}
The hunk is the simplest patch that has a commuting pattern in which the
commuted patches differ from the originals (rather than simple success or
failure). This makes commuting or merging two hunks a tad tedious.
\begin{code}
commuteHunk :: FileName -> (FilePatchType :< FilePatchType) C(x y)
-> Maybe ((Prim :< Prim) C(x y))
commuteHunk f (Hunk line2 old2 new2 :< Hunk line1 old1 new1)
| seq f $ line1 + lengthnew1 < line2 =
Just (FP f (Hunk line1 old1 new1) :<
FP f (Hunk (line2 lengthnew1 + lengthold1) old2 new2))
| line2 + lengthold2 < line1 =
Just (FP f (Hunk (line1+ lengthnew2 lengthold2) old1 new1) :<
FP f (Hunk line2 old2 new2))
| line1 + lengthnew1 == line2 &&
lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =
Just (FP f (Hunk line1 old1 new1) :<
FP f (Hunk (line2 lengthnew1 + lengthold1) old2 new2))
| line2 + lengthold2 == line1 &&
lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =
Just (FP f (Hunk (line1 + lengthnew2 lengthold2) old1 new1) :<
FP f (Hunk line2 old2 new2))
| otherwise = seq f Nothing
where lengthnew1 = length new1
lengthnew2 = length new2
lengthold1 = length old1
lengthold2 = length old2
commuteHunk _ _ = impossible
\end{code}
Hunks, of course, can be coalesced if they have any overlap. Note that
coalesce code doesn't check if the two patches are conflicting. If you are
coalescing two conflicting hunks, you've already got a bug somewhere.
\begin{code}
coalesceHunk :: FileName
-> Int -> [B.ByteString] -> [B.ByteString]
-> Int -> [B.ByteString] -> [B.ByteString]
-> Maybe (Prim C(x y))
coalesceHunk f line1 old1 new1 line2 old2 new2
| line1 == line2 && lengthold1 < lengthnew2 =
if take lengthold1 new2 /= old1
then Nothing
else case drop lengthold1 new2 of
extranew -> Just (FP f (Hunk line1 old2 (new1 ++ extranew)))
| line1 == line2 && lengthold1 > lengthnew2 =
if take lengthnew2 old1 /= new2
then Nothing
else case drop lengthnew2 old1 of
extraold -> Just (FP f (Hunk line1 (old2 ++ extraold) new1))
| line1 == line2 = if new2 == old1 then Just (FP f (Hunk line1 old2 new1))
else Nothing
| line1 < line2 && lengthold1 >= line2 line1 =
case take (line2 line1) old1 of
extra-> coalesceHunk f line1 old1 new1 line1 (extra ++ old2) (extra ++ new2)
| line1 > line2 && lengthnew2 >= line1 line2 =
case take (line1 line2) new2 of
extra-> coalesceHunk f line2 (extra ++ old1) (extra ++ new1) line2 old2 new2
| otherwise = Nothing
where lengthold1 = length old1
lengthnew2 = length new2
\end{code}
One of the most important pieces of code is the canonization of a hunk,
which is where the ``diff'' algorithm is performed. This algorithm begins
with chopping off the identical beginnings and endings of the old and new
hunks. This isn't strictly necessary, but is a good idea, since this
process is $O(n)$, while the primary diff algorithm is something
considerably more painful than that\ldots\ actually the head would be dealt
with all right, but with more space complexity. I think it's more
efficient to just chop the head and tail off first.
\begin{code}
canonizeHunk :: FileName -> Int
-> [B.ByteString] -> [B.ByteString] -> FL Prim C(x y)
canonizeHunk f line old new
| null old || null new
= FP f (Hunk line old new) :>: NilFL
canonizeHunk f line old new = makeHoley f line $ getChanges old new
makeHoley :: FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])]
-> FL Prim C(x y)
makeHoley f line changes =
unsafeMap_l2f (\ (l,o,n) -> FP f (Hunk (l+line) o n)) changes
tryTokReplace :: String -> String -> String
-> [B.ByteString] -> Maybe [B.ByteString]
tryTokReplace t o n mss =
mapM (fmap B.concat . tryTokInternal t (BC.pack o) (BC.pack n)) mss
tryTokInternal :: String -> B.ByteString -> B.ByteString
-> B.ByteString -> Maybe [B.ByteString]
tryTokInternal _ o n s | isNothing (substrPS o s) &&
isNothing (substrPS n s) = Just [s]
tryTokInternal t o n s =
case BC.break (regChars t) s of
(before,s') ->
case BC.break (not . regChars t) s' of
(tok,after) ->
case tryTokInternal t o n after of
Nothing -> Nothing
Just rest ->
if tok == o
then Just $ before : n : rest
else if tok == n
then Nothing
else Just $ before : tok : rest
modernizePrim :: Prim C(x y) -> FL Prim C(x y)
modernizePrim (Split ps) = concatFL $ mapFL_FL modernizePrim ps
modernizePrim p = p :>: NilFL
instance MyEq Prim where
unsafeCompare (Move a b) (Move c d) = a == c && b == d
unsafeCompare (DP d1 p1) (DP d2 p2)
= d1 == d2 && p1 `unsafeCompare` p2
unsafeCompare (FP f1 fp1) (FP f2 fp2)
= f1 == f2 && fp1 `unsafeCompare` fp2
unsafeCompare (Split ps1) (Split ps2)
= eqFL unsafeCompare ps1 ps2
unsafeCompare (ChangePref a1 b1 c1) (ChangePref a2 b2 c2)
= c1 == c2 && b1 == b2 && a1 == a2
unsafeCompare Identity Identity = True
unsafeCompare _ _ = False
mergeOrders :: Ordering -> Ordering -> Ordering
mergeOrders EQ x = x
mergeOrders LT _ = LT
mergeOrders GT _ = GT
comparePrim :: Prim C(x y) -> Prim C(w z) -> Ordering
comparePrim (Move a b) (Move c d) = compare (a, b) (c, d)
comparePrim (Move _ _) _ = LT
comparePrim _ (Move _ _) = GT
comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2)
comparePrim (DP _ _) _ = LT
comparePrim _ (DP _ _) = GT
comparePrim (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) $ unsafeCoerceP (f2, fp2)
comparePrim (FP _ _) _ = LT
comparePrim _ (FP _ _) = GT
comparePrim (Split ps1) (Split ps2) = compareFL comparePrim ps1 $ unsafeCoerceP ps2
comparePrim (Split _) _ = LT
comparePrim _ (Split _) = GT
comparePrim Identity Identity = EQ
comparePrim Identity _ = LT
comparePrim _ Identity = GT
comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2)
= compare (c1, b1, a1) (c2, b2, a2)
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
compareFL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Ordering)
-> FL a C(x y) -> FL a C(w z) -> Ordering
compareFL _ NilFL NilFL = EQ
compareFL _ NilFL _ = LT
compareFL _ _ NilFL = GT
compareFL f (x:>:xs) (y:>:ys) = f x y `mergeOrders` compareFL f xs ys
class FromPrim p where
fromPrim :: Prim C(x y) -> p C(x y)
class FromPrim p => ToFromPrim p where
toPrim :: p C(x y) -> Maybe (Prim C(x y))
class FromPrims p where
fromPrims :: FL Prim C(x y) -> p C(x y)
joinPatches :: FL p C(x y) -> p C(x y)
instance FromPrim Prim where
fromPrim = id
instance ToFromPrim Prim where
toPrim = Just . id
instance FromPrim p => FromPrims (FL p) where
fromPrims = mapFL_FL fromPrim
joinPatches = concatFL
instance FromPrim p => FromPrims (RL p) where
fromPrims = reverseFL . mapFL_FL fromPrim
joinPatches = concatRL . reverseFL
class (Invert p, Commute p, Effect p) => Conflict p where
listConflictedFiles :: p C(x y) -> [FilePath]
listConflictedFiles p =
nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p
resolveConflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]]
resolveConflicts _ = []
commuteNoConflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))
commuteNoConflicts (x:>y) =
do y':>x' <- commute (x:>y)
y'':>ix'' <- commute (invert x :> y')
IsEq <- return $ y'' =\/= y
IsEq <- return $ ix'' =\/= invert x'
return (y':>x')
conflictedEffect :: p C(x y) -> [IsConflictedPrim]
conflictedEffect x = case listConflictedFiles x of
[] -> mapFL (IsC Okay) $ effect x
_ -> mapFL (IsC Conflicted) $ effect x
isInconsistent :: p C(x y) -> Maybe Doc
isInconsistent _ = Nothing
instance Conflict p => Conflict (FL p) where
listConflictedFiles = nubsort . concat . mapFL listConflictedFiles
resolveConflicts NilFL = []
resolveConflicts x = resolveConflicts $ reverseFL x
commuteNoConflicts (NilFL :> x) = Just (x :> NilFL)
commuteNoConflicts (x :> NilFL) = Just (NilFL :> x)
commuteNoConflicts (xs :> ys) = do ys' :> rxs' <- commuteNoConflictsRLFL (reverseFL xs :> ys)
return $ ys' :> reverseRL rxs'
conflictedEffect = concat . mapFL conflictedEffect
isInconsistent = listToMaybe . catMaybes . mapFL isInconsistent
instance Conflict p => Conflict (RL p) where
listConflictedFiles = nubsort . concat . mapRL listConflictedFiles
resolveConflicts x = rcs x NilFL
where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL Prim C(w))]]
rcs NilRL _ = []
rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p =
case commuteNoConflictsFL (p:>passedby) of
Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby)
Nothing -> rcs ps (p:>:passedby)
rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby)
commuteNoConflicts (NilRL :> x) = Just (x :> NilRL)
commuteNoConflicts (x :> NilRL) = Just (NilRL :> x)
commuteNoConflicts (xs :> ys) = do ys' :> rxs' <- commuteNoConflictsRLFL (xs :> reverseRL ys)
return $ reverseFL ys' :> rxs'
conflictedEffect = concat . reverse . mapRL conflictedEffect
isInconsistent = listToMaybe . catMaybes . mapRL isInconsistent
data IsConflictedPrim where
IsC :: !ConflictState -> !(Prim C(x y)) -> IsConflictedPrim
data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read)
class Effect p where
effect :: p C(x y) -> FL Prim C(x y)
effect = reverseRL . effectRL
effectRL :: p C(x y) -> RL Prim C(x y)
effectRL = reverseFL . effect
isHunk :: p C(x y) -> Maybe (Prim C(x y))
isHunk _ = Nothing
instance Effect Prim where
effect p | IsEq <- sloppyIdentity p = NilFL
| otherwise = p :>: NilFL
effectRL p | IsEq <- sloppyIdentity p = NilRL
| otherwise = p :<: NilRL
isHunk p = if primIsHunk p then Just p else Nothing
instance Conflict Prim
instance Effect p => Effect (FL p) where
effect p = concatFL $ mapFL_FL effect p
effectRL p = concatRL $ mapRL_RL effectRL $ reverseFL p
instance Effect p => Effect (RL p) where
effect p = concatFL $ mapFL_FL effect $ reverseRL p
effectRL p = concatRL $ mapRL_RL effectRL p
commuteNoConflictsFL :: Conflict p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))
commuteNoConflictsFL (p :> NilFL) = Just (NilFL :> p)
commuteNoConflictsFL (q :> p :>: ps) = do p' :> q' <- commuteNoConflicts (q :> p)
ps' :> q'' <- commuteNoConflictsFL (q' :> ps)
return (p' :>: ps' :> q'')
commuteNoConflictsRL :: Conflict p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))
commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL)
commuteNoConflictsRL (p :<: ps :> q) = do q' :> p' <- commuteNoConflicts (p :> q)
q'' :> ps' <- commuteNoConflictsRL (ps :> q')
return (q'' :> p' :<: ps')
commuteNoConflictsRLFL :: Conflict p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))
commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL)
commuteNoConflictsRLFL (xs :> NilFL) = Just (NilFL :> xs)
commuteNoConflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteNoConflictsRL (xs :> y)
ys' :> xs'' <- commuteNoConflictsRLFL (xs' :> ys)
return (y' :>: ys' :> xs'')
\end{code}