{-# 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 (..))
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
  (:->) ::
    Matcher 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
_ (Matcher cls name m r
m :-> Maybe (Action cls name m r -> MockT m r)
_))) =
    Located String -> String
withLoc (Maybe (Action cls name m Any) -> Matcher cls name m r -> String
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a b.
MockableBase cls =>
Maybe (Action cls name m a) -> Matcher cls name m b -> String
showMatcher Maybe (Action cls name m Any)
forall a. Maybe a
Nothing Matcher cls name m r
m String -> Located (SingleRule cls name m r) -> Located String
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 :: CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRule CallStack
callstack (Matcher cls name m r
m :=> []) =
  Step m -> ExpectSet (Step m)
forall step. step -> ExpectSet step
ExpectStep (Located (SingleRule cls name m r) -> Step m
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step (CallStack
-> SingleRule cls name m r -> Located (SingleRule cls name m r)
forall a. CallStack -> a -> Located a
locate CallStack
callstack (Matcher cls name m r
m Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:-> Maybe (Action cls name m r -> MockT m r)
forall a. Maybe a
Nothing)))
expandRule CallStack
callstack (Matcher cls name m r
m :=> [Action cls name m r -> MockT m r]
rs) =
  (ExpectSet (Step m) -> ExpectSet (Step m) -> ExpectSet (Step m))
-> [ExpectSet (Step m)] -> ExpectSet (Step m)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1
    ExpectSet (Step m) -> ExpectSet (Step m) -> ExpectSet (Step m)
forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectSequence
    (((Action cls name m r -> MockT m r) -> ExpectSet (Step m))
-> [Action cls name m r -> MockT m r] -> [ExpectSet (Step m)]
forall a b. (a -> b) -> [a] -> [b]
map (Step m -> ExpectSet (Step m)
forall step. step -> ExpectSet step
ExpectStep (Step m -> ExpectSet (Step m))
-> ((Action cls name m r -> MockT m r) -> Step m)
-> (Action cls name m r -> MockT m r)
-> ExpectSet (Step m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (SingleRule cls name m r) -> Step m
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step (Located (SingleRule cls name m r) -> Step m)
-> ((Action cls name m r -> MockT m r)
    -> Located (SingleRule cls name m r))
-> (Action cls name m r -> MockT m r)
-> Step m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack
-> SingleRule cls name m r -> Located (SingleRule cls name m r)
forall a. CallStack -> a -> Located a
locate CallStack
callstack (SingleRule cls name m r -> Located (SingleRule cls name m r))
-> ((Action cls name m r -> MockT m r) -> SingleRule cls name m r)
-> (Action cls name m r -> MockT m r)
-> Located (SingleRule cls name m r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Matcher cls name m r
m Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:->) (Maybe (Action cls name m r -> MockT m r)
 -> SingleRule cls name m r)
-> ((Action cls name m r -> MockT m r)
    -> Maybe (Action cls name m r -> MockT m r))
-> (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Action cls name m r -> MockT m r)
-> Maybe (Action cls name m r -> MockT m r)
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 :: Multiplicity
-> CallStack -> Rule cls name m r -> ExpectSet (Step m)
expandRepeatRule Multiplicity
mult CallStack
_ (Matcher cls name m r
_ :=> [Action cls name m r -> MockT m r]
rs)
  | Bool -> Bool
not (Multiplicity -> Bool
feasible (Multiplicity
mult Multiplicity -> Multiplicity -> Multiplicity
forall a. Num a => a -> a -> a
- Int -> Multiplicity
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Action cls name m r -> MockT m r] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action cls name m r -> MockT m r]
rs))) =
    String -> ExpectSet (Step m)
forall a. HasCallStack => String -> a
error (String -> ExpectSet (Step m)) -> String -> ExpectSet (Step m)
forall a b. (a -> b) -> a -> b
$
      Int -> String
forall a. Show a => a -> String
show ([Action cls name m r -> MockT m r] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action cls name m r -> MockT m r]
rs)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" responses is too many for multiplicity "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Multiplicity -> String
forall a. Show a => a -> String
show Multiplicity
mult
expandRepeatRule Multiplicity
mult CallStack
callstack (Matcher 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 = ExpectSet (Step m) -> ExpectSet (Step m) -> ExpectSet (Step m)
forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectEither ExpectSet (Step m)
forall step. ExpectSet step
ExpectNothing ExpectSet (Step m)
body
  | Bool
otherwise = ExpectSet (Step m)
body
  where
    body :: ExpectSet (Step m)
body =
      ExpectSet (Step m) -> ExpectSet (Step m) -> ExpectSet (Step m)
forall step. ExpectSet step -> ExpectSet step -> ExpectSet step
ExpectSequence
        (Step m -> ExpectSet (Step m)
forall step. step -> ExpectSet step
ExpectStep (Located (SingleRule cls name m r) -> Step m
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step (CallStack
-> SingleRule cls name m r -> Located (SingleRule cls name m r)
forall a. CallStack -> a -> Located a
locate CallStack
callstack (Matcher cls name m r
m Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:-> (Action cls name m r -> MockT m r)
-> Maybe (Action cls name m r -> MockT m r)
forall a. a -> Maybe a
Just Action cls name m r -> MockT m r
r1))))
        (Multiplicity
-> CallStack -> Rule cls name m r -> ExpectSet (Step m)
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 Multiplicity -> Multiplicity -> Multiplicity
forall a. Num a => a -> a -> a
- Multiplicity
1) CallStack
callstack (Matcher cls name m r
m Matcher cls name m r
-> [Action cls name m r -> MockT m r] -> Rule cls name m r
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
Matcher 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 (Action cls name m r -> MockT m r)
-> [Action cls name m r -> MockT m r]
-> [Action cls name m r -> MockT m r]
forall a. a -> [a] -> [a]
: [Action cls name m r -> MockT m r]
rs)))
expandRepeatRule Multiplicity
mult CallStack
callstack (Matcher cls name m r
m :=> [Action cls name m r -> MockT m r]
rs) =
  Multiplicity -> ExpectSet (Step m) -> ExpectSet (Step m)
forall step. Multiplicity -> ExpectSet step -> ExpectSet step
ExpectConsecutive
    Multiplicity
mult
    (Step m -> ExpectSet (Step m)
forall step. step -> ExpectSet step
ExpectStep (Located (SingleRule cls name m r) -> Step m
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
MockableMethod cls name m r =>
Located (SingleRule cls name m r) -> Step m
Step (CallStack
-> SingleRule cls name m r -> Located (SingleRule cls name m r)
forall a. CallStack -> a -> Located a
locate CallStack
callstack (Matcher cls name m r
m Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
Matcher cls name m r
-> Maybe (Action cls name m r -> MockT m r)
-> SingleRule cls name m r
:-> [Action cls name m r -> MockT m r]
-> Maybe (Action cls name m r -> MockT 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 {Expected m a -> ExpectSet (Step m)
unwrapExpected :: ExpectSet (Step m)}

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