MergeSpec.hs

{-# LANGUAGE PolyKinds        #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE GADTs            #-}
module Data.Digems.Patch.MergeSpec (spec) where

import Generics.MRSOP.Base

import Data.Digems.Patch
import Data.Digems.Diff
import Data.Digems.Patch.Merge
import Data.Digems.Change
import Data.Digems.Change.Thinning
import Data.Digems.Change.Apply
import Languages.RTree
import Languages.RTree.Diff

import Test.QuickCheck
import Test.Hspec

import Control.Monad.Except

--------------------------------------------
-- ** Merge Properties

{-
merge_id :: Property
merge_id = forAll genSimilarTrees' $ \(t1 , t2)
  -> let patch = digemRTree t1 t2
         iden  = digemRTree t1 t1
         mpid  = patch // iden
         midp  = iden  // patch
      in case (,) <$> noConflicts mpid <*> noConflicts midp of
           Nothing -> expectationFailure
                    $ unwords [ "has conflicts:"
                              , unwords $ getConflicts mpid
                              , ";;"
                              , unwords $ getConflicts midp
                              ]
           Just (pid , idp) ->
             case (,) <$> applyRTree pid t1 <*> applyRTree idp t2 of
               Left err -> expectationFailure ("apply failed: " ++ err)
               Right (r1 , r2) -> (r1 , r2) `shouldBe` (t2 , t2)
         

merge_diag :: Property
merge_diag = forAll genSimilarTrees' $ \(t1 , t2)
  -> let patch = digemRTree t1 t2
      in case noConflicts (patch // patch) of
           Nothing -> expectationFailure "has conflicts"
           Just p  -> case applyRTree' p t2 of
             Nothing -> expectationFailure "apply failed"
             Just r  -> r `shouldBe` t2
-}

--------------------------------------------
-- ** Manual Merge Examples

data MergeOutcome
  = MergeOk
  | MergeDiffers
  | ApplyFailed
  | HasConflicts
  deriving (Eq , Show)

expectMerge :: DiffMode
            -> MergeOutcome -> String -> RTree -> RTree -> RTree
            -> SpecWith (Arg Property)
expectMerge mode expt lbl a o b = do
  it (lbl ++ ": " ++ show expt) $
    doMerge mode a o b `shouldBe` expt

doMerge :: DiffMode -> RTree -> RTree -> RTree -> MergeOutcome
doMerge mode a o b
  = let a' = dfrom $ into @FamRTree a
        b' = dfrom $ into @FamRTree b
        o' = dfrom $ into @FamRTree o
        -- VCM: Funny... with DM_ProperShare and DM_NoNested
        -- we see the same hspec restuls, but with DM_Patience
        -- we get a different result altogether.
        oa = digemRTreeHM mode 1 o a
        ob = digemRTreeHM mode 1 o b
        oaob = oa // ob
        oboa = ob // oa
     in case (,) <$> noConflicts oaob <*> noConflicts oboa of
             Just (ab , ba)
               -> case (,) <$> apply ab b' <*> apply ba a' of
                   Right (c1 , c2)
                     | eqFix eqHO c1 c2 -> MergeOk
                     | otherwise        -> MergeDiffers
                   Left _               -> ApplyFailed
             Nothing                    -> HasConflicts
 

mustMerge :: DiffMode -> String -> RTree -> RTree -> RTree -> SpecWith (Arg Property)
mustMerge m = expectMerge m MergeOk

xexpectMerge :: MergeOutcome -> String -> String -> RTree -> RTree -> RTree
             -> SpecWith (Arg Property)
xexpectMerge expt reason lbl a o b = do
  it (lbl ++ ": " ++ show expt) $
    pendingWith reason



----------------------
-- Example 1

a1 , o1 , b1 :: RTree
a1 = "a" :>: [ "b" :>: []
             , "c" :>: []
             , "d" :>: []
             ]

o1 = "a" :>: [ "b" :>: []
             , "d" :>: []
             ]

b1 = "a" :>: [ "b'" :>: []
             , "d" :>: []
             ]

-------------------
-- Example 2

a2, o2, b2 :: RTree
a2 = "b" :>: [ "u" :>: [ "3" :>: [] ] , ".." :>: [] ]

o2 = "b" :>: [ "b" :>: [ "u" :>: [ "3" :>: [] ] , ".." :>: [] ]
             , "." :>: []
             ]

b2 = "b" :>: [ "b" :>: [ "u" :>: [ "4" :>: [] ] , "u" :>: [ ".." :>: [] ] ]
             , "." :>: []
             ]

-----------------
-- Example 3

a3 , o3 , b3 :: RTree
a3 = "x'" :>: [ "y" :>: [] , "z" :>: [] ]

o3 = "x" :>: [ "y" :>: [] , "z" :>: [] ]

b3 = "x" :>: [ "y'" :>: [] ]

---------------------------------
-- Example 4

a4 , o4 , b4 :: RTree
a4 = "y" :>: []
o4 = "x" :>: []
b4 = "y" :>: []

---------------------------------
-- Example 5

a5 , o5 , b5 :: RTree
a5 = "x" :>: [ "k" :>: [] , "u" :>: []]
o5 = "x" :>: [ "u" :>: [] , "k" :>: []]
b5 = "x" :>: [ "y" :>: ["u" :>: [] , "k" :>: [] ] 
             , "u" :>: [] , "k" :>: [] ]

---------------------------------
-- Example 6

a6 , o6 , b6 :: RTree
a6 = "x" :>: [ "u" :>: []]
o6 = "x" :>: [ "u" :>: [] , "k" :>: []]
b6 = "x" :>: [ "y" :>: ["u" :>: [] , "k" :>: [] ] 
             , "u" :>: [] , "k" :>: [] ]


---------------------------------
-- Example 7

a7 , o7 , b7 :: RTree
a7 = "x" :>: [ "u" :>: [ "b" :>: [] ] , "l" :>: [] ]
o7 = "x" :>: [ "a" :>: [] , "u" :>: [ "b" :>: [] ] , "k" :>: [] , "l" :>: []]
b7 = "y" :>: [ "a" :>: [] , "u" :>: [ "b" :>: [] ] , "k" :>: [] , "new" :>: [] , "l" :>: []]

---------------------------------
-- Example 8

a8 , o8 , b8 :: RTree
a8 = "x" :>: [ "k" :>: [] , "u" :>: []]
o8 = "x" :>: [ "u" :>: [] , "k" :>: []]
b8 = "x" :>: [ "u" :>: [] , "a" :>: [] , "k" :>: []]

---------------------------------
-- Example 9

a9 , o9 , b9 :: RTree
a9 = "x" :>: [ "k" :>: []  , "u" :>: []]
o9 = "x" :>: [ "u" :>: []  , "k" :>: []]
b9 = "x" :>: [ "u'" :>: [] , "k" :>: []]


-- Now we follow with triples that must NOT merge

--------------------------------
-- Example 10

a10 , o10 , b10 :: RTree
a10 = "x" :>: [ "u" :>: []  , "a" :>: [] , "k" :>: []]
o10 = "x" :>: [ "u" :>: []  , "k" :>: []]
b10 = "x" :>: [ "u" :>: []  , "b" :>: [] , "k" :>: []]

------------------------------
-- Example 11

a11 , o11 , b11 :: RTree
a11 = "x" :>: [ "u" :>: []  , "a" :>: []]
o11 = "x" :>: [ "u" :>: []  , "b" :>: []]
b11 = "x" :>: [ "u" :>: []  , "c" :>: []]

-----------------------------
-- Example 12

a12 , o12 , b12 :: RTree
a12 = "f" :>: ["j" :>: []]
o12 = "f" :>: ["a" :>: []]
b12 = "e" :>: []

----------------------------
-- Example 13

a13 , o13 , b13 :: RTree
a13 = "a" :>: []
o13 = "d" :>: ["i" :>: []]
b13 = "a" :>: ["j" :>: ["i" :>: []]]

---------------------------
-- Example 14

a14 , o14 , b14 :: RTree
a14 = "l" :>: []
o14 = "k" :>: ["b" :>: [],"l" :>: []]
b14 = "f" :>: ["k" :>: [],"b" :>: []]

---------------------------
-- Example 15

a15 , o15 , b15 :: RTree
a15 = "g" :>: []
o15 = "i" :>: ["g" :>: [],"c" :>: []]
b15 = "g" :>: ["k" :>: [],"l" :>: []]

------------------------
-- Example 16

a16 , o16 , b16 :: RTree
a16 = "j" :>: []
o16 = "g" :>: ["f" :>: [],"j" :>: []]
b16 = "e" :>: ["a" :>: [],"a" :>: [],"f" :>: []]

------------------------
-- Example 17

a17 , o17 , b17 :: RTree
a17 = "j" :>: ["f" :>: []]
o17 = "e" :>: ["f" :>: [],"f" :>: [],"m" :>: []]
b17 = "j" :>: ["g" :>: ["c" :>: [],"c" :>: [],"h" :>: [],"f" :>: []]]

------------------------
-- Example 18

a18 , o18 , b18 :: RTree
a18 = "r" :>: [ "a" :>: [] , "a" :>: []]
o18 = "r" :>: [ "a" :>: [] , "c" :>: []]
b18 = "r" :>: [ "b" :>: [] , "c" :>: [] ]

-------------------------
-- Example 19

a19 , o19 , b19 :: RTree
a19 = "c" :>: ["c" :>: []]
o19 = "c" :>: ["m" :>: ["a" :>: []]]
b19 = "f" :>: ["c" :>: [],"c" :>: [],"c" :>: [],"k" :>: []]

------------------------
-- Example 20

a20 , o20 , b20 :: RTree

a20 = "x" :>: ["a" :>: [] , "c" :>: [] , "d" :>: [] , "b" :>: []]
o20 = "x" :>: ["a" :>: [] , "b" :>: []]
b20 = "x" :>: ["a" :>: [] , "c" :>: [] , "b" :>: []]

{-
cc :: RTree -> RTree -> RTree -> Bool
cc a o b =
  let p = distrCChange $ digemRTree o a
      q = distrCChange $ digemRTree o b
   in case (,) <$> thin p (domain q) <*> thin q (domain p) of
        Left err -> error "imp; its a span!"
        Right (p' , q')
          -> (     changeEq q q'  &&      changeEq p p')
          || (     changeEq q q'  && not (changeEq p p'))
          || (not (changeEq q q') &&      changeEq p p')
-}

oa9 = digemRTree o9 a9
ob9 = digemRTree o9 b9

oa8 = digemRTree o8 a8
ob8 = digemRTree o8 b8 `withFreshNamesFrom` oa8

coa8 = distrCChange oa8
cob8 = distrCChange ob8

myprocess ca cb =
  let Right ca' = thin ca (domain cb)
      Right cb' = thin cb (domain ca)
      newinsa   = pmatch (cCtxDel ca') (cCtxDel cb') >>= transport (cCtxIns ca')
   in case runExcept newinsa of
        Left err -> error ("impossible: " ++ show err)
        Right r  -> (r , cCtxDel cb' , cCtxIns cb')

{-
mymerge :: RTree -> RTree -> RTree -> IO ()
mymerge a o b = do
  let oa = digemRTree o a
  let ob = digemRTree o b `withFreshNamesFrom` oa
  let ca' = distrCChange oa
  let cb' = distrCChange ob
  let (ca , d , cb) = myprocess ca' cb'
  let (i , res)  = diff' 0 d ca
  let (_ , res') = diff' 0 d cb
  print res
  putStrLn "-----------------"
  print res'
-}
{-
p = distrCChange oa8
q = distrCChange ob8 
thinned p q = uncurry' cmatch <$> thin' (cCtxDel p :*: cCtxIns p)
                                        (cCtxDel q :*: cCtxIns q)

mymerge p q = do
  p' <- thin p (domain q)
  q' <- thin q (domain p)
  if changeEq q' q
  then return p
  else case tr p' q' of
    Left err -> error $ show err
    Right r  -> return r
-}

myDigemRTree = digemRTreeHM DM_ProperShare 1

oa1 = myDigemRTree o1 a1
ob1 = myDigemRTree o1 b1

oa2 = myDigemRTree o2 a2
ob2 = myDigemRTree o2 b2

oa7 = myDigemRTree o7 a7
ob7 = myDigemRTree o7 b7

oa5 = myDigemRTree o5 a5
ob5 = myDigemRTree o5 b5

oa6 = myDigemRTree o6 a6
ob6 = myDigemRTree o6 b6

oa12 = myDigemRTree o12 a12
ob12 = myDigemRTree o12 b12

oa13 = myDigemRTree o13 a13
ob13 = myDigemRTree o13 b13

oa14 = myDigemRTree o14 a14
ob14 = myDigemRTree o14 b14

oa15 = myDigemRTree o15 a15
ob15 = myDigemRTree o15 b15

oa16 = myDigemRTree o16 a16
ob16 = myDigemRTree o16 b16

oa17 = myDigemRTree o17 a17
ob17 = myDigemRTree o17 b17

oa18 = myDigemRTree o18 a18
ob18 = myDigemRTree o18 b18

oa19 = myDigemRTree o19 a19
ob19 = myDigemRTree o19 b19

oa20 = myDigemRTree o20 a20
ob20 = myDigemRTree o20 b20

gen3Trees :: Gen (RTree , RTree , RTree)
gen3Trees = choose (0 , 4)
        >>= genSimilarTreesN 3
        >>= \[a , o , b] -> return (a , o , b)

spec :: Spec
spec = do
  -- describe "properties" $ do
  --   it "p // id == p && id // p == id" $ merge_id
  --   it "p // p  == id"                 $ merge_diag
  
  flip mapM_ (enumFrom (toEnum 0)) $ \m -> do
    describe ("merge: manual examples (" ++ show m ++ ")") $ do
      mustMerge m "01" a1 o1 b1
      mustMerge m "02" a2 o2 b2
      mustMerge m "03" a3 o3 b3
      mustMerge m "04" a4 o4 b4
      if m == DM_Patience
        then expectMerge m HasConflicts "05" a5 o5 b5
        else mustMerge m "05" a5 o5 b5
      if m == DM_Patience
        then expectMerge m HasConflicts "06" a6 o6 b6
        else mustMerge m "06" a6 o6 b6
      mustMerge m "07" a7 o7 b7
      mustMerge m "08" a8 o8 b8
      mustMerge m "09" a9 o9 b9

      expectMerge m HasConflicts "10" a10 o10 b10
      expectMerge m HasConflicts "11" a11 o11 b11
      expectMerge m HasConflicts "12" a12 o12 b12

      mustMerge m "13" a13 o13 b13

      expectMerge m HasConflicts "14" a14 o14 b14
      expectMerge m HasConflicts "15" a15 o15 b15
      expectMerge m HasConflicts "16" a16 o16 b16
      if m == DM_Patience
        then mustMerge m "17" a17 o17 b17
        else expectMerge m HasConflicts "17" a17 o17 b17

      mustMerge m "18" a18 o18 b18
      mustMerge m "19" a19 o19 b19
      xexpectMerge MergeOk "What to do with self-contained ins-ins?" "20" a20 o20 b20

    describe ("merge: conflict or ok (" ++ show m ++ ")") $ do
      it "contains no apply fail or merge differs" $ property $
        forAll gen3Trees $ \(a , o , b)
          -> doMerge m a o b `elem` [MergeOk , HasConflicts]