    -- Copyright (C) 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.

    {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
    {-# LANGUAGE CPP #-}
    -- , TypeOperators, GADTs, PatternGuards #-}

    #include "gadts.h"

    -- | Conflictor patches
    module Darcs.Patch.Real
           ( RealPatch(..), prim2real, is_consistent, is_forward, is_duplicate,
             pullCommon, mergeUnravelled ) where

    import Control.Monad ( mplus, liftM )
    import Data.List ( partition, nub )
    import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Conflict(..), Effect(..),
                              showPrim, FileNameFormat(NewFormat),
                              IsConflictedPrim(..), ConflictState(..) )
    import Darcs.Patch.Read ( readPrim )
    import Darcs.Patch.Patchy
    import Darcs.Witnesses.Ordered
    --import Darcs.Patch.Read ()
    --import Darcs.Patch.Viewing ()
    --import Darcs.Patch.Apply ()
    import Darcs.Patch.Commute ( mangle_unravelled )
    import Darcs.Patch.Non ( Non(..), Nonable(..), unNon,
                             showNons, showNon, readNons, readNon,
                             add, addP, addPs, remP, remPs, remNons,
                             (*>), (>*), (*>>), (>>*) )
    import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL,
                                      genCommuteWhatWeCanRL,
                                      removeRL, removeFL, remove_subsequenceFL )
    import qualified Data.ByteString.Char8 as BC ( ByteString, unpack )
    import Darcs.Patch.ReadMonads ( work, peek_input, my_lex )
    import Darcs.Utils ( nubsort )
    import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal )
    import Darcs.Witnesses.Show
    import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) )
    import Darcs.ColorPrinter ( errorDoc, assertDoc )
    --import Printer ( greenText )
    --import Darcs.ColorPrinter ( traceDoc )
    #include "impossible.h"

    -- |
    -- @Duplicate x@: This patch has no effect since @x@ is already present in the repository
    --
    -- @Etacilpud x: invert (Duplicate x)@
    --
    -- @Normal prim@: A primitive patch
    --
    -- @Conflictor ix xx x@:
    -- @ix@ is the set of patches:
    --
    --   * that conflict with @x@ and also conflict with another patch in the repository
    --
    --   * that conflict with a patch that conflict with @x@
    --
    -- @xx@ is the sequence of patches that conflict *only* with @x@
    --
    -- @x@ is the current patch
    --
    -- @ix@ and @x@ are stored as @Non@ objects, which include any necessary
    --  context to uniquely define the patch that is referred to.
    --
    -- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@
    data RealPatch C(x y) where
        Duplicate :: Non RealPatch C(x) -> RealPatch C(x x)
        Etacilpud :: Non RealPatch C(x) -> RealPatch C(x x)
        Normal :: Prim C(x y) -> RealPatch C(x y)
        Conflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(y x)
        InvConflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(x y)

    -- | 'is_duplicate' @p@ is ' @True@ if @p@ is either a  'Duplicate' or 'Etacilpud' patch
    is_duplicate :: RealPatch C(s y) -> Bool
    is_duplicate (Duplicate _) = True
    is_duplicate (Etacilpud _) = True
    is_duplicate _ = False

    -- | This is only used for unit testing
    is_forward :: RealPatch C(s y) -> Maybe Doc
    is_forward p@(InvConflictor _ _ _) =
        Just $ redText "An inverse conflictor" $$ showPatch p
    is_forward p@(Etacilpud _) =
        Just $ redText "An inverse duplicate" $$ showPatch p
    is_forward _ = Nothing

    mergeUnravelled :: [Sealed ((FL Prim) C(x))] -> Maybe (FlippedSeal RealPatch C(x))
    mergeUnravelled [] = Nothing
    mergeUnravelled [_] = Nothing
    mergeUnravelled ws = case mergeUnravelled_private ws of
                         Nothing -> Nothing
                         Just NilRL -> bug "found no patches in mergeUnravelled"
                         Just (z:<:_) -> Just $ FlippedSeal z
        where notNullS :: Sealed ((FL Prim) C(x)) -> Bool
              notNullS (Sealed NilFL) = False
              notNullS _ = True
              mergeUnravelled_private :: [Sealed (FL Prim C(x))] -> Maybe (RL RealPatch C(x x))
              mergeUnravelled_private xs = reverseFL `fmap` mergeConflictingNons
                                                            (map sealed2non $ filter notNullS xs)

    -- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'.
    --   @xs@ must be non-empty since we split this list at the last patch
    sealed2non :: Sealed ((FL Prim) C(x)) -> Non RealPatch C(x)
    sealed2non (Sealed xs) = case reverseFL xs of
                             y:<:ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y
                             NilRL -> bug "NilFL encountered in sealed2non"

    mergeConflictingNons :: [Non RealPatch C(x)] -> Maybe (FL RealPatch C(x x))
    mergeConflictingNons ns = mcn $ map unNon ns
        where mcn :: [Sealed (FL RealPatch C(x))] -> Maybe (FL RealPatch C(x x))
              mcn [] = Just NilFL
              mcn [Sealed p] = case join_effects p of -- this is just a safety check, and could
                               NilFL -> Just p                 -- be removed when we're sure of the code.
                               _ -> Nothing
              mcn (Sealed p1:Sealed p2:zs) = case pullCommon p1 p2 of
                                             Common c ps qs ->
                                                 case merge (ps :\/: qs) of
                                                 qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs)

    join_effects :: Effect p => p C(x y) -> FL Prim C(x y)
    join_effects = join_inverses . effect
        where join_inverses :: FL Prim C(x y) -> FL Prim C(x y)
              join_inverses NilFL = NilFL
              join_inverses (p:>:ps) = case removeFL (invert p) ps' of
                                       Just ps'' -> ps''
                                       Nothing -> p :>: ps'
                  where ps' = join_inverses ps

    assertConsistent :: RealPatch C(x y) -> RealPatch C(x y)
    assertConsistent x = assertDoc (do e <- is_consistent x
                                       Just (redText "Inconsistent patch:" $$ showPatch x $$ e)) x

    -- | @mergeAfterConflicting@ takes as input a sequence of conflicting
    -- patches @xxx@ (which therefore have no effect) and a sequence of
    -- primitive patches @yyy@ that follow said sequence of conflicting
    -- patches, and may depend upon some of the conflicting patches (as a
    -- resolution).

    -- The output is two sequences of patches the first consisting of a
    -- set of mutually-conflicting patches, and the second having the same
    -- effect as the original primitive patch sequence in the input.

    -- So far as I can tell, the second output is always identical to
    -- @mapFL Normal yyy@

    -- The first output is the set of patches from @xxx@ that are depended
    -- upon by @yyy@.

    mergeAfterConflicting :: FL RealPatch C(x x) -> FL Prim C(x y)
                          -> Maybe (FL RealPatch C(x x), FL RealPatch C(x y))
    mergeAfterConflicting xxx yyy = --traceDoc (greenText "mergeAfterConflicting xxx" $$ showPatch xxx $$
                                    --          greenText "and yyy" $$ showPatch yyy) $
                                    mac (reverseFL xxx) yyy NilFL
        where mac :: RL RealPatch C(x y) -> FL Prim C(y z) -> FL RealPatch C(z a)
                  -> Maybe (FL RealPatch C(x x), FL RealPatch C(x a))
              mac NilRL xs goneby = case join_effects goneby of
                                    NilFL -> Just (NilFL, mapFL_FL Normal xs)
                                    _z -> --traceDoc (greenText "mac1 z" $$ showPatch _z) $
                                          Nothing
              mac (p:<:ps) xs goneby = --traceDoc (greenText "mac ps" $$ showPatch ps $$
                                       --          greenText "p" $$ showPatch p $$
                                       --          greenText "xs" $$ showPatch xs $$
                                       --          greenText "goneby" $$ showPatch goneby) $
                                       case commuteFL (p :> mapFL_FL Normal xs) of
                                       Left _  -> case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of
                                                  a:>p':>b ->
                                                      do (b',xs') <- mac b xs goneby
                                                         let pa = join_effects $ p':<:a
                                                         --traceDoc (greenText "foo1" $$
                                                         --          showPatch pa) $ Just ()
                                                         NilFL <- return pa
                                                         return (reverseRL (p':<:a)+>+b', xs')
                                                       `mplus` do NilFL <- return goneby
                                                                  NilFL <- return $ join_effects (p:<:ps)
                                                                  return (reverseRL (p:<:ps),
                                                                          mapFL_FL Normal xs)
                                       Right (l:>p'') ->
                                           case allNormal l of
                                           Just xs'' -> mac ps xs'' (p'':>:goneby)
                                           Nothing ->
                                                  case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of
                                                  a:>p':>b ->
                                                      do (b',xs') <- mac b xs goneby
                                                         let pa = join_effects $ p':<:a
                                                         --traceDoc (greenText "foo2" $$
                                                         --          showPatch pa) $ Just ()
                                                         NilFL <- return pa
                                                         return $ (reverseRL (p':<:a)+>+b', xs')

    geteff :: [Non RealPatch C(x)] -> FL Prim C(x y) -> ([Non RealPatch C(x)], FL RealPatch C(x y))
    geteff _ NilFL = ([],NilFL)
    geteff ix (x:>:xs) | Just ix' <- mapM (remP (Normal x)) ix
                                   = --traceDoc (greenText "I got rid of x" $$ showPatch x) $
                                     case geteff ix' xs of
                                     (ns,xs') -> (non (Normal x) : map (addP (Normal x)) ns,
                                                  Normal x :>: xs')
    geteff ix xx = case mergeConflictingNons ix of
                   Nothing -> errorDoc $ redText "mergeConflictingNons failed in geteff with ix" $$
                              showNons ix $$ redText "xx" $$ showPatch xx
                   Just rix -> case mergeAfterConflicting rix xx of
                               Just (a,x) -> (map (addPs (reverseFL a)) $ toNons x,
                                              a +>+ x)
                               Nothing -> errorDoc $ redText "mergeAfterConflicting failed in geteff"$$
                                          redText "where ix" $$ showNons ix $$
                                          redText "and xx" $$ showPatch xx $$
                                          redText "and rix" $$ showPatch rix

    xx2nons :: [Non RealPatch C(x)] -> FL Prim C(x y) -> [Non RealPatch C(x)]
    xx2nons ix xx = fst $ geteff ix xx

    xx2patches :: [Non RealPatch C(x)] -> FL Prim C(x y) -> FL RealPatch C(x y)
    xx2patches ix xx = snd $ geteff ix xx

    -- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns
    --   @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@).
    --   Otherwise, it returns 'Nothing'.
    allNormal :: FL RealPatch C(x y) -> Maybe (FL Prim C(x y))
    allNormal (Normal x:>:xs) = (x :>:) `fmap` allNormal xs
    allNormal NilFL = Just NilFL
    allNormal _ = Nothing

    -- | This is used for unit-testing and for internal sanity checks
    is_consistent :: RealPatch C(x y) -> Maybe Doc
    is_consistent (Normal _) = Nothing
    is_consistent (Duplicate _) = Nothing
    is_consistent (Etacilpud _) = Nothing
    is_consistent (Conflictor im mm m@(Non deps _))
        | not $ everyone_conflicts im = Just $ redText "Someone doesn't conflict in im in is_consistent"
        | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in is_consistent"
        | any (\x -> any (x `conflicts_with`) nmm) im
            = Just $ redText "mm conflicts with im in is_consistent where nmm is" $$
                     showNons nmm
        | Nothing <- (nmm ++ im) `minus` toNons deps = Just $ redText "dependencies not in conflict:" $$
                                                       showNons (toNons deps) $$
                                                       redText "compared with deps itself:" $$
                                                       showPatch deps
        | otherwise = case all_conflicts_with m im of
                      (im1,[]) | im1 `eqSet` im -> Nothing
                      (_,imnc) -> Just $ redText "m doesn't conflict with im in is_consistent.  unconflicting:"
                                  $$ showNons imnc
        where (nmm, rmm) = geteff im mm
    is_consistent c@(InvConflictor _ _ _) = is_consistent (invert c)

    everyone_conflicts :: [Non RealPatch C(x)] -> Bool
    everyone_conflicts [] = True
    everyone_conflicts (x:xs) = case all_conflicts_with x xs of
                                ([],_) -> False
                                (_,xs') -> everyone_conflicts xs'

    prim2real :: Prim C(x y) -> RealPatch C(x y)
    prim2real = Normal

    instance Patchy RealPatch

    instance MyEq p => Eq (Sealed (p C(x))) where
        (Sealed x) == (Sealed y) | IsEq <- x =\/= y = True
                                 | otherwise = False

    merge_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x))
    merge_with p [] = effect `mapSeal` unNon p
    merge_with p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $
                      filter (\x -> not (p `depends_upon` x) && not (p `conflicts_with` x)) xs
        where mergeall :: [Sealed (FL RealPatch C(x))] -> Sealed (FL Prim C(x))
              mergeall [Sealed x] = Sealed $ effect x
              mergeall [] = Sealed NilFL
              mergeall (Sealed x:Sealed y:rest) = case merge (x :\/: y) of
                                                  y' :/\: _ -> mergeall (Sealed (x+>+y'):rest)
              unconflicting_of [] = []
              unconflicting_of (q:qs) = case all_conflicts_with q qs of
                                        ([],_) -> q:qs
                                        (_,nc) -> unconflicting_of nc

    instance Conflict RealPatch where
        conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x]
        conflictedEffect (Etacilpud _) = impossible
        conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]
        conflictedEffect (InvConflictor _ _ _) = impossible
        conflictedEffect (Normal x) = [IsC Okay x]
        resolveConflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled]
                where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx)
                      nonxx = nonxx_ (nonxx_aux ix xx)
                      nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y)
                      nonxx_aux a b = reverseFL $ xx2patches a b
                      nonxx_ :: RL RealPatch C(x y) -> [Non RealPatch C(x)]
                      nonxx_ NilRL = []
                      nonxx_ ((Normal q) :<: qs) = [Non (reverseRL qs) q]
                      nonxx_ _ = []
                      isn :: Sealed (FL p C(x)) -> Bool
                      isn (Sealed NilFL) = False
                      isn _ = True
        resolveConflicts _ = []

        -- cA
        commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x)
        commute_no_conflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x)
        commute_no_conflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x)
        commute_no_conflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x)
        -- cB
        commute_no_conflicts (x :> Duplicate d) = if d == addP (invert x) (non x)
                                                  then Just (x :> Duplicate d)
                                                  else do d' <- remP (invert x) d
                                                          return (Duplicate d' :> x)
        commute_no_conflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d'))
        commute_no_conflicts c@(Etacilpud _ :> _) = invertCommuteNC c
        commute_no_conflicts c@(_ :> Etacilpud _) = invertCommuteNC c
        -- cE
        commute_no_conflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y)
                                                         return (Normal y' :> Normal x')
        -- cF -- involves a conflict
        -- cG
        commute_no_conflicts (Normal x :> Conflictor iy yy y) =
            case commuteFL (x :> invert yy) of
            Right (iyy' :> x') -> do
               y':iy' <- mapM (Normal x' >*) (y:iy)
               return (Conflictor iy' (invert iyy') y' :> Normal x')
            _ -> Nothing
        -- cFi+cGi  -- handle with previous two pattern matches
        commute_no_conflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c
        -- icG FIXME: where is icF?
        commute_no_conflicts (Conflictor iy' yy' y' :> Normal x') =
            do x :> iyy <- commuteRL (invertFL yy' :> x')
               y:iy <- mapM (*> Normal x') (y':iy')
               return (Normal x :> Conflictor iy (invertRL iyy) y)
        -- icGi      -- handle with previous pattern match
        commute_no_conflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c
        -- cH -- this involves a conflict commute
        -- cI
        commute_no_conflicts (Conflictor ix xx x :> Conflictor iy yy y) =
            do xx' :> yy' <- commute (yy :> xx)
               x':ix' <- mapM (yy >>*) (x:ix)
               y':iy' <- mapM (*>> xx') (y:iy)
               False <- return $ any (conflicts_with y) (x':ix')
               False <- return $ any (conflicts_with x') iy
               return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')
        -- cHi+cIi            uses previous two matches
        commute_no_conflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c
        -- cJ
        commute_no_conflicts (InvConflictor ix xx x :> Conflictor iy yy y) =
            do iyy' :> xx' <- commute (xx :> invert yy)
               y':iy' <- mapM (xx' >>*) (y:iy)
               x':ix' <- mapM (invertFL iyy' >>*) (x:ix)
               False <- return $ any (conflicts_with y') (x':ix')
               False <- return $ any (conflicts_with x') iy'
               return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')
        -- icJ
        commute_no_conflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') =
            do xx :> iyy <- commute (invert yy' :> xx')
               y:iy <- mapM (*>> xx') (y':iy')
               x:ix <- mapM (*>> yy') (x':ix')
               False <- return $ any (conflicts_with y') (x':ix')
               False <- return $ any (conflicts_with x') iy'
               return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)

    instance FromPrim RealPatch where
        fromPrim = prim2real
    instance ToFromPrim RealPatch where
        toPrim (Normal p) = Just p
        toPrim _ = Nothing

    instance MyEq RealPatch where
        (Duplicate x) =\/= (Duplicate y) | x == y = IsEq
        (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq
        (Normal x) =\/= (Normal y) = x =\/= y
        (Conflictor cx xx x) =\/= (Conflictor cy yy y)
            | map (add $ invertFL xx) cx `eqSet`
              map (add $ invertFL yy) cy &&
              add (invert xx) x == add (invert yy) y = xx =/\= yy
        (InvConflictor cx xx x) =\/= (InvConflictor cy yy y)
            | cx `eqSet` cy && x == y = xx =\/= yy
        _ =\/= _ = NotEq

    eqSet :: Eq a => [a] -> [a] -> Bool
    eqSet [] [] = True
    eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys
    eqSet _ _ = False

    remove1 :: Eq a => a -> [a] -> Maybe [a]
    remove1 x (y:ys) | x == y = Just ys
                     | otherwise = (y :) `fmap` remove1 x ys
    remove1 _ [] = Nothing

    minus :: Eq a => [a] -> [a] -> Maybe [a]
    minus xs [] = Just xs
    minus xs (y:ys) = do xs' <- remove1 y xs
                         xs' `minus` ys

    invertNon :: Non RealPatch C(x) -> Non RealPatch C(x)
    invertNon (Non c x)
        | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x)
        | otherwise = addPs (Normal x :<: reverseFL c) $ non nix
        where nix = Normal $ invert x

    nonTouches :: Non RealPatch C(x) -> [FilePath]
    nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL)

    nonHunkMatches :: (BC.ByteString -> Bool) -> Non RealPatch C(x) -> Bool
    nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x

    toNons :: (Conflict p, Patchy p, ToFromPrim p, Nonable p) => FL p C(x y) -> [Non p C(x)]
    toNons xs = map lastNon $ initsFL xs
        where lastNon :: (Conflict p, Patchy p, Nonable p) => Sealed ((p :> FL p) C(x)) -> Non p C(x)
              lastNon (Sealed xxx) = case lastNon_aux xxx of
                                     deps :> p :> _ -> case non p of
                                                       Non NilFL pp -> Non (reverseRL deps) pp
                                                       Non ds pp -> errorDoc $ redText "Weird case in toNons" $$
                                                                    redText "please report this bug!" $$
                                                                    (case xxx of
                                                                     z:>zs -> showPatch (z:>:zs)) $$
                                                                    redText "ds are" $$ showPatch ds $$
                                                                    redText "pp is" $$ showPatch pp
              reverseFoo :: (p :> FL p) C(x y) -> (RL p :> p) C(x y)
              reverseFoo (p :> ps) = rf NilRL p ps
                  where rf :: RL p C(a b) -> p C(b c) -> FL p C(c d) -> (RL p :> p) C(a d)
                        rf rs l NilFL = rs :> l
                        rf rs x (y:>:ys) = rf (x:<:rs) y ys
              lastNon_aux :: Commute p => (p :> FL p) C(x y) -> (RL p :> p :> RL p) C(x y)
              lastNon_aux = commuteWhatWeCanRL . reverseFoo

    initsFL :: Patchy p => FL p C(x y) -> [Sealed ((p :> FL p) C(x))]
    initsFL NilFL = []
    initsFL (x:>:xs) = Sealed (x:>NilFL) : map (\ (Sealed (y:>xs')) -> Sealed (x:>y:>:xs')) (initsFL xs)

    fromNons :: [Non RealPatch C(x)] -> Maybe (Sealed (FL Prim C(x)))
    fromNons [] = Just $ Sealed $ NilFL
    fromNons ns = do (Sealed p, ns') <- pullInContext ns
                     ns'' <- mapM (remP $ fromPrim p) ns'
                     Sealed ps <- fromNons ns''
                     return $ Sealed $ p :>: ps

    pullInContext :: [Non RealPatch C(x)] -> Maybe (Sealed (Prim C(x)), [Non RealPatch C(x)])
    pullInContext (Non NilFL p:ns) = Just (Sealed p, ns)
    pullInContext (n:ns) = do (sp,ns') <- pullInContext ns
                              return (sp, n:ns')
    pullInContext [] = Nothing

    filterConflictsFL :: Non RealPatch C(x) -> FL Prim C(x y) -> (FL Prim :> FL Prim) C(x y)
    filterConflictsFL _ NilFL = NilFL :> NilFL
    filterConflictsFL n (p:>:ps)
        | Just n' <- remP (fromPrim p) n = case filterConflictsFL n' ps of
                                           p1 :> p2 -> p:>:p1 :> p2
        | otherwise = case commuteWhatWeCanFL (p :> ps) of
                      p1 :> p' :> p2 -> case filterConflictsFL n p1 of
                                        p1a :> p1b -> p1a :> p1b +>+ p' :>: p2

    instance Invert RealPatch where
        invert (Duplicate d) = Etacilpud d
        invert (Etacilpud d) = Duplicate d
        invert (Normal p) = Normal (invert p)
        invert (Conflictor x c p) = InvConflictor x c p
        invert (InvConflictor x c p) = Conflictor x c p
        identity = Normal identity

    instance Commute RealPatch where
    --    commute (x :> y) | traceDoc (greenText "commuting x" $$ showPatch x $$
    --                                 greenText "with y" $$ showPatch y) False = undefined
        commute (x :> y) | Just (y' :> x') <- commute_no_conflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x')
        -- cF
        commute (Normal x :> Conflictor a1'nop2 n1'x p1') -- these patches conflicted
            | Just rn1' <- removeRL x (reverseFL n1'x) =
                          do let p2:n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x:<:rn1')
                                 a2 = p1':a1'nop2++n1nons
                             case (a1'nop2, reverseRL rn1', p1') of
                               ([], NilFL, Non c y) | NilFL <- join_effects c ->
                                        Just (Normal y :> Conflictor a1'nop2 (y:>:NilFL) p2)
                               (a1,n1,_) -> Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)
        -- cFi  -- handle with previous pattern match
        commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c
        -- cH
        commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)
            | Just a2_minus_p1 <- remove1 p1' a2,
              not (p2 `depends_upon` p1') =
                  do let n1nons = map (add n2) $ xx2nons a1 n1
                         n2nons = xx2nons a2 n2
                         Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons
                         n2n1 = n2 +>+ n1
                         a1' = map (add n2) a1
                         p2ooo = remNons a1' p2
                     n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1
                     let n1'n2'nons = xx2nons a2_minus_p1n1 (n1'+>+n2')
                         n1'nons = take (lengthFL n1') n1'n2'nons
                         n2'nons = drop (lengthFL n1') n1'n2'nons
                         Just a1'nop2 = (a2++n2nons) `minus` (p1':n1'nons)
                         Just a2'o = --traceDoc (greenText "\n\nConflictor a1 n1 p1 is" $$
                                     --          showPatch (assertConsistent $ Conflictor a1 n1 p1) $$
                                     --          greenText "and Conflictor a2 n2 p2 is" $$
                                     --          showPatch (assertConsistent $ Conflictor a2 n2 p2) $$
                                     --          greenText "where n2'nons is" $$ showNons n2'nons $$
                                     --          greenText "and others are" $$
                                     --          showNons (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) $$
                                     --          greenText "These came from" $$
                                     --          showNons (a2_minus_p1++n2nons) $$
                                     --          greenText "n1'n2'nons" $$ showNons n1'n2'nons $$
                                     --          greenText "from n1' :> n2'" $$
                                     --          showPatch n1' $$ greenText ":>" $$ showPatch n2' $$
                                     --          greenText "p2" $$ showNon p2 $$
                                     --          greenText "p2 fixed" $$ showNon p2ooo $$
                                     --          -- greenText "pren1" $$ showPatch pren1 $$
                                     --          greenText "n1'" $$ showPatch n1' $$
                                     --          greenText "p2" $$ showNon p2
                                     --         )
                                     (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) `minus` n2'nons
                         Just a2' = mapM (remPs (xx2patches a1'nop2 n1')) $
                                    a2'o
                         Just p2' = remPs (xx2patches a1'nop2 n1') p2
                     case (a2', n2', p2') of
                       ([], NilFL, Non c x) | NilFL <- join_effects c ->
                                              Just (Normal x :> Conflictor a1'nop2 (n1'+>+x:>:NilFL) p1')
                                            | otherwise -> impossible
                       _ -> Just (Conflictor a2' n2' p2' :> Conflictor (p2:a1'nop2) n1' p1')
            where (_,rpn2) = geteff a2 n2
                  p1' = addPs (reverseFL rpn2) p1
        -- cHi         -- uses previous match
        commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c
        commute _ = Nothing

        merge (InvConflictor _ _ _ :\/: _) = impossible
        merge (_ :\/: InvConflictor _ _ _) = impossible
        merge (Etacilpud _ :\/: _) = impossible
        merge (_ :\/: Etacilpud _) = impossible
    --    merge (x :\/: y) | traceDoc (greenText "merging x" $$ showPatch x $$
    --                                 greenText "with y" $$ showPatch y) False = impossible
        -- mA
        merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a
        -- mB
        merge (Duplicate a :\/: b) = b :/\: Duplicate (addP (invert b) a) -- FIXME ???
        -- smB
        merge m@(_ :\/: Duplicate _) = swapMerge m
        -- mC
    --    merge _ | traceDoc (greenText "about to look for conflictingness") False = impossible
        merge (x :\/: y) | Just (y' :> ix') <- commute (invert (assertConsistent x) :> assertConsistent y),
                           Just (y'' :> _) <- commute (x :> y'),
                           IsEq <- y'' =\/= y = --traceDoc (greenText "These didn't conflict") $
                                                assertConsistent y' :/\: invert (assertConsistent ix')
                         | IsEq <- x =\/= y,
                           n <- addP (invert x) $ non x =
                                     --traceDoc (greenText "Found duplicate") $
                                     Duplicate n :/\: Duplicate n
    --    merge (x :\/: y) | traceDoc (greenText "trying to merging x" $$ showPatch x $$
    --                                 greenText "which conflicts with y" $$ showPatch y) False = impossible
        -- mD
        merge (Normal x :\/: Normal y) =
            Conflictor [] (x:>:NilFL) (non $ Normal y) :/\: Conflictor [] (y:>:NilFL) (non $ Normal x)
        -- mG
        merge (Normal x :\/: Conflictor iy yy y) =
              --traceDoc (greenText "merging Normal x" $$ showPatch x $$
              --          greenText "and Conflictor iy yy y" $$ showPatch (Conflictor iy yy y)) $
              Conflictor iy yyx y :/\: Conflictor (y:iy++nyy) NilFL x'
                  where yyx = yy +>+ x:>:NilFL
                        (x':nyy) = reverse $ xx2nons iy yyx
        -- smE+smG
        merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m
    --    merge (x :\/: y) | traceDoc (greenText "still trying to merge x" $$ showPatch x $$
    --                                 greenText "with y" $$ showPatch y) False = impossible
        -- mH see also cH
        merge (Conflictor ix xx x :\/: Conflictor iy yy y) =
            case pullCommonRL (reverseFL xx) (reverseFL yy) of
            CommonRL rxx1 ryy1 c ->
                case commuteRLFL (ryy1 :> invertRL rxx1) of
                Just (ixx' :> ryy') ->
                    let xx' = invert ixx'
                        yy' = reverseRL ryy'
                        y':iy' = map (add $ invertFL ixx') (y:iy)
                        x':ix' = map (add ryy') (x:ix)
                        nyy' = xx2nons iy' yy'
                        nxx' = xx2nons ix' xx'
                        icx = drop (lengthRL rxx1) $ xx2nons ix (reverseRL $ c+<+rxx1)
                        ic' = map (add ryy') icx
                        ixy' = ic' ++ (iy'+++ix')
                        -- +++ above is a more efficient version of nub
                        -- (iy'++ix') given that we know each element shows up
                        -- only once in either list.
                    in --traceDoc (greenText "here I am! and so is ixy'" $$ showNons ixy' $$
                       --          greenText "and iy" $$ showNons iy $$ greenText (show $ length iy) $$
                       --          greenText "and ix" $$ showNons ix $$
                       --          greenText "and iy'" $$ showNons iy' $$
                       --          greenText "and ix'" $$ showNons ix' $$
                       --          greenText "and ic'" $$ showNons ic'
                       --         ) $
                    Conflictor (x':ixy'++nxx') yy' y' :/\: Conflictor (y':ixy'++nyy') xx' x'
                Nothing -> impossible pullInContext fromNons
    --    merge _ = error "haven't finished fixing merge"

        listTouchedFiles (Duplicate p) = nonTouches p
        listTouchedFiles (Etacilpud p) = nonTouches p
        listTouchedFiles (Normal p) = listTouchedFiles p
        listTouchedFiles (Conflictor x c p) =
            nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p
        listTouchedFiles (InvConflictor x c p) =
            nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p

        hunkMatches f (Duplicate p) = nonHunkMatches f p
        hunkMatches f (Etacilpud p) = nonHunkMatches f p
        hunkMatches f (Normal p) = hunkMatches f p
        hunkMatches f (Conflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]
        hunkMatches f (InvConflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]

    {-
    all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)]
                         -> ([Non RealPatch C(x)], [Non RealPatch C(x)])
    all_conflicts_withFL xx ns = case partition f ns of
                                 ([],nc) -> ([],nc)
                                 (c,nc) -> case acw c nc of
                                           (c',nc') -> (c++c',nc')
        where acw (y:ys) zs = case all_conflicts_with y zs of
                              (c,nc) -> case acw ys nc of
                                        (c',nc') -> (c++c',nc')
              acw [] zs = ([],zs)
              f (Non c p) = case commuteRLFL (invertFL c :> mapFL_FL Normal xx) of
                            Nothing -> True
                            Just (xx' :> _) -> case commuteFL (Normal (invert p) :> xx') of
                                               Nothing -> True
                                               Just _ -> False
    -}
    all_conflicts_with :: Non RealPatch C(x) -> [Non RealPatch C(x)]
                       -> ([Non RealPatch C(x)], [Non RealPatch C(x)])
    all_conflicts_with x ys = acw $ partition (conflicts_with x) ys
        where acw ([],nc) = ([],nc)
              acw (c:cs, nc) = case all_conflicts_with c nc of
                               (c1,nc1) -> case acw (cs, nc1) of
                                           (xs',nc') -> (c:c1++xs',nc')

    conflicts_with :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool
    conflicts_with x y | x `depends_upon` y || y `depends_upon` x = False
    conflicts_with x (Non cy y) =
        case remPs cy x of
        Just (Non cx' x') -> case commuteFL (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of
                             Right _ -> False
                             Left _ -> True
        Nothing -> True

    depends_upon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool
    depends_upon (Non xs _) (Non ys y) =
        case remove_subsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of
        Just _ -> True
        Nothing -> False

    (+++) :: Eq a => [a] -> [a] -> [a]
    [] +++ x = x
    x +++ [] = x
    (x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys)
                   | otherwise = x : (xs +++ xys)

    swapMerge :: (RealPatch :\/: RealPatch) C(x y) -> (RealPatch :/\: RealPatch) C(x y)
    swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'

    invertCommute :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))
    invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)
                                return (invert iy' :> invert ix')

    invertCommuteNC :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))
    invertCommuteNC (x :> y) = do ix' :> iy' <- commute_no_conflicts (invert y :> invert x)
                                  return (invert iy' :> invert ix')

    -- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted
    --   out of both @xs@ and @ys@ along with the remnants of both lists
    pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)
    pullCommon NilFL ys = Common NilFL NilFL ys
    pullCommon xs NilFL = Common NilFL xs NilFL
    pullCommon (x:>:xs) xys | Just ys <- removeFL x xys = case pullCommon xs ys of
                                                          Common c xs' ys' -> Common (x:>:c) xs' ys'
    pullCommon (x:>:xs) ys = case commuteWhatWeCanFL (x :> xs) of
                             xs1:>x':>xs2 -> case pullCommon xs1 ys of
                                             Common c xs1' ys' -> Common c (xs1'+>+x':>:xs2) ys'

    -- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in common,
    --   in other words @cs +>+ xs@ and @cs +>+ ys@
    data Common p C(o x y) where
        Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)

    -- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted
    --   out of both @xs@ and @ys@ along with the remnants of both lists
    pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)
    pullCommonRL NilRL ys = CommonRL NilRL ys NilRL
    pullCommonRL xs NilRL = CommonRL xs NilRL NilRL
    pullCommonRL (x:<:xs) xys
        | Just ys <- removeRL x xys = case pullCommonRL xs ys of
                                      CommonRL xs' ys' c -> CommonRL xs' ys' (x:<:c)
    pullCommonRL (x:<:xs) ys =
        case commuteWhatWeCanRL (xs :> x) of
        xs1:>x':>xs2 -> case pullCommonRL xs2 ys of
                        CommonRL xs2' ys' c -> CommonRL (xs2'+<+x':<:xs1) ys' c

    -- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@ in common,
    --   in other words @xs +<+ cs@ and @ys +<+ cs@
    data CommonRL p C(x y f) where
        CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)

    instance Apply RealPatch where
        apply opts p = apply opts (effect p)
        applyAndTryToFixFL (Normal p) = mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p
        applyAndTryToFixFL x = do apply [] x; return Nothing

    instance ShowPatch RealPatch where
        showPatch (Duplicate d) = blueText "duplicate" $$ showNon d
        showPatch (Etacilpud d) = blueText "etacilpud" $$ showNon d
        showPatch (Normal p) = showPrim NewFormat p
        showPatch (Conflictor i NilFL p) =
            blueText "conflictor" <+> showNons i <+> blueText "[]" $$ showNon p
        showPatch (Conflictor i cs p) =
            blueText "conflictor" <+> showNons i <+> blueText "[" $$
            showPatch cs $$
            blueText "]" $$
            showNon p
        showPatch (InvConflictor i NilFL p) =
            blueText "rotcilfnoc" <+> showNons i <+> blueText "[]" $$ showNon p
        showPatch (InvConflictor i cs p) =
            blueText "rotcilfnoc" <+> showNons i <+> blueText "[" $$
            showPatch cs $$
            blueText "]" $$
            showNon p
        showContextPatch (Normal p) = showContextPatch p
        showContextPatch c = return $ showPatch c

    instance ReadPatch RealPatch where
     readPatch' _ =
         do s <- peek_input
            case fmap (BC.unpack . fst) $ my_lex s of
              Just "duplicate" ->
                  do work my_lex
                     p <- readNon
                     return $ (Sealed . Duplicate) `fmap` p
              Just "etacilpud" ->
                  do work my_lex
                     p <- readNon
                     return $ (Sealed . Etacilpud) `fmap` p
              Just "conflictor" ->
                  do work my_lex
                     --let tracePeek x = do y <- peek_input
                     --                     traceDoc (greenText x $$ greenText (show $ BC.unpack y)) return ()
                     i <- readNons
                     Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')

                     Just p <- readNon
                     return $ Just $ Sealed $ Conflictor i (unsafeCoerceP ps) p
              Just "rotcilfnoc" ->
                  do work my_lex
                     i <- readNons
                     Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')
                     Just p <- readNon
                     return $ Just $ Sealed $ InvConflictor i ps p
              _ -> do mp <- readPrim NewFormat
                      case mp of
                        Just p -> return $ Just $ Normal `mapSeal` p
                        Nothing -> return Nothing

    instance Show (RealPatch C(x y)) where
        show p = renderString $ showPatch p

    instance Show2 RealPatch where
        show2 = show

    instance Nonable RealPatch where
        non (Duplicate d) = d
        non (Etacilpud d) = invertNon d -- FIXME !!! ???
        non (Normal p) = Non NilFL p
        non (Conflictor _ xx x) = add (invertFL xx) x
        non (InvConflictor _ _ n) = invertNon n

    instance Effect RealPatch where
        effect (Duplicate _) = NilFL
        effect (Etacilpud _) = NilFL
        effect (Normal p) = effect p
        effect (Conflictor _ e _) = invert e
        effect (InvConflictor _ e _) = e
        effectRL (Duplicate _) = NilRL
        effectRL (Etacilpud _) = NilRL
        effectRL (Normal p) = effectRL p
        effectRL (Conflictor _ e _) = invertFL e
        effectRL (InvConflictor _ e _) = reverseFL e
        isHunk rp = do Normal p <- return rp
                       isHunk p