-- Copyright (C) 2007 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-}
{-# LANGUAGE CPP #-}

#include "gadts.h"

module Darcs.Test.Patch.Unit ( patch_unit_tests ) where

import Data.Maybe ( catMaybes, isNothing )
import qualified Data.ByteString.Char8 as BC ( pack )
import Darcs.Witnesses.Sealed
import Darcs.Patch
import Darcs.Patch.Patchy ( mergeFL, Invert )
import Darcs.Patch.Real ( RealPatch, prim2real, is_consistent, is_forward, is_duplicate )
import Darcs.Test.Patch.Test () -- for instance Eq Patch
import Darcs.Witnesses.Ordered
import Darcs.Patch.Properties ( recommute, commute_inverses, permutivity, partial_permutivity,
                                inverse_doesnt_commute, patch_and_inverse_commute,
                                merge_commute, merge_consistent, merge_arguments_consistent,
                                merge_either_way, show_read,
                                join_inverses, join_commute )
import Darcs.Patch.Prim ( join )
import Darcs.Test.Patch.QuickCheck
import Printer ( Doc, redText, ($$) )
--import Printer ( greenText )
--import Darcs.ColorPrinter ( traceDoc )
--import Darcs.ColorPrinter ( errorDoc )
import Darcs.ColorPrinter () -- for instance Show Doc
import Test.HUnit ( assertBool )
import Test.Framework.Providers.HUnit ( testCase )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Test.Framework ( Test )

-- import Debug.Trace
-- #include "impossible.h"

-- | The unit tests defined about patches
patch_unit_tests :: [Test]
patch_unit_tests = [--do putStr "Checking with quickcheck that real patches have consistent flattenings... "
                    --   quickCheck (not . isBottomTimeOut (Just 10) . prop_consistent_tree_flattenings) >> return 0
                    run_primitive_tests "prim join inverses" (\ (a:\/:_) -> join_inverses join a) mergeables,
                    testProperty "Checking prim join inverses using QuickCheck... " (isNothing . join_inverses join),
                    run_primitive_tests "prim inverse doesn't commute" (\ (a:\/:_) -> inverse_doesnt_commute a) mergeables,
                    -- The following fails because of setpref patches...
                    --,do putStr "Checking prim inverse doesn't commute using QuickCheck... "
                    --    simpleCheck (inverse_doesnt_commute :: Prim -> Maybe Doc)
                    run_primitive_tests "join commute" (join_commute join) prim_permutables,
                    testProperty "Checking prim join commute using QuickCheck... " (unseal2 (isNothing . join_commute join)),
                    run_primitive_tests "prim recommute" (recommute commute) $ map mergeable2commutable mergeables,
                    run_primitive_tests "prim patch and inverse commute" (patch_and_inverse_commute commute) $ map mergeable2commutable mergeables,
                    run_primitive_tests "prim inverses commute" (commute_inverses commute) $ map mergeable2commutable mergeables,
                    --,do putStr "Checking prim recommute using QuickCheck... "
                    --    simpleCheck (recommute
                    --                 (commute :: Prim :> Prim
                    --                          -> Maybe (Prim :> Prim)))
                    run_primitive_tests "FL prim recommute" (recommute commute) $ map mergeable2commutable mergeablesFL,
                    run_primitive_tests "FL prim patch and inverse commute" (patch_and_inverse_commute commute) $ map mergeable2commutable mergeablesFL,
                    run_primitive_tests "FL prim inverses commute" (commute_inverses commute) $ map mergeable2commutable mergeablesFL,
                    run_primitive_tests "fails" (commute_fails commute) ([] :: [Prim :> Prim]),
                    run_primitive_tests "read and show work on Prim" show_read prim_patches,
                    run_primitive_tests "read and show work on RealPatch" show_read real_patches,
                    testProperty "Checking that readPatch and showPatch work on RealPatch... "
                                 (isNothing . (unseal $ patchFromTree $ (show_read :: RealPatch -> Maybe Doc))),
                    testProperty "Checking that readPatch and showPatch work on FL RealPatch... "
                                 (isNothing . (unseal2 $ (show_read :: FL RealPatch -> Maybe Doc))),
                    run_primitive_tests "example flattenings work"
                                        (\x -> if prop_consistent_tree_flattenings x
                                                 then Nothing
                                                 else Just $ redText "oops")
                                        real_patch_loop_examples,
                    testProperty "Checking that tree flattenings are consistent... " prop_consistent_tree_flattenings,
                    testProperty "Checking with quickcheck that real patches are consistent... "
                                 (isNothing . (unseal $ patchFromTree $ is_consistent)),
                    run_primitive_tests "real merge input consistent" (merge_arguments_consistent is_consistent) real_mergeables,
                    run_primitive_tests "real merge input is forward" (merge_arguments_consistent is_forward) real_mergeables,
                    run_primitive_tests "real merge output is forward" (merge_consistent is_forward) real_mergeables,
                    run_primitive_tests "real merge output consistent" (merge_consistent is_consistent) real_mergeables,
                    run_primitive_tests "real merge either way" merge_either_way real_mergeables,
                    run_primitive_tests "real merge and commute" merge_commute real_mergeables,

                    run_primitive_tests "real recommute" (recommute commute) real_commutables,
                    run_primitive_tests "real inverses commute" (commute_inverses commute) real_commutables,
                    run_primitive_tests "real permutivity" (permutivity commute) $ filter (not_duplicatestriple) real_triples,
                    run_primitive_tests "real partial permutivity" (partial_permutivity commute) $ filter (not_duplicatestriple) real_triples,

                    testProperty "Checking we can do merges using QuickCheck"
                                 (isNothing . (prop_is_mergeable ::
                                                Sealed (WithStartState RepoModel (Tree Prim))
                                                -> Maybe (Tree RealPatch C(x)))),
                    testProperty "Checking recommute using QuickCheck Tree generator"
                                 (isNothing. (unseal $ commutePairFromTree $
                                              (recommute
                                               (commute :: RealPatch :> RealPatch
                                                           -> Maybe (RealPatch :> RealPatch))))),
                    testProperty "Checking recommute using QuickCheck TWFP generator"
                                 (isNothing . (unseal $ commutePairFromTWFP $
                                               (recommute
                                                 (commute :: RealPatch :> RealPatch
                                                          -> Maybe (RealPatch :> RealPatch))))),
                    testConditional "Checking nontrivial recommute"
                                    (unseal $ commutePairFromTree $ nontrivial_reals)
                                    (unseal $ commutePairFromTree $
                                     (recommute
                                      (commute :: RealPatch :> RealPatch
                                               -> Maybe (RealPatch :> RealPatch)))),
                    testConditional "Checking nontrivial recommute using TWFP"
                                    (unseal $ commutePairFromTWFP $ nontrivial_reals)
                                    (unseal $ commutePairFromTWFP $
                                      (recommute
                                       (commute :: RealPatch :> RealPatch
                                                -> Maybe (RealPatch :> RealPatch)))),

                    testProperty "Checking inverses commute using QuickCheck Tree generator"
                                 (isNothing . (unseal $ commutePairFromTree $
                                               (commute_inverses
                                                 (commute :: RealPatch :> RealPatch
                                                             -> Maybe (RealPatch :> RealPatch))))),
                    testProperty "Checking inverses commute using QuickCheck TWFP generator"
                                 (isNothing . (unseal $ commutePairFromTWFP $
                                               (commute_inverses
                                                (commute :: RealPatch :> RealPatch
                                                            -> Maybe (RealPatch :> RealPatch))))),
                    testConditional "Checking nontrivial inverses commute"
                                    (unseal $ commutePairFromTree $ nontrivial_reals)
                                    (unseal $ commutePairFromTree $
                                     (commute_inverses
                                      (commute :: RealPatch :> RealPatch
                                               -> Maybe (RealPatch :> RealPatch)))),
                    testConditional "Checking nontrivial inverses commute using TWFP"
                                    (unseal $ commutePairFromTWFP $ nontrivial_reals)
                                    (unseal $ commutePairFromTWFP $
                                     (commute_inverses
                                      (commute :: RealPatch :> RealPatch
                                               -> Maybe (RealPatch :> RealPatch)))),

                    testProperty "Checking merge either way using QuickCheck TWFP generator"
                                 (isNothing . (unseal $ mergePairFromTWFP $
                                               (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))),
                    testProperty "Checking merge either way using QuickCheck Tree generator"
                                 (isNothing . (unseal $ mergePairFromTree $
                                               (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))),
                    testConditional "Checking nontrivial merge either way"
                                    (unseal $ mergePairFromTree $ nontrivial_merge_reals)
                                    (unseal $ mergePairFromTree $
                                     (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)),
                    testConditional "Checking nontrivial merge either way using TWFP"
                                    (unseal $ mergePairFromTWFP $ nontrivial_merge_reals)
                                    (unseal $ mergePairFromTWFP $
                                     (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)),

                    testConditional "Checking permutivity"
                                    (unseal $ commuteTripleFromTree not_duplicatestriple)
                                    (unseal $ commuteTripleFromTree $ permutivity
                                            (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))),
                    testConditional "Checking partial permutivity"
                                    (unseal $ commuteTripleFromTree not_duplicatestriple)
                                    (unseal $ commuteTripleFromTree $ partial_permutivity
                                            (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))),
                    testConditional "Checking nontrivial permutivity"
                                    (unseal $ commuteTripleFromTree
                                               (\t -> nontrivial_triple t && not_duplicatestriple t))
                                    (unseal $ commuteTripleFromTree $
                                      (permutivity
                                       (commute :: RealPatch :> RealPatch
                                                -> Maybe (RealPatch :> RealPatch))))
                   ]

not_duplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool
not_duplicatestriple (a :> b :> c) = not $ any is_duplicate [a,b,c]

--not_duplicates_pair :: RealPatch :> RealPatch -> Bool
--not_duplicates_pair (a :> b) = not $ any is_duplicate [a,b]

nontrivial_triple :: RealPatch :> RealPatch :> RealPatch -> Bool
nontrivial_triple (a :> b :> c) =
    case commute (a :> b) of
    Nothing -> False
    Just (b' :> a') ->
      case commute (a' :> c) of
      Nothing -> False
      Just (c'' :> a'') ->
        case commute (b :> c) of
        Nothing -> False
        Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&
                            (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&
                            (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))

nontrivial_reals :: RealPatch :> RealPatch -> Bool
nontrivial_reals = nontrivial_commute

nontrivial_commute :: Patchy p => p :> p -> Bool
nontrivial_commute (x :> y) = case commute (x :> y) of
                              Just (y' :> x') -> not (y' `unsafeCompare` y) ||
                                                 not (x' `unsafeCompare` x)
                              Nothing -> False

nontrivial_merge_reals :: RealPatch :\/: RealPatch -> Bool
nontrivial_merge_reals = nontrivial_merge

nontrivial_merge :: Patchy p => p :\/: p -> Bool
nontrivial_merge (x :\/: y) = case merge (x :\/: y) of
                              y' :/\: x' -> not (y' `unsafeCompare` y) ||
                                            not (x' `unsafeCompare` x)

-- | Run a test function on a set of data, using HUnit. The test function should
--   return @Nothing@ upon success and a @Just x@ upon failure.
run_primitive_tests :: (Show a, Show b) => String         -- ^ The test name
                                        -> (a -> Maybe b) -- ^ The test function
                                        -> [a]            -- ^ The test data
                                        -> Test
run_primitive_tests name test datas = testCase name (assertBool assertName res)
    where assertName = "Boolean assertion for \"" ++ name ++ "\""
          res        = and $ map (isNothing . test) datas

quickhunk :: Int -> String -> String -> Prim
quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)
                                (map (\c -> BC.pack [c]) n)

prim_permutables :: [Prim :> Prim :> Prim]
prim_permutables =
    [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"]

mergeables :: [Prim :\/: Prim]
mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",
              quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",
              quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",
              quickhunk 0 "a" "" :\/: quickhunk 1 "" "b",
              quickhunk 0 "a" "" :\/: quickhunk 1 "b" "",
              quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""
             ]

mergeablesFL :: [FL Prim :\/: FL Prim]
mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables ++
           [] --    [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)
              --  :\/: (quickhunk 1 "a" "z" :>: NilFL),
              --  (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL)
              --  :\/: (quickhunk 1 "a" "z" :>: NilFL)]

mergeable2commutable :: Invert p => p :\/: p -> p :> p
mergeable2commutable (x :\/: y) = invert x :> y

prim_patches :: [Prim]
prim_patches = concatMap mergeable2patches mergeables
    where mergeable2patches (x:\/:y) = [x,y]

real_patches :: [RealPatch]
real_patches = concatMap commutable2patches real_commutables
    where commutable2patches (x:>y) = [x,y]

real_triples :: [RealPatch :> RealPatch :> RealPatch]
real_triples = [ob' :> oa2 :> a2'',
                oa' :> oa2 :> a2''] ++ triple_examples
               ++ map unsafeUnseal2 (concatMap getTriples realFLs)
    where oa = prim2real $ quickhunk 1 "o" "aa"
          oa2 = oa
          a2 = prim2real $ quickhunk 2 "a34" "2xx"
          ob = prim2real $ quickhunk 1 "o" "bb"
          ob' :/\: oa' = merge (oa :\/: ob)
          a2' :/\: _ = merge (ob' :\/: a2)
          a2'' :/\: _ = merge (oa2 :\/: a2')

realFLs :: [FL RealPatch]
realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]
    where oa = prim2real $ quickhunk 1 "o" "a"
          ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)

real_commutables :: [RealPatch :> RealPatch]
real_commutables = commute_examples ++ map mergeable2commutable real_mergeables++
                   [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs)
    where oa = prim2real $ quickhunk 1 "o" "a"
          ob = prim2real $ quickhunk 1 "o" "b"
          _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)

real_mergeables :: [RealPatch :\/: RealPatch]
real_mergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables
                        ++ real_igloo_mergeables
                        ++ real_quickcheck_mergeables
                        ++ merge_examples
                        ++ catMaybes (map pair2m (concatMap getPairs realFLs))
                        ++ [(oa :\/: od),
                            (oa :\/: a2'),
                            (ob' :\/: od''),
                            (oe :\/: od),
                            (of' :\/: oe'),
                            (ob' :\/: oe'),
                            (oa :\/: oe'),
                            (ob' :\/: oc'),
                            (b2' :\/: oc'''),
                            (ob' :\/: a2),
                            (b2' :\/: og'''),
                            (oc''' :\/: og'''),
                            (oc'' :\/: og''),
                            (ob'' :\/: og''),
                            (ob'' :\/: oc''),
                            (oc' :\/: od'')]
    where oa = prim2real $ quickhunk 1 "o" "aa"
          a2 = prim2real $ quickhunk 2 "a34" "2xx"
          og = prim2real $ quickhunk 3 "4" "g"
          ob = prim2real $ quickhunk 1 "o" "bb"
          b2 = prim2real $ quickhunk 2 "b" "2"
          oc = prim2real $ quickhunk 1 "o" "cc"
          od = prim2real $ quickhunk 7 "x" "d"
          oe = prim2real $ quickhunk 7 "x" "e"
          pf = prim2real $ quickhunk 7 "x" "f"
          od'' = prim2real $ quickhunk 8 "x" "d"
          ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)
          a2' :/\: _ = merge (ob' :\/: a2)
          ob'' :/\: _ = merge (a2 :\/: ob')
          og' :/\: _ = merge (oa :\/: og)
          og'' :/\: _ = merge (a2 :\/: og')
          og''' :/\: _ = merge (ob' :\/: og')
          oc' :/\: _ = merge (oa :\/: oc)
          oc'' :/\: _ = merge (a2 :\/: oc)
          oc''' :/\: _ = merge (ob' :\/: oc')
          oe' :/\: _ = merge (od :\/: oe)
          of' :/\: _ = merge (od :\/: pf)
          pair2m :: Sealed2 (RealPatch :> RealPatch)
                 -> Maybe (RealPatch :\/: RealPatch)
          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)
                                          return (xx :\/: y')

real_igloo_mergeables :: [RealPatch :\/: RealPatch]
real_igloo_mergeables = [(a :\/: b),
                    (b :\/: c),
                    (a :\/: c),
                    (x :\/: a),
                    (y :\/: b),
                    (z :\/: c),
                    (x' :\/: y'),
                    (z' :\/: y'),
                    (x' :\/: z'),
                    (a :\/: a)]
    where a = prim2real $ quickhunk 1 "1" "A"
          b = prim2real $ quickhunk 2 "2" "B"
          c = prim2real $ quickhunk 3 "3" "C"
          x = prim2real $ quickhunk 1 "1BC" "xbc"
          y = prim2real $ quickhunk 1 "A2C" "ayc"
          z = prim2real $ quickhunk 1 "AB3" "abz"
          x' :/\: _ = merge (a :\/: x)
          y' :/\: _ = merge (b :\/: y)
          z' :/\: _ = merge (c :\/: z)

real_quickcheck_mergeables :: [RealPatch :\/: RealPatch]
real_quickcheck_mergeables = [-- invert k1 :\/: n1
                             --, invert k2 :\/: n2
                               hb :\/: k
                             , b' :\/: b'
                             , n' :\/: n'
                             , b :\/: d
                             , k' :\/: k'
                             , k3 :\/: k3
                             ] ++ catMaybes (map pair2m pairs)
    where hb = prim2real $ quickhunk 0 "" "hb"
          k = prim2real $ quickhunk 0 "" "k"
          n = prim2real $ quickhunk 0 "" "n"
          b = prim2real $ quickhunk 1 "b" ""
          d = prim2real $ quickhunk 2 "" "d"
          d':/\:_ = merge (b :\/: d)
          --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)
          --k2 :>: n2 :>: NilFL :/\: _ =
          --    merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL)
          k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL)
          pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL)
          pair2m :: Sealed2 (RealPatch :> RealPatch)
                 -> Maybe (RealPatch :\/: RealPatch)
          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)
                                          return (xx :\/: y')

          i = prim2real $ quickhunk 0 "" "i"
          x = prim2real $ quickhunk 0 "" "x"
          xi = prim2real $ quickhunk 0 "xi" ""
          d3 :/\: _ = merge (xi :\/: d)
          _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)

commute_fails :: (MyEq p, Patchy p) => (p :> p -> Maybe (p :> p)) -> p :> p
              -> Maybe Doc
commute_fails c (x :> y) = do y' :> x' <- c (x :> y)
                              return $ redText "x" $$ showPatch x $$
                                       redText ":> y" $$ showPatch y $$
                                       redText "y'" $$ showPatch y' $$
                                       redText ":> x'" $$ showPatch x'