module Test.Chell
(
defaultMain
, Suite
, suite
, suiteName
, suiteTests
, test
, skipIf
, skipWhen
, Assertion (..)
, AssertionResult (..)
, IsAssertion
, Assertions
, assertions
, assert
, expect
, Test.Chell.fail
, trace
, note
, equal
, notEqual
, equalWithin
, just
, nothing
, left
, right
, throws
, throwsEq
, greater
, greaterEqual
, lesser
, lesserEqual
, sameItems
, equalItems
, IsText
, equalLines
, Test (..)
, testName
, runTest
, TestOptions
, testOptionSeed
, testOptionTimeout
, TestResult (..)
, Failure (..)
, Location (..)
) where
import qualified Control.Applicative
import qualified Control.Exception
import Control.Exception (Exception)
import Control.Monad (ap, liftM, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.Algorithm.Patience as Patience
import qualified Data.ByteString.Char8
import qualified Data.ByteString.Lazy.Char8
import Data.Foldable (Foldable, foldMap)
import Data.List (foldl', intercalate, sort)
import Data.Maybe (isJust, isNothing)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import qualified Data.Text
import Data.Text (Text)
import qualified Data.Text.Lazy
import qualified Data.Text.IO
import qualified Language.Haskell.TH as TH
import Test.Chell.Main (defaultMain)
import Test.Chell.Types
testOptionSeed :: TestOptions -> Int
testOptionSeed = testOptionSeed_
testOptionTimeout :: TestOptions -> Maybe Int
testOptionTimeout = testOptionTimeout_
skipIf :: Bool -> Suite -> Suite
skipIf skip = if skip then step else id where
step (SuiteTest (Test name _)) = SuiteTest
(Test name (\_ -> return TestSkipped))
step (Suite name suites) = Suite name (map step suites)
skipWhen :: IO Bool -> Suite -> Suite
skipWhen p = step where
step (SuiteTest (Test name io)) = SuiteTest (Test name (\opts -> do
skip <- p
if skip then return TestSkipped else io opts))
step (Suite name suites) = Suite name (map step suites)
newtype Assertion = Assertion (IO AssertionResult)
data AssertionResult
= AssertionPassed
| AssertionFailed Text
class IsAssertion a where
toAssertion :: a -> Assertion
instance IsAssertion Assertion where
toAssertion = id
instance IsAssertion Bool where
toAssertion x = Assertion (return (if x
then AssertionPassed
else AssertionFailed "$assert: boolean assertion failed"))
type TestState = (IORef [(Text, Text)], [Failure])
newtype Assertions a = Assertions { unAssertions :: TestState -> IO (Maybe a, TestState) }
instance Functor Assertions where
fmap = liftM
instance Control.Applicative.Applicative Assertions where
pure = return
(<*>) = ap
instance Monad Assertions where
return x = Assertions (\s -> return (Just x, s))
m >>= f = Assertions (\s -> do
(maybe_a, s') <- unAssertions m s
case maybe_a of
Nothing -> return (Nothing, s')
Just a -> unAssertions (f a) s')
instance MonadIO Assertions where
liftIO io = Assertions (\s -> do
x <- io
return (Just x, s))
assertions :: Text -> Assertions a -> Suite
assertions name testm = test (Test name io) where
io opts = do
noteRef <- newIORef []
let getNotes = fmap reverse (readIORef noteRef)
let getResult = do
res <- unAssertions testm (noteRef, [])
case res of
(_, (_, [])) -> do
notes <- getNotes
return (TestPassed notes)
(_, (_, fs)) -> do
notes <- getNotes
return (TestFailed notes (reverse fs))
handleJankyIO opts getResult getNotes
addFailure :: Maybe TH.Loc -> Text -> Assertions ()
addFailure maybe_loc msg = Assertions $ \(notes, fs) -> do
let loc = do
th_loc <- maybe_loc
return $ Location
{ locationFile = Data.Text.pack (TH.loc_filename th_loc)
, locationModule = Data.Text.pack (TH.loc_module th_loc)
, locationLine = toInteger (fst (TH.loc_start th_loc))
}
return (Just (), (notes, Failure loc msg : fs))
die :: Assertions a
die = Assertions (\s -> return (Nothing, s))
fail :: TH.Q TH.Exp
fail = do
loc <- TH.location
let qloc = liftLoc loc
[| \msg -> addFailure (Just $qloc) msg >> die |]
trace :: Text -> Assertions ()
trace msg = liftIO (Data.Text.IO.putStrLn msg)
note :: Text -> Text -> Assertions ()
note key value = Assertions (\(notes, fs) -> do
modifyIORef notes ((key, value) :)
return (Just (), (notes, fs)))
liftLoc :: TH.Loc -> TH.Q TH.Exp
liftLoc loc = [| TH.Loc filename package module_ start end |] where
filename = TH.loc_filename loc
package = TH.loc_package loc
module_ = TH.loc_module loc
start = TH.loc_start loc
end = TH.loc_end loc
assertAt :: IsAssertion assertion => TH.Loc -> Bool -> assertion -> Assertions ()
assertAt loc fatal assertion = do
let Assertion io = toAssertion assertion
result <- liftIO io
case result of
AssertionPassed -> return ()
AssertionFailed err -> do
addFailure (Just loc) err
when fatal die
assert :: TH.Q TH.Exp
assert = do
loc <- TH.location
let qloc = liftLoc loc
[| assertAt $qloc True |]
expect :: TH.Q TH.Exp
expect = do
loc <- TH.location
let qloc = liftLoc loc
[| assertAt $qloc False |]
pure :: Bool -> String -> Assertion
pure True _ = Assertion (return AssertionPassed)
pure False err = Assertion (return (AssertionFailed (Data.Text.pack err)))
equal :: (Show a, Eq a) => a -> a -> Assertion
equal x y = pure (x == y) ("equal: " ++ show x ++ " is not equal to " ++ show y)
notEqual :: (Eq a, Show a) => a -> a -> Assertion
notEqual x y = pure (x /= y) ("notEqual: " ++ show x ++ " is equal to " ++ show y)
equalWithin :: (Real a, Show a) => a -> a
-> a
-> Assertion
equalWithin x y delta = pure
((x delta <= y) && (x + delta >= y))
("equalWithin: " ++ show x ++ " is not within " ++ show delta ++ " of " ++ show y)
just :: Maybe a -> Assertion
just x = pure (isJust x) ("just: received Nothing")
nothing :: Maybe a -> Assertion
nothing x = pure (isNothing x) ("nothing: received Just")
left :: Either a b -> Assertion
left x = pure (isLeft x) ("left: received Right") where
isLeft (Left _) = True
isLeft (Right _) = False
right :: Either a b -> Assertion
right x = pure (isRight x) ("right: received Left") where
isRight (Left _) = False
isRight (Right _) = True
throws :: Exception err => (err -> Bool) -> IO a -> Assertion
throws p io = Assertion (do
either_exc <- Control.Exception.try io
return (case either_exc of
Left exc -> if p exc
then AssertionPassed
else AssertionFailed (Data.Text.pack ("throws: exception " ++ show exc ++ " did not match predicate"))
Right _ -> AssertionFailed (Data.Text.pack ("throws: no exception thrown"))))
throwsEq :: (Eq err, Exception err, Show err) => err -> IO a -> Assertion
throwsEq expected io = Assertion (do
either_exc <- Control.Exception.try io
return (case either_exc of
Left exc -> if exc == expected
then AssertionPassed
else AssertionFailed (Data.Text.pack ("throwsEq: exception " ++ show exc ++ " is not equal to " ++ show expected))
Right _ -> AssertionFailed (Data.Text.pack ("throwsEq: no exception thrown"))))
greater :: (Ord a, Show a) => a -> a -> Assertion
greater x y = pure (x > y) ("greater: " ++ show x ++ " is not greater than " ++ show y)
greaterEqual :: (Ord a, Show a) => a -> a -> Assertion
greaterEqual x y = pure (x > y) ("greaterEqual: " ++ show x ++ " is not greater than or equal to " ++ show y)
lesser :: (Ord a, Show a) => a -> a -> Assertion
lesser x y = pure (x < y) ("lesser: " ++ show x ++ " is not less than " ++ show y)
lesserEqual :: (Ord a, Show a) => a -> a -> Assertion
lesserEqual x y = pure (x <= y) ("lesserEqual: " ++ show x ++ " is not less than or equal to " ++ show y)
sameItems :: (Foldable container, Show item, Ord item) => container item -> container item -> Assertion
sameItems x y = equalDiff' "sameItems" sort x y
equalItems :: (Foldable container, Show item, Ord item) => container item -> container item -> Assertion
equalItems x y = equalDiff' "equalItems" id x y
equalDiff' :: (Foldable container, Show item, Ord item)
=> String
-> ([item]
-> [item])
-> container item
-> container item
-> Assertion
equalDiff' label norm x y = checkDiff (items x) (items y) where
items = norm . foldMap (:[])
checkDiff xs ys = case checkItems (Patience.diff xs ys) of
(same, diff) -> pure same diff
checkItems diffItems = case foldl' checkItem (True, []) diffItems of
(same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))
checkItem (same, acc) item = case item of
Patience.Old t -> (False, ("\t- " ++ show t) : acc)
Patience.New t -> (False, ("\t+ " ++ show t) : acc)
Patience.Both t _-> (same, ("\t " ++ show t) : acc)
errorMsg diff = label ++ ": items differ\n" ++ diff
class IsText a where
toLines :: a -> [a]
unpack :: a -> String
instance IsText String where
toLines = lines
unpack = id
instance IsText Text where
toLines = Data.Text.lines
unpack = Data.Text.unpack
instance IsText Data.Text.Lazy.Text where
toLines = Data.Text.Lazy.lines
unpack = Data.Text.Lazy.unpack
instance IsText Data.ByteString.Char8.ByteString where
toLines = Data.ByteString.Char8.lines
unpack = Data.ByteString.Char8.unpack
instance IsText Data.ByteString.Lazy.Char8.ByteString where
toLines = Data.ByteString.Lazy.Char8.lines
unpack = Data.ByteString.Lazy.Char8.unpack
equalLines :: (Ord a, IsText a) => a -> a -> Assertion
equalLines x y = checkDiff (toLines x) (toLines y) where
checkDiff xs ys = case checkItems (Patience.diff xs ys) of
(same, diff) -> pure same diff
checkItems diffItems = case foldl' checkItem (True, []) diffItems of
(same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))
checkItem (same, acc) item = case item of
Patience.Old t -> (False, ("\t- " ++ unpack t) : acc)
Patience.New t -> (False, ("\t+ " ++ unpack t) : acc)
Patience.Both t _-> (same, ("\t " ++ unpack t) : acc)
errorMsg diff = "equalLines: lines differ\n" ++ diff