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