packages feed

test-fixture 0.2.0.0 → 0.2.1.0

raw patch · 3 files changed

+327/−22 lines, 3 filesdep ~basedep ~template-haskell

Dependency ranges changed: base, template-haskell

Files

src/Control/Monad/TestFixture.hs view
@@ -1,19 +1,201 @@-module Control.Monad.TestFixture-  ( module Control.Monad.RWS.Class-  , WST+{-|+  = Introduction and motivation++  This package provides a set of helper functions and types that are designed to+  assist with writing tests for functions that encode side-effects into monads+  using effect-specific typeclasses. Consider a function that performs some sort+  of side effect, such as a function that looks up a user from a database:++  > lookupUser :: UserId -> IO (Maybe User)++  Now consider a function that uses the @lookupUser@ function:++  > lookupUserIsAdmin :: UserId -> IO Bool+  > lookupUserIsAdmin userId = do+  >   maybeUser <- lookupUser userId+  >   return $ maybe False isAdmin maybeUser++  This function works fine, but it’s very difficult to test, even though it is+  extremely simple. Since @lookupUser@ just runs in 'IO', it isn’t easy to test+  @lookupUserIsAdmin@ in isolation. To fix this, it’s possible to create a+  layer of indirection between @lookupUserIsAdmin@ and @lookupUser@ by making+  @lookupUser@ a method of a typeclass instead of a free function:++  > class Monad m => LookupUser m where+  >   lookupUser :: UserId -> m (Maybe User)++  Implementing the original, 'IO'-bound version of @lookupUser@ is easy; we just+  create a @LookupUser@ instance for 'IO':++  > instance LookupUser IO where+  >   lookupUser = lookupUserIO++  However, we can also create other monads that implement the @LookupUser@+  typeclass. For example, we could create a very simple newtype wrapper around+  'Data.Functor.Identity.Identity' with an implementation that /always/ returns+  a user successfully:++  > newtype SuccessMonad a = SuccessMonad (Identity a)+  >   deriving (Functor, Applicative, Monad)+  >+  > runSuccess :: SuccessMonad a -> a+  > runSuccess (SuccessMonad (Identity x)) = x+  >+  > instance LookupUser SuccessMonad where+  >   lookupUser _ = return $ Just User { isAdmin = True }++  Now we can test @lookupUserIsAdmin@ completely deterministically without ever+  needing to touch a real database (using hspec syntax as an example):++  > lookupUserIsAdmin :: LookupUser m => UserId -> m Bool+  > lookupUserIsAdmin userId = do+  >   maybeUser <- lookupUser userId+  >   return $ maybe False isAdmin maybeUser+  >+  > spec = describe "lookupUserIsAdmin" $ do+  >   it "returns True when the UserId corresponds to an admin user" $+  >     runSuccess (lookupUserIsAdmin (UserId 42)) `shouldBe` True++  Similarly, we can also test the failure case by creating a monad that will+  always return 'Nothing':++  > newtype FailureMonad a = FailureMonad (Identity a)+  >   deriving (Functor, Applicative, Monad)+  >+  > runFailure :: FailureMonad a -> a+  > runFailure (FailureMonad (Identity x)) = x+  >+  > instance LookupUser FailureMonad where+  >   lookupUser _ = return Nothing+  >+  >   it "returns False when the UserId does not have a corresponding User" $+  >     runFailure (lookupUserIsAdmin (UserId 42)) `shouldBe` False++  This is great, but it comes at a pretty significant cost: lots and lots of+  boilerplate. It could get even worse when you have a typeclass with many+  methods, or even multiple typeclasses at a time! Clearly, there needs to be+  some way to abstract this pattern a little bit to make it easier to use.++  = Creating a customizable monad++  To permit creating easily customizable implementations of monadic interfaces,+  we can /reify/ a typeclass at the value level by creating a record type with+  a field that corresponds to each method:++  > data Fixture m = Fixture { _lookupUser :: UserId -> m (Maybe User) }++  We have to prefix each method name with an underscore to avoid name clashes,+  but now we have the ability to create a first-class value that represents+  a particular implementation of the @LookupUser@ typeclass. The next step+  is turning one of these values into something that can actually be supplied as+  a monad implementation. One way to do this is to use a reader monad to thread+  a particular 'Fixture' value around. We can create a newtype that will do that+  for us:++  > newtype FixtureM a = FixtureM (Fixture Identity -> a)+  >   deriving (Functor, Applicative, Monad)+  >+  > runFixture :: Fixture Identity -> FixtureM a -> a+  > runFixture fixture (FixtureM func) = func fixture++  By making this new `FixtureM` type an instance of `LookupUser`, we can use+  the @runFixture@ function that we defined to run a particular computation with+  any arbitrary fixture at runtime:++  > instance LookupUser FixtureM where+  >   lookupUser userId = FixtureM $ \fixture ->+  >     runIdentity $ _lookupUser fixture userId++  Now we can write all our tests using one-off fixture implementations without+  creating entirely new types:++  > spec = describe "lookupUserIsAdmin" $ do+  >   it "returns True when the UserId corresponds to an admin user" $ do+  >     let fixture = Fixture { _lookupUser = return $ Just User { isAdmin = True } }+  >     runFixture fixture (lookupUserIsAdmin (UserId 42)) `shouldBe` True+  >+  >   it "returns False when the UserId corresponds to a non-admin user" $ do+  >     let fixture = Fixture { _lookupUser = return $ Just User { isAdmin = False } }+  >     runFixture fixture (lookupUserIsAdmin (UserId 42)) `shouldBe` False+  >+  >   it "returns False when the UserId does not have a corresponding User" $ do+  >     let fixture = Fixture { _lookupUser = return Nothing }+  >     runFixture fixture (lookupUserIsAdmin (UserId 42)) `shouldBe` False++  = Moving beyond a reader++  The above example is relatively contrived, but it may be possible to see how+  this technique could be applied to a larger set of monadic typeclasses by+  creating more instances on a fixture with more methods.++  However, it is sometimes useful to do /even more/ with a fixture, such as+  verifying that a given function was called with a particular argument. For+  example, consider a function with the following signature:++  > insertUser :: User -> m ()++  In this case, testing the /result/ is likely not particulary interesting, but+  testing that the function itself is called with the right argument might be+  helpful. Even more subtly, a function might be called multiple times, and it+  might need to return different values each time! This requires some degree of+  state tracking that a reader monad simply cannot provide.++  To solve this, the provided 'TestFixture' monad is a wrapper aroud the 'RWS'+  monad, which combines a /reader/, /writer/, and /state/ monad into a single+  system. This allows “logging” results from a fixture by using 'tell' within+  the fixture definition and 'logTestFixture', and it also permits having+  fixture invocations depend on previous uses of the fixture by using 'get' and+  'put' from 'MonadState'.++  Continuing from the above example but using 'TestFixture' instead, we eschew+  the simpler @FixtureM@ type and create instances over 'TestFixture' instead:++  > instance Monoid w => LookupUser (TestFixture Fixture w s) where+  >   lookupUser userId = do+  >     fn <- asks _lookupUser+  >     lift $ fn userId++  Now we can write our tests using the 'unTestFixture' function, along with the+  similar 'logTestFixture' functions and friends:++  > spec = describe "lookupUserIsAdmin" $ do+  >   it "returns True when the UserId corresponds to an admin user" $ do+  >     let fixture = Fixture { _lookupUser = return $ Just User { isAdmin = True } }+  >     unTestFixture (lookupUserIsAdmin (UserId 42)) fixture () `shouldBe` True+  >+  >   it "returns False when the UserId corresponds to a non-admin user" $ do+  >     let fixture = Fixture { _lookupUser = return $ Just User { isAdmin = False } }+  >     unTestFixture (lookupUserIsAdmin (UserId 42)) fixture () `shouldBe` False+  >+  >   it "returns False when the UserId does not have a corresponding User" $ do+  >     let fixture = Fixture { _lookupUser = return Nothing }+  >     unTestFixture (lookupUserIsAdmin (UserId 42)) fixture () `shouldBe` False++  As a final note, writing out all of these fixture record definitions and+  instance declarations can be extremely tedious with large numbers of+  typeclasses and tests. To mitigate this, the "Control.Monad.TestFixture.TH"+  module provides a 'Control.Monad.TestFixture.TH.mkFixture' function, which+  uses Template Haskell to generate the necessary code instead.+-}+module Control.Monad.TestFixture (+  -- * The TestFixture monad+    TestFixture   , WS+  , unTestFixture+  , logTestFixture+  , evalTestFixture+  , execTestFixture+  , runTestFixture+  -- * The TestFixtureT monad transformer   , TestFixtureT-  , TestFixture+  , WST   , unTestFixtureT   , logTestFixtureT   , evalTestFixtureT   , execTestFixtureT   , runTestFixtureT-  , unTestFixture-  , logTestFixture-  , evalTestFixture-  , execTestFixture-  , runTestFixture+  -- * Helper functions+  , module Control.Monad.RWS.Class   , arg0   , arg1   , arg2@@ -30,78 +212,172 @@ import Data.Functor.Identity import Control.Monad.Reader -type WST w s m = RWST () w s m+-- | The 'TestFixture' monad. A wrapper around the 'RWS' monad, where the reader+--   is a reified typeclass dictionary. For more information, see the module+--   documentation for "Control.Monad.TestFixture".+type TestFixture r w s = TestFixtureT r w s Identity+-- | A type alias for 'RWS' where the reader component is always @()@. Used+--   because the actual reader component is already occupied by the dictionary+--   being threaded by the 'TestFixture' monad. type WS w s = WST w s Identity++-- | 'TestFixture' as a monad transformer instead of as a monad. A wrapper+--   around the 'RWST' monad transformer. type TestFixtureT r w s m = ReaderT (r (WST w s m)) (WST w s m)-type TestFixture r w s = TestFixtureT r w s Identity+-- | The 'WS' type alias equivalent for the 'TestFixtureT' monad transformer.+type WST w s m = RWST () w s m +-- | The transformer equivalent of 'unTestFixture'. unTestFixtureT :: Monad m => TestFixtureT r () s m a -> r (WST () s m)  -> s -> m a unTestFixtureT stack env st = fmap fst (evalTestFixtureT stack env st) +-- | The transformer equivalent of 'logTestFixture'. logTestFixtureT :: Monad m => TestFixtureT r w s m a -> r (WST w s m)  -> s -> m w logTestFixtureT stack env st = fmap snd (evalTestFixtureT stack env st) +-- | The transformer equivalent of 'evalTestFixture'. evalTestFixtureT :: Monad m => TestFixtureT r w s m a -> r (WST w s m)  -> s -> m (a, w) evalTestFixtureT stack env st = evalRWST (runReaderT stack env) () st +-- | The transformer equivalent of 'execTestFixture'. execTestFixtureT :: Monad m => TestFixtureT r w s m a -> r (WST w s m) -> s -> m (s, w) execTestFixtureT stack env st = execRWST (runReaderT stack env) () st +-- | The transformer equivalent of 'runTestFixture'. runTestFixtureT :: Monad m => TestFixtureT r w s m a -> r (WST w s m)  -> s -> m (a, s, w) runTestFixtureT stack env st = runRWST (runReaderT stack env) () st -unTestFixture :: TestFixture r () s a -> r (WS () s)  -> s -> a+{-|+  The simplest way to run a test given a fixture, 'unTestFixture' simply runs a+  monadic computation with a particular fixture and a starting state and returns+  the computations result. Useful for testing impure functions that return+  useful values.+-}+unTestFixture+  :: TestFixture r () s a -- ^ the monadic computation to run+  -> r (WS () s)          -- ^ the fixture dictionary to use+  -> s                    -- ^ the initial monad state+  -> a                    -- ^ the computation’s result unTestFixture stack env st = runIdentity (unTestFixtureT stack env st) -logTestFixture :: TestFixture r w s a -> r (WS w s)  -> s -> w+{-|+  Like 'unTestFixture', but instead of returning the result of the computation,+  'logTestFixture' returns the value written from the writer monad. Useful for+  testing impure functions called exclusively for side-effects that do not+  depend on complex prior state.+-}+logTestFixture :: TestFixture r w s a -> r (WS w s) -> s -> w logTestFixture stack env st = runIdentity (logTestFixtureT stack env st) -evalTestFixture :: TestFixture r w s a -> r (WS w s)  -> s -> (a, w)+{-|+  Combines 'unTestFixture' and 'logTestFixture' to return /both/ the+  computation’s result and the written value as a tuple.+-}+evalTestFixture :: TestFixture r w s a -> r (WS w s) -> s -> (a, w) evalTestFixture stack env st = runIdentity (evalTestFixtureT stack env st) -execTestFixture :: TestFixture r w s a -> r (WS w s)  -> s -> (s, w)+{-|+  Like 'logTestFixture' but returns the final monadic state as well as the value+  written from the writer monad. Useful for testing stateful side-effectful+  computations.+-}+execTestFixture :: TestFixture r w s a -> r (WS w s) -> s -> (s, w) execTestFixture stack env st = runIdentity (execTestFixtureT stack env st) -runTestFixture :: TestFixture r w s a -> r (WS w s)  -> s -> (a, s, w)+{-|+  Runs a test fixture and returns all three pieces of resulting information:+  the computation’s result, the final monadic state, and the value written from+  the writer.+-}+runTestFixture :: TestFixture r w s a -> r (WS w s) -> s -> (a, s, w) runTestFixture stack env st = runIdentity (runTestFixtureT stack env st) +{-|+  A helper function for implementing typeclass instances over 'TestFixture' that+  pull a value out of a monadic dictionary. For example, given the following+  instance:++  > instance Monoid w => MonadSomething (TestFixture Fixture w s) where+  >   getSomething = do+  >     something <- asks _getSomething+  >     lift something++  Using 'arg0', it can be rewritten like this:++  > instance Monoid w => MonadSomething (TestFixture Fixture w s) where+  >   getSomething = arg0 _getSomething++  For functions of various arities instead of plain values, use 'arg1' through+  'arg7', instead.+-} arg0 :: (Monoid w) => (r (WS w s) -> WS w s a) -> TestFixture r w s a arg0 rec = asks rec >>= lift +{-|+  Like 'arg0', but for lifting record accessors containing functions of arity+  one. For example, given the following instance:++  > instance Monoid w => MonadSomething (TestFixture Fixture w s) where+  >   doSomething x = do+  >     fn <- asks _doSomething+  >     lift $ fn x++  Using 'arg1', it can be rewritten like this:++  > instance Monoid w => MonadSomething (TestFixture Fixture w s) where+  >   doSomething = arg1 _doSomething++  For functions of higher arities, use 'arg2' through 'arg7'.+-} arg1 :: (Monoid w) => (r (WS w s) -> a -> WS w s b) -> a -> TestFixture r w s b arg1 rec a = do   fn <- asks rec   lift $ fn a +-- | Like 'arg1', but for functions of arity 2. arg2 :: (Monoid w) => (r (WS w s) -> a -> b -> WS w s c) -> a -> b -> TestFixture r w s c arg2 rec a b = do   fn <- asks rec   lift $ fn a b +-- | Like 'arg1', but for functions of arity 3. arg3 :: (Monoid w) => (r (WS w s) -> a -> b -> c -> WS w s d) -> a -> b -> c -> TestFixture r w s d arg3 rec a b c = do   fn <- asks rec   lift $ fn a b c +-- | Like 'arg1', but for functions of arity 4. arg4 :: (Monoid w) => (r (WS w s) -> a -> b -> c -> d -> WS w s e) -> a -> b -> c -> d -> TestFixture r w s e arg4 rec a b c d = do   fn <- asks rec   lift $ fn a b c d +-- | Like 'arg1', but for functions of arity 5. arg5 :: (Monoid w) => (r (WS w s) -> a -> b -> c -> d -> e -> WS w s f) -> a -> b -> c -> d -> e -> TestFixture r w s f arg5 rec a b c d e = do   fn <- asks rec   lift $ fn a b c d e +-- | Like 'arg1', but for functions of arity 6. arg6 :: (Monoid w) => (r (WS w s) -> a -> b -> c -> d -> e -> f -> WS w s g) -> a -> b -> c -> d -> e -> f -> TestFixture r w s g arg6 rec a b c d e f = do   fn <- asks rec   lift $ fn a b c d e f +-- | Like 'arg1', but for functions of arity 7. arg7 :: (Monoid w) => (r (WS w s) -> a -> b -> c -> d -> e -> f -> g -> WS w s h) -> a -> b -> c -> d -> e -> f -> g -> TestFixture r w s h arg7 rec a b c d e f g = do   fn <- asks rec   lift $ fn a b c d e f g +{-|+  An extremely simple helper function for creating “base” fixture dictionaries+  with implementations that will simply throw as soon as they are called using+  a helpful error message. The provided argument should be the name of a method+  being implemented.++  >>> unimplemented "_getSomething"+  *** Exception: unimplemented fixture method `_getSomething`+-} unimplemented :: String -> a unimplemented name = error ("unimplemented fixture method `" ++ name ++ "`")
src/Control/Monad/TestFixture/TH.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}  {-|@@ -116,7 +117,7 @@   let fixtureFields = join $ zipWith (methodsToFields mVar) types methods   let fixtureCs = [RecC fixtureName fixtureFields] -  let fixtureDec = DataD [] fixtureName [PlainTV mVar] fixtureCs []+  let fixtureDec = mkDataD [] fixtureName [PlainTV mVar] fixtureCs   return (fixtureDec, fixtureFields)  mkDefaultInstance :: Name -> [VarStrictType] -> Q Dec@@ -130,7 +131,7 @@   let defImpl = RecConE fixtureName fixtureClauses   let defDecl = FunD 'def [Clause [] (NormalB defImpl) []] -  return $ InstanceD [] (AppT (ConT ''Default) appliedFixtureT) [defDecl]+  return $ mkInstanceD [] (AppT (ConT ''Default) appliedFixtureT) [defDecl]  mkInstance :: Info -> Name -> Q Dec mkInstance (ClassI (ClassD _ className _ _ methods) _) fixtureName = do@@ -144,7 +145,7 @@    funDecls <- traverse mkDictInstanceFunc methods -  return $ InstanceD [monoidConstraint] instanceHead funDecls+  return $ mkInstanceD [monoidConstraint] instanceHead funDecls mkInstance other _ = fail $ "mkInstance: expected a class name, given " ++ show other  {-|@@ -191,7 +192,7 @@        is the typeclass whose constraint must be removed. -} methodToField :: Name -> Type -> Dec -> VarStrictType-methodToField mVar classT (SigD name typ) = (fieldName, NotStrict, newT)+methodToField mVar classT (SigD name typ) = (fieldName, noStrictness, newT)   where fieldName = methodNameToFieldName name         newT = replaceClassConstraint classT mVar typ methodToField _ _ _ = error "internal error; report a bug with the test-fixture package"@@ -332,3 +333,31 @@ -} applyE :: Exp -> [Exp] -> Exp applyE = foldl' AppE++{------------------------------------------------------------------------------|+| The following functions abstract over differences in template-haskell        |+| between GHC versions. This allows the same code to work without writing CPP  |+| everywhere and ending up with a small mess.                                  |+|------------------------------------------------------------------------------}++mkInstanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+mkInstanceD = InstanceD Nothing+#else+mkInstanceD = InstanceD+#endif++mkDataD :: Cxt -> Name -> [TyVarBndr] -> [Con] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+mkDataD a b c d = DataD a b c Nothing d []+#else+mkDataD a b c d = DataD a b c d []+#endif++#if MIN_VERSION_template_haskell(2,11,0)+noStrictness :: Bang+noStrictness = Bang NoSourceUnpackedness NoSourceStrictness+#else+noStrictness :: Strict+noStrictness = NotStrict+#endif
test-fixture.cabal view
@@ -1,7 +1,7 @@ name:   test-fixture version:-  0.2.0.0+  0.2.1.0 synopsis:   Test monadic side-effects description:@@ -37,7 +37,7 @@       base >= 4.7 && < 5     , data-default     , mtl-    , template-haskell+    , template-haskell >= 2.10 && < 2.12  source-repository head   type: