packages feed

polysemy-mocks (empty) → 0.1.0.0

raw patch · 11 files changed

+814/−0 lines, 11 filesdep +basedep +hspecdep +polysemysetup-changed

Dependencies added: base, hspec, polysemy, polysemy-mocks, template-haskell

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for polysemy-mocks++## 0.1.0.0++* First release. Can mock effects.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Akshay Mankar (c) 2020++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 Akshay Mankar 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,54 @@+# Polysemy Mocks++## Overview++`polysemy-mocks` aims to provide a structure to write all mocks for polysemy and to generate those.++## Example++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module TeletypeSpec where++import Data.Kind+import Polysemy+import Polysemy.Internal (send)+import Test.Hspec+import Test.Polysemy.Mock+import Test.Polysemy.Mock.TH (genMock)+import Prelude hiding (read)++data Teletype (m :: Type -> Type) a where+  Read :: Teletype m String+  Write :: String -> Teletype m ()++makeSem ''Teletype++genMock ''Teletype++program :: Member Teletype r => Sem r ()+program = do+  write "Name: "+  name <- read+  write $ "Hello " <> name++spec :: Spec+spec =+  describe "program" $ do+    it "greets" $ runM @IO . evalMock $ do+      mockReadReturns (pure "Akshay")+      mock @Teletype @IO program+      writes <- mockWriteCalls+      embed $ writes `shouldBe` ["Name: ", "Hello Akshay"]+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ polysemy-mocks.cabal view
@@ -0,0 +1,53 @@+cabal-version: 1.12++name:           polysemy-mocks+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/akshaymankar/polysemy-mocks#readme>+homepage:       https://github.com/akshaymankar/polysemy-mocks#readme+bug-reports:    https://github.com/akshaymankar/polysemy-mocks/issues+author:         Akshay Mankar+maintainer:     itsakshaymankar@gmail.com+copyright:      2020 Akshay Mankar+license:        BSD3+license-file:   LICENSE+build-type:     Simple+category:       Testing+synopsis:       Mocking framework for polysemy effects+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/akshaymankar/polysemy-mocks++library+  hs-source-dirs:+      src+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , polysemy+    , template-haskell+  exposed-modules:+      Test.Polysemy.Mock+      Test.Polysemy.Mock.TH++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      base >=4.7 && <5+    , hspec+    , polysemy+    , polysemy-mocks+  default-language: Haskell2010+  other-modules:+      Test.Polysemy.Mock.TeletypeTHSpec+      Test.Polysemy.Mock.TeletypeSpec+      Test.Polysemy.Mock.TeletypeIdentitySpec+  build-tool-depends:  hspec-discover:hspec-discover
+ src/Test/Polysemy/Mock.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.Polysemy.Mock+  ( Mock (..),+    runMock,+    evalMock,+    execMock,+    MockMany (..),+    MocksExist,+    MockChain,+    MockImpls,+    (:++:),+  )+where++import Data.Kind+import Polysemy+import Polysemy.State++-- | The 'Mock' class can be instantiated for an effect 'eff' and a functor 'm'.+-- Here 'eff' represents the effect being mocked and 'm' is the side-effect the mock implementation uses to keep track of 'MockState'.+--+-- To take the classic example of Teletype, we can mock Teletype using the 'Identity' functor like this:+-- Consder a Teletype effect defined as:+--+-- @+-- data Teletype (m :: * -> *) a where+--   Read :: Teletype m String+--   Write :: String -> Teletype m ()+--+-- makeSem ''Teletype+-- @+--+-- A simple 'Mock' instance which always reads "Mock" when Read action is called and records all Write actions.+--+-- @+-- instance Mock Teletype Identity where+--   data MockImpl Teletype Identity m a where+--     MockRead :: MockImpl Teletype Identity m String+--     MockWrite :: String -> MockImpl Teletype Identity m String+--     MockWriteCalls :: MockImpl Teletype Identity m [String]+--+--   data MockState Teletype Identity = MockState {writes :: [String]}+--+--   initialMockState = MockState []+--+--   mock = interpret $ \case+--     Read -> send @(MockImpl Teletype Identity) MockRead+--     Write s -> send @(MockImpl Teletype Identity) $ MockWrite s+--+--   mockToState = reinterpretH $ \case+--     MockRead -> pureT "Mock"+--     MockWrite s -> do+--       (MockState w) <- get @(MockState Teletype Identity)+--       put $ MockState (w ++ [s])+--       pureT ()+--     MockWriteCalls -> do+--       (MockState w) <- get @(MockState Teletype Identity)+--       pureT w+-- @+--+-- If we have a program which uses the @Teletype@ effect like this:+--+-- @+-- program :: Member Teletype r => Sem r ()+-- program = do+--  name <- read+--  write $ "Hello " <> name+-- @+--+-- This program can be tested using hspec and our mock like this:+--+-- @+-- spec :: Spec+-- spec = describe "program" $ do+--   it "writes hello message" $ do+--     let MockState w =+--           runIdentity . runM . execMock $+--             mock @Teletype @Identity program+--     w `shouldBe` ["Hello Mock"]+-- @+--+-- One can write such tests without even using this class. This class and the+-- library is more useful when used with the template haskell generator for the+-- mocks. The generator will produce a different mock than written above and it+-- can be used like this:+--+-- @+-- genMock ''Teletype+--+-- mockWriteReturns :: (String -> m ()) -> Sem '[MockImpl Teletype m, Embed m] ()+-- mockWriteReturns = send . MockWriteReturns+--+-- mockReadReturns :: m String -> Sem '[MockImpl Teletype m, Embed m] ()+-- mockReadReturns = send . MockReadReturns+--+-- mockReadCalls :: forall m. Sem '[MockImpl Teletype m, Embed m] [()]+-- mockReadCalls = send @(MockImpl Teletype m) MockReadCalls+--+-- mockWriteCalls :: forall m. Sem '[MockImpl Teletype m, Embed m] [String]+-- mockWriteCalls = send @(MockImpl Teletype m) MockWriteCalls+--+-- spec :: Spec+-- spec = describe "program" $ do+--   it "writes hello message" $ runM @IO . evalMock do+--     mockReadReturns $ pure "Mock"+--     mockWriteReturns $ pure ()+--     mock @Teletype @IO program+--     w <- mockWriteCalls+--     embed $ w `shouldBe` ["Hello Mock"]+-- @+class Mock (eff :: Effect) (m :: Type -> Type) where+  -- | The effect which 'eff' should be interpreted to+  data MockImpl eff m :: Effect++  -- | The type keep information about the mock.+  -- For example, it can be used to keep record of actions called on the effect and what to return on each call+  data MockState eff m++  -- | Can be used to set default return values and initialize other attributes of the 'MockState'+  initialMockState :: MockState eff m++  -- | Swaps real effect for the mock one.+  mock :: Member (MockImpl eff m) r => Sem (eff ': r) a -> Sem r a++  -- | Update mock state for every action on the mock+  mockToState :: Member (Embed m) r => Sem (MockImpl eff m ': r) a -> Sem (State (MockState eff m) ': r) a++-- | Run a mocked effect to get 'MockState' and the effect value+runMock :: (Mock eff m, Member (Embed m) r) => Sem (MockImpl eff m ': r) a -> Sem r (MockState eff m, a)+runMock = runState initialMockState . mockToState++-- | Like 'runMock' but discards the 'MockState'+evalMock :: (Mock eff m, Member (Embed m) r) => Sem (MockImpl eff m ': r) a -> Sem r a+evalMock = evalState initialMockState . mockToState++-- | Like 'runMock' but only returns the 'MockState'+execMock :: (Mock eff m, Member (Embed m) r) => Sem (MockImpl eff m ': r) a -> Sem r (MockState eff m)+execMock = execState initialMockState . mockToState++-- | Mock many effects+class MockMany (effs :: EffectRow) m (r :: EffectRow) where+  -- | Give a computation using a list of effects, transform it into a computation using Mocks of those effects+  mockMany :: MockChain effs m r => Sem (effs :++: r) a -> Sem r a++  -- | Given a computation using Mock effects, evaluate the computation+  evalMocks :: (MocksExist effs m, Member (Embed m) r) => Sem (MockImpls effs m :++: r) a -> Sem r a++instance MockMany '[] r m where+  mockMany = id+  evalMocks = id++instance (MockMany effs m r, Member (Embed m) (MockImpls effs m :++: r)) => MockMany (eff ': effs) m r where+  mockMany = mockMany @effs @m . mock @eff @m+  evalMocks = evalMocks @effs @m . evalMock @eff++type family MockChain (xs :: EffectRow) m (r :: EffectRow) :: Constraint where+  MockChain '[] r m = ()+  MockChain (x ': xs) m r = (Mock x m, Member (MockImpl x m) (xs :++: r), MockChain xs m r)++-- | Append type level lists+type family (xs :: [a]) :++: r :: [a] where+  '[] :++: r = r+  (x ': xs) :++: r = x ': (xs :++: r)++-- | Constraint to assert existence of mocks for each effect in 'xs' for state effect 'm'+type family MocksExist (xs :: EffectRow) m :: Constraint where+  MocksExist '[] _ = ()+  MocksExist (x ': xs) m = (Mock x m, MocksExist xs m)++type family MockImpls (xs :: EffectRow) m where+  MockImpls '[] _ = '[]+  MockImpls (x ': xs) m = MockImpl x m ': MockImpls xs m
+ src/Test/Polysemy/Mock/TH.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Polysemy.Mock.TH (genMock) where++import Data.Bifunctor (first)+import Data.List (foldl')+import Language.Haskell.TH hiding (Strict)+import Polysemy (Embed, Members, Sem, interpret, pureT, reinterpretH)+import Polysemy.Internal (embed, send)+import Polysemy.Internal.TH.Common+import Polysemy.State (get, put)+import Test.Polysemy.Mock++-- | Generate mock using template-haskell.+-- Example usage:+--+-- > genMock ''Teletype+genMock :: Name -> Q [Dec]+genMock effName = do+  (_, constructors) <- getEffectMetadata effName+  -- MockImpl+  let mockImplEffectType = ConT ''MockImpl `AppT` ConT effName `AppT` returnsEffect+  let mockImplReturnType = mockImplEffectType `AppT` VarT (mkName "m")+  let mockImplDataType = mockImplReturnType `AppT` VarT (mkName "a")+  let mockImplConstructors =+        map (mkMockConstructor mockImplReturnType) constructors+          <> map (mkMockReturns mockImplReturnType) constructors+          <> map (mkMockCalls mockImplReturnType) constructors+  let mockImplD = DataInstD [] Nothing mockImplDataType Nothing mockImplConstructors []+  -- MockState+  mockStateConName <- newName (nameBase ''MockState <> nameBase effName)+  let mockStateRec =+        map mkMockStateCallsField constructors+          <> map mkMockStateReturnsField constructors+  let mockStateConstructor = RecC mockStateConName mockStateRec+  let mockStateType = ConT ''MockState `AppT` ConT effName `AppT` returnsEffect+  let mockStateD = DataInstD [] Nothing mockStateType Nothing [mockStateConstructor] []+  -- initialMockState+  let initialStateExps =+        map mkInitialCalls constructors+          <> map mkInitialReturns constructors+  let initialStateBody = NormalB (RecConE mockStateConName initialStateExps)+  let initialStateD = FunD 'initialMockState [Clause [] initialStateBody []]+  -- mock+  let mockMatches = map (mkMockMatch mockImplEffectType) constructors+  let mockBody = NormalB (AppE (VarE 'interpret) (LamCaseE mockMatches))+  let mockD = FunD 'mock [Clause [] mockBody []]+  -- mockToState+  let mockToStateMatches =+        map (mkMockToStateMatch mockStateType) constructors+          <> map (mkReturnsToStateMatch mockStateType) constructors+          <> map (mkCallsToStateMatch mockStateType) constructors+  let mockToStateBody = NormalB (AppE (VarE 'reinterpretH) (LamCaseE mockToStateMatches))+  let mockToStateD = FunD 'mockToState [Clause [] mockToStateBody []]+  -- instance+  let mockInstanceD =+        InstanceD+          Nothing+          [ConT ''Applicative `AppT` returnsEffect]+          (ConT ''Mock `AppT` ConT effName `AppT` returnsEffect)+          [ mockImplD,+            mockStateD,+            initialStateD,+            mockD,+            mockToStateD+          ]+  -- makeSem+  let semD =+        concatMap (mkReturnsSem mockImplEffectType) constructors+          <> concatMap (mkCallsSem mockImplEffectType) constructors+  -- Bring it together+  pure $ mockInstanceD : semD++mkMockConstructor :: Type -> ConLiftInfo -> Con+mkMockConstructor t c =+  let args = (map (first (const defaultBang)) $ cliFunArgs c)+   in GadtC [mockConName c] args (AppT t $ cliEffRes c)++mkMockReturns :: Type -> ConLiftInfo -> Con+mkMockReturns t c =+  GadtC [returnsConName c] [(defaultBang, returnsFunctionType c)] (AppT t $ TupleT 0)++mkMockCalls :: Type -> ConLiftInfo -> Con+mkMockCalls t c =+  GadtC [callsConName c] [] (AppT t (functionCallType c))++mkMockStateCallsField :: ConLiftInfo -> (Name, Bang, Type)+mkMockStateCallsField c =+  (callsFieldName c, defaultBang, functionCallType c)++mkMockStateReturnsField :: ConLiftInfo -> (Name, Bang, Type)+mkMockStateReturnsField c =+  (returnsFieldName c, defaultBang, returnsFunctionType c)++mkInitialCalls :: ConLiftInfo -> (Name, Exp)+mkInitialCalls c =+  (callsFieldName c, ListE [])++mkInitialReturns :: ConLiftInfo -> (Name, Exp)+mkInitialReturns c =+  let returnsFn =+        case cliEffRes c of+          (TupleT 0) -> LamE (map (const WildP) $ cliFunArgs c) $ AppE (VarE 'pure) (TupE [])+          _ -> AppE (VarE 'error) (LitE (StringL $ "Unexpected mock invocation: " <> nameBase (cliFunName c)))+   in (returnsFieldName c, returnsFn)++mkMockMatch :: Type -> ConLiftInfo -> Match+mkMockMatch t c =+  let pat = ConP (cliConName c) (map (VarP . fst) (cliFunArgs c))+      sendFn = VarE 'send+      args = map (VarE . fst) (cliFunArgs c)+      theMock = foldl' AppE (ConE $ mockConName c) args+      body = NormalB (AppE (AppTypeE sendFn t) theMock)+   in Match pat body []++mkMockToStateMatch :: Type -> ConLiftInfo -> Match+mkMockToStateMatch t c =+  let pat = ConP (mockConName c) (map VarP vars)+      --+      vars = map fst (cliFunArgs c)+      newArgs = if length (cliFunArgs c) == 1+                   then ListE [ VarE . fst . head . cliFunArgs $ c]+                   else+#if MIN_VERSION_template_haskell(2,16,0)+                      ListE [TupE (map (Just . VarE . fst) $ cliFunArgs c)]+#else+                      ListE [TupE (map (VarE . fst) $ cliFunArgs c)]+#endif+      oldArgs = AppE (VarE (callsFieldName c)) (VarE stateName)+      allArgs = InfixE (Just oldArgs) (VarE '(++)) (Just newArgs)+      newState = RecUpdE (VarE stateName) [(callsFieldName c, allArgs)]+      --+      applyReturnsFn = foldl' AppE (VarE (returnsFieldName c)) (VarE stateName : map VarE vars)+      embedReturnsFn = AppE (VarE 'embed) applyReturnsFn+      returnAsPureT = NoBindS $ InfixE (Just (VarE 'pureT)) (VarE '(=<<)) (Just embedReturnsFn)+      body =+        NormalB+          ( DoE+              [ getState t,+                putState newState,+                returnAsPureT+              ]+          )+   in Match pat body []++mkReturnsToStateMatch :: Type -> ConLiftInfo -> Match+mkReturnsToStateMatch t c =+  let f = mkName "f"+      pat = ConP (returnsConName c) [VarP f]+      newState = RecUpdE (VarE stateName) [(returnsFieldName c, VarE f)]+      returnNothing = NoBindS $ AppE (VarE 'pureT) (TupE [])+      body =+        NormalB+          ( DoE+              [ getState t,+                putState newState,+                returnNothing+              ]+          )+   in Match pat body []++mkCallsToStateMatch :: Type -> ConLiftInfo -> Match+mkCallsToStateMatch t c =+  let pat = ConP (callsConName c) []+      returnCalls = NoBindS $ AppE (VarE 'pureT) (AppE (VarE (callsFieldName c)) (VarE stateName))+      body =+        NormalB+          ( DoE+              [ getState t,+                returnCalls+              ]+          )+   in Match pat body []++mkReturnsSem ::+  -- | Should look like: @MockImpl Teletype n@+  -- n is assumed to be 'stateEffectName', maybe this is problematic, but it works for now+  Type ->+  ConLiftInfo ->+  [Dec]+mkReturnsSem mockImplEffType c =+  let funcName = mkName ("mock" <> nameBase (cliConName c) <> "Returns")+      body = NormalB (InfixE (Just $ VarE 'send) (VarE '(.)) (Just $ ConE (returnsConName c)))+      appArrowT = AppT . AppT ArrowT+      r = VarT $ mkName "r"+      semr t = ConT ''Sem `AppT` r `AppT` t+      typ = ForallT [] [membersEffListType mockImplEffType r] (returnsFunctionType c `appArrowT` semr (TupleT 0))+   in [ SigD funcName typ,+        FunD funcName [Clause [] body []]+      ]++mkCallsSem ::+  -- | Should look like: @MockImpl Teletype n@+  -- n is assumed to be 'stateEffectName', maybe this is problematic, but it works for now+  Type ->+  ConLiftInfo ->+  [Dec]+mkCallsSem mockImplEffType c =+  let funcName = mkName ("mock" <> nameBase (cliConName c) <> "Calls")+      typeAppliedSend = VarE 'send `AppTypeE` mockImplEffType+      body = NormalB $ typeAppliedSend `AppE` ConE (callsConName c)+      r = VarT $ mkName "r"+      semr t = ConT ''Sem `AppT` r `AppT` t+      typ = ForallT [PlainTV returnsEffectName, PlainTV $ mkName "r"] [membersEffListType mockImplEffType r] (semr $ functionCallType c)+   in [ SigD funcName typ,+        FunD funcName [Clause [] body []]+      ]++membersEffListType :: Type -> Type -> Type+membersEffListType mockImplEffType r =+  let embededStateEffect = ConT ''Embed `AppT` VarT returnsEffectName+      appConsT = AppT . AppT PromotedConsT+      effList = foldr appConsT PromotedNilT [mockImplEffType, embededStateEffect]+   in ConT ''Members `AppT` effList `AppT` r++getState :: Type -> Stmt+getState t = BindS (VarP stateName) (VarE 'get `AppTypeE` t)++putState :: Exp -> Stmt+putState newState = NoBindS (AppE (VarE 'put) newState)++stateName :: Name+stateName = mkName "state"++callsConName :: ConLiftInfo -> Name+callsConName c = mkName ("Mock" <> nameBase (cliConName c) <> "Calls")++returnsConName :: ConLiftInfo -> Name+returnsConName c = mkName ("Mock" <> nameBase (cliConName c) <> "Returns")++mockConName :: ConLiftInfo -> Name+mockConName c = mkName ("Mock" <> nameBase (cliConName c))++callsFieldName :: ConLiftInfo -> Name+callsFieldName c = mkName (nameBase (cliFunName c) <> "Calls")++returnsFieldName :: ConLiftInfo -> Name+returnsFieldName c = mkName (nameBase (cliFunName c) <> "Returns")++defaultBang :: Bang+defaultBang = Bang NoSourceUnpackedness NoSourceStrictness++functionCallType :: ConLiftInfo -> Type+functionCallType c =+  let arity = length $ cliFunArgs c+   in if arity == 1+        then AppT ListT $ snd $ head $ cliFunArgs c+        else AppT ListT $ foldl' AppT (TupleT arity) (map snd $ cliFunArgs c)++returnsFunctionType :: ConLiftInfo -> Type+returnsFunctionType c =+  let argTypes = (map snd $ cliFunArgs c)+      returnType = (AppT returnsEffect $ cliEffRes c)+   in foldr (AppT . AppT ArrowT) returnType argTypes++returnsEffect :: Type+returnsEffect = VarT returnsEffectName++returnsEffectName :: Name+returnsEffectName = mkName "n"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Test/Polysemy/Mock/TeletypeIdentitySpec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Polysemy.Mock.TeletypeIdentitySpec where++import Data.Functor.Identity+import Data.Kind+import Polysemy+import Polysemy.Internal (send)+import Polysemy.State+import Test.Hspec+import Test.Polysemy.Mock+import Prelude hiding (read)++data Teletype (m :: Type -> Type) a where+  Read :: Teletype m String+  Write :: String -> Teletype m ()++read :: Member Teletype r => Sem r String+read = send Read++write :: Member Teletype r => String -> Sem r ()+write = send . Write++instance Mock Teletype Identity where+  data MockImpl Teletype Identity m a where+    MockRead :: MockImpl Teletype Identity m String+    MockWrite :: String -> MockImpl Teletype Identity m ()+    MockWriteCalls :: MockImpl Teletype Identity m [String]++  data MockState Teletype Identity = MockState {writes :: [String]}++  initialMockState = MockState []++  mock = interpret $ \case+    Read -> send @(MockImpl Teletype Identity) MockRead+    Write s -> send @(MockImpl Teletype Identity) $ MockWrite s++  mockToState = reinterpretH $ \case+    MockRead -> pureT "Mock"+    MockWrite s -> do+      (MockState w) <- get @(MockState Teletype Identity)+      put $ MockState (w ++ [s])+      pureT ()+    MockWriteCalls -> do+      (MockState w) <- get @(MockState Teletype Identity)+      pureT w++program :: Member Teletype r => Sem r ()+program = do+  name <- read+  write $ "Hello " <> name++{-# ANN spec ("HLint: ignore Redundant do" :: String) #-}+spec :: Spec+spec = describe "program" $ do+  it "writes hello message" $ do+    let MockState w =+          runIdentity . runM . execMock $+            mock @Teletype @Identity program+    w `shouldBe` ["Hello Mock"]
+ test/Test/Polysemy/Mock/TeletypeSpec.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Polysemy.Mock.TeletypeSpec where++import Data.Functor.Identity+import Data.Kind+import Polysemy+import Polysemy.Internal (send)+import Polysemy.State+import Test.Hspec+import Test.Polysemy.Mock+import Prelude hiding (read)++data Teletype (m :: Type -> Type) a where+  Read :: Teletype m String+  Write :: String -> Teletype m ()++read :: Member Teletype r => Sem r String+read = send Read++write :: Member Teletype r => String -> Sem r ()+write = send . Write++instance forall n. Mock Teletype n where+  data MockImpl Teletype n m a where+    MockRead :: MockImpl Teletype n m String+    MockWrite :: String -> MockImpl Teletype n m ()+    MockReadReturns :: n String -> MockImpl Teletype n m ()+    MockWriteReturns :: (String -> n ()) -> MockImpl Teletype n m ()+    MockReadCalls :: MockImpl Teletype n m [()]+    MockWriteCalls :: MockImpl Teletype n m [String]++  data MockState Teletype n = MockState+    { readCalls :: [()],+      writeCalls :: [String],+      readReturns :: n String,+      writeReturns :: String -> n ()+    }++  initialMockState = MockState [] [] (error "Unimplemented") (error "Unimplemented")++  mock = interpret $ \case+    Read -> send @(MockImpl Teletype n) MockRead+    Write s -> send @(MockImpl Teletype n) $ MockWrite s+  mockToState = reinterpretH $ \case+    MockRead -> do+      state <- get @(MockState Teletype n)+      put state {readCalls = readCalls state ++ [()]}+      pureT =<< embed (readReturns state)+    MockWrite s -> do+      state <- get @(MockState Teletype n)+      put state {writeCalls = writeCalls state ++ [s]}+      pureT =<< embed (writeReturns state s)+    MockReadReturns f -> do+      state <- get @(MockState Teletype n)+      put state {readReturns = f}+      pureT ()+    MockWriteReturns f -> do+      state <- get @(MockState Teletype n)+      put state {writeReturns = f}+      pureT ()+    MockReadCalls -> do+      state <- get @(MockState Teletype n)+      pureT (readCalls state)+    MockWriteCalls -> do+      state <- get @(MockState Teletype n)+      pureT (writeCalls state)++mockWriteReturns :: (String -> m ()) -> Sem '[MockImpl Teletype m, Embed m] ()+mockWriteReturns = send . MockWriteReturns++mockReadReturns :: m String -> Sem '[MockImpl Teletype m, Embed m] ()+mockReadReturns = send . MockReadReturns++mockReadCalls :: forall m. Sem '[MockImpl Teletype m, Embed m] [()]+mockReadCalls = send @(MockImpl Teletype m) MockReadCalls++mockWriteCalls :: forall m. Sem '[MockImpl Teletype m, Embed m] [String]+mockWriteCalls = send @(MockImpl Teletype m) MockWriteCalls++program :: Member Teletype r => Sem r ()+program = do+  write "Name: "+  name <- read+  write $ "Hello " <> name++{-# ANN spec ("HLint: ignore Redundant do" :: String) #-}+spec :: Spec+spec =+  describe "program" $ do+    it "greets" $ runM @IO . evalMock $ do+      mockWriteReturns (const $ pure ())+      mockReadReturns (pure "Akshay")+      mock @Teletype @IO program+      writes <- mockWriteCalls+      embed $ writes `shouldBe` ["Name: ", "Hello Akshay"]+    it "greets without IO" $ do+      let state = runIdentity . runM @Identity . execMock $ do+            mockWriteReturns (const $ pure ())+            mockReadReturns (pure "Akshay")+            mock @Teletype @Identity program+      writeCalls state `shouldBe` ["Name: ", "Hello Akshay"]
+ test/Test/Polysemy/Mock/TeletypeTHSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Test.Polysemy.Mock.TeletypeTHSpec where++import Data.Kind+import Polysemy+import Test.Hspec+import Test.Polysemy.Mock+import Test.Polysemy.Mock.TH (genMock)+import Prelude hiding (read)++data Teletype (m :: Type -> Type) a where+  Read :: Teletype m String+  Write :: String -> Teletype m ()++makeSem ''Teletype++genMock ''Teletype++program :: Member Teletype r => Sem r ()+program = do+  write "Name: "+  name <- read+  write $ "Hello " <> name++{-# ANN spec ("HLint: ignore Redundant do" :: String) #-}+spec :: Spec+spec =+  describe "program" $ do+    it "greets" $+      runM @IO . evalMock @Teletype @IO $ do+        mockReadReturns @IO (pure "Akshay")+        mock @Teletype @IO program+        writes <- mockWriteCalls @IO+        embed $ writes `shouldBe` ["Name: ", "Hello Akshay"]