%  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}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{-# LANGUAGE CPP #-}
-- , MagicHash, TypeOperators, GADTs, PatternGuards #-}

#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 () -- for Invert instance of FL
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

-- FIXME: The following code needs to be moved.

-- | Tells you if two patches are in the same category, human-wise.
-- Currently just returns true if they are filepatches on the same
-- file.
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
    -- this case may not work usefully
    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"

{-
instance Show (Prim C(x y))  where
    show p = renderString (showPrim p) ++ "\n"
-}

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}
(
  <put patches here> (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 =
-- an optimisation; break the list up into independent sublists
-- and apply f to each of them
     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 -- ordering is trickier with rmdir present
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' @ps@ puts a sequence of primitive patches into
-- canonical form. Even if the patches are just hunk patches,
-- this is not necessarily the same set of results as you would get
-- if you applied the sequence to a specific tree and recalculated
-- a diff.
--
-- Note that this process does not preserve the commutation behaviour
-- of the patches and is therefore not appropriate for use when
-- working with already recorded patches (unless doing amend-record
-- or the like).
canonizeFL :: FL Prim C(x y) -> FL Prim C(x y)
-- Running canonize twice is apparently necessary to fix issue525;
-- would be nice to understand why.
canonizeFL = concatFL . mapFL_FL canonize . sortCoalesceFL .
             concatFL . mapFL_FL canonize

-- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as
--   possible, sorting the results according to the scheme defined
--   in 'comparePrim'
sortCoalesceFL :: FL Prim C(x y) -> FL Prim C(x y)
sortCoalesceFL = mapPrimFL sortCoalesceFL2

-- | The heart of "sortCoalesceFL"
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' @new ps@ is almost like @new :>: ps@ except
--   as an alternative to consing, we first try to coalesce @new@ with
--   the head of @ps@.  If this fails, we try again, using commutation
--   to push @new@ down the list until we find a place where either
--   (a) @new@ is @LT@ the next member of the list [see 'comparePrim']
--   (b) commutation fails or
--   (c) coalescing succeeds.
--   The basic principle is to coalesce if we can and cons otherwise.
--
--   As an additional optimization, pushCoalescePatch outputs a Left
--   value if it wasn't able to shrink the patch sequence at all, and
--   a Right value if it was indeed able to shrink the patch sequence.
--   This avoids the O(N) calls to lengthFL that were in the older
--   code.
--
--   Also note that pushCoalescePatch is only ever used (and should
--   only ever be used) as an internal function in in
--   sortCoalesceFL2.
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 -- Count directory itself as being in directory...
          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
--cleverCommute c (p1,p2) = c (p1,p2) `mplus`
--    (case c (invert p2,invert p1) of
--     Succeeded (p1', p2') -> Succeeded (invert p2', invert p1')
--     Failed -> Failed
--     Unknown -> Unknown)

speedyCommute :: CommuteFunction
speedyCommute (p1 :< p2) -- Deal with common case quickly!
    | 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
             ]

{-
Note that it must be true that

commutex (A^-1 A, P) = Just (P, A'^-1 A')

and

if commutex (A, B) == Just (B', A')
then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1)
-}

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
                               ]
    -- Recurse on everything, these are potentially spoofed patches
    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)
       -- The following should be a redundant check
       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' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single
--   patch without intermediary changes.  For example, two hunk patches
--   modifying adjacent lines can be coalesced into a bigger hunk patch.
--   Or a patch which moves file A to file B can be coalesced with a
--   patch that moves file B into file C, yielding a patch that moves
--   file A to file C.
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) -- f1 = f2
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
-- Token replace patches operating right after (or before) AddFile (RmFile)
-- is an identity patch, as far as coalescing is concerned.
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' @p1 p2@ is used to provide an arbitrary ordering between
--   @p1@ and @p2@.  Basically, identical patches are equal and
--   @Move < DP < FP < Split < Identity < ChangePref@.
--   Everything else is compared in dictionary order of its arguments.
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 _ = []
    -- | If 'commuteNoConflicts' @x :> y@ succeeds, we know that that @x@ commutes
    --   past @y@ without any conflicts.   This function is useful for patch types
    --   for which 'commute' is defined to always succeed; so we need some way to
    --   pick out the specific cases where commutation succeeds without any conflicts.
    --
    --   Consider the commute square with patch names written in capital letters and
    --   repository states written in small letters.
    --
    --   @
    --          X
    --       o-->--a
    --       |     |
    --    Y' v     v Y
    --       |     |
    --       z-->--b
    --          X'
    --   @
    --
    --   The default definition of this function checks that we can mirror the
    --   commutation with patch inverses (written with the negative sign)
    --
    --   @
    --         -X     X
    --       a-->--o-->--a
    --       |     |     |
    --   Y'' v  Y' v     v Y
    --       |     |     |
    --       b-->--z-->--b
    --         (-X)'  X'
    --   @
    --
    --
    --   We check that commuting @X@ and @Y@ succeeds, as does commuting @-X@ and @Y'@.
    --   It also checks that @Y'' == Y@ and that @-(X')@ is the same as @(-X)'@
    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)

-- | Patches whose concrete effect which can be expressed as a list of
--   primitive patches.
--
--   A minimal definition would be either of @effect@ or @effectRL@.
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}