packages feed

method (empty) → 0.1.0.0

raw patch · 15 files changed

+1273/−0 lines, 15 filesdep +basedep +hspecdep +methodsetup-changed

Dependencies added: base, hspec, method, rio, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for method++## 0.1.0.0 -- 2021-01-09++* First stable version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Taku Terao++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Taku Terao nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# method+rebindable methods for improving testability++![Travis](https://travis-ci.org/autotaker/method.svg?branch=main)+![Haskell CI](https://github.com/autotaker/method/workflows/Haskell%20CI/badge.svg)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ method.cabal view
@@ -0,0 +1,70 @@+cabal-version:      2.4++-- Initial package description 'method.cabal' generated by 'cabal init'.+-- For further documentation, see http://haskell.org/cabal/users-guide/++name:               method+version:            0.1.0.0+synopsis:           rebindable methods for improving testability+description:+  This package provides Method typeclass, which represents +  monadic functions, and provides easy DSL for mocking/verifying methods.++homepage:           https://github.com/autotaker/method+bug-reports:        https://github.com/autotaker/method/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             Taku Terao+maintainer:         autotaker@gmail.com++-- copyright:+category:           Control+extra-source-files:+  CHANGELOG.md+  README.md++common shared-properties+  build-depends:+    , base          >=4.13.0.0 && <5.0+    , rio           ^>=0.1.19.0+    , transformers  ^>=0.5.6.2++  default-language: Haskell2010+  ghc-options:+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+    -Wmissing-import-lists -Wcompat++common test-depends+  build-depends:      hspec ^>=2.7.4+  build-tool-depends: hspec-discover:hspec-discover ^>=2.7++library+  import:          shared-properties++  -- cabal-fmt:        expand src+  exposed-modules:+    Control.Method+    Control.Method.Internal+    Test.Method+    Test.Method.Matcher+    Test.Method.Mock+    Test.Method.Monitor+    Test.Method.Monitor.Internal++  -- other-modules:+  -- other-extensions:+  hs-source-dirs:  src++test-suite method-test+  import:           shared-properties, test-depends+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Spec.hs++  -- cabal-fmt: expand test -Spec+  other-modules:+    Test.Method.MockSpec+    Test.Method.MonitorSpec++  build-depends:    method
+ src/Control/Method.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Control.Method+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Control.Method+  ( -- * Usage+    -- $usage++    -- ** Dependency Injection+    -- $di++    -- ** Decorating methods+    -- $decorate++    -- * References+    Method (..),+    TupleLike (..),+    decorate,+    decorate_,+    decorateBefore_,+    invoke,+    liftJoin,+  )+where++import Control.Exception (SomeException)+import Control.Method.Internal+  ( Nil (Nil),+    TupleLike (AsTuple, fromTuple, toTuple),+    type (:*) ((:*)),+  )+import Control.Monad.Trans.Accum (AccumT)+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Select (SelectT)+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.CPS as CPS+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict+import Data.Functor.Identity (Identity)+import Data.Kind (Type)+import RIO (MonadReader, MonadUnliftIO, RIO, ST, SimpleGetter, throwIO, tryAny, view)++-- $usage+-- This module provides dependency injection and decoration+-- for monadic functions (called methods).++-- $di+--+-- For example, assume that we are implementing signin function,+-- which checks user's password.+--+-- First, let's create an interface to access database.+--+-- @+-- type UserRepository env = UserRepository {+--   findById :: UserId -> 'RIO' env (Maybe User)+--   create :: User -> 'RIO' env UserId+-- }+-- @+--+-- And add Has-pattern typeclass.+-- It's better to user 'SimpleGetter' instead of 'Lens',+-- because we rarely modify the interface.+--+-- @+-- class HasUserRepository env where+--   userRepositoryL :: 'SimpleGetter' env (UserRepository env)+-- @+--+-- In @signup@ function, call @findById@ method via 'invoke'.+--+-- @+-- signin :: HasUserRepository env => UserId -> Password -> RIO env (Maybe User)+-- signin userId pass = do+--   muser <- invoke (userRepositoryL . to findById) userId+--   pure $ do+--     user <- muser+--     guard (authCheck user pass)+--     pure user+-- @+--+-- In production code, inject @UserRepository@ implementation which+-- accesses database+--+-- @+-- userRepositoryImpl :: UserRepository env+-- userRepositoryImpl = UserRepository {+--   findById = ...,+--   create = ...+-- }+--+-- data ProductionEnv = ProductionEnv+-- instance HasUserRepository ProductionEnv where+--   userRepositoryL = to $ const userRepositoryImpl+-- @+--+-- In test code, inject @UserRepository@ mock implementation.+--+-- @+-- userRepositoryMock :: UserRepository env+-- userRepositoryMock = UserRepository {+--   findById = \userId -> pure $ Just (User userId "password123")+--   createUser = \user -> pure $ Just "example"+-- }+--+-- data TestEnv = TestEnv+-- instance HasUserRepository TestEnv where+--   userRepositoryL = to $ const userRepositoryMock+--+-- test :: Spec+-- test = describe "signin" $ do+--   it "return user for correct password" $ do+--     runRIO TestEnv (signin "example" "password123")+--       ``shouldReturn`` Just (User "example" "password123")+--   it "return Nothing for incorrect password" $ do+--     runRIO TestEnv (signin "example" "wrong")+--       ``shouldReturn`` Nothing+-- @++-- $decorate+-- By using 'decorate', 'decorate_', or 'decorateBefore_' function,+-- we can insert hooks before/after calling methods+--+-- Example to insert logging feature+--+-- >>> let f x y = pure (replicate x y) :: IO [String]+-- >>> let before args = putStrLn $ "args: " ++ show (toTuple args)+-- >>> let after res = putStrLn $ "ret: " ++ show res+-- >>> let decorateF = decorate_ before after f+-- >>> decorateF 2 "foo"+-- args: (2,"foo")+-- ret: Right ["foo","foo"]+-- ["foo","foo"]+--+-- Another example to decorate method with transaction management+--+-- @+-- transactional :: (Method method, MonadUnliftIO (Base method)) => (Connection -> method) -> method+-- transactional = decorate before after+--   where+--     before = do+--       conn <- liftIO $ getConnection cInfo+--       begin conn+--       pure conn+--     after conn (Left _) = liftIO $ rollback conn+--     after conn (Right _) = liftIO $ commit conn+-- @++-- | "Method" a is a function of the form+--  @a1 -> a2 -> ... -> an -> m b@+--  where @m@ is "Monad"+--+--  Typical monads in transformers package are supported.+--  If you want to support other monads (for example @M@),+--  add the following boilerplate.+--+-- @+-- instance Method (M a) where+--   Base (M a) = M+--   Ret  (M a) = a+-- @+--+--   __Caution__ Function monad @(-> r)@ cannot be an instance of 'Method'+class Monad (Base method) => Method method where+  -- | Underling monad+  --+  --   @Base (a1 -> ... -> an -> m b) = m@+  type Base method :: Type -> Type++  -- | Arguments tuple of the method+  --+  --   @Args (a1 -> ... -> an -> m b) = a1 :* ... :* an@+  type Args method :: Type++  type Args method = Nil++  -- | Return type of the method+  --+  --   @Ret  (a1 -> ... -> an -> m b) = b@+  type Ret method :: Type++  -- | Convert method to unary function+  uncurryMethod :: method -> Args method -> Base method (Ret method)+  {-# INLINE uncurryMethod #-}+  default uncurryMethod ::+    (method ~ Base method a, Args method ~ Nil, Ret method ~ a) =>+    method ->+    Args method ->+    Base method (Ret method)+  uncurryMethod method Nil = method++  -- | Reconstruct method from unary function+  curryMethod :: (Args method -> Base method (Ret method)) -> method+  {-# INLINE curryMethod #-}+  default curryMethod ::+    (method ~ Base method a, Args method ~ Nil, Ret method ~ a) =>+    (Args method -> Base method (Ret method)) ->+    method+  curryMethod method' = method' Nil++-- | Generalization of 'join' function+{-# INLINE liftJoin #-}+liftJoin :: Method method => Base method method -> method+liftJoin mMethod = curryMethod $ \args -> do+  method <- mMethod+  uncurryMethod method args++instance Method (IO a) where+  type Base (IO a) = IO+  type Ret (IO a) = a++instance Method (RIO env a) where+  type Base (RIO env a) = RIO env+  type Ret (RIO env a) = a++instance Method (Identity a) where+  type Base (Identity a) = Identity+  type Ret (Identity a) = a++instance Method (Maybe a) where+  type Base (Maybe a) = Maybe+  type Ret (Maybe a) = a++instance Method [a] where+  type Base [a] = []+  type Ret [a] = a++instance Method (Either e a) where+  type Base (Either e a) = Either e+  type Ret (Either e a) = a++instance Method (ST s a) where+  type Base (ST s a) = ST s+  type Ret (ST s a) = a++instance (Monoid w, Monad m) => Method (AccumT w m a) where+  type Base (AccumT w m a) = AccumT w m+  type Ret (AccumT w m a) = a++instance (Monad m) => Method (ContT r m a) where+  type Base (ContT r m a) = ContT r m+  type Ret (ContT r m a) = a++instance (Monad m) => Method (ExceptT e m a) where+  type Base (ExceptT e m a) = ExceptT e m+  type Ret (ExceptT e m a) = a++instance (Monad m) => Method (MaybeT m a) where+  type Base (MaybeT m a) = MaybeT m+  type Ret (MaybeT m a) = a++instance (Monad m) => Method (CPS.RWST r w s m a) where+  type Base (CPS.RWST r w s m a) = CPS.RWST r w s m+  type Ret (CPS.RWST r w s m a) = a++instance (Monad m, Monoid w) => Method (Lazy.RWST r w s m a) where+  type Base (Lazy.RWST r w s m a) = Lazy.RWST r w s m+  type Ret (Lazy.RWST r w s m a) = a++instance (Monad m, Monoid w) => Method (Strict.RWST r w s m a) where+  type Base (Strict.RWST r w s m a) = Strict.RWST r w s m+  type Ret (Strict.RWST r w s m a) = a++instance Monad m => Method (ReaderT r m a) where+  type Base (ReaderT r m a) = ReaderT r m+  type Ret (ReaderT r m a) = a++instance Monad m => Method (SelectT r m a) where+  type Base (SelectT r m a) = SelectT r m+  type Ret (SelectT r m a) = a++instance Monad m => Method (Lazy.StateT s m a) where+  type Base (Lazy.StateT s m a) = Lazy.StateT s m+  type Ret (Lazy.StateT s m a) = a++instance Monad m => Method (Strict.StateT s m a) where+  type Base (Strict.StateT s m a) = Strict.StateT s m+  type Ret (Strict.StateT s m a) = a++instance (Monad m) => Method (CPS.WriterT w m a) where+  type Base (CPS.WriterT w m a) = CPS.WriterT w m+  type Ret (CPS.WriterT w m a) = a++instance (Monad m, Monoid w) => Method (Lazy.WriterT w m a) where+  type Base (Lazy.WriterT w m a) = Lazy.WriterT w m+  type Ret (Lazy.WriterT w m a) = a++instance (Monad m, Monoid w) => Method (Strict.WriterT w m a) where+  type Base (Strict.WriterT w m a) = Strict.WriterT w m+  type Ret (Strict.WriterT w m a) = a++instance Method b => Method (a -> b) where+  type Base (a -> b) = Base b+  type Args (a -> b) = a :* Args b+  type Ret (a -> b) = Ret b+  {-# INLINE uncurryMethod #-}+  uncurryMethod method (a :* args) = uncurryMethod (method a) args+  {-# INLINE curryMethod #-}+  curryMethod method' a = curryMethod (\args -> method' (a :* args))++-- | Insert hooks before/after calling the argument method+{-# INLINE decorate #-}+decorate ::+  (Method method, MonadUnliftIO (Base method)) =>+  (Args method -> Base method a) ->+  (a -> Either SomeException (Ret method) -> Base method ()) ->+  (a -> method) ->+  method+decorate before after method = curryMethod $ \args -> do+  a <- before args+  res <- tryAny (uncurryMethod (method a) args)+  case res of+    Left err -> after a res >> throwIO err+    Right v -> after a res >> pure v++-- | Insert hooks before/after calling the argument method+{-# INLINE decorate_ #-}+decorate_ ::+  (Method method, MonadUnliftIO (Base method)) =>+  (Args method -> Base method ()) ->+  (Either SomeException (Ret method) -> Base method ()) ->+  method ->+  method+decorate_ before after method = curryMethod $ \args -> do+  before args+  res <- tryAny (uncurryMethod method args)+  case res of+    Left err -> after res >> throwIO err+    Right v -> after res >> pure v++-- | Insert hooks only before calling the argument method.+--   Because it's free from 'MonadUnliftIO' constraint,+--   any methods are supported.+{-# INLINE decorateBefore_ #-}+decorateBefore_ ::+  (Method method) =>+  (Args method -> Base method ()) ->+  method ->+  method+decorateBefore_ before method = curryMethod $ \args -> do+  before args+  uncurryMethod method args++-- | invoke method taken from reader environment+{-# INLINE invoke #-}+invoke :: (MonadReader env (Base method), Method method) => SimpleGetter env method -> method+invoke getter = liftJoin (view getter)
+ src/Control/Method/Internal.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Control.Method.Internal+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Control.Method.Internal+  ( TupleLike (..),+    Nil (Nil),+    (:*) ((:*)),+  )+where++class TupleLike a where+  type AsTuple a+  fromTuple :: AsTuple a -> a+  toTuple :: a -> AsTuple a++instance TupleLike Nil where+  type AsTuple Nil = ()+  {-# INLINE fromTuple #-}+  fromTuple _ = Nil+  {-# INLINE toTuple #-}+  toTuple _ = ()++instance TupleLike (a :* Nil) where+  type AsTuple (a :* Nil) = a+  {-# INLINE fromTuple #-}+  fromTuple a = a :* Nil+  {-# INLINE toTuple #-}+  toTuple (a :* Nil) = a++instance TupleLike (a :* b :* Nil) where+  type AsTuple (a :* b :* Nil) = (a, b)+  {-# INLINE fromTuple #-}+  fromTuple (a, b) = a :* b :* Nil+  {-# INLINE toTuple #-}+  toTuple (a :* b :* Nil) = (a, b)++instance TupleLike (a :* b :* c :* Nil) where+  type AsTuple (a :* b :* c :* Nil) = (a, b, c)+  {-# INLINE fromTuple #-}+  fromTuple (a, b, c) = a :* b :* c :* Nil+  {-# INLINE toTuple #-}+  toTuple (a :* b :* c :* Nil) = (a, b, c)++instance TupleLike (a :* b :* c :* d :* Nil) where+  type AsTuple (a :* b :* c :* d :* Nil) = (a, b, c, d)+  {-# INLINE fromTuple #-}+  fromTuple (a, b, c, d) = a :* b :* c :* d :* Nil+  {-# INLINE toTuple #-}+  toTuple (a :* b :* c :* d :* Nil) = (a, b, c, d)++instance TupleLike (a :* b :* c :* d :* e :* Nil) where+  type AsTuple (a :* b :* c :* d :* e :* Nil) = (a, b, c, d, e)+  {-# INLINE fromTuple #-}+  fromTuple (a, b, c, d, e) = a :* b :* c :* d :* e :* Nil+  {-# INLINE toTuple #-}+  toTuple (a :* b :* c :* d :* e :* Nil) = (a, b, c, d, e)++instance TupleLike (a :* b :* c :* d :* e :* f :* Nil) where+  type AsTuple (a :* b :* c :* d :* e :* f :* Nil) = (a, b, c, d, e, f)+  {-# INLINE fromTuple #-}+  fromTuple (a, b, c, d, e, f) = a :* b :* c :* d :* e :* f :* Nil+  {-# INLINE toTuple #-}+  toTuple (a :* b :* c :* d :* e :* f :* Nil) = (a, b, c, d, e, f)++instance TupleLike (a :* b :* c :* d :* e :* f :* g :* Nil) where+  type AsTuple (a :* b :* c :* d :* e :* f :* g :* Nil) = (a, b, c, d, e, f, g)+  {-# INLINE fromTuple #-}+  fromTuple (a, b, c, d, e, f, g) = a :* b :* c :* d :* e :* f :* g :* Nil+  {-# INLINE toTuple #-}+  toTuple (a :* b :* c :* d :* e :* f :* g :* Nil) = (a, b, c, d, e, f, g)++-- | Nullary tuple+data Nil = Nil+  deriving (Eq, Ord, Show)++-- | Tuple constructor+data a :* b = a :* !b+  deriving (Eq, Ord, Show)++infixr 1 :*
+ src/Test/Method.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module : Test.Method+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Test.Method+  ( -- $usage++    -- * Mock++    -- ** Usage+    -- $mock++    -- ** References+    mockup,+    thenReturn,+    thenAction,+    thenMethod,+    throwNoStubShow,+    throwNoStub,+    NoStubException (NoStubException),++    -- * Monitor++    -- ** Usage+    -- $monitor++    -- ** References+    Monitor,+    Event,+    watchBy,+    watch,+    withMonitor,+    withMonitor_,++    -- *** Matcher for events+    call,+    times,++    -- *** Procedual api for monitor+    newMonitor,+    listenEventLog,++    -- * Matcher++    -- ** References++    -- *** Basics+    Matcher,+    anything,+    when,++    -- *** Matcher for method arguments+    TupleLike (AsTuple, fromTuple, toTuple),+    ArgsMatcher (args),+    args',+  )+where++import Test.Method.Matcher+  ( ArgsMatcher (..),+    Matcher,+    TupleLike (..),+    anything,+    args',+    when,+  )+import Test.Method.Mock+  ( NoStubException (NoStubException),+    mockup,+    thenAction,+    thenMethod,+    thenReturn,+    throwNoStub,+    throwNoStubShow,+  )+import Test.Method.Monitor+  ( Event,+    Monitor,+    call,+    listenEventLog,+    newMonitor,+    times,+    watch,+    watchBy,+    withMonitor,+    withMonitor_,+  )++-- $usage+-- This module provides DSLs for mocking+-- methods and for validating method calls++-- $mock+--+-- @+-- fizzbuzz :: Int -> IO String+-- fizzbuzz = 'mockup' $ do+--   'when' ('args' (\x -> mod x 15 == 0)) `'thenReturn'` "fizzbuzz"+--   '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'+-- @+--+-- >>> fizzbuzz 0+-- "fizzbuzz"+-- >>> fizzbuzz 1+-- "1"+-- >>> fizzbuzz 3+-- "fizz"+-- >>> fizzbuzz 5+-- "buzz"+-- >>> fizzbuzz (-1)+-- *** Exception: NoStubException "-1"++-- @++-- $monitor+--+-- @+-- type ExampleMethod = Int -> String -> IO String+-- example :: ExampleMethod+-- example n s | n < 0 = throwString "negative n"+--             | otherwise = pure $ concat $ replicate n s+--+-- doit :: ExampleMethod -> IO ()+-- doit example = (do+--   example 2 "foo" >>= putStrLn+--   example 3 "foo" >>= putStrLn+--   example (-1) "bar" >>= putStrLn+--   example 3 "bar" >>= putStrLn) `catchAny` (const $ pure ())+-- @+--+-- @+-- spec :: Spec+-- spec = describe "doit" $ do+--   before ('withMonitor_' $ \\monitor -> doit ('watch' monitor example))+--+--   it "calls example _ \"foo\" twice" $ \\logs -> do+--     logs `'shouldSatisfy'` ((==2) `'times'` 'call' ('args' ('anything', (=="foo"))))+--+--   it "calls example (-1) \"bar\" once" $ \\logs -> do+--     logs `'shouldSatisfy'` ((==1) `'times'` 'call' ('args' ((==(-1)), (=="bar"))))+--+--   it "does not call example 3 \"bar\" " $ \\logs -> do+--     logs `'shouldSatisfy'` ((==0) `'times'` 'call' ('args' ((==3), (=="bar"))))+-- @
+ src/Test/Method/Matcher.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Test.Method.Matcher+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Test.Method.Matcher+  ( anything,+    when,+    Matcher,+    TupleLike (..),+    ArgsMatcher (..),+    args',+  )+where++import Control.Method.Internal (Nil (Nil), TupleLike (AsTuple, fromTuple, toTuple), (:*) ((:*)))++type Matcher a = a -> Bool++-- | Matcher that matches anything+anything :: Matcher a+anything = const True++-- | synonym of 'id' function.+-- Use this function for improving readability+when :: Matcher a -> Matcher a+when = id++-- | Matcher for 'Control.Method.Args'+--+-- >>> args ((==2), (>3)) (2 :* 4 :* Nil)+-- True+-- >>> args even (1 :* Nil)+-- False+-- >>> args () Nil+-- True+class TupleLike a => ArgsMatcher a where+  type EachMatcher a++  -- | Convert a tuple of matchers to a matcher of tuples+  args :: EachMatcher a -> Matcher a++-- | Convert a tuple matcher to a tuple-like matcher.+--+-- >>> args' (\(a, b) -> a * b == 10) (2 :* 5 :* Nil)+-- True+-- >>> args' (\(a, b) -> a * b == 10) (2 :* 4 :* Nil)+-- False+{-# INLINE args' #-}+args' :: TupleLike a => Matcher (AsTuple a) -> Matcher a+args' m a = m (toTuple a)++instance ArgsMatcher Nil where+  type EachMatcher Nil = ()+  {-# INLINE args #-}+  args _ = anything++instance ArgsMatcher (a :* Nil) where+  type EachMatcher (a :* Nil) = Matcher a+  {-# INLINE args #-}+  args matcher (a :* Nil) = matcher a++instance ArgsMatcher (a :* b :* Nil) where+  type EachMatcher (a :* b :* Nil) = (Matcher a, Matcher b)+  {-# INLINE args #-}+  args (ma, mb) (a :* b :* Nil) = ma a && mb b++instance ArgsMatcher (a :* b :* c :* Nil) where+  type EachMatcher (a :* b :* c :* Nil) = (Matcher a, Matcher b, Matcher c)+  {-# INLINE args #-}+  args (ma, mb, mc) (a :* b :* c :* Nil) = ma a && mb b && mc c++instance ArgsMatcher (a :* b :* c :* d :* Nil) where+  type EachMatcher (a :* b :* c :* d :* Nil) = (Matcher a, Matcher b, Matcher c, Matcher d)+  {-# INLINE args #-}+  args (ma, mb, mc, md) (a :* b :* c :* d :* Nil) = ma a && mb b && mc c && md d++instance ArgsMatcher (a :* b :* c :* d :* e :* Nil) where+  type EachMatcher (a :* b :* c :* d :* e :* Nil) = (Matcher a, Matcher b, Matcher c, Matcher d, Matcher e)+  {-# INLINE args #-}+  args (ma, mb, mc, md, me) (a :* b :* c :* d :* e :* Nil) = ma a && mb b && mc c && md d && me e++instance ArgsMatcher (a :* b :* c :* d :* e :* f :* Nil) where+  type EachMatcher (a :* b :* c :* d :* e :* f :* Nil) = (Matcher a, Matcher b, Matcher c, Matcher d, Matcher e, Matcher f)+  {-# INLINE args #-}+  args (ma, mb, mc, md, me, mf) (a :* b :* c :* d :* e :* f :* Nil) = ma a && mb b && mc c && md d && me e && mf f++instance ArgsMatcher (a :* b :* c :* d :* e :* f :* g :* Nil) where+  type EachMatcher (a :* b :* c :* d :* e :* f :* g :* Nil) = (Matcher a, Matcher b, Matcher c, Matcher d, Matcher e, Matcher f, Matcher g)+  {-# INLINE args #-}+  args (ma, mb, mc, md, me, mf, mg) (a :* b :* c :* d :* e :* f :* g :* Nil) = ma a && mb b && mc c && md d && me e && mf f && mg g
+ src/Test/Method/Mock.hs view
@@ -0,0 +1,123 @@+{-# 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 (Show, Typeable)++instance Exception NoStubException++instance Semigroup (MockSpec method) where+  (<>) = Combine++instance Monoid (MockSpec method) where+  mempty = 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 spec = buildMock (execWriter spec)++buildMock :: (Method method, MonadThrow (Base 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++-- | @'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 =+  tell $+    MockSpec matcher $+      curryMethod $+        throwM . NoStubException . show . 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 fshow matcher =+  tell $+    MockSpec matcher $+      curryMethod $+        throwM . NoStubException . fshow++fromRules :: (Method method, MonadThrow (Base method)) => [(Matcher (Args method), method)] -> method+fromRules rules = curryMethod $ \args ->+  let ret = find (\(matcher, _) -> matcher args) rules+   in case ret of+        Just (_, method) -> uncurryMethod method args+        Nothing -> throwM $ NoStubException "no mock"++toRules :: MockSpec method -> [(Matcher (Args method), method)]+toRules = reverse . go []+  where+    go acc Empty = acc+    go acc (Combine a b) = go (go acc a) b+    go acc (MockSpec matcher ret) = (matcher, ret) : acc
+ src/Test/Method/Monitor.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Test.Method.Monitor+-- Description:+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+--+-- Validating method calls by monitoring+module Test.Method.Monitor+  ( Event,+    Monitor,+    newMonitor,+    watch,+    watchBy,+    listenEventLog,+    withMonitor,+    withMonitor_,+    times,+    call,+  )+where++import Control.Method (Method (Args, Base, Ret), decorate)+import Data.Coerce (coerce)+import RIO+  ( MonadIO (liftIO),+    MonadUnliftIO,+    readSomeRef,+  )+import Test.Method.Matcher (Matcher)+import Test.Method.Monitor.Internal+  ( EqUptoShow (EqUptoShow),+    Event (Enter, Leave),+    Monitor (monitorTrace),+    logEvent,+    newMonitor,+    tick,+  )++-- | @watchBy fArgs fRet monitor method@ decorates @method@+-- so that @monitor@ logs the method calls.+-- This function is suited for monitoring multiple methods.+--+-- @fArgs@ and @fRet@ is converter for arguments/return values of given method.+--+-- @+-- foo :: Int -> IO String+-- foo = ...+-- bar :: Int -> String -> IO ()+-- bar = ...+--+-- data MonitorArgs = FooArgs Int | BarArgs (Int,String) deriving(Eq,Show)+-- data MonitorRet = FooRet String | BarRet () deriving(Eq, Show)+--+-- foo' :: Monitor MonitorArgs MonitorRet -> Int -> IO String+-- foo' monitor = watch monitor (FooArgs . toTuple) FooRet foo+-- bar' :: Monitor MonitorArgs MonitorRet -> Int -> String -> IO ()+-- bar' monitor = watch monitor (BarArgs . toTuple) BarRet bar+-- @+{-# INLINEABLE watchBy #-}+watchBy ::+  (Method method, MonadUnliftIO (Base method)) =>+  (Args method -> args) ->+  (Ret method -> ret) ->+  Monitor args ret ->+  method ->+  method+watchBy fargs fret m method = method'+  where+    method' = decorate before after (const method)+    before args = do+      t <- tick m+      logEvent m (Enter t (fargs args))+      pure t+    after t result = do+      t' <- tick m+      logEvent m (Leave t' t $ coerce $ fmap fret result)++-- | Simplified version of 'watchBy'. It is suitable to monitor single method.+{-# INLINE watch #-}+watch ::+  (Method method, MonadUnliftIO (Base method)) =>+  Monitor (Args method) (Ret method) ->+  method ->+  method+watch = watchBy id id++-- | Get current event logs from monitor+{-# INLINE listenEventLog #-}+listenEventLog :: MonadIO m => Monitor args ret -> m [Event args ret]+listenEventLog m = reverse <$> readSomeRef (monitorTrace m)++-- | @'times' countMatcher eventMatcher@ counts events that matches @eventMatcher@,+--   and then the count matches @countMatcher@+times :: Matcher Int -> Matcher (Event args ret) -> Matcher [Event args ret]+times countMatcher eventMatcher =+  countMatcher . length . filter eventMatcher++-- | @'call' matcher@ matches method call whose arguments matches @matcher@+call :: Matcher args -> Matcher (Event args ret)+call argsM (Enter _ args) = argsM args+call _ Leave {} = False++-- | @withMonitor f@ calls @f@ with 'Monitor',+-- and then returns monitored event logs during the function call+-- in addition to the return value of the function call+{-# INLINE withMonitor #-}+withMonitor :: MonadIO m => (Monitor args ret -> m a) -> m (a, [Event args ret])+withMonitor f = do+  monitor <- liftIO newMonitor+  r <- f monitor+  logs <- listenEventLog monitor+  pure (r, logs)++-- | @withMonitor_ f@ calls @f@ with 'Monitor', and returns event logs during the call.+{-# INLINE withMonitor_ #-}+withMonitor_ :: MonadIO m => (Monitor args ret -> m ()) -> m [Event args ret]+withMonitor_ f = do+  monitor <- liftIO newMonitor+  f monitor+  listenEventLog monitor
+ src/Test/Method/Monitor/Internal.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module : Test.Method.Monitor.Internal+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Test.Method.Monitor.Internal where++import Data.Typeable (typeOf)+import RIO+  ( IORef,+    MonadIO,+    SomeException,+    SomeRef,+    Typeable,+    modifySomeRef,+    newIORef,+    newSomeRef,+    readIORef,+    writeIORef,+  )++-- | 'Tick' represents call identifier+newtype Tick = Tick {unTick :: Int}+  deriving (Eq, Ord, Show, Enum)++-- | @'Event' args ret@ is a function call event+data Event args ret+  = Enter {eventTick :: !Tick, eventArgs :: !args}+  | Leave+      { eventTick :: !Tick,+        eventEnterTick :: !Tick,+        eventRet :: !(Either (EqUptoShow SomeException) ret)+      }+  deriving (Eq, Ord, Show)++type Clock = IORef Tick++-- | newtype to implement show instance which shows its type.+newtype ShowType a = ShowType a+  deriving (Eq, Ord)++instance Typeable a => Show (ShowType a) where+  show (ShowType a) = show (typeOf a)++-- | newtype to compare values via 'show'+newtype EqUptoShow a = EqUptoShow a++instance Show a => Show (EqUptoShow a) where+  show (EqUptoShow a) = show a++instance Show a => Eq (EqUptoShow a) where+  a == b = show a == show b++instance Show a => Ord (EqUptoShow a) where+  compare a b = compare (show a) (show b)++-- | @Monitor arg ret@ is an event monitor of methods,+-- which logs method calls.+data Monitor args ret = Monitor+  { monitorTrace :: !(SomeRef [Event args ret]),+    monitorClock :: !Clock+  }++-- | Generate new instance of 'Monitor'+newMonitor :: IO (Monitor args ret)+newMonitor = Monitor <$> newSomeRef [] <*> newIORef (Tick 0)++-- | Increment the clock and return the current tick.+{-# INLINE tick #-}+tick :: MonadIO m => Monitor args ret -> m Tick+tick Monitor {monitorClock = clock} = do+  t <- readIORef clock+  writeIORef clock $! succ t+  pure t++-- | logs an event+{-# INLINE logEvent #-}+logEvent :: MonadIO m => Monitor args ret -> Event args ret -> m ()+logEvent Monitor {monitorTrace = tr} event = modifySomeRef tr (event :)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-import-lists #-}
+ test/Test/Method/MockSpec.hs view
@@ -0,0 +1,24 @@+module Test.Method.MockSpec where++import Test.Hspec (Selector, Spec, describe, it, shouldReturn, shouldThrow)+import Test.Method.Matcher (ArgsMatcher (args), args', when)+import Test.Method.Mock (NoStubException, mockup, thenReturn)++spec :: Spec+spec = do+  describe "mockup" $ do+    let method :: Int -> Int -> IO Int+        method = mockup $ do+          when (args ((==) 1, (>=) 2)) `thenReturn` 3+          when (args' (\(a, b) -> a * b == 6)) `thenReturn` 42+    it "mock method 1 2 returns 3" $ do+      method 1 2 `shouldReturn` 3++    it "mock method 2 2 throws Exception" $ do+      method 0 2 `shouldThrow` anyNoStubException++    it "mock method 2 3 returns 42" $ do+      method 2 3 `shouldReturn` 42++anyNoStubException :: Selector NoStubException+anyNoStubException _ = True
+ test/Test/Method/MonitorSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}++module Test.Method.MonitorSpec where++import Control.Method (TupleLike (fromTuple))+import RIO (newIORef, readIORef, throwString, void, writeIORef)+import Test.Hspec+  ( Spec,+    anyException,+    before,+    describe,+    it,+    shouldBe,+    shouldReturn,+    shouldSatisfy,+    shouldThrow,+  )+import Test.Method.Matcher (ArgsMatcher (args), anything)+import Test.Method.Monitor+  ( call,+    listenEventLog,+    newMonitor,+    times,+    watch,+    watchBy,+    withMonitor_,+  )+import Test.Method.Monitor.Internal+  ( Event (Enter, Leave),+    Monitor (monitorClock),+    Tick (Tick),+    tick,+  )++spec :: Spec+spec = do+  describe "newClock" $ do+    describe "newMonitor" $ do+      it "has empty trace" $ do+        m <- newMonitor+        length <$> listenEventLog m `shouldReturn` 0+      it "has clock initialized with zero" $ do+        m <- newMonitor+        readIORef (monitorClock m) `shouldReturn` Tick 0++    describe "tick" $ do+      it "increments monitor's clock" $ do+        m <- newMonitor+        t <- tick m+        t `shouldBe` Tick 0+        t1 <- tick m+        t1 `shouldBe` Tick 1++    describe "watch'" $ do+      let setup = do+            m <- newMonitor+            let method = watch m method'+            pure (m, method)+          method' :: Int -> IO String+          method' n+            | n == 42 = throwString "error"+            | otherwise = pure $ show n++      before setup $ do+        it "logs single method call" $ \(m, method) -> do+          void $ method 1+          listenEventLog m+            `shouldReturn` [ Enter (Tick 0) (fromTuple 1),+                             Leave (Tick 1) (Tick 0) (Right "1")+                           ]+        it "logs exception thrown" $ \(m, method) -> do+          method 42 `shouldThrow` anyException+          logs <- listenEventLog m+          shouldSatisfy (logs !! 1) $ \case+            Leave (Tick 1) (Tick 0) (Left _) -> True+            _ -> False+    describe "watch" $ do+      let setup = do+            m <- newMonitor+            r <- newIORef (0 :: Int)+            let get :: IO Int+                get = watchBy Left Left m (readIORef r)+                put :: Int -> IO ()+                put = watchBy Right Right m (writeIORef r)+            pure (m, get, put)+      before setup $ do+        it "logs two method call" $ \(m, get, put) -> do+          put 10+          _ <- get+          _ <- get+          listenEventLog m+            `shouldReturn` [ Enter (Tick 0) (Right (fromTuple 10)),+                             Leave (Tick 1) (Tick 0) (Right (Right ())),+                             Enter (Tick 2) (Left (fromTuple ())),+                             Leave (Tick 3) (Tick 2) (Right (Left 10)),+                             Enter (Tick 4) (Left (fromTuple ())),+                             Leave (Tick 5) (Tick 4) (Right (Left 10))+                           ]+    describe "times" $ do+      let setup = withMonitor_ $ \m -> do+            let method :: String -> IO ()+                method = watch m (const $ pure ())+            method "hoge"+            method "piyo"++      before setup $ do+        it "should call method twice" $ \logs -> do+          logs `shouldSatisfy` ((== 2) `times` call anything)++        it "should not call method with \"fuga\"" $ \logs -> do+          logs `shouldSatisfy` ((== 0) `times` call (args (== "fuga")))++        it "should call method with \"hoge\" at least once" $ \logs -> do+          logs `shouldSatisfy` ((>= 1) `times` call (args (== "hoge")))