packages feed

method 0.2.0.0 → 0.3.0.0

raw patch · 10 files changed

+1043/−41 lines, 10 files

Files

CHANGELOG.md view
@@ -1,5 +1,18 @@ # Revision history for method +## 0.3.0.0 -- 2021-02-22+* Add new Protocol DSL to write communication specification between multiple methods. [\#5](https://github.com/autotaker/method/issues/5)+  * Added new `Test.Method.Protocol` module.+  * Generalize `thenReturn`, `thenAction`, and `thenMethod` by using `Behave` type class.+  * Rename `throwNoStubShow` -> `throwNoStub` and `throwNoStub` -> `throwNoStubWithShow` to+    keep consistency with `lookupMock`/`lookupMockWithShow`.+* Add functions to mock polymorphic methods. [\#7](https://github.com/autotaker/method/issues/7)+  * Added new `Test.Method.Dynamic` module.++## 0.2.0.0 -- 2021-01-10+* `throwNoStub` throws runtime exception instead of throwing exception via `MonadThrow`. [\#1](https://github.com/autotaker/method/issues/1)++ ## 0.1.0.0 -- 2021-01-09  * First stable version
method.cabal view
@@ -4,7 +4,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/  name:               method-version:            0.2.0.0+version:            0.3.0.0 synopsis:           rebindable methods for improving testability description:   This package provides Method typeclass, which represents @@ -46,10 +46,13 @@     Control.Method     Control.Method.Internal     Test.Method+    Test.Method.Behavior+    Test.Method.Dynamic     Test.Method.Matcher     Test.Method.Mock     Test.Method.Monitor     Test.Method.Monitor.Internal+    Test.Method.Protocol    -- other-modules:   -- other-extensions:@@ -64,7 +67,9 @@    -- cabal-fmt: expand test -Spec   other-modules:+    Test.Method.DynamicSpec     Test.Method.MockSpec     Test.Method.MonitorSpec+    Test.Method.ProtocolSpec    build-depends:    method
src/Control/Method/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}@@ -14,6 +15,8 @@   ) where +import GHC.Generics (Generic)+ class TupleLike a where   type AsTuple a   fromTuple :: AsTuple a -> a@@ -81,6 +84,6 @@  -- | Tuple constructor data a :* b = a :* !b-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic)  infixr 1 :*
src/Test/Method.hs view
@@ -8,7 +8,7 @@ module Test.Method   ( -- $usage -    -- * Mock+    -- * Mocking monomorphic methods      -- ** Usage     -- $mock@@ -18,9 +18,21 @@     thenReturn,     thenAction,     thenMethod,-    throwNoStubShow,+    throwNoStubWithShow,     throwNoStub, +    -- * Mocking polymorphic methods++    -- ** Usage+    -- $dynamic+    DynamicShow,+    Dynamic,+    castMethod,+    dynArg,+    FromDyn (fromDyn),+    ToDyn (toDyn),+    Typeable,+     -- * Monitor      -- ** Usage@@ -42,6 +54,23 @@     newMonitor,     listenEventLog, +    -- * Protocol++    -- ** Usage+    -- $protocol++    -- ** References+    protocol,+    ProtocolM,+    ProtocolEnv,+    CallId,+    decl,+    whenArgs,+    dependsOn,+    lookupMock,+    lookupMockWithShow,+    verify,+     -- * Matcher      -- ** References@@ -58,6 +87,7 @@   ) where +import Test.Method.Dynamic import Test.Method.Matcher   ( ArgsMatcher (..),     Matcher,@@ -72,7 +102,7 @@     thenMethod,     thenReturn,     throwNoStub,-    throwNoStubShow,+    throwNoStubWithShow,   ) import Test.Method.Monitor   ( Event,@@ -86,6 +116,18 @@     withMonitor,     withMonitor_,   )+import Test.Method.Protocol+  ( CallId,+    ProtocolEnv,+    ProtocolM,+    decl,+    dependsOn,+    lookupMock,+    lookupMockWithShow,+    protocol,+    verify,+    whenArgs,+  )  -- $usage -- This module provides DSLs for mocking@@ -100,7 +142,7 @@ --   'when' ('args' (\\x -> mod x 3 == 0)) `'thenReturn'` "fizz" --   'when' ('args' (\\x -> mod x 5 == 0)) `'thenReturn'` "buzz" --   'when' ('args' (>=0)) `'thenMethod'` (\\x -> pure $ show x)---   'throwNoStubShow' $ 'when' 'anything'+--   'throwNoStub' $ 'when' 'anything' -- @ -- -- >>> fizzbuzz 0@@ -164,4 +206,172 @@ -- --   it "does not call example 3 \\\"bar\\\" " $ \\logs -> do --     logs `'shouldSatisfy'` ((==0) `'times'` 'call' ('args' ((==3), (=="bar"))))+-- @++-- $protocol+-- Protocol is a DSL to write specification on communications between dependent methods.+-- By using Protocol, you can specify+--+-- * how many times each method is called,+-- * what arguments are passed for each call, and+-- * in which order methods are called.+--+-- For example, let's test user creation logic @signup@.+--+-- @+-- signup :: Service -> Username -> IO (Maybe UserId)+-- signup svc username = ...+-- type UserName = String+-- type UserId = Int+-- @+--+-- This method depends on @Service@, which consists of two methods.+--+-- * @findUser@: checks whether the user name is taken already,+-- * @createUser@: creates a user with given user name.+--+-- @+-- data Service = Service{+--   findUser :: UserName -> IO (Maybe UserId),+--   createUser :: UserName -> IO UserId+-- }+-- @+--+-- Let's check the following specification of @signup@ method.+--+-- 1. If @findUser@ returns @Just user@, it returns @Nothing@ without calling @createUser@.+-- 2. If @findUser@ returns @Nothing@, it calls @createUser@ and returns the created user.+--+-- In order to write Protocol DSL, first you define a GADT functor that+-- represents labels of dependent methods.+--+-- @+-- data Methods m where+--   FindUser :: Methods (UserName -> IO (Maybe UserId))+--   CreateUser :: Methods (UserName -> IO UserId)+--+-- deriving instance (Show (Methods m))+-- deriving instance (Eq (Methods m))+-- deriving instance (Ord (Methods m))+-- @+--+-- Then, you can write test for the specification.+--+-- @+-- spec :: Spec+-- spec = do+--   describe "signup" $ do+--     let username = "user1"+--         userId = 1+--     context "if ``findUser`` returns `Just user`" $+--       it "return \`Nothing\` without calling ``createUser``" $ do+--         -- Because env is stateful, it should be initialized for each test+--         env <- 'protocol' $ do+--           'decl' $ 'whenArgs' FindUser (==username) ``thenReturn`` Just userId+--         -- mocking methods from protocol env. Each mock method raises an exception+--         -- if it is called in a different way than that specified by the protocol.+--         let service = Service {+--               findUser = 'lookupMock' FindUser env,+--               createUser = 'lookupMock' CreateUser env+--             }+--         signup service username \`shouldReturn\` Nothing+--         -- Checks all calls specified by the protocol are called.+--         'verify' env+--+--       it "call ``createUser`` and return `Just userId`" $ do+--         env <- protocol $ do+--           findUserCall <- 'decl' $ 'whenArgs' FindUser (==username) ``thenReturn`` Nothing+--           'decl' $ 'whenArgs' CreateUser (==username) ``thenReturn`` Just userId ``dependsOn`` [findUserCall]+--         let service = Service {+--               findUser = 'lookupMock' FindUser env,+--               createUser = 'lookupMock' CreateUser env+--             }+--         signup service username ``shouldReturn`` Just userId+--         'verify' env+-- @+--+-- Protocol DSL consists of method call declarations like:+--+-- @+-- 'decl' $ 'whenArgs' FindUser (=="user1") ``thenReturn`` Nothing+-- @+--+-- This declaration specifies that @findUser@ is called once with argument @"user1"@+-- and it returns @Nothing@.+-- If @findUser@ is called with other argument, it raises an exception.+--+-- In protocol DSL, you can specify in which order methods are called, by using 'dependsOn' function.+-- For example:+--+-- @+-- findUserCall <- 'decl' $ 'whenArgs' FindUser (=="user1") ``thenReturn`` Nothing+-- 'decl' $ 'whenArgs' CreateUser (=="user1") ``thenReturn`` Nothing ``dependsOn`` [findUserCall]+-- @+--+-- @findUser@ must be called before calling @createUser@.+-- On the other hand, in the following example:+--+-- @+-- 'decl' $ 'whenArgs' FindUser (=="user1") ``thenReturn`` Nothing+-- 'decl' $ 'whenArgs' CreateUser (=="user1") ``thenReturn`` Nothing+-- @+--+-- the order of calling two methods does not matter.+--+-- However, each call declaration implicitly depends on the previous call declaration of the same method.+-- For example:+--+-- @+-- 'decl' $ 'whenArgs' FindUser (=="user1") ``thenReturn`` Nothing+-- 'decl' $ 'whenArgs' FindUser (=="user2") ``thenReturn`` Just 1+-- @+--+-- @findUser "user1"@ must be called before @findUser "user2"@ is called.++-- $dynamic+-- Often you want to mock polymorphic functions.+-- For example, assume that we are testing the following method.+--+-- @+-- type QueryFunc = forall q r. (ToRow q, FromRow r) => Query -> q -> IO [r]+-- service :: QueryFunc -> Day -> IO [Event]+-- service query today = do+--   events <- query "SELECT * FROM event WHERE date = ?" (Only today)+--   pure events+-- @+--+-- Because @QueryFunc@ is a polymorphic function, it is impossible to mock directly with 'mockup'.+--+-- In order to mock @QueryFunc@, first add 'Typeable' (and 'Show') constraint(s) for each type variables.+--+-- @+-- type QueryFunc = forall q r. (ToRow q, 'Typeable' q, 'Show' q, FromRow r, 'Typeable' r, 'Show' r) => Query -> q -> IO [r]+-- @+--+-- Next, we mock dynamic version of 'QueryFunc', where each type variable is replaced with 'DynamicShow'+-- (or 'Dynamic').+-- Finally, we obtain polymorphic method by casting+-- the dynamic version with 'castMethod'.+--+-- @+-- queryDyn :: Query -> 'DynamicShow' -> IO ['DynamicShow']+-- queryDyn = 'mockup' $ ...+-- queryMock :: QueryFunc+-- queryMock = 'castMethod' queryDyn+-- @+--+-- Now you can write test for @service@ as follows.+--+-- @+-- spec :: Spec+-- spec = do+--   describe "service" $ do+--     it "return events whose dates are equal to today" $ do+--       let today = fromGregorian 2020 2 20+--           sql = "SELECT * FROM event WHERE date = ?"+--           events = [Event 0, Event 1]+--           queryDyn :: Query -> 'DynamicShow' -> IO ['DynamicShow']+--           queryDyn = mockup $+--             when (args ((==sql), 'dynArg' (==today))) ``thenReturn`` 'toDyn' events+--       service ('castMethod' queryDyn) today ``shouldReturn`` events -- @
+ src/Test/Method/Behavior.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Method.Behavior+  ( Behave (..),+    thenReturn,+    thenAction,+  )+where++import Control.Method (Method (Base, Ret, curryMethod))++-- | A type class whose behavior is specified by a method+class Behave x where+  -- | Type of the first argument of 'thenMethod',+  --   representing the condition when the method is called+  type Condition x++  -- | Type of the second argument of 'thenMethod',+  --   representing a method to be called.+  type MethodOf x++  -- | Specify behavior from a pair of a condition and a method.+  thenMethod :: Condition x -> MethodOf x -> x++-- | Specify behavior that return a constant value for a call+thenReturn ::+  (Behave x, Method (MethodOf x)) =>+  Condition x ->+  Ret (MethodOf x) ->+  x+thenReturn lhs v =+  thenMethod lhs $ curryMethod $ const $ pure v++-- | Specify behavior that executes an action for a call+thenAction ::+  (Behave x, Method (MethodOf x)) =>+  Condition x ->+  Base (MethodOf x) (Ret (MethodOf x)) ->+  x+thenAction lhs action =+  thenMethod lhs $ curryMethod $ const action
+ src/Test/Method/Dynamic.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Test.Method.Dynamic+-- Description:+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Test.Method.Dynamic+  ( DynamicShow,+    Dynamic,+    castMethod,+    dynArg,+    DynamicLike (..),+    FromDyn (..),+    ToDyn (..),+    Typeable,+  )+where++import Control.Method (Method (Args, Base, Ret, curryMethod, uncurryMethod))+import Control.Method.Internal (type (:*))+import Data.Dynamic (Dynamic)+import qualified Data.Dynamic as D+import Data.Typeable (Proxy (Proxy), Typeable, typeRep)+import GHC.Generics+  ( Generic (Rep, from, to),+    K1 (K1),+    M1 (M1),+    U1 (U1),+    type (:*:) ((:*:)),+    type (:+:) (L1, R1),+  )+import Test.Method.Matcher (Matcher)++-- | Dynamic value whose content is showable.+-- Using this type instead of 'Dynamic' is recommended because it gives better error messages.+data DynamicShow = DynamicShow !Dynamic String++instance Show DynamicShow where+  show (DynamicShow v s) = "<<" ++ s ++ " :: " ++ show (D.dynTypeRep v) ++ ">>"++-- | @FromDyn a b@ provides a function to convert type @a@ to type @b@,+-- where @b@ is a type whose dynamic type occurences are replaced by concrete types.+--+-- For example: @FromDyn (Int, Dynamic, Maybe Dynamic) (Int, Bool, Maybe String)@+class FromDyn a b where+  -- | convert dynamic value to specified type. It thows runtime exception if+  -- the dynamic value does not have specified type.+  fromDyn :: a -> b+  default fromDyn :: (Generic a, Generic b, FromDyn' (Rep a) (Rep b)) => a -> b+  fromDyn = to . fromDyn' . from++-- | @ToDyn a b@ provides a function to convert type @b@ to type @a@, where+-- @b@ is a type whose dynamic type occurences are replaced by concrete types.+--+-- For example: @ToDyn (Int, Dynamic, Maybe Dynamic) (Int, Bool, Maybe String)@+class ToDyn a b where+  -- | convert value of specified type to dynamic value+  toDyn :: b -> a+  default toDyn :: (Generic a, Generic b, ToDyn' (Rep a) (Rep b)) => b -> a+  toDyn = to . toDyn' . from++class FromDyn' f g where+  fromDyn' :: f a -> g a++class ToDyn' f g where+  toDyn' :: g a -> f a++instance (FromDyn' f f', FromDyn' g g') => FromDyn' (f :+: g) (f' :+: g') where+  {-# INLINE fromDyn' #-}+  fromDyn' (L1 a) = L1 (fromDyn' a)+  fromDyn' (R1 b) = R1 (fromDyn' b)++instance (FromDyn' f f', FromDyn' g g') => FromDyn' (f :*: g) (f' :*: g') where+  {-# INLINE fromDyn' #-}+  fromDyn' (a :*: b) = fromDyn' a :*: fromDyn' b++instance (FromDyn a a') => FromDyn' (K1 i a) (K1 i a') where+  {-# INLINE fromDyn' #-}+  fromDyn' (K1 a) = K1 (fromDyn a)++instance FromDyn' U1 U1 where+  {-# INLINE fromDyn' #-}+  fromDyn' _ = U1++instance (FromDyn' f f') => FromDyn' (M1 i t f) (M1 i t f') where+  {-# INLINE fromDyn' #-}+  fromDyn' (M1 a) = M1 (fromDyn' a)++instance Typeable a => FromDyn Dynamic a where+  fromDyn = fromDynamic++instance (Typeable a, Show a) => FromDyn DynamicShow a where+  fromDyn = fromDynamic++instance {-# INCOHERENT #-} FromDyn a a where+  {-# INLINE fromDyn #-}+  fromDyn = id++instance (ToDyn' f f', ToDyn' g g') => ToDyn' (f :+: g) (f' :+: g') where+  {-# INLINE toDyn' #-}+  toDyn' (L1 a) = L1 (toDyn' a)+  toDyn' (R1 b) = R1 (toDyn' b)++instance (ToDyn' f f', ToDyn' g g') => ToDyn' (f :*: g) (f' :*: g') where+  {-# INLINE toDyn' #-}+  toDyn' (a :*: b) = toDyn' a :*: toDyn' b++instance (ToDyn a a') => ToDyn' (K1 i a) (K1 i a') where+  {-# INLINE toDyn' #-}+  toDyn' (K1 a) = K1 (toDyn a)++instance ToDyn' U1 U1 where+  {-# INLINE toDyn' #-}+  toDyn' _ = U1++instance (ToDyn' f f') => ToDyn' (M1 i t f) (M1 i t f') where+  {-# INLINE toDyn' #-}+  toDyn' (M1 a) = M1 (toDyn' a)++instance Typeable a => ToDyn Dynamic a where+  toDyn = D.toDyn++instance (Typeable a, Show a) => ToDyn DynamicShow a where+  toDyn = toDynamicShow++instance {-# INCOHERENT #-} ToDyn a a where+  {-# INLINE toDyn #-}+  toDyn = id++instance (FromDyn a a', ToDyn b b') => ToDyn (a -> b) (a' -> b') where+  toDyn f a = toDyn $ f (fromDyn a)++instance (ToDyn a a', FromDyn b b') => FromDyn (a -> b) (a' -> b') where+  fromDyn f a = fromDyn $ f (toDyn a)++instance (FromDyn a b, FromDyn c d) => FromDyn (a :* c) (b :* d)++instance (ToDyn a b, ToDyn c d) => ToDyn (a :* c) (b :* d)++instance (FromDyn a b) => FromDyn [a] [b]++instance (ToDyn a b) => ToDyn [a] [b]++instance (FromDyn a b) => FromDyn (Maybe a) (Maybe b)++instance (ToDyn a b) => ToDyn (Maybe a) (Maybe b)++instance (FromDyn a a', FromDyn b b') => FromDyn (Either a b) (Either a' b')++instance (ToDyn a a', ToDyn b b') => ToDyn (Either a b) (Either a' b')++instance (FromDyn a a', FromDyn b b') => FromDyn (a, b) (a', b')++instance (ToDyn a a', ToDyn b b') => ToDyn (a, b) (a', b')++instance (FromDyn a a', FromDyn b b', FromDyn c c') => FromDyn (a, b, c) (a', b', c')++instance (ToDyn a a', ToDyn b b', ToDyn c c') => ToDyn (a, b, c) (a', b', c')++instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d') => FromDyn (a, b, c, d) (a', b', c', d')++instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d') => ToDyn (a, b, c, d) (a', b', c', d')++instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d', FromDyn e e') => FromDyn (a, b, c, d, e) (a', b', c', d', e')++instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d', ToDyn e e') => ToDyn (a, b, c, d, e) (a', b', c', d', e')++instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d', FromDyn e e', FromDyn f f') => FromDyn (a, b, c, d, e, f) (a', b', c', d', e', f')++instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d', ToDyn e e', ToDyn f f') => ToDyn (a, b, c, d, e, f) (a', b', c', d', e', f')++instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d', FromDyn e e', FromDyn f f', FromDyn g g') => FromDyn (a, b, c, d, e, f, g) (a', b', c', d', e', f', g')++instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d', ToDyn e e', ToDyn f f', ToDyn g g') => ToDyn (a, b, c, d, e, f, g) (a', b', c', d', e', f', g')++-- | convert a dynamically-typed method to a polymorphic method.+--+--   @+--   fDyn :: String -> DynamicShow -> Dynamic -> IO [DynamicShow]+--   fDyn = ...+--   fPoly :: (Typeable a, Show a, Typeable b, Typeable c, Show c) => String -> a -> b -> IO [c]+--   fPoly = castMethod fDyn+--   @+castMethod ::+  ( ToDyn (Args method) (Args method'),+    FromDyn (Ret method) (Ret method'),+    Method method,+    Method method',+    Base method ~ Base method'+  ) =>+  method ->+  method'+castMethod method = curryMethod $ \args ->+  fromDyn <$> uncurryMethod method (toDyn args)++fromDynamic :: forall a d. (Typeable a, DynamicLike d, Show d) => d -> a+fromDynamic v =+  D.fromDyn (asDyn v) $+    error $ "cannot cast " ++ show v ++ " to " ++ show (typeRep (Proxy :: Proxy a))++toDynamicShow :: (Typeable a, Show a) => a -> DynamicShow+toDynamicShow a = DynamicShow (D.toDyn a) (show a)++-- | Generalizes 'Dynamic' and 'DynamicShow'+class DynamicLike a where+  asDyn :: a -> Dynamic++instance DynamicLike Dynamic where+  asDyn = id++instance DynamicLike DynamicShow where+  asDyn (DynamicShow a _) = a++-- | Convert given matcher to dynamic matcher. The dynamic matcher+-- matches a dynamic value only if the value has the type of given matcher.+dynArg :: (Typeable a, DynamicLike b) => Matcher a -> Matcher b+dynArg matcher dv =+  maybe False matcher $ D.fromDynamic $ asDyn dv
src/Test/Method/Mock.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}  -- |@@ -12,26 +15,37 @@ -- DSL to generate mock methods. module Test.Method.Mock   ( Mock,-    MockSpec,+    MockM,     mockup,     thenReturn,     thenAction,     thenMethod,-    throwNoStubShow,+    throwNoStubWithShow,     throwNoStub,   ) where  import Control.Method-  ( Method (Args, Base, Ret, curryMethod, uncurryMethod),+  ( 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 = Writer (MockSpec method) ()+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)@@ -47,53 +61,33 @@ -- 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 spec = buildMock (execWriter spec)+mockup (MockM spec) = buildMock (execWriter spec)  buildMock :: Method method => MockSpec method -> method buildMock spec = fromRules $ toRules 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 retVal =-  tell $ MockSpec matcher $ curryMethod (const $ pure 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 ret =-  tell $ MockSpec matcher $ curryMethod $ const 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 method = tell $ MockSpec matcher method+instance a ~ () => Behave (MockM method a) where+  type Condition (MockM method a) = Matcher (Args method)+  type MethodOf (MockM method a) = method+  thenMethod lhs method = tell $ MockSpec lhs method --- | @'throwNoStubShow' matcher@ means the method raises a runtime exception+-- | @'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.-throwNoStubShow ::+throwNoStub ::   ( Method method,     Show (AsTuple (Args method)),     TupleLike (Args method)   ) =>   Matcher (Args method) ->   Mock method-throwNoStubShow matcher =-  tell $-    MockSpec matcher $-      curryMethod $-        error . ("no stub found for argument: " <>) . show . toTuple+throwNoStub = throwNoStubWithShow (show . toTuple) --- | @'throwNoStubShow' fshow matcher@ means the method raises runtime exception+-- | @'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.-throwNoStub :: (Method method) => (Args method -> String) -> (Args method -> Bool) -> Mock method-throwNoStub fshow matcher =+throwNoStubWithShow :: (Method method) => (Args method -> String) -> (Args method -> Bool) -> Mock method+throwNoStubWithShow fshow matcher =   tell $     MockSpec matcher $       curryMethod $ error . ("no stub found for argument: " <>) . fshow
+ src/Test/Method/Protocol.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Test.Method.Protocol+-- Description:+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Test.Method.Protocol+  ( protocol,+    ProtocolM,+    ProtocolEnv,+    Call,+    CallArgs,+    CallId,+    IsMethodName,+    lookupMock,+    lookupMockWithShow,+    decl,+    whenArgs,+    thenMethod,+    thenAction,+    thenReturn,+    dependsOn,+    verify,+  )+where++import Control.Method+  ( Method (Args, Base, curryMethod, uncurryMethod),+    TupleLike (AsTuple, toTuple),+  )+import Control.Monad.Trans.State.Strict (StateT, execStateT, state)+import Data.Maybe (fromJust)+import Data.Typeable+  ( Typeable,+    cast,+    typeOf,+  )+import RIO (IORef, MonadIO (liftIO), Set, forM_, newIORef, on, readIORef, unless, writeIORef, (&))+import qualified RIO.List as L+import qualified RIO.Map as M+import qualified RIO.Set as S+import Test.Method.Behavior (Behave (Condition, MethodOf, thenMethod), thenAction, thenReturn)+import Test.Method.Matcher (ArgsMatcher (EachMatcher, args), Matcher)+import Unsafe.Coerce (unsafeCoerce)++newtype CallId = CallId {unCallId :: Int}+  deriving (Eq, Ord, Show)++data CallArgs f m = CallArgs+  { methodName :: f m,+    argsMatcher :: Matcher (Args m)+  }++data Call f m = Call+  { argsSpec :: CallArgs f m,+    retSpec :: m,+    dependCall :: [CallId]+  }++data SomeCall f where+  SomeCall :: IsMethodName f m => Call f m -> SomeCall f++data SomeMethodName f where+  SomeMethodName :: IsMethodName f m => f m -> SomeMethodName f++instance Eq (SomeMethodName f) where+  SomeMethodName x == SomeMethodName y =+    case cast y of+      Just y' -> x == y'+      Nothing -> False++instance Ord (SomeMethodName f) where+  compare (SomeMethodName x) (SomeMethodName y) =+    compare (typeOf x) (typeOf y) <> case cast y of+      Just y' -> compare x y'+      Nothing -> LT++instance Show (SomeMethodName f) where+  show (SomeMethodName x) = show x++data MethodCallAssoc f where+  MethodCallAssoc ::+    forall f m.+    (Typeable (f m), Show (f m)) =>+    { assocCalls :: [(CallId, Call f m)],+      assocCounter :: IORef Int+    } ->+    MethodCallAssoc f++-- | @'ProtocolEnv' f@ provides mock methods, where @f@ is a GADT functor that+--   represents the set of dependent methods.+data ProtocolEnv f = ProtocolEnv+  { callSpecs :: [(CallId, SomeCall f)],+    methodEnv :: M.Map (SomeMethodName f) (MethodCallAssoc f),+    calledIdSetRef :: IORef (Set CallId)+  }++newtype ProtocolM f a+  = ProtocolM (StateT ([(CallId, SomeCall f)], CallId) IO a)++deriving instance Functor (ProtocolM f)++deriving instance Applicative (ProtocolM f)++deriving instance Monad (ProtocolM f)++getMethodName :: SomeCall f -> SomeMethodName f+getMethodName (SomeCall Call {argsSpec = CallArgs {methodName = name}}) = SomeMethodName name++-- | Build 'ProtocolEnv' from Protocol DSL.+protocol :: ProtocolM f a -> IO (ProtocolEnv f)+protocol (ProtocolM dsl) = do+  (specs, _) <- execStateT dsl ([], CallId 0)+  assocList <-+    specs+      & map (\(callId, call) -> (getMethodName call, callId, call))+      & L.sortOn (\(x, y, _) -> (x, y))+      & L.groupBy ((==) `on` (\(x, _, _) -> x))+      & mapM+        ( \l ->+            case head l of+              (SomeMethodName (name :: f m), _, _) -> do+                ref <- newIORef 0+                pure+                  ( SomeMethodName name,+                    MethodCallAssoc @f @m+                      [(callId, unsafeCoerce call) | (_, callId, SomeCall call) <- l]+                      ref+                  )+        )+  ref <- newIORef S.empty+  pure+    ProtocolEnv+      { callSpecs = specs,+        methodEnv = M.fromList assocList,+        calledIdSetRef = ref+      }++tick :: MonadIO m => IORef Int -> m Int+tick ref = liftIO $ do+  x <- readIORef ref+  writeIORef ref (x + 1)+  pure x++type IsMethodName f m = (Typeable (f m), Ord (f m), Show (f m))++-- | Get the mock method by method name.+--   Return a unstubed method (which throws exception for every call)+--   if the behavior of the method is unspecified by ProtocolEnv+lookupMock ::+  forall f m.+  (IsMethodName f m, Show (AsTuple (Args m)), TupleLike (Args m), Method m, MonadIO (Base m)) =>+  -- | name of method+  f m ->+  ProtocolEnv f ->+  m+lookupMock = lookupMockWithShow (show . toTuple)++-- | Get the mock method by method name.+--   Return a unstubed method (which throws exception for every call)+--   if the behavior of the method is unspecified by ProtocolEnv.+--   Use this function only if you want to customize+--   show implementation for the argument of the method.+lookupMockWithShow ::+  forall f m.+  (IsMethodName f m, Method m, MonadIO (Base m)) =>+  -- | show function for the argument of method+  (Args m -> String) ->+  -- | name of method+  f m ->+  ProtocolEnv f ->+  m+lookupMockWithShow fshow name ProtocolEnv {..} =+  case M.lookup (SomeMethodName name) methodEnv of+    Nothing -> curryMethod $ \_ ->+      error $+        "0-th call of method " <> show name <> " is unspecified"+    Just MethodCallAssoc {assocCalls = assocCalls', ..} ->+      let assocCalls = unsafeCoerce assocCalls' :: [(CallId, Call f m)]+       in curryMethod $ \xs -> do+            i <- tick assocCounter+            unless (i < length assocCalls) $+              error $ show i <> "-th call of method " <> show name <> " is unspecified"+            let (callId, Call {..}) = assocCalls !! i+                CallArgs {..} = argsSpec+            unless (argsMatcher xs) $+              error $+                "unexpected argument of " <> show i <> "-th call of method " <> show name <> ": "+                  <> fshow xs+            calledIdSet <- liftIO $ readIORef calledIdSetRef+            forM_ dependCall $ \callId' -> do+              unless (S.member callId' calledIdSet) $+                let call = fromJust $ L.lookup callId' callSpecs+                 in error $ "dependent method " <> show (getMethodName call) <> " is not called: " <> show callId'+            liftIO $ writeIORef calledIdSetRef $! S.insert callId calledIdSet+            uncurryMethod retSpec xs++-- | Declare a method call specification. It returns the call id of the method call.+decl :: (IsMethodName f m) => Call f m -> ProtocolM f CallId+decl call = ProtocolM $+  state $ \(l, callId@(CallId i)) ->+    (callId, ((callId, SomeCall call) : l, CallId (i + 1)))++-- | Specify the argument condition of a method call+whenArgs :: ArgsMatcher (Args m) => f m -> EachMatcher (Args m) -> CallArgs f m+whenArgs name matcher = CallArgs {methodName = name, argsMatcher = args matcher}++instance Behave (Call f m) where+  type Condition (Call f m) = CallArgs f m+  type MethodOf (Call f m) = m+  thenMethod lhs m =+    Call+      { argsSpec = lhs,+        retSpec = m,+        dependCall = []+      }++-- | Specify on which method calls the call depends.+dependsOn :: Call f m -> [CallId] -> Call f m+dependsOn call depends = call {dependCall = depends <> dependCall call}++-- | Verify that all method calls specified by Protocol DSL are fired.+verify :: ProtocolEnv f -> IO ()+verify ProtocolEnv {..} = do+  forM_ (M.assocs methodEnv) $ \(name, MethodCallAssoc {..}) -> do+    n <- readIORef assocCounter+    let expected = length assocCalls+    unless (n == expected) $+      error $+        "method " <> show name <> " should be called " <> show expected+          <> " times, but actually is called "+          <> show n+          <> " times"
+ test/Test/Method/DynamicSpec.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TypeApplications #-}++module Test.Method.DynamicSpec where++import Control.Exception (evaluate)+import Control.Exception.Base (ErrorCall (ErrorCall))+import Data.Proxy (Proxy (Proxy), asProxyTypeOf)+import Test.Hspec+  ( Expectation,+    Spec,+    anyErrorCall,+    describe,+    it,+    shouldBe,+    shouldReturn,+    shouldThrow,+  )+import Test.Method.Dynamic+  ( Dynamic,+    DynamicShow,+    FromDyn (fromDyn),+    ToDyn (toDyn),+    Typeable,+    castMethod,+    dynArg,+  )+import Test.Method.Matcher+  ( ArgsMatcher (args),+    Matcher,+    anything,+    when,+  )+import Test.Method.Mock (mockup, thenReturn, throwNoStub)++spec :: Spec+spec = do+  describe "fromDyn" $ do+    let fid :: (FromDyn b a, ToDyn b a, Show a, Eq a) => Proxy b -> a -> Expectation+        fid proxy x = fromDyn (toDyn x `asProxyTypeOf` proxy) `shouldBe` x+    it "Int -> Int" $ fid (Proxy @Int) (0 :: Int)+    it "Dynamic -> Int" $ fid (Proxy @Dynamic) (0 :: Int)+    it "DynamicShow ->Int" $ fid (Proxy @DynamicShow) (0 :: Int)+    it "[Dynamic] -> [Int]" $ fid (Proxy @[Dynamic]) [0 :: Int]+    it "Maybe Dynamic -> Maybe ()" $ fid (Proxy @(Maybe Dynamic)) (Nothing :: Maybe ())+    it "Either Dynamic Bool -> Either Int Bool" $ fid (Proxy @(Either Dynamic Bool)) (Left 0 :: Either Int Bool)+    it "(Int, Dynamic) -> (Int, Int)" $ fid (Proxy @(Int, Dynamic)) (0 :: Int, 0 :: Int)+    it "Dynamic^7 -> Char^7" $+      fid+        (Proxy @(Dynamic, Dynamic, Dynamic, Dynamic, Dynamic, Dynamic, Dynamic))+        ('a', 'b', 'c', 'd', 'e', 'f', 'g')+    it "((Int, Dynamic) -> (Dynamic, Int)) -> ((Int, Int) -> (Int, Int))" $ do+      let f :: (Int, Int) -> (Int, Int)+          f = fromDyn (toDyn (id :: (Int, Int) -> (Int, Int)) :: ((Int, Dynamic) -> (Dynamic, Int)))+      f (42, 57) `shouldBe` (42, 57)++    it "throw type error" $+      evaluate (fromDyn (toDyn True :: Dynamic) :: Char)+        `shouldThrow` ( \(ErrorCall msg) ->+                          msg == "cannot cast <<Bool>> to Char"+                      )++  describe "Show DynamicShow" $ do+    it "show (DynamicShow (0 :: Int)) == \"<<0 :: Int>>\"" $ do+      show (toDyn (0 :: Int) :: DynamicShow) `shouldBe` "<<0 :: Int>>"+  describe "castMethod" $ do+    let f :: (Typeable a, Show a) => String -> a -> IO a+        f = castMethod f'+        f' :: String -> DynamicShow -> IO DynamicShow+        f' = mockup $ do+          when (args ((== "int"), dynArg (== (10 :: Int)))) `thenReturn` toDyn (20 :: Int)+          when (args ((== "bool"), dynArg (== True))) `thenReturn` toDyn False+          when (args ((== "invalid"), dynArg (anything :: Matcher Bool))) `thenReturn` toDyn 'A'+          throwNoStub (when anything)+    it "polymorphic" $ do+      f "int" (10 :: Int) `shouldReturn` 20+      f "bool" True `shouldReturn` False+      (f "invalid" True >>= evaluate) `shouldThrow` anyErrorCall+      f "invalid" 'a' `shouldThrow` anyErrorCall
+ test/Test/Method/ProtocolSpec.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}++module Test.Method.ProtocolSpec where++import RIO (ByteString, Text, void)+import Test.Hspec+  ( Spec,+    anyErrorCall,+    before,+    context,+    describe,+    it,+    shouldReturn,+    shouldThrow,+  )+import Test.Method.Protocol+  ( ProtocolM,+    decl,+    dependsOn,+    lookupMock,+    protocol,+    thenReturn,+    verify,+    whenArgs,+  )++data Methods m where+  FindUser :: Methods (UserName -> IO (Maybe User))+  FindPassword :: Methods (UserName -> IO (Maybe HashedPassword))+  CreateUser :: Methods (UserName -> IO User)+  HashPassword :: Methods (PlainPassword -> IO HashedPassword)+  UpsertAuth :: Methods (UserId -> HashedPassword -> IO ())++data Service = Service+  { findUser :: UserName -> IO (Maybe User),+    findPassword :: UserName -> IO (Maybe HashedPassword),+    createUser :: UserName -> IO User,+    hashPassword :: PlainPassword -> IO HashedPassword,+    upsertAuth :: UserId -> HashedPassword -> IO ()+  }++doService :: Service -> UserName -> PlainPassword -> IO (Maybe User)+doService Service {..} usernm passwd = do+  mUser <- findUser usernm+  case mUser of+    Just _ -> pure Nothing+    Nothing -> do+      hpasswd <- hashPassword passwd+      user <- createUser usernm+      upsertAuth (userId user) hpasswd+      pure $ Just user++doServiceHashFirst :: Service -> UserName -> PlainPassword -> IO (Maybe User)+doServiceHashFirst Service {..} usernm passwd = do+  hpasswd <- hashPassword passwd+  mUser <- findUser usernm+  case mUser of+    Just _ -> pure Nothing+    Nothing -> do+      user <- createUser usernm+      upsertAuth (userId user) hpasswd+      pure $ Just user++doServiceWrongArgument :: Service -> UserName -> PlainPassword -> IO (Maybe User)+doServiceWrongArgument Service {..} usernm passwd = do+  mUser <- findUser usernm+  case mUser of+    Just _ -> pure Nothing+    Nothing -> do+      _ <- hashPassword passwd+      user <- createUser usernm+      upsertAuth (userId user) passwd+      pure $ Just user++doServiceWrongExtraCalls :: Service -> UserName -> PlainPassword -> IO (Maybe User)+doServiceWrongExtraCalls Service {..} usernm passwd = do+  mUser <- findUser usernm+  case mUser of+    Just _ -> pure Nothing+    Nothing -> do+      hpasswd <- hashPassword passwd+      hpasswd' <- hashPassword hpasswd+      user <- createUser usernm+      upsertAuth (userId user) hpasswd'+      pure $ Just user++doServiceWrongMissingCalls :: Service -> UserName -> PlainPassword -> IO (Maybe User)+doServiceWrongMissingCalls Service {..} usernm passwd = do+  mUser <- findUser usernm+  case mUser of+    Just _ -> pure Nothing+    Nothing -> do+      _ <- hashPassword passwd+      user <- createUser usernm+      pure $ Just user++doServiceWrongOrder :: Service -> UserName -> PlainPassword -> IO (Maybe User)+doServiceWrongOrder Service {..} usernm passwd = do+  user <- createUser usernm+  mUser <- findUser usernm+  case mUser of+    Just _ -> pure Nothing+    Nothing -> do+      hpasswd <- hashPassword passwd+      upsertAuth (userId user) hpasswd+      pure $ Just user++doServiceWrongUnspecifiedMethod :: Service -> UserName -> PlainPassword -> IO (Maybe User)+doServiceWrongUnspecifiedMethod Service {..} usernm _passwd = do+  mUser <- findUser usernm+  case mUser of+    Just _ -> pure Nothing+    Nothing -> do+      Just hpasswd <- findPassword usernm+      user <- createUser usernm+      upsertAuth (userId user) hpasswd+      pure $ Just user++serviceProtocol :: UserName -> PlainPassword -> HashedPassword -> UserId -> ProtocolM Methods ()+serviceProtocol usernm passwd hpasswd userid = do+  i1 <- decl $ whenArgs FindUser (== usernm) `thenReturn` Nothing+  i2 <- decl $ whenArgs CreateUser (== usernm) `thenReturn` User usernm userid `dependsOn` [i1]+  i3 <- decl $ whenArgs HashPassword (== passwd) `thenReturn` hpasswd+  void $ decl $ whenArgs UpsertAuth ((== userid), (== hpasswd)) `thenReturn` () `dependsOn` [i2, i3]++deriving instance (Show (Methods m))++deriving instance (Eq (Methods m))++deriving instance (Ord (Methods m))++type UserName = Text++type PlainPassword = ByteString++type HashedPassword = ByteString++type UserId = Int++data Env = Env++data User = User {userName :: UserName, userId :: UserId}+  deriving (Eq, Ord, Show)++spec :: Spec+spec = describe "protocol" $ do+  let usernm = "user1"+      passwd = "password1"+      hpasswd = "hashed_password1"+      userid = 0+  let setup = do+        penv <- protocol $ serviceProtocol usernm passwd hpasswd userid+        pure+          ( penv,+            Service+              { findUser = lookupMock FindUser penv,+                findPassword = lookupMock FindPassword penv,+                createUser = lookupMock CreateUser penv,+                hashPassword = lookupMock HashPassword penv,+                upsertAuth = lookupMock UpsertAuth penv+              }+          )+  before setup $ do+    context "accept valid impl" $ do+      it "accept valid impl findUser first" $ \(penv, service) -> do+        doService service usernm passwd `shouldReturn` Just (User usernm userid)+        verify penv+      it "accept valid impl hash first" $ \(penv, service) -> do+        doServiceHashFirst service usernm passwd `shouldReturn` Just (User usernm userid)+        verify penv+    context "reject invalid impl" $ do+      it "invalid argument" $ \(_, service) ->+        doServiceWrongArgument service usernm passwd `shouldThrow` anyErrorCall+      it "extra calls" $ \(_, service) ->+        doServiceWrongExtraCalls service usernm passwd `shouldThrow` anyErrorCall+      it "missing calls" $ \(penv, service) -> do+        doServiceWrongMissingCalls service usernm passwd `shouldReturn` Just (User usernm userid)+        verify penv `shouldThrow` anyErrorCall+      it "wrong order" $ \(_, service) -> do+        doServiceWrongOrder service usernm passwd `shouldThrow` anyErrorCall+      it "unspecified method call" $ \(_, service) -> do+        doServiceWrongUnspecifiedMethod service usernm passwd `shouldThrow` anyErrorCall