diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Ivan Perez and Manuel Bärenz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ivan Perez and Manuel Bärenz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dunai-core.cabal b/dunai-core.cabal new file mode 100644 --- /dev/null +++ b/dunai-core.cabal @@ -0,0 +1,83 @@ +name: dunai-core +version: 0.5.1.0 +synopsis: Generalised reactive framework supporting classic, arrowized and monadic FRP. + (Core library fork.) +homepage: https://github.com/turion/dunai-core +description: + Dunai is a 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: + + (mirror: ). +license: BSD3 +license-file: LICENSE +author: Ivan Perez, Manuel Bärenz +maintainer: programming@manuelbaerenz.de +-- copyright: +category: Reactivity, FRP +build-type: Simple +-- extra-source-files: +cabal-version: 1.18 + +source-repository head + type: git + location: git@github.com:turion/dunai-core + + +library + 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.Random + Control.Monad.Trans.MSF.Reader + Control.Monad.Trans.MSF.RWS + Control.Monad.Trans.MSF.State + Control.Monad.Trans.MSF.Writer + Data.MonadicStreamFunction + Data.MonadicStreamFunction.Core + Data.MonadicStreamFunction.Async + Data.MonadicStreamFunction.Instances.ArrowChoice + Data.MonadicStreamFunction.Instances.ArrowLoop + Data.MonadicStreamFunction.Instances.ArrowPlus + Data.MonadicStreamFunction.Instances.Num + Data.MonadicStreamFunction.Instances.VectorSpace + Data.MonadicStreamFunction.Parallel + Data.MonadicStreamFunction.ReactHandle + Data.MonadicStreamFunction.Util + + -- Auxiliary definitions + Data.VectorSpace + + other-modules: Control.Arrow.Util + + build-depends: base >=4.10 && < 4.13 + , transformers == 0.5.* + , transformers-base == 0.4.* + , MonadRandom == 0.5.* + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Control/Arrow/Util.hs b/src/Control/Arrow/Util.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/Util.hs @@ -0,0 +1,28 @@ +-- | Utility functions to work with 'Arrow's. +module Control.Arrow.Util where + +import Control.Arrow + +-- | Constantly produce the same output. +constantly :: Arrow a => b -> a c b +constantly = arr . const +{-# INLINE constantly #-} + +-- import Control.Category (id) +-- import Prelude hiding (id) + +-- (&&&!) :: 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 + +-- * Apply functions at the end. +-- +-- | Alternative name for '^<<'. +elementwise :: Arrow a => (c -> d) -> a b c -> a b d +elementwise = (^<<) + +-- | Apply a curried function with two arguments to the outputs of two arrows. +elementwise2 :: Arrow a => (c -> d -> e) -> a b c -> a b d -> a b e +elementwise2 op a1 a2 = (a1 &&& a2) >>^ uncurry op diff --git a/src/Control/Monad/Trans/MSF.hs b/src/Control/Monad/Trans/MSF.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Rank2Types #-} + +-- | This module reexports nearly all submodules. RWS is not exported since +-- names collide with Reader, State and Writer. +module Control.Monad.Trans.MSF + ( module Control.Monad.Trans.MSF.GenLift + , module Control.Monad.Trans.MSF.Except + , module Control.Monad.Trans.MSF.Maybe + , module Control.Monad.Trans.MSF.Random + , module Control.Monad.Trans.MSF.Reader + , module Control.Monad.Trans.MSF.State + , module Control.Monad.Trans.MSF.Writer + ) + where + +import Control.Monad.Trans.MSF.GenLift +import Control.Monad.Trans.MSF.Except +import Control.Monad.Trans.MSF.Maybe +import Control.Monad.Trans.MSF.Random +import Control.Monad.Trans.MSF.Reader +import Control.Monad.Trans.MSF.State +import Control.Monad.Trans.MSF.Writer diff --git a/src/Control/Monad/Trans/MSF/Except.hs b/src/Control/Monad/Trans/MSF/Except.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/Except.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE Rank2Types #-} +-- | 'MSF's in the 'ExceptT' monad are monadic stream functions +-- that can throw exceptions, +-- i.e. return an exception value instead of a continuation. +-- This module gives ways to throw exceptions in various ways, +-- and to handle them through a monadic interface. +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 (liftM, ap) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except hiding (liftCallCC, liftListen, liftPass) -- Avoid conflicting exports +import Control.Monad.Trans.Maybe +import Data.Either (fromLeft, fromRight) + +-- Internal +-- import Control.Monad.Trans.MSF.GenLift +import Data.MonadicStreamFunction + +-- * Throwing exceptions + +-- | Throw the exception 'e' whenever the function evaluates to 'True'. +throwOnCond :: Monad m => (a -> Bool) -> e -> MSF (ExceptT e m) a a +throwOnCond cond e = proc a -> if cond a + then throwS -< e + else returnA -< a + +-- | Variant of 'throwOnCond' for Kleisli arrows. +-- | Throws the exception when the input is 'True'. +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 throwS -< e + else returnA -< a + +-- | Throw the exception when the input is 'True'. +throwOn :: Monad m => e -> MSF (ExceptT e m) Bool () +throwOn e = proc b -> throwOn' -< (b, e) + +-- | Variant of 'throwOn', where the exception may change every tick. +throwOn' :: Monad m => MSF (ExceptT e m) (Bool, e) () +throwOn' = proc (b, e) -> if b + then throwS -< e + else returnA -< () + +-- | When the input is @Just e@, throw the exception @e@. +-- (Does not output any actual data.) +throwMaybe :: Monad m => MSF (ExceptT e m) (Maybe e) (Maybe a) +throwMaybe = mapMaybeS throwS + +-- | Immediately throw the incoming exception. +throwS :: Monad m => MSF (ExceptT e m) e a +throwS = arrM throwE + +-- | Immediately throw the given exception. +throw :: Monad m => e -> MSF (ExceptT e m) a b +throw = arrM_ . throwE + +-- | Do not throw an exception. +pass :: Monad m => MSF (ExceptT e m) a a +pass = Category.id + +-- | Converts an 'MSF' in 'MaybeT' to an 'MSF' in 'ExceptT'. +-- Whenever 'Nothing' is thrown, throw @()@ instead. +maybeToExceptS :: Monad m + => MSF (MaybeT m) a b -> MSF (ExceptT () m) a b +maybeToExceptS = liftMSFPurer (ExceptT . (maybe (Left ()) Right <$>) . runMaybeT) + +-- * Catching exceptions + +-- | Catch an exception in an 'MSF'. As soon as an exception occurs, +-- the current continuation is replaced by a new 'MSF', the exception handler, +-- based on the exception value. +-- For exception catching where the handler can throw further exceptions, +-- see 'MSFExcept' further below. +catchS :: Monad m => MSF (ExceptT e m) a b -> (e -> MSF m a b) -> MSF m a b +catchS msf f = safely $ do + e <- try msf + safe $ f e + +-- | Similar to Yampa's delayed switching. Looses a @b@ in case of an 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 + +-- | Escape an 'ExceptT' layer by outputting the exception whenever it occurs. +-- If an exception occurs, the current 'MSF' continuation is tested again +-- on the next input. +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') + +-- | Embed an 'ExceptT' value inside the 'MSF'. +-- Whenever the input value is an ordinary value, +-- it is passed on. If it is an exception, it is raised. +inExceptT :: Monad m => MSF (ExceptT e m) (ExceptT e m a) a +inExceptT = arrM id + +-- | In case an exception occurs in the first argument, +-- replace the exception by the second component of the tuple. +tagged :: Monad m => MSF (ExceptT e1 m) a b -> MSF (ExceptT e2 m) (a, e2) b +tagged msf = runMSFExcept $ do + _ <- try $ msf <<< arr fst + (_, e2) <- currentInput + return e2 + + +-- * Monad interface for Exception MSFs + +-- | 'MSF's with an 'ExceptT' transformer layer +-- are in fact monads /in the exception type/. +-- +-- * 'return' corresponds to throwing an exception immediately. +-- * '>>=' is exception handling: +-- The first value throws an exception, +-- while the Kleisli arrow handles the exception +-- and produces a new signal function, +-- which can throw exceptions in a different type. +-- * @m@: The monad that the 'MSF' may take side effects in. +-- * @a@: The input type +-- * @b@: The output type +-- * @e@: The type of exceptions that can be thrown +newtype MSFExcept m a b e = MSFExcept { runMSFExcept :: MSF (ExceptT e m) a b } + +-- | An alias for the 'MSFExcept' constructor, +-- used to enter the 'MSFExcept' monad context. +-- Execute an 'MSF' in 'ExceptT' until it raises an exception. +try :: MSF (ExceptT e m) a b -> MSFExcept m a b e +try = MSFExcept + +-- | Immediately throw the current input as an exception. +currentInput :: Monad m => MSFExcept m e b e +currentInput = try throwS + +-- | Functor instance for MSFs on the 'Either' monad. Fmapping is the same as +-- applying a transformation to the 'Left' values. +instance Monad m => Functor (MSFExcept m a b) where + fmap = liftM + +-- | Applicative instance for MSFs on the 'Either' monad. The function 'pure' +-- throws an exception. +instance Monad m => Applicative (MSFExcept m a b) where + pure = MSFExcept . throw + (<*>) = ap + +-- | Monad instance for 'MSFExcept'. Bind uses the exception as the 'return' +-- value in the monad. +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) + +-- | The empty type. As an exception type, it encodes "no exception possible". +data Empty + +-- | If no exception can occur, the 'MSF' can be executed without the 'ExceptT' layer. +safely :: Monad m => MSFExcept m a b Empty -> MSF m a b +safely (MSFExcept msf) = safely' msf + where + safely' msf = MSF $ \a -> do + (b, msf') <- fromRight (error "safely: Received `Left`") + <$> (runExceptT $ unMSF msf a) + return (b, safely' msf') + +-- | An 'MSF' without an 'ExceptT' layer never throws an exception, +-- and can thus have an arbitrary exception type. +safe :: Monad m => MSF m a b -> MSFExcept m a b e +safe = try . liftMSFTrans + +-- | Inside the 'MSFExcept' monad, execute an action of the wrapped monad. +-- This passes the last input value to the action, +-- but doesn't advance a tick. +once :: Monad m => (a -> m e) -> MSFExcept m a b e +once f = try $ arrM (lift . f) >>> throwS + +-- | Variant of 'once' without input. +once_ :: Monad m => m e -> MSFExcept m a b e +once_ = once . const + +-- | Advances a single tick with the given Kleisli arrow, +-- and then throws an exception. +step :: Monad m => (a -> m (b, e)) -> MSFExcept m a b e +step f = try $ proc a -> do + n <- count -< () + (b, e) <- arrM (lift . f) -< a + _ <- throwOn' -< (n > (1 :: Int), e) + returnA -< b + +-- * Utilities definable in terms of 'MSFExcept' + +-- TODO This is possibly not the best location for these functions, +-- but moving them to Data.MonadicStreamFunction.Util would form an import cycle +-- that could only be broken by moving a few things to Data.MonadicStreamFunction.Core +-- (that probably belong there anyways). + +-- | Extract an '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 = safely $ do + msf <- once_ sfaction + safe msf + +-- | Reactimates an 'MSFExcept' until it throws an exception. +reactimateExcept :: Monad m => MSFExcept m () () e -> m e +reactimateExcept msfe = fromLeft (error "reactimateExcept: Received `Right`") + <$> (runExceptT $ reactimate $ runMSFExcept msfe) + +-- | Reactimates an 'MSF' until it returns 'True'. +reactimateB :: Monad m => MSF m () Bool -> m () +reactimateB sf = reactimateExcept $ try $ liftMSFTrans sf >>> throwOn () diff --git a/src/Control/Monad/Trans/MSF/GenLift.hs b/src/Control/Monad/Trans/MSF/GenLift.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/GenLift.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE Rank2Types #-} + +-- | More generic lifting combinators. +-- +-- This module contains more generic lifting combinators. It includes several +-- implementations, and obviously should be considered work in progress. The +-- goal is to make this both simple and conceptually understandable. +module Control.Monad.Trans.MSF.GenLift where + +import Control.Applicative +import Data.MonadicStreamFunction + +-- | Lifting combinator to move from one monad to another, if one has a +-- function to run computations in one monad into another. Note that, unlike a +-- polymorphic lifting function @forall a . m a -> m1 a@, this auxiliary +-- function needs to be a bit more structured. + +-- 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') + +-- | Lifting combinator to move from one monad to another, if one has a +-- function to run computations in one monad into another. Note that, unlike a +-- polymorphic lifting function @forall a . m a -> m1 a@, this auxiliary +-- function needs to be a bit more structured, although less structured than +-- 'lifterS'. + +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') + +-- | Lifting combinator to move from one monad to another, if one has a +-- function to run computations in one monad into another. Note that, unlike a +-- polymorphic lifting function @forall a . m a -> m1 a@, this auxiliary +-- function needs to be a bit more structured, although less structured than +-- 'lifterS'. +transG1 :: (Monad m1, 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 + +-- | More general lifting combinator that enables recovery. Note that, unlike a +-- polymorphic lifting function @forall a . m a -> m1 a@, this auxiliary +-- function needs to be a bit more structured, and produces a Maybe value. The +-- previous 'MSF' is used if a new one is not produced. +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 -> + +-- 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 diff --git a/src/Control/Monad/Trans/MSF/Maybe.hs b/src/Control/Monad/Trans/MSF/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/Maybe.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE Rank2Types #-} +{- | +The 'Maybe' monad is very versatile. It can stand for default arguments, +for absent values, and for (nondescript) exceptions. +The latter viewpoint is most natural in the context of 'MSF's. +-} +module Control.Monad.Trans.MSF.Maybe + ( module Control.Monad.Trans.MSF.Maybe + , module Control.Monad.Trans.Maybe + , maybeToExceptS + ) where + +-- External +import Control.Monad.Trans.Maybe + hiding (liftCallCC, liftCatch, liftListen, liftPass) -- Avoid conflicting exports + +-- Internal +import Control.Monad.Trans.MSF.Except +import Control.Monad.Trans.MSF.GenLift +import Data.MonadicStreamFunction + +-- * Throwing 'Nothing' as an exception ("exiting") + +-- | Throw the exception immediately. +exit :: Monad m => MSF (MaybeT m) a b +exit = arrM_ $ MaybeT $ return Nothing + +-- | Throw the exception when the condition becomes true on the input. +exitWhen :: Monad m => (a -> Bool) -> MSF (MaybeT m) a a +exitWhen condition = proc a -> do + _ <- exitIf -< condition a + returnA -< a + +-- | Exit when the incoming value is 'True'. +exitIf :: Monad m => MSF (MaybeT m) Bool () +exitIf = proc condition -> if condition + then exit -< () + else returnA -< () + +-- | @Just a@ is passed along, 'Nothing' causes the whole 'MSF' to exit. +maybeExit :: Monad m => MSF (MaybeT m) (Maybe a) a +maybeExit = inMaybeT + +-- | Embed a 'Maybe' value in the 'MaybeT' layer. Identical to 'maybeExit'. +inMaybeT :: Monad m => MSF (MaybeT m) (Maybe a) a +inMaybeT = arrM $ MaybeT . return + + +-- * Catching Maybe exceptions + +-- | Run the first @msf@ until the second one produces 'True' from the output of the first. +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 + +-- | When an exception occurs in the first 'msf', the second 'msf' is executed from there. +catchMaybe + :: Monad m + => MSF (MaybeT m) a b -> MSF m a b -> MSF m a b +catchMaybe msf1 msf2 = safely $ do + _ <- try $ maybeToExceptS msf1 + safe msf2 + +-- * Converting to and from 'MaybeT' + +-- | Converts a list to an 'MSF' in 'MaybeT', +-- which outputs an element of the list at each step, +-- throwing 'Nothing' when the list ends. +listToMaybeS :: Monad m => [b] -> MSF (MaybeT m) a b +listToMaybeS = foldr iPost exit + +-- * Running 'MaybeT' +-- | Remove the 'MaybeT' layer by outputting 'Nothing' when the exception occurs. +-- The continuation in which the exception occurred is then tested on the next input. +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) + +-- | Different implementation, to study performance. +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) + +-- mapMaybeS msf == runMaybeS (inMaybeT >>> lift mapMaybeS) + +{- +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) +-} + +-- | Reactimates an 'MSF' in the 'MaybeT' monad until it throws 'Nothing'. +reactimateMaybe + :: Monad m + => MSF (MaybeT m) () () -> m () +reactimateMaybe msf = reactimateExcept $ try $ maybeToExceptS msf + +-- | Run an 'MSF' fed from a list, discarding results. Useful when one needs to +-- combine effects and streams (i.e., for testing purposes). +embed_ :: Monad m => MSF m a () -> [a] -> m () + +embed_ msf as = reactimateMaybe $ listToMaybeS as >>> liftMSFTrans msf diff --git a/src/Control/Monad/Trans/MSF/RWS.hs b/src/Control/Monad/Trans/MSF/RWS.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/RWS.hs @@ -0,0 +1,45 @@ +-- | This module combines the wrapping and running functions +-- for the 'Reader', 'Writer' and 'State' monad layers in a single layer. +-- +-- It is based on the _strict_ 'RWS' monad 'Control.Monad.Trans.RWS.Strict', +-- so when combining it with other modules such as @mtl@'s, +-- the strict version has to be included, i.e. 'Control.Monad.RWS.Strict' +-- instead of 'Control.Monad.RWS' or 'Control.Monad.RWS.Lazy'. +module Control.Monad.Trans.MSF.RWS + ( module Control.Monad.Trans.MSF.RWS + , module Control.Monad.Trans.RWS.Strict + ) where + +-- External +import Control.Monad.Trans.RWS.Strict + hiding (liftCallCC, liftCatch) -- Avoid conflicting exports +import Data.Monoid +import Data.Functor ((<$>)) + +-- Internal +import Control.Monad.Trans.MSF.GenLift +import Data.MonadicStreamFunction + +-- * 'RWS' (Reader-Writer-State) monad + +-- | Run the 'RWST' layer by making the state variables explicit. +runRWSS :: (Monad m, Monoid w) + => MSF (RWST r w s m) a b + -> MSF 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') + +-- | Wrap an 'MSF' with explicit state variables in 'RWST' monad. +rwsS :: (Monad m, Monoid w) + => MSF m (r, s, a) (w, s, b) + -> MSF (RWST r w s m) a b +rwsS = lifterS wrapRWST + where + wrapRWST :: Monad m + => ((r, s, a) -> m ((w, s, b), c)) -> a -> RWST r w s m (b, c) + wrapRWST f a = RWST $ \r s -> do + ((w, s', b), c) <- f (r, s, a) + return ((b, c), s', w) diff --git a/src/Control/Monad/Trans/MSF/Random.hs b/src/Control/Monad/Trans/MSF/Random.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/Random.hs @@ -0,0 +1,74 @@ +-- | In this module, 'MSF's in a monad supporting random number generation +-- (i.e. having the 'RandT' layer in its stack) can be run. +-- Running means supplying an initial random number generator, +-- where the update of the generator at every random number generation +-- is already taken care of. +-- +-- Under the hood, 'RandT' is basically just 'StateT', +-- with the current random number generator as mutable state. + + +{-# LANGUAGE Arrows #-} +module Control.Monad.Trans.MSF.Random + ( + runRandS + , evalRandS + + , getRandomS + , getRandomsS + , getRandomRS + , getRandomRS_ + , getRandomsRS + , getRandomsRS_ + ) where + +-- External +import Control.Monad.Random + +-- Internal +import Data.MonadicStreamFunction + +-- | Run an 'MSF' in the 'RandT' random number monad transformer +-- by supplying an initial random generator. +-- Updates the generator every step. +runRandS :: (RandomGen g, Monad m) + => MSF (RandT g m) a b + -> g -- ^ The initial random number generator. + -> MSF m a (g, b) +runRandS msf g = MSF $ \a -> do + ((b, msf'), g') <- runRandT (unMSF msf a) g + return ((g', b), runRandS msf' g') + +-- | Evaluate an 'MSF' in the 'RandT' transformer, +-- i.e. extract possibly random values +-- by supplying an initial random generator. +-- Updates the generator every step but discharges the generator. +evalRandS :: (RandomGen g, Monad m) => MSF (RandT g m) a b -> g -> MSF m a b +evalRandS msf g = runRandS msf g >>> arr snd + +-- | Create a stream of random values. +getRandomS :: (MonadRandom m, Random b) => MSF m a b +getRandomS = arrM_ getRandom + + +-- | Create a stream of lists of random values. +getRandomsS :: (MonadRandom m, Random b) => MSF m a [b] +getRandomsS = arrM_ getRandoms + +-- | Create a stream of random values in a given fixed range. +getRandomRS :: (MonadRandom m, Random b) => (b, b) -> MSF m a b +getRandomRS range = arrM_ $ getRandomR range + +-- | Create a stream of random values in a given range, +-- where the range is specified on every tick. +getRandomRS_ :: (MonadRandom m, Random b) => MSF m (b, b) b +getRandomRS_ = arrM getRandomR + +-- | Create a stream of lists of random values in a given fixed range. +getRandomsRS :: (MonadRandom m, Random b) => (b, b) -> MSF m a [b] +getRandomsRS range = arrM_ $ getRandomRs range + +-- | Create a stream of lists of random values in a given range, +-- where the range is specified on every tick. +getRandomsRS_ :: (MonadRandom m, Random b) => MSF m (b, b) [b] +getRandomsRS_ = arrM getRandomRs diff --git a/src/Control/Monad/Trans/MSF/Reader.hs b/src/Control/Monad/Trans/MSF/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/Reader.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE Rank2Types #-} + +-- | 'MSF's with a 'Reader' monadic layer. +-- +-- This module contains functions to work with 'MSF's that include a 'Reader' +-- monadic layer. This includes functions to create new 'MSF's that include an +-- additional layer, and functions to flatten that layer out of the 'MSF`'s +-- transformer stack. +module Control.Monad.Trans.MSF.Reader + ( module Control.Monad.Trans.Reader + -- * 'Reader' 'MSF' running and wrapping. + , readerS + , runReaderS + , runReaderS_ + -- ** Alternative implementation using internal type. + , readerS' + , runReaderS' + -- ** Alternative implementation using generic lifting. + , runReaderS'' + ) where + +-- External +import Control.Monad.Trans.Reader + hiding (liftCallCC, liftCatch) -- Avoid conflicting exports + +-- Internal +import Control.Monad.Trans.MSF.GenLift +import Data.MonadicStreamFunction + +-- * Reader 'MSF' running and wrapping + +-- | Build an 'MSF' in the 'Reader' monad from one that takes the reader +-- environment as an extra input. This is the opposite of 'runReaderS'. +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') + +-- | Build an 'MSF' that takes an environment as an extra input from one on the +-- 'Reader' monad. This is the opposite of 'readerS'. +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') + + +-- | Build an 'MSF' /function/ that takes a fixed environment as additional +-- input, from an 'MSF' in the 'Reader' monad. +-- +-- This should be always equal to: +-- +-- @ +-- runReaderS_ msf s = arr (\a -> (s,a)) >>> runReaderS msf +-- @ +-- +-- although 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) + +-- ** Alternative implementation using internal type. + +-- TODO: One one should exist, ideally. + +-- | Alternative version of 'readerS'. +readerS' :: Monad m => MSF m (s, a) b -> MSF (ReaderT s m) a b +readerS' = lifterS wrapReaderT + +-- | Alternative version of 'runReaderS' wrapping/unwrapping functions. +runReaderS' :: Monad m => MSF (ReaderT s m) a b -> MSF m (s, a) b +runReaderS' = lifterS unwrapReaderT + +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 implementation using generic lifting. + +-- | Alternative version of 'runReaderS'. +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 +-} + + +-- Another alternative: +-- +-- 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 diff --git a/src/Control/Monad/Trans/MSF/State.hs b/src/Control/Monad/Trans/MSF/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/State.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE Rank2Types #-} +-- | 'MSF's with a 'State' monadic layer. +-- +-- This module contains functions to work with 'MSF's that include a 'State' +-- monadic layer. This includes functions to create new 'MSF's that include an +-- additional layer, and functions to flatten that layer out of the 'MSF`'s +-- transformer stack. +-- +-- It is based on the _strict_ state monad 'Control.Monad.Trans.State.Strict', +-- so when combining it with other modules such as @mtl@'s, +-- the strict version has to be included, i.e. 'Control.Monad.State.Strict' +-- instead of 'Control.Monad.State' or 'Control.Monad.State.Lazy'. +module Control.Monad.Trans.MSF.State + ( module Control.Monad.Trans.State.Strict + -- * 'State' 'MSF' running and wrapping + , stateS + , runStateS + , runStateS_ + , runStateS__ + -- ** Alternative implementation using 'lifterS' + , stateS' + , runStateS' + -- ** Alternative implementation using 'transS' + , runStateS'' + -- ** Alternative implementation using 'transG' + , runStateS''' + ) 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 + +-- * 'State' 'MSF' running and wrapping + +-- | Build an 'MSF' in the 'State' monad from one that takes the state as an +-- extra input. This is the opposite of 'runStateS'. +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') + +-- | Build an 'MSF' that takes a state as an extra input from one on the +-- 'State' monad. This is the opposite of 'stateS'. +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') + +-- | Build an 'MSF' /function/ that takes a fixed state as additional input, +-- from an 'MSF' in the 'State' monad, and outputs the new state with every +-- transformation step. +-- +-- This should be always equal to: +-- +-- @ +-- runStateS_ msf s = feedback s $ runStateS msf >>> arr (\(s,b) -> ((s,b), s)) +-- @ +-- +-- although possibly more efficient. + + +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') + +-- | Build an 'MSF' /function/ that takes a fixed state as additional +-- input, from an 'MSF' in the 'State' monad. +-- +-- This should be always equal to: +-- +-- @ +-- runStateS__ msf s = feedback s $ runStateS msf >>> arr (\(s,b) -> (b, s)) +-- @ +-- +-- although possibly more efficient. + + +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') + +-- * Alternative implementations +-- +-- ** Alternative using running/wrapping 'MSF' combinators using generic lifting + +-- ** Alternative using 'lifterS'. + +-- | Alternative implementation of 'stateS' using 'lifterS'. +stateS' :: 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') + +-- | Alternative implementation of 'runStateS' using 'lifterS'. +runStateS' :: 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) + +-- ** Alternative using 'transS'. + +-- | Alternative implementation of 'runStateS' using 'transS'. +runStateS'' :: 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 +-} + +-- ** Alternative using 'transG'. + +-- | Alternative implementation of 'runStateS' using 'transG'. +runStateS''' :: 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) diff --git a/src/Control/Monad/Trans/MSF/Writer.hs b/src/Control/Monad/Trans/MSF/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MSF/Writer.hs @@ -0,0 +1,104 @@ +-- | 'MSF's with a 'Writer' monadic layer. +-- +-- This module contains functions to work with 'MSF's that include a 'Writer' +-- monadic layer. This includes functions to create new 'MSF's that include an +-- additional layer, and functions to flatten that layer out of the 'MSF`'s +-- transformer stack. +-- +-- It is based on the _strict_ writer monad 'Control.Monad.Trans.Writer.Strict', +-- so when combining it with other modules such as @mtl@'s, +-- the strict version has to be included, i.e. 'Control.Monad.Writer.Strict' +-- instead of 'Control.Monad.Writer' or 'Control.Monad.Writer.Lazy'. +module Control.Monad.Trans.MSF.Writer + ( module Control.Monad.Trans.Writer.Strict + -- * 'Writer' 'MSF' running and wrapping + , writerS + , runWriterS + + -- ** Alternative implementation using 'lifterS' + , writerS' + , runWriterS' + + -- ** Alternative implementation using 'transS' + , writerS'' + , runWriterS'' + ) 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' 'MSF' running and wrapping + +-- | Build an 'MSF' in the 'Writer' monad from one that produces the log as an +-- extra output. This is the opposite of 'runWriterS'. +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') + +-- | Build an 'MSF' that produces the log as an extra output from one on the +-- 'Writer' monad. This is the opposite of 'writerS'. +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 + +-- ** Alternative implementation using 'lifterS' + +-- | Alternative implementation of 'writerS' using 'lifterS'. +writerS' :: (Monad m, Monoid s) => MSF m a (s, b) -> MSF (WriterT s m) a b +writerS' = lifterS wrapMSFWriterT + +-- | Alternative implementation of 'runWriterS' using 'lifterS'. +runWriterS' :: (Monoid s, Monad m) => MSF (WriterT s m) a b -> MSF m a (s, b) +runWriterS' = lifterS unwrapMSFWriterT + +-- ** Alternative implementation using 'transS' + +-- | Alternative implementation of 'writerS' using 'transS'. +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') + +-- | Alternative implementation of 'runWriterS' using 'transS'. +runWriterS'' :: (Monoid s, 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) diff --git a/src/Data/MonadicStreamFunction.hs b/src/Data/MonadicStreamFunction.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction.hs @@ -0,0 +1,59 @@ +-- | Monadic Stream Functions are synchronized stream functions +-- with side effects. +-- +-- 'MSF's 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. +-- +-- 'MSF's 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 'MSF's 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. +-- +-- 'MSF's 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 'MSF's, see: +-- +-- (mirror: ). +-- +-- Apart from the modules exported, this module exports instances from: +-- +-- - "Data.MonadicStreamFunction.Instances.ArrowChoice" +-- - "Data.MonadicStreamFunction.Instances.ArrowLoop" +-- - "Data.MonadicStreamFunction.Instances.ArrowPlus" + +module Data.MonadicStreamFunction + ( module Control.Arrow + , module Data.MonadicStreamFunction.Core + , module Data.MonadicStreamFunction.Util + ) + where + +-- External + +import Control.Arrow + +-- Internal + +import Data.MonadicStreamFunction.Core +import Data.MonadicStreamFunction.Util + +-- Internal (Instances) + +import Data.MonadicStreamFunction.Instances.ArrowChoice () +import Data.MonadicStreamFunction.Instances.ArrowLoop () +import Data.MonadicStreamFunction.Instances.ArrowPlus () diff --git a/src/Data/MonadicStreamFunction/Async.hs b/src/Data/MonadicStreamFunction/Async.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Async.hs @@ -0,0 +1,65 @@ +-- | This module contains operations on monadic streams that are asynchronous, +-- i.e. that change the speed at which data enters or leaves the 'MSF'. + +module Data.MonadicStreamFunction.Async where + +-- Internal +import Data.MonadicStreamFunction.Core +import Data.MonadicStreamFunction.Util (MStream) + +{- | +Concatenates a monadic stream of lists to a monadic stream. +The stream of lists will be called exactly when new data is needed. + +Example: + +>>> let intstream = arrM_ $ putStrLn "Enter a list of Ints:" >> readLn :: MStream IO [Int] +>>> reactimate $ concatS intstream >>> arrM print +Enter a list of Ints: +[1,2,33] +1 +2 +33 +Enter a list of Ints: +[] +Enter a list of Ints: +[] +Enter a list of Ints: +[1,2] +1 +2 +Enter a list of Ints: +... + +Beware that @concatS msf@ becomes unproductive when @msf@ starts outputting empty lists forever. +This is ok: + +>>> let boolToList b = if b then ["Yes"] else [] +>>> let everyOddEmpty = count >>> arr (even >>> boolToList) +>>> reactimate $ concatS everyOddEmpty >>> arrM print +"Yes" +"Yes" +"Yes" +"Yes" +"Yes" +... + +But this will be caught in a loop: + +>>> let after3Empty = count >>> arr ((<= 3) >>> boolToList) +>>> reactimate $ concatS after3Empty >>> arrM print +"Yes" +"Yes" +"Yes" +^CInterrupted. +-} +concatS :: Monad m => MStream m [b] -> MStream m b +concatS msf = MSF $ \_ -> tick msf [] + where + tick msf' (b:bs) = return (b, MSF $ \_ -> tick msf' bs) + tick msf' [] = do + (bs, msf'') <- unMSF msf' () + tick msf'' bs +-- TODO Maybe this can be written more nicely with exceptions? +-- Similarly takeS :: Int -> MSF m a b -> MSFExcept m a b () throws an exception after n ticks +-- Or with merge? diff --git a/src/Data/MonadicStreamFunction/Core.hs b/src/Data/MonadicStreamFunction/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Core.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE Rank2Types #-} +-- | Monadic Stream Functions are synchronized stream functions +-- with side effects. +-- +-- 'MSF's 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. +-- +-- 'MSF's 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 'MSF's 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. +-- +-- 'MSF's 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 'MSF's, see: +-- +-- (mirror: ). + +-- 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 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 +-- module. +-- +-- By separating some instances and functions in other modules , we can +-- easily understand what is the essential idea and then analyse how it +-- is affected by an extension. It also helps demonstrate that something +-- works for MSFs + ArrowChoice, or MSFs + ArrowLoop, etc. +-- +-- 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 here +-- individually, but the main module instead. +module Data.MonadicStreamFunction.Core where + +-- External +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) + +-- * Definitions + +-- | Stepwise, side-effectful 'MSF's without implicit knowledge of time. +-- +-- 'MSF's 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 definition for 'Category'. Defines 'id' and '.'. +instance Monad m => Category (MSF m) where + id = go + 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') + +-- | 'Arrow' instance for 'MSF's. +instance Monad m => Arrow (MSF m) where + + arr f = go + where go = MSF $ \a -> return (f a, go) + + first sf = MSF $ \(a,c) -> do + (b, sf') <- unMSF sf a + b `seq` return ((b, c), first sf') + +-- | 'Functor' instance for 'MSF's. +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) + +-- | 'Applicative' instance for 'MSF's. +instance 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 ($)) + +-- * Monadic computations and 'MSF's + +-- ** Lifting point-wise computations + +-- | Apply a monadic transformation to every element of the input stream. +-- +-- Generalisation of 'arr' from 'Arrow' to monadic functions. +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 .) + +-- ** Lifting 'MSF's + +-- *** Lifting across monad stacks + +-- | Lift inner monadic actions in monad stacks. + +liftMSFTrans :: (MonadTrans t, Monad m, Monad (t m)) + => MSF m a b + -> MSF (t m) a b +liftMSFTrans = liftMSFPurer lift + +-- | 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 = liftMSFPurer liftBase + +-- *** Generic 'MSF' Lifting + +-- IPerez: There is an alternative signature for liftMStreamPurer that also +-- works, and makes the code simpler: +-- +-- 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: +-- +-- liftMSFTrans = liftMSFPurer lift +-- liftMSFBase = liftMSFPurer liftBase +-- +-- We could also define a strict version of liftMSFPurer as follows: +-- +-- liftMStreamPurer' f = liftMSFPurer (f >=> whnfVal) +-- where whnfVal p@(b,_) = b `seq` return p +-- +-- and leave liftMSFPurer as a lazy version (by default). + +-- | Lifting purer monadic actions (in an arbitrary way) +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') + +-- * Delays + +-- | 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 -> MSF m a a +delay = iPre + +-- * Switching + +-- | 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 given 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 + +-- | 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') + +-- * Execution/simulation + +-- | Apply a monadic stream function to a list. +-- +-- Because the result is in a monad, it may be necessary to +-- traverse the whole list to evaluate the value in the results to WHNF. +-- For example, if the monad is the maybe monad, this may not produce anything +-- if the 'MSF' produces 'Nothing' at any point, so the output stream cannot +-- consumed progressively. +-- +-- 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 => MSF m a b -> [a] -> m [b] +embed _ [] = return [] +embed sf (a:as) = do + (b, sf') <- unMSF sf a + bs <- embed sf' as + return (b:bs) + +-- | Run an 'MSF' indefinitely passing a unit-carrying input stream. +reactimate :: Monad m => MSF m () () -> m () +reactimate sf = do + (_, sf') <- unMSF sf () + reactimate sf' diff --git a/src/Data/MonadicStreamFunction/Instances/ArrowChoice.hs b/src/Data/MonadicStreamFunction/Instances/ArrowChoice.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Instances/ArrowChoice.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Instance of 'ArrowChoice' for Monadic Stream Functions ('MSF'). +-- +-- Import this module to include that (orphan) instance. +module Data.MonadicStreamFunction.Instances.ArrowChoice where + +import Control.Arrow + +import Data.MonadicStreamFunction.Core + +-- | 'ArrowChoice' instance for MSFs. +instance Monad m => ArrowChoice (MSF m) where + left :: MSF m a b -> MSF m (Either a c) (Either b c) + left sf = MSF f + where + f (Left a) = do (b, sf') <- unMSF sf a + return (Left b, left sf') + f (Right c) = return (Right c, left sf) diff --git a/src/Data/MonadicStreamFunction/Instances/ArrowLoop.hs b/src/Data/MonadicStreamFunction/Instances/ArrowLoop.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Instances/ArrowLoop.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecursiveDo #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Instance of 'ArrowLoop' for Monadic Stream Functions ('MSF'). +-- +-- Import this module to include that (orphan) instance. +-- +-- This is only defined for monads that are instances of 'MonadFix'. +module Data.MonadicStreamFunction.Instances.ArrowLoop where + +import Data.MonadicStreamFunction.Core + +-- External +import Control.Arrow +import Control.Monad.Fix + +-- | 'ArrowLoop' instance for MSFs. The monad must be an instance of +-- 'MonadFix'. +instance MonadFix m => ArrowLoop (MSF m) where + loop :: MSF m (b, d) (c, d) -> MSF m b c + loop sf = MSF $ \a -> do + rec ((b,c), sf') <- unMSF sf (a, c) + return (b, loop sf') diff --git a/src/Data/MonadicStreamFunction/Instances/ArrowPlus.hs b/src/Data/MonadicStreamFunction/Instances/ArrowPlus.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Instances/ArrowPlus.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Instance of 'ArrowPlus' for Monadic Stream Functions ('MSF'). +-- +-- Import this module to include that (orphan) instance. +-- +-- This is only defined for monads that are instances of 'MonadPlus'. +module Data.MonadicStreamFunction.Instances.ArrowPlus where + +-- base +import Control.Arrow +import Control.Monad +import Control.Applicative + +-- dunai +import Data.MonadicStreamFunction.Core + +-- | Instance of 'ArrowZero' for Monadic Stream Functions ('MSF'). +-- The monad must be an instance of 'MonadPlus'. +instance (Monad m, MonadPlus m) => ArrowZero (MSF m) where + zeroArrow = MSF $ const mzero + +-- | Instance of 'ArrowPlus' for Monadic Stream Functions ('MSF'). +-- The monad must be an instance of 'MonadPlus'. +instance (Monad m, MonadPlus m) => ArrowPlus (MSF m) where + sf1 <+> sf2 = MSF $ \a -> unMSF sf1 a `mplus` unMSF sf2 a + +instance (Monad m, MonadPlus m) => Alternative (MSF m a) where + empty = zeroArrow + (<|>) = (<+>) diff --git a/src/Data/MonadicStreamFunction/Instances/Num.hs b/src/Data/MonadicStreamFunction/Instances/Num.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Instances/Num.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Number instances for 'MSF's that produce numbers. This allows you to use +-- numeric operators with 'MSF's that output numbers, for example, +-- you can write: +-- +-- @ +-- msf1 :: MSF Input Double -- defined however you want +-- msf2 :: MSF Input Double -- defined however you want +-- msf3 :: MSF Input Double +-- msf3 = msf1 + msf2 +-- @ +-- +-- instead of +-- +-- @ +-- msf3 = (msf1 &&& msf2) >>> arr (uncurry (+)) +-- @ +-- +-- Instances are provided for the type classes 'Num', 'Fractional' +-- and 'Floating'. + +module Data.MonadicStreamFunction.Instances.Num where + +import Control.Arrow.Util +import Data.MonadicStreamFunction.Core + +-- | 'Num' instance for 'MSF's. +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 + +-- | 'Fractional' instance for 'MSF's. +instance (Monad m, Fractional b) => Fractional (MSF m a b) where + fromRational = constantly . fromRational + (/) = elementwise2 (/) + recip = elementwise recip + +-- | 'Floating' instance for 'MSF's. +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 diff --git a/src/Data/MonadicStreamFunction/Instances/VectorSpace.hs b/src/Data/MonadicStreamFunction/Instances/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Instances/VectorSpace.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | 'VectorSpace' instances for 'MSF's that produce vector spaces. This allows +-- you to use vector operators with 'MSF's that output vectors, for example, you +-- can write: +-- +-- @ +-- msf1 :: MSF Input (Double, Double) -- defined however you want +-- msf2 :: MSF Input (Double, Double) -- defined however you want +-- msf3 :: MSF Input (Double, Double) +-- msf3 = msf1 ^+^ msf2 +-- @ +-- +-- instead of +-- +-- @ +-- msf3 = (msf1 &&& msf2) >>> arr (uncurry (^+^)) +-- @ +-- +-- +-- Instances are provided for the type classes 'RModule' and 'VectorSpace'. +module Data.MonadicStreamFunction.Instances.VectorSpace where + +import Control.Arrow +import Control.Arrow.Util +import Data.MonadicStreamFunction.Core +import Data.VectorSpace + +-- These conflict with Data.VectorSpace.Instances + +-- | R-module instance for 'MSF's. +instance (Monad m, RModule v) => RModule (MSF m a v) where + type Groundring (MSF m a v) = Groundring v + zeroVector = constantly zeroVector + r *^ msf = msf >>^ (r *^) + negateVector = (>>^ negateVector) + (^+^) = elementwise2 (^+^) + (^-^) = elementwise2 (^-^) + +-- | Vector-space instance for 'MSF's. +instance (Monad m, VectorSpace v) => VectorSpace (MSF m a v) where + msf ^/ r = msf >>^ (^/ r) diff --git a/src/Data/MonadicStreamFunction/Parallel.hs b/src/Data/MonadicStreamFunction/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Parallel.hs @@ -0,0 +1,23 @@ +-- | Versions of arrow combinators that run things in parallel using 'par', if +-- possible. +module Data.MonadicStreamFunction.Parallel where + +-- External +import Control.Arrow +import GHC.Conc + +-- Internal +import Data.MonadicStreamFunction + +-- | Run two 'MSF's in parallel, taking advantage of parallelism if +-- possible. This is the parallel version of '***'. + +(*|*) :: 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') + +-- | Parallel version of '&&&'. +(&|&) :: Monad m => MSF m a b -> MSF m a c -> MSF m a (b, c) +msf1 &|& msf2 = arr (\a -> (a, a)) >>> (msf1 *|* msf2) diff --git a/src/Data/MonadicStreamFunction/ReactHandle.hs b/src/Data/MonadicStreamFunction/ReactHandle.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/ReactHandle.hs @@ -0,0 +1,34 @@ +-- | 'ReactHandle's. +-- +-- 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'. +-- The 'MSF' may not require input or produce output data, +-- all such data must be handled through side effects +-- (such as wormholes). +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 external loop at every cycle. +react :: MonadIO m => ReactHandle m -> m () +react handle = do + msf <- liftIO $ readIORef handle + (_, msf') <- unMSF msf () + liftIO $ writeIORef handle msf' diff --git a/src/Data/MonadicStreamFunction/Util.hs b/src/Data/MonadicStreamFunction/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/Util.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE Arrows #-} +-- | Useful auxiliary functions and definitions. +module Data.MonadicStreamFunction.Util where + +-- External +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.MonadicStreamFunction.Instances.ArrowChoice () +import Data.VectorSpace + +-- * Streams and sinks + +-- | A stream is an 'MSF' that produces outputs, while ignoring the input. +-- It can obtain the values from a monadic context. +type MStream m a = MSF m () a + +-- | A sink is an 'MSF' that consumes inputs, while producing no output. +-- It can consume the values with side effects. +type MSink m a = MSF m a () + +-- * Lifting + +-- | Pre-inserts an input sample. +{-# DEPRECATED insert "Don't use this. arrM id instead" #-} +insert :: Monad m => MSF m (m a) a +insert = arrM id + +-- | Lifts a computation into a Stream. +arrM_ :: Monad m => m b -> MSF m a b +arrM_ = arrM . const + +-- | Lift the first 'MSF' into the monad of the second. +(^>>>) :: MonadBase m1 m2 => MSF m1 a b -> MSF m2 b c -> MSF m2 a c +sf1 ^>>> sf2 = liftMSFBase sf1 >>> sf2 +{-# INLINE (^>>>) #-} + +-- | Lift the second 'MSF' into the monad of the first. +(>>>^) :: MonadBase m1 m2 => MSF m2 a b -> MSF m1 b c -> MSF m2 a c +sf1 >>>^ sf2 = sf1 >>> liftMSFBase sf2 +{-# INLINE (>>>^) #-} + +-- * Analogues of 'map' and 'fmap' + +-- | Apply an 'MSF' to every input. +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'') + +-- | Apply an 'MSF' to every input. Freezes temporarily if the input is +-- 'Nothing', and continues as soon as a 'Just' is received. +mapMaybeS :: Monad m => MSF m a b -> MSF m (Maybe a) (Maybe b) +mapMaybeS msf = proc maybeA -> case maybeA of + Just a -> arr Just <<< msf -< a + Nothing -> returnA -< Nothing + +-- * Adding side effects + +-- | Applies a function to produce an additional side effect and passes the +-- input unchanged. +withSideEffect :: Monad m => (a -> m b) -> MSF m a a +withSideEffect method = (id &&& arrM method) >>> arr fst + +-- | Produces an additional side effect and passes the input unchanged. +withSideEffect_ :: Monad m => m b -> MSF m a a +withSideEffect_ method = withSideEffect $ const method + +-- * Delays + +-- See also: 'iPre' + +-- | Preprends a fixed output to an 'MSF'. The first input is completely +-- ignored. +iPost :: Monad m => b -> MSF m a b -> MSF m a b +iPost b sf = MSF $ \_ -> return (b, sf) + +-- | Preprends a fixed output to an 'MSF', shifting the output. +next :: Monad m => b -> MSF m a b -> MSF m a b +next b sf = sf >>> delay b + +-- | Buffers and returns the elements in FIFO order, +-- returning 'Nothing' whenever the buffer is empty. +fifo :: Monad m => MSF m [a] (Maybe a) +fifo = feedback [] $ proc (as, accum) -> do + let accum' = accum ++ as + returnA -< case accum' of + [] -> (Nothing, []) + (a : as) -> (Just a , as) + +-- * Edge detectors + +-- | Emits 'True' (once) when the input value changes +-- to the given argument, from any other value. +-- +-- (If the input is equal to the given argument on the first tick, +-- 'True' is also emitted. +-- ) +edgeTo + :: (Monad m, Eq a) + => a -- ^ The new value that the signal should have _now_ to trigger the edge + -> MSF m a Bool +edgeTo aNew = proc a -> do + maPrevious <- delay Nothing -< Just a + returnA -< a == aNew && maPrevious /= Just aNew + +-- | Like 'edgeTo', but triggers as soon when the input changes +-- from the given argument to any value that is _not_ equal to it. +-- +-- (Does not trigger on the first tick.) +edgeFrom + :: (Monad m, Eq a) + => a -- ^ The old value that the signal should have directly before the edge + -> MSF m a Bool +edgeFrom aOld = proc a -> do + maPrevious <- delay Nothing -< Just a + returnA -< a /= aOld && maPrevious == Just aOld + +-- | Triggers when both 'edgeTo' and 'edgeFrom' would trigger, +-- i.e. when the input changes from the first given value to the second. +edgeFromTo + :: (Monad m, Eq a) + => a -- ^ The old value that the signal should have directly before the edge + -> a -- ^ The new value that the signal should have _now_ to trigger the edge + -> MSF m a Bool +edgeFromTo aOld aNew = edgeFrom aOld &&& edgeTo aNew >>> arr (uncurry (&&)) + +-- | Emits 'True' (once) when the input value evaluates to 'True' +-- under the given predicate. +-- +-- Example usage: @edgeWhen (> 1)@ +edgeWhen + :: (Monad m, Eq a) + => (a -> Bool) -- ^ The predicate that is to be evaluated on the incoming signal + -> MSF m a Bool +edgeWhen predicate = arr predicate >>> edgeTo True + + + +-- * Folding + +-- ** Folding for 'VectorSpace' instances + +-- | Count the number of simulation steps. Produces 1, 2, 3,... +count :: (Num n, Monad m) => MSF m a n +count = arr (const 1) >>> accumulateWith (+) 0 + +-- | Sums the inputs, starting from zero. +sumS :: (RModule v, Monad m) => MSF m v v +sumS = sumFrom zeroVector + +-- | Sums the inputs, starting from an initial vector. +sumFrom :: (RModule v, Monad m) => v -> MSF m v v +sumFrom = accumulateWith (^+^) + +-- ** Folding for monoids + +-- | Accumulate the inputs, starting from 'mempty'. +mappendS :: (Monoid n, Monad m) => MSF m n n +mappendS = mappendFrom mempty +{-# INLINE mappendS #-} + +-- | Accumulate the inputs, starting from an initial monoid value. +mappendFrom :: (Monoid n, Monad m) => n -> MSF m n n +mappendFrom = accumulateWith mappend + +-- ** Generic folding \/ accumulation + +-- | Applies a function to the input and an accumulator, +-- outputting the updated accumulator. +-- Equal to @\f s0 -> feedback s0 $ arr (uncurry f >>> dup)@. +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') + +-- | Applies a transfer function to the input and an accumulator, +-- returning the updated accumulator and output. +mealy :: Monad m => (a -> s -> (b, s)) -> s -> MSF m a b +mealy f s0 = feedback s0 $ arr $ uncurry f + +-- * Unfolding + +-- | Generate outputs using a step-wise generation function and an initial +-- value. +unfold :: Monad m => (a -> (b, a)) -> a -> MSF m arbitrary b +unfold f a = feedback a (arr (snd >>> f)) + +-- | Generate outputs using a step-wise generation Kleisli arrow and an initial +-- value. +unfoldM :: Monad m => (a -> m (b, a)) -> a -> MSF m arbitrary b +unfoldM f a = feedback a (arrM (snd >>> f)) + +-- | Generate outputs using a step-wise generation function and an initial +-- value. Version of 'unfold' in which the output and the new accumulator +-- are the same. Should be equal to @\f a -> unfold (f >>> dup) a@. +repeatedly :: Monad m => (a -> a) -> a -> MSF m () a +repeatedly f = unfold $ f >>> dup + where + dup a = (a, a) + + +-- * Debugging + +-- | Outputs every input sample, with a given message prefix. +trace :: Show a => String -> MSF IO a a +trace = traceWith putStrLn + +-- | Outputs every input sample, with a given message prefix, using an +-- auxiliary printing function. +traceWith :: (Monad m, Show a) => (String -> m ()) -> String -> MSF m a a +traceWith method msg = + withSideEffect (method . (msg ++) . show) + +-- | Outputs every input sample, with a given message prefix, using an +-- auxiliary printing function, when a condition is met. +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 + +-- | Outputs every input sample, with a given message prefix, when a condition +-- is met, and waits for some input \/ enter to continue. +pauseOn :: Show a => (a -> Bool) -> String -> MSF IO a a +pauseOn cond = traceWhen cond $ \s -> print s >> getLine >> return () diff --git a/src/Data/VectorSpace.hs b/src/Data/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Data/VectorSpace.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Module : Data.VectorSpace +-- Copyright : (c) Ivan Perez and Manuel Bärenz +-- License : See the LICENSE file in the distribution. +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Vector space type relation and basic instances. +-- Heavily inspired by Yampa's @FRP.Yampa.VectorSpace@ module. + +module Data.VectorSpace where + +------------------------------------------------------------------------------ +-- * Vector space classes +------------------------------------------------------------------------------ + +infixr 6 *^ +infixl 6 ^/ +infix 6 `dot` +infixl 5 ^+^, ^-^ + +-- | R-modules. +-- A module @v@ over a ring @Groundring v@ +-- is an abelian group with a linear multiplication. +-- The hat @^@ denotes the side of an operation +-- on which the vector stands, +-- i.e. @a *^ v@ for @v@ a vector. +-- +-- A minimal definition should include the type 'Groundring' and the +-- implementations of 'zeroVector', '^+^', and one of '*^' or '^*'. +-- +-- The following laws must be satisfied: +-- +-- * @v1 ^+^ v2 == v2 ^+^ v1@ +-- * @a *^ zeroVector == zeroVector@ +-- * @a *^ (v1 ^+^ v2) == a *^ v1 ^+^ a*^ v2 +-- * @a *^ v == v ^* a@ +-- * @negateVector v == (-1) *^ v@ +-- * @v1 ^-^ v2 == v1 ^+^ negateVector v2@ +class Num (Groundring v) => RModule v where + type Groundring v + zeroVector :: v + + (*^) :: Groundring v -> v -> v + (*^) = flip (^*) + + (^*) :: v -> Groundring v -> v + (^*) = flip (*^) + + negateVector :: v -> v + negateVector v = (-1) *^ v + + (^+^) :: v -> v -> v + + (^-^) :: v -> v -> v + v1 ^-^ v2 = v1 ^+^ negateVector v2 + +-- Maybe norm and normalize should not be class methods, in which case +-- the constraint on the coefficient space (a) should (or, at least, could) +-- be Fractional (roughly a Field) rather than Floating. + +-- Minimal instance: zeroVector, (*^), (^+^), dot +-- class Fractional (Groundfield v) => VectorSpace v where + +-- | A vector space is a module over a field, +-- i.e. a commutative ring with inverses. +-- +-- It needs to satisfy the axiom +-- @v ^/ a == (1/a) *^ v@, +-- which is the default implementation. +class (Fractional (Groundring v), RModule v) => VectorSpace v where + (^/) :: v -> Groundfield v -> v + v ^/ a = (1/a) *^ v + +-- | The ground ring of a vector space is required to be commutative +-- and to possess inverses. +-- It is then called the "ground field". +-- Commutativity amounts to the law @a * b = b * a@, +-- and the existence of inverses is given +-- by the requirement of the 'Fractional' type class. +type Groundfield v = Groundring v + +-- | An inner product space is a module with an inner product, +-- i.e. a map @dot@ satisfying +-- +-- * @v1 `dot` v2 == v2 `dot` v1@ +-- * @(v1 ^+^ v2) `dot` v3 == v1 `dot` v3 ^+^ v2 `dot` v3@ +-- * @(a *^ v1) `dot` v2 == a *^ v1 `dot` v2@ +class RModule v => InnerProductSpace v where + dot :: v -> v -> Groundfield v + +-- | A normed space is a module with a norm, +-- i.e. a function @norm@ satisfying +-- +-- * @norm (a ^* v) = a ^* norm v@ +-- * @norm (v1 ^+^ v2) <= norm v1 ^+^ norm v2@ +-- (the "triangle inequality") +-- +-- A typical example is @sqrt (v `dot` v)@, +-- for an inner product space. +class (Floating (Groundfield v), InnerProductSpace v, VectorSpace v) => NormedSpace v where + norm :: v -> Groundfield v + norm v = sqrt $ v `dot` v + +-- | Divides a vector by its norm, resulting in a vector of norm 1. +-- Throws an error on vectors with norm 0. +normalize :: (Eq (Groundfield v), NormedSpace v) => v -> v +normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector" + where nv = norm v + + +----------------------------- +-- Instances for scalar types +----------------------------- + + +instance RModule Int where + type Groundring Int = Int + (^+^) = (+) + (^*) = (*) + zeroVector = 0 + +instance RModule Integer where + type Groundring Integer = Integer + (^+^) = (+) + (^*) = (*) + zeroVector = 0 + +instance RModule Double where + type Groundring Double = Double + (^+^) = (+) + (^*) = (*) + zeroVector = 0 + +instance RModule Float where + type Groundring Float = Float + (^+^) = (+) + (^*) = (*) + zeroVector = 0 + +instance VectorSpace Double where + +instance VectorSpace Float where + +----------------------- +-- Instances for tuples +----------------------- + + +instance + ( Groundring a ~ Groundring b + , RModule a, RModule b + ) => RModule (a, b) where + type Groundring (a, b) = Groundring a + zeroVector = (zeroVector, zeroVector) + (a, b) ^* x = (a ^* x, b ^* x) + (a1, b1) ^+^ (a2, b2) = (a1 ^+^ a2, b1 ^+^ b2) + +instance + (Groundfield a ~ Groundfield b + , VectorSpace a, VectorSpace b + ) => VectorSpace (a, b) where + (a, b) ^/ x = (a ^/ x, b ^/ x) + +instance (Groundfield a ~ Groundfield b, InnerProductSpace a, InnerProductSpace b) => InnerProductSpace (a, b) where + (a1, b1) `dot` (a2, b2) = (a1 `dot` a2) + (b1 `dot` b2) + +instance (Groundfield a ~ Groundfield b, NormedSpace a, NormedSpace b) => NormedSpace (a, b) where + +-- ** Utilities to work with n-tuples for n = 3, 4, 5 + +break3Tuple :: (a, b, c) -> ((a, b), c) +break3Tuple (a, b, c) = ((a, b), c) + +join3Tuple :: ((a, b), c) -> (a, b, c) +join3Tuple ((a, b), c) = (a, b, c) + +break4Tuple :: (a, b, c, d) -> ((a, b), (c, d)) +break4Tuple (a, b, c, d) = ((a, b), (c, d)) + +join4Tuple :: ((a, b), (c, d)) -> (a, b, c, d) +join4Tuple ((a, b), (c, d)) = (a, b, c, d) + +break5Tuple :: (a, b, c, d, e) -> ((a, b), (c, d, e)) +break5Tuple (a, b, c, d, e) = ((a, b), (c, d, e)) + +join5Tuple :: ((a, b), (c, d, e)) -> (a, b, c, d, e) +join5Tuple ((a, b), (c, d, e)) = (a, b, c, d, e) + + + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , RModule a, RModule b, RModule c + ) => RModule (a, b, c) where + type Groundring (a, b, c) = Groundring a + zeroVector = join3Tuple zeroVector + a *^ v = join3Tuple $ a *^ (break3Tuple v) + v1 ^+^ v2 = join3Tuple $ break3Tuple v1 ^+^ break3Tuple v2 + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , VectorSpace a, VectorSpace b, VectorSpace c + ) => VectorSpace (a, b, c) where + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , InnerProductSpace a, InnerProductSpace b, InnerProductSpace c + ) => InnerProductSpace (a, b, c) where + v1 `dot` v2 = break3Tuple v1 `dot` break3Tuple v2 + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , NormedSpace a, NormedSpace b, NormedSpace c + ) => NormedSpace (a, b, c) where + + + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , RModule a, RModule b, RModule c, RModule d + ) => RModule (a, b, c, d) where + type Groundring (a, b, c, d) = Groundring a + zeroVector = join4Tuple zeroVector + a *^ v = join4Tuple $ a *^ (break4Tuple v) + v1 ^+^ v2 = join4Tuple $ break4Tuple v1 ^+^ break4Tuple v2 + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , VectorSpace a, VectorSpace b, VectorSpace c, VectorSpace d + ) => VectorSpace (a, b, c, d) where + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , InnerProductSpace a, InnerProductSpace b + , InnerProductSpace c, InnerProductSpace d + ) => InnerProductSpace (a, b, c, d) where + v1 `dot` v2 = break4Tuple v1 `dot` break4Tuple v2 + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , NormedSpace a, NormedSpace b, NormedSpace c, NormedSpace d + ) => NormedSpace (a, b, c, d) where + + + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , Groundring a ~ Groundring e + , RModule a, RModule b, RModule c, RModule d, RModule e + ) => RModule (a, b, c, d, e) where + type Groundring (a, b, c, d, e) = Groundring a + zeroVector = join5Tuple zeroVector + a *^ v = join5Tuple $ a *^ (break5Tuple v) + v1 ^+^ v2 = join5Tuple $ break5Tuple v1 ^+^ break5Tuple v2 + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , Groundring a ~ Groundring e + , VectorSpace a, VectorSpace b, VectorSpace c, VectorSpace d, VectorSpace e + ) => VectorSpace (a, b, c, d, e) where + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , Groundring a ~ Groundring e + , InnerProductSpace a, InnerProductSpace b, InnerProductSpace c + , InnerProductSpace d, InnerProductSpace e + ) => InnerProductSpace (a, b, c, d, e) where + v1 `dot` v2 = break5Tuple v1 `dot` break5Tuple v2 + +instance + ( Groundring a ~ Groundring b + , Groundring a ~ Groundring c + , Groundring a ~ Groundring d + , Groundring a ~ Groundring e + , NormedSpace a, NormedSpace b, NormedSpace c, NormedSpace d, NormedSpace e + ) => NormedSpace (a, b, c, d, e) where + + +-- * Vector spaces from arbitrary 'Fractional's + +-- | Wrap an arbitrary 'Fractional' in this newtype +-- in order to get 'VectorSpace', and related instances. +newtype FractionalVectorSpace a = FractionalVectorSpace { getFractional :: a } + deriving (Num, Fractional) + + +instance Num a => RModule (FractionalVectorSpace a) where + type Groundring (FractionalVectorSpace a) = a + v1 ^+^ v2 = FractionalVectorSpace $ getFractional v1 + getFractional v2 + v ^* a = FractionalVectorSpace $ getFractional v * a + zeroVector = FractionalVectorSpace 0 + +instance Fractional a => VectorSpace (FractionalVectorSpace a) where + +instance Num a => InnerProductSpace (FractionalVectorSpace a) where + v1 `dot` v2 = getFractional v1 * getFractional v2 + +instance Floating a => NormedSpace (FractionalVectorSpace a) where