Simple.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TemplateHaskell #-}
----------------------------------------------------------------------
-- |
-- Module      :  Test.Simple
-- Copyright   :  (c) Boris Sukholitko 2012
-- License     :  BSD3
-- 
-- Maintainer  :  boriss@gmail.com
-- Stability   :  experimental
-- 
-- Test.Simple is yet another testing library for Haskell. It has testing primitives
-- familiar to recovering Perl programmers :).
-- 
-- Here is example suitable for cabal test-suite integration. Note that TemplateHaskell
-- usage is optional and is needed for test failure locations only.
--
-- @
--{-\# LANGUAGE TemplateHaskell \#-}
--
--import Test.Simple
--import Control.Monad
--
--main :: IO ()
--main = testSimpleMain $ do
--          plan 7
--          ok True
--          is 1 1
--          isnt \"a\" \"b\"
--          like \"abcd\" \"bc\"
--          unlike \"a\" \"b\"
--          diag \"Successful so far, failures follow ...\"
--          $loc >> ok False \-\- location will be recorded
--          is \"a\" \"b\" >>= guard
--          diag \"I am not being called\" \-\- not reached because of the guard: MonadPlus FTW!
-- @
--
----------------------------------------------------------------------

module Test.Simple (
            -- * Types
            TestSimpleT, Likeable(isLike),
            
            -- * Main
            testSimpleMain, runTestSimple,
            
            -- * Plan
            plan,

            -- * Test functions
            ok, isnt, is, like, unlike, isRight,

            -- * Diagnostics
            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

-- | Is used in 'like', 'unlike' tests.
class Likeable a b where
    -- | Returns 'True' if @a@ is like @b@
    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] }

-- | Test.Simple is implemented as monad transformer.
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 failed = tsFailed s > 0
        let mismatch = (tsPlanned s /= tsCounter s)
        if failed
                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 (failed || mismatch)
    finOutput s = s { tsOutput = (StdOut $ "1.." ++ show (tsPlanned s)):(reverse $ tsOutput s) }
    isFailed s = tsFailed s > 0 || (tsPlanned s /= tsCounter s)

-- | Runs 'TestSimpleT' transformer. Returns whether the tests where successful and resulting
-- output.
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

-- | Runs 'TestSimpleT' transformer in 'IO'. Outputs results in TAP format.
-- Exits with error on test failure.
--
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

-- | Is @Bool@ ok?
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 " "

-- | Are values different?
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"

-- | Are values equal?
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)

-- | Is @a@ like @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)

-- | Is @a@ unlike @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)

-- | Is 'Either' right?
isRight :: (Monad m, Show a) => Either a b -> TestSimpleT m Bool
isRight (Right _) = ok True
isRight (Left a) = ok False >>? diagVals "got Left:" (quote a) "expected:" "Right"

-- | Outputs diagnostics message.
diag :: Monad m => String -> TestSimpleT m ()
diag s = modify (\st -> st { tsOutput = (StdErr $ "# " ++ s):(tsOutput st) })

-- | Sets expected number of tests. Running more or less tests is considered failure.
-- Note, that plans are composable, e.g:
--
-- @
-- (plan 1 >> ok True) >> (plan 1 >> ok True)
-- @
--
-- will expect 2 tests.
plan :: Monad m => Int -> TestSimpleT m ()
plan i = modify (\st -> st { tsPlanned = tsPlanned st + i })

-- | Records current location to output in case of failures.
-- Necessary caveat: failing later without updating location produces the last location recorded.
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