diff3 0.1.0.1 → 0.1.2
raw patch · 4 files changed
+170/−110 lines, 4 filesdep +QuickCheckdep +diff3dep +test-frameworkdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, diff3, test-framework, test-framework-quickcheck2
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.Algorithm.Diff3: merge :: [Hunk a] -> Either [Hunk a] [a]
Files
- Data/Algorithm/Diff3.hs +0/−109
- diff3.cabal +13/−1
- src/Data/Algorithm/Diff3.hs +123/−0
- test/properties.hs +34/−0
− Data/Algorithm/Diff3.hs
@@ -1,109 +0,0 @@-{-| An implementation of a 3-way merge algorithm. -}-module Data.Algorithm.Diff3 (Hunk(..), diff3) where--import Data.Algorithm.Diff-import Data.Monoid (Monoid, mempty, mappend)------------------------------------------------------------------------------------- | A hunk is a collection of changes that occur in a document. A hunk can be--- some changes only in A, only in B, in both A & B (equally), or conflicting--- between A, B and the original document.-data Hunk a = ChangedInA [a] | ChangedInB [a] | Both [a] | Conflict [a] [a] [a]- deriving (Eq, Show)-------------------------------------------------------------------------------------- | Perform a 3-way diff against 2 documents and the original document.-diff3 :: (Eq a) => [a] -> [a] -> [a] -> [Hunk a]-diff3 a o b = step (getDiff o a) (getDiff o b)- where- step :: [(DI, a)] -> [(DI, a)] -> [Hunk a]- step [] [] = []- step oa ob =- let (conflictHunk, ra, rb) = shortestConflict oa ob- (matchHunk, ra', rb') = shortestMatch ra rb- in conflictHunk ++ matchHunk ++ step ra' rb'------------------------------------------------------------------------------------toHunk :: [(DI, a)] -> [(DI, a)] -> [Hunk a]-toHunk [] [] = mempty-toHunk a [] = return $ ChangedInA $ map snd a-toHunk [] b = return $ ChangedInB $ map snd b-toHunk a b- | all isB a && all isB b = return $ Both $ map snd $ filter isA a- | all isB a = return $ ChangedInB $ map snd $ filter isA b- | all isB b = return $ ChangedInA $ map snd $ filter isA a- | otherwise = return $ Conflict (map snd $ filter isA a)- (map snd $ filter isO a)- (map snd $ filter isA b)------------------------------------------------------------------------------------isA :: (DI, t) -> Bool-isA (F,_) = False-isA (_,_) = True-{-# INLINE isA #-}-----------------------------------------------------------------------------------isO :: (DI, t) -> Bool-isO (S,_) = False-isO (_,_) = True-{-# INLINE isO #-}------------------------------------------------------------------------------------isB :: (DI, t) -> Bool-isB (B,_) = True-isB (_,_) = False-{-# INLINE isB #-}-----------------------------------------------------------------------------------shortestMatch :: [(DI,a)] -> [(DI,a)] -> ([Hunk a], [(DI, a)], [(DI, a)])-shortestMatch oa ob = go oa ob [] []- where- go (x@(B,_):xs) (y@(B,_):ys) accX accY = go xs ys (accX ++ [x]) (accY ++ [y])- go xs ys accX accY = (toHunk accX accY, xs, ys)------------------------------------------------------------------------------------shortestConflict :: [(DI,a)] -> [(DI,a)] -> ([Hunk a], [(DI, a)], [(DI, a)])-shortestConflict l r =- let (hunk, rA, rB) = go l r- in (uncurry toHunk hunk, rA, rB)- where- go a b =- let (as, ta) = break isBoth a- (bs, tb) = break isBoth b- am = sum $ map motion as- bm = sum $ map motion bs- (as', ta') = incurMotion bm ta- (bs', tb') = incurMotion am tb- in if am == bm- then ((as, bs), ta, tb)- else ((as ++ as', bs ++ bs'), [], []) <> go ta' tb'-- isBoth (B,_) = True- isBoth (_,_) = False-- motion (S,_) = 0- motion _ = 1------------------------------------------------------------------------------------incurMotion :: Int -> [(DI, t)] -> ([(DI,t)], [(DI,t)])-incurMotion _ [] = ([], [])-incurMotion 0 as = ([], as)-incurMotion n (a@(B,_):as) = ([a], []) <> incurMotion (pred n) as-incurMotion n (a@(S,_):as) = ([a], []) <> incurMotion (pred n) as-incurMotion n (a:as) = ([a], []) <> incurMotion n as-------------------------------------------------------------------------------------- This is here so we can build on GHC 7.4.-infixr 6 <>---- | An infix synonym for 'mappend'.-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}
diff3.cabal view
@@ -1,5 +1,5 @@ name: diff3-version: 0.1.0.1+version: 0.1.2 synopsis: Perform a 3-way difference of documents homepage: http://github.com/ocharles/diff3.git license: BSD3@@ -20,5 +20,17 @@ library exposed-modules: Data.Algorithm.Diff3 build-depends: base ==4.6.*, Diff ==0.1.*+ hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans -fno-warn-unused-do-bind+++test-suite properties+ type: exitcode-stdio-1.0+ main-is: test/properties.hs+ build-depends:+ base,+ diff3,+ QuickCheck,+ test-framework,+ test-framework-quickcheck2
+ src/Data/Algorithm/Diff3.hs view
@@ -0,0 +1,123 @@+{-| An implementation of a 3-way merge algorithm. -}+module Data.Algorithm.Diff3 (Hunk(..), diff3, merge) where++import Data.Algorithm.Diff+import Data.Monoid (Monoid, mempty, mappend)++--------------------------------------------------------------------------------+-- | A hunk is a collection of changes that occur in a document. A hunk can be+-- some changes only in A, only in B, in both A & B (equally), or conflicting+-- between A, B and the original document.+data Hunk a = ChangedInA [a] | ChangedInB [a] | Both [a] | Conflict [a] [a] [a]+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- | Perform a 3-way diff against 2 documents and the original document.+diff3 :: Eq a => [a] -> [a] -> [a] -> [Hunk a]+diff3 a o b = step (getDiff o a) (getDiff o b)+ where+ step [] [] = []+ step [] ob = toHunk [] ob+ step oa [] = toHunk oa []+ step oa ob =+ let (conflictHunk, ra, rb) = shortestConflict oa ob+ (matchHunk, ra', rb') = shortestMatch ra rb+ in conflictHunk ++ matchHunk ++ step ra' rb'+++--------------------------------------------------------------------------------+merge :: [Hunk a] -> Either [Hunk a] [a]+merge hunks = maybe (Left hunks) Right $ go hunks+ where+ go [] = Just []+ go ((Conflict _ _ _):_) = Nothing+ go ((ChangedInA as):t) = fmap (as ++) $ go t+ go ((ChangedInB bs):t) = fmap (bs ++) $ go t+ go ((Both xs):t) = fmap (xs ++) $ go t+++--------------------------------------------------------------------------------+toHunk :: [(DI, a)] -> [(DI, a)] -> [Hunk a]+toHunk [] [] = mempty+toHunk a [] = return $ ChangedInA $ map snd a+toHunk [] b = return $ ChangedInB $ map snd b+toHunk a b+ | all isB a && all isB b = return $ Both $ map snd $ filter isA a+ | all isB a = return $ ChangedInB $ map snd $ filter isA b+ | all isB b = return $ ChangedInA $ map snd $ filter isA a+ | otherwise = return $ Conflict (map snd $ filter isA a)+ (map snd $ filter isO a)+ (map snd $ filter isA b)+++--------------------------------------------------------------------------------+isA :: (DI, t) -> Bool+isA (F,_) = False+isA (_,_) = True+{-# INLINE isA #-}++--------------------------------------------------------------------------------+isO :: (DI, t) -> Bool+isO (S,_) = False+isO (_,_) = True+{-# INLINE isO #-}+++--------------------------------------------------------------------------------+isB :: (DI, t) -> Bool+isB (B,_) = True+isB (_,_) = False+{-# INLINE isB #-}++--------------------------------------------------------------------------------+shortestMatch :: [(DI,a)] -> [(DI,a)] -> ([Hunk a], [(DI, a)], [(DI, a)])+shortestMatch oa ob = go oa ob [] []+ where+ go (x@(B,_):xs) (y@(B,_):ys) accX accY = go xs ys (accX ++ [x]) (accY ++ [y])+ go xs ys accX accY = (toHunk accX accY, xs, ys)+++--------------------------------------------------------------------------------+shortestConflict :: [(DI,a)] -> [(DI,a)] -> ([Hunk a], [(DI, a)], [(DI, a)])+shortestConflict l r =+ let (hunk, rA, rB) = go l r+ in (uncurry toHunk hunk, rA, rB)+ where+ go [] b = (([], b), [], [])+ go a [] = ((a, []), [], [])+ go a b =+ let (as, ta) = break isBoth a+ (bs, tb) = break isBoth b+ am = sum $ map motion as+ bm = sum $ map motion bs+ (as', ta') = incurMotion bm ta+ (bs', tb') = incurMotion am tb+ in if am == bm+ then ((as, bs), ta, tb)+ else ((as ++ as', bs ++ bs'), [], []) <> go ta' tb'++ isBoth (B,_) = True+ isBoth (_,_) = False++ motion (S,_) = 0+ motion _ = 1+++--------------------------------------------------------------------------------+incurMotion :: Int -> [(DI, t)] -> ([(DI,t)], [(DI,t)])+incurMotion _ [] = ([], [])+incurMotion 0 as = ([], as)+incurMotion n (a@(B,_):as) = ([a], []) <> incurMotion (pred n) as+incurMotion n (a@(S,_):as) = ([a], []) <> incurMotion (pred n) as+incurMotion n (a:as) = ([a], []) <> incurMotion n as+++--------------------------------------------------------------------------------+-- This is here so we can build on GHC 7.4.+infixr 6 <>++-- | An infix synonym for 'mappend'.+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}
+ test/properties.hs view
@@ -0,0 +1,34 @@+module Main where++import Data.Algorithm.Diff3+import Data.Monoid (mempty)+import Test.Framework+import Test.QuickCheck+import Test.Framework.Providers.QuickCheck2++leftChanges :: [Int] -> [Int] -> Bool+leftChanges left original = merge (diff3 left original original) == Right left++rightChanges :: [Int] -> [Int] -> Bool+rightChanges right original = merge (diff3 original original right) == Right right++identicalChanges :: [Int] -> [Int] -> Property+identicalChanges changed original = (changed /= original) ==>+ conflicts (merge (diff3 changed original changed))+ where conflicts (Left _) = True+ conflicts (Right _) = False++identityMerge :: [Int] -> Bool+identityMerge as = merge (diff3 as as as) == Right as++main :: IO ()+main =+ let testOpts = mempty { topt_maximum_generated_tests = Just 5000 }+ runner = mempty { ropt_test_options = Just testOpts }+ in defaultMainWithOpts+ [ testProperty "Can make changes in left document" leftChanges+ , testProperty "Can make changes in right document" rightChanges+ , testProperty "Left/right identical changes conflict" identicalChanges+ , testProperty "The 'identity' merge always succeeds" identityMerge+ ]+ runner