{- 
    Copyright 2011 Mario Blazevic

    This file is part of the Streaming Component Combinators (SCC) project.

    The SCC project 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 3 of the License, or (at your option) any later
    version.

    SCC 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 SCC.  If not, see
    <http://www.gnu.org/licenses/>.
-}

-- | This module contains tests of "Text.ParserCombinators.Incremental" module.

{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-}

module Main where

import Control.Applicative (Alternative, empty, (*>), (<|>))
import Control.Monad (liftM, liftM2)
import Data.List (find, minimumBy, nub, sort)
import Data.Monoid (Monoid(..))
import System.Environment (getArgs)

import Test.QuickCheck (Arbitrary(..), Gen, Property, property, (==>), (.&&.), forAll, oneof, resize, sized, verbose,
                        whenFail)
import Test.QuickCheck.Checkers (Binop, EqProp(..), TestBatch, isAssoc, leftId, rightId, verboseBatch)
import Test.QuickCheck.Classes (functor, monad, monoid, applicative, monadFunctor, monadApplicative, monadOr)

import Text.ParserCombinators.Incremental (Parser, feedEof, feed, completeResults,
                                           (><), (<<|>),
                                           anyToken, eof, lookAhead, notFollowedBy, satisfy, skip, token, string,
                                           showWith)

main = do args <- getArgs 
          case args of [] -> mapM_ verboseBatch tests
                       _ -> mapM_ (\batch-> maybe (error ("No test batch named " ++ batch)) verboseBatch 
                                            (find ((batch ==) . fst) tests)) args

parser2 :: Parser [Bool] (String, String)
parser2 = undefined

parser3 :: Parser [Bool] (String, String, String)
parser3 = undefined

tests :: [TestBatch]
tests = [monoid parser3,
         functor parser3,
         applicative parser3,
         alternative parser2,
         monad parser3,
         monadFunctor parser2,
         monadApplicative parser2,
         monadOr parser2,
         primitives,
         lookAheadBatch,
         join]

-- | Properties to check that the 'Alternative' @m@ satisfies the alternative
-- properties
alternative :: forall m a b.
               ( Alternative m
               , Arbitrary (m a), Arbitrary (m b)
               , Show (m a), Show (m b)
               , EqProp (m a), EqProp (m b)
               ) =>
               m (a,b) -> TestBatch
alternative = const ( "alternative"
                    , [ ("left zero"     , property leftZeroP)
                      , ("right zero"    , property rightZeroP)
                      , ("left identity" , leftId (<|>) (empty :: m a))
                      , ("right identity", rightId (<|>) (empty :: m a))
                      , ("associativity" , isAssoc ((<|>) :: Binop (m a)))
                      , ("left distribution", property leftDistP)
                      ]
                    )
 where
   leftZeroP :: m a -> Property
   rightZeroP :: m a -> Property
   leftDistP :: m a -> m a -> m b -> Property

   leftZeroP k = (empty *> k) =-= empty
   rightZeroP k = (k *> empty) =-= (empty :: m b)
   leftDistP a b k = ((a <|> b) *> k) =-= ((a *> k) <|> (b *> k))

primitives :: TestBatch
primitives = ("primitives",
              [("anyToken EOF", feedEof (anyToken :: Parser [Bool] [Bool]) =-= empty),
               ("anyToken list", property tokenListP),
               ("token", property tokenP),
               ("token = satisfy . (==)", property tokenSatisfyP),
               ("satisfy not", property satisfyNotP),
               ("satisfy or not", property satisfyOrNotP),
               ("string", property stringP),
               ("feed eof", property feedEofP),
               ("feedEof eof", property feedEofEofP)])
   where tokenListP :: Bool -> [Bool] -> Property
         tokenP :: Bool -> [Bool] -> Property
         tokenSatisfyP :: Bool -> Property
         satisfyNotP :: (Bool -> Bool) -> Property
         satisfyOrNotP :: (Bool -> Bool) -> Property
         stringP :: [Bool] -> [Bool] -> Property
         feedEofP :: [Bool] -> Property
         feedEofEofP :: Bool
         
         tokenListP x xs = canonicalResults (feed (x:xs) anyToken) =-= [([x], xs)]
         tokenP x xs = canonicalResults (feed (x:xs) (token [x])) =-= [([x], xs)]
         tokenSatisfyP x = token [x] =-= satisfy (== [x])
         satisfyNotP pred = satisfy (pred . head) =-= (notFollowedBy (satisfy (not . pred . head)) >< anyToken)
         satisfyOrNotP pred = (satisfy (pred . head) <|> satisfy (not . pred . head)) =-= anyToken
         stringP xs ys = xs /= [] ==> canonicalResults (feed (xs ++ ys) (string xs)) =-= [(xs, ys)]
         feedEofP x = x /= [] ==> feed x eof =-= (empty :: Parser [Bool] String)
         feedEofEofP = canonicalResults (feedEof eof :: Parser [Bool] String) == [([], [])]

lookAheadBatch :: TestBatch
lookAheadBatch = ("lookAhead",
                  [("lookAhead", property lookAheadP),
                   ("lookAhead p >> p", property lookAheadConsumeP),
                   ("notFollowedBy p >< p", property lookAheadNotOrP),
                   ("not not", property lookAheadNotNotP),
                   ("lookAhead anyToken", property lookAheadTokenP)])
   where lookAheadP :: [Bool] -> Parser [Bool] String -> Bool
         lookAheadConsumeP :: Parser [Bool] String -> Property
         lookAheadNotOrP :: Parser [Bool] String -> Property
         lookAheadNotNotP :: Parser [Bool] String -> Property
         lookAheadTokenP :: Bool -> [Bool] -> Bool
         
         lookAheadP xs p = completeResults (feed xs $ lookAhead p)
                           == map (\(r, _)-> (r, xs)) (completeResults (feed xs p))
         lookAheadConsumeP p = (lookAhead p >> p) =-= p
         lookAheadNotOrP p = (notFollowedBy p >< p) =-= empty
         lookAheadNotNotP p = notFollowedBy (notFollowedBy p :: Parser [Bool] ()) =-= (skip (lookAhead p) :: Parser [Bool] ())
         lookAheadTokenP x xs = canonicalResults (feed (x:xs) (lookAhead anyToken)) == [([x], x:xs)]

instance (Eq x, Monoid x, Ord x, Show x) => EqProp (Parser [Bool] x) where
   p1 =-= p2 = sameResults (feedEof p1) (feedEof p2)
               .&&. halveSize (\s-> sized $ \n-> whenFail (print (n, s, p1, p2)) (feed s p1 =-= feed s p2)) arbitrary
      where sameResults p1 p2 = whenFail (print (canonicalResults p1) >> putStrLn "  !=" >> print (canonicalResults p2)
                                          >> putStrLn "  =>" >> print p1 >> putStrLn "  !=" >> print p2)
                                         (canonicalResults p1 == canonicalResults p2)

join :: TestBatch
join = ("join",
        [("empty ><", property leftZeroP),
         (">< empty", property rightZeroP),
         ("(<|>) ><", property leftDistP),
         (">< (<|>)", property rightDistP),
         ("><", property joinP)])
   where leftZeroP :: Parser [Bool] String -> Property
         rightZeroP :: Parser [Bool] String -> Property
         leftDistP :: Parser [Bool] String -> Parser [Bool] String -> Parser [Bool] String -> Property
         rightDistP :: Parser [Bool] String -> Parser [Bool] String -> Parser [Bool] String -> Property
         joinP :: [Bool] -> Parser [Bool] String -> Parser [Bool] String -> Bool

         leftZeroP k = (empty >< k) =-= empty
         rightZeroP k = (k >< empty) =-= empty
         leftDistP a b k = ((a <|> b) >< k) =-= ((a >< k) <|> (b >< k))
         rightDistP k a b = (k >< (a <|> b)) =-= ((k >< a) <|> (k >< b))
         joinP input a b = canonicalResults (feed input (a >< b))
                           == sort (nub [(r1 ++ r2, rest') 
                                        | (r1, rest) <- canonicalResults (feed input a),
                                          (r2, rest') <- completeResults (feed rest b)])

canonicalResults p = sort $ nub $ completeResults p

instance (Arbitrary r, Monoid r) => Arbitrary (Parser [Bool] r) where
   arbitrary = sized $ 
               \n-> resize (min 50 n) $
                    oneof [return empty,
                           reduceSize return arbitrary,
                           splitSize (><) (liftM return arbitrary) arbitrary,
                           splitSize (<|>) arbitrary arbitrary,
                           splitSize (<<|>) arbitrary arbitrary,
                           reduceSize (anyToken >>) arbitrary,
                           reduceSize (satisfy head >>) arbitrary,
                           reduceSize (satisfy (not . head) >>) arbitrary,
                           reduceSize lookAhead arbitrary,
                           reduceSize notFollowedBy (arbitrary :: Gen (Parser [Bool] r))]

instance (Monoid r, Show r) => Show (Parser [Bool] r) where
   show p = showWith (showBoolFun show) show p

instance Monoid Bool where
   mempty = False
   mappend = (||)

showBoolFun :: (r -> String) -> ([Bool] -> r) -> String
showBoolFun show f = "\\[b]-> if b then " ++ show (f [True]) ++ " else " ++ show (f [False])

splitSize :: (a -> b -> c) -> Gen a -> Gen b -> Gen c
splitSize f a b = sized $ \n-> liftM2 f (resize (div n 2) a) (resize (div n 2) b)

reduceSize :: (a -> b) -> Gen a -> Gen b
reduceSize f a = sized $ \n-> liftM f (resize (if n > 0 then pred n else n) a)

halveSize :: (a -> Property) -> Gen a -> Property
halveSize f a = sized $ \n-> if n < 2 then property True else resize (n `div` 2) (a >>= f)