module Test.Simple (
TestSimpleT, Likeable(isLike),
testSimpleMain,
plan,
ok, isnt, is, like, unlike,
loc, diag) where
import Control.Monad.Trans.State.Plus
import Control.Monad.State
import System.Exit (exitFailure)
import Data.List (isInfixOf)
import System.IO (hPutStrLn, stderr)
import qualified Language.Haskell.TH as TH
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 []
testSimpleMain :: MonadIO m => TestSimpleT m a -> m ()
testSimpleMain (MkTST sm) = do
s <- execStatePlusT sm emptyState
liftIO $ do
putStrLn $ "1.." ++ show (tsPlanned s)
mapM_ printLine $ reverse (tsOutput s)
let mismatch = (tsPlanned s /= tsCounter s)
let failed = tsFailed s > 0;
when mismatch $ hPutStrLn stderr $ "# Looks like you planned " ++ show (tsPlanned s)
++ " tests but ran " ++ show (tsCounter s) ++ "."
when failed $ hPutStrLn stderr $ "# Looks like you failed " ++ show (tsFailed s)
++ " test of " ++ show (tsPlanned s) ++ "."
when (failed || mismatch) 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 $ diagFailed (tsLoc s)
return b
where diagFailed (Just l) = diag $ concat [
" Failed test at ", TH.loc_filename l, " line ", show $ fst $ TH.loc_start l ]
diagFailed _ = diag $ " Failed test at unknown location."
(>>?) :: Monad m => m Bool -> m () -> m Bool
m >>? d = do
b <- m
unless b d
return b
quote :: Show a => a -> String
quote a = "'" ++ show a ++ "'"
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:" (quote a) "expected:" "anything else"
is :: (Eq a, Show a, Monad m) => a -> a -> TestSimpleT m Bool
is a b = ok (a == b) >>? diagVals "got:" (quote a) "expected:" (quote b)
like :: (Show a, Show b, Likeable a b, Monad m) => a -> b -> TestSimpleT m Bool
like a b = ok (isLike a b) >>? diagVals "" (quote a) "doesn't match" (quote 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 "" (quote a) "matches" (quote b)
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