1{-# LANGUAGE CPP #-} 2{-# LANGUAGE RecordWildCards #-} 3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE TypeFamilies #-} 6{-# LANGUAGE TypeSynonymInstances #-} 7 8-- NOTE: re-exported from Test.Hspec.Core.Spec 9module Test.Hspec.Core.Example ( 10 Example (..) 11, Params (..) 12, defaultParams 13, ActionWith 14, Progress 15, ProgressCallback 16, Result(..) 17, ResultStatus (..) 18, Location (..) 19, FailureReason (..) 20, safeEvaluate 21, safeEvaluateExample 22) where 23 24import qualified Test.HUnit.Lang as HUnit 25 26import Data.CallStack 27 28import Control.Exception 29import Control.DeepSeq 30import Data.Typeable (Typeable) 31import qualified Test.QuickCheck as QC 32import Test.Hspec.Expectations (Expectation) 33 34import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests) 35import qualified Test.QuickCheck.Property as QCP 36 37import Test.Hspec.Core.QuickCheckUtil 38import Test.Hspec.Core.Util 39import Test.Hspec.Core.Compat 40import Test.Hspec.Core.Example.Location 41 42-- | A type class for examples 43class Example e where 44 type Arg e 45 type Arg e = () 46 evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result 47 48data Params = Params { 49 paramsQuickCheckArgs :: QC.Args 50, paramsSmallCheckDepth :: Int 51} deriving (Show) 52 53defaultParams :: Params 54defaultParams = Params { 55 paramsQuickCheckArgs = QC.stdArgs 56, paramsSmallCheckDepth = 5 57} 58 59type Progress = (Int, Int) 60type ProgressCallback = Progress -> IO () 61 62-- | An `IO` action that expects an argument of type @a@ 63type ActionWith a = a -> IO () 64 65-- | The result of running an example 66data Result = Result { 67 resultInfo :: String 68, resultStatus :: ResultStatus 69} deriving (Show, Typeable) 70 71data ResultStatus = 72 Success 73 | Pending (Maybe Location) (Maybe String) 74 | Failure (Maybe Location) FailureReason 75 deriving (Show, Typeable) 76 77data FailureReason = 78 NoReason 79 | Reason String 80 | ExpectedButGot (Maybe String) String String 81 | Error (Maybe String) SomeException 82 deriving (Show, Typeable) 83 84instance NFData FailureReason where 85 rnf reason = case reason of 86 NoReason -> () 87 Reason r -> r `deepseq` () 88 ExpectedButGot p e a -> p `deepseq` e `deepseq` a `deepseq` () 89 Error m e -> m `deepseq` e `seq` () 90 91instance Exception ResultStatus 92 93safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result 94safeEvaluateExample example params around progress = safeEvaluate $ forceResult <$> evaluateExample example params around progress 95 where 96 forceResult :: Result -> Result 97 forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r 98 99 forceResultStatus :: ResultStatus -> ResultStatus 100 forceResultStatus r = case r of 101 Success -> r 102 Pending _ m -> m `deepseq` r 103 Failure _ m -> m `deepseq` r 104 105safeEvaluate :: IO Result -> IO Result 106safeEvaluate action = do 107 r <- safeTry $ action 108 return $ case r of 109 Left e | Just result <- fromException e -> Result "" result 110 Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit 111 Left e -> Result "" $ Failure Nothing $ Error Nothing e 112 Right result -> result 113 114instance Example Result where 115 type Arg Result = () 116 evaluateExample e = evaluateExample (\() -> e) 117 118instance Example (a -> Result) where 119 type Arg (a -> Result) = a 120 evaluateExample example _params action _callback = do 121 ref <- newIORef (Result "" Success) 122 action (evaluate . example >=> writeIORef ref) 123 readIORef ref 124 125instance Example Bool where 126 type Arg Bool = () 127 evaluateExample e = evaluateExample (\() -> e) 128 129instance Example (a -> Bool) where 130 type Arg (a -> Bool) = a 131 evaluateExample p _params action _callback = do 132 ref <- newIORef (Result "" Success) 133 action (evaluate . example >=> writeIORef ref) 134 readIORef ref 135 where 136 example a 137 | p a = Result "" Success 138 | otherwise = Result "" $ Failure Nothing NoReason 139 140instance Example Expectation where 141 type Arg Expectation = () 142 evaluateExample e = evaluateExample (\() -> e) 143 144hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus 145hunitFailureToResult pre e = case e of 146 HUnit.HUnitFailure mLoc err -> 147 case err of 148 HUnit.Reason reason -> Failure location (Reason $ addPre reason) 149 HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot (addPreMaybe preface) expected actual) 150 where 151 addPreMaybe :: Maybe String -> Maybe String 152 addPreMaybe xs = case (pre, xs) of 153 (Just x, Just y) -> Just (x ++ "\n" ++ y) 154 _ -> pre <|> xs 155 where 156 location = case mLoc of 157 Nothing -> Nothing 158 Just loc -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) 159 where 160 addPre :: String -> String 161 addPre xs = case pre of 162 Just x -> x ++ "\n" ++ xs 163 Nothing -> xs 164 165instance Example (a -> Expectation) where 166 type Arg (a -> Expectation) = a 167 evaluateExample e _ action _ = action e >> return (Result "" Success) 168 169instance Example QC.Property where 170 type Arg QC.Property = () 171 evaluateExample e = evaluateExample (\() -> e) 172 173instance Example (a -> QC.Property) where 174 type Arg (a -> QC.Property) = a 175 evaluateExample p c action progressCallback = do 176 r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p) 177 return $ fromQuickCheckResult r 178 where 179 qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ 180 \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) 181 182fromQuickCheckResult :: QC.Result -> Result 183fromQuickCheckResult r = case parseQuickCheckResult r of 184 QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err) 185 QuickCheckResult _ info QuickCheckSuccess -> Result info Success 186 QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of 187 Just e | Just result <- fromException e -> Result info result 188 Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit 189 Just e -> failure (uncaughtException e) 190 Nothing -> failure falsifiable 191 where 192 failure = Result info . Failure Nothing . Reason 193 194 numbers = formatNumbers n quickCheckFailureNumShrinks 195 196 hunitAssertion :: String 197 hunitAssertion = intercalate "\n" [ 198 "Falsifiable " ++ numbers ++ ":" 199 , indent (unlines quickCheckFailureCounterexample) 200 ] 201 202 uncaughtException e = intercalate "\n" [ 203 "uncaught exception: " ++ formatException e 204 , numbers 205 , indent (unlines quickCheckFailureCounterexample) 206 ] 207 208 falsifiable = intercalate "\n" [ 209 quickCheckFailureReason ++ " " ++ numbers ++ ":" 210 , indent (unlines quickCheckFailureCounterexample) 211 ] 212 213indent :: String -> String 214indent = intercalate "\n" . map (" " ++) . lines 215