module Test.Simple (
TestSimpleT, Likeable(isLike),
testSimpleMain, runTestSimple, qcTestSimpleMain,
plan,
ok, isnt, is, like, unlike, isRight,
loc, diag, diagen) where
import Control.Monad.Trans.State.Plus
import Control.Monad.State
import System.Exit (exitFailure)
import Data.List (isInfixOf, intercalate)
import System.IO (hPutStrLn, stderr)
import qualified Language.Haskell.TH as TH
import Test.QuickCheck (Testable(property), quickCheckResult, Gen)
import Test.QuickCheck.Test (isSuccess)
import Test.QuickCheck.Property (Result(reason), succeeded, failed)
class Likeable a b where
isLike :: a -> b -> Bool
instance Eq a => Likeable [a] [a] where
isLike = flip isInfixOf
data TSOutput = StdOut String | StdErr String
data TSState = TSS { tsCounter :: Int, tsFailed :: Int, tsPlanned :: Int, tsLoc :: Maybe TH.Loc
, tsOutput :: [TSOutput] }
newtype TestSimpleT m a = MkTST { unTST :: StatePlusT TSState m a }
deriving (Functor, MonadTrans, Monad, MonadPlus
, MonadState TSState, MonadIO)
emptyState :: TSState
emptyState = TSS 0 0 0 Nothing []
finishTS :: Monad m => TestSimpleT m a -> m (Bool, TSState)
finishTS m = do
ms <- execStatePlusT (unTST m) emptyState
finState <- execStatePlusT (unTST finish) ms
return (not $ isFailed finState, finState)
where
finish = do
s <- get
let fld = tsFailed s > 0
let mismatch = (tsPlanned s /= tsCounter s)
if fld
then diag $ "Looks like you failed " ++ show (tsFailed s)
++ " test of " ++ show (tsPlanned s) ++ "."
else if mismatch
then diag $ "Looks like you planned " ++ show (tsPlanned s)
++ " tests but ran " ++ show (tsCounter s) ++ "."
else return ()
modify finOutput
return $ not (fld || mismatch)
finOutput s = s { tsOutput = (StdOut $ "1.." ++ show (tsPlanned s)):(reverse $ tsOutput s) }
isFailed s = tsFailed s > 0 || (tsPlanned s /= tsCounter s)
runTestSimple :: Monad m => TestSimpleT m a -> m (Bool, [String])
runTestSimple m = do
(b, s) <- finishTS m
return (b, map toStr $ tsOutput s)
where toStr (StdOut str) = str
toStr (StdErr str) = str
testSimpleMain :: MonadIO m => TestSimpleT m a -> m ()
testSimpleMain m = do
(b, s) <- finishTS m
liftIO $ do
mapM_ printLine $ tsOutput s
unless b exitFailure
where printLine (StdOut s) = putStrLn s
printLine (StdErr s) = hPutStrLn stderr s
ok :: Monad m => Bool -> TestSimpleT m Bool
ok b = do
s <- get
let oks = "ok " ++ show (tsCounter s + 1)
put $ s { tsCounter = (tsCounter s) + 1
, tsFailed = (tsFailed s) + if b then 0 else 1
, tsOutput = (StdOut $ if b then oks else "not " ++ oks):(tsOutput s)
}
unless b $ diag $ concat [ " Failed test", showLoc s ]
return b
showLoc :: TSState -> String
showLoc s = " at " ++ go (tsLoc s) ++ "." where
go Nothing = "unknown location"
go (Just l) = concat [ TH.loc_filename l, " line ", show $ fst $ TH.loc_start l ]
(>>?) :: Monad m => m Bool -> m () -> m Bool
m >>? d = do
b <- m
unless b d
return b
diagVals :: Monad m => String -> String -> String -> String-> TestSimpleT m ()
diagVals as a bs b = do
diag $ concat [ spaces, as, " ", a ]
diag $ concat [ bs, " ", b ]
where spaces = take (length bs length as) $ cycle " "
isnt :: (Eq a, Show a, Monad m) => a -> a -> TestSimpleT m Bool
isnt a b = ok (a /= b) >>? diagVals "got:" (show a) "expected:" "anything else"
is :: (Eq a, Show a, Monad m) => a -> a -> TestSimpleT m Bool
is a b = ok (a == b) >>? diagVals "got:" (show a) "expected:" (show b)
like :: (Show a, Show b, Likeable a b, Monad m) => a -> b -> TestSimpleT m Bool
like a b = ok (isLike a b) >>? diagVals "" (show a) "doesn't match" (show b)
unlike :: (Show a, Show b, Likeable a b, Monad m) => a -> b -> TestSimpleT m Bool
unlike a b = ok (not $ isLike a b) >>? diagVals "" (show a) "matches" (show b)
isRight :: (Monad m, Show a) => Either a b -> TestSimpleT m Bool
isRight (Right _) = ok True
isRight (Left a) = ok False >>? diagVals "got Left:" (show a) "expected:" "Right"
diag :: Monad m => String -> TestSimpleT m ()
diag s = modify (\st -> st { tsOutput = (StdErr $ "# " ++ s):(tsOutput st) })
plan :: Monad m => Int -> TestSimpleT m ()
plan i = modify (\st -> st { tsPlanned = tsPlanned st + i })
loc :: TH.Q TH.Exp
loc = do
l <- TH.location
let ql = liftLoc l
[| modify (\s -> s { tsLoc = Just $ql }) |]
liftLoc :: TH.Loc -> TH.Q TH.Exp
liftLoc l = [| TH.Loc f p m s e |] where
f = TH.loc_filename l
p = TH.loc_package l
m = TH.loc_module l
s = TH.loc_start l
e = TH.loc_end l
instance Testable (TestSimpleT Gen a) where
property m = do
(b, lns) <- runTestSimple m
property $ if b then succeeded else failed { reason = intercalate "\n" lns }
qcTestSimpleMain :: (Testable (m a), Monad m) => m a -> IO ()
qcTestSimpleMain m = do
res <- quickCheckResult m
unless (isSuccess res) exitFailure
diagen :: Show a => String -> Gen a -> TestSimpleT Gen a
diagen msg gen = do
a <- lift gen
s <- get
diag $ concat [ msg, ": ", show a, showLoc s ]
return a