module Test3 where
import Arbitrary3
import Monad
import IOExtensions

data Property = P (Generator Result)
unP (P x) = x

data Result = Tested [String] Bool Bool | NotTested
--                   arguments
--                            result of test
--                                 true in a trivial case

class Testable a where
  property :: a -> Property

instance Testable Property where
  property = id

instance Testable Bool where
  property b = P (return$ Tested [] b False)

forAll g f = P$ do a<-g
                   r<-unP (property (f a))
                   return$ case r of
                     Tested xs b t -> Tested (show a:xs) b t
                     NotTested -> NotTested
                 
instance (Arbitrary a, Show a, Testable b) => Testable (a->b) where
  property f = forAll arbitrary f

data Implication = Implies Bool Property

instance Testable Implication where
  property (Implies p (P q)) = P$
    if p then q else return NotTested

infixr 0 ==>
p ==> q = Implies p (property q)

data TrivialIf = TrivialIf Bool Property

instance Testable TrivialIf where
  property (TrivialIf p (P q)) = P$
    do r<-q
       case r of
         NotTested -> return NotTested
         Tested xs b t -> return (Tested xs b (t||p))

trivialIf b p = TrivialIf b (property p)

--============================================================================
-- The checker itself
--============================================================================

data CheckResult = 
  PassedAllTests Int | PassedSomeTests Int Int | FailedOnTest Int [String]

runCheck report p =
  do r<-checks report p
     case r of
       PassedAllTests t -> 
         putStr ("OK: passed "++show ntests++" tests"++showTriv t ntests)
       PassedSomeTests n t ->  
         putStr ("Arguments exhausted after passing "++show n++" tests"++
                 showTriv t n)
       FailedOnTest n xs -> 
         putStr ("Test failed on "++nth n++" attempt on:\n"++unlines xs)

checks report p =
  let P p' = property p in
  do xs<-runGenerator 2 
           (foldr (\_ ps -> liftM2 (:) p' (bigger ps)) (return []) 
                  [1..2*ntests])
     let tests = take ntests [(vs,b,t) | Tested vs b t<-xs]
     report tests
     let (successes,failure) = span (\(vs,b,t)->b) tests
         nsuccesses = length successes
         ntriv = (length (filter (\(vs,b,t)->t) successes))
         (failingData,_,_):_ = failure
     if length successes==ntests
       then return (PassedAllTests ntriv)
       else if null failure
       then return (PassedSomeTests nsuccesses ntriv)
       else return (FailedOnTest (length successes+1) failingData)
     

ntests = 100 :: Int

nth 0 = "0th"
nth 1 = "1st"
nth 2 = "2nd"
nth 3 = "3rd"
nth n | n<20 = show n++"th"
nth n = show (n`div`10)++nth(n`mod`10)

quickCheck x = unixQuickCheck x

unixQuickCheck p = runCheck (countup 0) p

winQuickCheck s p = do putStr (s++": ")
                       runCheck (countup 0) p

countup n xs = do putStr (temporary (show n))
                  case xs of
                    [] -> return ()
                    (x,b,t):xs' -> if b then countup (n+1) xs' else return ()

temporary s = s++concat (map (const bs) s)
bs = "\b"

verboseCheck p = runCheck verbose p

verbose ((xs,b,t):ts) =
  do putStr "Testing:\n"
     putStr (unlines xs)
     if t then putStr "(trivial)\n" else return ()
     if b then verbose ts else return ()
verbose [] = return ()


coverage p =
  let P p' = property p in
  do xs<-runGenerator 2 
           (foldr (\_ ps -> liftM2 (:) p' (bigger ps)) (return []) 
                  [1..2*ntests])
     let tests = take ntests [(vs,b,t) | Tested vs b t<-xs]
         successes = [(vs,t) | (vs,True,t)<-tests]
         trivs = [vs | (vs,True)<-successes]
     count 0 0 0 tests
     if null tests then
       putStr "No tests performed, because no arguments could be generated"
       else
         do
           putStr ("Coverage: "++percentage (length successes) (length tests)++
                   showTriv (length trivs) (length successes))
           if length tests < ntests then
               putStr (" of "++show (length tests)++" tests")
             else return ()
  where count m n p xs = do putStr (temporary 
                              (show m++" of "++show n++showTriv p n))
                            case xs of
                              [] -> return ()
                              (vs,b,t):xs' -> 
                                count (m+if b then 1 else 0) 
                                      (n+1) 
                                      (p+if t then 1 else 0)
                                      xs'

percentage m 0 = "0/0%"
percentage m n = show (m*100`div`n)++"%"  

showTriv t n =
  if 3*t<=n then "" else
    " ("++percentage t n++" trivial cases)"