Merge branch 'master' of gitlab.com:queertypes/freer

src/Control/Monad/Freer/Coroutine.hs

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

src/Control/Monad/Freer/Internal.hs

@@ -49,6 +49,7 @@ module Control.Monad.Freer.Internal (
   qComp,
   send,
   run,
+  runM,
   handleRelay,
   handleRelayS,
   interpose,
@@ -130,6 +131,16 @@ run :: Eff '[] w -> w
 run (Val x) = x
 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
 -- constructed. Therefore, run is a total function if its argument
 -- terminates.

src/Control/Monad/Freer/State.hs

@@ -23,13 +23,14 @@ module Control.Monad.Freer.State (
   State,
   get,
   put,
+  modify,
   runState,
 
-  ProxyState(..),
   transactionState
 ) where
 
 import Control.Monad.Freer.Internal
+import Data.Proxy
 
 --------------------------------------------------------------------------------
                          -- State, strict --
@@ -44,10 +45,14 @@ data State s v where
 get :: Member (State s) r => Eff r s
 get = send Get
 
--- | Modify state
+-- | Store state
 put :: Member (State s) r => s -> Eff r ()
 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
 runState :: Eff (State s ': r) w -> s -> Eff r (w,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))
 
 
-data ProxyState s = ProxyState
-
 -- |
 -- An encapsulated State handler, for transactional semantics
 -- The global state is updated only if the transactionState finished
 -- successfully
 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
  where
    loop :: s -> Eff r w -> Eff r w

src/Control/Monad/Freer/Writer.hs

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

tests/Tests.hs

@@ -6,6 +6,7 @@ import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 
+import Tests.Coroutine
 import Tests.Exception
 import Tests.Fresh
 import Tests.NonDetEff
@@ -13,6 +14,8 @@ import Tests.Reader
 import Tests.State
 import Tests.StateRW
 
+import qualified Data.List
+
 --------------------------------------------------------------------------------
                            -- Pure Tests --
 --------------------------------------------------------------------------------
@@ -25,6 +28,23 @@ pureTests = testGroup "Pure Eff tests"
       (\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 --
 --------------------------------------------------------------------------------
@@ -58,9 +78,17 @@ freshTests = testGroup "Fresh 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 = 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 = defaultMain $ testGroup "Tests"
   [ pureTests
+  , coroutineTests
   , exceptionTests
   , freshTests
-  -- , nonDetEffTests -- FIXME: failing
+  , nonDetEffTests
   , readerTests
   , stateTests
   ]

tests/Tests/Coroutine.hs

@@ -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 ()

tests/Tests/NonDetEff.hs

@@ -7,7 +7,7 @@ import Control.Monad.Freer
 
 ifte :: Member NonDetEff r
      => 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 xs = do
@@ -16,7 +16,7 @@ generatePrimes xs = do
            guard $ d < n && n `mod` d == 0)
        (const mzero)
        (return n)
-  where gen = msum . fmap return $ xs
+  where gen = msum (fmap return xs)
 
 testIfte :: [Int] -> [Int]
 testIfte = run . makeChoiceA . generatePrimes