{-# OPTIONS -O2 -fglasgow-exts #-}
module Properties where
import Text.Printf
import Control.Monad
import Control.Arrow hiding (pure)
import Control.Applicative hiding ((<|>),many)
import Data.Maybe
import Data.Monoid
import Data.List
import System.IO
import System.Random hiding (next)
import qualified Data.Map as M
import Text.StringTemplate.Classes
import Text.StringTemplate.Instances
import Text.StringTemplate.Base
import Text.StringTemplate.Group
import Test.QuickCheck
import System.Environment
--import Debug.Trace
--mytrace h x = trace (h ++ ": " ++ x) $ x
main :: IO ()
main = do
args <- getArgs
let n = if null args then 100 else read (head args)
(results, passed) <- liftM unzip $ mapM
(\(s,a) -> printf "%-25s: " s >> a n) tests
printf "Passed %d tests!\n" (sum passed)
when (not . and $ results) $ fail "Not all tests passed!"
where
tests =
[("prop_paddedTrans" , mytest prop_paddedTrans),
("prop_constStr" , mytest prop_constStr),
("prop_emptyNulls" , mytest prop_emptyNulls),
("prop_fullNulls" , mytest prop_fullNulls),
("prop_substitution" , mytest prop_substitution),
("prop_separator" , mytest prop_separator),
("prop_attribs" , mytest prop_attribs),
("prop_comment" , mytest prop_comment),
("prop_ifelse" , mytest prop_ifelse),
("prop_simpleGroup" , mytest prop_simpleGroup)
]
{-----------------------------------------------------------------------
Limited tests for now: just for list juggling and some basic parsing.
-----------------------------------------------------------------------}
prop_paddedTrans (x::[Int]) (y::[Int]) (z::[Int]) n =
(length pt == length npt) &&
all (3 ==) (map length pt) &&
all (all (==n)) (zipWith unmerge (paddedTrans n pt) [x,y,z])
where pt = paddedTrans n [x,y,z]
npt = transpose [x,y,z]
unmerge xl@(x:xs) (y:ys)
| x == y = unmerge xs ys
| otherwise = xl
unmerge x y = x
prop_constStr (LitString x) = x == (toString . newSTMP $ x)
prop_emptyNulls (LitString x) (LitString y) i =
(concat . replicate (abs i) $ x) ==
(toString . newSTMP . concat . replicate (abs i) $ tmpl)
where tmpl = x++"$"++y++"$"
prop_fullNulls (LitString x) (LitString y) i =
length y > 0 ==>
(concat . replicate (abs i) $ x++y) ==
(toString . newSTMP . concat . replicate (abs i) $ tmpl)
where tmpl = x++"$"++y++";null='"++y++"'$"
prop_substitution (LitString x) (LitString y) (LitString z) i =
length y > 0 ==>
(concat . replicate (abs i) $ x++z) ==
(toString . setAttribute y z .
newSTMP . concat . replicate (abs i) $ tmpl)
where tmpl = x++"$"++y++"$"
prop_separator (LitString x) (LitString y) (LitString z) i =
length x > 0 ==>
(concat . intersperse z . replicate (abs i) $ y) ==
(toString . setAttribute x (replicate (abs i) y)
. newSTMP $ tmpl)
where tmpl = "$"++x++";separator='"++z++"'$"
prop_comment (LitString x) (LitString y) (LitString z) =
toString (newSTMP (x ++ "$!" ++ y ++ "!$" ++ z)) == x ++ z
prop_attribs (LitString x) i =
toString (setManyAttrib (replicate (abs i) ("f",x)) $ newSTMP "$f$")
== (concat . replicate (abs i) $ x)
prop_ifelse a b c d =
toString (setManyAttrib alist . newSTMP $ "$if(a)$a$elseif(b)$b$elseif(c)$c$else$$if(d)$d$else$e$endif$$endif$") == (fst . head . filter snd) alist
where alist = [("a",a),("b",b),("c",c),("d",d),("e",True)]
prop_simpleGroup (LitString x) (LitString y) (LitString z) (LitString t) =
length x > 0 && length y > 0 && length z > 0 && length t > 0
&& length (nub [x,y,z,t]) == 4 ==>
x == (toString . fromJust . getStringTemplate x $ grp)
where tm = newSTMP x
tm' = newSTMP $ "$"++y++"()$"
tmIt = newSTMP "$it$"
tm'' = newSTMP $ "$"++z++"():"++t++"()$"
grp = groupStringTemplates [(y,tm),(z,tm'),(t,tmIt),(x,tm'')]
newtype LitChar = LitChar {unLitChar :: Char} deriving Show
instance Arbitrary LitChar where
arbitrary = LitChar <$> choose ('a','z')
coarbitrary = undefined
newtype LitString = LitString String deriving Show
instance Arbitrary LitString where
arbitrary = LitString . map unLitChar <$> sized (\n -> choose (0,n) >>= vector)
coarbitrary = undefined
{--------------------------------------------------------------------
QuickCheck Driver: This lovely code borrowed wholesale from XMonad.
--------------------------------------------------------------------}
mytest :: Testable a => a -> Int -> IO (Bool, Int)
mytest a n = mycheck defaultConfig
{ configMaxTest=n
, configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] } a
mycheck :: Testable a => Config -> a -> IO (Bool, Int)
mycheck config a = do
rnd <- newStdGen
mytests config (evaluate a) rnd 0 0 []
mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)
mytests config gen rnd0 ntest nfail stamps
| ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)
| nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)
| otherwise =
do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
case ok result of
Nothing ->
mytests config gen rnd1 ntest (nfail+1) stamps
Just True ->
mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
Just False ->
putStr ( "Falsifiable after "
++ show ntest
++ " tests:\n"
++ unlines (arguments result)
) >> hFlush stdout >> return (False, ntest)
where
result = generate (configSize config ntest) rnd2 gen
(rnd1,rnd2) = split rnd0
done :: String -> Int -> [[String]] -> IO ()
done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
where
table = display . map entry . reverse . sort . map pairLength . group
. sort . filter (not . null) $ stamps
display [] = ".\n"
display [x] = " (" ++ x ++ ").\n"
display xs = ".\n" ++ unlines (map (++ ".") xs)
pairLength xss@(xs:_) = (length xss, xs)
entry (n, xs) = percentage n ntest ++ " "
++ concat (intersperse ", " xs)
percentage n m = show ((100 * n) `div` m) ++ "%"