packages feed

freer-converse (empty) → 0.1.0.0

raw patch · 9 files changed

+582/−0 lines, 9 filesdep +basedep +freer-conversedep +freer-effectssetup-changed

Dependencies added: base, freer-converse, freer-effects, tasty, tasty-hunit, tasty-quickcheck, text

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for freer-converse++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Robert Hensing++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 Robert Hensing 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ examples/Hello.hs view
@@ -0,0 +1,23 @@+-- | A simple console program with getLine and putLine calls.+module Hello where+import           Control.Monad.Freer+import           Control.Monad.Freer.Internal (send)+import           Data.Monoid+import           Data.Text                    (Text)+import           Prelude                      hiding (getLine)++data Console a where+  GetLine :: Console Text+  PutLine :: Text -> Console ()++putLine :: Member Console r => Text -> Eff r ()+putLine = send . PutLine++getLine :: Member Console r => Eff r Text+getLine = send GetLine++hello :: Member Console r => Eff r ()+hello = do+  putLine "Who are you?"+  name <- getLine+  putLine $ "Hello, " <> name
+ examples/HelloTest.hs view
@@ -0,0 +1,119 @@+-- | This is a basic example use of 'Control.Monad.Freer.Converse' and 'Control.Monad.Freer.Test' to perform ad-hoc unit tests.+--+-- This example is intentionally a bit repetitive, in an attempt to+-- lower the mental overhead. In practice you should probably refactor+-- some low hanging fruit.++{-# LANGUAGE LambdaCase #-}+module Main where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Freer+import           Control.Monad.Freer.Converse+import           Control.Monad.Freer.TestControl+import           Data.Functor.Classes.FreerConverse.Parametric+import           Data.Monoid+import           Data.Text                                     (Text, pack)+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck++import           Hello++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [unitTests, properties]++properties :: TestTree+properties = testGroup "Properties"+  [ testProperty "hello responds with your name" $+    forAll genText $ \name -> Right () == (+      pureTest hello $ do+        greeting <- expect $ \case+          PutLine v -> spy v+          other -> throwUnexpected other++        when (greeting /= ("Who are you?" :: Text)) $+          failure "Wrong greeter"++        stub $ \case+          GetLine -> return (name :: Text)+          other -> throwUnexpected other++        v <- expect $ \case+          PutLine v -> spy v+          other -> throwUnexpected other++        when (v /= ("Hello, " <> name :: Text)) $+          failure "Wrong greeter"++        return $ Right ()+      )+  ]++unitTests :: TestTree+unitTests = testGroup "Unit tests"+  [ testCase "hello asks who you are and responds" $+    hUnitTest hello $ do++        v <- expect $ \case+          PutLine v -> spy v+          other -> throwUnexpected other++        send $ v @?= ("Who are you?" :: Text)++        stub $ \case+          GetLine -> return ("Haskell Curry" :: Text)+          other -> throwUnexpected other++        v <- expect $ \case+          PutLine v -> spy v+          other -> throwUnexpected other++        send $ v @?= ("Hello, Haskell Curry" :: Text)++  , testGroup "Verbose step by step" $+    [ testCase "hello asks who you are" $+      hUnitTest hello $ do++        v <- expect $ \case+          PutLine v -> spy v+          other -> throwUnexpected other++        send $ v @?= ("Who are you?" :: Text)++    , testCase "hello responds with your name" $+      hUnitTest hello $ do++        stub $ \case PutLine _ -> return ()++        stub $ \case+          GetLine -> return ("Haskell Curry" :: Text)+          other -> throwUnexpected other++        v <- expect $ \case+          PutLine v -> spy v+          other -> throwUnexpected other++        send $ v @?= ("Hello, Haskell Curry" :: Text)+    ]+  ]++instance ShowP Console where+  showP GetLine     = "ReadLine"+  showP (PutLine v) = ("PutLine " ++ show v)++genText :: Gen Text+genText = pack <$> arbitrary++hUnitTest :: Eff '[f, TestControl, IO] v+          -> Eff '[Converse f '[TestControl, IO] v, TestControl, IO] ()+          -> IO ()+hUnitTest program script = runM $ runTestControlError $ runConverse program script++pureTest :: Eff '[f, TestControl] v+         -> Eff '[Converse f '[TestControl] v, TestControl] (Either String ())+         -> Either String ()+pureTest program script = run $ runTestControl (return . Left) (return $ Right ()) $ runConverse program script
+ freer-converse.cabal view
@@ -0,0 +1,65 @@+name:                freer-converse+version:             0.1.0.0+synopsis:            Handle effects conversely using monadic conversation+description:         One can think of an effectful program and its effect+                     handler as /two communicating processes/.+                     This package provides the missing pieces that let you+                     write your programs in such a style in+                     @Control.Monad.Freer.Converse@.+                     .+                     One useful area of application is unit testing. The+                     @Control.Monad.Freer.TestControl@ intends to provide what+                     you need to write /ad-hoc test fixtures/.+                     +license:             BSD3+license-file:        LICENSE+author:              Robert Hensing+maintainer:          hackage@roberthensing.nl+copyright:           Robert Hensing+category:            Testing+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10+tested-with:         GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.2++library+  exposed-modules:     Control.Monad.Freer.Converse+                       Control.Monad.Freer.TestControl+                       Data.Functor.Classes.FreerConverse.Parametric+  default-extensions:  RankNTypes, TypeOperators, GADTs, FlexibleContexts, DataKinds, OverloadedStrings+  build-depends:       base >=4.7 && <4.10+                     , freer-effects >=0.3 && <0.4+                     , text+  ghc-options:         -Wall+  hs-source-dirs:      src+  default-language:    Haskell2010++flag reloadable+  description: Include the library by source, so GHCi can reload it when+               running the test suite.+               Decreases iteration time in ghci, but increases the+               'cabal build' time, so it's off by default.+  default: False+  +  +test-suite example-Hello+  type: exitcode-stdio-1.0+  hs-source-dirs: examples+  default-language: Haskell2010+  default-extensions:  RankNTypes, TypeOperators, GADTs, FlexibleContexts, DataKinds, OverloadedStrings+  main-is:             HelloTest.hs+  other-modules:       Hello+  build-depends:       base >=4.7 && <4.10+                     , freer-effects >=0.3 && <0.4+                     , tasty+                     , tasty-hunit+                     , tasty-quickcheck+                     , text+  if flag(reloadable)+    hs-source-dirs:  src examples+  else+    Build-Depends:   freer-converse++source-repository head+  type: git+  location: https://github.com/roberth/freer-converse
+ src/Control/Monad/Freer/Converse.hs view
@@ -0,0 +1,103 @@+-- | This module lets you handle effects using an effectful program using a+-- model of two communicating processes.+--+--  * The 'normal' computation: a computation that uses some effect @f@ and possibly others effects, @r@+--  * The handling computation: a computation that responds to the+--    effects @f@ of the normal computation by means of @Converse f@+--    and is also allowed to use the effects @r@.+--+-- This effect is called @Converse@, because it is meaningful both as a verb and as an adjective.+--+--  * The computations converse — having a one-to-one conversation where @f@ is the language+--  * The handling computation has perform the opposite\/converse of+--    the normal computation: when the normal computation /requests/ a+--    value by means of @f@ and the handler emits a @Converse f@+--    effect, the handler has to /provide/ that value.+--+module Control.Monad.Freer.Converse+  ( -- * Running tests+    runConverse+  , Converse+  , converse+  , peekEvent+  , showNext+  , module Control.Monad.Freer+  ) where+import           Control.Monad.Freer+import           Control.Monad.Freer.Internal+import           Data.Functor.Classes.FreerConverse.Parametric++-- | Handle the effects of another computation, as an effect.+--+-- For example, a handling computation may have type @Eff '[Converse f m v] a@+-- and handles effects for the 'normal' computation @Eff '[f] v@.+--+--+-- /Type parameters:/+--+-- [@f@] The effect that is communicated between the normal computation and the handling computation+-- [@r@] The remaining effects that both computations may use+-- [@v@] The result of the normal computation+-- [@a@] The result of the handling computation+data Converse f r v a where+  Converse+    :: (forall x. f x -> Eff r (Maybe x, a)) -- Maybe handle an effect. When Nothing is returned, the same effect can be handled next time, so this provides a 1-item lookahead. (FIXME: turn into haddocks when supported)+    -> (v -> Eff r a)                        -- Handle the result+    -> Converse f r v a++-- | Look at the next event without handling it+peekEvent :: (forall x. f x -> Eff r a) -> Eff (Converse f r v ': r) (Either v a)+peekEvent peeker = converse (fmap (\a -> (Nothing, Right a)) . peeker)+                            (return . Left)++-- | Show what happens next, examples:+--+--     "Next event: ReadLine"+--+--     "Done with result: 42"+showNext :: (Show v, ShowP f) => Eff (Converse f r v ': r) String+showNext = do+  p <- peekEvent (return . showP)+  return $ case p of+    Right x -> "Next event: " ++ x+    Left v  -> "Done with result: " ++ show v++inj1 :: t v -> Union (t ': r) v+inj1 = inj++-- | Called by the handling computation, to interact with the 'normal' computation. (See module description for definitions)+--+-- This is the most general way of interacting with the normal computation, reflecting the constructor of the 'Converse' type.+--+converse+  :: (forall x. f x -> Eff r (Maybe x, b)) -- ^ Handle an effect emitted by the normal computation. This may produce other effects in @r@. In order to handle the effect, return a @(Just x, <...>)@. The right hand side of the tuple may be used to return a value to be used later on by the handling computation (@b@ also occurs in the return value)+  -> (v -> Eff r b) -- ^ Handle the case where the normal computation has completed and returned a value of type @v@.+  -> Eff (Converse f r v ': r) b -- ^ A computation that should run in the handling computation.+converse f f' = E (inj1 (Converse f f')) (tsingleton return)++-- | Zips together the two communicating computations, the normal computation+-- that uses effect @f@ and the handling computation that uses effect @Converse f@+--+-- The handling computation gets to run effects (the @r@ parameter) first+-- whenever a 'scheduling' choice presents itself.+--+runConverse+  :: Eff (f ': r) v               -- ^ The normal computation+  -> Eff (Converse f r v ': r) b  -- ^ The handling computation+  -> Eff r b                      -- ^ A runnable combined computation+runConverse _subject _script@(Val b) = return b+runConverse subject script@(E x qScript) = case decomp x of+    Left scriptSideEffect -> E  scriptSideEffect+                                (tsingleton (qComp qScript (runConverse subject)))+    Right (Converse onEvent onResult) -> case subject of+      Val subjectResult -> do+        c <- onResult subjectResult+        runConverse subject (qScript `qApp` c)+      E subjectEffect qSubject -> case decomp subjectEffect of+        Left sideEffect -> E sideEffect (tsingleton (qComp qSubject c))+           where c s = runConverse s script+        Right event -> do+          (maybeReply, spy) <- onEvent event+          case maybeReply of+            Just reply -> runConverse (qSubject `qApp` reply) (qScript `qApp` spy)+            Nothing -> runConverse subject (qScript `qApp` spy)
+ src/Control/Monad/Freer/TestControl.hs view
@@ -0,0 +1,173 @@+-- | This module provides functions and a TestControl effect for implmenting+-- unit tests with 'Control.Monad.Freer.Converse'.++module Control.Monad.Freer.TestControl+  ( TestControl+  , runTestControl+  , runTestControlData+  , runTestControlData_+  , runTestControlError+  , TestExitStatus(..)++      -- * Controlling the test+  , fulfilled+  , throwUnexpected+  , throwExpecting+  , failure++      -- * Interacting with the test subject+  , expect+  , collect+  , stub+  , stubs+  , result+  , result_+  , converse++      -- * Arguments to 'expect', 'stubs', etc+  , spy++  ) where++import           Control.Applicative+import           Control.Arrow                                 (first)+import           Control.Monad                                 (join)+import           Control.Monad.Freer.Converse+import           Control.Monad.Freer.Exception+import           Data.Monoid+import           Data.Functor.Classes.FreerConverse.Parametric++-- | An effect for terminating the test when either the test has failed, or the+-- goal of the test has been fulfilled without problems but need not continue+-- the normal flow of execution.+type TestControl = Exc TestExitStatus+-- | Interruption of a test run.+data TestExitStatus = TestFulfilled -- ^ The goal of the test was accomplished and the test need not continue.+                    | TestFailed String -- ^ A problem was detected++-- | The goal of the test has been accomplished. Stops further execution of the+-- test. Results in a successful test result.+fulfilled :: Member TestControl r => Eff r a+fulfilled = throwError TestFulfilled++-- | Handler for 'TestControl' effects. Runs the computation (a test) and+--+--   * calls into the first argument on failure,+--   * calls into the second argument on 'fulfilled' or+--   * returns the value produced by the test (often just '()').+--+-- Note that the @r@ parameter determines what (computational or I/O)+-- effects are required/allowed for running the test. This makes it+-- possible to write pure tests, tests that explore all branches of+-- nondeterministic choices, tests that read from files dynamically,+-- etc.+runTestControl :: (String -> Eff r a) -- ^ On failure+               -> Eff r a             -- ^ On fulfill+               -> Eff (TestControl ': r) a -- ^ The test, with @TestControl@+               -> Eff r a             -- ^ The test, without @TestControl@+runTestControl onFail onFulfill t = runError t >>= \testResult -> case testResult of+  Left (TestFailed s) -> onFail s+  Left TestFulfilled  -> onFulfill+  Right x             -> return x++-- | Runs a test, letting it terminate early, as appropriate.+--+-- Like 'runTestControl' but for those who like to pattern match instead.+runTestControlData :: Eff (TestControl ': r) a -> Eff r (Either String (Maybe a))+runTestControlData a = runTestControl (return . Left) (return (Right Nothing)) (fmap (Right . Just) a)++-- | Runs a test, letting it terminate early, as appropriate.+--+-- Like 'runTestControlData' but will not return a value from the test.+runTestControlData_ :: Eff (TestControl ': r) a -> Eff r (Either String ())+runTestControlData_ a = runTestControl (return . Left) (return (Right ())) (Right () <$ a)++-- | Runs a test, letting it terminate early, as appropriate.+--+-- Throws an error with 'error' on failure.+runTestControlError :: Eff (TestControl ': r) () -> Eff r ()+runTestControlError = runTestControl (error . showString "Test failed: ") (return ())++-- | Terminates the test with error, showing provided reason and next event.+failure :: (Member TestControl r, Show v, ShowP f) => String -- ^ Reason for test failure+  -> Eff (Converse f r v ': r) a+failure reason = do+  nextEvent <- showNext+  throwError $ TestFailed $ reason ++ "\nNext event: " ++ nextEvent++-- | Terminates test as a failure by showing the expectation and the event.+throwExpecting+  :: ( ShowP f+     , Member TestControl r+     )+  => String -- ^ Noun phrase describing expectation+  -> f a -- ^ Unexpected event+  -> Eff r b+throwExpecting expectation v = throwError $ TestFailed $ "Expecting " ++ expectation ++ ", but got " ++ showP v++-- | Throw an unexpected event error+throwUnexpected :: (ShowP f, Member TestControl r) => f a -> Eff r b+throwUnexpected v = throwError $ TestFailed $ "Unexpected effect: " ++ showP v++-- | When an event occurs, provide a value @a@ for the test subject and a value @b@+-- for the test script.+expect+  :: Member TestControl r+  => (forall a. f a -> Eff r (a, b))+  -> Eff (Converse f r v ': r) b+expect f = converse (\x -> first Just <$> f x) (const $ throwError $ TestFailed "Unexpected program termination: effect expected.")++-- | When an event occurs, provide a value to the test subject.+--+-- Like 'expect', but does not return a value to the test script.+stub :: Member TestControl r+  => (forall b. f b -> Eff r b)+  -> Eff (Converse f r v ': r) ()+stub f = expect (fmap (\x -> (x,())) <$> f)++-- | Provide a value to the test subject, if and as long as matching+-- events occur. Matching stops when Nothing is returned from the passed function.+--+-- Returns the number of events that have been matched.+collect :: (forall a. f a -> Eff r (Maybe (a, b))) -> Eff (Converse f r v ': r) [b]+collect f = do+  join $ converse (+            \x -> do+              replyMaybe <- f x+              case replyMaybe of+                Just (reply, spied) -> return (Just reply, (spied :) <$> collect f)+                Nothing -> return (Nothing, (return []))+            ) (const $ return (return []))++-- | Like 'collect', but simpler because it does not return a value to+-- the test script.+stubs+  :: (forall b. f b -> Eff r (Maybe b))+  -> Eff (Converse f r v ': r) ()+stubs f = do+  join $ converse (+            \x -> do+              replyMaybe <- f x+              case replyMaybe of+                Just reply -> return (Just reply, stubs f)+                Nothing    -> return (Nothing, (return ()))+            ) (const $ return (return ()))++-- | Retrieve the result of the program. Fails if an effect of type+-- @f@ is still pending.+result :: (Member TestControl r, ShowP f) => Eff (Converse f r v ': r) v+result = converse throwUnexpected return++-- | Like 'result' but more generic because it does not attempt to+-- show the unexpected effect in the error message.+result_ :: (Member TestControl r) => Eff (Converse f r v ': r) v+result_ = converse (const $ throwError $ TestFailed $+                      "Expected program termination with result, but got an effect instead."+                   )+                   return++++-- | Provide empty response to test subject, pass argument to test script+spy :: (Monad m, Monoid mm) => a -> m (mm, a)+spy a = return (mempty, a)
+ src/Data/Functor/Classes/FreerConverse/Parametric.hs view
@@ -0,0 +1,62 @@+-- | When you have a value of @f a@, but you can not possibly have+-- some constraint on @a@, you often can not use type class instances+-- of @f a@, because they require instances for @a@. This module+-- provides type classes that mirror existing type classes but do not+-- have the constraint on @a@, usually at the cost of functionality.+{-# LANGUAGE CPP #-}+module Data.Functor.Classes.FreerConverse.Parametric+  ( ShowP(..)+  , defaultShowsPrecP+  ) where+import           Control.Applicative (Const)+import           Data.Proxy          (Proxy)++-- | Without a @Show a@ constraint it is impossible to show a value of type+-- @Maybe a@. It is, however, possible to distinguish between the @Just _@ and @Nothing cases.+--+-- This type class provides this functionality. It is similar to @Show1@ in @transformers@' @Data.Functor.Classes@, but without the @Show a@ constraint. Therefore, it can be used on quantified, unconstrained types like @forall a. Maybe a@.+class ShowP f where+  -- | Like 'showsPrec', but without using values of type @a@+  showsPrecP :: Int -> f a -> ShowS+  showsPrecP _ x s = showP x ++ s+  -- | Like 'show', but without using values of type @a@+  showP :: f a -> String+  showP x = showsPrecP 0 x ""++-- | Implements 'showsPrecP' using an instance 'Functor'@ f@ and an instance 'Show'@ a => @'Show'@ (f a)@+--+-- The values of type @a@ will be shown as @_@+defaultShowsPrecP :: (Functor f, Show (f Placeholder)) => Int -> f a -> ShowS+defaultShowsPrecP n x = showsPrec n (fmap (const Placeholder) x)++-- Not exported. For use by defaultShowsPrecP to get the 'right' Show instance to feed into the Show a => Show (f a) instance.+data Placeholder = Placeholder+instance Show Placeholder where+  show _ = "_"++-- | Equal to the Show instance+instance ShowP Proxy where+  showsPrecP = showsPrec+  showP = show++#if MIN_VERSION_base(4,8,0)+-- | Equal to the Show instance+instance Show a => ShowP (Const a) where+  showsPrecP = showsPrec+  showP = show+#endif++instance ShowP Maybe where+  showsPrecP = defaultShowsPrecP++instance ShowP [] where+  showsPrecP = defaultShowsPrecP++instance ShowP IO where+  showP _ = "<IO>"++instance Show a => ShowP (Either a) where+  showsPrecP = defaultShowsPrecP++instance Show a => ShowP ((,) a) where+  showsPrecP = defaultShowsPrecP