module Darcs.Patch.Prim.V1.Coalesce
()
where
import Prelude hiding ( pi )
import Data.Map ( elems, fromListWith, mapWithKey )
import qualified Data.ByteString as B (ByteString)
import Darcs.Patch.FileName ( FileName, fp2fn )
import Darcs.Patch.Prim.Class ( PrimCanonize(..) )
import Darcs.Patch.Prim.V1.Commute ()
import Darcs.Patch.Prim.V1.Core
( Prim(..), FilePatchType(..), DirPatchType(..)
, comparePrim, isIdentity
)
import Darcs.Patch.Prim.V1.Show ()
import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:<)(..)
, reverseRL, mapFL, mapFL_FL
, concatFL, lengthFL, (+>+) )
import Darcs.Witnesses.Sealed ( unseal, Sealed2(..), unsafeUnseal2
, Gap(..), unFreeLeft
)
import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Commute ( Commute(..) )
import Lcs ( getChanges )
#include "gadts.h"
#include "impossible.h"
coalesce :: (Prim :< Prim) C(x y) -> Maybe (FL Prim C(x y))
coalesce (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing
coalesce (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just NilFL
coalesce (FP f1 p1 :< FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :< p2)
coalesce (Move a b :< Move b' a') | a == a' = Just $ Move b' b :>: NilFL
coalesce (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile :>: NilFL
coalesce (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir :>: NilFL
coalesce (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile :>: NilFL
coalesce (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir :>: NilFL
coalesce (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 :>: NilFL
coalesce _ = Nothing
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 (y:ys) = unsafeUnseal2 y :>: unsealList ys
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 (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
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' +>+ ps)
Nothing -> case commute (p :> p1) of
Nothing -> Nothing
Just (p1' :> p') -> tryOne (p1':<:sofar) p' ps
sortCoalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y)
sortCoalesceFL2 NilFL = NilFL
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' :>: NilFL) -> Right $ either id id $ pushCoalescePatch new' ps'
Just NilFL -> Right ps'
Just _ -> impossible
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)
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
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
canonizeHunk :: Gap w
=> FileName -> Int -> [B.ByteString] -> [B.ByteString]
-> w (FL Prim)
canonizeHunk f line old new
| null old || null new
= freeGap (FP f (Hunk line old new) :>: NilFL)
canonizeHunk f line old new = makeHoley f line $ getChanges old new
makeHoley :: Gap w
=> FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])]
-> w (FL Prim)
makeHoley f line changes =
foldr (joinGap (:>:)) (emptyGap NilFL) $
map (\ (l,o,n) -> freeGap (FP f (Hunk (l+line) o n))) changes
instance PrimCanonize Prim where
tryToShrink = mapPrimFL tryHarderToShrink
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
sortCoalesceFL = mapPrimFL sortCoalesceFL2
canonize p | IsEq <- isIdentity p = NilFL
canonize (FP f (Hunk line old new)) = unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk f line old new
canonize p = p :>: NilFL
canonizeFL = concatFL . mapFL_FL canonize . sortCoalesceFL .
concatFL . mapFL_FL canonize
join (x :> y) = coalesce (y :< x)