{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | This module is a parameter of the mock function.
--
-- This parameter can be used when creating and verifying the mock.
module Test.MockCat.Param
  ( Param,
    value,
    param,
    (|>),
    expect,
    expect_,
    expectByExpr,
    any
  )
where

import Language.Haskell.TH
import Test.MockCat.Cons ((:>) (..))
import Test.MockCat.TH
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (any)

data Param v
  = ExpectValue v
  | ExpectCondition (v -> Bool) String

instance (Eq a) => Eq (Param a) where
  (ExpectValue a
a) == :: Param a -> Param a -> Bool
== (ExpectValue a
b) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b
  (ExpectValue a
a) == (ExpectCondition a -> Bool
m2 String
_) = a -> Bool
m2 a
a
  (ExpectCondition a -> Bool
m1 String
_) == (ExpectValue a
b) = a -> Bool
m1 a
b
  (ExpectCondition a -> Bool
_ String
l1) == (ExpectCondition a -> Bool
_ String
l2) = String
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
l2

type family ShowResult a where
  ShowResult String = String
  ShowResult a = String

class ShowParam a where
  showParam :: a -> ShowResult a

instance {-# OVERLAPPING #-} ShowParam (Param String) where
  showParam :: Param String -> ShowResult (Param String)
showParam (ExpectCondition String -> Bool
_ String
l) = String
ShowResult (Param String)
l
  showParam (ExpectValue String
a) = String
ShowResult (Param String)
a

instance {-# INCOHERENT #-} (Show a) => ShowParam (Param a) where
  showParam :: Param a -> ShowResult (Param a)
showParam (ExpectCondition a -> Bool
_ String
l) = String
ShowResult (Param a)
l
  showParam (ExpectValue a
a) = a -> String
forall a. Show a => a -> String
show a
a

instance (ShowParam (Param a)) => Show (Param a) where
  show :: Param a -> String
show = Param a -> String
Param a -> ShowResult (Param a)
forall a. ShowParam a => a -> ShowResult a
showParam

value :: Param v -> v
value :: forall v. Param v -> v
value (ExpectValue v
a) = v
a
value Param v
_ = String -> v
forall a. HasCallStack => String -> a
error String
"not implement"

param :: v -> Param v
param :: forall v. v -> Param v
param = v -> Param v
forall v. v -> Param v
ExpectValue

class ConsGen a b r | a b -> r where
  (|>) :: a -> b -> r

instance {-# OVERLAPPING #-} (Param a ~ a', (Param b :> c) ~ bc) => ConsGen a (Param b :> c) (a' :> bc) where
  |> :: a -> (Param b :> c) -> a' :> bc
(|>) a
a = a' -> (Param b :> c) -> a' :> (Param b :> c)
forall a b. a -> b -> a :> b
(:>) (a -> Param a
forall v. v -> Param v
param a
a)
instance {-# OVERLAPPING #-} ((Param b :> c) ~ bc) => ConsGen (Param a) (Param b :> c) (Param a :> bc) where
  |> :: Param a -> (Param b :> c) -> Param a :> bc
(|>) = Param a -> (Param b :> c) -> Param a :> bc
Param a -> (Param b :> c) -> Param a :> (Param b :> c)
forall a b. a -> b -> a :> b
(:>)
instance ConsGen (Param a) (Param b) (Param a :> Param b) where
  |> :: Param a -> Param b -> Param a :> Param b
(|>) = Param a -> Param b -> Param a :> Param b
forall a b. a -> b -> a :> b
(:>)
instance {-# OVERLAPPABLE #-} ((Param b) ~ b') => ConsGen (Param a) b (Param a :> b') where
  |> :: Param a -> b -> Param a :> b'
(|>) Param a
a b
b = Param a -> b' -> Param a :> b'
forall a b. a -> b -> a :> b
(:>) Param a
a (b -> Param b
forall v. v -> Param v
param b
b)
instance {-# OVERLAPPABLE #-} ((Param a) ~ a') => ConsGen a (Param b) (a' :> Param b) where
  |> :: a -> Param b -> a' :> Param b
(|>) a
a = a' -> Param b -> a' :> Param b
forall a b. a -> b -> a :> b
(:>) (a -> Param a
forall v. v -> Param v
param a
a)
instance {-# OVERLAPPABLE #-} (Param a ~ a', Param b ~ b') => ConsGen a b (a' :> b') where
  |> :: a -> b -> a' :> b'
(|>) a
a b
b = a' -> b' -> a' :> b'
forall a b. a -> b -> a :> b
(:>) (a -> Param a
forall v. v -> Param v
param a
a) (b -> Param b
forall v. v -> Param v
param b
b)

infixr 8 |>

-- | Make a parameter to which any value is expected to apply.
any :: Param a
any :: forall a. Param a
any = Param Any -> Param a
forall a b. a -> b
unsafeCoerce ((Any -> Bool) -> String -> Param Any
forall v. (v -> Bool) -> String -> Param v
ExpectCondition (Bool -> Any -> Bool
forall a b. a -> b -> a
const Bool
True) String
"any")

{- | Create a conditional parameter.

   When applying a mock function, if the argument does not satisfy this condition, an error occurs.

   In this case, the specified label is included in the error message.
-}
expect :: (a -> Bool) -> String -> Param a
expect :: forall v. (v -> Bool) -> String -> Param v
expect = (a -> Bool) -> String -> Param a
forall v. (v -> Bool) -> String -> Param v
ExpectCondition

{- | Create a conditional parameter.

  In applied a mock function, if the argument does not satisfy this condition, an error occurs.

  Unlike @'expect'@, it does not require a label, but the error message is displayed as [some condition].
-}
expect_ :: (a -> Bool) -> Param a
expect_ :: forall a. (a -> Bool) -> Param a
expect_ a -> Bool
f = (a -> Bool) -> String -> Param a
forall v. (v -> Bool) -> String -> Param v
ExpectCondition a -> Bool
f String
"[some condition]"

{- | Create a conditional parameter based on @Q Exp@. 

  In applying a mock function, if the argument does not satisfy this condition, an error is raised.

  The conditional expression is displayed in the error message.
-}
expectByExpr :: Q Exp -> Q Exp
expectByExpr :: Q Exp -> Q Exp
expectByExpr Q Exp
qf = do
  String
str <- Q Exp -> Q String
showExp Q Exp
qf
  [|ExpectCondition $Q Exp
qf str|]