{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# 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,
    MockM,
    mockup,
    thenReturn,
    thenAction,
    thenMethod,
    throwNoStubWithShow,
    throwNoStub,
  )
where

import Control.Method
  ( Method (Args, curryMethod, uncurryMethod),
    TupleLike (AsTuple, toTuple),
  )
import RIO.List (find)
import RIO.Writer (MonadWriter (tell), Writer, execWriter)
import Test.Method.Behavior (Behave (Condition, MethodOf, thenMethod), thenAction, thenReturn)
import Test.Method.Matcher (Matcher)

type Mock method = MockM method ()

newtype MockM method a = MockM (Writer (MockSpec method) a)

deriving instance (Functor (MockM method))

deriving instance (Applicative (MockM method))

deriving instance (Monad (MockM method))

deriving instance (MonadWriter (MockSpec method) (MockM method))

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

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) => Mock method -> method
mockup :: Mock method -> method
mockup (MockM Writer (MockSpec method) ()
spec) = MockSpec method -> method
forall method. Method method => MockSpec method -> method
buildMock (Writer (MockSpec method) () -> MockSpec method
forall w a. Writer w a -> w
execWriter Writer (MockSpec method) ()
spec)

buildMock :: Method method => MockSpec method -> method
buildMock :: MockSpec method -> method
buildMock MockSpec method
spec = [(Matcher (Args method), method)] -> method
forall method.
Method 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

instance a ~ () => Behave (MockM method a) where
  type Condition (MockM method a) = Matcher (Args method)
  type MethodOf (MockM method a) = method
  thenMethod :: Condition (MockM method a)
-> MethodOf (MockM method a) -> MockM method a
thenMethod Condition (MockM method a)
lhs MethodOf (MockM method a)
method = MockSpec method -> MockM method ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (MockSpec method -> MockM method ())
-> MockSpec method -> MockM method ()
forall a b. (a -> b) -> a -> b
$ Matcher (Args method) -> method -> MockSpec method
forall method. Matcher (Args method) -> method -> MockSpec method
MockSpec Condition (MockM method a)
Matcher (Args method)
lhs method
MethodOf (MockM method a)
method

-- | @'throwNoStub' matcher@ means the method raises a runtime exception
-- if the arguments matches @matcher@. The argument tuple is converted to 'String' by
-- using 'show' function.
throwNoStub ::
  ( Method method,
    Show (AsTuple (Args method)),
    TupleLike (Args method)
  ) =>
  Matcher (Args method) ->
  Mock method
throwNoStub :: Matcher (Args method) -> Mock method
throwNoStub = (Args method -> String) -> Matcher (Args method) -> Mock method
forall method.
Method method =>
(Args method -> String) -> (Args method -> Bool) -> Mock method
throwNoStubWithShow (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)

-- | @'throwNoStubWithShow' fshow matcher@ means the method raises runtime exception
-- if the arguments matches @matcher@. The argument tuple is converted to 'String' by
-- using 'fshow' function.
throwNoStubWithShow :: (Method method) => (Args method -> String) -> (Args method -> Bool) -> Mock method
throwNoStubWithShow :: (Args method -> String) -> (Args method -> Bool) -> Mock method
throwNoStubWithShow 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
$ String -> Base method (Ret method)
forall a. HasCallStack => String -> a
error (String -> Base method (Ret method))
-> (Args method -> String)
-> Args method
-> Base method (Ret method)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"no stub found for argument: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (Args method -> String) -> Args method -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args method -> String
fshow

fromRules :: Method 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 -> String -> Base method (Ret method)
forall a. HasCallStack => String -> a
error String
"no stub. For debugging, use `throwNoStubShow anything`"

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