% 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,
DirPatchType(..), FilePatchType(..),
CommuteFunction, Perhaps(..),
null_patch, nullP, isNullPatch,
is_identity,
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,
try_tok_internal,
try_shrinking_inverse,
n_fn,
FromPrim(..), FromPrims(..), ToFromPrim(..),
Conflict(..), Effect(..), commute_no_conflictsFL, commute_no_conflictsRL
)
where
import Prelude hiding ( pi )
import Control.Monad ( MonadPlus, msum, mzero, mplus )
import Data.Maybe ( isNothing )
#ifndef GADT_WITNESSES
import Data.Map ( elems, fromListWith, mapWithKey )
#endif
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)
import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, norm_path,
movedirfilename, encode_white )
import Darcs.Witnesses.Ordered
import Darcs.Witnesses.Sealed ( Sealed, unseal )
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
is_identity :: Prim C(x y) -> EqCheck C(x y)
is_identity (FP _ (Binary old new)) | old == new = unsafeCoerce# IsEq
is_identity (FP _ (Hunk _ old new)) | old == new = unsafeCoerce# IsEq
is_identity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerce# IsEq
is_identity (Move old new) | old == new = unsafeCoerce# IsEq
is_identity Identity = IsEq
is_identity _ = 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 $ n_fn f) AddFile
rmfile f = FP (fp2fn $ n_fn f) RmFile
adddir d = DP (fp2fn $ n_fn d) AddDir
rmdir d = DP (fp2fn $ n_fn d) RmDir
move f f' = Move (fp2fn $ n_fn f) (fp2fn $ n_fn f')
changepref p f t = ChangePref p f t
hunk f line old new = evalargs FP (fp2fn $ n_fn f) (Hunk line old new)
tokreplace f tokchars old new =
evalargs FP (fp2fn $ n_fn f) (TokReplace tokchars old new)
binary f old new = FP (fp2fn $! n_fn f) $ Binary old new
n_fn :: FilePath -> FilePath
n_fn f = "./"++(fn2fp $ norm_path $ 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 > app_prec) $ showString "Move " .
showsPrec (app_prec + 1) fn1 . showString " " .
showsPrec (app_prec + 1) fn2
showsPrec d (DP fn dp) = showParen (d > app_prec) $ showString "DP " .
showsPrec (app_prec + 1) fn . showString " " .
showsPrec (app_prec + 1) dp
showsPrec d (FP fn fp) = showParen (d > app_prec) $ showString "FP " .
showsPrec (app_prec + 1) fn . showString " " .
showsPrec (app_prec + 1) fp
showsPrec d (Split l) = showParen (d > app_prec) $ showString "Split " .
showsPrec (app_prec + 1) l
showsPrec _ Identity = showString "Identity"
showsPrec d (ChangePref p f t) = showParen (d > app_prec) $ showString "ChangePref " .
showsPrec (app_prec + 1) p . showString " " .
showsPrec (app_prec + 1) f . showString " " .
showsPrec (app_prec + 1) t
instance Show2 Prim where
showsPrec2 = showsPrec
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 > app_prec) $ showString "Hunk " .
showsPrec (app_prec + 1) line . showString " " .
showsPrecC old . showString " " .
showsPrecC new
where showsPrecC [] = showString "[]"
showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (app_prec + 1) (map B.head ss)
showsPrec d (Hunk line old new) = showParen (d > app_prec) $ showString "Hunk " .
showsPrec (app_prec + 1) line . showString " " .
showsPrec (app_prec + 1) old . showString " " .
showsPrec (app_prec + 1) new
showsPrec d (TokReplace t old new) = showParen (d > app_prec) $ showString "TokReplace " .
showsPrec (app_prec + 1) t . showString " " .
showsPrec (app_prec + 1) old . showString " " .
showsPrec (app_prec + 1) new
showsPrec d (Binary old new) = showParen (d > app_prec) $ showString "Binary " .
showsPrec (app_prec + 1) old . showString " " .
showsPrec (app_prec + 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 . encode_white . 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 "{}"
\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 $ break_every 78 $ fromPS2Hex o)
$$ invisibleText "newhex"
$$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex n)
where makeprintable ps = invisibleText "*" <> invisiblePS ps
break_every :: Int -> B.ByteString -> [B.ByteString]
break_every n ps | B.length ps < n = [ps]
| otherwise = B.take n ps : break_every 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 ")"
commute_split :: CommuteFunction
commute_split (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')
commute_split _ = Unknown
tryToShrink :: FL Prim C(x y) -> FL Prim C(x y)
tryToShrink = mapPrimFL try_harder_to_shrink
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 =
#ifdef GADT_WITNESSES
f x
#else
case mapM toSimple $ mapFL id x of
Just sx -> foldr (+>+) NilFL $ elems $
mapWithKey (\ k p -> f (fromSimples k (p NilFL))) $
fromListWith (flip (.)) $
map (\ (a,b) -> (a,(b:>:))) sx
Nothing -> f x
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
#endif
try_harder_to_shrink :: FL Prim C(x y) -> FL Prim C(x y)
try_harder_to_shrink x = try_to_shrink2 $ maybe x id (try_shrinking_inverse x)
try_to_shrink2 :: FL Prim C(x y) -> FL Prim C(x y)
try_to_shrink2 psold =
let ps = sortCoalesceFL psold
ps_shrunk = shrink_a_bit ps
in
if lengthFL ps_shrunk < lengthFL ps
then try_to_shrink2 ps_shrunk
else ps_shrunk
try_shrinking_inverse :: FL Prim C(x y) -> Maybe (FL Prim C(x y))
try_shrinking_inverse (x:>:y:>:z)
| IsEq <- invert x =\/= y = Just z
| otherwise = case try_shrinking_inverse (y:>:z) of
Nothing -> Nothing
Just yz' -> Just $ case try_shrinking_inverse (x:>:yz') of
Nothing -> x:>:yz'
Just xyz' -> xyz'
try_shrinking_inverse _ = Nothing
shrink_a_bit :: FL Prim C(x y) -> FL Prim C(x y)
shrink_a_bit NilFL = NilFL
shrink_a_bit (p:>:ps) =
case try_one NilRL p ps of
Nothing -> p :>: shrink_a_bit ps
Just ps' -> ps'
try_one :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z)
-> Maybe (FL Prim C(w z))
try_one _ _ NilFL = Nothing
try_one 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') -> try_one (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 sort_coalesceFL2
sort_coalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y)
sort_coalesceFL2 NilFL = NilFL
sort_coalesceFL2 (x:>:xs) | IsEq <- nullP x = sort_coalesceFL2 xs
sort_coalesceFL2 (x:>:xs) | IsEq <- is_identity x = sort_coalesceFL2 xs
sort_coalesceFL2 (x:>:xs) = either id id $ push_coalesce_patch x $ sort_coalesceFL2 xs
push_coalesce_patch :: Prim C(x y) -> FL Prim C(y z)
-> Either (FL Prim C(x z)) (FL Prim C(x z))
push_coalesce_patch new NilFL = Left (new:>:NilFL)
push_coalesce_patch new ps@(p:>:ps')
= case coalesce (p :< new) of
Just new' | IsEq <- nullP new' -> Right ps'
| otherwise -> Right $ either id id $ push_coalesce_patch new' ps'
Nothing -> if comparePrim new p == LT then Left (new:>:ps)
else case commute (new :> p) of
Just (p' :> new') ->
case push_coalesce_patch new' ps' of
Right r -> Right $ either id id $
push_coalesce_patch p' r
Left r -> Left (p' :>: r)
Nothing -> Left (new:>:ps)
is_in_directory :: FileName -> FileName -> Bool
is_in_directory 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
clever_commute :: CommuteFunction -> CommuteFunction
clever_commute 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
speedy_commute :: CommuteFunction
speedy_commute (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
everything_else_commute :: CommuteFunction
everything_else_commute 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 [
clever_commute commute_filedir xx
,clever_commute commute_split 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 speedy_commute x,
toFwdCommute everything_else_commute 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
is_superdir :: FileName -> FileName -> Bool
is_superdir d1 d2 = isd (fn2fp d1) (fn2fp d2)
where isd s1 s2 =
length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/"
commute_filedir :: CommuteFunction
commute_filedir (FP f1 p1 :< FP f2 p2) =
if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerce# p2) :< FP f1 (unsafeCoerce# p1) )
else commuteFP f1 (p1 :< p2)
commute_filedir (DP d1 p1 :< DP d2 p2) =
if (not $ is_in_directory d1 d2) && (not $ is_in_directory d2 d1) &&
d1 /= d2
then Succeeded ( DP d2 (unsafeCoerce# p2) :< DP d1 (unsafeCoerce# p1) )
else Failed
commute_filedir (DP d dp :< FP f fp) =
if not $ is_in_directory d f
then Succeeded (FP f (unsafeCoerce# fp) :< DP d (unsafeCoerce# dp))
else Failed
commute_filedir (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')
commute_filedir (Move d d' :< DP d2 p2)
| is_superdir d2 d' || is_superdir 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')
commute_filedir (Move d d' :< Move f f')
| f == d' || f' == d = Failed
| f == d || f' == d' = Failed
| d `is_superdir` f && f' `is_superdir` d' = Failed
| otherwise =
Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :<
Move (movedirfilename f' f d) (movedirfilename f' f d'))
commute_filedir _ = Unknown
type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y))
subcommutes :: [(String, CommuteFunction)]
subcommutes =
[("speedy_commute", speedy_commute),
("commute_filedir", clever_commute commute_filedir),
("commute_filepatches", clever_commute commute_filepatches),
("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 <- is_identity 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}
commute_filepatches :: CommuteFunction
commute_filepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2)
commute_filepatches _ = 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 try_tok_replace t o n old2 of
Nothing -> Failed
Just old2' ->
case try_tok_replace 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 = make_holey f line $ getChanges old new
make_holey :: FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])]
-> FL Prim C(x y)
make_holey f line changes =
unsafeMap_l2f (\ (l,o,n) -> FP f (Hunk (l+line) o n)) changes
try_tok_replace :: String -> String -> String
-> [B.ByteString] -> Maybe [B.ByteString]
try_tok_replace t o n mss =
mapM (fmap B.concat . try_tok_internal t (BC.pack o) (BC.pack n)) mss
try_tok_internal :: String -> B.ByteString -> B.ByteString
-> B.ByteString -> Maybe [B.ByteString]
try_tok_internal _ o n s | isNothing (substrPS o s) &&
isNothing (substrPS n s) = Just [s]
try_tok_internal t o n s =
case BC.break (regChars t) s of
(before,s') ->
case BC.break (not . regChars t) s' of
(tok,after) ->
case try_tok_internal 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)
= eq_FL unsafeCompare ps1 ps2
unsafeCompare (ChangePref a1 b1 c1) (ChangePref a2 b2 c2)
= c1 == c2 && b1 == b2 && a1 == a2
unsafeCompare Identity Identity = True
unsafeCompare _ _ = False
merge_orders :: Ordering -> Ordering -> Ordering
merge_orders EQ x = x
merge_orders LT _ = LT
merge_orders 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) = compare_FL 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)
eq_FL :: (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
eq_FL _ NilFL NilFL = True
eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys
eq_FL _ _ _ = False
compare_FL :: (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
compare_FL _ NilFL NilFL = EQ
compare_FL _ NilFL _ = LT
compare_FL _ _ NilFL = GT
compare_FL f (x:>:xs) (y:>:ys) = f x y `merge_orders` compare_FL 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 _ = []
commute_no_conflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))
commute_no_conflicts (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
instance Conflict p => Conflict (FL p) where
listConflictedFiles = nubsort . concat . mapFL listConflictedFiles
resolveConflicts NilFL = []
resolveConflicts x = resolveConflicts $ reverseFL x
commute_no_conflicts (NilFL :> x) = Just (x :> NilFL)
commute_no_conflicts (x :> NilFL) = Just (NilFL :> x)
commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (reverseFL xs :> ys)
return $ ys' :> reverseRL rxs'
conflictedEffect = concat . mapFL conflictedEffect
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 commute_no_conflictsFL (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)
commute_no_conflicts (NilRL :> x) = Just (x :> NilRL)
commute_no_conflicts (x :> NilRL) = Just (NilRL :> x)
commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (xs :> reverseRL ys)
return $ reverseFL ys' :> rxs'
conflictedEffect = concat . reverse . mapRL conflictedEffect
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
commute_no_conflictsFL :: Conflict p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))
commute_no_conflictsFL (p :> NilFL) = Just (NilFL :> p)
commute_no_conflictsFL (q :> p :>: ps) = do p' :> q' <- commute_no_conflicts (q :> p)
ps' :> q'' <- commute_no_conflictsFL (q' :> ps)
return (p' :>: ps' :> q'')
commute_no_conflictsRL :: Conflict p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))
commute_no_conflictsRL (NilRL :> p) = Just (p :> NilRL)
commute_no_conflictsRL (p :<: ps :> q) = do q' :> p' <- commute_no_conflicts (p :> q)
q'' :> ps' <- commute_no_conflictsRL (ps :> q')
return (q'' :> p' :<: ps')
commute_no_conflictsRLFL :: Conflict p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))
commute_no_conflictsRLFL (NilRL :> ys) = Just (ys :> NilRL)
commute_no_conflictsRLFL (xs :> NilFL) = Just (NilFL :> xs)
commute_no_conflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commute_no_conflictsRL (xs :> y)
ys' :> xs'' <- commute_no_conflictsRLFL (xs' :> ys)
return (y' :>: ys' :> xs'')
\end{code}