{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module : Test.Method.Mock
-- Description:
-- License: BSD-3
-- Maintainer: autotaker@gmail.com
-- Stability: experimental
--
-- DSL to generate mock methods.
module Test.Method.Mock
  ( Mock,
    MockSpec,
    mockup,
    thenReturn,
    thenAction,
    thenMethod,
    throwNoStubShow,
    throwNoStub,
    NoStubException (NoStubException),
  )
where

import Control.Method
  ( Method (Args, Base, Ret, curryMethod, uncurryMethod),
    TupleLike (AsTuple, toTuple),
  )
import Data.Data (Typeable)
import RIO (Exception, MonadThrow (throwM))
import RIO.List (find)
import RIO.Writer (MonadWriter (tell), Writer, execWriter)
import Test.Method.Matcher (Matcher)

type Mock method = Writer (MockSpec method) ()

data MockSpec method
  = Empty
  | Combine (MockSpec method) (MockSpec method)
  | MockSpec (Matcher (Args method)) method

newtype NoStubException = NoStubException String
  deriving (Int -> NoStubException -> ShowS
[NoStubException] -> ShowS
NoStubException -> String
(Int -> NoStubException -> ShowS)
-> (NoStubException -> String)
-> ([NoStubException] -> ShowS)
-> Show NoStubException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoStubException] -> ShowS
$cshowList :: [NoStubException] -> ShowS
show :: NoStubException -> String
$cshow :: NoStubException -> String
showsPrec :: Int -> NoStubException -> ShowS
$cshowsPrec :: Int -> NoStubException -> ShowS
Show, Typeable)

instance Exception NoStubException

instance Semigroup (MockSpec method) where
  <> :: MockSpec method -> MockSpec method -> MockSpec method
(<>) = MockSpec method -> MockSpec method -> MockSpec method
forall method.
MockSpec method -> MockSpec method -> MockSpec method
Combine

instance Monoid (MockSpec method) where
  mempty :: MockSpec method
mempty = MockSpec method
forall method. MockSpec method
Empty

-- | generate a method from Mock DSL.
-- Mock DSL consists of rules.
-- On a call of generated method, the first rule matched the arguments is applied.
mockup :: (Method method, MonadThrow (Base method)) => Mock method -> method
mockup :: Mock method -> method
mockup Mock method
spec = MockSpec method -> method
forall method.
(Method method, MonadThrow (Base method)) =>
MockSpec method -> method
buildMock (Mock method -> MockSpec method
forall w a. Writer w a -> w
execWriter Mock method
spec)

buildMock :: (Method method, MonadThrow (Base method)) => MockSpec method -> method
buildMock :: MockSpec method -> method
buildMock MockSpec method
spec = [(Matcher (Args method), method)] -> method
forall method.
(Method method, MonadThrow (Base method)) =>
[(Matcher (Args method), method)] -> method
fromRules ([(Matcher (Args method), method)] -> method)
-> [(Matcher (Args method), method)] -> method
forall a b. (a -> b) -> a -> b
$ MockSpec method -> [(Matcher (Args method), method)]
forall method. MockSpec method -> [(Matcher (Args method), method)]
toRules MockSpec method
spec

-- | @matcher `'thenReturn'` value@ means the method return @value@
-- if the arguments matches @matcher@.
thenReturn :: (Method method, Applicative (Base method)) => Matcher (Args method) -> Ret method -> Mock method
thenReturn :: Matcher (Args method) -> Ret method -> Mock method
thenReturn Matcher (Args method)
matcher Ret method
retVal =
  MockSpec method -> Mock method
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (MockSpec method -> Mock method) -> MockSpec method -> Mock method
forall a b. (a -> b) -> a -> b
$ Matcher (Args method) -> method -> MockSpec method
forall method. Matcher (Args method) -> method -> MockSpec method
MockSpec Matcher (Args method)
matcher (method -> MockSpec method) -> method -> MockSpec method
forall a b. (a -> b) -> a -> b
$ (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod (Base method (Ret method) -> Args method -> Base method (Ret method)
forall a b. a -> b -> a
const (Base method (Ret method)
 -> Args method -> Base method (Ret method))
-> Base method (Ret method)
-> Args method
-> Base method (Ret method)
forall a b. (a -> b) -> a -> b
$ Ret method -> Base method (Ret method)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ret method
retVal)

-- | @matcher `'thenAction'` action@ means the method executes @action@
-- if the arguments matches @matcher@.
thenAction ::
  Method method =>
  Matcher (Args method) ->
  Base method (Ret method) ->
  Mock method
thenAction :: Matcher (Args method) -> Base method (Ret method) -> Mock method
thenAction Matcher (Args method)
matcher Base method (Ret method)
ret =
  MockSpec method -> Mock method
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (MockSpec method -> Mock method) -> MockSpec method -> Mock method
forall a b. (a -> b) -> a -> b
$ Matcher (Args method) -> method -> MockSpec method
forall method. Matcher (Args method) -> method -> MockSpec method
MockSpec Matcher (Args method)
matcher (method -> MockSpec method) -> method -> MockSpec method
forall a b. (a -> b) -> a -> b
$ (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$ Base method (Ret method) -> Args method -> Base method (Ret method)
forall a b. a -> b -> a
const Base method (Ret method)
ret

-- | @matcher `'thenMethod'` action@ means the method call @method@ with the arguments
-- if the arguments matches @matcher@.
thenMethod :: (Method method) => Matcher (Args method) -> method -> Mock method
thenMethod :: Matcher (Args method) -> method -> Mock method
thenMethod Matcher (Args method)
matcher method
method = MockSpec method -> Mock method
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (MockSpec method -> Mock method) -> MockSpec method -> Mock method
forall a b. (a -> b) -> a -> b
$ Matcher (Args method) -> method -> MockSpec method
forall method. Matcher (Args method) -> method -> MockSpec method
MockSpec Matcher (Args method)
matcher method
method

-- | @'throwNoStubShow' matcher@ means the method throws a 'NoStubException'
-- if the arguments matches @matcher@. The argument tuple is converted to 'String' by
-- using 'show' function.
throwNoStubShow ::
  ( Method method,
    Show (AsTuple (Args method)),
    MonadThrow (Base method),
    TupleLike (Args method)
  ) =>
  Matcher (Args method) ->
  Mock method
throwNoStubShow :: Matcher (Args method) -> Mock method
throwNoStubShow Matcher (Args method)
matcher =
  MockSpec method -> Mock method
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (MockSpec method -> Mock method) -> MockSpec method -> Mock method
forall a b. (a -> b) -> a -> b
$
    Matcher (Args method) -> method -> MockSpec method
forall method. Matcher (Args method) -> method -> MockSpec method
MockSpec Matcher (Args method)
matcher (method -> MockSpec method) -> method -> MockSpec method
forall a b. (a -> b) -> a -> b
$
      (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$
        NoStubException -> Base method (Ret method)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NoStubException -> Base method (Ret method))
-> (Args method -> NoStubException)
-> Args method
-> Base method (Ret method)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NoStubException
NoStubException (String -> NoStubException)
-> (Args method -> String) -> Args method -> NoStubException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsTuple (Args method) -> String
forall a. Show a => a -> String
show (AsTuple (Args method) -> String)
-> (Args method -> AsTuple (Args method)) -> Args method -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args method -> AsTuple (Args method)
forall a. TupleLike a => a -> AsTuple a
toTuple

-- | @'throwNoStubShow' fshow matcher@ means the method throws a 'NoStubException'
-- if the arguments matches @matcher@. The argument tuple is converted to 'String' by
-- using 'fshow' function.
throwNoStub :: (Method method, MonadThrow (Base method)) => (Args method -> String) -> (Args method -> Bool) -> Mock method
throwNoStub :: (Args method -> String) -> (Args method -> Bool) -> Mock method
throwNoStub Args method -> String
fshow Args method -> Bool
matcher =
  MockSpec method -> Mock method
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (MockSpec method -> Mock method) -> MockSpec method -> Mock method
forall a b. (a -> b) -> a -> b
$
    (Args method -> Bool) -> method -> MockSpec method
forall method. Matcher (Args method) -> method -> MockSpec method
MockSpec Args method -> Bool
matcher (method -> MockSpec method) -> method -> MockSpec method
forall a b. (a -> b) -> a -> b
$
      (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$
        NoStubException -> Base method (Ret method)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NoStubException -> Base method (Ret method))
-> (Args method -> NoStubException)
-> Args method
-> Base method (Ret method)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NoStubException
NoStubException (String -> NoStubException)
-> (Args method -> String) -> Args method -> NoStubException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args method -> String
fshow

fromRules :: (Method method, MonadThrow (Base method)) => [(Matcher (Args method), method)] -> method
fromRules :: [(Matcher (Args method), method)] -> method
fromRules [(Matcher (Args method), method)]
rules = (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$ \Args method
args ->
  let ret :: Maybe (Matcher (Args method), method)
ret = ((Matcher (Args method), method) -> Bool)
-> [(Matcher (Args method), method)]
-> Maybe (Matcher (Args method), method)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Matcher (Args method)
matcher, method
_) -> Matcher (Args method)
matcher Args method
args) [(Matcher (Args method), method)]
rules
   in case Maybe (Matcher (Args method), method)
ret of
        Just (Matcher (Args method)
_, method
method) -> method -> Args method -> Base method (Ret method)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod method
method Args method
args
        Maybe (Matcher (Args method), method)
Nothing -> NoStubException -> Base method (Ret method)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NoStubException -> Base method (Ret method))
-> NoStubException -> Base method (Ret method)
forall a b. (a -> b) -> a -> b
$ String -> NoStubException
NoStubException String
"no mock"

toRules :: MockSpec method -> [(Matcher (Args method), method)]
toRules :: MockSpec method -> [(Matcher (Args method), method)]
toRules = [(Matcher (Args method), method)]
-> [(Matcher (Args method), method)]
forall a. [a] -> [a]
reverse ([(Matcher (Args method), method)]
 -> [(Matcher (Args method), method)])
-> (MockSpec method -> [(Matcher (Args method), method)])
-> MockSpec method
-> [(Matcher (Args method), method)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Matcher (Args method), method)]
-> MockSpec method -> [(Matcher (Args method), method)]
forall b.
[(Matcher (Args b), b)] -> MockSpec b -> [(Matcher (Args b), b)]
go []
  where
    go :: [(Matcher (Args b), b)] -> MockSpec b -> [(Matcher (Args b), b)]
go [(Matcher (Args b), b)]
acc MockSpec b
Empty = [(Matcher (Args b), b)]
acc
    go [(Matcher (Args b), b)]
acc (Combine MockSpec b
a MockSpec b
b) = [(Matcher (Args b), b)] -> MockSpec b -> [(Matcher (Args b), b)]
go ([(Matcher (Args b), b)] -> MockSpec b -> [(Matcher (Args b), b)]
go [(Matcher (Args b), b)]
acc MockSpec b
a) MockSpec b
b
    go [(Matcher (Args b), b)]
acc (MockSpec Matcher (Args b)
matcher b
ret) = (Matcher (Args b)
matcher, b
ret) (Matcher (Args b), b)
-> [(Matcher (Args b), b)] -> [(Matcher (Args b), b)]
forall a. a -> [a] -> [a]
: [(Matcher (Args b), b)]
acc