{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}

-- | This module defines the desugaring from multi-response 'Rule's into
-- multiple steps.
module Test.HMock.Internal.Step where

import Data.Kind (Constraint, Type)
import Data.Maybe (listToMaybe)
import GHC.Stack (CallStack, callStack)
import GHC.TypeLits (Symbol)
import Test.HMock.ExpectContext (ExpectContext (..), MockableMethod)
import Test.HMock.Internal.ExpectSet (ExpectSet (..))
import Test.HMock.Internal.Rule
  ( Rule (..),
    WholeMethodMatcher (..),
    showWholeMatcher,
  )
import {-# SOURCE #-} Test.HMock.Internal.State (MockT)
import Test.HMock.Internal.Util (Located (..), locate, withLoc)
import Test.HMock.Mockable (MockableBase (..))
import Test.HMock.Multiplicity
  ( Multiplicity,
    anyMultiplicity,
    feasible,
    meetsMultiplicity,
  )
import Test.HMock.Rule (Expectable (toRule))

-- | A Rule that contains only a single response.  This is the target for
-- desugaring the multi-response rule format.
data
  SingleRule
    (cls :: (Type -> Type) -> Constraint)
    (name :: Symbol)
    (m :: Type -> Type)
    (r :: Type)
  where
  (:->) ::
    WholeMethodMatcher cls name m r ->
    Maybe (Action cls name m r -> MockT m r) ->
    SingleRule cls name m r

-- | A single step of an expectation.
data Step m where
  Step ::
    MockableMethod cls name m r =>
    Located (SingleRule cls name m r) ->
    Step m

instance Show (Step m) where
  show :: Step m -> String
show (Step l :: Located (SingleRule cls name m r)
l@(Loc Maybe String
_ (WholeMethodMatcher cls name m r
m :-> Maybe (Action cls name m r -> MockT m r)
_))) =
    Located String -> String
withLoc (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a b.
MockableBase cls =>
Maybe (Action cls name m a)
-> WholeMethodMatcher cls name m b -> String
showWholeMatcher forall a. Maybe a
Nothing WholeMethodMatcher cls name m r
m forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Located (SingleRule cls name m r)
l)

-- | Expands a Rule into an expectation.  The expected multiplicity will be one
-- if there are no responses; otherwise one call is expected per response.
expandRule ::
  MockableMethod cls name m r =>
  CallStack ->
  Rule cls name m r ->
  ExpectSet (Step m)
expandRule :: forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRule CallStack
callstack (WholeMethodMatcher cls name m r
m :=> []) =
  forall step. step -> ExpectSet step
ExpectStep (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step (forall a. CallStack -> a -> Located a
locate CallStack
callstack (WholeMethodMatcher cls name m r
m forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
WholeMethodMatcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:-> forall a. Maybe a
Nothing)))
expandRule CallStack
callstack (WholeMethodMatcher cls name m r
m :=> [Action cls name m r -> MockT m r]
rs) =
  forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1
    forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectSequence
    (forall a b. (a -> b) -> [a] -> [b]
map (forall step. step -> ExpectSet step
ExpectStep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CallStack -> a -> Located a
locate CallStack
callstack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WholeMethodMatcher cls name m r
m forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
WholeMethodMatcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:->) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) [Action cls name m r -> MockT m r]
rs)

-- | Expands a Rule into an expectation, given a target multiplicity.  It is an
-- error if there are too many responses for the multiplicity.  If there are
-- too few responses, the last response will be repeated.
expandRepeatRule ::
  MockableMethod cls name m r =>
  Multiplicity ->
  CallStack ->
  Rule cls name m r ->
  ExpectSet (Step m)
expandRepeatRule :: forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Multiplicity
-> CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRepeatRule Multiplicity
mult CallStack
_ (WholeMethodMatcher cls name m r
_ :=> [Action cls name m r -> MockT m r]
rs)
  | Bool -> Bool
not (Multiplicity -> Bool
feasible (Multiplicity
mult forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action cls name m r -> MockT m r]
rs))) =
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action cls name m r -> MockT m r]
rs)
        forall a. [a] -> [a] -> [a]
++ String
" responses is too many for multiplicity "
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Multiplicity
mult
expandRepeatRule Multiplicity
mult CallStack
callstack (WholeMethodMatcher cls name m r
m :=> (Action cls name m r -> MockT m r
r1 : Action cls name m r -> MockT m r
r2 : [Action cls name m r -> MockT m r]
rs))
  | Multiplicity -> Int -> Bool
meetsMultiplicity Multiplicity
mult Int
0 = forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectEither forall step. ExpectSet step
ExpectNothing ExpectSet (Step m)
body
  | Bool
otherwise = ExpectSet (Step m)
body
  where
    body :: ExpectSet (Step m)
body =
      forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectSequence
        (forall step. step -> ExpectSet step
ExpectStep (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step (forall a. CallStack -> a -> Located a
locate CallStack
callstack (WholeMethodMatcher cls name m r
m forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
WholeMethodMatcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:-> forall a. a -> Maybe a
Just Action cls name m r -> MockT m r
r1))))
        (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Multiplicity
-> CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRepeatRule (Multiplicity
mult forall a. Num a => a -> a -> a
- Multiplicity
1) CallStack
callstack (WholeMethodMatcher cls name m r
m forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
WholeMethodMatcher cls name m r
-> [Action cls name m r -> MockT m r] -> Rule cls name m r
:=> (Action cls name m r -> MockT m r
r2 forall a. a -> [a] -> [a]
: [Action cls name m r -> MockT m r]
rs)))
expandRepeatRule Multiplicity
mult CallStack
callstack (WholeMethodMatcher cls name m r
m :=> [Action cls name m r -> MockT m r]
rs) =
  forall step. Multiplicity -> ExpectSet step -> ExpectSet step
ExpectConsecutive
    Multiplicity
mult
    (forall step. step -> ExpectSet step
ExpectStep (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step (forall a. CallStack -> a -> Located a
locate CallStack
callstack (WholeMethodMatcher cls name m r
m forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
WholeMethodMatcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:-> forall a. [a] -> Maybe a
listToMaybe [Action cls name m r -> MockT m r]
rs))))

-- | Newtype wrapper to make the type of ExpectSet conform to the ExpectContext
-- class.  The "return type" a is a phantom.
newtype Expected m a = Expected {forall (m :: * -> *) a. Expected m a -> ExpectSet (Step m)
unwrapExpected :: ExpectSet (Step m)}

instance ExpectContext Expected where
  expect :: forall (m :: * -> *) (cls :: (* -> *) -> Constraint)
       (name :: Symbol) r expectable.
(HasCallStack, MonadIO m, MockableMethod cls name m r,
 Expectable cls name m r expectable) =>
expectable -> Expected m ()
expect expectable
e = forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRule HasCallStack => CallStack
callStack (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r ex.
Expectable cls name m r ex =>
ex -> Rule cls name m r
toRule expectable
e))
  expectN :: forall (m :: * -> *) (cls :: (* -> *) -> Constraint)
       (name :: Symbol) r expectable.
(HasCallStack, MonadIO m, MockableMethod cls name m r,
 Expectable cls name m r expectable) =>
Multiplicity -> expectable -> Expected m ()
expectN Multiplicity
mult expectable
e = forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Multiplicity
-> CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRepeatRule Multiplicity
mult HasCallStack => CallStack
callStack (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r ex.
Expectable cls name m r ex =>
ex -> Rule cls name m r
toRule expectable
e))
  expectAny :: forall (m :: * -> *) (cls :: (* -> *) -> Constraint)
       (name :: Symbol) r expectable.
(HasCallStack, MonadIO m, MockableMethod cls name m r,
 Expectable cls name m r expectable) =>
expectable -> Expected m ()
expectAny expectable
e =
    forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Multiplicity
-> CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRepeatRule Multiplicity
anyMultiplicity HasCallStack => CallStack
callStack (forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r ex.
Expectable cls name m r ex =>
ex -> Rule cls name m r
toRule expectable
e))
  inSequence :: forall (m :: * -> *).
MonadIO m =>
(forall (ctx' :: (* -> *) -> * -> *).
 ExpectContext ctx' =>
 [ctx' m ()])
-> Expected m ()
inSequence forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
[ctx' m ()]
es = forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectSequence (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Expected m a -> ExpectSet (Step m)
unwrapExpected forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
[ctx' m ()]
es))
  inAnyOrder :: forall (m :: * -> *).
MonadIO m =>
(forall (ctx' :: (* -> *) -> * -> *).
 ExpectContext ctx' =>
 [ctx' m ()])
-> Expected m ()
inAnyOrder forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
[ctx' m ()]
es = forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectInterleave (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Expected m a -> ExpectSet (Step m)
unwrapExpected forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
[ctx' m ()]
es))
  anyOf :: forall (m :: * -> *).
MonadIO m =>
(forall (ctx' :: (* -> *) -> * -> *).
 ExpectContext ctx' =>
 [ctx' m ()])
-> Expected m ()
anyOf forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
[ctx' m ()]
es = forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectEither (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Expected m a -> ExpectSet (Step m)
unwrapExpected forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
[ctx' m ()]
es))
  times :: forall (m :: * -> *).
MonadIO m =>
Multiplicity
-> (forall (ctx' :: (* -> *) -> * -> *).
    ExpectContext ctx' =>
    ctx' m ())
-> Expected m ()
times Multiplicity
mult forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
ctx' m ()
e = forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall step. Multiplicity -> ExpectSet step -> ExpectSet step
ExpectMulti Multiplicity
mult (forall (m :: * -> *) a. Expected m a -> ExpectSet (Step m)
unwrapExpected forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
ctx' m ()
e))
  consecutiveTimes :: forall (m :: * -> *).
MonadIO m =>
Multiplicity
-> (forall (ctx' :: (* -> *) -> * -> *).
    ExpectContext ctx' =>
    ctx' m ())
-> Expected m ()
consecutiveTimes Multiplicity
mult forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
ctx' m ()
e =
    forall (m :: * -> *) a. ExpectSet (Step m) -> Expected m a
Expected (forall step. Multiplicity -> ExpectSet step -> ExpectSet step
ExpectConsecutive Multiplicity
mult (forall (m :: * -> *) a. Expected m a -> ExpectSet (Step m)
unwrapExpected forall (ctx' :: (* -> *) -> * -> *).
ExpectContext ctx' =>
ctx' m ()
e))