{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

-- | Utilities for defining your own validity 'Spec's
--
-- You will need @TypeApplications@ to use these.
module Test.Validity.Utils
  ( nameOf,
    genDescr,
    binRelStr,
    shouldFail,
    failsBecause,
    Anon (..),
    shouldBeValid,
    shouldBeInvalid,
  )
where

import Control.Arrow (second)
import Control.Monad.Trans.Writer (mapWriterT)
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 :: forall {k} (a :: k). Typeable a => String
nameOf =
  let s :: String
s = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)
   in if Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s
        then String
"(" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
")"
        else String
s

genDescr ::
  forall a.
  Typeable a =>
  String ->
  String
genDescr :: forall {k} (a :: k). Typeable a => String -> String
genDescr String
genname = [String] -> String
unwords [String
"\"" forall a. [a] -> [a] -> [a]
++ String
genname, String
"::", forall {k} (a :: k). Typeable a => String
nameOf @a forall a. [a] -> [a] -> [a]
++ String
"\""]

binRelStr ::
  forall a.
  Typeable a =>
  String ->
  String
binRelStr :: forall {k} (a :: k). Typeable a => String -> String
binRelStr String
op = [String] -> String
unwords [String
"(" forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
")", String
"::", String
name, String
"->", String
name, String
"->", String
"Bool"]
  where
    name :: String
name = forall {k} (a :: k). Typeable a => String
nameOf @a

newtype Anon a
  = Anon a

instance Show (Anon a) where
  show :: Anon a -> String
show Anon a
_ = String
"Anonymous"

instance Functor Anon where
  fmap :: forall a b. (a -> b) -> Anon a -> Anon b
fmap a -> b
f (Anon a
a) = forall a. a -> Anon a
Anon (a -> b
f a
a)

-- I'm not sure why mapSpecTree was removed from hspec-core,
-- but it has been copied here for convenience.
-- https://github.com/hspec/hspec/commit/020c7ecc4a73c24af38e9fab049f60bb9aec6981#diff-29cb22f0ef6e98086a71fc045847bd21L22
mapSpecTree' :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r

#if MIN_VERSION_hspec(2,10,0)
mapSpecTree' :: forall a b r. (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r
mapSpecTree' SpecTree a -> SpecTree b
f (SpecM WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r
specs) = forall a r.
WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r -> SpecM a r
SpecM (forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map SpecTree a -> SpecTree b
f)))) WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r
specs)
#else
mapSpecTree' f (SpecM specs) = SpecM (mapWriterT (fmap (second (map f))) specs)
#endif

-- | Asserts that a given 'Spec' tree fails _somewhere_.
--
-- It also shows the given string when reporting that the tree unexpectedly
-- succeeded.
failsBecause :: String -> SpecWith () -> SpecWith ()
failsBecause :: String -> SpecWith () -> SpecWith ()
failsBecause String
s = 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 SpecTree ()
sp =
      forall c a. a -> Tree c a
Leaf
        Item
          { itemRequirement :: String
itemRequirement = String
s,
            itemLocation :: Maybe Location
itemLocation = forall a. Maybe a
Nothing,
            itemIsFocused :: Bool
itemIsFocused = Bool
False,
            itemIsParallelizable :: Maybe Bool
itemIsParallelizable = forall a. Maybe a
Nothing,
            itemExample :: Params -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
itemExample =
              \Params
_ ActionWith () -> IO ()
_ ProgressCallback
_ -> do
                let conf :: Config
conf =
                      Config
defaultConfig {configFormatter :: Maybe Formatter
configFormatter = forall a. a -> Maybe a
Just Formatter
silent}
                Summary
r <- Config -> SpecWith () -> IO Summary
hspecWithResult Config
conf forall a b. (a -> b) -> a -> b
$ forall a. [SpecTree a] -> SpecWith a
fromSpecList [SpecTree ()
sp]
                let succesful :: Bool
succesful =
                      Summary -> Int
summaryExamples Summary
r forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Summary -> Int
summaryFailures Summary
r forall a. Ord a => a -> a -> Bool
> Int
0
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Result
produceResult Bool
succesful
          }

produceResult :: Bool -> Test.Hspec.Core.Spec.Result
produceResult :: Bool -> Result
produceResult Bool
succesful =
  Result
    { resultInfo :: String
resultInfo = String
"",
      resultStatus :: ResultStatus
resultStatus =
        if Bool
succesful
          then ResultStatus
Success
          else Maybe Location -> FailureReason -> ResultStatus
Failure forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Test.Hspec.Core.Spec.Reason String
"Should have failed but didn't."
    }

shouldFail :: Property -> Property
shouldFail :: Property -> Property
shouldFail =
  forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult forall a b. (a -> b) -> a -> b
$ \Result
res ->
    Result
res
      { reason :: String
reason = [String] -> String
unwords [String
"Should have failed:", Result -> String
reason Result
res],
        expect :: Bool
expect = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Result -> Bool
expect Result
res
      }