diff --git a/dunai.cabal b/dunai.cabal --- a/dunai.cabal +++ b/dunai.cabal @@ -1,5 +1,5 @@ name: dunai -version: 0.4.0.0 +version: 0.5 synopsis: Generalised reactive framework supporting classic, arrowized and monadic FRP. homepage: https://github.com/ivanperez-keera/dunai description: @@ -56,10 +56,10 @@ 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 @@ -70,15 +70,13 @@ Data.MonadicStreamFunction.Instances.ArrowPlus Data.MonadicStreamFunction.Instances.Num Data.MonadicStreamFunction.Instances.VectorSpace + Data.MonadicStreamFunction.InternalCore Data.MonadicStreamFunction.Parallel Data.MonadicStreamFunction.ReactHandle Data.MonadicStreamFunction.Util -- Auxiliary definitions Data.VectorSpace - Data.VectorSpace.Fractional - Data.VectorSpace.Tuples - Data.VectorSpace.Specific other-modules: Control.Arrow.Util @@ -94,6 +92,7 @@ type: exitcode-stdio-1.0 main-is: hlint.hs hs-source-dirs: tests + default-language: Haskell2010 if !flag(test-hlint) buildable: False else @@ -107,6 +106,7 @@ main-is: HaddockCoverage.hs ghc-options: -Wall hs-source-dirs: tests + default-language: Haskell2010 if !flag(test-doc-coverage) buildable: False diff --git a/src/Control/Arrow/Util.hs b/src/Control/Arrow/Util.hs --- a/src/Control/Arrow/Util.hs +++ b/src/Control/Arrow/Util.hs @@ -8,18 +8,6 @@ constantly = arr . const {-# INLINE constantly #-} --- | Alternative implementation of '<<<' that binds more strongly. -infixr 4 <-< -(<-<) :: Arrow a => a c d -> a b c -> a b d -(<-<) = (<<<) -{-# INLINE (<-<) #-} - --- | Alternative implementation of '>>>' that binds more strongly. -infixr 4 >-> -(>->) :: Arrow a => a b c -> a c d -> a b d -(>->) = (>>>) -{-# INLINE (>->) #-} - -- import Control.Category (id) -- import Prelude hiding (id) diff --git a/src/Control/Monad/Trans/MSF.hs b/src/Control/Monad/Trans/MSF.hs --- a/src/Control/Monad/Trans/MSF.hs +++ b/src/Control/Monad/Trans/MSF.hs @@ -3,8 +3,7 @@ -- | 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.Except , module Control.Monad.Trans.MSF.Maybe , module Control.Monad.Trans.MSF.Random , module Control.Monad.Trans.MSF.Reader @@ -13,7 +12,6 @@ ) 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 diff --git a/src/Control/Monad/Trans/MSF/Except.hs b/src/Control/Monad/Trans/MSF/Except.hs --- a/src/Control/Monad/Trans/MSF/Except.hs +++ b/src/Control/Monad/Trans/MSF/Except.hs @@ -20,8 +20,8 @@ import Control.Monad.Trans.Maybe -- Internal --- import Control.Monad.Trans.MSF.GenLift import Data.MonadicStreamFunction +import Data.MonadicStreamFunction.InternalCore -- * Throwing exceptions @@ -50,7 +50,7 @@ then throwS -< e else returnA -< () --- | When the input is 'Just e', throw the exception 'e'. +-- | 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 @@ -61,15 +61,17 @@ -- | Immediately throw the given exception. throw :: Monad m => e -> MSF (ExceptT e m) a b -throw = arrM_ . throwE +throw = constM . throwE -- | Do not throw an exception. pass :: Monad m => MSF (ExceptT e m) a a pass = Category.id --- | Whenever 'Nothing' is thrown, throw '()' instead. -maybeToExceptS :: (Functor m, Monad m) => MSF (MaybeT m) a b -> MSF (ExceptT () m) a b -maybeToExceptS = liftMSFPurer (ExceptT . (maybe (Left ()) Right <$>) . runMaybeT) +-- | Converts an 'MSF' in 'MaybeT' to an 'MSF' in 'ExceptT'. +-- Whenever 'Nothing' is thrown, throw @()@ instead. +maybeToExceptS :: (Functor m, Monad m) + => MSF (MaybeT m) a b -> MSF (ExceptT () m) a b +maybeToExceptS = morphS (ExceptT . (maybe (Left ()) Right <$>) . runMaybeT) -- * Catching exceptions @@ -83,25 +85,24 @@ e <- try msf safe $ f e --- | Similar to Yampa's delayed switching. Looses a 'b' in case of an exception. +-- | Similar to Yampa's delayed switching. Loses 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 + b <- liftTransS msf -< a + me <- liftTransS msfe -< b inExceptT -< ExceptT $ return $ maybe (Right b) Left me +-- TODO This needs to be renamed as 'runExceptS'! +-- 'exceptS' would have type @MSF m a (Either e b) -> MSF (ExceptT e m) a b@ -- | 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') +exceptS :: (Functor m, Monad m) => MSF (ExceptT e m) a b -> MSF m a (Either e b) +exceptS = transG return $ const $ fmap f . runExceptT + where + f (Left e) = (Left e , Nothing) + f (Right (b, c)) = (Right b, Just c ) -- | Embed an 'ExceptT' value inside the 'MSF'. -- Whenever the input value is an ordinary value, @@ -113,7 +114,7 @@ -- 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 - e1 <- try $ msf <<< arr fst + _ <- try $ msf <<< arr fst (_, e2) <- currentInput return e2 @@ -124,15 +125,19 @@ -- are in fact monads /in the exception type/. -- -- * 'return' corresponds to throwing an exception immediately. --- * '(>>=)' is exception handling: +-- * '>>=' 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. +-- | 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 @@ -152,30 +157,41 @@ pure = MSFExcept . throw (<*>) = ap --- | Monad instance for 'MSFExcept'. Bind uses the exception as the "return" +-- | 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) + MSFExcept msf >>= f = MSFExcept $ handleExceptT msf $ runMSFExcept . f +handleExceptT + :: Monad m + => MSF (ExceptT e1 m) a b + -> (e1 -> MSF (ExceptT e2 m) a b) + -> MSF (ExceptT e2 m) a b +handleExceptT msf f = flip handleGen msf $ \a mbcont -> do + ebcont <- lift $ runExceptT mbcont + case ebcont of + Left e -> unMSF (f e) a + Right (b, msf') -> return (b, handleExceptT 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 +safely (MSFExcept msf) = morphS fromExcept msf where - safely' msf = MSF $ \a -> do - Right (b, msf') <- runExceptT $ unMSF msf a - return (b, safely' msf') + fromExcept ma = do + -- We can assume that the pattern @Left e@ will not occur, + -- since @e@ would have to be of type @Empty@. + Right a <- runExceptT ma + return a -- | 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 +safe = try . liftTransS -- | Inside the 'MSFExcept' monad, execute an action of the wrapped monad. -- This passes the last input value to the action, @@ -203,10 +219,10 @@ -- that could only be broken by moving a few things to Data.MonadicStreamFunction.Core -- (that probably belong there anyways). --- | Extract MSF from a monadic action. +-- | 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 +-- 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 @@ -221,4 +237,33 @@ -- | Reactimates an 'MSF' until it returns 'True'. reactimateB :: Monad m => MSF m () Bool -> m () -reactimateB sf = reactimateExcept $ try $ liftMSFTrans sf >>> throwOn () +reactimateB sf = reactimateExcept $ try $ liftTransS sf >>> throwOn () + +-- * Analog to Yampa's switch, with Maybe instead of Event +switch :: Monad m => MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b +switch sf f = catchS ef f + where + ef = proc a -> do + (b,me) <- liftTransS sf -< a + inExceptT -< ExceptT $ return $ maybe (Right b) Left me + +-- | 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) + +handleGen :: (a -> m1 (b1, MSF m1 a b1) -> m2 (b2, MSF m2 a b2)) + -> MSF m1 a b1 + -> MSF m2 a b2 +handleGen handler msf = MSF $ \a -> handler a (unMSF msf a) diff --git a/src/Control/Monad/Trans/MSF/GenLift.hs b/src/Control/Monad/Trans/MSF/GenLift.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/MSF/GenLift.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# 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, 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 - --- | 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 --- a/src/Control/Monad/Trans/MSF/Maybe.hs +++ b/src/Control/Monad/Trans/MSF/Maybe.hs @@ -17,14 +17,13 @@ -- 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 +exit = constM $ MaybeT $ return Nothing -- | Throw the exception when the condition becomes true on the input. exitWhen :: Monad m => (a -> Bool) -> MSF (MaybeT m) a a @@ -52,8 +51,8 @@ -- | 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 + b <- liftTransS msf -< a + c <- liftTransS 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. @@ -75,47 +74,21 @@ -- * 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 +runMaybeS :: (Functor m, Monad m) => MSF (MaybeT m) a b -> MSF m a (Maybe b) +runMaybeS msf = exceptS (maybeToExceptS msf) >>> arr eitherToMaybe 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) + eitherToMaybe (Left ()) = Nothing + eitherToMaybe (Right b) = Just b --- | 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 :: (Functor m, 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 +-- | Run an 'MSF' fed from a list, discarding results. Useful when one needs to -- combine effects and streams (i.e., for testing purposes). embed_ :: (Functor m, Monad m) => MSF m a () -> [a] -> m () -embed_ msf as = reactimateMaybe $ listToMaybeS as >>> liftMSFTrans msf +embed_ msf as = reactimateMaybe $ listToMaybeS as >>> liftTransS 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,37 @@ +-- | 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 Data.MonadicStreamFunction + +-- * 'RWS' (Reader-Writer-State) monad + + +-- | Wrap an 'MSF' with explicit state variables in 'RWST' monad. +rwsS :: (Functor m, Monad m, Monoid w) + => MSF m (r, s, a) (w, s, b) + -> MSF (RWST r w s m) a b +rwsS = morphGS $ \f a -> RWST $ \r s -> (\((w, s', b), c) -> ((b, c), s', w)) + <$> f (r, s, a) + +-- | Run the 'RWST' layer by making the state variables explicit. +runRWSS :: (Functor m, Monad m, Monoid w) + => MSF (RWST r w s m) a b + -> MSF m (r, s, a) (w, s, b) +runRWSS = morphGS $ \f (r, s, a) -> (\((b, c), s', w) -> ((w, s', b), c)) + <$> runRWST (f a) r s diff --git a/src/Control/Monad/Trans/MSF/Random.hs b/src/Control/Monad/Trans/MSF/Random.hs --- a/src/Control/Monad/Trans/MSF/Random.hs +++ b/src/Control/Monad/Trans/MSF/Random.hs @@ -1,5 +1,15 @@ +-- | 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 +module Control.Monad.Trans.MSF.Random ( runRandS , evalRandS @@ -17,34 +27,48 @@ -- Internal import Data.MonadicStreamFunction +import Control.Monad.Trans.MSF.State --- | Updates the generator every step -runRandS :: (RandomGen g, Monad m) - => MSF (RandT g m) a b - -> g +-- | Run an 'MSF' in the 'RandT' random number monad transformer +-- by supplying an initial random generator. +-- Updates the generator every step. +runRandS :: (RandomGen g, Functor m, 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') +runRandS = runStateS_ . morphS (StateT . runRandT) --- | 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 +-- | 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, Functor m, 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 +getRandomS = constM getRandom + +-- | Create a stream of lists of random values. getRandomsS :: (MonadRandom m, Random b) => MSF m a [b] -getRandomsS = arrM_ getRandoms +getRandomsS = constM 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 +getRandomRS range = constM $ 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 +getRandomsRS range = constM $ 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 --- a/src/Control/Monad/Trans/MSF/Reader.hs +++ b/src/Control/Monad/Trans/MSF/Reader.hs @@ -1,22 +1,17 @@ {-# LANGUAGE Rank2Types #-} --- | MSFs with a Reader monadic layer. +-- | 'MSF's with a 'Reader' monadic layer. -- --- This module contains functions to work with MSFs that include a 'Reader' --- monadic layer. This includes functions to create new MSFs that include an --- additional layer, and functions to flatten that layer out of the MSF's +-- 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 wrapping/unwrapping. + -- * 'Reader' 'MSF' running and wrapping. , readerS , runReaderS , runReaderS_ - -- ** Alternative implementation using internal type. - , readerS' - , runReaderS' - -- ** Alternative implementation using generic lifting. - , runReaderS'' ) where -- External @@ -24,86 +19,22 @@ hiding (liftCallCC, liftCatch) -- Avoid conflicting exports -- Internal -import Control.Monad.Trans.MSF.GenLift import Data.MonadicStreamFunction --- * Reader MSF wrapping/unwrapping +-- * Reader 'MSF' running and wrapping --- | Build an MSF in the 'Reader' monad from one that takes the reader +-- | 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') +readerS :: Monad m => MSF m (r, a) b -> MSF (ReaderT r m) a b +readerS = morphGS $ \f a -> ReaderT $ \r -> f (r, a) --- | Build an MSF that takes an environment as an extra input from one on the +-- | 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') +runReaderS :: Monad m => MSF (ReaderT r m) a b -> MSF m (r, a) b +runReaderS = morphGS $ \f (r, a) -> runReaderT (f a) r --- | Build an MSF /function/ that takes a fixed environment as additional +-- | 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 +runReaderS_ msf s = arr (\a -> (s,a)) >>> runReaderS msf diff --git a/src/Control/Monad/Trans/MSF/State.hs b/src/Control/Monad/Trans/MSF/State.hs --- a/src/Control/Monad/Trans/MSF/State.hs +++ b/src/Control/Monad/Trans/MSF/State.hs @@ -1,132 +1,57 @@ {-# LANGUAGE Rank2Types #-} --- | MSFs with a State monadic layer. +-- | 'MSF's with a 'State' monadic layer. -- --- This module contains functions to work with MSFs that include a 'State' --- monadic layer. This includes functions to create new MSFs that include an --- additional layer, and functions to flatten that layer out of the MSF's +-- 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/wrapping/unwrapping + -- * '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 +import Data.Tuple (swap) -- Internal -import Control.Monad.Trans.MSF.GenLift -import Data.MonadicStreamFunction +import Data.MonadicStreamFunction.Core +import Data.MonadicStreamFunction.InternalCore --- * State MSF running/wrapping/unwrapping +-- * 'State' 'MSF' running and wrapping --- | Build an MSF in the 'State' monad from one that takes the state as an +-- | 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') +stateS :: (Functor m, Monad m) => MSF m (s, a) (s, b) -> MSF (StateT s m) a b +stateS = morphGS $ \f a -> StateT $ \s -> (\((s', b), c) -> ((b, c), s')) + <$> f (s, a) --- | Build an MSF that takes a state as an extra input from one on the +-- | 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') +runStateS :: (Functor m, Monad m) => MSF (StateT s m) a b -> MSF m (s, a) (s, b) +runStateS = morphGS $ \f (s, a) -> (\((b, c), s') -> ((s', b), c)) + <$> runStateT (f a) s --- | 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 +-- | 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' :: (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') - --- | Alternative implementation of 'runStateS' using 'lifterS'. -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) - --- ** Alternative using 'transS'. - --- | Alternative implementation of 'runStateS' using 'transS'. -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 --} - --- ** Alternative using 'transG'. +runStateS_ :: (Functor m, Monad m) => MSF (StateT s m) a b -> s -> MSF m a (s, b) +runStateS_ msf s = feedback s + $ arr swap >>> runStateS msf >>> arr (\(s', b) -> ((s', b), s')) --- | Alternative implementation of 'runStateS' using 'transG'. -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) +-- TODO Rename this to execStateS! +-- | Build an 'MSF' /function/ that takes a fixed state as additional +-- input, from an 'MSF' in the 'State' monad. +runStateS__ :: (Functor m, Monad m) => MSF (StateT s m) a b -> s -> MSF m a b +runStateS__ msf s = runStateS_ msf s >>> arr snd diff --git a/src/Control/Monad/Trans/MSF/Writer.hs b/src/Control/Monad/Trans/MSF/Writer.hs --- a/src/Control/Monad/Trans/MSF/Writer.hs +++ b/src/Control/Monad/Trans/MSF/Writer.hs @@ -1,99 +1,41 @@ --- | MSFs with a Writer monadic layer. +-- | 'MSF's with a 'Writer' monadic layer. -- --- This module contains functions to work with MSFs that include a 'Writer' --- monadic layer. This includes functions to create new MSFs that include an --- additional layer, and functions to flatten that layer out of the MSF's +-- 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 \/ wrapping \/ unwrapping + -- * '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.Functor ((<$>)) import Data.Monoid -- Internal -import Control.Monad.Trans.MSF.GenLift import Data.MonadicStreamFunction --- * Writer MSF running/wrapping/unwrapping +-- * 'Writer' 'MSF' running and wrapping --- | Build an MSF in the 'Writer' monad from one that produces the log as an +-- | 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') +writerS :: (Functor m, Monad m, Monoid w) + => MSF m a (w, b) -> MSF (WriterT w m) a b +writerS = morphGS $ \f a -> WriterT $ (\((w, b), c) -> ((b, c), w)) <$> f a --- | Build an MSF that produces the log as an extra output from one on the +-- | 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, Functor m, 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, 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) +runWriterS :: (Functor m, Monad m) + => MSF (WriterT s m) a b -> MSF m a (s, b) +runWriterS = morphGS $ \f a -> (\((b, c), s) -> ((s, b), c)) + <$> runWriterT (f a) diff --git a/src/Data/MonadicStreamFunction.hs b/src/Data/MonadicStreamFunction.hs --- a/src/Data/MonadicStreamFunction.hs +++ b/src/Data/MonadicStreamFunction.hs @@ -1,31 +1,32 @@ -- | Monadic Stream Functions are synchronized stream functions -- with side effects. -- --- MSFs are defined by a function @unMSF :: MSF m a b -> a -> m (b, MSF m a b)@ +-- '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. -- --- MSFs are a generalisation of the implementation mechanism used by Yampa, +-- '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 MSFs that end with a result (akin to Tasks in Yampa, and +-- 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. +-- 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, +-- '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 MSFs, see: +-- For a very detailed introduction to 'MSF's, see: -- -- (mirror: ). -- diff --git a/src/Data/MonadicStreamFunction/Async.hs b/src/Data/MonadicStreamFunction/Async.hs --- a/src/Data/MonadicStreamFunction/Async.hs +++ b/src/Data/MonadicStreamFunction/Async.hs @@ -5,6 +5,7 @@ -- Internal import Data.MonadicStreamFunction.Core +import Data.MonadicStreamFunction.InternalCore import Data.MonadicStreamFunction.Util (MStream) {- | @@ -13,7 +14,7 @@ Example: ->>> let intstream = arrM_ $ putStrLn "Enter a list of Ints:" >> readLn :: MStream IO [Int] +>>> let intstream = constS $ putStrLn "Enter a list of Ints:" >> readLn :: MStream IO [Int] >>> reactimate $ concatS intstream >>> arrM print Enter a list of Ints: [1,2,33] diff --git a/src/Data/MonadicStreamFunction/Core.hs b/src/Data/MonadicStreamFunction/Core.hs --- a/src/Data/MonadicStreamFunction/Core.hs +++ b/src/Data/MonadicStreamFunction/Core.hs @@ -1,229 +1,189 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} -- | Monadic Stream Functions are synchronized stream functions -- with side effects. -- --- MSFs are defined by a function @unMSF :: MSF m a b -> a -> m (b, MSF m a b)@ +-- '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. -- --- MSFs are a generalisation of the implementation mechanism used by Yampa, +-- '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 MSFs that end with a result (akin to Tasks in Yampa, and +-- 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. +-- 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, +-- '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 MSFs, see: +-- 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 +module Data.MonadicStreamFunction.Core + ( -- * Types + MSF + -- * Lifting and Monadic transformations + -- ** Lifting point-wise computations + , constM + , arrM + , liftBaseM + -- ** Trans-monadic MSF combinators + -- *** MonadBase + , liftBaseS + , (^>>>) + , (>>>^) + -- *** MonadTrans + , liftTransS + -- *** Generic Monadic Transformations + , morphS + , morphGS + -- * Depending on the past + , feedback + -- * Simulation + , reactimate + , embed + , module Control.Arrow + ) + where --- External -import Control.Arrow import Control.Applicative -import Control.Category (Category(..)) -import Control.Monad +import Control.Arrow +import Control.Category as C import Control.Monad.Base import Control.Monad.Trans.Class +import Data.Tuple (swap) import Prelude hiding ((.), id, sum) +import Data.MonadicStreamFunction.InternalCore (MSF, morphGS, feedback, reactimate, embed) + -- * Definitions --- | 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) } +-- | 'Arrow' instance for 'MSF's. +instance Monad m => Arrow (MSF m) where --- Instances + arr f = arrM (return . f) --- | 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') + -- first sf = MSF $ \(a,c) -> do + -- (b, sf') <- unMSF sf a + -- b `seq` return ((b, c), first sf') --- | 'Arrow' instance for MSFs. -instance Monad m => Arrow (MSF m) where + first = morphGS $ \f (a,c) -> do + (b, msf') <- f a + return ((b, c), msf') - 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 and applicative instances --- | Functor instance for MSFs. -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) +-- | 'Functor' instance for 'MSF's. +instance Monad 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 MSFs. +-- | 'Applicative' instance for 'MSF's. 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 ($)) --- * Monadic computations and MSFs -- ** Lifting point-wise computations +-- | Lifts a monadic computation into a Stream. +constM :: Monad m => m b -> MSF m a b +constM = arrM . const + -- | 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) +--arrM f = go +-- where go = MSF $ \a -> do +-- b <- f a +-- return (b, go) +arrM f = morphGS (\i a -> i a >>= \(_,c) -> f a >>= \b -> return (b, c)) C.id -- | Monadic lifting from one monad into another -liftS :: (Monad m2, MonadBase m1 m2) => (a -> m1 b) -> MSF m2 a b -liftS = arrM . (liftBase .) +liftBaseM :: (Monad m2, MonadBase m1 m2) => (a -> m1 b) -> MSF m2 a b +liftBaseM = arrM . (liftBase .) --- ** Lifting MSFs +-- ** MSF combinators that apply monad transformations --- *** Lifting across monad stacks +-- | Lift innermost monadic actions in monad stack (generalisation of +-- 'liftIO'). +liftBaseS :: (Monad m2, MonadBase m1 m2) => MSF m1 a b -> MSF m2 a b +liftBaseS = morphS liftBase +-- *** MonadBase +-- | 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 = liftBaseS 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 >>> liftBaseS sf2 +{-# INLINE (>>>^) #-} + +-- *** MonadTrans + -- | 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 +liftTransS :: (MonadTrans t, Monad m, Monad (t m)) + => MSF m a b + -> MSF (t m) a b +liftTransS = morphS 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 monadic transformation --- *** Generic MSF Lifting +-- | Apply trans-monadic actions (in an arbitrary way). +-- +-- This is just a convenience function when you have a function to move across +-- monads, because the signature of 'morphGS' is a bit complex. +morphS :: (Monad m2, Monad m1) + => (forall c . m1 c -> m2 c) + -> MSF m1 a b + -> MSF m2 a b +morphS morph = morphGS morph' + where + -- The following makes the a's and the b's the same, and it just says: + -- whatever function m1F you give me to apply to every sample, I use morph + -- on the result to go from m1 to m2. + -- + -- Remember that: + -- morphGS :: Monad m2 + -- => (forall c . (a1 -> m1 (b1, c)) -> (a2 -> m2 (b2, c))) + -- -- ^ The natural transformation. @mi@, @ai@ and @bi@ for @i = 1, 2@ + -- -- can be chosen freely, but @c@ must be universally quantified + -- -> MSF m1 a1 b1 + -- -> MSF m2 a2 b2 + -- + -- morph' :: (forall c . (a -> m1 (b, c)) -> (a -> m2 (b, c))) + morph' m1F = morph . m1F -- 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 +-- morphS :: 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 +-- liftTransS = morphS lift +-- liftBaseS = morphS liftBase -- --- We could also define a strict version of liftMSFPurer as follows: +-- We could also define a strict version of morphS as follows: -- --- liftMStreamPurer' f = liftMSFPurer (f >=> whnfVal) +-- morphS' f = morphS (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' +-- and leave morphS as a lazy version (by default). diff --git a/src/Data/MonadicStreamFunction/Instances/ArrowChoice.hs b/src/Data/MonadicStreamFunction/Instances/ArrowChoice.hs --- a/src/Data/MonadicStreamFunction/Instances/ArrowChoice.hs +++ b/src/Data/MonadicStreamFunction/Instances/ArrowChoice.hs @@ -8,6 +8,7 @@ import Control.Arrow import Data.MonadicStreamFunction.Core +import Data.MonadicStreamFunction.InternalCore -- | 'ArrowChoice' instance for MSFs. instance Monad m => ArrowChoice (MSF m) where diff --git a/src/Data/MonadicStreamFunction/Instances/ArrowLoop.hs b/src/Data/MonadicStreamFunction/Instances/ArrowLoop.hs --- a/src/Data/MonadicStreamFunction/Instances/ArrowLoop.hs +++ b/src/Data/MonadicStreamFunction/Instances/ArrowLoop.hs @@ -9,6 +9,7 @@ module Data.MonadicStreamFunction.Instances.ArrowLoop where import Data.MonadicStreamFunction.Core +import Data.MonadicStreamFunction.InternalCore -- External import Control.Arrow @@ -16,7 +17,7 @@ -- | 'ArrowLoop' instance for MSFs. The monad must be an instance of -- 'MonadFix'. -instance (Monad m, MonadFix m) => ArrowLoop (MSF m) where +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) diff --git a/src/Data/MonadicStreamFunction/Instances/ArrowPlus.hs b/src/Data/MonadicStreamFunction/Instances/ArrowPlus.hs --- a/src/Data/MonadicStreamFunction/Instances/ArrowPlus.hs +++ b/src/Data/MonadicStreamFunction/Instances/ArrowPlus.hs @@ -6,10 +6,14 @@ -- 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 +import Data.MonadicStreamFunction.InternalCore -- | Instance of 'ArrowZero' for Monadic Stream Functions ('MSF'). -- The monad must be an instance of 'MonadPlus'. @@ -20,3 +24,7 @@ -- 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 (Functor m, 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 --- a/src/Data/MonadicStreamFunction/Instances/Num.hs +++ b/src/Data/MonadicStreamFunction/Instances/Num.hs @@ -1,8 +1,9 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Number instances for MSFs that produce numbers. This allows you to use --- numeric operators with MSFs that output numbers, for example, you can write: +-- | 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 @@ -25,7 +26,7 @@ import Control.Arrow.Util import Data.MonadicStreamFunction.Core --- | 'Num' instance for MSFs. +-- | 'Num' instance for 'MSF's. instance (Monad m, Num b) => Num (MSF m a b) where (+) = elementwise2 (+) (-) = elementwise2 (-) @@ -35,13 +36,13 @@ negate = elementwise negate fromInteger = constantly . fromInteger --- | 'Fractional' instance for MSFs. +-- | '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 MSFs. +-- | 'Floating' instance for 'MSF's. instance (Monad m, Floating b) => Floating (MSF m a b) where pi = constantly pi exp = elementwise exp diff --git a/src/Data/MonadicStreamFunction/Instances/VectorSpace.hs b/src/Data/MonadicStreamFunction/Instances/VectorSpace.hs --- a/src/Data/MonadicStreamFunction/Instances/VectorSpace.hs +++ b/src/Data/MonadicStreamFunction/Instances/VectorSpace.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | 'VectorSpace' instances for MSFs that produce vector spaces. This allows --- you to use vector operators with MSFs that output vectors, for example, you +-- | '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: -- -- @ @@ -28,7 +28,7 @@ -- These conflict with Data.VectorSpace.Instances --- | R-module instance for MSFs. +-- | 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 @@ -37,6 +37,6 @@ (^+^) = elementwise2 (^+^) (^-^) = elementwise2 (^-^) --- | Vector-space instance for MSFs. +-- | 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/InternalCore.hs b/src/Data/MonadicStreamFunction/InternalCore.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonadicStreamFunction/InternalCore.hs @@ -0,0 +1,135 @@ +{-# 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. +-- +-- This modules defines only the minimal core. Hopefully, other functions can be +-- defined in terms of the functions in this module without accessing the +-- MSF constuctor. + + +-- 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.InternalCore 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') + +-- * Monadic computations and 'MSF's + +-- | Generic lifting of a morphism to the level of 'MSF's. +-- +-- Natural transformation to the level of 'MSF's. +-- +-- __Mathematical background:__ The type @a -> m (b, c)@ is a functor in @c@, +-- and @MSF m a b@ is its greatest fixpoint, i.e. it is isomorphic to the type +-- @a -> m (b, MSF m a b)@, by definition. +-- The types @m@, @a@ and @b@ are parameters of the functor. +-- Taking a fixpoint is functorial itself, meaning that a morphism +-- (a natural transformation) of two such functors gives a morphism +-- (an ordinary function) of their fixpoints. +-- +-- This is in a sense the most general "abstract" lifting function, +-- i.e. the most general one that only changes input, output and side effect +-- types, and doesn't influence control flow. +-- Other handling functions like exception handling or 'ListT' broadcasting +-- necessarily change control flow. +morphGS :: Monad m2 + => (forall c . (a1 -> m1 (b1, c)) -> (a2 -> m2 (b2, c))) + -- ^ The natural transformation. @mi@, @ai@ and @bi@ for @i = 1, 2@ + -- can be chosen freely, but @c@ must be universally quantified + -> MSF m1 a1 b1 + -> MSF m2 a2 b2 +morphGS morph msf = MSF $ \a2 -> do + (b2, msf') <- morph (unMSF msf) a2 + return (b2, morphGS morph msf') + +-- * 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/Parallel.hs b/src/Data/MonadicStreamFunction/Parallel.hs --- a/src/Data/MonadicStreamFunction/Parallel.hs +++ b/src/Data/MonadicStreamFunction/Parallel.hs @@ -8,9 +8,10 @@ -- Internal import Data.MonadicStreamFunction +import Data.MonadicStreamFunction.InternalCore --- | Run two MSFs in parallel, taking advantage of parallelism if --- possible. This is the parallel version of '(***)'. +-- | 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 @@ -18,6 +19,6 @@ (d, msf2') <- unMSF msf2 c b `par` d `pseq` return ((b, d), msf1' *|* msf2') --- | Parallel version of '(&&&)'. +-- | 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 --- a/src/Data/MonadicStreamFunction/ReactHandle.hs +++ b/src/Data/MonadicStreamFunction/ReactHandle.hs @@ -1,5 +1,5 @@ --- | ReactHandle - +-- | '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. @@ -12,34 +12,24 @@ -- Internal import Data.MonadicStreamFunction +import Data.MonadicStreamFunction.InternalCore --- | A storage for the current state of an MSF +-- | 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 +-- | 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 +-- | 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' - - --- | 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) diff --git a/src/Data/MonadicStreamFunction/Util.hs b/src/Data/MonadicStreamFunction/Util.hs --- a/src/Data/MonadicStreamFunction/Util.hs +++ b/src/Data/MonadicStreamFunction/Util.hs @@ -1,66 +1,41 @@ -{-# LANGUAGE Arrows #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE Rank2Types #-} -- | Useful auxiliary functions and definitions. 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.MonadicStreamFunction.Instances.ArrowChoice +import Data.MonadicStreamFunction.Instances.ArrowChoice () import Data.VectorSpace +import Prelude hiding (id, (.)) +import Control.Monad.Trans.MSF.State + -- * Streams and sinks --- | A stream is an MSF that produces outputs ignoring the input. It can --- obtain the values from a monadic context. +-- | 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 stream is an MSF that produces outputs producing no output. It can --- consume the values with side effects. +-- | 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 (^>>>) #-} +-- * Analogues of 'map' and 'fmap' --- | 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 +-- | 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 @@ -82,14 +57,26 @@ -- See also: 'iPre' --- | Preprends a fixed output to an MSF. The first input is completely +-- | Delay a signal by one sample. +iPre :: Monad m + => a -- ^ First output + -> MSF m a a +-- iPre firsta = MSF $ \a -> return (firsta, iPre a) +iPre firsta = feedback firsta $ arr swap + where swap (a,b) = (b, a) +-- iPre firsta = next firsta identity + + +-- | 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) +iPost b sf = sf >>> (feedback (Just b) $ arr $ \(c, ac) -> case ac of + Nothing -> (c, Nothing) + Just b' -> (b', Nothing)) --- | Preprends a fixed output to an MSF, shifting the output. +-- | 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 +next b sf = sf >>> iPre b -- | Buffers and returns the elements in FIFO order, -- returning 'Nothing' whenever the buffer is empty. @@ -102,7 +89,7 @@ -- * Folding --- ** Folding for VectorSpace instances +-- ** Folding for 'VectorSpace' instances -- | Count the number of simulation steps. Produces 1, 2, 3,... count :: (Num n, Monad m) => MSF m a n @@ -129,12 +116,18 @@ -- ** Generic folding \/ accumulation --- | Applies a function to the input and an accumulator, outputing the --- accumulator. Equal to @\f s0 -> feedback s0 $ arr (uncurry f >>> dup)@. +-- | 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 diff --git a/src/Data/VectorSpace.hs b/src/Data/VectorSpace.hs --- a/src/Data/VectorSpace.hs +++ b/src/Data/VectorSpace.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Data.VectorSpace -- Copyright : (c) Ivan Perez and Manuel Bärenz @@ -16,7 +17,7 @@ module Data.VectorSpace where ------------------------------------------------------------------------------ --- Vector space type relation +-- * Vector space classes ------------------------------------------------------------------------------ infixr 6 *^ @@ -77,15 +78,13 @@ (^/) :: v -> Groundfield v -> v v ^/ a = (1/a) *^ v --- TODO Why is this not a type synonym? -- | 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 family Groundfield v :: * -type instance Groundfield v = Groundring v +type Groundfield v = Groundring v -- | An inner product space is a module with an inner product, -- i.e. a map @dot@ satisfying @@ -105,15 +104,220 @@ -- -- A typical example is @sqrt (v `dot` v)@, -- for an inner product space. -class RModule v => NormedSpace v where +class (Floating (Groundfield v), InnerProductSpace v, VectorSpace v) => NormedSpace v where norm :: v -> Groundfield v + norm v = sqrt $ v `dot` v -{- -instance (Floating (Groundfield v), VectorSpace v, InnerProductSpace v) => NormedSpace v where - norm v = sqrt (v `dot` v) --} -{- I'd like to know why this won't work -normalize :: (Eq a, NormedSpace v a) => v -> 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 - -} + 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 diff --git a/src/Data/VectorSpace/Fractional.hs b/src/Data/VectorSpace/Fractional.hs deleted file mode 100644 --- a/src/Data/VectorSpace/Fractional.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | VectorSpace instances for Num/Fractional types. --- --- This module includes instances for: --- --- * 'InnerProductSpace' and 'RModule' for 'Num' --- --- * 'VectorSpace' for 'Fractional's -module Data.VectorSpace.Fractional where - --- 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 - --- | R-module instance for any number, where '^+^ is '+' and multiplication is --- normal multiplication. -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 - --- | Vector-space instance for any fractional, where vectorial division is --- normal number division. -instance Fractional a => VectorSpace a where - a ^/ x = a / x - --- | Inner-product instance for any number. -instance Num a => InnerProductSpace a where - x1 `dot` x2 = x1 * x2 diff --git a/src/Data/VectorSpace/Specific.hs b/src/Data/VectorSpace/Specific.hs deleted file mode 100644 --- a/src/Data/VectorSpace/Specific.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | Vector space instances for concrete/specific types. --- --- This module contains: --- --- * 'RModule' instances for 'Int', 'Integer', 'Double' and 'Float'. --- --- * 'VectorSpace' for 'Double' and 'Float'. - -module Data.VectorSpace.Specific where - -import Data.VectorSpace - --- | R-mobule instance for 'Int's. -instance RModule Int where - type Groundring Int = Int - (^+^) = (+) - (^*) = (*) - zeroVector = 0 - --- | R-mobule instance for 'Integer's. -instance RModule Integer where - type Groundring Integer = Integer - (^+^) = (+) - (^*) = (*) - zeroVector = 0 - - --- | R-mobule instance for 'Double's. -instance RModule Double where - type Groundring Double = Double - (^+^) = (+) - (^*) = (*) - zeroVector = 0 - --- | R-mobule instance for 'Floating's. -instance RModule Float where - type Groundring Float = Float - (^+^) = (+) - (^*) = (*) - zeroVector = 0 - --- | Vector-space instance for 'Double'. -instance VectorSpace Double where - --- | Vector-space instance for 'Floating's. -instance VectorSpace Float where diff --git a/src/Data/VectorSpace/Tuples.hs b/src/Data/VectorSpace/Tuples.hs deleted file mode 100644 --- a/src/Data/VectorSpace/Tuples.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | Vector space instances for small tuples of 'Fractional'. --- --- This module contains 'RModule', 'VectorSpace' and 'InnerProductSpace' for --- tuples of up to five elements. - -module Data.VectorSpace.Tuples where - -import Data.VectorSpace - --- | R-module instance 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) - --- | Vector-space instance for tuples. -instance (Groundfield a ~ Groundfield b, VectorSpace a, VectorSpace b) => VectorSpace (a, b) where - (a, b) ^/ x = (a ^/ x, b ^/ x) - --- | Inner Product Space instance for tuples. -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 Num a => RModule (a,a) where - type Groundring (a,a) = a - zeroVector = (0,0) - a *^ (x,y) = (a * x, a * y) - negateVector (x,y) = (-x, -y) - (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2) - (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2) - -instance Fractional a => VectorSpace (a,a) where - (x,y) ^/ a = (x / a, y / a) - - -instance Fractional a => InnerProductSpace (a,a) where - (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2 - --} - --- | R-module instance for tuples with 3 elements. -instance Num a => RModule (a,a,a) where - type Groundring (a,a,a) = a - zeroVector = (0,0,0) - a *^ (x,y,z) = (a * x, a * y, a * z) - negateVector (x,y,z) = (-x, -y, -z) - (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2) - (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2) - --- | Vector-space instance for tuples with 3 elements. -instance Fractional a => VectorSpace (a,a,a) where - (x,y,z) ^/ a = (x / a, y / a, z / a) - --- | Inner Product Space instance for tuples with 3 elements. -instance Num a => InnerProductSpace (a,a,a) where - (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 - - --- | R-module instance for tuples with 4 elements. -instance Num a => RModule (a,a,a,a) where - type Groundring (a,a,a,a) = a - zeroVector = (0,0,0,0) - a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u) - negateVector (x,y,z,u) = (-x, -y, -z, -u) - (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2) - (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2) - --- | Vector-space instance for tuples with 4 elements. -instance Fractional a => VectorSpace (a,a,a,a) where - (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a) - --- | Inner Product Space instance for tuples with 4 elements. -instance Num a => InnerProductSpace (a,a,a,a) where - (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 - - --- | R-module instance for tuples with 5 elements. -instance Num a => RModule (a,a,a,a,a) where - type Groundring (a,a,a,a,a) = a - zeroVector = (0,0,0,0,0) - a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v) - negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v) - (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2) - (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2) - --- | Vector-space instance for tuples with 5 elements. -instance Fractional a => VectorSpace (a,a,a,a,a) where - (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a) - --- | Inner Product Space instance for tuples with 5 elements. -instance Num a => InnerProductSpace (a,a,a,a,a) where - (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) = - x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2