-- This file is just my unit-testing library. {-# language BlockArguments #-} {-# language DeriveDataTypeable #-} {-# language ScopedTypeVariables #-} module TestLib( Test(..), (~:), Cond(..), checkCond, Rel(..), checkRel, checkEq, (~?=), (~=?), (~&&), (~||), testlibMain ) where import Control.Exception (Exception, SomeException, evaluate, throwIO, try) import Control.Monad (foldM, unless) import Data.List import Data.Typeable (Typeable, cast) import GHC.Stack (HasCallStack) import System.Environment (getArgs) import System.Exit (exitFailure) import Text.Read (readMaybe) -- | The in-house exception type when a test case fails. data CheckException = CheckFailed String deriving Typeable instance Exception CheckException instance Show CheckException where show (CheckFailed msg) = msg data Test = ToRun (IO ()) | Named String Test | And Test Test (~:) :: HasCallStack => String -> Test -> Test (~:) = Named infix 4 ~: runTestForMachine (ToRun p) = p runTestForMachine (Named name t) = runTestForMachine t runTestForMachine (And t1 t2) = do runTestForMachine t1 runTestForMachine t2 -- | A record type packing up a predicate and its name. data Cond a = MkCond{cond :: a -> Bool, condName :: String} -- | Test with a predicate. checkCond :: (HasCallStack, Show a) => Cond a -- ^ predicate -> a -- ^ testee value -> Test checkCond MkCond{cond=p, condName=name} x = ToRun do b <- evaluate (p x) unless b (throwIO (CheckFailed msg)) where msg = "Predicate \"" ++ name ++ "\" fails.\nProblematic value: " ++ show x -- | A record type packing up both a relation and its name. Note that the -- testers in this library work best when the relation is symmetric. data Rel a = MkRel{rel :: a -> a -> Bool, relName :: String} -- | The @==@ relation. eq :: Eq a => Rel a eq = MkRel{rel = (==), relName = "=="} -- | Test with a relation against an expected value. checkRel :: (HasCallStack, Show a) => Rel a -- ^ relation -> a -- ^ received value -> a -- ^ expected value -> Test checkRel MkRel{rel=r, relName=name} received expected = ToRun do b <- evaluate (r received expected) unless b (throwIO (CheckFailed msg)) where msg = "Relation \"" ++ name ++ "\" fails:\n" ++ "expected: " ++ show expected ++ "\n" ++ "received: " ++ show received -- | Equality test. 2nd argument is the expected answer. checkEq :: (HasCallStack, Eq a, Show a) => a -> a -> Test checkEq = checkRel eq -- | Equality test. 2nd argument is the expected answer. (~?=) :: (HasCallStack, Eq a, Show a) => a -> a -> Test (~?=) = checkEq infix 5 ~?= -- | Equality test. 1st argument is the expected answer. (~=?) :: (HasCallStack, Eq a, Show a) => a -> a -> Test (~=?) = flip checkEq infix 5 ~=? -- | Require passing both tests. Stop upon 1st failure. (~&&) :: HasCallStack => Test -> Test -> Test (~&&) = And infixr 3 ~&& -- | Require passing one of two tests. Stop upon 1st success. (~||) :: HasCallStack => Test -> Test -> Test pa ~|| pb = ToRun do e <- try (runTestForMachine pa) case e of Right _ -> return () Left (_ :: SomeException) -> runTestForMachine pb infixr 2 ~|| runTestForHuman :: Test -> IO Bool runTestForHuman (And t1 t2) = (&&) <$> runTestForHuman t1 <*> runTestForHuman t2 runTestForHuman t = do case t of Named name _ -> putStr ("Test \"" ++ name ++ "\": ") ToRun _ -> putStr ("Unnamed test: ") e <- try (runTestForMachine t) case e of Left (exc :: SomeException) -> do print exc putStrLn "" return False Right _ -> do putStrLn "passed" putStrLn "" return True -- | Use this for main. testlibMain :: [Test] -> IO () testlibMain tests = do arg <- fmap (parseArgs (length tests)) getArgs case arg of Arg Human Nothing -> do b <- foldM (\b t -> (b &&) <$> runTestForHuman t) True tests unless b exitFailure Arg Human (Just i) -> do b <- runTestForHuman (tests !! i) unless b exitFailure Arg Machine (Just i) -> runTestForMachine (tests !! i) ArgError -> error "No valid test number." data Args = Arg Mode (Maybe Int) | ArgError data Mode = Human | Machine parseArgs n args = go (Arg Human Nothing) args where go a [] = a go a@(Arg mode intMay) (x : xs) | x == "-q" = go (Arg Machine intMay) xs | Just i <- readMaybe x, 0 <= i, i < n = go (Arg mode (Just i)) xs | otherwise = ArgError