%  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.

\begin{code}
{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-}
#include "gadts.h"
module Darcs.Patch.Unit ( run_patch_unit_tests ) where

import Control.Monad ( unless )
import Data.Maybe ( catMaybes )
import FastPackedString
import Darcs.Sealed
import Darcs.Patch
import Darcs.Patch.Patchy ( mergeFL, Invert )
import Darcs.Patch.Real ( RealPatch, prim2real, is_consistent, is_forward, is_duplicate )
import Darcs.Patch.Test () -- for instance Eq Patch
import Darcs.Patch.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.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 Debug.Trace
-- #include "impossible.h"
\end{code}

\begin{code}
run_patch_unit_tests :: IO Int
run_patch_unit_tests =
    run_some_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
    ,do putStr "Checking prim join inverses using QuickCheck... "
        simpleCheck (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
    ,do putStr "Checking prim join commute using QuickCheck... "
        simpleCheck (unseal2 (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
    ,do putStr "Checking that readPatch and showPatch work on RealPatch... "
        simpleCheck (unseal $ patchFromTree $ (show_read :: RealPatch -> Maybe Doc))
    ,do putStr "Checking that readPatch and showPatch work on FL RealPatch... "
        simpleCheck (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
    ,do putStr "Checking that tree flattenings are consistent... "
        simpleCheck ((\b -> if b then Nothing else Just False) . prop_consistent_tree_flattenings)

    ,do putStr "Checking with quickcheck that real patches are consistent... "
        simpleCheck (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

    ,do putStr "Checking we can do merges using QuickCheck... "
        simpleCheck (prop_is_mergeable ::
                         Sealed (WithStartState RepoModel (Tree Prim))
                             -> Maybe (Tree RealPatch C(x)))
    ,do putStr "Checking again we can do merges using QuickCheck... "
        thoroughCheck 1000 (prop_is_mergeable ::
                                Sealed (WithStartState RepoModel (Tree Prim))
                                    -> Maybe (Tree RealPatch C(x)))

    ,do putStr "Checking recommute using QuickCheck Tree generator... "
        simpleCheck (unseal $ commutePairFromTree $
                    (recommute
                     (commute :: RealPatch :> RealPatch
                              -> Maybe (RealPatch :> RealPatch))))
    ,do putStr "Checking recommute using QuickCheck TWFP generator... "
        simpleCheck (unseal $ commutePairFromTWFP $
                    (recommute
                     (commute :: RealPatch :> RealPatch
                              -> Maybe (RealPatch :> RealPatch))))
    ,do putStr "Checking nontrivial recommute... "
        simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals)
                                   (unseal $ commutePairFromTree $
                                    (recommute
                                     (commute :: RealPatch :> RealPatch
                                              -> Maybe (RealPatch :> RealPatch))))
    ,do putStr "Checking nontrivial recommute using TWFP... "
        simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals)
                                   (unseal $ commutePairFromTWFP $
                                    (recommute
                                     (commute :: RealPatch :> RealPatch
                                              -> Maybe (RealPatch :> RealPatch))))

    ,do putStr "Checking inverses commute using QuickCheck Tree generator... "
        simpleCheck (unseal $ commutePairFromTree $
                    (commute_inverses
                     (commute :: RealPatch :> RealPatch
                              -> Maybe (RealPatch :> RealPatch))))
    ,do putStr "Checking inverses commute using QuickCheck TWFP generator... "
        simpleCheck (unseal $ commutePairFromTWFP $
                    (commute_inverses
                     (commute :: RealPatch :> RealPatch
                              -> Maybe (RealPatch :> RealPatch))))
    ,do putStr "Checking nontrivial inverses commute... "
        simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals)
                                   (unseal $ commutePairFromTree $
                                    (commute_inverses
                                     (commute :: RealPatch :> RealPatch
                                              -> Maybe (RealPatch :> RealPatch))))
    ,do putStr "Checking nontrivial inverses commute using TWFP... "
        simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals)
                                   (unseal $ commutePairFromTWFP $
                                    (commute_inverses
                                     (commute :: RealPatch :> RealPatch
                                              -> Maybe (RealPatch :> RealPatch))))

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

    ,do putStr "Checking permutivity... "
        simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple)
            (unseal $ commuteTripleFromTree $ permutivity
                    (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))
    ,do putStr "Checking partial permutivity... "
        simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple)
            (unseal $ commuteTripleFromTree $ partial_permutivity
                    (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))
    ,do putStr "Checking nontrivial permutivity... "
        simpleConditionalCheck (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_some_tests :: String -> [IO Int] -> IO Int
run_some_tests name ts = do unless (null name) $ putStr $ "Testing " ++ name ++ "... "
                            errs <- sum `fmap` sequence ts
                            unless (null name) $
                                   if errs < 1
                                   then putStrLn "passed."
                                   else putStrLn $ "failed " ++ name ++" in "++ show errs ++ " tests."
                            return errs

run_primitive_tests :: (Show a, Show b) => String -> (a -> Maybe b) -> [a] -> IO Int
run_primitive_tests name test datas = run_some_tests name $ map test' datas
    where test' d = case test d of
                    Just e -> do putStrLn $ name ++ " failed!"
                                 putStrLn $ "Input: " ++ show d
                                 putStrLn $ "Output: " ++ show e
                                 return 1
                    Nothing -> return 0

\end{code}

\begin{code}
quickhunk :: Int -> String -> String -> Prim
quickhunk l o n = hunk "test" l (map (\c -> packString [c]) o)
                                (map (\c -> packString [c]) n)
\end{code}

\begin{code}
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]

unsafeUnseal2 :: Sealed2 p -> p
unsafeUnseal2 (Sealed2 p) = p

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)

\end{code}

\begin{code}
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'

\end{code}