Merge branch 'master' into 'master'

Various improvements and fixes.

* Fixed `ifte` and made the `nonDetEffTests` better.
* Fixed `runC` for the `Yield` effect.
* Added a `runM` handler for running an arbitrary monad (if it's the only effect left to handle).
* Added a `modify` function for the State effect.
* Removed the `ProxyState` type wasn't necessary in favor of `Data.Proxy`.
* Made the `Writer` effect work with arbitrary monoids instead of just lists.

See merge request !2
This commit is contained in:
Allele Dev 2016-03-07 12:00:50 +00:00
commit 36fb6d62bc
7 changed files with 95 additions and 22 deletions

View File

@ -1,5 +1,7 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-| {-|
Module : Control.Monad.Freer.Coroutine Module : Control.Monad.Freer.Coroutine
@ -19,7 +21,8 @@ starting point.
module Control.Monad.Freer.Coroutine ( module Control.Monad.Freer.Coroutine (
Yield, Yield,
yield, yield,
Status(..) Status(..),
runC
) where ) where
import Control.Monad.Freer.Internal import Control.Monad.Freer.Internal
@ -40,12 +43,9 @@ yield x f = send (Yield x f)
-- resuming with the value of type b -- resuming with the value of type b
data Status r a b = Done | Continue a (b -> Eff r (Status r a b)) data Status r a b = Done | Continue a (b -> Eff r (Status r a b))
{- FIXME: this does not compile -- | Launch a thread and report its status
-- Launch a thread and report its status runC :: Eff (Yield a b ': r) w -> Eff r (Status r a b)
runC :: Eff (Yield a b ': r) w -> Eff r (Y r a b) runC = handleRelay (\_ -> return Done) handler
runC m = loop m where
where loop :: Monad m => Eff a b -> m (Y r c d) handler :: Yield a b v -> Arr r v (Status r a b) -> Eff r (Status r a b)
loop (Val _) = return Done handler (Yield a k) arr = return $ Continue a (arr . k)
loop (E u u') = handleRelay u loop $
\(Yield x k) -> return (Y x (loop . k))
-}

View File

@ -49,6 +49,7 @@ module Control.Monad.Freer.Internal (
qComp, qComp,
send, send,
run, run,
runM,
handleRelay, handleRelay,
handleRelayS, handleRelayS,
interpose, interpose,
@ -130,6 +131,16 @@ run :: Eff '[] w -> w
run (Val x) = x run (Val x) = x
run _ = error "Internal:run - This (E) should never happen" run _ = error "Internal:run - This (E) should never happen"
-- | Runs a set of Effects. Requires that all effects are consumed,
-- except for a single effect known to be a monad.
-- The value returned is a computation in that monad.
-- This is useful for plugging in traditional transformer stacks.
runM :: Monad m => Eff '[m] w -> m w
runM (Val x) = return x
runM (E u q) = case decomp u of
Right mb -> mb >>= runM . qApp q
Left _ -> error "Internal:runM - This (Left) should never happen"
-- the other case is unreachable since Union [] a cannot be -- the other case is unreachable since Union [] a cannot be
-- constructed. Therefore, run is a total function if its argument -- constructed. Therefore, run is a total function if its argument
-- terminates. -- terminates.

View File

@ -23,13 +23,14 @@ module Control.Monad.Freer.State (
State, State,
get, get,
put, put,
modify,
runState, runState,
ProxyState(..),
transactionState transactionState
) where ) where
import Control.Monad.Freer.Internal import Control.Monad.Freer.Internal
import Data.Proxy
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- State, strict -- -- State, strict --
@ -44,10 +45,14 @@ data State s v where
get :: Member (State s) r => Eff r s get :: Member (State s) r => Eff r s
get = send Get get = send Get
-- | Modify state -- | Store state
put :: Member (State s) r => s -> Eff r () put :: Member (State s) r => s -> Eff r ()
put s = send (Put s) put s = send (Put s)
-- | Modify state
modify :: Member (State s) r => (s -> s) -> Eff r ()
modify f = fmap f get >>= put
-- | Handler for State effects -- | Handler for State effects
runState :: Eff (State s ': r) w -> s -> Eff r (w,s) runState :: Eff (State s ': r) w -> s -> Eff r (w,s)
runState (Val x) s = return (x,s) runState (Val x) s = return (x,s)
@ -57,14 +62,12 @@ runState (E u q) s = case decomp u of
Left u' -> E u' (tsingleton (\x -> runState (qApp q x) s)) Left u' -> E u' (tsingleton (\x -> runState (qApp q x) s))
data ProxyState s = ProxyState
-- | -- |
-- An encapsulated State handler, for transactional semantics -- An encapsulated State handler, for transactional semantics
-- The global state is updated only if the transactionState finished -- The global state is updated only if the transactionState finished
-- successfully -- successfully
transactionState :: forall s r w. Member (State s) r => transactionState :: forall s r w. Member (State s) r =>
ProxyState s -> Eff r w -> Eff r w Proxy s -> Eff r w -> Eff r w
transactionState _ m = do s <- get; loop s m transactionState _ m = do s <- get; loop s m
where where
loop :: s -> Eff r w -> Eff r w loop :: s -> Eff r w -> Eff r w

View File

@ -35,6 +35,6 @@ tell :: Member (Writer o) r => o -> Eff r ()
tell o = send $ Writer o tell o = send $ Writer o
-- | Simple handler for Writer effects -- | Simple handler for Writer effects
runWriter :: Eff (Writer o ': r) a -> Eff r (a,[o]) runWriter :: Monoid o => Eff (Writer o ': r) a -> Eff r (a,o)
runWriter = handleRelay (\x -> return (x,[])) runWriter = handleRelay (\x -> return (x,mempty))
(\ (Writer o) k -> k () >>= \ (x,l) -> return (x,o:l)) (\ (Writer o) k -> k () >>= \ (x,l) -> return (x,o `mappend` l))

View File

@ -6,6 +6,7 @@ import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Test.Tasty.QuickCheck import Test.Tasty.QuickCheck
import Tests.Coroutine
import Tests.Exception import Tests.Exception
import Tests.Fresh import Tests.Fresh
import Tests.NonDetEff import Tests.NonDetEff
@ -13,6 +14,8 @@ import Tests.Reader
import Tests.State import Tests.State
import Tests.StateRW import Tests.StateRW
import qualified Data.List
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Pure Tests -- -- Pure Tests --
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -25,6 +28,23 @@ pureTests = testGroup "Pure Eff tests"
(\x y -> addInEff x y == x + y) (\x y -> addInEff x y == x + y)
] ]
--------------------------------------------------------------------------------
-- Coroutine Tests --
--------------------------------------------------------------------------------
-- | Counts number of consecutive pairs of odd elements at beginning of a list.
countOddDuoPrefix :: [Int] -> Int
countOddDuoPrefix list = count list 0
where
count (i1:i2:is) n = if even i1 && even i2 then n else count is (n+1)
count _ n = n
coroutineTests :: TestTree
coroutineTests = testGroup "Coroutine Eff tests"
[ testProperty "Counting consecutive pairs of odds"
(\list -> runTestCoroutine list == countOddDuoPrefix list)
]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Exception Tests -- -- Exception Tests --
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -58,9 +78,17 @@ freshTests = testGroup "Fresh tests"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Nondeterministic Effect Tests -- -- Nondeterministic Effect Tests --
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- https://wiki.haskell.org/Prime_numbers
primesTo :: Int -> [Int]
primesTo m = sieve [2..m] {- (\\) is set-difference for unordered lists -}
where
sieve (x:xs) = x : sieve (xs Data.List.\\ [x,x+x..m])
sieve [] = []
nonDetEffTests :: TestTree nonDetEffTests :: TestTree
nonDetEffTests = testGroup "NonDetEff tests" nonDetEffTests = testGroup "NonDetEff tests"
[ testCase "[2,3,5] are primes generated by ifte" (testIfte [2..6] @?= [2,3,5]) [ testProperty "Primes in 2..n generated by ifte"
(\n' -> let n = abs n' in testIfte [2..n] == primesTo n)
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -100,9 +128,10 @@ stateTests = testGroup "State tests"
main :: IO () main :: IO ()
main = defaultMain $ testGroup "Tests" main = defaultMain $ testGroup "Tests"
[ pureTests [ pureTests
, coroutineTests
, exceptionTests , exceptionTests
, freshTests , freshTests
-- , nonDetEffTests -- FIXME: failing , nonDetEffTests
, readerTests , readerTests
, stateTests , stateTests
] ]

30
tests/Tests/Coroutine.hs Normal file
View File

@ -0,0 +1,30 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
module Tests.Coroutine (
runTestCoroutine
) where
import Control.Monad
import Control.Monad.Freer
import Control.Monad.Freer.Coroutine
import Control.Monad.Freer.State
runTestCoroutine :: [Int] -> Int
runTestCoroutine list = snd $ run $ runState effTestCoroutine 0
where
testCoroutine :: (Members '[Yield () Int, State Int] r) => Eff r ()
testCoroutine = do
-- yield for two elements and hope they're both odd
b <- (&&)
<$> yield () (even :: Int -> Bool)
<*> yield () (even :: Int -> Bool)
unless b (modify ((+1) :: Int -> Int) >> testCoroutine)
effTestCoroutine = do
status <- runC testCoroutine
handleStatus list status
where
handleStatus _ Done = return ()
handleStatus (i:is) (Continue () k) = k i >>= handleStatus is
handleStatus [] _ = return ()

View File

@ -7,7 +7,7 @@ import Control.Monad.Freer
ifte :: Member NonDetEff r ifte :: Member NonDetEff r
=> Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b
ifte t th el = (t >>= th) <|> el ifte t th el = msplit t >>= maybe el (\(a,m) -> th a <|> (m >>= th))
generatePrimes :: Member NonDetEff r => [Int] -> Eff r Int generatePrimes :: Member NonDetEff r => [Int] -> Eff r Int
generatePrimes xs = do generatePrimes xs = do
@ -16,7 +16,7 @@ generatePrimes xs = do
guard $ d < n && n `mod` d == 0) guard $ d < n && n `mod` d == 0)
(const mzero) (const mzero)
(return n) (return n)
where gen = msum . fmap return $ xs where gen = msum (fmap return xs)
testIfte :: [Int] -> [Int] testIfte :: [Int] -> [Int]
testIfte = run . makeChoiceA . generatePrimes testIfte = run . makeChoiceA . generatePrimes