dunai 0.0.1.0 → 0.1.0.0

raw patch · 20 files changed

+1452/−31 lines, 20 filesdep +directorydep +filepathdep +hlintdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath, hlint, process, regex-posix, transformers, transformers-base

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +23/−26
• dunai.cabal +66/−4
• src/Control/Arrow/Util.hs +30/−0
• src/Control/Monad/Trans/MStreamF.hs +509/−0
• src/Data/MonadicStreamFunction.hs +168/−1
• src/Data/MonadicStreamFunction/ArrowChoice.hs +12/−0
• src/Data/MonadicStreamFunction/ArrowLoop.hs +16/−0
• src/Data/MonadicStreamFunction/ArrowPlus.hs +12/−0
• src/Data/MonadicStreamFunction/Core.hs +173/−0
• src/Data/MonadicStreamFunction/Instances.hs +16/−0
• src/Data/MonadicStreamFunction/Instances/Num.hs +41/−0
• src/Data/MonadicStreamFunction/Instances/VectorSpace.hs +21/−0
• src/Data/MonadicStreamFunction/Parallel.hs +27/−0
• src/Data/Tuple/Util.hs +7/−0
• src/Data/VectorSpace.hs +72/−0
• src/Data/VectorSpace/Instances.hs +22/−0
• src/Data/VectorSpace/Specific.hs +34/−0
• src/Data/VectorSpace/Tuples.hs +89/−0
• tests/HaddockCoverage.hs +91/−0
• tests/hlint.hs +23/−0

@@ -1,33 +1,30 @@-In the original BSD license, both occurrences of the phrase "COPYRIGHT-HOLDERS AND CONTRIBUTORS" in the disclaimer read "REGENTS AND-CONTRIBUTORS".--Here is the license template:--Copyright (c) 2016, Manuel Bärenz (University of Bamberg), Ivan Perez-(University of Nottingham).+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:+modification, are permitted provided that the following conditions are met: -1. Redistributions of source code must retain the above copyright-notice, this list of conditions and the following disclaimer.+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer. -2. 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.+    * 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. -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-HOLDER 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.+    * 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.

@@ -1,8 +1,8 @@ name:                dunai-version:             0.0.1.0+version:             0.1.0.0 synopsis:            Generalised reactive framework supporting classic, arrowized and monadic FRP. -- description:-license:             BSD2+license:             BSD3 license-file:        LICENSE author:              Ivan Perez, Manuel Bärenz maintainer:          ivan.perez@keera.co.uk@@ -12,10 +12,72 @@ -- extra-source-files: cabal-version:       >=1.10 +-- You can disable the hlint test suite with -f-test-hlint+flag test-hlint+  default: False+  manual: True++-- You can disable the haddock coverage test suite with -f-test-doc-coverage+flag test-doc-coverage+  default: False+  manual: True+ library-  exposed-modules:   Data.MonadicStreamFunction+  exposed-modules:   Control.Monad.Trans.MStreamF+                     Data.MonadicStreamFunction+                     Data.MonadicStreamFunction.Core+                     Data.MonadicStreamFunction.ArrowChoice+                     Data.MonadicStreamFunction.ArrowLoop+                     Data.MonadicStreamFunction.ArrowPlus+                     Data.MonadicStreamFunction.Instances+                     Data.MonadicStreamFunction.Instances.Num+                     Data.MonadicStreamFunction.Instances.VectorSpace+                     Data.MonadicStreamFunction.Parallel -  build-depends:     base >=4.6 && < 5+		     -- Auxiliary definitions+                     Data.VectorSpace+                     Data.VectorSpace.Instances+                     Data.VectorSpace.Tuples+                     Data.VectorSpace.Specific++  other-modules:     Control.Arrow.Util+                     Data.Tuple.Util++  build-depends:     base >=4.6 && < 5,+                     transformers,+                     transformers-base   hs-source-dirs:    src   default-language:  Haskell2010   ghc-options:       -Wall -fno-warn-unused-do-bind++test-suite hlint+  type: exitcode-stdio-1.0+  main-is: hlint.hs+  hs-source-dirs: tests+  if !flag(test-hlint)+    buildable: False+  else+    build-depends:+      base,+      hlint >= 1.7++-- Verify that the code is thoroughly documented+test-suite haddock-coverage+  type: exitcode-stdio-1.0+  main-is: HaddockCoverage.hs+  ghc-options: -Wall+  hs-source-dirs: tests++  if !flag(test-doc-coverage)+    buildable: False+  else+    build-depends:+      base >= 4 && < 5,+      directory,+      filepath,+      process,+      regex-posix++source-repository head+  type:     git+  location: git@bitbucket.org:iperezdominguez/dunai.git

@@ -0,0 +1,30 @@+module Control.Arrow.Util where++-- Do we even need that module? How much of it exists in the standard library?++import Control.Arrow+import Control.Category (id)+import Prelude hiding (id)++-- Hah! I shall implement this for TimelessSFs and SFs at the same time!+constantly :: Arrow a => b -> a c b+constantly = arr . const+{-# INLINE constantly #-}++-- More strongly bound arrow combinators+infixr 4 <-<+(<-<) :: Arrow a => a c d -> a b c -> a b d+(<-<) = (<<<)+{-# INLINE (<-<) #-}++infixr 4 >->+(>->) :: Arrow a => a b c -> a c d -> a b d+(>->) = (>>>)+{-# INLINE (>->) #-}+++(&&&!) :: 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

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

@@ -1,1 +1,168 @@-module Data.MonadicStreamFunction where+-- | Monadic Stream Functions are synchronized stream functions+-- with side effects.+module Data.MonadicStreamFunction+  ( module Control.Arrow+  , module Data.MonadicStreamFunction+  , module X+  )+ where++-- External+import Control.Applicative+import Control.Arrow+import Control.Category (Category(..))+import Control.Monad+import Control.Monad.Base+import Data.Monoid+import Prelude hiding ((.), id, sum)++-- Internal (generic)+import Data.VectorSpace+import Data.VectorSpace.Instances()++import Data.MonadicStreamFunction.Core        as X+import Data.MonadicStreamFunction.ArrowChoice as X+import Data.MonadicStreamFunction.ArrowLoop   as X+import Data.MonadicStreamFunction.ArrowPlus   as X++-- ** Instances for monadic streams++instance Functor m => Functor (MStreamF m r)+  where+    -- fmap f as = as >>> arr f+    fmap f as = MStreamF $ \r -> fTuple <$> unMStreamF as r+      where+        fTuple (a, as') = (f a, f <$> as')++instance Applicative m => Applicative (MStreamF m r) where+  -- pure a = constantly a+  pure a = MStreamF $ \_ -> pure (a, pure a)+  {-+  fs <*> as = proc _ -> do+      f <- fs -< ()+      a <- as -< ()+      returnA -< f a+  -}+  fs <*> as = MStreamF $ \r -> applyTuple <$> unMStreamF fs r <*> unMStreamF as r+    where+      applyTuple (f, fs') (a, as') = (f a, fs' <*> as')++-- ** Lifts++{-# DEPRECATED insert "Don't use this. liftMStreamF id instead" #-}+insert :: Monad m => MStreamF m (m a) a+insert = liftMStreamF id+-- This expands to the old code:+--+-- MStreamF $ \ma -> do+--   a <- ma+--   return (a, insert)++liftMStreamF_ :: Monad m => m b -> MStreamF m a b+liftMStreamF_ = liftMStreamF . const++-- * Monadic lifting from one monad into another++-- ** Monad stacks++(^>>>) :: MonadBase m1 m2 => MStreamF m1 a b -> MStreamF m2 b c -> MStreamF m2 a c+sf1 ^>>> sf2 = (liftMStreamFBase sf1) >>> sf2+{-# INLINE (^>>>) #-}++(>>>^) :: MonadBase m1 m2 => MStreamF m2 a b -> MStreamF m1 b c -> MStreamF m2 a c+sf1 >>>^ sf2 = sf1 >>> (liftMStreamFBase sf2)+{-# INLINE (>>>^) #-}++-- ** Delays and signal overwriting++-- See also: 'iPre'++iPost :: Monad m => b -> MStreamF m a b -> MStreamF m a b+iPost b sf = MStreamF $ \_ -> return (b, sf)++next :: Monad m => b -> MStreamF m a b -> MStreamF m a b+next b sf = MStreamF $ \a -> do+  (b', sf') <- unMStreamF sf a+  return (b, next b' sf')+-- rather, once delay is tested:+-- next b sf = sf >>> delay b++-- ** Switching++-- See also: 'switch', and the exception monad combinators for MSFs in+-- Control.Monad.Trans.MStreamF++untilS :: Monad m => MStreamF m a b -> MStreamF m b Bool -> MStreamF m a (b, Maybe ())+untilS sf1 sf2 = sf1 >>> (arr id &&& (sf2 >>> arr boolToMaybe))+  where boolToMaybe x = if x then Just () else Nothing++andThen :: Monad m => MStreamF m a (b, Maybe ()) -> MStreamF m a b -> MStreamF m a b+andThen sf1 sf2 = switch sf1 $ const sf2++-- ** Feedback loops++-- | Missing: 'feedback'++-- * Adding side effects+withSideEffect :: Monad m => (a -> m b) -> MStreamF m a a+withSideEffect method = (id &&& liftMStreamF method) >>> arr fst++withSideEffect_ :: Monad m => m b -> MStreamF m a a+withSideEffect_ method = withSideEffect $ const method++-- * Debugging++traceGeneral :: (Monad m, Show a) => (String -> m ()) -> String -> MStreamF m a a+traceGeneral method msg =+  withSideEffect (method . (msg ++) . show)++trace :: Show a => String -> MStreamF IO a a+trace = traceGeneral putStrLn++-- FIXME: This does not seem to be a very good name.  It should be+-- something like traceWith. It also does too much.+pauseOnGeneral :: (Monad m, Show a) => (a -> Bool) -> (String -> m ()) -> String -> MStreamF m a a+pauseOnGeneral cond method msg = withSideEffect $ \a ->+  when (cond a) $ method $ msg ++ show a++pauseOn :: Show a => (a -> Bool) -> String -> MStreamF IO a a+pauseOn cond = pauseOnGeneral cond $ \s -> print s >> getLine >> return ()++-- * Tests and examples++sum :: (Monoid n, Monad m) => MStreamF m n n+sum = sumFrom mempty+{-# INLINE sum #-}++sumFrom :: (Monoid n, Monad m) => n -> MStreamF m n n+sumFrom n0 = MStreamF $ \n -> let acc = n0 `mappend` n+                              -- in acc `seq` return (acc, sumFrom acc)+                              in return (acc, sumFrom acc)+-- sum = feedback 0 (arr (uncurry (+) >>> dup))+--  where dup x = (x,x)++count :: (Num n, Monad m) => MStreamF m () n+count = arr (const (Sum 1)) >>> sum >>> arr getSum++unfold :: Monad m => (a -> (b,a)) -> a -> MStreamF m () b+unfold f a = MStreamF $ \_ -> let (b,a') = f a in b `seq` return (b, unfold f a')+-- unfold f x = feedback x (arr (snd >>> f))++repeatedly :: Monad m => (a -> a) -> a -> MStreamF m () a+repeatedly f = repeatedly'+ where repeatedly' a = MStreamF $ \() -> let a' = f a in a' `seq` return (a, repeatedly' a')+-- repeatedly f x = feedback x (arr (f >>> \x -> (x,x)))++-- FIXME: This should *not* be in this module+mapMStreamF :: Monad m => MStreamF m a b -> MStreamF m [a] [b]+mapMStreamF sf = MStreamF $ consume sf+  where+    consume :: Monad m => MStreamF m a t -> [a] -> m ([t], MStreamF m [a] [t])+    consume sf []     = return ([], mapMStreamF sf)+    consume sf (a:as) = do+      (b, sf')   <- unMStreamF sf a+      (bs, sf'') <- consume sf' as+      b `seq` return (b:bs, sf'')++-- * Streams (or generators)+type MStream m a = MStreamF m () a

@@ -0,0 +1,12 @@+module Data.MonadicStreamFunction.ArrowChoice where++import Control.Arrow++import Data.MonadicStreamFunction.Core++instance Monad m => ArrowChoice (MStreamF m) where+  left sf = MStreamF f+    where+      f (Left a) = do (b, sf') <- unMStreamF sf a+                      return (Left b, left sf')+      f (Right c) = return (Right c, left sf)

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

@@ -0,0 +1,12 @@+module Data.MonadicStreamFunction.ArrowPlus where++import Control.Arrow+import Control.Monad++import Data.MonadicStreamFunction.Core++instance (Monad m, MonadPlus m) => ArrowZero (MStreamF m) where+  zeroArrow = MStreamF $ const mzero++instance (Monad m, MonadPlus m) => ArrowPlus (MStreamF m) where+  sf1 <+> sf2 = MStreamF $ \a -> unMStreamF sf1 a `mplus` unMStreamF sf2 a

@@ -0,0 +1,173 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE Rank2Types     #-}+-- | Monadic Stream Functions are synchronized stream functions+-- with side effects.++-- This module contains the core. Only the core. It should be possible+-- to define every function and type outside this module, except for the+-- instances for ArrowLoop, ArrowChoice, etc., without access to the+-- internal constructor for MStreamF and the function 'unMStreamF'.+--+-- 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+-- individually, but the main module instead.+module Data.MonadicStreamFunction.Core where++-- External+import Control.Applicative+import Control.Arrow+import Control.Category (Category(..))+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Class+import Prelude hiding ((.), id, sum)++-- MStreamF: Stepwise, side-effectful MStreamFs without implicit knowledge of time+data MStreamF m a b = MStreamF { unMStreamF :: a -> m (b, MStreamF m a b) }++instance Monad m => Category (MStreamF m) where+  id = go+    where go = MStreamF $ \a -> return (a, go)+  sf2 . sf1 = MStreamF $ \a -> do+    (b, sf1') <- unMStreamF sf1 a+    (c, sf2') <- unMStreamF sf2 b+    let sf' = sf2' . sf1'+    c `seq` return (c, sf')++instance Monad m => Arrow (MStreamF m) where++  arr f = go+    where go = MStreamF $ \a -> return (f a, go)++  first sf = MStreamF $ \(a,c) -> do+    (b, sf') <- unMStreamF sf a+    b `seq` return ((b, c), first sf')+    -- This is called the "monadic strength" of m++-- ** Lifts+liftMStreamF :: Monad m => (a -> m b) -> MStreamF m a b+liftMStreamF f = go+ where go = MStreamF $ \a -> do+              b <- f a+              return (b, go)++-- * Monadic lifting from one monad into another++-- ** Purer monads++-- IPerez: There is an alternative signature for liftMStreamPurer that also+-- works, and makes the code simpler:+--+-- liftMStreamFPurer :: Monad m => (m1 (b, MStreamF m1 a b) -> m (b, MStreamF m1 a b)) -> MStreamF m1 a b -> MStreamF m a b+--+-- Then we can express:+--+-- liftMStreamFTrans = liftMStreamFPurer lift+-- liftMStreamFBase  = liftMStreamFPurer liftBase+--+-- We could also define a strict version of liftMStreamFPurer as follows:+--+-- liftMStreamPurer' f = liftMStreamFPurer (f >=> whnfVal)+--   where whnfVal p@(b,_) = b `seq` return p+--+-- and leave liftMStreamFPurer as a lazy version (by default).++-- | Lifting purer monadic actions (in an arbitrary way)+liftMStreamFPurer :: (Monad m2, Monad m1) => (forall c . m1 c -> m2 c) -> MStreamF m1 a b -> MStreamF m2 a b+liftMStreamFPurer liftPurer sf = MStreamF $ \a -> do+  (b, sf') <- liftPurer $ unMStreamF sf a+  b `seq` return (b, liftMStreamFPurer liftPurer sf')++-- ** Monad stacks++-- | Lifting inner monadic actions in monad stacks+-- TODO Should be able to express this in terms of MonadBase+liftMStreamFTrans :: (MonadTrans t, Monad m, Monad (t m)) => MStreamF m a b -> MStreamF (t m) a b+liftMStreamFTrans sf = MStreamF $ \a -> do+  (b, sf') <- lift $ unMStreamF sf a+  return (b, liftMStreamFTrans sf')++-- | Lifting the innest monadic actions in a monad stacks (generalisation of liftIO)+liftMStreamFBase :: (Monad m2, MonadBase m1 m2) => MStreamF m1 a b -> MStreamF m2 a b+liftMStreamFBase sf = MStreamF $ \a -> do+  (b, sf') <- liftBase $ unMStreamF sf a+  b `seq` return (b, liftMStreamFBase sf')++-- * MSFs within monadic actions++-- | Extract MSF from a monadic action+performOnFirstSample :: Monad m => m (MStreamF m a b) -> MStreamF m a b+performOnFirstSample sfaction = MStreamF $ \a -> do+  sf <- sfaction+  unMStreamF sf a++-- ** Delays and signal overwriting++iPre :: Monad m => a -> MStreamF m a a+iPre firsta = MStreamF $ \a -> return (firsta, delay a)+-- iPre firsta = feedback firsta $ lift swap+--   where swap (a,b) = (b, a)+-- iPre firsta = next firsta identity++-- FIXME: Remove delay from this module. We should try to make this module+-- small, keeping only primitives.+delay :: Monad m => a -> MStreamF m a a+delay = iPre++-- ** Switching++switch :: Monad m => MStreamF m a (b, Maybe c) -> (c -> MStreamF m a b) -> MStreamF m a b+switch sf f = MStreamF $ \a -> do+  ((b, c), sf') <- unMStreamF sf a+  return (b, maybe (switch sf' f) f c)++-- ** Feedback loops++feedback :: Monad m => c -> MStreamF m (a, c) (b, c) -> MStreamF m a b+feedback c sf = MStreamF $ \a -> do+  ((b', c'), sf') <- unMStreamF sf (a, c)+  return (b', feedback c' sf')++-- * Reactimating++-- | 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 liftMStreamF and (>>>), together+-- with some action that consumes/actuates on the output.+--+-- This is called "runSF" in Liu, Cheng, Hudak, "Causal Commutative Arrows and+-- Their Optimization"+embed :: Monad m => MStreamF m a b -> [a] -> m [b]+embed _  []     = return []+embed sf (a:as) = do+  (b, sf') <- unMStreamF sf a+  bs       <- embed sf' as+  return (b:bs)++-- | Runs an MSF indefinitely passing a unit-carrying input stream.+reactimate :: Monad m => MStreamF m () () -> m ()+reactimate sf = do+  (_, sf') <- unMStreamF sf ()+  reactimate sf'++-- | Runs an MSF indefinitely passing a unit-carrying input stream.+reactimateB :: Monad m => MStreamF m () Bool -> m ()+reactimateB sf = do+  (b, sf') <- unMStreamF sf ()+  if b then return () else reactimateB sf'

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

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

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

@@ -0,0 +1,27 @@+module Data.MonadicStreamFunction.Parallel where++-- External+import Control.Arrow+-- import Control.Parallel+import GHC.Conc++-- Internal+import Data.MonadicStreamFunction++-- IPerez: This should be similar to the following:+-- (msf1 *** msf2) >>> parS+-- where parS             = arr parTuple+--       parTuple p@(a,b) = (a `par` b `pseq` p)+-- Manuel: but we added strictness annotations to first+-- and so (***) might be strict in both arguments and not take+-- full advantage of parallelism.+--+(*|*) :: Monad m => MStreamF m a b -> MStreamF m c d -> MStreamF m (a, c) (b, d)+msf1 *|* msf2 = MStreamF $ \(a, c) -> do+    (b, msf1') <- unMStreamF msf1 a+    (d, msf2') <- unMStreamF msf2 c+    b `par` d `pseq` return ((b, d), msf1' *|* msf2')+++(&|&) :: Monad m => MStreamF m a b -> MStreamF m a c -> MStreamF m a (b, c)+msf1 &|& msf2 = arr (\a -> (a, a)) >>> (msf1 *|* msf2)

@@ -0,0 +1,7 @@+module Data.Tuple.Util where++assocR :: ((a, b), c) -> (a, (b, c))+assocR ((a, b), c) = (a, (b, c))++assocL :: (a, (b, c)) -> ((a, b), c)+assocL (a, (b, c)) = ((a, b), c)

@@ -0,0 +1,72 @@+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE UndecidableInstances   #-}+-- |+-- 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.++module Data.VectorSpace where++------------------------------------------------------------------------------+-- Vector space type relation+------------------------------------------------------------------------------++infixr 6 *^+infixl 6 ^/+infix 6 `dot`+infixl 5 ^+^, ^-^++-- TODO Add laws this should satisfy++class Num (Groundring v) => RModule v where+    type Groundring v+    zeroVector   :: v+    (*^)         :: Groundring v -> v -> v+    (^*)         :: v -> Groundring v -> v+    (^*) = flip (*^)+    (*^) = 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+class (Fractional (Groundring v), RModule v) => VectorSpace v where+    (^/)         :: v -> Groundfield v -> v+    v ^/ a = (1/a) *^ v++type family Groundfield v :: *+type instance Groundfield v = Groundring v++class RModule v => InnerProductSpace v where+    dot          :: v -> v -> Groundfield v++class RModule v => NormedSpace v  where+    norm         :: v -> Groundfield 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+normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"+    where nv = norm v+    -}

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

@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies           #-}+module Data.VectorSpace.Specific where++import Data.VectorSpace+++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

@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE TypeFamilies           #-}+module Data.VectorSpace.Tuples where++import Data.VectorSpace++------------------------------------------------------------------------------+-- Vector space instances for small tuples of Fractional+------------------------------------------------------------------------------++++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 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++-}++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)++instance Fractional a => VectorSpace (a,a,a) where+    (x,y,z) ^/ a = (x / a, y / a, z / a)+++instance Num a => InnerProductSpace (a,a,a) where+    (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2+++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)++instance Fractional a => VectorSpace (a,a,a,a) where+    (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a)+++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+++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)++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)+++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

@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (HaddockCoverage)+-- Copyright   :  (C) 2015 Ivan Perez+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Ivan Perez <ivan.perez@keera.co.uk>+-- Stability   :  provisional+-- Portability :  portable+--+-- Copyright notice: This file borrows code+-- https://hackage.haskell.org/package/lens-4.7/src/tests/doctests.hsc+-- which is itself licensed BSD-style as well.+--+-- Run haddock on a source tree and report if anything in any+-- module is not documented.+-----------------------------------------------------------------------------+module Main where++import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.Process+import Text.Regex.Posix++main :: IO ()+main = do+  -- Find haskell modules+  -- TODO: Ideally cabal should do this (provide us with the+  -- list of modules). An alternative would be to use cabal haddock+  -- but that would need a --no-html argument or something like that.+  -- Alternatively, we could use cabal haddock with additional arguments.+  --+  -- See:+  -- https://github.com/keera-studios/haddock/commit/d5d752943c4e5c6c9ffcdde4dc136fcee967c495+  -- https://github.com/haskell/haddock/issues/309#issuecomment-150811929+  files <- getSources++  let haddockArgs = [ "--no-warnings", "--ignore-all-exports" ] ++ files+  let cabalArgs   = [ "exec", "--", "haddock" ] ++ haddockArgs+  (code, out, _err) <- readProcessWithExitCode "cabal" cabalArgs ""++  -- Filter out coverage lines, and find those that denote undocumented+  -- modules.+  --+  -- TODO: is there a way to annotate a function as self-documenting,+  -- in the same way we do with ANN for hlint?+  let isIncompleteModule :: String -> Bool+      isIncompleteModule line = isCoverageLine line && not (line =~ "^ *100%")+        where isCoverageLine :: String -> Bool+              isCoverageLine line = line =~ "^ *[0-9]+%"++  let incompleteModules :: [String]+      incompleteModules = filter isIncompleteModule $ lines out++  -- Based on the result of haddock, report errors and exit.+  -- Note that, unline haddock, this script does not+  -- output anything to stdout. It uses stderr instead+  -- (as it should).+  case (code, incompleteModules) of+    (ExitSuccess  , []) -> return ()+    -- (ExitFailure _, _)  -> exitFailure+    (_            , _)  -> do+      hPutStrLn stderr "The following modules are not fully documented:"+      mapM_ (hPutStrLn stderr) incompleteModules+      exitFailure++getSources :: IO [FilePath]+getSources = filter isHaskellFile <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++    isHaskellFile fp = (isSuffixOf ".hs" fp || isSuffixOf ".lhs" fp)+                     && not (any (`isSuffixOf` fp) excludedFiles)++    excludedFiles = [ ]++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c++-- find-based implementation (not portable)+--+-- getSources :: IO [FilePath]+-- getSources = fmap lines $ readProcess "find" ["src/", "-iname", "*hs"] ""

@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (hlint)+-- Copyright   :  (C) 2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+    args <- getArgs+    hints <- hlint $ ["src", "--cross", "--hint=tests/HLint.hs" ] ++ args+    unless (null hints) exitFailure