packages feed

method 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+71/−64 lines, 5 files

Files

method.cabal view
@@ -4,7 +4,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/  name:               method-version:            0.1.0.0+version:            0.2.0.0 synopsis:           rebindable methods for improving testability description:   This package provides Method typeclass, which represents
src/Control/Method.hs view
@@ -68,18 +68,17 @@ -- -- @ -- type UserRepository env = UserRepository {---   findById :: UserId -> 'RIO' env (Maybe User)---   create :: User -> 'RIO' env UserId+--   _findById :: UserId -> 'RIO' env (Maybe User)+--   _create :: User -> 'RIO' env UserId -- }+-- makeLenses UserRepository'' -- @ -- -- 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)+--   userRepositoryL :: Lens\' env (UserRepository env) -- @ -- -- In @signup@ function, call @findById@ method via 'invoke'.@@ -87,7 +86,7 @@ -- @ -- signin :: HasUserRepository env => UserId -> Password -> RIO env (Maybe User) -- signin userId pass = do---   muser <- invoke (userRepositoryL . to findById) userId+--   muser <- invoke (userRepositoryL . findById) userId --   pure $ do --     user <- muser --     guard (authCheck user pass)@@ -100,13 +99,13 @@ -- @ -- userRepositoryImpl :: UserRepository env -- userRepositoryImpl = UserRepository {---   findById = ...,---   create = ...+--   _findById = ...,+--   _create = ... -- } -- -- data ProductionEnv = ProductionEnv -- instance HasUserRepository ProductionEnv where---   userRepositoryL = to $ const userRepositoryImpl+--   userRepositoryL = lens (const userRepositoryImpl) const -- @ -- -- In test code, inject @UserRepository@ mock implementation.@@ -114,21 +113,25 @@ -- @ -- userRepositoryMock :: UserRepository env -- userRepositoryMock = UserRepository {---   findById = \userId -> pure $ Just (User userId "password123")---   createUser = \user -> pure $ Just "example"+--   _findById = \userId -> pure $ Just (User userId "password123")+--   _createUser = \user -> pure $ Just "example" -- } ----- data TestEnv = TestEnv+-- data TestEnv = TestEnv { _userRepository :: UserRepository Env }+-- makeLenses TestEnv''+-- -- instance HasUserRepository TestEnv where---   userRepositoryL = to $ const userRepositoryMock+--   userRepositoryL = userRepository --+-- env = TestEnv userRepositoryMock+-- -- test :: Spec -- test = describe "signin" $ do --   it "return user for correct password" $ do---     runRIO TestEnv (signin "example" "password123")+--     runRIO env (signin "example" "password123") --       ``shouldReturn`` Just (User "example" "password123") --   it "return Nothing for incorrect password" $ do---     runRIO TestEnv (signin "example" "wrong")+--     runRIO env (signin "example" "wrong") --       ``shouldReturn`` Nothing -- @
src/Test/Method.hs view
@@ -20,7 +20,6 @@     thenMethod,     throwNoStubShow,     throwNoStub,-    NoStubException (NoStubException),      -- * Monitor @@ -68,8 +67,7 @@     when,   ) import Test.Method.Mock-  ( NoStubException (NoStubException),-    mockup,+  ( mockup,     thenAction,     thenMethod,     thenReturn,@@ -98,10 +96,10 @@ -- @ -- 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)+--   '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' -- @ --@@ -114,37 +112,56 @@ -- >>> fizzbuzz 5 -- "buzz" -- >>> fizzbuzz (-1)--- *** Exception: NoStubException "-1"+-- *** Exception: no stub found for argument: -1+-- CallStack (from HasCallStack):+--  error, called at src/Test/Method/Mock.hs:98:9 in method-0.2.0.0-inplace:Test.Method.Mock"  -- @  -- $monitor --+-- Production code+-- -- @--- type ExampleMethod = Int -> String -> IO String--- example :: ExampleMethod--- example n s | n < 0 = throwString "negative n"---             | otherwise = pure $ concat $ replicate n s+-- type ExampleMethod env = Int -> String -> RIO env () ----- 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 ())+-- class HasExampleMethod env where+--   exampleL :: Lens\' env (ExampleMethod env)+--+-- doit :: HasExampleMethod env => RIO env ()+-- doit = (do+--   invoke exampleL 2 "foo"+--   invoke exampleL 3 "foo"+--   invoke exampleL (-1) "bar"+--   invoke exampleL 3 "bar") `catchAny` (const $ pure ()) -- @ --+-- Test code+-- -- @+-- data Env = Env { _example :: ExampleMethod env }+-- makeLenses Env''+--+-- instance HasExampleMethod Env where+--   exampleL = example+--+-- exampleMock :: ExampleMethod+-- exampleMock = 'mockup' $ do+--   'when' ('args' ((<0), 'anything')) `'thenAction'` throwString "negative n"+--   'when' 'anything' `'thenReturn'` ()+--+-- env = Env exampleMock+-- -- spec :: Spec -- spec = describe "doit" $ do---   before ('withMonitor_' $ \\monitor -> doit ('watch' monitor example))+--   before $ 'withMonitor_' $ \\monitor -> runRIO env $ local (exampleL %~ 'watch' monitor) doit -----   it "calls example _ \"foo\" twice" $ \\logs -> do+--   it "calls example _ \\\"foo\\\" twice" $ \\logs -> do --     logs `'shouldSatisfy'` ((==2) `'times'` 'call' ('args' ('anything', (=="foo")))) -----   it "calls example (-1) \"bar\" once" $ \\logs -> do+--   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+--   it "does not call example 3 \\\"bar\\\" " $ \\logs -> do --     logs `'shouldSatisfy'` ((==0) `'times'` 'call' ('args' ((==3), (=="bar")))) -- @
src/Test/Method/Mock.hs view
@@ -19,7 +19,6 @@     thenMethod,     throwNoStubShow,     throwNoStub,-    NoStubException (NoStubException),   ) where @@ -27,8 +26,6 @@   ( 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)@@ -40,11 +37,6 @@   | 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 @@ -54,10 +46,10 @@ -- | 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 :: (Method method) => Mock method -> method mockup spec = buildMock (execWriter spec) -buildMock :: (Method method, MonadThrow (Base method)) => MockSpec method -> method+buildMock :: Method method => MockSpec method -> method buildMock spec = fromRules $ toRules spec  -- | @matcher `'thenReturn'` value@ means the method return @value@@@ -81,13 +73,12 @@ thenMethod :: (Method method) => Matcher (Args method) -> method -> Mock method thenMethod matcher method = tell $ MockSpec matcher method --- | @'throwNoStubShow' matcher@ means the method throws a 'NoStubException'+-- | @'throwNoStubShow' 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 ::   ( Method method,     Show (AsTuple (Args method)),-    MonadThrow (Base method),     TupleLike (Args method)   ) =>   Matcher (Args method) ->@@ -96,24 +87,23 @@   tell $     MockSpec matcher $       curryMethod $-        throwM . NoStubException . show . toTuple+        error . ("no stub found for argument: " <>) . show . toTuple --- | @'throwNoStubShow' fshow matcher@ means the method throws a 'NoStubException'+-- | @'throwNoStubShow' 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, MonadThrow (Base method)) => (Args method -> String) -> (Args method -> Bool) -> Mock method+throwNoStub :: (Method method) => (Args method -> String) -> (Args method -> Bool) -> Mock method throwNoStub fshow matcher =   tell $     MockSpec matcher $-      curryMethod $-        throwM . NoStubException . fshow+      curryMethod $ error . ("no stub found for argument: " <>) . fshow -fromRules :: (Method method, MonadThrow (Base method)) => [(Matcher (Args method), method)] -> method+fromRules :: Method 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"+        Nothing -> error "no stub. For debugging, use `throwNoStubShow anything`"  toRules :: MockSpec method -> [(Matcher (Args method), method)] toRules = reverse . go []
test/Test/Method/MockSpec.hs view
@@ -1,8 +1,8 @@ module Test.Method.MockSpec where -import Test.Hspec (Selector, Spec, describe, it, shouldReturn, shouldThrow)+import Test.Hspec (Spec, anyErrorCall, describe, it, shouldReturn, shouldThrow) import Test.Method.Matcher (ArgsMatcher (args), args', when)-import Test.Method.Mock (NoStubException, mockup, thenReturn)+import Test.Method.Mock (mockup, thenReturn)  spec :: Spec spec = do@@ -14,11 +14,8 @@     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 2 throws ErrorCall" $ do+      method 0 2 `shouldThrow` anyErrorCall      it "mock method 2 3 returns 42" $ do       method 2 3 `shouldReturn` 42--anyNoStubException :: Selector NoStubException-anyNoStubException _ = True