test-fixture 0.3.1.0 → 0.4.0.0

raw patch · 4 files changed

+154/−33 lines, 4 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• src/Control/Monad/TestFixture.hs +36/−19
• src/Control/Monad/TestFixture/TH.hs +70/−11
• test-fixture.cabal +3/−1
• test/Test/Control/Monad/TestFixtureSpec.hs +45/−2

@@ -1,5 +1,11 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+#endif+ {-|   = Introduction and motivation @@ -205,8 +211,11 @@   , arg6   , arg7   , unimplemented+  , log   ) where +import Prelude hiding (log)+ import qualified Control.Monad.Writer.Class import qualified Control.Monad.State.Class @@ -220,17 +229,17 @@ type TestFixture fixture log state = TestFixtureT fixture log state Identity  -- | 'TestFixture' as a monad transformer instead of as a monad.-newtype TestFixtureT fixture log state m a = TestFixtureT { getRWST :: RWST (fixture (TestFixtureT fixture log state m)) log state m a }+newtype TestFixtureT fixture log state m a = TestFixtureT { getRWST :: RWST (fixture (TestFixtureT fixture log state m)) [log] state m a }   deriving     ( Functor     , Applicative     , Monad     , MonadReader (fixture (TestFixtureT fixture log state m))-    , MonadWriter log+    , MonadWriter [log]     , MonadState state     ) -instance Monoid log => MonadTrans (TestFixtureT fixture log state) where+instance MonadTrans (TestFixtureT fixture log state) where   lift = TestFixtureT . lift  -- | The transformer equivalent of 'unTestFixture'.@@ -238,19 +247,19 @@ unTestFixtureT stack env = fmap fst (evalTestFixtureT stack env)  -- | The transformer equivalent of 'logTestFixture'.-logTestFixtureT :: Monad m => TestFixtureT fixture log () m a -> fixture (TestFixtureT fixture log () m) -> m log+logTestFixtureT :: Monad m => TestFixtureT fixture log () m a -> fixture (TestFixtureT fixture log () m) -> m [log] logTestFixtureT stack env = fmap snd (evalTestFixtureT stack env)  -- | The transformer equivalent of 'evalTestFixture'.-evalTestFixtureT :: Monad m => TestFixtureT fixture log () m a -> fixture (TestFixtureT fixture log () m) -> m (a, log)+evalTestFixtureT :: Monad m => TestFixtureT fixture log () m a -> fixture (TestFixtureT fixture log () m) -> m (a, [log]) evalTestFixtureT stack env = evalRWST (getRWST stack) env ()  -- | The transformer equivalent of 'execTestFixture'.-execTestFixtureT :: Monad m => TestFixtureT fixture log state m a -> fixture (TestFixtureT fixture log state m) -> state -> m (state, log)+execTestFixtureT :: Monad m => TestFixtureT fixture log state m a -> fixture (TestFixtureT fixture log state m) -> state -> m (state, [log]) execTestFixtureT stack env st = execRWST (getRWST stack) env st  -- | The transformer equivalent of 'runTestFixture'.-runTestFixtureT :: Monad m => TestFixtureT fixture log state m a -> fixture (TestFixtureT fixture log state m) -> state -> m (a, state, log)+runTestFixtureT :: Monad m => TestFixtureT fixture log state m a -> fixture (TestFixtureT fixture log state m) -> state -> m (a, state, [log]) runTestFixtureT stack env st = runRWST (getRWST stack) env st  {-|@@ -270,14 +279,14 @@   testing impure functions called exclusively for side-effects that do not   depend on complex prior state. -}-logTestFixture :: TestFixture fixture log () a -> fixture (TestFixture fixture log ()) -> log+logTestFixture :: TestFixture fixture log () a -> fixture (TestFixture fixture log ()) -> [log] logTestFixture stack env = runIdentity (logTestFixtureT stack env)  {-|   Combines 'unTestFixture' and 'logTestFixture' to return /both/ the   computation’s result and the written value as a tuple. -}-evalTestFixture :: TestFixture fixture log () a -> fixture (TestFixture fixture log ()) -> (a, log)+evalTestFixture :: TestFixture fixture log () a -> fixture (TestFixture fixture log ()) -> (a, [log]) evalTestFixture stack env = runIdentity (evalTestFixtureT stack env)  {-|@@ -285,7 +294,7 @@   monadic state tupled with the value written from the writer monad. Useful for   testing stateful side-effectful computations. -}-execTestFixture :: TestFixture fixture log state a -> fixture (TestFixture fixture log state) -> state -> (state, log)+execTestFixture :: TestFixture fixture log state a -> fixture (TestFixture fixture log state) -> state -> (state, [log]) execTestFixture stack env st = runIdentity (execTestFixtureT stack env st)  {-|@@ -293,7 +302,7 @@   resulting information: the computation’s result, the final monadic state, and   the value written from the writer. -}-runTestFixture :: TestFixture fixture log state a -> fixture (TestFixture fixture log state) -> state -> (a, state, log)+runTestFixture :: TestFixture fixture log state a -> fixture (TestFixture fixture log state) -> state -> (a, state, [log]) runTestFixture stack env st = runIdentity (runTestFixtureT stack env st)  {-|@@ -314,7 +323,7 @@   For functions of various arities instead of plain values, use 'arg1' through   'arg7', instead. -}-arg0 :: (Monoid log) => (fixture (TestFixture fixture log state) -> TestFixture fixture log state a) -> TestFixture fixture log state a+arg0 :: (fixture (TestFixture fixture log state) -> TestFixture fixture log state a) -> TestFixture fixture log state a arg0 rec = join $ asks rec  {-|@@ -333,43 +342,43 @@    For functions of higher arities, use 'arg2' through 'arg7'. -}-arg1 :: (Monoid log) => (fixture (TestFixture fixture log state) -> a -> TestFixture fixture log state b) -> a -> TestFixture fixture log state b+arg1 :: Monad m => (fixture (TestFixtureT fixture log state m) -> a -> TestFixtureT fixture log state m b) -> a -> TestFixtureT fixture log state m b arg1 rec a = do   fn <- asks rec   fn a  -- | Like 'arg1', but for functions of arity 2.-arg2 :: (Monoid log) => (fixture (TestFixture fixture log state) -> a -> b -> TestFixture fixture log state c) -> a -> b -> TestFixture fixture log state c+arg2 :: Monad m => (fixture (TestFixtureT fixture log state m) -> a -> b -> TestFixtureT fixture log state m c) -> a -> b -> TestFixtureT fixture log state m c arg2 rec a b = do   fn <- asks rec   fn a b  -- | Like 'arg1', but for functions of arity 3.-arg3 :: (Monoid log) => (fixture (TestFixture fixture log state) -> a -> b -> c -> TestFixture fixture log state d) -> a -> b -> c -> TestFixture fixture log state d+arg3 :: Monad m => (fixture (TestFixtureT fixture log state m) -> a -> b -> c -> TestFixtureT fixture log state m d) -> a -> b -> c -> TestFixtureT fixture log state m d arg3 rec a b c = do   fn <- asks rec   fn a b c  -- | Like 'arg1', but for functions of arity 4.-arg4 :: (Monoid log) => (fixture (TestFixture fixture log state) -> a -> b -> c -> d -> TestFixture fixture log state e) -> a -> b -> c -> d -> TestFixture fixture log state e+arg4 :: Monad m => (fixture (TestFixtureT fixture log state m) -> a -> b -> c -> d -> TestFixtureT fixture log state m e) -> a -> b -> c -> d -> TestFixtureT fixture log state m e arg4 rec a b c d = do   fn <- asks rec   fn a b c d  -- | Like 'arg1', but for functions of arity 5.-arg5 :: (Monoid log) => (fixture (TestFixture fixture log state) -> a -> b -> c -> d -> e -> TestFixture fixture log state f) -> a -> b -> c -> d -> e -> TestFixture fixture log state f+arg5 :: Monad m => (fixture (TestFixtureT fixture log state m) -> a -> b -> c -> d -> e -> TestFixtureT fixture log state m f) -> a -> b -> c -> d -> e -> TestFixtureT fixture log state m f arg5 rec a b c d e = do   fn <- asks rec   fn a b c d e  -- | Like 'arg1', but for functions of arity 6.-arg6 :: (Monoid log) => (fixture (TestFixture fixture log state) -> a -> b -> c -> d -> e -> f -> TestFixture fixture log state g) -> a -> b -> c -> d -> e -> f -> TestFixture fixture log state g+arg6 :: Monad m => (fixture (TestFixtureT fixture log state m) -> a -> b -> c -> d -> e -> f -> TestFixtureT fixture log state m g) -> a -> b -> c -> d -> e -> f -> TestFixtureT fixture log state m g arg6 rec a b c d e f = do   fn <- asks rec   fn a b c d e f  -- | Like 'arg1', but for functions of arity 7.-arg7 :: (Monoid log) => (fixture (TestFixture fixture log state) -> a -> b -> c -> d -> e -> f -> g -> TestFixture fixture log state h) -> a -> b -> c -> d -> e -> f -> g -> TestFixture fixture log state h+arg7 :: Monad m => (fixture (TestFixtureT fixture log state m) -> a -> b -> c -> d -> e -> f -> g -> TestFixtureT fixture log state m h) -> a -> b -> c -> d -> e -> f -> g -> TestFixtureT fixture log state m h arg7 rec a b c d e f g = do   fn <- asks rec   fn a b c d e f g@@ -385,3 +394,11 @@ -} unimplemented :: String -> a unimplemented name = error ("unimplemented fixture method `" ++ name ++ "`")++{-|+  Logs a single value using 'MonadWriter' when the writer state is a list.+  Equivalent to @'tell' . 'pure'@. Useful with 'TestFixture' implementations to+  record values when using functions like 'logTestFixture'.+-}+log :: MonadWriter [log] m => log -> m ()+log = tell . pure

@@ -48,15 +48,33 @@   > data Fixture m =   >   { _fetchRecord :: DBRecord a => Id a -> m (Either DBError a)   >   , _insertRecord :: DBRecord a => a -> m (Either DBError (Id a))-  >   , _sendRequest :: HTTPRequest -> m (Either HTTPError HTTPResponse) }+  >   , _sendRequest :: HTTPRequest -> m (Either HTTPError HTTPResponse)+  >   }   >   > instance Default (Fixture m) where-  >   def =+  >   def = Fixture   >     { _fetchRecord = unimplemented "_fetchRecord"   >     , _insertRecord = unimplemented "_insertRecord"-  >     , _sendRequest = unimplemented "_sendRequest" }+  >     , _sendRequest = unimplemented "_sendRequest"+  >     }   >-  > instance Monoid w => DB (TestFixture Fixture w s) where+  > type FixturePure = Fixture (TestFixture Fixture () ())+  >+  > type FixtureLog log = Fixture (TestFixture Fixture log ())+  >+  > type FixtureState state = Fixture (TestFixture Fixture () state)+  >+  > type FixtureLogState log state = Fixture (TestFixture Fixture log state)+  >+  > type FixturePureT m = Fixture (TestFixture Fixture () () m)+  >+  > type FixtureLogT log m = Fixture (TestFixture Fixture log () m)+  >+  > type FixtureStateT state m = Fixture (TestFixture Fixture () state m)+  >+  > type FixtureLogStateT log state m = Fixture (TestFixtureT Fixture log state m)+  >+  > instance Monad m => DB (TestFixtureT Fixture w s m) where   >   fetchRecord r = do   >     fn <- asks _fetchRecord   >     lift $ fn r@@ -64,7 +82,7 @@   >     fn <- asks _insertRecord   >     lift $ fn r   >-  > instance Monoid w => HTTP (TestFixture Fixture w s) where+  > instance Monad m => HTTP (TestFixtureT Fixture w s m) where   >   sendRequest r = do   >     fn <- asks _sendRequest   >     lift $ fn r@@ -79,8 +97,9 @@  import qualified Control.Monad.Reader as Reader +import Prelude hiding (log) import Control.Monad (join, replicateM)-import Control.Monad.TestFixture (TestFixture, unimplemented)+import Control.Monad.TestFixture (TestFixture, TestFixtureT, unimplemented) import Data.Default (Default(..)) import Data.List (foldl', nub, partition) import Language.Haskell.TH@@ -100,12 +119,13 @@   let fixtureName = mkName fixtureNameStr    (fixtureDec, fixtureFields) <- mkFixtureRecord fixtureName classNames+  typeSynonyms <- mkFixtureTypeSynonyms fixtureName   defaultInstanceDec <- mkDefaultInstance fixtureName fixtureFields    infos <- traverse reify classNames   instanceDecs <- traverse (flip mkInstance fixtureName) infos -  return ([fixtureDec, defaultInstanceDec] ++ instanceDecs)+  return ([fixtureDec, defaultInstanceDec] ++ typeSynonyms ++ instanceDecs)  mkFixtureRecord :: Name -> [Name] -> Q (Dec, [VarStrictType]) mkFixtureRecord fixtureName classNames = do@@ -120,6 +140,45 @@   let fixtureDec = mkDataD [] fixtureName [PlainTV mVar] fixtureCs   return (fixtureDec, fixtureFields) +mkFixtureTypeSynonyms :: Name -> Q [Dec]+mkFixtureTypeSynonyms fixtureName = do+  mName <- newName "m"+  logName <- newName "log"+  stateName <- newName "state"++  let mVar = VarT mName+  let logVar = VarT logName+  let stateVar = VarT stateName++  let mTVBndr = PlainTV mName+  let logTVBndr = PlainTV logName+  let stateTVBndr = PlainTV stateName++  let fixturePure = mkTypeSynonym "Pure" [] (mkFixtureType unit unit)+  let fixtureLog = mkTypeSynonym "Log" [logTVBndr] (mkFixtureType logVar unit)+  let fixtureState = mkTypeSynonym "State" [stateTVBndr] (mkFixtureType unit stateVar)+  let fixtureLogState = mkTypeSynonym "LogState" [logTVBndr, stateTVBndr] (mkFixtureType logVar stateVar)+  let fixturePureT = mkTypeSynonym "PureT" [mTVBndr] (mkFixtureTransformerType unit unit mVar)+  let fixtureLogT = mkTypeSynonym "LogT" [logTVBndr, mTVBndr] (mkFixtureTransformerType logVar unit mVar)+  let fixtureStateT = mkTypeSynonym "StateT" [stateTVBndr, mTVBndr] (mkFixtureTransformerType unit stateVar mVar)+  let fixtureLogStateT = mkTypeSynonym "LogStateT" [logTVBndr, stateTVBndr, mTVBndr] (mkFixtureTransformerType logVar stateVar mVar)++  return+    [ fixturePure+    , fixtureLog+    , fixtureState+    , fixtureLogState+    , fixturePureT+    , fixtureLogT+    , fixtureStateT+    , fixtureLogStateT+    ]+  where+    unit = TupleT 0+    mkTypeSynonym suffix varBndr ty = TySynD (mkName (nameBase fixtureName ++ suffix)) varBndr ty+    mkFixtureType log state = AppT (ConT fixtureName) (AppT (AppT (AppT (ConT ''TestFixture) (ConT fixtureName)) log) state)+    mkFixtureTransformerType log state m = AppT (ConT fixtureName) (AppT (AppT (AppT (AppT (ConT ''TestFixtureT) (ConT fixtureName)) log) state) m)+ mkDefaultInstance :: Name -> [VarStrictType] -> Q Dec mkDefaultInstance fixtureName fixtureFields = do   varName <- newName "m"@@ -137,15 +196,15 @@ mkInstance (ClassI (ClassD _ className _ _ methods) _) fixtureName = do   writerVar <- VarT <$> newName "w"   stateVar <- VarT <$> newName "s"+  mVar <- VarT <$> newName "m" -  let monoidConstraint = AppT (ConT ''Monoid) writerVar-  let fixtureWithoutVarsT = AppT (ConT ''TestFixture) (ConT fixtureName)-  let fixtureT = AppT (AppT fixtureWithoutVarsT writerVar) stateVar+  let fixtureWithoutVarsT = AppT (ConT ''TestFixtureT) (ConT fixtureName)+  let fixtureT = AppT (AppT (AppT fixtureWithoutVarsT writerVar) stateVar) mVar   let instanceHead = AppT (ConT className) fixtureT    funDecls <- traverse mkDictInstanceFunc methods -  return $ mkInstanceD [monoidConstraint] instanceHead funDecls+  return $ mkInstanceD [AppT (ConT ''Monad) mVar] instanceHead funDecls mkInstance other _ = fail $ "mkInstance: expected a class name, given " ++ show other  {-|

@@ -1,7 +1,7 @@ name:   test-fixture version:-  0.3.1.0+  0.4.0.0 synopsis:   Test monadic side-effects description:@@ -57,3 +57,5 @@     , test-fixture     , hspec     , hspec-discover+    , transformers+    , mtl

@@ -7,6 +7,7 @@  import Test.Hspec +import Control.Monad.Trans.Class (lift) import Control.Monad.TestFixture import Control.Monad.TestFixture.TH @@ -31,16 +32,44 @@ class Monad m => HTTP m where   sendRequest :: HTTPRequest -> m (Either HTTPError HTTPResponse) +class Monad m => Throw m where+  throwMessage :: String -> m a+ useDBAndHTTP :: (DB m, HTTP m, DBRecord r) => r -> m (Either DBError r) useDBAndHTTP record = do   (Right (Id recordId)) <- insertRecord record   (Right response) <- sendRequest $ GET ("/record/" ++ show recordId)   fetchRecord $ Id (responseStatus response) -mkFixture "Fixture" [''DB, ''HTTP]+mkFixture "Fixture" [''DB, ''HTTP, ''Throw] +-- At compile time, ensure the fixture type synonyms are generated.+fixturePure :: FixturePure+fixturePure = def :: Fixture (TestFixture Fixture () ())++fixtureLog :: FixtureLog log+fixtureLog = def :: Fixture (TestFixture Fixture log ())++fixtureState :: FixtureState state+fixtureState = def :: Fixture (TestFixture Fixture () s)++fixtureLogState :: FixtureLogState log state+fixtureLogState = def :: Fixture (TestFixture Fixture log state)++fixturePureT :: Monad m => FixturePureT m+fixturePureT = def :: Fixture (TestFixtureT Fixture () () m)++fixtureLogT :: Monad m => FixtureLogT log m+fixtureLogT = def :: Fixture (TestFixtureT Fixture log () m)++fixtureStateT :: Monad m => FixtureStateT state m+fixtureStateT = def :: Fixture (TestFixtureT Fixture () s m)++fixtureLogStateT :: Monad m => FixtureLogStateT log state m+fixtureLogStateT = def :: Fixture (TestFixtureT Fixture log state m)+ spec :: Spec-spec =+spec = do   describe "mkFixture" $     it "generates a fixture type that can be used to stub out methods" $ do       let fixture = def@@ -50,3 +79,17 @@             }       let result = unTestFixture (useDBAndHTTP User) fixture       result `shouldBe` Right User++  describe "handle throws" $ do+    it "capture a thrown error message" $ let+      throwFixture :: FixturePureT (Either String)+      throwFixture = def+        { _throwMessage = \msg -> lift (Left msg)+        }++      throwExample :: Throw m => m ()+      throwExample = throwMessage "error message"++      actual = unTestFixtureT throwExample throwFixture+      expected = Left "error message"+      in actual `shouldBe` expected