module Darcs.Patch.Prim.V1.Commute
( Perhaps(..)
, subcommutes, WrappedCommuteFunction(..)
)
where
import Prelude hiding ( pi )
import Control.Monad ( MonadPlus, msum, mzero, mplus )
import qualified Data.ByteString as B (ByteString, concat)
import qualified Data.ByteString.Char8 as BC (pack)
import Darcs.Patch.FileName ( FileName, fn2fp, movedirfilename )
import Darcs.Witnesses.Ordered ( (:<)(..) )
import Darcs.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Prim.V1.Core
( Prim(..), FilePatchType(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Commute ( Commute(..), toFwdCommute, toRevCommute )
import Darcs.Patch.Permutations ()
import Darcs.Patch.TokenReplace ( tryTokInternal )
#include "impossible.h"
#include "gadts.h"
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 (p2@(FP f' _) :< p1@(FP f _))
| f /= f' = Succeeded (unsafeCoerceP p1 :< unsafeCoerceP p2)
speedyCommute _other = Unknown
everythingElseCommute :: CommuteFunction
everythingElseCommute x = eec x
where
eec :: CommuteFunction
eec (ChangePref p f t :<p1) = Succeeded (unsafeCoerceP p1 :< ChangePref p f t)
eec (p2 :<ChangePref p f t) = Succeeded (ChangePref p f t :< unsafeCoerceP p2)
eec xx = cleverCommute commuteFiledir xx
instance Commute Prim where
commute x = toMaybe $ msum [toFwdCommute speedyCommute x,
toFwdCommute everythingElseCommute x
]
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 (unsafeCoerceP p2) :< FP f1 (unsafeCoerceP 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 (unsafeCoerceP p2) :< DP d1 (unsafeCoerceP p1) )
else Failed
commuteFiledir (DP d dp :< FP f fp) =
if not $ isInDirectory d f
then Succeeded (FP f (unsafeCoerceP fp) :< DP d (unsafeCoerceP 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) (unsafeCoerceP p2) :< Move d d')
commuteFiledir (Move d d' :< DP d2 p2)
| isSuperdir d2 d' || isSuperdir d2 d = Failed
| d == d2 = Failed
| d2 == d' = Failed
| otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerceP 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))
newtype WrappedCommuteFunction = WrappedCommuteFunction { runWrappedCommuteFunction :: CommuteFunction }
subcommutes :: [(String, WrappedCommuteFunction)]
subcommutes =
[("speedyCommute", WrappedCommuteFunction speedyCommute),
("commuteFiledir", WrappedCommuteFunction (cleverCommute commuteFiledir)),
("commuteFilepatches", WrappedCommuteFunction (cleverCommute commuteFilepatches)),
("commutex", WrappedCommuteFunction (toPerhaps . toRevCommute commute))
]
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
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
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