dunai 0.1.0.0 → 0.1.1.0

raw patch · 25 files changed

+1130/−833 lines, 25 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• dunai.cabal +42/−6
• src/Control/Arrow/Util.hs +6/−8
• src/Control/Monad/Trans/MSF.hs +12/−0
• src/Control/Monad/Trans/MSF/Except.hs +147/−0
• src/Control/Monad/Trans/MSF/GenLift.hs +116/−0
• src/Control/Monad/Trans/MSF/Maybe.hs +117/−0
• src/Control/Monad/Trans/MSF/Reader.hs +72/−0
• src/Control/Monad/Trans/MSF/State.hs +82/−0
• src/Control/Monad/Trans/MSF/Writer.hs +71/−0
• src/Control/Monad/Trans/MStreamF.hs +0/−509
• src/Data/MonadicStreamFunction.hs +37/−154
• src/Data/MonadicStreamFunction/ArrowChoice.hs +4/−3
• src/Data/MonadicStreamFunction/ArrowLoop.hs +5/−6
• src/Data/MonadicStreamFunction/ArrowPlus.hs +5/−4
• src/Data/MonadicStreamFunction/Core.hs +140/−66
• src/Data/MonadicStreamFunction/Instances.hs +3/−4
• src/Data/MonadicStreamFunction/Instances/Num.hs +33/−33
• src/Data/MonadicStreamFunction/Instances/VectorSpace.hs +11/−12
• src/Data/MonadicStreamFunction/Parallel.hs +5/−5
• src/Data/MonadicStreamFunction/ReactHandle.hs +45/−0
• src/Data/MonadicStreamFunction/Util.hs +148/−0
• src/Data/VectorSpace/Fractional.hs +26/−0
• src/Data/VectorSpace/Instances.hs +0/−22
• src/Data/VectorSpace/Specific.hs +2/−1
• src/Data/VectorSpace/Tuples.hs +1/−0

@@ -1,7 +1,35 @@ name:                dunai-version:             0.1.0.0+version:             0.1.1.0 synopsis:            Generalised reactive framework supporting classic, arrowized and monadic FRP.--- description:+description:+  Dunai is DSL for strongly-typed CPS-based composable transformations.+  .+  Dunai is based on a concept of Monadic Stream Functions (MSFs). MSFs are+  transformations defined by a function @unMSF :: MSF m a b -> a -> m (b, MSF m a b)@+  that executes one step of a simulation, and produces an output in a monadic+  context, and a continuation to be used for future steps.+  .+  MSFs are a generalisation of the implementation mechanism used by Yampa,+  Wormholes and other FRP and reactive implementations.+  .+  When combined with different monads, they produce interesting effects. For+  example, when combined with the @Maybe@ monad, they become transformations+  that may stop producing outputs (and continuations). The @Either@ monad gives+  rise to MSFs that end with a result (akin to Tasks in Yampa, and Monadic+  FRP).+  .+  Flattening, that is, going from some structure @MSF (t m) a b@ to @MSF m a b@+  for a specific transformer @t@ often gives rise to known FRP constructs. For+  instance, flattening with @EitherT@ gives rise to switching, and flattening+  with @ListT@ gives rise to parallelism with broadcasting.+  .+  MSFs can be used to implement many FRP variants, including Arrowized FRP,+  Classic FRP, and plain reactive programming. Arrowized and applicative+  syntax are both supported.+  .+  For a very detailed introduction to MSFs, see:+  <http://dl.acm.org/citation.cfm?id=2976010>+  (mirror: <http://www.cs.nott.ac.uk/~psxip1/#FRPRefactored>). license:             BSD3 license-file:        LICENSE author:              Ivan Perez, Manuel Bärenz@@ -23,7 +51,13 @@   manual: True  library-  exposed-modules:   Control.Monad.Trans.MStreamF+  exposed-modules:   Control.Monad.Trans.MSF+                     Control.Monad.Trans.MSF.Except+                     Control.Monad.Trans.MSF.GenLift+                     Control.Monad.Trans.MSF.Maybe+                     Control.Monad.Trans.MSF.Reader+                     Control.Monad.Trans.MSF.State+                     Control.Monad.Trans.MSF.Writer                      Data.MonadicStreamFunction                      Data.MonadicStreamFunction.Core                      Data.MonadicStreamFunction.ArrowChoice@@ -33,10 +67,12 @@                      Data.MonadicStreamFunction.Instances.Num                      Data.MonadicStreamFunction.Instances.VectorSpace                      Data.MonadicStreamFunction.Parallel+                     Data.MonadicStreamFunction.ReactHandle+                     Data.MonadicStreamFunction.Util -		     -- Auxiliary definitions+                     -- Auxiliary definitions                      Data.VectorSpace-                     Data.VectorSpace.Instances+                     Data.VectorSpace.Fractional                      Data.VectorSpace.Tuples                      Data.VectorSpace.Specific @@ -80,4 +116,4 @@  source-repository head   type:     git-  location: git@bitbucket.org:iperezdominguez/dunai.git+  location: git@github.com:ivanperez-keera/dunai.git

@@ -1,10 +1,6 @@ module Control.Arrow.Util where --- Do we even need that module? How much of it exists in the standard library?- import Control.Arrow-import Control.Category (id)-import Prelude hiding (id)  -- Hah! I shall implement this for TimelessSFs and SFs at the same time! constantly :: Arrow a => b -> a c b@@ -22,9 +18,11 @@ (>->) = (>>>) {-# INLINE (>->) #-} +-- import Control.Category (id)+-- import Prelude hiding (id) -(&&&!) :: Arrow a => a b c -> a b () -> a b c-a1 &&&! a2 = (a1 &&& a2) >>> arr fst+-- (&&&!) :: Arrow a => a b c -> a b () -> a b c+-- a1 &&&! a2 = (a1 &&& a2) >>> arr fst -sink :: Arrow a => a b c -> a c () -> a b c-a1 `sink` a2 = a1 >>> (id &&& a2) >>> arr fst+-- sink :: Arrow a => a b c -> a c () -> a b c+-- a1 `sink` a2 = a1 >>> (id &&& a2) >>> arr fst

@@ -0,0 +1,12 @@+{-# LANGUAGE Rank2Types          #-}++module Control.Monad.Trans.MSF ( module X ) where+-- Caution, RWS is not exported since names collide with Reader, State and Writer++import Control.Monad.Trans.MSF.GenLift as X++import Control.Monad.Trans.MSF.Except as X+import Control.Monad.Trans.MSF.Maybe as X+import Control.Monad.Trans.MSF.Reader as X+import Control.Monad.Trans.MSF.State as X+import Control.Monad.Trans.MSF.Writer as X

@@ -0,0 +1,147 @@+{-# LANGUAGE Arrows              #-}+{-# LANGUAGE Rank2Types          #-}+module Control.Monad.Trans.MSF.Except+  ( module Control.Monad.Trans.MSF.Except+  , module Control.Monad.Trans.Except+  ) where++-- External+import Control.Applicative+import qualified Control.Category as Category+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+  hiding (liftCallCC, liftListen, liftPass) -- Avoid conflicting exports++-- Internal+import Control.Monad.Trans.MSF.GenLift+import Data.MonadicStreamFunction+++-- * Throwing exceptions++throwOnCond :: Monad m => (a -> Bool) -> e -> MSF (ExceptT e m) a a+throwOnCond cond e = proc a -> if cond a+    then arrM throwE -< e+    else returnA -< a++throwOnCondM :: Monad m => (a -> m Bool) -> e -> MSF (ExceptT e m) a a+throwOnCondM cond e = proc a -> do+    b <- arrM (lift . cond) -< a+    if b+    then arrM throwE -< e+    else returnA -< a+++throwOn :: Monad m => e -> MSF (ExceptT e m) Bool ()+throwOn e = proc b -> throwOn' -< (b, e)++throwOn' :: Monad m => MSF (ExceptT e m) (Bool, e) ()+throwOn' = proc (b, e) -> if b+    then arrM throwE -< e+    else returnA -< ()++throwMaybe :: Monad m => MSF (ExceptT e m) (Maybe e) (Maybe a)+throwMaybe = mapMaybeS $ arrM throwE++throwS :: Monad m => MSF (ExceptT e m) e a+throwS = arrM throwE++throw :: Monad m => e -> MSF (ExceptT e m) a b+throw = arrM_ . throwE++pass :: Monad m => MSF (ExceptT e m) a a+pass = Category.id++-- * Catching exceptions++{-+catchS' :: Monad m => MSF (ExceptT e m) a b -> (e -> m (b, MSF m a b)) -> MSF m a b+catchS' msf f = MSF $ \a -> (unMSF msf a) f `catchFinal` f+-}+catchS :: Monad m => MSF (ExceptT e m) a b -> (e -> MSF m a b) -> MSF m a b+catchS msf f = MSF $ \a -> do+    cont <- runExceptT $ unMSF msf a+    case cont of+        Left e          -> unMSF (f e) a+        Right (b, msf') -> return (b, msf' `catchS` f)++-- catchFinal :: Monad m => ExceptT e m a -> (e -> m a) -> m a+-- catchFinal action f = do+--     ea <- runExceptT action+--     case ea of+--         Left  e -> f e+--         Right a -> return a++-- Similar to delayed switching. Looses a b in case of exception+untilE :: Monad m => MSF m a b -> MSF m b (Maybe e)+       -> MSF (ExceptT e m) a b+untilE msf msfe = proc a -> do+    b <- liftMSFTrans msf -< a+    me <- liftMSFTrans msfe -< b+    inExceptT -< (ExceptT . return) (maybe (Right b) Left me)++exceptS :: Monad m => MSF (ExceptT e m) a b -> MSF m a (Either e b)+exceptS msf = go+ where+   go = MSF $ \a -> do+          cont <- runExceptT $ unMSF msf a+          case cont of+            Left e          -> return (Left e,  go)+            Right (b, msf') -> return (Right b, exceptS msf')++++inExceptT :: Monad m => MSF (ExceptT e m) (ExceptT e m a) a+inExceptT = arrM id -- extracts value from monadic action++{-+tagged :: MSF (ExceptT e m) a b -> MSF (ExceptT t m) (a, t) b+tagged msf = MSF $ \(a, t) -> ExceptT $ do+  cont <- runExceptT $ unMSF msf a+  case cont of+    Left  e     -> _ return t+    Right bmsf' -> _ return bmsf'+    -}+-- * Monad interface for Exception MSFs++newtype MSFExcept m a b e = MSFExcept { runMSFExcept :: MSF (ExceptT e m) a b }++try :: MSF (ExceptT e m) a b -> MSFExcept m a b e+try = MSFExcept++instance Functor (MSFExcept m a b) where++instance Monad m => Applicative (MSFExcept m a b) where+  pure = MSFExcept . throw++instance Monad m => Monad (MSFExcept m a b) where+  MSFExcept msf >>= f = MSFExcept $ MSF $ \a -> do+    cont <- lift $ runExceptT $ unMSF msf a+    case cont of+      Left e          -> unMSF (runMSFExcept $ f e) a+      Right (b, msf') -> return (b, runMSFExcept $ try msf' >>= f)++data Empty++safely :: Monad m => MSFExcept m a b Empty -> MSF m a b+safely (MSFExcept msf) = safely' msf+  where+    safely' msf = MSF $ \a -> do+      Right (b, msf') <- runExceptT $ unMSF msf a+      return (b, safely' msf')++safe :: Monad m => MSF m a b -> MSFExcept m a b e+safe = try . liftMSFTrans++once :: Monad m => (a -> m b) -> MSFExcept m a c ()+once f = MSFExcept $ arrM (lift . f) >>> throw ()++once_ :: Monad m => m b -> MSFExcept m c d ()+once_ = once . const++tagged :: Monad m => MSF (ExceptT e1 m) a b -> MSF (ExceptT e2 m) (a, e2) b+tagged msf = MSF $ \(a, e2) -> ExceptT $ do+  cont <- runExceptT $ unMSF msf a+  case cont of+    Left e1 -> return $ Left e2+    Right (b, msf') -> return $ Right (b, tagged msf')

@@ -0,0 +1,116 @@+{-# LANGUAGE Rank2Types          #-}+module Control.Monad.Trans.MSF.GenLift where++import Control.Applicative+import Data.MonadicStreamFunction++-- * Attempt at writing a more generic MSF lifting combinator.  This is+-- here only to make it easier to find, in a perfect world we'd move+-- this to a different module/branch, or at least to the bottom of the+-- file.+--+-- TODO: does this also work well with the state and the writer monads?+--+-- Even if this code works, it's difficult to understand the concept.+--+-- It is also unclear how much it helps. Ideally, the auxiliary function+-- should operate only on monadic values, not monadic stream functions.+-- That way we could separate concepts: namely the recursion pattern+-- from the monadic lifting/unlifting/sequencing.+--+-- Maybe if we split f in several functions, one that does some sort of+-- a -> a1 transformation, another that does some b1 -> b+-- transformation, with the monads and continuations somewhere, it'll+-- make more sense.+--+-- Based on this lifting function we can also defined all the other+-- liftings we have in Core:+--+-- liftMSFPurer' :: (Monad m1, Monad m)+--                    => (m1 (b, MSF m1 a b) -> m (b, MSF m1 a b))+--                    -> MSF m1 a b+--                    -> MSF m  a b+-- liftMSFPurer' f = lifterS (\g a -> f $ g a)+--+-- More liftings:+-- liftMSFTrans = liftMSFPurer lift+-- liftMSFBase  = liftMSFPurer liftBase+--+-- And a strict version of liftMSFPurer:+-- liftMStreamPurer' f = liftMSFPurer (f >=> whnfVal)+--   where whnfVal p@(b,_) = b `seq` return p+--+-- MB: I'm not sure we're gaining much insight by rewriting all the lifting+-- functions like that.+-- IP: I said the same thing above ("It is also unclear how much it+-- helps."). It's work in progress.+--+-- MB: The type (a1 -> m1 (b1, MSF m1 a1 b1)) is just MSF m1 a1 b1.+-- IP: I'm looking for a lifting pattern in terms of m m1 a b a1 and b1. By+-- exposing the function, I'm hoping to *eventually see* the pattern. If I hide+-- it in the MSF, then it'll always remain hidden.+lifterS :: (Monad m, Monad m1)+        => ((a1 -> m1 (b1, MSF m1 a1 b1)) -> a -> m (b, MSF m1 a1 b1))+        -> MSF m1 a1 b1+        -> MSF m  a  b+lifterS f msf = MSF $ \a -> do+  (b, msf') <- f (unMSF msf) a+  return (b, lifterS f msf')++-- ** Another wrapper idea+transS :: (Monad m1, Monad m2)+       => (a2 -> m1 a1)+       -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, c))+       -> MSF m1 a1 b1 -> MSF m2 a2 b2+transS transformInput transformOutput msf = MSF $ \a2 -> do+    (b2, msf') <- transformOutput a2 $ unMSF msf =<< transformInput a2+    return (b2, transS transformInput transformOutput msf')++-- ** A more general lifting mechanism that enables recovery.+transG1 :: (Monad m1, Functor m2, Monad m2)+        => (a2 -> m1 a1)+        -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, c))+        -> MSF m1 a1 b1 -> MSF m2 a2 b2+transG1 transformInput transformOutput msf =+  transG transformInput transformOutput' msf+    where+      -- transformOutput' :: forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c)+      transformOutput' a b = second Just <$> transformOutput a b++transG :: (Monad m1, Monad m2)+       => (a2 -> m1 a1)+       -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c))+       -> MSF m1 a1 b1 -> MSF m2 a2 b2+transG transformInput transformOutput msf = go+  where go = MSF $ \a2 -> do+               (b2, msf') <- transformOutput a2 $ unMSF msf =<< transformInput a2+               case msf' of+                 Just msf'' -> return (b2, transG transformInput transformOutput msf'')+                 Nothing    -> return (b2, go)++-- transGN :: (Monad m1, Monad m2)+--         => (a2 -> m1 a1)+--         -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, [c]))+--         -> MSF m1 a1 b1 -> MSF m2 a2 b2+-- transGN transformInput transformOutput msf = go+--   where go = MSF $ \a2 -> do+--                (b2, msf') <- transformOutput a2 $ unMSF msf =<< transformInput a2+--                case msf' of+--                  []      -> return (b2, go)+--                  [msf''] -> return (b2, transGN transformInput transformOutput msf'')+--                  ms      ->++-- ** Wrapping/unwrapping+--+-- IP: Alternative formulation (typechecks just fine):+--+-- FIXME: The foralls may get in the way. They may not be necessary.  MB+-- raised the issue already for similar code in Core.+--+type Wrapper   m1 m2 t1 t2 = forall a b . (t1 a -> m2 b     ) -> (a    -> m1 (t2 b))+type Unwrapper m1 m2 t1 t2 = forall a b . (a    -> m1 (t2 b)) -> (t1 a -> m2 b     )+--+-- Helper type, for when we need some identity * -> * type constructor that+-- does not get in the way.+--+type Id a = a

@@ -0,0 +1,117 @@+{-# LANGUAGE Arrows              #-}+{-# LANGUAGE Rank2Types          #-}+module Control.Monad.Trans.MSF.Maybe+  ( module Control.Monad.Trans.MSF.Maybe+  , module Control.Monad.Trans.Maybe+  ) where++-- External+import Control.Monad.Trans.Maybe+  hiding (liftCallCC, liftCatch, liftListen, liftPass) -- Avoid conflicting exports++-- Internal+import Control.Monad.Trans.MSF.GenLift+import Data.MonadicStreamFunction+++runMaybeS'' :: Monad m => MSF (MaybeT m) a b -> MSF m a (Maybe b)+runMaybeS'' = transG transformInput transformOutput+  where+    transformInput       = return+    transformOutput _ m1 = do r <- runMaybeT m1+                              case r of+                                Nothing     -> return (Nothing, Nothing)+                                Just (b, c) -> return (Just b,  Just c)+++-- * Throwing Nothing as an exception ("exiting")++exit :: Monad m => MSF (MaybeT m) a b+exit = MSF $ const $ MaybeT $ return Nothing++exitWhen :: Monad m => (a -> Bool) -> MSF (MaybeT m) a a+exitWhen condition = go where+    go = MSF $ \a -> MaybeT $+        if condition a+        then return Nothing+        else return $ Just (a, go)++exitIf :: Monad m => MSF (MaybeT m) Bool ()+exitIf = MSF $ \b -> MaybeT $ return $ if b then Nothing else Just ((), exitIf)++-- Just a is passed along, Nothing causes the whole MSF to exit+maybeExit :: Monad m => MSF (MaybeT m) (Maybe a) a+maybeExit = MSF $ MaybeT . return . fmap (\x -> (x, maybeExit))++inMaybeT :: Monad m => MSF (MaybeT m) (Maybe a) a+inMaybeT = arrM $ MaybeT . return++-- * Catching Maybe exceptions++untilMaybe :: Monad m => MSF m a b -> MSF m b Bool -> MSF (MaybeT m) a b+untilMaybe msf cond = proc a -> do+  b <- liftMSFTrans msf -< a+  c <- liftMSFTrans cond -< b+  inMaybeT -< if c then Nothing else Just b++catchMaybe :: Monad m => MSF (MaybeT m) a b -> MSF m a b -> MSF m a b+catchMaybe msf1 msf2 = MSF $ \a -> do+  cont <- runMaybeT $ unMSF msf1 a+  case cont of+    Just (b, msf1') -> return (b, msf1' `catchMaybe` msf2)+    Nothing         -> unMSF msf2 a+++++-- * Running MaybeT+runMaybeS :: Monad m => MSF (MaybeT m) a b -> MSF m a (Maybe b)+runMaybeS msf = go+  where+    go = MSF $ \a -> do+           bmsf <- runMaybeT $ unMSF msf a+           case bmsf of+             Just (b, msf') -> return (Just b, runMaybeS msf')+             Nothing        -> return (Nothing, go)+++-- mapMaybeS msf == runMaybeS (inMaybeT >>> lift mapMaybeS)++{-+maybeS :: Monad m => MSF m a (Maybe b) -> MSF (MaybeT m) a b+maybeS msf = MSF $ \a -> MaybeT $ return $ unMSF msf a+-- maybeS msf == lift msf >>> inMaybeT+-}++{-+-- MB: Doesn't typecheck, I don't know why+--+-- IP: Because of the forall in runTS.+--+-- From the action runMaybeT msfaction it does not know that+-- the second element of the pair in 'thing' will be a continuation.+--+-- The first branch of the case works because you are passing the+-- msf' as is.+--+-- In the second one, you are passing msf, which has the specific type+-- MSF (MaybeT m) a b.+--+-- Two things you can try (to help you see that this is indeed why GHC is+-- complaining):+--   - Make the second continuation undefined. Then it typechecks.+--   - Use ScopedTypeVariables and a let binding to type msf' in the+--   first branch of the case selector. It'll complain about the type+--   of msf' if you say it's forcibly a MSF (MaybeT m) a b.+--++runMaybeS'' :: Monad m => MSF (MaybeT m) a b -> MSF m a (Maybe b)+runMaybeS'' msf = transS transformInput transformOutput msf+  where+    transformInput  = return+    transformOutput _ msfaction = do+      thing <- runMaybeT msfaction+      case thing of+        Just (b, msf') -> return (Just b, msf')+        Nothing        -> return (Nothing, msf)+-}

@@ -0,0 +1,72 @@+{-# LANGUAGE Rank2Types          #-}+module Control.Monad.Trans.MSF.Reader+  ( module Control.Monad.Trans.MSF.Reader+  , module Control.Monad.Trans.Reader+  ) where++-- External+import Control.Monad.Trans.Reader+  hiding (liftCallCC, liftCatch) -- Avoid conflicting exports+++-- Internal+import Control.Monad.Trans.MSF.GenLift+import Data.MonadicStreamFunction+++-- * Reader monad+readerS :: Monad m => MSF m (s, a) b -> MSF (ReaderT s m) a b+readerS msf = MSF $ \a -> do+  (b, msf') <- ReaderT $ \s -> unMSF msf (s, a)+  return (b, readerS msf')++runReaderS :: Monad m => MSF (ReaderT s m) a b -> MSF m (s, a) b+runReaderS msf = MSF $ \(s,a) -> do+  (b, msf') <- runReaderT (unMSF msf a) s+  return (b, runReaderS msf')++-- ** Alternative wrapping/unwrapping MSF combinators using generic lifting++runReaderS' :: Monad m => MSF (ReaderT s m) a b -> MSF m (s, a) b+runReaderS' = lifterS unwrapReaderT+++type ReaderWrapper   s m = Wrapper   (ReaderT s m) m ((,) s) Id+type ReaderUnwrapper s m = Unwrapper (ReaderT s m) m ((,) s) Id+-- and use the types:+-- wrapReaderT   :: ReaderWrapper s m+-- unwrapReaderT :: ReaderUnwrapper s m++wrapReaderT :: ((s, a) -> m b) -> a -> ReaderT s m b+wrapReaderT g i = ReaderT $ g . flip (,) i++unwrapReaderT :: (a -> ReaderT s m b) -> (s, a) -> m b+unwrapReaderT g i = uncurry (flip runReaderT) $ second g i++readerS' :: Monad m => MSF m (s, a) b -> MSF (ReaderT s m) a b+readerS' = lifterS wrapReaderT++runReaderS'' :: Monad m => MSF (ReaderT s m) a b -> MSF m (s, a) b+runReaderS'' = transG transformInput transformOutput+  where+    transformInput  (_, a) = return a+    transformOutput (s, _) m1 = do (r, c) <- runReaderT m1 s+                                   return (r, Just c)++{-+readerS'' :: Monad m => MSF m (s, a) b -> MSF (ReaderT s m) a b+readerS'' = transS transformInput transformOutput+  where+    transformInput :: a -> m (s, a)+    transformInput a = (,) <$> asks <*> pure a+    transformOutput _ = lift+-}++-- ** Auxiliary functions related to ReaderT++-- IP: Is runReaderS_ msf s = arr (\a -> (s,a)) >>> runReaderS msf ?+-- MB: Yes, but possibly more efficient.+runReaderS_ :: Monad m => MSF (ReaderT s m) a b -> s -> MSF m a b+runReaderS_ msf s = MSF $ \a -> do+  (b, msf') <- runReaderT (unMSF msf a) s+  return (b, runReaderS_ msf' s)

@@ -0,0 +1,82 @@+{-# LANGUAGE Rank2Types          #-}+module Control.Monad.Trans.MSF.State+  ( module Control.Monad.Trans.MSF.State+  , module Control.Monad.Trans.State.Strict+  ) where++-- External+import Control.Applicative+import Control.Monad.Trans.State.Strict+  hiding (liftCallCC, liftCatch, liftListen, liftPass) -- Avoid conflicting exports++-- Internal+import Control.Monad.Trans.MSF.GenLift+import Data.MonadicStreamFunction++++-- * Running and wrapping+stateS :: Monad m => MSF m (s, a) (s, b) -> MSF (StateT s m) a b+stateS msf = MSF $ \a -> StateT $ \s -> do+    ((s', b), msf') <- unMSF msf (s, a)+    return ((b, stateS msf'), s')++runStateS :: Monad m => MSF (StateT s m) a b -> MSF m (s, a) (s, b)+runStateS msf = MSF $ \(s, a) -> do+    ((b, msf'), s') <- runStateT (unMSF msf a) s+    return ((s', b), runStateS msf')++-- * Auxiliary functions++-- IP: Is runStateS_ msf s = feedback s $ runStateS msf >>> arr (\(s,b) -> ((s,b), s)) ?+runStateS_ :: Monad m => MSF (StateT s m) a b -> s -> MSF m a (s, b)+runStateS_ msf s = MSF $ \a -> do+    ((b, msf'), s') <- runStateT (unMSF msf a) s+    return ((s', b), runStateS_ msf' s')++-- IP: Is runStateS__ msf s = feedback s $ runStateS msf >>> arr (\(s,b) -> (b, s)) ?+runStateS__ :: Monad m => MSF (StateT s m) a b -> s -> MSF m a b+runStateS__ msf s = MSF $ \a -> do+    ((b, msf'), s') <- runStateT (unMSF msf a) s+    return (b, runStateS__ msf' s')+++runStateS''' :: (Functor m, Monad m) => MSF (StateT s m) a b -> MSF m (s, a) (s, b)+runStateS''' = transG transformInput transformOutput+  where+    transformInput  (_, a)           = return a+    transformOutput (s, _) msfaction = sym <$> runStateT msfaction s+    sym ((b, msf), s)                = ((s, b), Just msf)++-- * Alternative running/wrapping MSF combinators using generic lifting+--+-- IPerez: TODO: Is this exactly the same as stateS?+stateS' :: (Functor m, Monad m) => MSF m (s, a) (s, b) -> MSF (StateT s m) a b+stateS' = lifterS (\g i -> StateT ((resort <$>) . g . flip (,) i))+ where resort ((s, b), ct) = ((b, ct), s)++-- stateS' :: Monad m => MSF m (s, a) (s, b) -> MSF (StateT s m) a b+-- stateS' = lifterS $ \f a -> StateT $ \s -> do+--   ((s', b), msf') <- f (s, a)+--   return ((b, msf'), s')++runStateS' :: (Functor m, Monad m) => MSF (StateT s m) a b -> MSF m (s, a) (s, b)+runStateS' = lifterS (\g i -> resort <$> uncurry (flip runStateT) (second g i))+ where resort ((b, msf), s) = ((s, b), msf)+++runStateS'' :: (Functor m, Monad m) => MSF (StateT s m) a b -> MSF m (s, a) (s, b)+runStateS'' = transS transformInput transformOutput+  where+    transformInput  (_, a)           = return a+    transformOutput (s, _) msfaction = sym <$> runStateT msfaction s+    sym ((b, msf), s)                = ((s, b), msf)++{-+stateS'' :: Monad m => MSF m (s, a) (s, b) -> MSF (StateT s m) a b+stateS'' = transS transformInput transformOutput+  where+    transformInput  (_, a) = return a+    transformOutput (s, _) = do+        put s+-}

@@ -0,0 +1,71 @@+module Control.Monad.Trans.MSF.Writer+  ( module Control.Monad.Trans.MSF.Writer+  , module Control.Monad.Trans.Writer.Strict+  ) where++-- External+import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer.Strict+  hiding (liftCallCC, liftCatch, pass) -- Avoid conflicting exports+import Data.Monoid++-- Internal+import Control.Monad.Trans.MSF.GenLift+import Data.MonadicStreamFunction++-- * Writer monad+writerS :: (Monad m, Monoid s) => MSF m a (s, b) -> MSF (WriterT s m) a b+writerS msf = MSF $ \a -> do+    ((s, b), msf') <- lift $ unMSF msf a+    tell s+    return (b, writerS msf')++runWriterS :: Monad m => MSF (WriterT s m) a b -> MSF m a (s, b)+runWriterS msf = MSF $ \a -> do+    ((b, msf'), s') <- runWriterT $ unMSF msf a+    return ((s', b), runWriterS msf')+++-- * Alternative running/wrapping MSF combinators using generic lifting++writerS' :: (Monad m, Monoid s) => MSF m a (s, b) -> MSF (WriterT s m) a b+writerS' = lifterS wrapMSFWriterT++runWriterS' :: (Monoid s, Functor m, Monad m) => MSF (WriterT s m) a b -> MSF m a (s, b)+runWriterS' = lifterS unwrapMSFWriterT++writerS'' :: (Monad m, Monoid w) => MSF m a (w, b) -> MSF (WriterT w m) a b+writerS'' = transS transformInput transformOutput+  where+    transformInput = return+    transformOutput _ msfaction = do+        ((w, b), msf') <- lift msfaction+        tell w+        return (b, msf')++runWriterS'' :: (Monoid s, Functor m, Monad m) => MSF (WriterT s m) a b -> MSF m a (s, b)+runWriterS'' = transS transformInput transformOutput+  where+    transformInput              = return+    transformOutput _ msfaction = sym <$> runWriterT msfaction+    sym ((b, msf), s)           = ((s, b), msf)++-- ** Wrapping/unwrapping functions+--+-- TODO: These are *almost*-MSF-agnostic wrapping/unwrapping functions.+-- The continuations (and therefore the stream functions) are still+-- there, but now we know nothing about them, not even their type.+-- Monadic actions carry an extra value, of some polymorphic type ct,+-- which is only necessary to extract the output and the context.+--+-- wrapMSFWriterT :: (Monad m, Functor m) => (a -> WriterT s m (b, ct)) -> a -> m ((s, b), ct)+wrapMSFWriterT :: (Monoid s, Monad m) => (a -> m ((s, b), ct)) -> a -> WriterT s m (b, ct)+wrapMSFWriterT g i = do+  ((s, b), msf) <- lift $ g i+  tell s+  return (b, msf)++unwrapMSFWriterT :: (Monad m, Functor m) => (a -> WriterT s m (b, ct)) -> a -> m ((s, b), ct)+unwrapMSFWriterT g i = resort <$> runWriterT (g i)+  where resort ((b, msf), s) = ((s, b), msf)

@@ -1,509 +0,0 @@-{-# LANGUAGE Arrows              #-}-{-# LANGUAGE Rank2Types          #-}--module Control.Monad.Trans.MStreamF where--import Data.Monoid-import Control.Applicative-import Control.Arrow-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.List-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Reader-import Control.Monad.Trans.RWS.Strict hiding (tell, asks, put)-import Control.Monad.Trans.Writer.Strict--import Data.MonadicStreamFunction---- * Attempt at writing a more generic MSF lifting combinator.  This is--- here only to make it easier to find, in a perfect world we'd move--- this to a different module/branch, or at least to the bottom of the--- file.------ TODO: does this also work well with the state and the writer monads?------ Even if this code works, it's difficult to understand the concept.------ It is also unclear how much it helps. Ideally, the auxiliary function--- should operate only on monadic values, not monadic stream functions.--- That way we could separate concepts: namely the recursion pattern--- from the monadic lifting/unlifting/sequencing.------ Maybe if we split f in several functions, one that does some sort of--- a -> a1 transformation, another that does some b1 -> b--- transformation, with the monads and continuations somewhere, it'll--- make more sense.------ Based on this lifting function we can also defined all the other--- liftings we have in Core:------ liftMStreamFPurer' :: (Monad m1, Monad m)---                    => (m1 (b, MStreamF m1 a b) -> m (b, MStreamF m1 a b))---                    -> MStreamF m1 a b---                    -> MStreamF m  a b--- liftMStreamFPurer' f = lifterS (\g a -> f $ g a)------ More liftings:--- liftMStreamFTrans = liftMStreamFPurer lift--- liftMStreamFBase  = liftMStreamFPurer liftBase------ And a strict version of liftMStreamFPurer:--- liftMStreamPurer' f = liftMStreamFPurer (f >=> whnfVal)---   where whnfVal p@(b,_) = b `seq` return p------ MB: I'm not sure we're gaining much insight by rewriting all the lifting--- functions like that.--- IP: I said the same thing above ("It is also unclear how much it--- helps."). It's work in progress.------ MB: The type (a1 -> m1 (b1, MStreamF m1 a1 b1)) is just MStreamF m1 a1 b1.--- IP: I'm looking for a lifting pattern in terms of m m1 a b a1 and b1. By--- exposing the function, I'm hoping to *eventually see* the pattern. If I hide--- it in the MStreamF, then it'll always remain hidden.-lifterS :: (Monad m, Monad m1)-        => ((a1 -> m1 (b1, MStreamF m1 a1 b1)) -> a -> m (b, MStreamF m1 a1 b1))-        -> MStreamF m1 a1 b1-        -> MStreamF m  a  b-lifterS f msf = MStreamF $ \a -> do-  (b, msf') <- f (unMStreamF msf) a-  return (b, lifterS f msf')---- ** Another wrapper idea-transS :: (Monad m1, Monad m2)-       => (a2 -> m1 a1)-       -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, c))-       -> MStreamF m1 a1 b1 -> MStreamF m2 a2 b2-transS transformInput transformOutput msf = MStreamF $ \a2 -> do-    (b2, msf') <- transformOutput a2 $ unMStreamF msf =<< transformInput a2-    return (b2, transS transformInput transformOutput msf')---- ** A more general lifting mechanism that enables recovery.-transG1 :: (Monad m1, Functor m2, Monad m2)-        => (a2 -> m1 a1)-        -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, c))-        -> MStreamF m1 a1 b1 -> MStreamF m2 a2 b2-transG1 transformInput transformOutput msf =-  transG transformInput transformOutput' msf-    where-      -- transformOutput' :: forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c)-      transformOutput' a b = second Just <$> transformOutput a b--transG :: (Monad m1, Monad m2)-       => (a2 -> m1 a1)-       -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c))-       -> MStreamF m1 a1 b1 -> MStreamF m2 a2 b2-transG transformInput transformOutput msf = go-  where go = MStreamF $ \a2 -> do-               (b2, msf') <- transformOutput a2 $ unMStreamF msf =<< transformInput a2-               case msf' of-                 Just msf'' -> return (b2, transG transformInput transformOutput msf'')-                 Nothing    -> return (b2, go)---- transGN :: (Monad m1, Monad m2)---         => (a2 -> m1 a1)---         -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, [c]))---         -> MStreamF m1 a1 b1 -> MStreamF m2 a2 b2--- transGN transformInput transformOutput msf = go---   where go = MStreamF $ \a2 -> do---                (b2, msf') <- transformOutput a2 $ unMStreamF msf =<< transformInput a2---                case msf' of---                  []      -> return (b2, go)---                  [msf''] -> return (b2, transGN transformInput transformOutput msf'')---                  ms      ->---- ** Alternative Reader wrapping/unwrapping MSF combinators-readerS' :: Monad m => MStreamF m (s, a) b -> MStreamF (ReaderT s m) a b-readerS' = lifterS wrapReaderT--runReaderS'' :: Monad m => MStreamF (ReaderT s m) a b -> MStreamF m (s, a) b-runReaderS'' = transG transformInput transformOutput-  where-    transformInput  (_, a) = return a-    transformOutput (s, _) m1 = do (r, c) <- runReaderT m1 s-                                   return (r, Just c)---runStateS''' :: (Functor m, Monad m) => MStreamF (StateT s m) a b -> MStreamF m (s, a) (s, b)-runStateS''' = transG transformInput transformOutput-  where-    transformInput  (_, a)           = return a-    transformOutput (s, _) msfaction = sym <$> runStateT msfaction s-    sym ((b, msf), s)                = ((s, b), Just msf)--runMaybeS'' :: Monad m => MStreamF (MaybeT m) a b -> MStreamF m a (Maybe b)-runMaybeS'' = transG transformInput transformOutput-  where-    transformInput       = return-    transformOutput _ m1 = do r <- runMaybeT m1-                              case r of-                                Nothing     -> return (Nothing, Nothing)-                                Just (b, c) -> return (Just b,  Just c)--{--readerS'' :: Monad m => MStreamF m (s, a) b -> MStreamF (ReaderT s m) a b-readerS'' = transS transformInput transformOutput-  where-    transformInput :: a -> m (s, a)-    transformInput a = (,) <$> asks <*> pure a-    transformOutput _ = lift--}--runReaderS' :: Monad m => MStreamF (ReaderT s m) a b -> MStreamF m (s, a) b-runReaderS' = lifterS unwrapReaderT---- *** Wrapping/unwrapping functions------ IP: Alternative formulation (typechecks just fine):------ FIXME: The foralls may get in the way. They may not be necessary.  MB--- raised the issue already for similar code in Core.----type Wrapper   m1 m2 t1 t2 = forall a b . (t1 a -> m2 b     ) -> (a    -> m1 (t2 b))-type Unwrapper m1 m2 t1 t2 = forall a b . (a    -> m1 (t2 b)) -> (t1 a -> m2 b     )------ Helper type, for when we need some identity * -> * type constructor that--- does not get in the way.----type Id a = a------ And for the Reader, we can now define-type ReaderWrapper   s m = Wrapper   (ReaderT s m) m ((,) s) Id-type ReaderUnwrapper s m = Unwrapper (ReaderT s m) m ((,) s) Id--- and use the types:--- wrapReaderT   :: ReaderWrapper s m--- unwrapReaderT :: ReaderUnwrapper s m--wrapReaderT :: ((s, a) -> m b) -> a -> ReaderT s m b-wrapReaderT g i = ReaderT $ g . flip (,) i--unwrapReaderT :: (a -> ReaderT s m b) -> (s, a) -> m b-unwrapReaderT g i = uncurry (flip runReaderT) $ second g i---- ** Alternative State wrapping/unwrapping MSF combinators------ IPerez: TODO: Is this exactly the same as stateS?-stateS' :: (Functor m, Monad m) => MStreamF m (s, a) (s, b) -> MStreamF (StateT s m) a b-stateS' = lifterS (\g i -> StateT ((resort <$>) . (g . flip (,) i)))- where resort ((s, b), ct) = ((b, ct), s)---- stateS' :: Monad m => MStreamF m (s, a) (s, b) -> MStreamF (StateT s m) a b--- stateS' = lifterS $ \f a -> StateT $ \s -> do---   ((s', b), msf') <- f (s, a)---   return ((b, msf'), s')--runStateS' :: (Functor m, Monad m) => MStreamF (StateT s m) a b -> MStreamF m (s, a) (s, b)-runStateS' = lifterS (\g i -> resort <$> uncurry (flip runStateT) (second g i))- where resort ((b, msf), s) = ((s, b), msf)---runStateS'' :: (Functor m, Monad m) => MStreamF (StateT s m) a b -> MStreamF m (s, a) (s, b)-runStateS'' = transS transformInput transformOutput-  where-    transformInput  (_, a)           = return a-    transformOutput (s, _) msfaction = sym <$> runStateT msfaction s-    sym ((b, msf), s)                = ((s, b), msf)--{--stateS'' :: Monad m => MStreamF m (s, a) (s, b) -> MStreamF (StateT s m) a b-stateS'' = transS transformInput transformOutput-  where-    transformInput  (_, a) = return a-    transformOutput (s, _) = do-        put s--}--- ** Alternative Writer wrapping/unwrapping MSF combinators-----writerS' :: (Monad m, Monoid s) => MStreamF m a (s, b) -> MStreamF (WriterT s m) a b-writerS' = lifterS wrapMSFWriterT--runWriterS' :: (Monoid s, Functor m, Monad m) => MStreamF (WriterT s m) a b -> MStreamF m a (s, b)-runWriterS' = lifterS unwrapMSFWriterT--writerS'' :: (Monad m, Monoid w) => MStreamF m a (w, b) -> MStreamF (WriterT w m) a b-writerS'' = transS transformInput transformOutput-  where-    transformInput = return-    transformOutput _ msfaction = do-        ((w, b), msf') <- lift msfaction-        tell w-        return (b, msf')--runWriterS'' :: (Monoid s, Functor m, Monad m) => MStreamF (WriterT s m) a b -> MStreamF m a (s, b)-runWriterS'' = transS transformInput transformOutput-  where-    transformInput              = return-    transformOutput _ msfaction = sym <$> runWriterT msfaction-    sym ((b, msf), s)           = ((s, b), msf)---- *** Wrapping/unwrapping functions------ TODO: These are *almost*-MSF-agnostic wrapping/unwrapping functions.--- The continuations (and therefore the stream functions) are still--- there, but now we know nothing about them, not even their type.--- Monadic actions carry an extra value, of some polymorphic type ct,--- which is only necessary to extract the output and the context.------ wrapMSFWriterT :: (Monad m, Functor m) => (a -> WriterT s m (b, ct)) -> a -> m ((s, b), ct)-wrapMSFWriterT :: (Monoid s, Monad m) => (a -> m ((s, b), ct)) -> a -> WriterT s m (b, ct)-wrapMSFWriterT g i = do-  ((s, b), msf) <- lift $ g i-  tell s-  return (b, msf)--unwrapMSFWriterT :: (Monad m, Functor m) => (a -> WriterT s m (b, ct)) -> a -> m ((s, b), ct)-unwrapMSFWriterT g i = resort <$> runWriterT (g i)-  where resort ((b, msf), s) = ((s, b), msf)---- * Reader monad-readerS :: Monad m => MStreamF m (s, a) b -> MStreamF (ReaderT s m) a b-readerS msf = MStreamF $ \a -> do-  (b, msf') <- ReaderT $ \s -> unMStreamF msf (s, a)-  return (b, readerS msf')--runReaderS :: Monad m => MStreamF (ReaderT s m) a b -> MStreamF m (s, a) b-runReaderS msf = MStreamF $ \(s,a) -> do-  (b, msf') <- runReaderT (unMStreamF msf a) s-  return (b, runReaderS msf')---- ** Auxiliary functions related to ReaderT---- IP: Is runReaderS_ msf s = arr (\a -> (s,a)) >>> runReaderS msf ?--- MB: Yes, but possibly more efficient.-runReaderS_ :: Monad m => MStreamF (ReaderT s m) a b -> s -> MStreamF m a b-runReaderS_ msf s = MStreamF $ \a -> do-    (b, msf') <- runReaderT (unMStreamF msf a) s-    return (b, runReaderS_ msf' s)---- * State monad-stateS :: Monad m => MStreamF m (s, a) (s, b) -> MStreamF (StateT s m) a b-stateS msf = MStreamF $ \a -> StateT $ \s -> do-    ((s', b), msf') <- unMStreamF msf (s, a)-    return ((b, stateS msf'), s')--runStateS :: Monad m => MStreamF (StateT s m) a b -> MStreamF m (s, a) (s, b)-runStateS msf = MStreamF $ \(s, a) -> do-    ((b, msf'), s') <- runStateT (unMStreamF msf a) s-    return ((s', b), runStateS msf')---- ** Auxiliary functions related to StateT---- IP: Is runStateS_ msf s = feedback s $ runStateS msf >>> arr (\(s,b) -> ((s,b), s)) ?-runStateS_ :: Monad m => MStreamF (StateT s m) a b -> s -> MStreamF m a (s, b)-runStateS_ msf s = MStreamF $ \a -> do-    ((b, msf'), s') <- runStateT (unMStreamF msf a) s-    return ((s', b), runStateS_ msf' s')---- IP: Is runStateS__ msf s = feedback s $ runStateS msf >>> arr (\(s,b) -> (b, s)) ?-runStateS__ :: Monad m => MStreamF (StateT s m) a b -> s -> MStreamF m a b-runStateS__ msf s = MStreamF $ \a -> do-    ((b, msf'), s') <- runStateT (unMStreamF msf a) s-    return (b, runStateS__ msf' s')---- * Writer monad-writerS :: (Monad m, Monoid s) => MStreamF m a (s, b) -> MStreamF (WriterT s m) a b-writerS msf = MStreamF $ \a -> do-    ((s, b), msf') <- lift $ unMStreamF msf a-    tell s-    return (b, writerS msf')--runWriterS :: Monad m => MStreamF (WriterT s m) a b -> MStreamF m a (s, b)-runWriterS msf = MStreamF $ \a -> do-    ((b, msf'), s') <- runWriterT $ unMStreamF msf a-    return ((s', b), runWriterS msf')---- * RWS (Reader-Writer-State) monad--runRWSS :: (Functor m, Monad m, Monoid w)-        => MStreamF (RWST r w s m) a b-        -> MStreamF m (r, s, a) (w, s, b)-runRWSS = transS transformInput transformOutput-  where-    transformInput  (_, _, a) = return a-    transformOutput (r, s, _) msfaction = sym <$> runRWST msfaction r s-    sym ((b, msf'), s, w) = ((w, s, b), msf')----- * Maybe monad--exit :: Monad m => MStreamF (MaybeT m) a b-exit = MStreamF $ const $ MaybeT $ return Nothing--exitWhen :: Monad m => (a -> Bool) -> MStreamF (MaybeT m) a a-exitWhen condition = go where-    go = MStreamF $ \a -> MaybeT $-        if condition a-        then return Nothing-        else return $ Just (a, go)--exitIf :: Monad m => MStreamF (MaybeT m) Bool ()-exitIf = MStreamF $ \b -> MaybeT $ return $ if b then Nothing else Just ((), exitIf)---- Just a is passed along, Nothing causes the whole MStreamF to exit-maybeExit :: Monad m => MStreamF (MaybeT m) (Maybe a) a-maybeExit = MStreamF $ MaybeT . return . fmap (\x -> (x, maybeExit))--mapMaybeS :: Monad m => MStreamF m a b -> MStreamF m (Maybe a) (Maybe b)-mapMaybeS msf = go-  where-    go = MStreamF $ \maybeA -> case maybeA of-                                 Just a -> do-                                     (b, msf') <- unMStreamF msf a-                                     return (Just b, mapMaybeS msf')-                                 Nothing -> return (Nothing, go)---- mapMaybeS msf == runMaybeS (inMaybeT >>> lift mapMaybeS)--inMaybeT :: Monad m => MStreamF (MaybeT m) (Maybe a) a-inMaybeT = liftMStreamF $ MaybeT . return--{--maybeS :: Monad m => MStreamF m a (Maybe b) -> MStreamF (MaybeT m) a b-maybeS msf = MStreamF $ \a -> MaybeT $ return $ unMStreamF msf a--- maybeS msf == lift msf >>> inMaybeT--}--runMaybeS :: Monad m => MStreamF (MaybeT m) a b -> MStreamF m a (Maybe b)-runMaybeS msf = go-  where-    go = MStreamF $ \a -> do-           bmsf <- runMaybeT $ unMStreamF msf a-           case bmsf of-             Just (b, msf') -> return (Just b, runMaybeS msf')-             Nothing        -> return (Nothing, go)--{---- MB: Doesn't typecheck, I don't know why------ IP: Because of the forall in runTS.------ From the action runMaybeT msfaction it does not know that--- the second element of the pair in 'thing' will be a continuation.------ The first branch of the case works because you are passing the--- msf' as is.------ In the second one, you are passing msf, which has the specific type--- MStreamF (MaybeT m) a b.------ Two things you can try (to help you see that this is indeed why GHC is--- complaining):---   - Make the second continuation undefined. Then it typechecks.---   - Use ScopedTypeVariables and a let binding to type msf' in the---   first branch of the case selector. It'll complain about the type---   of msf' if you say it's forcibly a MStreamF (MaybeT m) a b.-----runMaybeS'' :: Monad m => MStreamF (MaybeT m) a b -> MStreamF m a (Maybe b)-runMaybeS'' msf = transS transformInput transformOutput msf-  where-    transformInput  = return-    transformOutput _ msfaction = do-      thing <- runMaybeT msfaction-      case thing of-        Just (b, msf') -> return (Just b, msf')-        Nothing        -> return (Nothing, msf)--}--untilMaybe :: Monad m => MStreamF m a b -> MStreamF m b Bool -> MStreamF (MaybeT m) a b-untilMaybe msf cond = proc a -> do-    b <- liftMStreamFTrans msf -< a-    c <- liftMStreamFTrans cond -< b-    inMaybeT -< if c then Nothing else Just b--catchMaybe :: Monad m => MStreamF (MaybeT m) a b -> MStreamF m a b -> MStreamF m a b-catchMaybe msf1 msf2 = MStreamF $ \a -> do-    cont <- runMaybeT $ unMStreamF msf1 a-    case cont of-        Just (b, msf1') -> return (b, msf1' `catchMaybe` msf2)-        Nothing         -> unMStreamF msf2 a----- * Exception monad--{--catchS' :: Monad m => MStreamF (ExceptT e m) a b -> (e -> m (b, MStreamF m a b)) -> MStreamF m a b-catchS' msf f = MStreamF $ \a -> (unMStreamF msf a) f `catchFinal` f--}-catchS :: Monad m => MStreamF (ExceptT e m) a b -> (e -> MStreamF m a b) -> MStreamF m a b-catchS msf f = MStreamF $ \a -> do-    cont <- runExceptT $ unMStreamF msf a-    case cont of-        Left e          -> unMStreamF (f e) a-        Right (b, msf') -> return (b, msf' `catchS` f)--exceptS :: Monad m => MStreamF (ExceptT e m) a b -> MStreamF m a (Either e b)-exceptS msf = go- where-   go = MStreamF $ \a -> do-          cont <- runExceptT $ unMStreamF msf a-          case cont of-            Left e          -> return (Left e,  go)-            Right (b, msf') -> return (Right b, exceptS msf')---- catchFinal :: Monad m => ExceptT e m a -> (e -> m a) -> m a--- catchFinal action f = do---     ea <- runExceptT action---     case ea of---         Left  e -> f e---         Right a -> return a---throwOnCond :: Monad m => (a -> Bool) -> e -> MStreamF (ExceptT e m) a a-throwOnCond cond e = proc a -> if cond a-    then liftMStreamF throwE -< e-    else returnA -< a--throwOnCondM :: Monad m => (a -> m Bool) -> e -> MStreamF (ExceptT e m) a a-throwOnCondM cond e = proc a -> do-    b <- liftMStreamF (lift . cond) -< a-    if b-    then liftMStreamF throwE -< e-    else returnA -< a---throwOn :: Monad m => e -> MStreamF (ExceptT e m) Bool ()-throwOn e = proc b -> throwOn' -< (b, e)--throwOn' :: Monad m => MStreamF (ExceptT e m) (Bool, e) ()-throwOn' = proc (b, e) -> if b-    then liftMStreamF throwE -< e-    else returnA -< ()---- Similar to delayed switching. Looses a b in case of exception-untilE :: Monad m => MStreamF m a b -> MStreamF m b (Maybe e)-       -> MStreamF (ExceptT e m) a b-untilE msf msfe = proc a -> do-    b <- liftMStreamFTrans msf -< a-    me <- liftMStreamFTrans msfe -< b-    inExceptT -< (ExceptT . return) (maybe (Right b) Left me)--throwMaybe :: Monad m => MStreamF (ExceptT e m) (Maybe e) (Maybe a)-throwMaybe = mapMaybeS $ liftMStreamF throwE--throwS :: Monad m => MStreamF (ExceptT e m) e a-throwS = liftMStreamF throwE--inExceptT :: Monad m => MStreamF (ExceptT e m) (ExceptT e m a) a-inExceptT = liftMStreamF id -- extracts value from monadic action---- * List monad---- Name alternative (in the article): collect-widthFirst :: (Functor m, Monad m) => MStreamF (ListT m) a b -> MStreamF m a [b]-widthFirst msf = widthFirst' [msf] where-    widthFirst' msfs = MStreamF $ \a -> do-        (bs, msfs') <- unzip . concat <$> mapM (runListT . flip unMStreamF a) msfs-        return (bs, widthFirst' msfs')----- Name alternatives: "choose", "parallely" (problematic because it's not multicore)-sequenceS :: Monad m => [MStreamF m a b] -> MStreamF (ListT m) a b-sequenceS msfs = MStreamF $ \a -> ListT $ sequence $ apply a <$> msfs-  where-    apply a msf = do-        (b, msf') <- unMStreamF msf a-        return (b, sequenceS [msf'])--- sequenceS = foldl (<+>) arrowzero . map liftMStreamFTrans

@@ -1,168 +1,51 @@ -- | Monadic Stream Functions are synchronized stream functions--- with side effects.+--   with side effects.+--+--   MSFs are defined by a function @unMSF :: MSF m a b -> a -> m (b, MSF m a b)@+--   that executes one step of a simulation, and produces an output in a+--   monadic context, and a continuation to be used for future steps.+--+--   See the module "Data.MonadicStreamFunction.Core" for details.+--+--   MSFs are a generalisation of the implementation mechanism used by Yampa,+--   Wormholes and other FRP and reactive implementations.+--+--   When combined with different monads, they produce interesting effects. For+--   example, when combined with the @Maybe@ monad, they become transformations+--   that may stop producing outputs (and continuations). The @Either@ monad+--   gives rise to MSFs that end with a result (akin to Tasks in Yampa, and+--   Monadic FRP).+--+--   Flattening, that is, going from some structure @MSF (t m) a b@ to @MSF m a b@+--   for a specific transformer @t@ often gives rise to known FRP constructs.+--   For instance, flattening with @EitherT@ gives rise to switching, and+--   flattening with @ListT@ gives rise to parallelism with broadcasting.+--+--   MSFs can be used to implement many FRP variants, including Arrowized FRP,+--   Classic FRP, and plain reactive programming. Arrowized and applicative+--   syntax are both supported.+--+--   For a very detailed introduction to MSFs, see:+--   <http://dl.acm.org/citation.cfm?id=2976010>+--   (mirror: <http://www.cs.nott.ac.uk/~psxip1/#FRPRefactored>).+ module Data.MonadicStreamFunction   ( module Control.Arrow-  , module Data.MonadicStreamFunction   , module X   )  where  -- External-import Control.Applicative+ import Control.Arrow-import Control.Category (Category(..))-import Control.Monad-import Control.Monad.Base-import Data.Monoid-import Prelude hiding ((.), id, sum) --- Internal (generic)-import Data.VectorSpace-import Data.VectorSpace.Instances()+-- Internal  import Data.MonadicStreamFunction.Core        as X-import Data.MonadicStreamFunction.ArrowChoice as X-import Data.MonadicStreamFunction.ArrowLoop   as X-import Data.MonadicStreamFunction.ArrowPlus   as X---- ** Instances for monadic streams--instance Functor m => Functor (MStreamF m r)-  where-    -- fmap f as = as >>> arr f-    fmap f as = MStreamF $ \r -> fTuple <$> unMStreamF as r-      where-        fTuple (a, as') = (f a, f <$> as')--instance Applicative m => Applicative (MStreamF m r) where-  -- pure a = constantly a-  pure a = MStreamF $ \_ -> pure (a, pure a)-  {--  fs <*> as = proc _ -> do-      f <- fs -< ()-      a <- as -< ()-      returnA -< f a-  -}-  fs <*> as = MStreamF $ \r -> applyTuple <$> unMStreamF fs r <*> unMStreamF as r-    where-      applyTuple (f, fs') (a, as') = (f a, fs' <*> as')---- ** Lifts--{-# DEPRECATED insert "Don't use this. liftMStreamF id instead" #-}-insert :: Monad m => MStreamF m (m a) a-insert = liftMStreamF id--- This expands to the old code:------ MStreamF $ \ma -> do---   a <- ma---   return (a, insert)--liftMStreamF_ :: Monad m => m b -> MStreamF m a b-liftMStreamF_ = liftMStreamF . const---- * Monadic lifting from one monad into another---- ** Monad stacks--(^>>>) :: MonadBase m1 m2 => MStreamF m1 a b -> MStreamF m2 b c -> MStreamF m2 a c-sf1 ^>>> sf2 = (liftMStreamFBase sf1) >>> sf2-{-# INLINE (^>>>) #-}--(>>>^) :: MonadBase m1 m2 => MStreamF m2 a b -> MStreamF m1 b c -> MStreamF m2 a c-sf1 >>>^ sf2 = sf1 >>> (liftMStreamFBase sf2)-{-# INLINE (>>>^) #-}---- ** Delays and signal overwriting---- See also: 'iPre'--iPost :: Monad m => b -> MStreamF m a b -> MStreamF m a b-iPost b sf = MStreamF $ \_ -> return (b, sf)--next :: Monad m => b -> MStreamF m a b -> MStreamF m a b-next b sf = MStreamF $ \a -> do-  (b', sf') <- unMStreamF sf a-  return (b, next b' sf')--- rather, once delay is tested:--- next b sf = sf >>> delay b---- ** Switching---- See also: 'switch', and the exception monad combinators for MSFs in--- Control.Monad.Trans.MStreamF--untilS :: Monad m => MStreamF m a b -> MStreamF m b Bool -> MStreamF m a (b, Maybe ())-untilS sf1 sf2 = sf1 >>> (arr id &&& (sf2 >>> arr boolToMaybe))-  where boolToMaybe x = if x then Just () else Nothing--andThen :: Monad m => MStreamF m a (b, Maybe ()) -> MStreamF m a b -> MStreamF m a b-andThen sf1 sf2 = switch sf1 $ const sf2---- ** Feedback loops---- | Missing: 'feedback'---- * Adding side effects-withSideEffect :: Monad m => (a -> m b) -> MStreamF m a a-withSideEffect method = (id &&& liftMStreamF method) >>> arr fst--withSideEffect_ :: Monad m => m b -> MStreamF m a a-withSideEffect_ method = withSideEffect $ const method---- * Debugging--traceGeneral :: (Monad m, Show a) => (String -> m ()) -> String -> MStreamF m a a-traceGeneral method msg =-  withSideEffect (method . (msg ++) . show)--trace :: Show a => String -> MStreamF IO a a-trace = traceGeneral putStrLn---- FIXME: This does not seem to be a very good name.  It should be--- something like traceWith. It also does too much.-pauseOnGeneral :: (Monad m, Show a) => (a -> Bool) -> (String -> m ()) -> String -> MStreamF m a a-pauseOnGeneral cond method msg = withSideEffect $ \a ->-  when (cond a) $ method $ msg ++ show a--pauseOn :: Show a => (a -> Bool) -> String -> MStreamF IO a a-pauseOn cond = pauseOnGeneral cond $ \s -> print s >> getLine >> return ()---- * Tests and examples--sum :: (Monoid n, Monad m) => MStreamF m n n-sum = sumFrom mempty-{-# INLINE sum #-}--sumFrom :: (Monoid n, Monad m) => n -> MStreamF m n n-sumFrom n0 = MStreamF $ \n -> let acc = n0 `mappend` n-                              -- in acc `seq` return (acc, sumFrom acc)-                              in return (acc, sumFrom acc)--- sum = feedback 0 (arr (uncurry (+) >>> dup))---  where dup x = (x,x)--count :: (Num n, Monad m) => MStreamF m () n-count = arr (const (Sum 1)) >>> sum >>> arr getSum--unfold :: Monad m => (a -> (b,a)) -> a -> MStreamF m () b-unfold f a = MStreamF $ \_ -> let (b,a') = f a in b `seq` return (b, unfold f a')--- unfold f x = feedback x (arr (snd >>> f))--repeatedly :: Monad m => (a -> a) -> a -> MStreamF m () a-repeatedly f = repeatedly'- where repeatedly' a = MStreamF $ \() -> let a' = f a in a' `seq` return (a, repeatedly' a')--- repeatedly f x = feedback x (arr (f >>> \x -> (x,x)))+import Data.MonadicStreamFunction.Util        as X --- FIXME: This should *not* be in this module-mapMStreamF :: Monad m => MStreamF m a b -> MStreamF m [a] [b]-mapMStreamF sf = MStreamF $ consume sf-  where-    consume :: Monad m => MStreamF m a t -> [a] -> m ([t], MStreamF m [a] [t])-    consume sf []     = return ([], mapMStreamF sf)-    consume sf (a:as) = do-      (b, sf')   <- unMStreamF sf a-      (bs, sf'') <- consume sf' as-      b `seq` return (b:bs, sf'')+-- Internal (Instances) --- * Streams (or generators)-type MStream m a = MStreamF m () a+import Data.MonadicStreamFunction.ArrowChoice ()+import Data.MonadicStreamFunction.ArrowLoop   ()+import Data.MonadicStreamFunction.ArrowPlus   ()

@@ -1,12 +1,13 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.MonadicStreamFunction.ArrowChoice where  import Control.Arrow  import Data.MonadicStreamFunction.Core -instance Monad m => ArrowChoice (MStreamF m) where-  left sf = MStreamF f+instance Monad m => ArrowChoice (MSF m) where+  left sf = MSF f     where-      f (Left a) = do (b, sf') <- unMStreamF sf a+      f (Left a) = do (b, sf') <- unMSF sf a                       return (Left b, left sf')       f (Right c) = return (Right c, left sf)

@@ -1,16 +1,15 @@-{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE RecursiveDo          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.MonadicStreamFunction.ArrowLoop where  import Data.MonadicStreamFunction.Core  -- External import Control.Arrow-import Control.Category (Category(..))-import Control.Monad import Control.Monad.Fix -instance (Monad m, MonadFix m) => ArrowLoop (MStreamF m) where+instance (Monad m, MonadFix m) => ArrowLoop (MSF m) where   -- loop :: a (b, d) (c, d) -> a b c-  loop sf = MStreamF $ \a -> do-              rec ((b,c), sf') <- unMStreamF sf (a, c)+  loop sf = MSF $ \a -> do+              rec ((b,c), sf') <- unMSF sf (a, c)               return (b, loop sf')

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.MonadicStreamFunction.ArrowPlus where  import Control.Arrow@@ -5,8 +6,8 @@  import Data.MonadicStreamFunction.Core -instance (Monad m, MonadPlus m) => ArrowZero (MStreamF m) where-  zeroArrow = MStreamF $ const mzero+instance (Monad m, MonadPlus m) => ArrowZero (MSF m) where+  zeroArrow = MSF $ const mzero -instance (Monad m, MonadPlus m) => ArrowPlus (MStreamF m) where-  sf1 <+> sf2 = MStreamF $ \a -> unMStreamF sf1 a `mplus` unMStreamF sf2 a+instance (Monad m, MonadPlus m) => ArrowPlus (MSF m) where+  sf1 <+> sf2 = MSF $ \a -> unMSF sf1 a `mplus` unMSF sf2 a

@@ -1,12 +1,40 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE Rank2Types     #-} -- | Monadic Stream Functions are synchronized stream functions--- with side effects.+--   with side effects.+--+--   MSFs are defined by a function @unMSF :: MSF m a b -> a -> m (b, MSF m a b)@+--   that executes one step of a simulation, and produces an output in a+--   monadic context, and a continuation to be used for future steps.+--+--   MSFs are a generalisation of the implementation mechanism used by Yampa,+--   Wormholes and other FRP and reactive implementations.+--+--   When combined with different monads, they produce interesting effects. For+--   example, when combined with the @Maybe@ monad, they become transformations+--   that may stop producing outputs (and continuations). The @Either@ monad+--   gives rise to MSFs that end with a result (akin to Tasks in Yampa, and+--   Monadic FRP).+--+--   Flattening, that is, going from some structure @MSF (t m) a b@ to @MSF m a b@+--   for a specific transformer @t@ often gives rise to known FRP constructs.+--   For instance, flattening with @EitherT@ gives rise to switching, and+--   flattening with @ListT@ gives rise to parallelism with broadcasting.+--+--   MSFs can be used to implement many FRP variants, including Arrowized FRP,+--   Classic FRP, and plain reactive programming. Arrowized and applicative+--   syntax are both supported.+--+--   For a very detailed introduction to MSFs, see:+--   <http://dl.acm.org/citation.cfm?id=2976010>+--   (mirror: <http://www.cs.nott.ac.uk/~psxip1/#FRPRefactored>). +-- NOTE TO IMPLEMENTORS:+-- -- This module contains the core. Only the core. It should be possible -- to define every function and type outside this module, except for the -- instances for ArrowLoop, ArrowChoice, etc., without access to the--- internal constructor for MStreamF and the function 'unMStreamF'.+-- internal constructor for MSF and the function 'unMSF'. -- -- It's very hard to know what IS essential to framework and if we start -- adding all the functions and instances that *may* be useful in one@@ -19,126 +47,170 @@ -- -- To address potential violations of basic design principles (like 'not -- having orphan instances'), the main module Data.MonadicStreamFunction--- exports everything. Users should *never* import this module+-- exports everything. Users should *never* import this module here -- individually, but the main module instead. module Data.MonadicStreamFunction.Core where  -- External-import Control.Applicative import Control.Arrow+import Control.Applicative import Control.Category (Category(..)) import Control.Monad import Control.Monad.Base import Control.Monad.Trans.Class import Prelude hiding ((.), id, sum) --- MStreamF: Stepwise, side-effectful MStreamFs without implicit knowledge of time-data MStreamF m a b = MStreamF { unMStreamF :: a -> m (b, MStreamF m a b) }+-- * Definitions -instance Monad m => Category (MStreamF m) where+-- | Stepwise, side-effectful MSFs without implicit knowledge of time.+--+-- MSFs should be applied to streams or executed indefinitely or until they+-- terminate. See 'reactimate' and 'reactimateB' for details. In general,+-- calling the value constructor 'MSF' or the function 'unMSF' is discouraged.+data MSF m a b = MSF { unMSF :: a -> m (b, MSF m a b) }++-- Instances++instance Monad m => Category (MSF m) where   id = go-    where go = MStreamF $ \a -> return (a, go)-  sf2 . sf1 = MStreamF $ \a -> do-    (b, sf1') <- unMStreamF sf1 a-    (c, sf2') <- unMStreamF sf2 b+    where go = MSF $ \a -> return (a, go)+  sf2 . sf1 = MSF $ \a -> do+    (b, sf1') <- unMSF sf1 a+    (c, sf2') <- unMSF sf2 b     let sf' = sf2' . sf1'     c `seq` return (c, sf') -instance Monad m => Arrow (MStreamF m) where+instance Monad m => Arrow (MSF m) where    arr f = go-    where go = MStreamF $ \a -> return (f a, go)+    where go = MSF $ \a -> return (f a, go) -  first sf = MStreamF $ \(a,c) -> do-    (b, sf') <- unMStreamF sf a+  first sf = MSF $ \(a,c) -> do+    (b, sf') <- unMSF sf a     b `seq` return ((b, c), first sf')-    -- This is called the "monadic strength" of m --- ** Lifts-liftMStreamF :: Monad m => (a -> m b) -> MStreamF m a b-liftMStreamF f = go- where go = MStreamF $ \a -> do-              b <- f a-              return (b, go)+instance Functor m => Functor (MSF m a) where+  -- fmap f msf == msf >>> arr f+  fmap f msf = MSF $ fmap fS . unMSF msf+    where+      fS (b, cont) = (f b, fmap f cont) +instance (Functor m, Monad m) => Applicative (MSF m a) where+  -- It is possible to define this instance with only Applicative m+  pure = arr . const+  fs <*> bs = (fs &&& bs) >>> arr (uncurry ($))++-- * Lifting++-- | Apply the same monadic transformation to every element of the input stream.+--+-- Generalisation of arr from Arrow to stream functions with monads.+arrM :: Monad m => (a -> m b) -> MSF m a b+arrM f = go+  where go = MSF $ \a -> do+               b <- f a+               return (b, go)+ -- * Monadic lifting from one monad into another +liftS :: (Monad m2, MonadBase m1 m2) => (a -> m1 b) -> MSF m2 a b+liftS = arrM . (liftBase .)+ -- ** Purer monads  -- IPerez: There is an alternative signature for liftMStreamPurer that also -- works, and makes the code simpler: ----- liftMStreamFPurer :: Monad m => (m1 (b, MStreamF m1 a b) -> m (b, MStreamF m1 a b)) -> MStreamF m1 a b -> MStreamF m a b+-- liftMSFPurer :: Monad m => (m1 (b, MSF m1 a b) -> m (b, MSF m1 a b)) -> MSF m1 a b -> MSF m a b -- -- Then we can express: ----- liftMStreamFTrans = liftMStreamFPurer lift--- liftMStreamFBase  = liftMStreamFPurer liftBase+-- liftMSFTrans = liftMSFPurer lift+-- liftMSFBase  = liftMSFPurer liftBase ----- We could also define a strict version of liftMStreamFPurer as follows:+-- We could also define a strict version of liftMSFPurer as follows: ----- liftMStreamPurer' f = liftMStreamFPurer (f >=> whnfVal)+-- liftMStreamPurer' f = liftMSFPurer (f >=> whnfVal) --   where whnfVal p@(b,_) = b `seq` return p ----- and leave liftMStreamFPurer as a lazy version (by default).+-- and leave liftMSFPurer as a lazy version (by default).  -- | Lifting purer monadic actions (in an arbitrary way)-liftMStreamFPurer :: (Monad m2, Monad m1) => (forall c . m1 c -> m2 c) -> MStreamF m1 a b -> MStreamF m2 a b-liftMStreamFPurer liftPurer sf = MStreamF $ \a -> do-  (b, sf') <- liftPurer $ unMStreamF sf a-  b `seq` return (b, liftMStreamFPurer liftPurer sf')+liftMSFPurer :: (Monad m2, Monad m1) => (forall c . m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b+liftMSFPurer liftPurer sf = MSF $ \a -> do+  (b, sf') <- liftPurer $ unMSF sf a+  b `seq` return (b, liftMSFPurer liftPurer sf')  -- ** Monad stacks --- | Lifting inner monadic actions in monad stacks+-- | Lift inner monadic actions in monad stacks.+ -- TODO Should be able to express this in terms of MonadBase-liftMStreamFTrans :: (MonadTrans t, Monad m, Monad (t m)) => MStreamF m a b -> MStreamF (t m) a b-liftMStreamFTrans sf = MStreamF $ \a -> do-  (b, sf') <- lift $ unMStreamF sf a-  return (b, liftMStreamFTrans sf')+liftMSFTrans :: (MonadTrans t, Monad m, Monad (t m))+             => MSF m a b+             -> MSF (t m) a b+liftMSFTrans sf = MSF $ \a -> do+  (b, sf') <- lift $ unMSF sf a+  return (b, liftMSFTrans sf') --- | Lifting the innest monadic actions in a monad stacks (generalisation of liftIO)-liftMStreamFBase :: (Monad m2, MonadBase m1 m2) => MStreamF m1 a b -> MStreamF m2 a b-liftMStreamFBase sf = MStreamF $ \a -> do-  (b, sf') <- liftBase $ unMStreamF sf a-  b `seq` return (b, liftMStreamFBase sf')+-- | Lift innermost monadic actions in a monad stacks (generalisation of+-- 'liftIO').+liftMSFBase :: (Monad m2, MonadBase m1 m2) => MSF m1 a b -> MSF m2 a b+liftMSFBase sf = MSF $ \a -> do+  (b, sf') <- liftBase $ unMSF sf a+  b `seq` return (b, liftMSFBase sf')  -- * MSFs within monadic actions --- | Extract MSF from a monadic action-performOnFirstSample :: Monad m => m (MStreamF m a b) -> MStreamF m a b-performOnFirstSample sfaction = MStreamF $ \a -> do+-- | Extract MSF from a monadic action.+--+-- Runs a monadic action that produces an MSF on the first iteration/step, and+-- uses that MSF as the main signal function for all inputs (including the+-- first one).+performOnFirstSample :: Monad m => m (MSF m a b) -> MSF m a b+performOnFirstSample sfaction = MSF $ \a -> do   sf <- sfaction-  unMStreamF sf a+  unMSF sf a  -- ** Delays and signal overwriting -iPre :: Monad m => a -> MStreamF m a a-iPre firsta = MStreamF $ \a -> return (firsta, delay a)+-- | Delay a signal by one sample.+iPre :: Monad m+     => a         -- ^ First output+     -> MSF m a a+iPre firsta = MSF $ \a -> return (firsta, delay a) -- iPre firsta = feedback firsta $ lift swap --   where swap (a,b) = (b, a) -- iPre firsta = next firsta identity +-- | See 'iPre'.+ -- FIXME: Remove delay from this module. We should try to make this module -- small, keeping only primitives.-delay :: Monad m => a -> MStreamF m a a+delay :: Monad m => a -> MSF m a a delay = iPre  -- ** Switching -switch :: Monad m => MStreamF m a (b, Maybe c) -> (c -> MStreamF m a b) -> MStreamF m a b-switch sf f = MStreamF $ \a -> do-  ((b, c), sf') <- unMStreamF sf a+-- | Switching applies one MSF until it produces a 'Just' output, and then+-- "turns on" a continuation and runs it.+--+-- A more advanced and comfortable approach to switching is givin by Exceptions+-- in "Control.Monad.Trans.MSF.Except"+switch :: Monad m => MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b+switch sf f = MSF $ \a -> do+  ((b, c), sf') <- unMSF sf a   return (b, maybe (switch sf' f) f c)  -- ** Feedback loops -feedback :: Monad m => c -> MStreamF m (a, c) (b, c) -> MStreamF m a b-feedback c sf = MStreamF $ \a -> do-  ((b', c'), sf') <- unMStreamF sf (a, c)+-- | Well-formed looped connection of an output component as a future input.+feedback :: Monad m => c -> MSF m (a, c) (b, c) -> MSF m a b+feedback c sf = MSF $ \a -> do+  ((b', c'), sf') <- unMSF sf (a, c)   return (b', feedback c' sf') --- * Reactimating+-- * Execution/simulation  -- | Apply a monadic stream function to a list. --@@ -148,26 +220,28 @@ -- if the MSF produces Nothing at any point, so the output stream cannot -- consumed progressively. ----- To explore the output progressively, use liftMStreamF and (>>>), together+-- To explore the output progressively, use liftMSF and (>>>), together -- with some action that consumes/actuates on the output. -- -- This is called "runSF" in Liu, Cheng, Hudak, "Causal Commutative Arrows and -- Their Optimization"-embed :: Monad m => MStreamF m a b -> [a] -> m [b]+embed :: Monad m => MSF m a b -> [a] -> m [b] embed _  []     = return [] embed sf (a:as) = do-  (b, sf') <- unMStreamF sf a+  (b, sf') <- unMSF sf a   bs       <- embed sf' as   return (b:bs) --- | Runs an MSF indefinitely passing a unit-carrying input stream.-reactimate :: Monad m => MStreamF m () () -> m ()+-- | Run an MSF indefinitely passing a unit-carrying input stream.+reactimate :: Monad m => MSF m () () -> m () reactimate sf = do-  (_, sf') <- unMStreamF sf ()+  (_, sf') <- unMSF sf ()   reactimate sf' --- | Runs an MSF indefinitely passing a unit-carrying input stream.-reactimateB :: Monad m => MStreamF m () Bool -> m ()+-- | Run an MSF indefinitely passing a unit-carrying input stream.+-- A more high-level approach to this would be the use of MaybeT+-- in Control.Monad.Trans.MSF.Maybe+reactimateB :: Monad m => MSF m () Bool -> m () reactimateB sf = do-  (b, sf') <- unMStreamF sf ()-  if b then return () else reactimateB sf'+  (b, sf') <- unMSF sf ()+  unless b $ reactimateB sf'

@@ -1,16 +1,15 @@-{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilies #-} module Data.MonadicStreamFunction.Instances where  -- External import Control.Arrow  -- Internal-import Control.Arrow.Util import Data.MonadicStreamFunction.Core  -- Numerical operations are defined elementwise on the output-elementwise :: Monad m => (b -> c) -> MStreamF m a b -> MStreamF m a c+elementwise :: Monad m => (b -> c) -> MSF m a b -> MSF m a c elementwise f msf = msf >>> arr f -elementwise2 :: Monad m => (b -> c -> d) -> MStreamF m a b -> MStreamF m a c -> MStreamF m a d+elementwise2 :: Monad m => (b -> c -> d) -> MSF m a b -> MSF m a c -> MSF m a d elementwise2 op msf1 msf2 = msf1 &&& msf2 >>> arr (uncurry op)

@@ -1,41 +1,41 @@-{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.MonadicStreamFunction.Instances.Num where - import Control.Arrow.Util import Data.MonadicStreamFunction.Core import Data.MonadicStreamFunction.Instances -instance (Monad m, Num b) => Num (MStreamF m a b) where-    (+)         = elementwise2 (+)-    (-)         = elementwise2 (-)-    (*)         = elementwise2 (*)-    abs         = elementwise abs-    signum      = elementwise signum-    negate      = elementwise negate-    fromInteger = constantly . fromInteger+instance (Monad m, Num b) => Num (MSF m a b) where+  (+)         = elementwise2 (+)+  (-)         = elementwise2 (-)+  (*)         = elementwise2 (*)+  abs         = elementwise abs+  signum      = elementwise signum+  negate      = elementwise negate+  fromInteger = constantly . fromInteger -instance (Monad m, Fractional b) => Fractional (MStreamF m a b) where-    fromRational = constantly . fromRational-    (/)          = elementwise2 (/)-    recip        = elementwise recip+instance (Monad m, Fractional b) => Fractional (MSF m a b) where+  fromRational = constantly . fromRational+  (/)          = elementwise2 (/)+  recip        = elementwise recip -instance (Monad m, Floating b) => Floating (MStreamF m a b) where-    pi      = constantly   pi-    exp     = elementwise  exp-    log     = elementwise  log-    sqrt    = elementwise  sqrt-    (**)    = elementwise2 (**)-    logBase = elementwise2 logBase-    sin     = elementwise  sin-    cos     = elementwise  cos-    tan     = elementwise  tan-    asin    = elementwise  asin-    acos    = elementwise  acos-    atan    = elementwise  atan-    sinh    = elementwise  sinh-    cosh    = elementwise  cosh-    tanh    = elementwise  tanh-    asinh   = elementwise  asinh-    acosh   = elementwise  acosh-    atanh   = elementwise  atanh+instance (Monad m, Floating b) => Floating (MSF m a b) where+  pi      = constantly   pi+  exp     = elementwise  exp+  log     = elementwise  log+  sqrt    = elementwise  sqrt+  (**)    = elementwise2 (**)+  logBase = elementwise2 logBase+  sin     = elementwise  sin+  cos     = elementwise  cos+  tan     = elementwise  tan+  asin    = elementwise  asin+  acos    = elementwise  acos+  atan    = elementwise  atan+  sinh    = elementwise  sinh+  cosh    = elementwise  cosh+  tanh    = elementwise  tanh+  asinh   = elementwise  asinh+  acosh   = elementwise  acosh+  atanh   = elementwise  atanh

@@ -1,21 +1,20 @@-{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.MonadicStreamFunction.Instances.VectorSpace where - import Control.Arrow.Util import Data.MonadicStreamFunction.Core import Data.MonadicStreamFunction.Instances import Data.VectorSpace - -- These conflict with Data.VectorSpace.Instances-instance (Monad m, RModule v) => RModule (MStreamF m a v) where-    type Groundring (MStreamF m a v) = Groundring v-    zeroVector   = constantly zeroVector-    r *^ msf     = elementwise (r *^) msf-    negateVector = elementwise negateVector-    (^+^)        = elementwise2 (^+^)-    (^-^)        = elementwise2 (^-^)+instance (Monad m, RModule v) => RModule (MSF m a v) where+  type Groundring (MSF m a v) = Groundring v+  zeroVector   = constantly zeroVector+  r *^ msf     = elementwise  (r *^) msf+  negateVector = elementwise  negateVector+  (^+^)        = elementwise2 (^+^)+  (^-^)        = elementwise2 (^-^) -instance (Monad m, VectorSpace v) => VectorSpace (MStreamF m a v) where-    msf ^/ r = elementwise (^/ r) msf+instance (Monad m, VectorSpace v) => VectorSpace (MSF m a v) where+  msf ^/ r = elementwise (^/ r) msf

@@ -16,12 +16,12 @@ -- and so (***) might be strict in both arguments and not take -- full advantage of parallelism. ---(*|*) :: Monad m => MStreamF m a b -> MStreamF m c d -> MStreamF m (a, c) (b, d)-msf1 *|* msf2 = MStreamF $ \(a, c) -> do-    (b, msf1') <- unMStreamF msf1 a-    (d, msf2') <- unMStreamF msf2 c+(*|*) :: Monad m => MSF m a b -> MSF m c d -> MSF m (a, c) (b, d)+msf1 *|* msf2 = MSF $ \(a, c) -> do+    (b, msf1') <- unMSF msf1 a+    (d, msf2') <- unMSF msf2 c     b `par` d `pseq` return ((b, d), msf1' *|* msf2')  -(&|&) :: Monad m => MStreamF m a b -> MStreamF m a c -> MStreamF m a (b, c)+(&|&) :: Monad m => MSF m a b -> MSF m a c -> MSF m a (b, c) msf1 &|& msf2 = arr (\a -> (a, a)) >>> (msf1 *|* msf2)

@@ -0,0 +1,45 @@+-- | ReactHandle++-- Sometimes it is beneficial to give control to an external main loop,+-- for example OpenGL or a hardware-clocked audio server like JACK.+-- This module makes Dunai compatible with external main loops.++module Data.MonadicStreamFunction.ReactHandle where++-- External+import Control.Monad.IO.Class+import Data.IORef++-- Internal+import Data.MonadicStreamFunction+++-- | A storage for the current state of an MSF+type ReactHandle m = IORef (MSF m () ())+++-- | Needs to be called before the external main loop is dispatched+reactInit :: MonadIO m => MSF m () () -> m (ReactHandle m)+reactInit = liftIO . newIORef+++-- | The callback that needs to be called by the main loop at every cycle+react :: MonadIO m => ReactHandle m -> m ()+react handle = do+  msf <- liftIO $ readIORef handle+  (_, msf') <- unMSF msf ()+  liftIO $ writeIORef handle msf'+++-- | Creates two ends of a synchronisation wormhole++-- Often, the external framework may have several parallel loops,+-- for example, OpenGL with a display callback, an idle callback and a keyboard callback.+-- In such cases, one would like to let the different parts communicate.+-- This is done through a wormhole, which is a shared mutable variable+-- that can be written from one part and read from the other.++createWormhole :: MonadIO m => a -> m (MSF m a (), MSF m () a)+createWormhole a = liftIO $ do+  ref <- newIORef a+  return (arrM $ liftIO . writeIORef ref, arrM_ $ liftIO $ readIORef ref)

@@ -0,0 +1,148 @@+module Data.MonadicStreamFunction.Util where++-- External+import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad+import Control.Monad.Base+import Data.Monoid+import Prelude hiding (id, (.))++-- Internal+import Data.MonadicStreamFunction.Core+import Data.VectorSpace++-- * Useful aliases+type MStream m a = MSF m () a+type MSink   m a = MSF m a ()+++-- * Stateful accumulation++accumulateWith :: Monad m => (a -> s -> s) -> s -> MSF m a s+accumulateWith f s0 = feedback s0 $ arr g+  where+    g (a, s) = let s' = f a s in (s', s')++-- ** Accumulation for monoids++mappendS :: (Monoid n, Monad m) => MSF m n n+mappendS = mappendFrom mempty+{-# INLINE mappendS #-}++mappendFrom :: (Monoid n, Monad m) => n -> MSF m n n+mappendFrom = accumulateWith mappend++-- ** Accumulation for VectorSpace instances++sumFrom :: (RModule v, Monad m) => v -> MSF m v v+sumFrom = accumulateWith (^+^)++sumS :: (RModule v, Monad m) => MSF m v v+sumS = sumFrom zeroVector++count :: (Num n, Monad m) => MSF m a n+count = arr (const 1) >>> accumulateWith (+) 0++-- * Generating Signals++unfold :: Monad m => (a -> (b,a)) -> a -> MSF m () b+unfold f a = MSF $ \_ -> let (b,a') = f a in b `seq` return (b, unfold f a')+-- unfold f x = feedback x (arr (snd >>> f))++repeatedly :: Monad m => (a -> a) -> a -> MSF m () a+repeatedly f = repeatedly'+ where repeatedly' a = MSF $ \() -> let a' = f a in a' `seq` return (a, repeatedly' a')+-- repeatedly f x = feedback x (arr (f >>> \x -> (x,x)))++-- * Special cases of map++mapMSF :: Monad m => MSF m a b -> MSF m [a] [b]+mapMSF = MSF . consume+  where+    consume :: Monad m => MSF m a t -> [a] -> m ([t], MSF m [a] [t])+    consume sf []     = return ([], mapMSF sf)+    consume sf (a:as) = do+      (b, sf')   <- unMSF sf a+      (bs, sf'') <- consume sf' as+      b `seq` return (b:bs, sf'')++mapMaybeS :: Monad m => MSF m a b -> MSF m (Maybe a) (Maybe b)+mapMaybeS msf = go+  where+    go = MSF $ \maybeA -> case maybeA of+      Just a -> do+        (b, msf') <- unMSF msf a+        return (Just b, mapMaybeS msf')+      Nothing -> return (Nothing, go)++++-- * Adding side effects+withSideEffect :: Monad m => (a -> m b) -> MSF m a a+withSideEffect method = (id &&& arrM method) >>> arr fst++withSideEffect_ :: Monad m => m b -> MSF m a a+withSideEffect_ method = withSideEffect $ const method++-- * Debugging++traceWith :: (Monad m, Show a) => (String -> m ()) -> String -> MSF m a a+traceWith method msg =+  withSideEffect (method . (msg ++) . show)++trace :: Show a => String -> MSF IO a a+trace = traceWith putStrLn++traceWhen :: (Monad m, Show a) => (a -> Bool) -> (String -> m ()) -> String -> MSF m a a+traceWhen cond method msg = withSideEffect $ \a ->+  when (cond a) $ method $ msg ++ show a++pauseOn :: Show a => (a -> Bool) -> String -> MSF IO a a+pauseOn cond = traceWhen cond $ \s -> print s >> getLine >> return ()+++-- * Inserting monadic actions into MSFs++{-# DEPRECATED insert "Don't use this. arrM id instead" #-}+insert :: Monad m => MSF m (m a) a+insert = arrM id++arrM_ :: Monad m => m b -> MSF m a b+arrM_ = arrM . const++-- * Lifting from one monad into another+++(^>>>) :: MonadBase m1 m2 => MSF m1 a b -> MSF m2 b c -> MSF m2 a c+sf1 ^>>> sf2 = liftMSFBase sf1 >>> sf2+{-# INLINE (^>>>) #-}++(>>>^) :: MonadBase m1 m2 => MSF m2 a b -> MSF m1 b c -> MSF m2 a c+sf1 >>>^ sf2 = sf1 >>> liftMSFBase sf2+{-# INLINE (>>>^) #-}++-- * Delays and signal overwriting++-- See also: 'iPre'++iPost :: Monad m => b -> MSF m a b -> MSF m a b+iPost b sf = MSF $ \_ -> return (b, sf)++next :: Monad m => b -> MSF m a b -> MSF m a b+next b sf = MSF $ \a -> do+  (b', sf') <- unMSF sf a+  return (b, next b' sf')+-- rather, once delay is tested:+-- next b sf = sf >>> delay b++-- * Alternative running functions++-- | Run an MSF fed from a list, discarding results. Useful when one needs to+-- combine effects and streams (i.e., for testing purposes).++-- TODO: This is not elementary, it can probably be built using other+-- construts. Move to a non-core module?+embed_ :: (Functor m, Monad m) => MSF m a () -> [a] -> m ()+embed_ msf as = void $ foldM (\sf a -> snd <$> unMSF sf a) msf as

@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# OPTIONS_GHC -fno-warn-orphans   #-}+module Data.VectorSpace.Fractional where++-- VectorSpace instances for Num/Fractional types. These sometimes clash with+-- user-defined instances.+-- (See https://github.com/ivanperez-keera/dunai/issues/11, where this+-- module used to be called Data.VectorSpace.Instances)++import Data.VectorSpace++instance Num a => RModule a where+    type Groundring a = a+    zeroVector     = 0+    a *^ x         = a * x+    negateVector x = -x+    x1 ^+^ x2      = x1 + x2+    x1 ^-^ x2      = x1 - x2++instance Fractional a => VectorSpace a where+    a ^/ x = a / x++instance Num a => InnerProductSpace a where+    x1 `dot` x2 = x1 * x2

@@ -1,22 +0,0 @@-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE UndecidableInstances   #-}-module Data.VectorSpace.Instances where--import Data.VectorSpace---instance Num a => RModule a where-    type Groundring a = a-    zeroVector     = 0-    a *^ x         = a * x-    negateVector x = -x-    x1 ^+^ x2      = x1 + x2-    x1 ^-^ x2      = x1 - x2---instance Fractional a => VectorSpace a where-    a ^/ x = a / x--instance Num a => InnerProductSpace a where-    x1 `dot` x2 = x1 * x2

@@ -1,4 +1,5 @@-{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.VectorSpace.Specific where  import Data.VectorSpace

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE TypeFamilies           #-}+{-# OPTIONS_GHC -fno-warn-orphans   #-} module Data.VectorSpace.Tuples where  import Data.VectorSpace