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