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')

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

-- | '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)

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

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

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 :: 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'')