{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}

-- | 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.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 =
  let s = show $ typeRep (Proxy @a)
   in if ' ' `elem` s
        then "(" ++ s ++ ")"
        else s

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

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

newtype Anon a =
    Anon a

instance Show (Anon a) where
    show _ = "Anonymous"

instance Functor Anon where
    fmap f (Anon a) = Anon (f 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
mapSpecTree' f (SpecM specs) = SpecM (mapWriterT (fmap (second (map f))) specs)

-- | 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 s = mapSpecTree' go
  where
    go :: SpecTree () -> SpecTree ()
    go sp =
        Leaf
            Item
                { itemRequirement = s
                , itemLocation = Nothing
#if MIN_VERSION_hspec_core(2,6,0)
                , itemIsFocused = False
#endif
#if MIN_VERSION_hspec_core(2,5,0)
                , itemIsParallelizable = Nothing
#else
                , itemIsParallelizable = False
#endif
                , itemExample =
                      \_ _ _ -> do
                          let conf =
                                  defaultConfig {configFormatter = Just silent}
                          r <- hspecWithResult conf $ fromSpecList [sp]
                          let succesful =
                                  summaryExamples r > 0 && summaryFailures r > 0
                          pure $ produceResult 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 succesful = Result
  { resultInfo = ""
  , resultStatus =
    if succesful
        then Success
        else Failure Nothing $ 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 =
    mapResult $ \res ->
        res
            { reason = unwords ["Should have failed:", reason res]
            , expect = not $ expect res
            }
