artery (empty) → 0.1

raw patch · 4 files changed

+211/−0 lines, 4 filesdep +basedep +containersdep +profunctorssetup-changed

Dependencies added: base, containers, profunctors, transformers

Files

Control/Artery.hs +158/−0
LICENSE +30/−0
Setup.hs +2/−0
artery.cabal +21/−0

+ Control/Artery.hs view

@@ -0,0 +1,158 @@+{-# LANGUAGE Rank2Types #-}
+module Control.Artery (Artery(..)
+    , runArtery
+    , effectful
+    , stateful
+    , scan
+    , scanM
+    , fromList
+    , runList
+    , feedback
+    , delay1
+    , delay
+    , module Control.Arrow) where
+
+import qualified Control.Category
+import Control.Arrow
+import Control.Applicative
+import qualified Data.Sequence as Seq
+import Data.Monoid
+import Data.Profunctor
+import Control.Monad.Trans.State
+
+-- | 'Artery' is a device that produces a value from the input every beat.
+newtype Artery m i o = Artery { unArtery :: forall r. i -> (o -> Artery m i o -> m r) -> m r }
+
+instance Control.Category.Category (Artery m) where
+    id = Artery $ \x cont -> cont x Control.Category.id
+    Artery f . Artery g = Artery $ \x cont -> g x $ \y g' -> f y $ \z f' -> cont z (f' Control.Category.. g')
+
+instance Arrow (Artery m) where
+    arr f = let a = Artery $ \x cont -> cont (f x) a in a
+    {-# INLINE arr #-}
+    Artery f *** Artery g = Artery $ \(x, y) cont -> f x $ \x' f' -> g y $ \y' g' -> cont (x', y') (f' *** g')
+    Artery f &&& Artery g = Artery $ \i cont -> f i $ \x f' -> g i $ \y g' -> cont (x, y) (f' &&& g')
+    first (Artery f) = Artery $ \(x, y) cont -> f x $ \x' f' -> cont (x', y) (first f')
+    second (Artery f) = Artery $ \(y, x) cont -> f x $ \x' f' -> cont (y, x') (second f')
+
+instance ArrowChoice (Artery m) where
+    left f = f +++ Control.Category.id
+    {-# INLINE left #-}
+    right f = Control.Category.id +++ f
+    {-# INLINE right #-}
+    f +++ g = Left <$> f ||| Right <$> g
+    {-# INLINE (+++) #-}
+    f ||| g = Artery $ \e cont -> case e of
+        Left x -> unArtery f x $ \o f' -> cont o (f' ||| g)
+        Right x -> unArtery g x $ \o g' -> cont o (f ||| g')
+
+instance Functor (Artery m i) where
+    fmap f = go where
+        go (Artery v) = Artery $ \x cont -> v x $ \a v' -> cont (f a) (go v')
+    {-# INLINE fmap #-}
+
+instance Applicative (Artery m i) where
+    pure x = go where
+        go = Artery $ \_ cont -> cont x go
+    {-# INLINE pure #-}
+    Artery ff <*> Artery fx = Artery $ \i cont -> ff i $ \f ff' -> fx i $ \x fx' -> cont (f x) (ff' <*> fx')
+
+instance Profunctor (Artery m) where
+    dimap f g = go where
+        go (Artery v) = Artery $ \i cont -> v (f i) $ \o v' -> cont (g o) (go v')
+    {-# INLINE dimap #-}
+
+instance Strong (Artery m) where
+    first' = first
+    {-# INLINE first' #-}
+    second' = second
+    {-# INLINE second' #-}
+
+instance Choice (Artery m) where
+    left' = left
+    {-# INLINE left' #-}
+    right' = right 
+    {-# INLINE right' #-}
+
+instance Num o => Num (Artery m i o) where
+    (+) = liftA2 (+)
+    {-# INLINE (+) #-}
+    (-) = liftA2 (-)
+    {-# INLINE (-) #-}
+    (*) = liftA2 (*)
+    {-# INLINE (*) #-}
+    abs = fmap abs
+    {-# INLINE abs #-}
+    signum = fmap signum
+    {-# INLINE signum #-}
+    fromInteger = pure . fromInteger
+    {-# INLINE fromInteger #-}
+
+instance Monoid o => Monoid (Artery m i o) where
+    mempty = pure mempty
+    {-# INLINE mempty #-}
+    mappend = liftA2 mappend
+    {-# INLINE mappend #-}
+
+-- | Run the given action every beat.
+effectful :: Monad m => (i -> m o) -> Artery m i o
+effectful m = go where
+    go = Artery $ \i cont -> m i >>= \o -> cont o go
+{-# INLINE effectful #-}
+
+-- | Run the given stateful action every beat.
+stateful :: Monad m => (i -> StateT s m o) -> s -> Artery m i o
+stateful m = go where
+    go s = Artery $ \i cont -> runStateT (m i) s >>= \(o, s') -> cont o (go s')
+{-# INLINE stateful #-}
+
+-- | Produce values by accumulating inputs.
+scan :: (i -> a -> a) -> a -> Artery m i a
+scan f = go where
+    go x = Artery $ \i cont -> cont x (go (f i x))
+{-# INLINE scan #-}
+
+-- | Analogous to 'scan', but it allows monadic accumulators.
+scanM :: Monad m => (i -> a -> m a) -> a -> Artery m i a
+scanM f = go where
+    go x = Artery $ \i cont -> f i x >>= \a -> cont x (go a)
+{-# INLINE scanM #-}
+
+-- | Pump up the 'Artery'.
+runArtery :: Monad m => Artery m i o -> i -> m (o, Artery m i o)
+runArtery (Artery v) i = v i (curry return)
+{-# INLINE runArtery #-}
+
+-- | Analogous to 'loop', but the feedback will be delayed a beat.
+feedback :: r -> Artery m (i, r) (o, r) -> Artery m i o
+feedback r (Artery v) = Artery $ \i cont -> v (i, r) $ \(o, r') v' -> cont o (feedback r' v')
+
+-- | Delay a beat. The first argument is the default value for the output.
+delay1 :: a -> Artery m a a
+delay1 = scan const
+{-# INLINE delay1 #-}
+
+-- | 'delay n' propagates a signal n beat behind. 
+delay :: Int -> a -> Artery m a a
+delay n d = go (Seq.replicate n d) where
+    go buf = Artery $ \i cont -> case Seq.viewl buf of
+        a Seq.:< buf' -> cont a $ go $ buf' Seq.|> i
+{-# INLINE delay #-}
+
+fromList :: [a] -> Artery m b a
+fromList seq = go seq where
+    go (x:xs) = Artery $ \_ cont -> cont x (go xs)
+    go [] = go seq
+
+runList :: Applicative m => Artery m a b -> [a] -> m [b]
+runList ar (x:xs) = unArtery ar x $ \y cont -> (y:) <$> runList cont xs
+runList _ [] = pure []
+
+triggered :: Monoid a => [a] -> Artery m Bool a
+triggered w = go [] where
+    zipLong (x:xs) (y:ys) = mappend x y : zipLong xs ys
+    zipLong xs [] = xs
+    zipLong [] ys = ys
+    go wav = Artery $ \i cont -> case (if i then id else zipLong w) wav of
+        x:xs -> cont x (go xs)
+        _ -> cont mempty (go [])

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Fumiaki Kinoshita
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Fumiaki Kinoshita 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ artery.cabal view

@@ -0,0 +1,21 @@+name:                artery
+version:             0.1
+synopsis:            A simple, arrow-based reactive programming
+description:         This package only provides Artery type and associated operations.
+homepage:            https://github.com/fumieval/artery
+license:             BSD3
+license-file:        LICENSE
+author:              Fumiaki Kinoshita
+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
+copyright:           Copyright (C) 2013 Fumiaki Kinoshita
+category:            Control, FRP
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Control.Artery
+  -- other-modules:       
+  other-extensions:    Rank2Types
+  build-depends:       base == 4.*, containers, profunctors >= 3.0 && < 5, transformers == 0.3.*
+  -- hs-source-dirs:      
+  default-language:    Haskell2010