{-
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)