src/Darcs/Patch/Real.lhs

   1 %  Copyright (C) 2007 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18
  19 \section{Conflictor patches}
  20
  21 \begin{code}
  22 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
  23 {-# LANGUAGE CPP #-}
  24 -- , TypeOperators, GADTs, PatternGuards #-}
  25
  26 #include "gadts.h"
  27
  28 module Darcs.Patch.Real
  29        ( RealPatch(..), prim2real, is_consistent, is_forward, is_duplicate,
  30          pullCommon, mergeUnravelled ) where
  31
  32 import Control.Monad ( mplus, liftM )
  33 import Data.List ( partition, nub )
  34 import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Conflict(..), Effect(..),
  35                           showPrim, FileNameFormat(NewFormat),
  36                           sort_coalesceFL, IsConflictedPrim(..), ConflictState(..) )
  37 import Darcs.Patch.Read ( readPrim )
  38 import Darcs.Patch.Patchy
  39 import Darcs.Ordered
  40 --import Darcs.Patch.Read ()
  41 --import Darcs.Patch.Viewing ()
  42 --import Darcs.Patch.Apply ()
  43 import Darcs.Patch.Commute ( mangle_unravelled )
  44 import Darcs.Patch.Non ( Non(..), Nonable(..), unNon,
  45                          showNons, showNon, readNons, readNon,
  46                          add, addP, addPs, remP, remPs, remNons,
  47                          (*>), (>*), (*>>), (>>*) )
  48 import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL,
  49                                   genCommuteWhatWeCanRL,
  50                                   removeRL, removeFL, remove_subsequenceFL )
  51 import qualified Data.ByteString.Char8 as BC ( unpack )
  52 import Darcs.Patch.ReadMonads (work, peek_input, my_lex )
  53 import Darcs.Utils ( nubsort )
  54 import Darcs.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal )
  55 import Darcs.Show
  56 import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) )
  57 import Darcs.ColorPrinter ( errorDoc, assertDoc )
  58 --import Printer ( greenText )
  59 --import Darcs.ColorPrinter ( traceDoc )
  60 #include "impossible.h"
  61
  62 -- Duplicate x: This patch has no effect since 'x' is already present in the repository
  63 --
  64 -- Etacilpud x: invert (Duplicate x)
  65 --
  66 -- Normal prim: A primitive patch
  67 --
  68 -- Conflictor ix xx x:
  69 -- 'ix' is the set of patches:
  70 --   * that conflict with 'x' and also conflict with another patch in the repository
  71 --   * that conflict with a patch that conflict with 'x'
  72 -- 'xx' is the sequence of patches that conflict *only* with 'x'
  73 -- 'x' is the current patch
  74 --
  75 -- 'ix' and 'x' are stored as "Non" objects, which include any necessary
  76 --  context to uniquely define the patch that is referred to.
  77 --
  78 -- InvConflictor ix xx x: like invert (Conflictor ix xx x)
  79 data RealPatch C(x y) where
  80     Duplicate :: Non RealPatch C(x) -> RealPatch C(x x)
  81     Etacilpud :: Non RealPatch C(x) -> RealPatch C(x x)
  82     Normal :: Prim C(x y) -> RealPatch C(x y)
  83     Conflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(y x)
  84     InvConflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(x y)
  85
  86 is_duplicate :: RealPatch C(s y) -> Bool
  87 is_duplicate (Duplicate _) = True
  88 is_duplicate (Etacilpud _) = True
  89 is_duplicate _ = False
  90
  91 is_forward :: RealPatch C(s y) -> Maybe Doc
  92 is_forward p@(InvConflictor _ _ _) =
  93     Just $ redText "An inverse conflictor" $$ showPatch p
  94 is_forward p@(Etacilpud _) =
  95     Just $ redText "An inverse duplicate" $$ showPatch p
  96 is_forward _ = Nothing
  97
  98 mergeUnravelled :: [Sealed ((FL Prim) C(x))] -> Maybe (FlippedSeal RealPatch C(x))
  99 mergeUnravelled [] = Nothing
 100 mergeUnravelled [_] = Nothing
 101 mergeUnravelled ws = case mergeUnravelled_private ws of
 102                      Nothing -> Nothing
 103                      Just NilRL -> bug "found no patches in mergeUnravelled"
 104                      Just (z:<:_) -> Just $ FlippedSeal z
 105     where notNullS :: Sealed ((FL Prim) C(x)) -> Bool
 106           notNullS (Sealed NilFL) = False
 107           notNullS _ = True
 108           mergeUnravelled_private :: [Sealed (FL Prim C(x))] -> Maybe (RL RealPatch C(x x))
 109           mergeUnravelled_private xs = reverseFL `fmap` mergeConflictingNons
 110                                                         (map sealed2non $ filter notNullS xs)
 111
 112 sealed2non :: Sealed ((FL Prim) C(x)) -> Non RealPatch C(x)
 113 sealed2non (Sealed xs) = case reverseFL xs of
 114                          y:<:ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y
 115                          NilRL -> bug "NilFL encountered in sealed2non"
 116
 117 mergeConflictingNons :: [Non RealPatch C(x)] -> Maybe (FL RealPatch C(x x))
 118 mergeConflictingNons ns = mcn $ map unNon ns
 119     where mcn :: [Sealed (FL RealPatch C(x))] -> Maybe (FL RealPatch C(x x))
 120           mcn [] = Just NilFL
 121           mcn [Sealed p] = case sort_coalesce_effects p of -- this is just a safety check, and could
 122                            NilFL -> Just p                 -- be removed when we're sure of the code.
 123                            _ -> Nothing
 124           mcn (Sealed p1:Sealed p2:zs) = case pullCommon p1 p2 of
 125                                          Common c ps qs ->
 126                                              case merge (ps :\/: qs) of
 127                                              qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs)
 128
 129 sort_coalesce_effects :: FL RealPatch C(x y) -> FL Prim C(x y)
 130 sort_coalesce_effects = sort_coalesceFL . effect
 131
 132 assertConsistent :: RealPatch C(x y) -> RealPatch C(x y)
 133 assertConsistent x = assertDoc (do e <- is_consistent x
 134                                    Just (redText "Inconsistent patch:" $$ showPatch x $$ e)) x
 135
 136 -- mergeAfterConflicting takes as input a sequence of conflicting
 137 -- patches xxx (which therefore have no effect) and a sequence of
 138 -- primitive patches yyy that follow said sequence of conflicting
 139 -- patches, and may depend upon some of the conflicting patches (as a
 140 -- resolution).
 141
 142 -- The output is two sequences of patches the first consisting of a
 143 -- set of mutually-conflicting patches, and the second having the same
 144 -- effect as the original primitive patch sequence in the input.
 145
 146 -- So far as I can tell, the second output is always identical to
 147 -- mapFL Normal yyy
 148
 149 -- The first output is the set of patches from xxx that are depended
 150 -- upon by yyy.
 151
 152 mergeAfterConflicting :: FL RealPatch C(x x) -> FL Prim C(x y)
 153                       -> Maybe (FL RealPatch C(x x), FL RealPatch C(x y))
 154 mergeAfterConflicting xxx yyy = --traceDoc (greenText "mergeAfterConflicting xxx" $$ showPatch xxx $$
 155                                 --          greenText "and yyy" $$ showPatch yyy) $
 156                                 mac (reverseFL xxx) yyy NilFL
 157     where mac :: RL RealPatch C(x y) -> FL Prim C(y z) -> FL RealPatch C(z a)
 158               -> Maybe (FL RealPatch C(x x), FL RealPatch C(x a))
 159           mac NilRL xs goneby = case sort_coalesce_effects goneby of
 160                                 NilFL -> Just (NilFL, mapFL_FL Normal xs)
 161                                 _z -> --traceDoc (greenText "mac1 z" $$ showPatch _z) $
 162                                       Nothing
 163           mac (p:<:ps) xs goneby = --traceDoc (greenText "mac ps" $$ showPatch ps $$
 164                                    --          greenText "p" $$ showPatch p $$
 165                                    --          greenText "xs" $$ showPatch xs $$
 166                                    --          greenText "goneby" $$ showPatch goneby) $
 167                                    case commuteFL (p :> mapFL_FL Normal xs) of
 168                                    Left _  -> case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of
 169                                               a:>p':>b ->
 170                                                   do (b',xs') <- mac b xs goneby
 171                                                      --traceDoc (greenText "foo1" $$
 172                                                      --          showPatch (sort_coalesceFL $
 173                                                      --                     effect $ p':<:a)) $ Just ()
 174                                                      NilFL <- return $ sort_coalesceFL $ effect $ p':<:a
 175                                                      return (reverseRL (p':<:a)+>+b', xs')
 176                                                    `mplus` do NilFL <- return goneby
 177                                                               NilFL <- return $ sort_coalesceFL $
 178                                                                        effect (p:<:ps)
 179                                                               return (reverseRL (p:<:ps),
 180                                                                       mapFL_FL Normal xs)
 181                                    Right (l:>p'') ->
 182                                        case allNormal l of
 183                                        Just xs'' -> mac ps xs'' (p'':>:goneby)
 184                                        Nothing ->
 185                                               case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of
 186                                               a:>p':>b ->
 187                                                   do (b',xs') <- mac b xs goneby
 188                                                      --traceDoc (greenText "foo2" $$
 189                                                      --          showPatch (sort_coalesceFL $
 190                                                      --                     effect $ p':<:a)) $ Just ()
 191                                                      NilFL <- return $ sort_coalesceFL $ effect $ p':<:a
 192                                                      return $ (reverseRL (p':<:a)+>+b', xs')
 193
 194 geteff :: [Non RealPatch C(x)] -> FL Prim C(x y) -> ([Non RealPatch C(x)], FL RealPatch C(x y))
 195 geteff _ NilFL = ([],NilFL)
 196 geteff ix (x:>:xs) | Just ix' <- mapM (remP (Normal x)) ix
 197                                = --traceDoc (greenText "I got rid of x" $$ showPatch x) $
 198                                  case geteff ix' xs of
 199                                  (ns,xs') -> (non (Normal x) : map (addP (Normal x)) ns,
 200                                               Normal x :>: xs')
 201 geteff ix xx = case mergeConflictingNons ix of
 202                Nothing -> errorDoc $ redText "mergeConflictingNons failed in geteff with ix" $$
 203                           showNons ix $$ redText "xx" $$ showPatch xx
 204                Just rix -> case mergeAfterConflicting rix xx of
 205                            Just (a,x) -> (map (addPs (reverseFL a)) $ toNons x,
 206                                           a +>+ x)
 207                            Nothing -> errorDoc $ redText "mergeAfterConflicting failed in geteff"$$
 208                                       redText "where ix" $$ showNons ix $$
 209                                       redText "and xx" $$ showPatch xx $$
 210                                       redText "and rix" $$ showPatch rix
 211
 212 xx2nons :: [Non RealPatch C(x)] -> FL Prim C(x y) -> [Non RealPatch C(x)]
 213 xx2nons ix xx = fst $ geteff ix xx
 214
 215 xx2patches :: [Non RealPatch C(x)] -> FL Prim C(x y) -> FL RealPatch C(x y)
 216 xx2patches ix xx = snd $ geteff ix xx
 217
 218 allNormal :: FL RealPatch C(x y) -> Maybe (FL Prim C(x y))
 219 allNormal (Normal x:>:xs) = (x :>:) `fmap` allNormal xs
 220 allNormal NilFL = Just NilFL
 221 allNormal _ = Nothing
 222
 223 is_consistent :: RealPatch C(x y) -> Maybe Doc
 224 is_consistent (Normal _) = Nothing
 225 is_consistent (Duplicate _) = Nothing
 226 is_consistent (Etacilpud _) = Nothing
 227 is_consistent (Conflictor im mm m@(Non deps _))
 228     | not $ everyone_conflicts im = Just $ redText "Someone doesn't conflict in im in is_consistent"
 229     | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in is_consistent"
 230     | any (\x -> any (x `conflicts_with`) nmm) im
 231         = Just $ redText "mm conflicts with im in is_consistent where nmm is" $$
 232                  showNons nmm
 233     | Nothing <- (nmm ++ im) `minus` toNons deps = Just $ redText "dependencies not in conflict:" $$
 234                                                    showNons (toNons deps) $$
 235                                                    redText "compared with deps itself:" $$
 236                                                    showPatch deps
 237     | otherwise = case all_conflicts_with m im of
 238                   (im1,[]) | im1 `eqSet` im -> Nothing
 239                   (_,imnc) -> Just $ redText "m doesn't conflict with im in is_consistent.  unconflicting:"
 240                               $$ showNons imnc
 241     where (nmm, rmm) = geteff im mm
 242 is_consistent c@(InvConflictor _ _ _) = is_consistent (invert c)
 243
 244 everyone_conflicts :: [Non RealPatch C(x)] -> Bool
 245 everyone_conflicts [] = True
 246 everyone_conflicts (x:xs) = case all_conflicts_with x xs of
 247                             ([],_) -> False
 248                             (_,xs') -> everyone_conflicts xs'
 249
 250 prim2real :: Prim C(x y) -> RealPatch C(x y)
 251 prim2real = Normal
 252
 253 instance Patchy RealPatch
 254
 255 instance MyEq p => Eq (Sealed (p C(x))) where
 256     (Sealed x) == (Sealed y) | IsEq <- x =\/= y = True
 257                              | otherwise = False
 258
 259 merge_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x))
 260 merge_with p [] = effect `mapSeal` unNon p
 261 merge_with p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $
 262                   filter (\x -> not (p `depends_upon` x) && not (p `conflicts_with` x)) xs
 263     where mergeall :: [Sealed (FL RealPatch C(x))] -> Sealed (FL Prim C(x))
 264           mergeall [Sealed x] = Sealed $ effect x
 265           mergeall [] = Sealed NilFL
 266           mergeall (Sealed x:Sealed y:rest) = case merge (x :\/: y) of
 267                                               y' :/\: _ -> mergeall (Sealed (x+>+y'):rest)
 268           unconflicting_of [] = []
 269           unconflicting_of (q:qs) = case all_conflicts_with q qs of
 270                                     ([],_) -> q:qs
 271                                     (_,nc) -> unconflicting_of nc
 272
 273 instance Conflict RealPatch where
 274     conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x]
 275     conflictedEffect (Etacilpud _) = impossible
 276     conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]
 277     conflictedEffect (InvConflictor _ _ _) = impossible
 278     conflictedEffect (Normal x) = [IsC Okay x]
 279     resolve_conflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled]
 280             where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx)
 281                   nonxx = case nonxx_aux ix xx of
 282                           NilRL -> []
 283                           Normal q:<:qs -> [Non (reverseRL qs) q]
 284                           _ -> []
 285                   nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y)
 286                   nonxx_aux a b = reverseFL $ xx2patches a b
 287                   isn :: Sealed (FL p C(x)) -> Bool
 288                   isn (Sealed NilFL) = False
 289                   isn _ = True
 290     resolve_conflicts _ = []
 291
 292     -- cA
 293     commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x)
 294     commute_no_conflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x)
 295     commute_no_conflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x)
 296     commute_no_conflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x)
 297     -- cB
 298     commute_no_conflicts (x :> Duplicate d) = if d == addP (invert x) (non x)
 299                                               then Just (x :> Duplicate d)
 300                                               else do d' <- remP (invert x) d
 301                                                       return (Duplicate d' :> x)
 302     commute_no_conflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d'))
 303     commute_no_conflicts c@(Etacilpud _ :> _) = invertCommuteNC c
 304     commute_no_conflicts c@(_ :> Etacilpud _) = invertCommuteNC c
 305     -- cE
 306     commute_no_conflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y)
 307                                                      return (Normal y' :> Normal x')
 308     -- cF -- involves a conflict
 309     -- cG
 310     commute_no_conflicts (Normal x :> Conflictor iy yy y) =
 311         case commuteFL (x :> invert yy) of
 312         Right (iyy' :> x') -> do
 313            y':iy' <- mapM (Normal x' >*) (y:iy)
 314            return (Conflictor iy' (invert iyy') y' :> Normal x')
 315         _ -> Nothing
 316     -- cFi+cGi  -- handle with previous two pattern matches
 317     commute_no_conflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c
 318     -- icG FIXME: where is icF?
 319     commute_no_conflicts (Conflictor iy' yy' y' :> Normal x') =
 320         do x :> iyy <- commuteRL (invertFL yy' :> x')
 321            y:iy <- mapM (*> Normal x') (y':iy')
 322            return (Normal x :> Conflictor iy (invertRL iyy) y)
 323     -- icGi      -- handle with previous pattern match
 324     commute_no_conflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c
 325     -- cH -- this involves a conflict commute
 326     -- cI
 327     commute_no_conflicts (Conflictor ix xx x :> Conflictor iy yy y) =
 328         do xx' :> yy' <- commute (yy :> xx)
 329            x':ix' <- mapM (yy >>*) (x:ix)
 330            y':iy' <- mapM (*>> xx') (y:iy)
 331            False <- return $ any (conflicts_with y) (x':ix')
 332            False <- return $ any (conflicts_with x') iy
 333            return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')
 334     -- cHi+cIi            uses previous two matches
 335     commute_no_conflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c
 336     -- cJ
 337     commute_no_conflicts (InvConflictor ix xx x :> Conflictor iy yy y) =
 338         do iyy' :> xx' <- commute (xx :> invert yy)
 339            y':iy' <- mapM (xx' >>*) (y:iy)
 340            x':ix' <- mapM (invertFL iyy' >>*) (x:ix)
 341            False <- return $ any (conflicts_with y') (x':ix')
 342            False <- return $ any (conflicts_with x') iy'
 343            return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')
 344     -- icJ
 345     commute_no_conflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') =
 346         do xx :> iyy <- commute (invert yy' :> xx')
 347            y:iy <- mapM (*>> xx') (y':iy')
 348            x:ix <- mapM (*>> yy') (x':ix')
 349            False <- return $ any (conflicts_with y') (x':ix')
 350            False <- return $ any (conflicts_with x') iy'
 351            return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)
 352
 353 instance FromPrim RealPatch where
 354     fromPrim = prim2real
 355 instance ToFromPrim RealPatch where
 356     toPrim (Normal p) = Just p
 357     toPrim _ = Nothing
 358
 359 instance MyEq RealPatch where
 360     (Duplicate x) =\/= (Duplicate y) | x == y = IsEq
 361     (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq
 362     (Normal x) =\/= (Normal y) = x =\/= y
 363     (Conflictor cx xx x) =\/= (Conflictor cy yy y)
 364         | map (add $ invertFL xx) cx `eqSet`
 365           map (add $ invertFL yy) cy &&
 366           add (invert xx) x == add (invert yy) y = xx =/\= yy
 367     (InvConflictor cx xx x) =\/= (InvConflictor cy yy y)
 368         | cx `eqSet` cy && x == y = xx =\/= yy
 369     _ =\/= _ = NotEq
 370
 371 eqSet :: Eq a => [a] -> [a] -> Bool
 372 eqSet [] [] = True
 373 eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys
 374 eqSet _ _ = False
 375
 376 remove1 :: Eq a => a -> [a] -> Maybe [a]
 377 remove1 x (y:ys) | x == y = Just ys
 378                  | otherwise = (y :) `fmap` remove1 x ys
 379 remove1 _ [] = Nothing
 380
 381 minus :: Eq a => [a] -> [a] -> Maybe [a]
 382 minus xs [] = Just xs
 383 minus xs (y:ys) = do xs' <- remove1 y xs
 384                      xs' `minus` ys
 385
 386 invertNon :: Non RealPatch C(x) -> Non RealPatch C(x)
 387 invertNon (Non c x)
 388     | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x)
 389     | otherwise = addPs (Normal x :<: reverseFL c) $ non nix
 390     where nix = Normal $ invert x
 391
 392 nonTouches :: Non RealPatch C(x) -> [FilePath]
 393 nonTouches (Non c x) = list_touched_files (c +>+ fromPrim x :>: NilFL)
 394
 395 toNons :: (Conflict p, Patchy p, ToFromPrim p, Nonable p) => FL p C(x y) -> [Non p C(x)]
 396 toNons xs = map lastNon $ initsFL xs
 397     where lastNon :: (Conflict p, Patchy p, Nonable p) => Sealed ((p :> FL p) C(x)) -> Non p C(x)
 398           lastNon (Sealed xxx) = case lastNon_aux xxx of
 399                                  deps :> p :> _ -> case non p of
 400                                                    Non NilFL pp -> Non (reverseRL deps) pp
 401                                                    Non ds pp -> errorDoc $ redText "Weird case in toNons" $$
 402                                                                 redText "please report this bug!" $$
 403                                                                 (case xxx of
 404                                                                  z:>zs -> showPatch (z:>:zs)) $$
 405                                                                 redText "ds are" $$ showPatch ds $$
 406                                                                 redText "pp is" $$ showPatch pp
 407           reverseFoo :: (p :> FL p) C(x y) -> (RL p :> p) C(x y)
 408           reverseFoo (p :> ps) = rf NilRL p ps
 409               where rf :: RL p C(a b) -> p C(b c) -> FL p C(c d) -> (RL p :> p) C(a d)
 410                     rf rs l NilFL = rs :> l
 411                     rf rs x (y:>:ys) = rf (x:<:rs) y ys
 412           lastNon_aux :: Commute p => (p :> FL p) C(x y) -> (RL p :> p :> RL p) C(x y)
 413           lastNon_aux = commuteWhatWeCanRL . reverseFoo
 414
 415 initsFL :: Patchy p => FL p C(x y) -> [Sealed ((p :> FL p) C(x))]
 416 initsFL NilFL = []
 417 initsFL (x:>:xs) = Sealed (x:>NilFL) : map (\ (Sealed (y:>xs')) -> Sealed (x:>y:>:xs')) (initsFL xs)
 418
 419 fromNons :: [Non RealPatch C(x)] -> Maybe (Sealed (FL Prim C(x)))
 420 fromNons [] = Just $ Sealed $ NilFL
 421 fromNons ns = do (Sealed p, ns') <- pullInContext ns
 422                  ns'' <- mapM (remP $ fromPrim p) ns'
 423                  Sealed ps <- fromNons ns''
 424                  return $ Sealed $ p :>: ps
 425
 426 pullInContext :: [Non RealPatch C(x)] -> Maybe (Sealed (Prim C(x)), [Non RealPatch C(x)])
 427 pullInContext (Non NilFL p:ns) = Just (Sealed p, ns)
 428 pullInContext (n:ns) = do (sp,ns') <- pullInContext ns
 429                           return (sp, n:ns')
 430 pullInContext [] = Nothing
 431
 432 filterConflictsFL :: Non RealPatch C(x) -> FL Prim C(x y) -> (FL Prim :> FL Prim) C(x y)
 433 filterConflictsFL _ NilFL = NilFL :> NilFL
 434 filterConflictsFL n (p:>:ps)
 435     | Just n' <- remP (fromPrim p) n = case filterConflictsFL n' ps of
 436                                        p1 :> p2 -> p:>:p1 :> p2
 437     | otherwise = case commuteWhatWeCanFL (p :> ps) of
 438                   p1 :> p' :> p2 -> case filterConflictsFL n p1 of
 439                                     p1a :> p1b -> p1a :> p1b +>+ p' :>: p2
 440
 441 instance Invert RealPatch where
 442     invert (Duplicate d) = Etacilpud d
 443     invert (Etacilpud d) = Duplicate d
 444     invert (Normal p) = Normal (invert p)
 445     invert (Conflictor x c p) = InvConflictor x c p
 446     invert (InvConflictor x c p) = Conflictor x c p
 447     identity = Normal identity
 448
 449 instance Commute RealPatch where
 450 --    commute (x :> y) | traceDoc (greenText "commuting x" $$ showPatch x $$
 451 --                                 greenText "with y" $$ showPatch y) False = undefined
 452     commute (x :> y) | Just (y' :> x') <- commute_no_conflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x')
 453     -- cF
 454     commute (Normal x :> Conflictor a1'nop2 n1'x p1') -- these patches conflicted
 455         | Just rn1' <- removeRL x (reverseFL n1'x) =
 456                       do let p2:n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x:<:rn1')
 457                              a2 = p1':a1'nop2++n1nons
 458                          case (a1'nop2, reverseRL rn1', p1') of
 459                            ([], NilFL, Non c y) | NilFL <- sort_coalesce_effects c ->
 460                                     Just (Normal y :> Conflictor a1'nop2 (y:>:NilFL) p2)
 461                            (a1,n1,_) -> Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)
 462     -- cFi  -- handle with previous pattern match
 463     commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c
 464     -- cH
 465     commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)
 466         | Just a2_minus_p1 <- remove1 p1' a2,
 467           not (p2 `depends_upon` p1') =
 468               do let n1nons = map (add n2) $ xx2nons a1 n1
 469                      n2nons = xx2nons a2 n2
 470                      Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons
 471                      n2n1 = n2 +>+ n1
 472                      a1' = map (add n2) a1
 473                      p2ooo = remNons a1' p2
 474                  n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1
 475                  let n1'n2'nons = xx2nons a2_minus_p1n1 (n1'+>+n2')
 476                      n1'nons = take (lengthFL n1') n1'n2'nons
 477                      n2'nons = drop (lengthFL n1') n1'n2'nons
 478                      Just a1'nop2 = (a2++n2nons) `minus` (p1':n1'nons)
 479                      Just a2'o = --traceDoc (greenText "\n\nConflictor a1 n1 p1 is" $$
 480                                  --          showPatch (assertConsistent $ Conflictor a1 n1 p1) $$
 481                                  --          greenText "and Conflictor a2 n2 p2 is" $$
 482                                  --          showPatch (assertConsistent $ Conflictor a2 n2 p2) $$
 483                                  --          greenText "where n2'nons is" $$ showNons n2'nons $$
 484                                  --          greenText "and others are" $$
 485                                  --          showNons (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) $$
 486                                  --          greenText "These came from" $$
 487                                  --          showNons (a2_minus_p1++n2nons) $$
 488                                  --          greenText "n1'n2'nons" $$ showNons n1'n2'nons $$
 489                                  --          greenText "from n1' :> n2'" $$
 490                                  --          showPatch n1' $$ greenText ":>" $$ showPatch n2' $$
 491                                  --          greenText "p2" $$ showNon p2 $$
 492                                  --          greenText "p2 fixed" $$ showNon p2ooo $$
 493                                  --          -- greenText "pren1" $$ showPatch pren1 $$
 494                                  --          greenText "n1'" $$ showPatch n1' $$
 495                                  --          greenText "p2" $$ showNon p2
 496                                  --         )
 497                                  (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) `minus` n2'nons
 498                      Just a2' = mapM (remPs (xx2patches a1'nop2 n1')) $
 499                                 a2'o
 500                      Just p2' = remPs (xx2patches a1'nop2 n1') p2
 501                  case (a2', n2', p2') of
 502                    ([], NilFL, Non c x) | NilFL <- sort_coalesce_effects c ->
 503                                           Just (Normal x :> Conflictor a1'nop2 (n1'+>+x:>:NilFL) p1')
 504                                         | otherwise -> impossible
 505                    _ -> Just (Conflictor a2' n2' p2' :> Conflictor (p2:a1'nop2) n1' p1')
 506         where (_,rpn2) = geteff a2 n2
 507               p1' = addPs (reverseFL rpn2) p1
 508     -- cHi         -- uses previous match
 509     commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c
 510     commute _ = Nothing
 511
 512     merge (InvConflictor _ _ _ :\/: _) = impossible
 513     merge (_ :\/: InvConflictor _ _ _) = impossible
 514     merge (Etacilpud _ :\/: _) = impossible
 515     merge (_ :\/: Etacilpud _) = impossible
 516 --    merge (x :\/: y) | traceDoc (greenText "merging x" $$ showPatch x $$
 517 --                                 greenText "with y" $$ showPatch y) False = impossible
 518     -- mA
 519     merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a
 520     -- mB
 521     merge (Duplicate a :\/: b) = b :/\: Duplicate (addP (invert b) a) -- FIXME ???
 522     -- smB
 523     merge m@(_ :\/: Duplicate _) = swapMerge m
 524     -- mC
 525 --    merge _ | traceDoc (greenText "about to look for conflictingness") False = impossible
 526     merge (x :\/: y) | Just (y' :> ix') <- commute (invert (assertConsistent x) :> assertConsistent y),
 527                        Just (y'' :> _) <- commute (x :> y'),
 528                        IsEq <- y'' =\/= y = --traceDoc (greenText "These didn't conflict") $
 529                                             assertConsistent y' :/\: invert (assertConsistent ix')
 530                      | IsEq <- x =\/= y,
 531                        n <- addP (invert x) $ non x =
 532                                  --traceDoc (greenText "Found duplicate") $
 533                                  Duplicate n :/\: Duplicate n
 534 --    merge (x :\/: y) | traceDoc (greenText "trying to merging x" $$ showPatch x $$
 535 --                                 greenText "which conflicts with y" $$ showPatch y) False = impossible
 536     -- mD
 537     merge (Normal x :\/: Normal y) =
 538         Conflictor [] (x:>:NilFL) (non $ Normal y) :/\: Conflictor [] (y:>:NilFL) (non $ Normal x)
 539     -- mG
 540     merge (Normal x :\/: Conflictor iy yy y) =
 541           --traceDoc (greenText "merging Normal x" $$ showPatch x $$
 542           --          greenText "and Conflictor iy yy y" $$ showPatch (Conflictor iy yy y)) $
 543           Conflictor iy yyx y :/\: Conflictor (y:iy++nyy) NilFL x'
 544               where yyx = yy +>+ x:>:NilFL
 545                     (x':nyy) = reverse $ xx2nons iy yyx
 546     -- smE+smG
 547     merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m
 548 --    merge (x :\/: y) | traceDoc (greenText "still trying to merge x" $$ showPatch x $$
 549 --                                 greenText "with y" $$ showPatch y) False = impossible
 550     -- mH see also cH
 551     merge (Conflictor ix xx x :\/: Conflictor iy yy y) =
 552         case pullCommonRL (reverseFL xx) (reverseFL yy) of
 553         CommonRL rxx1 ryy1 c ->
 554             case commuteRLFL (ryy1 :> invertRL rxx1) of
 555             Just (ixx' :> ryy') ->
 556                 let xx' = invert ixx'
 557                     yy' = reverseRL ryy'
 558                     y':iy' = map (add $ invertFL ixx') (y:iy)
 559                     x':ix' = map (add ryy') (x:ix)
 560                     nyy' = xx2nons iy' yy'
 561                     nxx' = xx2nons ix' xx'
 562                     icx = drop (lengthRL rxx1) $ xx2nons ix (reverseRL $ c+<+rxx1)
 563                     ic' = map (add ryy') icx
 564                     ixy' = ic' ++ (iy'+++ix')
 565                     -- +++ above is a more efficient version of nub
 566                     -- (iy'++ix') given that we know each element shows up
 567                     -- only once in either list.
 568                 in --traceDoc (greenText "here I am! and so is ixy'" $$ showNons ixy' $$
 569                    --          greenText "and iy" $$ showNons iy $$ greenText (show $ length iy) $$
 570                    --          greenText "and ix" $$ showNons ix $$
 571                    --          greenText "and iy'" $$ showNons iy' $$
 572                    --          greenText "and ix'" $$ showNons ix' $$
 573                    --          greenText "and ic'" $$ showNons ic'
 574                    --         ) $
 575                 Conflictor (x':ixy'++nxx') yy' y' :/\: Conflictor (y':ixy'++nyy') xx' x'
 576             Nothing -> impossible pullInContext fromNons
 577 --    merge _ = error "haven't finished fixing merge"
 578
 579     list_touched_files (Duplicate p) = nonTouches p
 580     list_touched_files (Etacilpud p) = nonTouches p
 581     list_touched_files (Normal p) = list_touched_files p
 582     list_touched_files (Conflictor x c p) =
 583         nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p
 584     list_touched_files (InvConflictor x c p) =
 585         nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p
 586
 587 {-
 588 all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)]
 589                      -> ([Non RealPatch C(x)], [Non RealPatch C(x)])
 590 all_conflicts_withFL xx ns = case partition f ns of
 591                              ([],nc) -> ([],nc)
 592                              (c,nc) -> case acw c nc of
 593                                        (c',nc') -> (c++c',nc')
 594     where acw (y:ys) zs = case all_conflicts_with y zs of
 595                           (c,nc) -> case acw ys nc of
 596                                     (c',nc') -> (c++c',nc')
 597           acw [] zs = ([],zs)
 598           f (Non c p) = case commuteRLFL (invertFL c :> mapFL_FL Normal xx) of
 599                         Nothing -> True
 600                         Just (xx' :> _) -> case commuteFL (Normal (invert p) :> xx') of
 601                                            Nothing -> True
 602                                            Just _ -> False
 603 -}
 604 all_conflicts_with :: Non RealPatch C(x) -> [Non RealPatch C(x)]
 605                    -> ([Non RealPatch C(x)], [Non RealPatch C(x)])
 606 all_conflicts_with x ys = acw $ partition (conflicts_with x) ys
 607     where acw ([],nc) = ([],nc)
 608           acw (c:cs, nc) = case all_conflicts_with c nc of
 609                            (c1,nc1) -> case acw (cs, nc1) of
 610                                        (xs',nc') -> (c:c1++xs',nc')
 611
 612 conflicts_with :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool
 613 conflicts_with x y | x `depends_upon` y || y `depends_upon` x = False
 614 conflicts_with x (Non cy y) =
 615     case remPs cy x of
 616     Just (Non cx' x') -> case commuteFL (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of
 617                          Right _ -> False
 618                          Left _ -> True
 619     Nothing -> True
 620
 621 depends_upon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool
 622 depends_upon (Non xs _) (Non ys y) =
 623     case remove_subsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of
 624     Just _ -> True
 625     Nothing -> False
 626
 627 (+++) :: Eq a => [a] -> [a] -> [a]
 628 [] +++ x = x
 629 x +++ [] = x
 630 (x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys)
 631                | otherwise = x : (xs +++ xys)
 632
 633 swapMerge :: (RealPatch :\/: RealPatch) C(x y) -> (RealPatch :/\: RealPatch) C(x y)
 634 swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'
 635
 636 invertCommute :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))
 637 invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)
 638                             return (invert iy' :> invert ix')
 639
 640 invertCommuteNC :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))
 641 invertCommuteNC (x :> y) = do ix' :> iy' <- commute_no_conflicts (invert y :> invert x)
 642                               return (invert iy' :> invert ix')
 643 pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)
 644 pullCommon NilFL ys = Common NilFL NilFL ys
 645 pullCommon xs NilFL = Common NilFL xs NilFL
 646 pullCommon (x:>:xs) xys | Just ys <- removeFL x xys = case pullCommon xs ys of
 647                                                       Common c xs' ys' -> Common (x:>:c) xs' ys'
 648 pullCommon (x:>:xs) ys = case commuteWhatWeCanFL (x :> xs) of
 649                          xs1:>x':>xs2 -> case pullCommon xs1 ys of
 650                                          Common c xs1' ys' -> Common c (xs1'+>+x':>:xs2) ys'
 651
 652 data Common p C(o x y) where
 653     Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)
 654
 655 pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)
 656 pullCommonRL NilRL ys = CommonRL NilRL ys NilRL
 657 pullCommonRL xs NilRL = CommonRL xs NilRL NilRL
 658 pullCommonRL (x:<:xs) xys
 659     | Just ys <- removeRL x xys = case pullCommonRL xs ys of
 660                                   CommonRL xs' ys' c -> CommonRL xs' ys' (x:<:c)
 661 pullCommonRL (x:<:xs) ys =
 662     case commuteWhatWeCanRL (xs :> x) of
 663     xs1:>x':>xs2 -> case pullCommonRL xs2 ys of
 664                     CommonRL xs2' ys' c -> CommonRL (xs2'+<+x':<:xs1) ys' c
 665
 666 data CommonRL p C(x y f) where
 667     CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)
 668
 669 instance Apply RealPatch where
 670     apply opts p = apply opts (effect p)
 671     applyAndTryToFixFL (Normal p) = mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p
 672     applyAndTryToFixFL x = do apply [] x; return Nothing
 673
 674 instance ShowPatch RealPatch where
 675     showPatch (Duplicate d) = blueText "duplicate" $$ showNon d
 676     showPatch (Etacilpud d) = blueText "etacilpud" $$ showNon d
 677     showPatch (Normal p) = showPrim NewFormat p
 678     showPatch (Conflictor i NilFL p) =
 679         blueText "conflictor" <+> showNons i <+> blueText "[]" $$ showNon p
 680     showPatch (Conflictor i cs p) =
 681         blueText "conflictor" <+> showNons i <+> blueText "[" $$
 682         showPatch cs $$
 683         blueText "]" $$
 684         showNon p
 685     showPatch (InvConflictor i NilFL p) =
 686         blueText "rotcilfnoc" <+> showNons i <+> blueText "[]" $$ showNon p
 687     showPatch (InvConflictor i cs p) =
 688         blueText "rotcilfnoc" <+> showNons i <+> blueText "[" $$
 689         showPatch cs $$
 690         blueText "]" $$
 691         showNon p
 692     showContextPatch s (Normal p) = showContextPatch s p
 693     showContextPatch _ c = showPatch c
 694
 695 instance ReadPatch RealPatch where
 696  readPatch' want_eof =
 697      do s <- peek_input
 698         case fmap (BC.unpack . fst) $ my_lex s of
 699           Just "duplicate" ->
 700               do work my_lex
 701                  p <- readNon
 702                  return $ (Sealed . Duplicate) `fmap` p
 703           Just "etacilpud" ->
 704               do work my_lex
 705                  p <- readNon
 706                  return $ (Sealed . Etacilpud) `fmap` p
 707           Just "conflictor" ->
 708               do work my_lex
 709                  --let tracePeek x = do y <- peek_input
 710                  --                     traceDoc (greenText x $$ greenText (show $ BC.unpack y)) return ()
 711                  i <- readNons
 712                  Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')
 713
 714                  Just p <- readNon
 715                  return $ Just $ Sealed $ Conflictor i (unsafeCoerceP ps) p
 716           Just "rotcilfnoc" ->
 717               do work my_lex
 718                  i <- readNons
 719                  Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')
 720                  Just p <- readNon
 721                  return $ Just $ Sealed $ InvConflictor i ps p
 722           _ -> do mp <- readPrim NewFormat want_eof
 723                   case mp of
 724                     Just p -> return $ Just $ Normal `mapSeal` p
 725                     Nothing -> return Nothing
 726
 727 instance Show (RealPatch C(x y)) where
 728     show p = renderString $ showPatch p
 729
 730 instance Show2 RealPatch where
 731     show2 = show
 732
 733 instance Nonable RealPatch where
 734     non (Duplicate d) = d
 735     non (Etacilpud d) = invertNon d -- FIXME !!! ???
 736     non (Normal p) = Non NilFL p
 737     non (Conflictor _ xx x) = add (invertFL xx) x
 738     non (InvConflictor _ _ n) = invertNon n
 739
 740 instance Effect RealPatch where
 741     effect (Duplicate _) = NilFL
 742     effect (Etacilpud _) = NilFL
 743     effect (Normal p) = effect p
 744     effect (Conflictor _ e _) = invert e
 745     effect (InvConflictor _ e _) = e
 746     effectRL (Duplicate _) = NilRL
 747     effectRL (Etacilpud _) = NilRL
 748     effectRL (Normal p) = effectRL p
 749     effectRL (Conflictor _ e _) = invertFL e
 750     effectRL (InvConflictor _ e _) = reverseFL e
 751     isHunk rp = do Normal p <- return rp
 752                    isHunk p
 753
 754 \end{code}