{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
module Test.Validity.Utils
( nameOf
, genDescr
, binRelStr
, shouldFail
, failsBecause
, Anon(..)
, shouldBeValid
, shouldBeInvalid
) where
import Control.Monad.Trans.Writer (mapWriterT)
import Control.Arrow (second)
import Data.Data
import Test.Hspec
import Test.Hspec.Core.Formatters
import Test.Hspec.Core.Runner
import Test.Hspec.Core.Spec
import Test.QuickCheck.Property
import Test.Validity.Property.Utils
nameOf ::
forall a. Typeable a
=> String
nameOf :: String
nameOf =
let s :: String
s = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
in if ' ' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s
then "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
else String
s
genDescr ::
forall a. Typeable a
=> String
-> String
genDescr :: String -> String
genDescr genname :: String
genname = [String] -> String
unwords ["\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
genname, "::", Typeable a => String
forall k (a :: k). Typeable a => String
nameOf @a String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\""]
binRelStr ::
forall a. Typeable a
=> String
-> String
binRelStr :: String -> String
binRelStr op :: String
op = [String] -> String
unwords ["(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")", "::", String
name, "->", String
name, "->", "Bool"]
where
name :: String
name = Typeable a => String
forall k (a :: k). Typeable a => String
nameOf @a
newtype Anon a =
Anon a
instance Show (Anon a) where
show :: Anon a -> String
show _ = "Anonymous"
instance Functor Anon where
fmap :: (a -> b) -> Anon a -> Anon b
fmap f :: a -> b
f (Anon a :: a
a) = b -> Anon b
forall a. a -> Anon a
Anon (a -> b
f a
a)
mapSpecTree' :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r
mapSpecTree' :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r
mapSpecTree' f :: SpecTree a -> SpecTree b
f (SpecM specs :: WriterT [SpecTree a] IO r
specs) = WriterT [SpecTree b] IO r -> SpecM b r
forall a r. WriterT [SpecTree a] IO r -> SpecM a r
SpecM ((IO (r, [SpecTree a]) -> IO (r, [SpecTree b]))
-> WriterT [SpecTree a] IO r -> WriterT [SpecTree b] IO r
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (((r, [SpecTree a]) -> (r, [SpecTree b]))
-> IO (r, [SpecTree a]) -> IO (r, [SpecTree b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([SpecTree a] -> [SpecTree b])
-> (r, [SpecTree a]) -> (r, [SpecTree b])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((SpecTree a -> SpecTree b) -> [SpecTree a] -> [SpecTree b]
forall a b. (a -> b) -> [a] -> [b]
map SpecTree a -> SpecTree b
f))) WriterT [SpecTree a] IO r
specs)
failsBecause :: String -> SpecWith () -> SpecWith ()
failsBecause :: String -> SpecWith () -> SpecWith ()
failsBecause s :: String
s = (SpecTree () -> SpecTree ()) -> SpecWith () -> SpecWith ()
forall a b r. (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r
mapSpecTree' SpecTree () -> SpecTree ()
go
where
go :: SpecTree () -> SpecTree ()
go :: SpecTree () -> SpecTree ()
go sp :: SpecTree ()
sp =
Item () -> SpecTree ()
forall c a. a -> Tree c a
Leaf
Item :: forall a.
String
-> Maybe Location
-> Maybe Bool
-> Bool
-> (Params
-> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result)
-> Item a
Item
{ itemRequirement :: String
itemRequirement = String
s
, itemLocation :: Maybe Location
itemLocation = Maybe Location
forall a. Maybe a
Nothing
#if MIN_VERSION_hspec_core(2,6,0)
, itemIsFocused :: Bool
itemIsFocused = Bool
False
#endif
#if MIN_VERSION_hspec_core(2,5,0)
, itemIsParallelizable :: Maybe Bool
itemIsParallelizable = Maybe Bool
forall a. Maybe a
Nothing
#else
, itemIsParallelizable = False
#endif
, itemExample :: Params -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
itemExample =
\_ _ _ -> do
let conf :: Config
conf =
Config
defaultConfig {configFormatter :: Maybe Formatter
configFormatter = Formatter -> Maybe Formatter
forall a. a -> Maybe a
Just Formatter
silent}
Summary
r <- Config -> SpecWith () -> IO Summary
hspecWithResult Config
conf (SpecWith () -> IO Summary) -> SpecWith () -> IO Summary
forall a b. (a -> b) -> a -> b
$ [SpecTree ()] -> SpecWith ()
forall a. [SpecTree a] -> SpecWith a
fromSpecList [SpecTree ()
sp]
let succesful :: Bool
succesful =
Summary -> Int
summaryExamples Summary
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Summary -> Int
summaryFailures Summary
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Bool -> Result
produceResult Bool
succesful
}
#if MIN_VERSION_hspec_core(2,4,0)
#if MIN_VERSION_hspec_core(2,5,0)
produceResult :: Bool -> Test.Hspec.Core.Spec.Result
produceResult :: Bool -> Result
produceResult succesful :: Bool
succesful = Result :: String -> ResultStatus -> Result
Result
{ resultInfo :: String
resultInfo = ""
, resultStatus :: ResultStatus
resultStatus =
if Bool
succesful
then ResultStatus
Success
else Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason "Should have failed but didn't."
}
#else
produceResult :: Bool -> Either a Test.Hspec.Core.Spec.Result
produceResult succesful =
Right $
if succesful
then Success
else Failure Nothing $ Reason "Should have failed but didn't."
#endif
#else
produceResult :: Bool -> Test.Hspec.Core.Spec.Result
produceResult succesful =
if succesful
then Success
else Fail Nothing "Should have failed but didn't."
#endif
shouldFail :: Property -> Property
shouldFail :: Property -> Property
shouldFail =
(Result -> Result) -> Property -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult ((Result -> Result) -> Property -> Property)
-> (Result -> Result) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ \res :: Result
res ->
Result
res
{ reason :: String
reason = [String] -> String
unwords ["Should have failed:", Result -> String
reason Result
res]
, expect :: Bool
expect = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Result -> Bool
expect Result
res
}