arrows-0.4.4.1/0000755000000000000000000000000012023105557011361 5ustar0000000000000000arrows-0.4.4.1/Setup.hs0000644000000000000000000000012712023105557013015 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain arrows-0.4.4.1/LICENSE0000644000000000000000000000311312023105557012364 0ustar0000000000000000The Glasgow Haskell Compiler License Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. arrows-0.4.4.1/arrows.cabal0000644000000000000000000000225512023105557013666 0ustar0000000000000000Name: arrows Version: 0.4.4.1 Build-Depends: base >= 4.0 && < 6, Stream Build-Type: Simple License: BSD3 License-file: LICENSE Author: Ross Paterson Maintainer: Ross Paterson Homepage: http://www.haskell.org/arrows/ Category: Control Synopsis: Arrow classes and transformers Description: Several classes that extend the Arrow class, and some transformers that implement or lift these classes. Exposed-Modules: Control.Arrow.Operations Control.Arrow.Transformer.Automaton Control.Arrow.Transformer.CoState Control.Arrow.Transformer.Error Control.Arrow.Transformer.State Control.Arrow.Transformer.Static Control.Arrow.Transformer.Stream Control.Arrow.Transformer.Writer Control.Arrow.Transformer.Reader Control.Arrow.Transformer.All Control.Arrow.Transformer Other-Modules: Control.Arrow.Internals Extensions: MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances arrows-0.4.4.1/Control/0000755000000000000000000000000012023105557013001 5ustar0000000000000000arrows-0.4.4.1/Control/Arrow/0000755000000000000000000000000012023105557014073 5ustar0000000000000000arrows-0.4.4.1/Control/Arrow/Operations.hs0000644000000000000000000001321212023105557016551 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Operations -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Subclasses of 'Arrow' providing additional operations. -- -- The signatures are designed to be compatible with the proposed -- notation for arrows, cf. . module Control.Arrow.Operations ( -- * Conventions -- $conventions -- * State transformers ArrowState(..), -- * State readers ArrowReader(..), -- * Monoid writers ArrowWriter(..), -- * Errors ArrowError(..), tryInUnlessDefault, -- * Synchronous circuits ArrowCircuit(..), ) where import Control.Arrow import Data.Monoid -- $conventions -- The arrow classes defined in this module have names like @Arrow@/Foo/, -- and contain operations specific to such arrows. Some of these include -- a method @new@/Foo/, which maps computations to computations of the -- same arrow type, but exposing some of the internals of the arrow. -- -- Arrow transformers have names like /Bar/@Arrow@, and are -- instances of appropriate arrow classes. For each arrow -- transformer, there is typically an encapsulation operator -- @run@/Bar/ that removes that transformer from the outside of an -- arrow type. The 'Control.Arrow.Transformer.lift' method of the -- 'Control.Arrow.Transformer.ArrowTransformer' class adds an arrow -- transformer to the outside of an arrow type. -- -- Typically a composite arrow type is built by applying a series of arrow -- transformers to a base arrow (usually either a function arrow or a -- 'Kleisli' arrow. The 'Control.Arrow.Transformer.lift' method and the -- @run@/Bar/ function operate only on the arrow transformer at the top -- of this stack. For more sophisticated manipulation of this stack of -- arrow transformers, many arrow transformers provide an @ArrowAdd@/Bar/ -- class, with methods methods @lift@/Bar/ and @elim@/Bar/ to add and remove -- the transformer anywhere in the stack. -- | An arrow type that provides a read-only state (an environment). -- If you also need to modify the state, use 'ArrowState'. class Arrow a => ArrowReader r a | a -> r where -- | Obtain the current value of the state. readState :: a b r -- | Run a subcomputation in the same arrow, but with a different -- environment. The environment of the outer computation is -- unaffected. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|newReader cmd|) env newReader :: a e b -> a (e,r) b -- | An arrow type that provides a modifiable state, -- based of section 9 of /Generalising Monads to Arrows/, by John Hughes, -- /Science of Computer Programming/ 37:67-111, May 2000. class Arrow a => ArrowState s a | a -> s where -- | Obtain the current value of the state. fetch :: a e s -- | Assign a new value to the state. store :: a s () -- | An arrow type that collects additional output (of some 'Monoid' type). class (Monoid w, Arrow a) => ArrowWriter w a | a -> w where -- | Add a piece of additional output. write :: a w () -- | Run a subcomputation in the same arrow, making its additional -- output accessible. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > (value, output) <- (|newWriter cmd|) newWriter :: a e b -> a e (b,w) -- | An arrow type that includes errors (or exceptions). -- -- Minimal definition: 'raise' and 'tryInUnless'. -- -- /TODO:/ the operations here are inconsistent with other arrow transformers. class Arrow a => ArrowError ex a | a -> ex where -- | Raise an error. raise :: a ex b -- | Traditional exception construct. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > body `handle` \ex -> handler handle :: a e b -- ^ computation that may raise errors -> a (e,ex) b -- ^ computation to handle errors -> a e b handle f h = tryInUnless f (arr snd) h -- | Exception construct in the style of /Exceptional Syntax/, -- by Nick Benton and Andrew Kennedy, /JFP/ 11(4):395-410, July 2001. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|tryInUnless -- > body -- > (\res -> success) -- > (\ex -> handler) -- > |) tryInUnless :: a e b -- ^ computation that may raise errors -> a (e,b) c -- ^ computation to receive successful results -> a (e,ex) c -- ^ computation to handle errors -> a e c -- | Handler that returns the error as a value. newError :: a e b -> a e (Either ex b) newError f = handle (f >>> arr Right) (arr (Left . snd)) -- | A suitable value for 'tryInUnless' when the arrow type belongs to -- 'ArrowChoice'. To use it, you must define either 'handle' or 'newError'. tryInUnlessDefault :: (ArrowError ex a, ArrowChoice a) => a e b -- ^ computation that may raise errors -> a (e,b) c -- ^ computation to receive successful results -> a (e,ex) c -- ^ computation to handle errors -> a e c tryInUnlessDefault f s h = arr id &&& newError f >>> arr dist >>> h ||| s where dist (e, Left ex) = Left (e, ex) dist (e, Right b) = Right (e, b) -- tryInUnless (and thus handle) could be replaced by newError if: -- 1. When ArrowChoice is available, tryInUnless and newError are equivalent. -- 2. When tryInUnless is available, so is ArrowChoice. -- (Counterexample: general CoKleisli) -- | An arrow type that can be used to interpret synchronous circuits. class ArrowLoop a => ArrowCircuit a where -- | A delay component. delay :: b -- ^ the value to return initially. -> a b b -- ^ an arrow that propagates its input -- with a one-tick delay. arrows-0.4.4.1/Control/Arrow/Transformer.hs0000644000000000000000000000142712023105557016735 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- Arrow transformers, for making new arrow types out of old ones. module Control.Arrow.Transformer ( ArrowTransformer(..) ) where import Control.Arrow -- | Construct a new arrow from an existing one. class (Arrow a, Arrow (f a)) => ArrowTransformer f a where -- | A transformation of arrows, preserving 'arr', '>>>' and 'first'. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|lift cmd|) lift :: a b c -> f a b c arrows-0.4.4.1/Control/Arrow/Internals.hs0000644000000000000000000002163012023105557016370 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Internals -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Manipulation of composite arrow types, beyond the basic lifting and -- encapsulation provided with each arrow transformer. -- -- The signatures are designed to be compatible with the proposed notation -- for arrows, cf. . -- #hide module Control.Arrow.Internals ( ArrowAddState(..), ArrowAddReader(..), ArrowAddWriter(..), ArrowAddError(..), ArrowAddStream(..), ) where import Control.Arrow import Control.Arrow.Operations import Data.Stream -- | Adding a 'Control.Arrow.Transformer.State.StateArrow' to an -- arrow type, but not necessarily as the outer arrow transformer. -- -- Typically a composite arrow type is built by applying a series -- of arrow transformer to a base arrow (usually either a function -- arrow or a 'Kleisli' arrow. One can add a transformer to the -- top of this stack using the 'Control.Arrow.Transformer.lift' -- method of the 'Control.Arrow.Transformer.ArrowTransformer' class, -- or remove a state transformer from the top of the stack using the -- 'Control.Arrow.Transformer.State.runState' encapsulation operator. -- The methods of this class add and remove state transformers anywhere -- in the stack. In the instance -- -- > instance Arrow a => ArrowAddState s (ArrowState s a) a -- -- they are equivalent to 'Control.Arrow.Transformer.lift' and -- 'Control.Arrow.Transformer.State.runState' respectively. -- Instances are lifted through other transformers with -- -- > instance ArrowAddState s a a' => -- > ArrowAddState s (FooArrow a) (FooArrow a') class (ArrowState s a, Arrow a') => ArrowAddState s a a' | a -> a' where -- | Lift a computation from an arrow to one with an added state. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|liftState cmd|) liftState :: a' e b -> a e b -- | Elimination of a state transformer from a computation, -- exposing the initial and final states. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > (result, final_state) <- (|elimState cmd|) init_state elimState :: a e b -> a' (e,s) (b,s) -- | Adding a 'Control.Arrow.Transformer.Reader.ReaderArrow' to an -- arrow type, but not necessarily as the outer arrow transformer. -- -- Typically a composite arrow type is built by applying a series -- of arrow transformer to a base arrow (usually either a function -- arrow or a 'Kleisli' arrow. One can add a transformer to the -- top of this stack using the 'Control.Arrow.Transformer.lift' -- method of the 'Control.Arrow.Transformer.ArrowTransformer' class, -- or remove a state transformer from the top of the stack using the -- 'Control.Arrow.Transformer.Reader.runReader' encapsulation operator. -- The methods of this class add and remove state transformers anywhere -- in the stack. In the instance -- -- > instance Arrow a => ArrowAddReader r (ArrowReader r a) a -- -- they are equivalent to 'Control.Arrow.Transformer.lift' and -- 'Control.Arrow.Transformer.Reader.runReader' respectively. -- Instances are lifted through other transformers with -- -- > instance ArrowAddReader r a a' => -- > ArrowAddReader r (FooArrow a) (FooArrow a') class (ArrowReader r a, Arrow a') => ArrowAddReader r a a' | a -> a' where -- | Lift a computation from an arrow to one with an added environment. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|liftReader cmd|) liftReader :: a' e b -> a e b -- | Elimination of a state reader from a computation, -- taking a value for the state. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|elimReader cmd|) env elimReader :: a e b -> a' (e,r) b -- | Adding a 'Control.Arrow.Transformer.Writer.WriterArrow' to an -- arrow type, but not necessarily as the outer arrow transformer. -- -- Typically a composite arrow type is built by applying a series -- of arrow transformer to a base arrow (usually either a function -- arrow or a 'Kleisli' arrow. One can add a transformer to the -- top of this stack using the 'Control.Arrow.Transformer.lift' -- method of the 'Control.Arrow.Transformer.ArrowTransformer' class, -- or remove a state transformer from the top of the stack using the -- 'Control.Arrow.Transformer.Writer.runWriter' encapsulation operator. -- The methods of this class add and remove state transformers anywhere -- in the stack. In the instance -- -- > instance Arrow a => ArrowAddWriter w (ArrowWriter w a) a -- -- they are equivalent to 'Control.Arrow.Transformer.lift' and -- 'Control.Arrow.Transformer.Writer.runWriter' respectively. -- Instances are lifted through other transformers with -- -- > instance ArrowAddWriter w a a' => -- > ArrowAddWriter w (FooArrow a) (FooArrow a') class (ArrowWriter w a, Arrow a') => ArrowAddWriter w a a' | a -> a' where -- | Lift a computation from an arrow to one with added output. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|liftWriter cmd|) liftWriter :: a' e b -> a e b -- | Elimination of an output writer from a computation, -- providing the accumulated output. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > (result, output) <- (|elimWriter cmd|) elimWriter :: a e b -> a' e (b,w) -- | Adding a 'Control.Arrow.Transformer.Error.ErrorArrow' to an -- arrow type, but not necessarily as the outer arrow transformer. -- -- Typically a composite arrow type is built by applying a series -- of arrow transformer to a base arrow (usually either a function -- arrow or a 'Kleisli' arrow. One can add a transformer to the -- top of this stack using the 'Control.Arrow.Transformer.lift' -- method of the 'Control.Arrow.Transformer.ArrowTransformer' class, -- or remove a state transformer from the top of the stack using the -- 'Control.Arrow.Transformer.Error.runError' encapsulation operator. -- The methods of this class add and remove state transformers anywhere -- in the stack. In the instance -- -- > instance Arrow a => ArrowAddError ex (ArrowError ex a) a -- -- they are equivalent to 'Control.Arrow.Transformer.lift' and -- 'Control.Arrow.Transformer.Error.runError' respectively. -- Instances are lifted through other transformers with -- -- > instance ArrowAddError ex a a' => -- > ArrowAddError ex (FooArrow a) (FooArrow a') -- -- This could be combined with 'Control.Arrow.Transformer.Error.handle', -- since the resulting arrow is always the arrow of the handler. -- Separating them has the advantage of consistency with the other arrows, -- and might give more helpful type error messages. class (ArrowError ex a, Arrow a') => ArrowAddError ex a a' | a -> a' where -- | Lift a computation from an arrow to one with error handling. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|liftError cmd|) liftError :: a' e b -> a e b -- | Elimination of errors from a computation, -- by completely handling any errors. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > body `elimError` \ex -> handler elimError :: a e b -> a' (e,ex) b -> a' e b -- | Adding a 'Control.Arrow.Transformer.Stream.StreamArrow' to an -- arrow type, but not necessarily as the outer arrow transformer. -- -- Typically a composite arrow type is built by applying a series -- of arrow transformer to a base arrow (usually either a function -- arrow or a 'Kleisli' arrow. One can add a transformer to the -- top of this stack using the 'Control.Arrow.Transformer.lift' -- method of the 'Control.Arrow.Transformer.ArrowTransformer' class, -- or remove a state transformer from the top of the stack using the -- 'Control.Arrow.Transformer.Stream.runStream' encapsulation operator. -- The methods of this class add and remove state transformers anywhere -- in the stack. In the instance -- -- > instance Arrow a => ArrowAddStream (ArrowStream a) a -- -- they are equivalent to 'Control.Arrow.Transformer.lift' and -- 'Control.Arrow.Transformer.Stream.runStream' respectively. -- Instances are lifted through other transformers with -- -- > instance ArrowAddStream a a' => -- > ArrowAddStream (FooArrow a) (FooArrow a') class (ArrowCircuit a, Arrow a') => ArrowAddStream a a' | a -> a' where -- | Lift a computation from an arrow to a stream processing one. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|liftStream cmd|) liftStream :: a' e b -> a e b -- | Run a stream processor on a stream of inputs, -- obtaining a stream of outputs. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > ys <- (|elimStream (\x -> ...)|) xs -- -- Here @xs@ refers to the input stream and @x@ to individual -- elements of that stream. @ys@ is bound to the output stream. elimStream :: a (e,b) c -> a' (e,Stream b) (Stream c) arrows-0.4.4.1/Control/Arrow/Transformer/0000755000000000000000000000000012023105557016375 5ustar0000000000000000arrows-0.4.4.1/Control/Arrow/Transformer/State.hs0000644000000000000000000001203312023105557020010 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.State -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- An arrow transformer that adds a modifiable state, -- based of section 9 of /Generalising Monads to Arrows/, by John Hughes, -- /Science of Computer Programming/ 37:67-111, May 2000. module Control.Arrow.Transformer.State( StateArrow(StateArrow), runState, ArrowAddState(..), ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative import Control.Arrow import Control.Category import Data.Monoid import Prelude hiding (id,(.)) -- | An arrow type that augments an existing arrow with a modifiable -- state. The 'ArrowState' class contains the operations on this state. newtype StateArrow s a b c = StateArrow (a (b, s) (c, s)) swapsnd :: ((a, b), c) -> ((a, c), b) swapsnd ~(~(x, y), z) = ((x, z), y) instance Category a => Category (StateArrow s a) where id = StateArrow id StateArrow f . StateArrow g = StateArrow (f . g) instance Arrow a => Arrow (StateArrow s a) where arr f = StateArrow (arr (\(x, s) -> (f x, s))) first (StateArrow f) = StateArrow (arr swapsnd >>> first f >>> arr swapsnd) instance Arrow a => ArrowTransformer (StateArrow s) a where lift f = StateArrow (first f) -- | Encapsulation of a state-using computation, exposing the initial -- and final states. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > (result, final_state) <- (|runState cmd|) init_state runState :: Arrow a => StateArrow s a e b -> a (e,s) (b,s) runState (StateArrow f) = f -- operations instance Arrow a => ArrowState s (StateArrow s a) where fetch = StateArrow (arr (\(_, s) -> (s, s))) store = StateArrow (arr (\(s, _) -> ((), s))) instance Arrow a => ArrowAddState s (StateArrow s a) a where liftState = lift elimState = runState -- The following promotions follow directly from the arrow transformer. instance ArrowZero a => ArrowZero (StateArrow s a) where zeroArrow = StateArrow zeroArrow instance ArrowCircuit a => ArrowCircuit (StateArrow s a) where delay x = lift (delay x) instance ArrowError ex a => ArrowError ex (StateArrow s a) where raise = lift raise handle (StateArrow f) (StateArrow h) = StateArrow (handle f (arr swapsnd >>> h)) tryInUnless (StateArrow f) (StateArrow s) (StateArrow h) = StateArrow (tryInUnless f (arr new_state >>> s) (arr swapsnd >>> h)) where new_state ((b,_),(c,s')) = ((b,c),s') newError (StateArrow f) = StateArrow (newError f &&& arr snd >>> arr h) where h (Left ex, s) = (Left ex, s) h (Right (c, s'), _) = (Right c, s') -- Note that in each case the error handler gets the original state. instance ArrowReader r a => ArrowReader r (StateArrow s a) where readState = lift readState newReader (StateArrow f) = StateArrow (arr swapsnd >>> newReader f) instance ArrowWriter w a => ArrowWriter w (StateArrow s a) where write = lift write newWriter (StateArrow f) = StateArrow (newWriter f >>> arr swapsnd) -- liftings of standard classes instance ArrowChoice a => ArrowChoice (StateArrow s a) where left (StateArrow f) = StateArrow (arr distr >>> left f >>> arr undistr) where distr (Left y, s) = Left (y, s) distr (Right z, s) = Right (z, s) undistr (Left (y, s)) = (Left y, s) undistr (Right (z, s)) = (Right z, s) instance ArrowApply a => ArrowApply (StateArrow s a) where app = StateArrow (arr (\((StateArrow f, x), s) -> (f, (x, s))) >>> app) instance ArrowLoop a => ArrowLoop (StateArrow s a) where loop (StateArrow f) = StateArrow (loop (arr swapsnd >>> f >>> arr swapsnd)) instance ArrowPlus a => ArrowPlus (StateArrow s a) where StateArrow f <+> StateArrow g = StateArrow (f <+> g) -- Other instances instance Arrow a => Functor (StateArrow s a b) where fmap f g = g >>> arr f instance Arrow a => Applicative (StateArrow s a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance ArrowPlus a => Alternative (StateArrow s a b) where empty = zeroArrow f <|> g = f <+> g instance ArrowPlus a => Monoid (StateArrow s a b c) where mempty = zeroArrow mappend f g = f <+> g -- promotions instance ArrowAddReader r a a' => ArrowAddReader r (StateArrow s a) (StateArrow s a') where liftReader (StateArrow f) = StateArrow (liftReader f) elimReader (StateArrow f) = StateArrow (arr swapsnd >>> elimReader f) instance ArrowAddWriter w a a' => ArrowAddWriter w (StateArrow s a) (StateArrow s a') where liftWriter (StateArrow f) = StateArrow (liftWriter f) elimWriter (StateArrow f) = StateArrow (elimWriter f >>> arr swapsnd) instance ArrowAddError ex a a' => ArrowAddError ex (StateArrow s a) (StateArrow s a') where liftError (StateArrow f) = StateArrow (liftError f) elimError (StateArrow f) (StateArrow h) = StateArrow (elimError f (arr swapsnd >>> h)) arrows-0.4.4.1/Control/Arrow/Transformer/CoState.hs0000644000000000000000000000400412023105557020271 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.CoState -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Transformation of state readers. -- -- /TODO:/ define operations for this arrow. module Control.Arrow.Transformer.CoState( CoStateArrow(CoStateArrow), ) where import Control.Applicative import Control.Arrow import Control.Category import Data.Monoid import Prelude hiding (id,(.)) newtype CoStateArrow s a b c = CoStateArrow (a (s -> b) (s -> c)) instance Category a => Category (CoStateArrow s a) where id = CoStateArrow id CoStateArrow f . CoStateArrow g = CoStateArrow (f . g) instance Arrow a => Arrow (CoStateArrow s a) where arr f = CoStateArrow (arr (f .)) first (CoStateArrow f) = CoStateArrow (arr unzipMap >>> first f >>> arr zipMap) zipMap :: (s -> a, s -> b) -> (s -> (a,b)) zipMap h s = (fst h s, snd h s) unzipMap :: (s -> (a,b)) -> (s -> a, s -> b) unzipMap h = (fst . h, snd . h) -- there is no transformer -- promotions of standard classes instance ArrowLoop a => ArrowLoop (CoStateArrow s a) where loop (CoStateArrow f) = CoStateArrow (loop (arr zipMap >>> f >>> arr unzipMap)) instance ArrowZero a => ArrowZero (CoStateArrow s a) where zeroArrow = CoStateArrow zeroArrow instance ArrowPlus a => ArrowPlus (CoStateArrow s a) where CoStateArrow f <+> CoStateArrow g = CoStateArrow (f <+> g) -- Other instances instance Arrow a => Functor (CoStateArrow s a b) where fmap f g = g >>> arr f instance Arrow a => Applicative (CoStateArrow s a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance ArrowPlus a => Alternative (CoStateArrow s a b) where empty = zeroArrow f <|> g = f <+> g instance ArrowPlus a => Monoid (CoStateArrow s a b c) where mempty = zeroArrow mappend f g = f <+> g arrows-0.4.4.1/Control/Arrow/Transformer/All.hs0000644000000000000000000000131412023105557017440 0ustar0000000000000000-- #hide module Control.Arrow.Transformer.All( module Control.Arrow.Transformer.Automaton, module Control.Arrow.Transformer.CoState, module Control.Arrow.Transformer.Error, module Control.Arrow.Transformer.Reader, module Control.Arrow.Transformer.State, module Control.Arrow.Transformer.Static, module Control.Arrow.Transformer.Stream, module Control.Arrow.Transformer.Writer ) where import Control.Arrow.Transformer.Automaton import Control.Arrow.Transformer.CoState import Control.Arrow.Transformer.Error import Control.Arrow.Transformer.Reader import Control.Arrow.Transformer.State import Control.Arrow.Transformer.Static import Control.Arrow.Transformer.Stream import Control.Arrow.Transformer.Writer arrows-0.4.4.1/Control/Arrow/Transformer/Reader.hs0000644000000000000000000001145712023105557020143 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.Reader -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Arrow transformer that adds a read-only state (i.e. an environment). module Control.Arrow.Transformer.Reader( ReaderArrow(ReaderArrow), runReader, ArrowAddReader(..), ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative import Control.Arrow import Control.Category import Data.Monoid import Prelude hiding (id,(.)) -- | An arrow type that augments an existing arrow with a read-only state -- (or environment). The 'ArrowReader' class contains the operations -- on this state. newtype ReaderArrow r a b c = ReaderArrow (a (b, r) c) -- | Encapsulation of a state-reading computation, taking a value for the -- state. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > (|runReader cmd|) env runReader :: Arrow a => ReaderArrow r a e b -> a (e,r) b runReader (ReaderArrow f) = f -- arrow transformer instance Arrow a => ArrowTransformer (ReaderArrow r) a where lift f = ReaderArrow (arr fst >>> f) -- liftings of standard classes instance Arrow a => Category (ReaderArrow r a) where id = ReaderArrow (arr fst) ReaderArrow f . ReaderArrow g = ReaderArrow (f . first g . arr dupenv) where dupenv (a, r) = ((a, r), r) instance Arrow a => Arrow (ReaderArrow r a) where arr f = ReaderArrow (arr (f . fst)) first (ReaderArrow f) = ReaderArrow (arr swapsnd >>> first f) swapsnd :: ((a, r), b) -> ((a, b), r) swapsnd ~(~(a, r), b) = ((a, b), r) instance ArrowChoice a => ArrowChoice (ReaderArrow r a) where left (ReaderArrow f) = ReaderArrow (arr dist' >>> left f) where dist' :: (Either b c, r) -> Either (b, r) c dist' (Left b, r) = Left (b, r) dist' (Right c, _) = Right c instance ArrowApply a => ArrowApply (ReaderArrow r a) where app = ReaderArrow (arr (\((ReaderArrow f, a), r) -> (f, (a, r))) >>> app) instance ArrowZero a => ArrowZero (ReaderArrow r a) where zeroArrow = lift zeroArrow instance ArrowPlus a => ArrowPlus (ReaderArrow r a) where ReaderArrow f <+> ReaderArrow g = ReaderArrow (f <+> g) instance ArrowLoop a => ArrowLoop (ReaderArrow r a) where loop (ReaderArrow f) = ReaderArrow (loop (arr swapsnd >>> f)) -- new instances instance Arrow a => ArrowReader r (ReaderArrow r a) where readState = ReaderArrow (arr snd) newReader (ReaderArrow f) = ReaderArrow (arr fst >>> f) instance Arrow a => ArrowAddReader r (ReaderArrow r a) a where liftReader = lift elimReader = runReader -- liftings of other classes instance ArrowCircuit a => ArrowCircuit (ReaderArrow r a) where delay x = lift (delay x) instance ArrowError ex a => ArrowError ex (ReaderArrow r a) where raise = lift raise handle (ReaderArrow f) (ReaderArrow h) = ReaderArrow (handle f (arr swapsnd >>> h)) tryInUnless (ReaderArrow f) (ReaderArrow s) (ReaderArrow h) = ReaderArrow (tryInUnless f (arr swapsnd >>> s) (arr swapsnd >>> h)) newError (ReaderArrow f) = ReaderArrow (newError f) instance ArrowState s a => ArrowState s (ReaderArrow r a) where fetch = lift fetch store = lift store instance ArrowWriter s a => ArrowWriter s (ReaderArrow r a) where write = lift write newWriter (ReaderArrow f) = ReaderArrow (newWriter f) -- Promotions of encapsulation operators. instance ArrowAddError ex a a' => ArrowAddError ex (ReaderArrow r a) (ReaderArrow r a') where liftError (ReaderArrow f) = ReaderArrow (liftError f) elimError (ReaderArrow f) (ReaderArrow h) = ReaderArrow (elimError f (arr swapsnd >>> h)) instance ArrowAddState s a a' => ArrowAddState s (ReaderArrow r a) (ReaderArrow r a') where liftState (ReaderArrow f) = ReaderArrow (liftState f) elimState (ReaderArrow f) = ReaderArrow (arr swapsnd >>> elimState f) -- instance ArrowAddReader r a a' => -- ArrowAddReader r (ReaderArrow r a) (ReaderArrow r a') where -- elimReader (ReaderArrow f) = ReaderArrow (arr swapsnd >>> elimReader f) instance ArrowAddWriter s a a' => ArrowAddWriter s (ReaderArrow r a) (ReaderArrow r a') where liftWriter (ReaderArrow f) = ReaderArrow (liftWriter f) elimWriter (ReaderArrow f) = ReaderArrow (elimWriter f) -- Other instances instance Arrow a => Functor (ReaderArrow r a b) where fmap f g = g >>> arr f instance Arrow a => Applicative (ReaderArrow r a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance ArrowPlus a => Alternative (ReaderArrow r a b) where empty = zeroArrow f <|> g = f <+> g instance ArrowPlus a => Monoid (ReaderArrow r a b c) where mempty = zeroArrow mappend f g = f <+> g arrows-0.4.4.1/Control/Arrow/Transformer/Error.hs0000644000000000000000000001322612023105557020026 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.Error -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- An arrow transformer that adds error handling. -- -- /TODO:/ the operations here are inconsistent with other arrow transformers. module Control.Arrow.Transformer.Error( ErrorArrow(ErrorArrow), runError, ArrowAddError(..), ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative import Control.Arrow import Control.Category import Data.Monoid import Prelude hiding (id,(.)) -- | An arrow that augments an existing arrow with possible errors. -- The 'ArrowError' class contains methods for raising and handling -- these errors. newtype ErrorArrow ex a b c = ErrorArrow (a b (Either ex c)) rstrength :: (Either ex a, b) -> Either ex (a, b) rstrength (Left ex, _) = Left ex rstrength (Right a, b) = Right (a, b) -- | Encapsulate an error-raising computation, -- by completely handling any errors. -- -- Typical usage in arrow notation: -- -- > proc p -> ... -- > body `runError` \ex -> handler runError :: ArrowChoice a => ErrorArrow ex a e b -- ^ computation that may raise errors -> a (e,ex) b -- ^ computation to handle errors -> a e b runError (ErrorArrow f) h = arr id &&& f >>> arr strength >>> h ||| arr id where strength (x, Left y) = Left (x, y) strength (_, Right z) = Right z -- transformer instance ArrowChoice a => ArrowTransformer (ErrorArrow ex) a where lift f = ErrorArrow (f >>> arr Right) -- liftings of standard classes instance ArrowChoice a => Category (ErrorArrow ex a) where id = ErrorArrow (arr Right) ErrorArrow f . ErrorArrow g = ErrorArrow (arr (either Left id) . right f . g) instance ArrowChoice a => Arrow (ErrorArrow ex a) where arr f = ErrorArrow (arr (Right . f)) first (ErrorArrow f) = ErrorArrow (first f >>> arr rstrength) instance ArrowChoice a => ArrowChoice (ErrorArrow ex a) where left (ErrorArrow f) = ErrorArrow (left f >>> arr assocsum) assocsum :: Either (Either a b) c -> Either a (Either b c) assocsum (Left (Left a)) = Left a assocsum (Left (Right b)) = Right (Left b) assocsum (Right c) = Right (Right c) instance (ArrowChoice a, ArrowApply a) => ArrowApply (ErrorArrow ex a) where app = ErrorArrow (arr (\(ErrorArrow f, x) -> (f, x)) >>> app) -- this instance has the right type, but it doesn't satisfy right -- tightening, or sliding of non-strict functions. instance (ArrowChoice a, ArrowLoop a) => ArrowLoop (ErrorArrow ex a) where loop (ErrorArrow f) = ErrorArrow (loop (f >>> arr dist)) where dist x = (fstRight x, snd $ fromRight x) fstRight (Left x) = Left x fstRight (Right (x,_)) = Right x fromRight (Left _) = error "fromRight" fromRight (Right y) = y -- Other instances instance ArrowChoice a => Functor (ErrorArrow ex a b) where fmap f g = g >>> arr f instance ArrowChoice a => Applicative (ErrorArrow ex a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance (Monoid ex, ArrowChoice a) => Alternative (ErrorArrow ex a b) where empty = zeroArrow f <|> g = f <+> g instance (Monoid ex, ArrowChoice a) => Monoid (ErrorArrow ex a b c) where mempty = zeroArrow mappend f g = f <+> g -- fresh instances instance ArrowChoice a => ArrowError ex (ErrorArrow ex a) where raise = ErrorArrow (arr Left) handle (ErrorArrow f) (ErrorArrow h) = ErrorArrow (arr id &&& f >>> arr strength >>> h ||| arr Right) where strength (x, Left y) = Left (x, y) strength (_, Right z) = Right z tryInUnless (ErrorArrow f) (ErrorArrow s) (ErrorArrow h) = ErrorArrow (arr id &&& f >>> arr distr >>> h ||| s) where distr (b, Left ex) = Left (b, ex) distr (b, Right c) = Right (b, c) instance ArrowChoice a => ArrowAddError ex (ErrorArrow ex a) a where liftError = lift elimError = runError instance (Monoid ex, ArrowChoice a) => ArrowZero (ErrorArrow ex a) where zeroArrow = ErrorArrow (arr (const (Left mempty))) instance (Monoid ex, ArrowChoice a) => ArrowPlus (ErrorArrow ex a) where f <+> g = handle f $ handle (arr fst >>> g) $ ErrorArrow (arr (\((_,ex1), ex2) -> Left (ex1 `mappend` ex2))) -- liftings of other arrow classes -- specializations of general promotions instance (ArrowReader r a, ArrowChoice a) => ArrowReader r (ErrorArrow ex a) where readState = lift readState newReader (ErrorArrow f) = ErrorArrow (newReader f) instance (ArrowState s a, ArrowChoice a) => ArrowState s (ErrorArrow ex a) where fetch = lift fetch store = lift store instance (ArrowWriter w a, ArrowChoice a) => ArrowWriter w (ErrorArrow ex a) where write = lift write newWriter (ErrorArrow f) = ErrorArrow (newWriter f >>> arr rstrength) -- promotions instance (ArrowAddReader r a a', ArrowChoice a, ArrowChoice a') => ArrowAddReader r (ErrorArrow ex a) (ErrorArrow ex a') where liftReader (ErrorArrow f) = ErrorArrow (liftReader f) elimReader (ErrorArrow f) = ErrorArrow (elimReader f) instance (ArrowAddState s a a', ArrowChoice a, ArrowChoice a') => ArrowAddState s (ErrorArrow ex a) (ErrorArrow ex a') where liftState (ErrorArrow f) = ErrorArrow (liftState f) elimState (ErrorArrow f) = ErrorArrow (elimState f >>> arr rstrength) instance (ArrowAddWriter w a a', ArrowChoice a, ArrowChoice a') => ArrowAddWriter w (ErrorArrow ex a) (ErrorArrow ex a') where liftWriter (ErrorArrow f) = ErrorArrow (liftWriter f) elimWriter (ErrorArrow f) = ErrorArrow (elimWriter f >>> arr rstrength) arrows-0.4.4.1/Control/Arrow/Transformer/Stream.hs0000644000000000000000000001212012023105557020160 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.Stream -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Arrow transformer lifting an arrow to streams. module Control.Arrow.Transformer.Stream( StreamArrow(StreamArrow), runStream, StreamMap, StreamMapST, runStreamST, ArrowAddStream(..), ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative import Control.Arrow import Control.Category import Control.Monad.ST import Data.Monoid import Data.Stream (Stream(..)) import qualified Data.Stream as Stream import Prelude hiding (id,(.)) -- | Arrows between streams. -- -- /Note/: 'lift' is only a functor if '***' in the underlying arrow is. newtype StreamArrow a b c = StreamArrow (a (Stream b) (Stream c)) instance Category a => Category (StreamArrow a) where id = StreamArrow id StreamArrow f . StreamArrow g = StreamArrow (f . g) instance Arrow a => Arrow (StreamArrow a) where arr f = StreamArrow (arr (fmap f)) first (StreamArrow f) = StreamArrow (arr Stream.unzip >>> first f >>> arr (uncurry Stream.zip)) genmap :: Arrow a => a b c -> a (Stream b) (Stream c) genmap f = arr (\xs -> (Stream.head xs, Stream.tail xs)) >>> f *** genmap f >>> arr (uncurry (Stream.Cons)) -- Caution: genmap is only a functor if *** for the base arrow is. -- (For Kleisli arrows, that would mean a commutative monad.) -- The same goes for the equivalent lift: it can be used to lift arrows, -- but won't preserve composition unless *** does. instance Arrow a => ArrowTransformer (StreamArrow) a where lift f = StreamArrow (genmap f) -- The following promotions follow directly from the arrow transformer. instance ArrowZero a => ArrowZero (StreamArrow a) where zeroArrow = lift zeroArrow instance ArrowState s a => ArrowState s (StreamArrow a) where fetch = lift fetch store = lift store instance ArrowWriter w a => ArrowWriter w (StreamArrow a) where write = lift write newWriter (StreamArrow f) = StreamArrow (newWriter f >>> arr strength) where strength :: Functor w' => (w' a',b) -> w' (a',b) strength (v, y) = fmap (\x -> (x, y)) v -- liftings of standard classes instance Arrow a => ArrowChoice (StreamArrow a) where left (StreamArrow f) = StreamArrow ((arr getLeft >>> f) &&& arr id >>> arr replace) where getLeft (Cons (Left x) xs) = Cons x (getLeft xs) getLeft (Cons (Right _) xs) = getLeft xs replace (~(Cons x xs), Cons (Left _) ys) = Cons (Left x) (replace (xs, ys)) replace (xs, Cons (Right y) ys) = Cons (Right y) (replace (xs, ys)) instance ArrowLoop a => ArrowLoop (StreamArrow a) where loop (StreamArrow f) = StreamArrow (loop (arr (uncurry Stream.zip) >>> f >>> arr Stream.unzip)) instance ArrowPlus a => ArrowPlus (StreamArrow a) where StreamArrow f <+> StreamArrow g = StreamArrow (f <+> g) -- I don't know of any other useful promotions. -- (elimWriter can be promoted, but doesn't seem useful.) -- Circuits instance ArrowLoop a => ArrowCircuit (StreamArrow a) where delay x = StreamArrow (arr (Cons x)) -- Other instances instance Arrow a => Functor (StreamArrow a b) where fmap f g = g >>> arr f instance Arrow a => Applicative (StreamArrow a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance ArrowPlus a => Alternative (StreamArrow a b) where empty = zeroArrow f <|> g = f <+> g instance ArrowPlus a => Monoid (StreamArrow a b c) where mempty = zeroArrow mappend f g = f <+> g -- | Run a stream processor on a stream of inputs, obtaining a stream -- of outputs. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > ys <- (|runStream (\x -> ...)|) xs -- -- Here @xs@ refers to the input stream and @x@ to individual -- elements of that stream. @ys@ is bound to the output stream. runStream :: ArrowLoop a => StreamArrow a (e,b) c -> a (e,Stream b) (Stream c) runStream (StreamArrow f) = arr (\(e, xs) -> fmap (\x -> (e, x)) xs) >>> f instance ArrowLoop a => ArrowAddStream (StreamArrow a) a where liftStream = lift elimStream = runStream -- | Mappings of streams type StreamMap = StreamArrow (->) -- | In-place state updates. -- -- /Note/: this is an arrow type, and 'lift' can be used to promote arrows -- from @'Kleisli' ('ST' s)@: the resulting arrow updates the state for -- each stream element in turn, and as long as the final state in not -- required all is well. However, 'lift' does not preserve composition, -- because this monad isn't commutative. In particular, a composition -- of 'lift's of state transformers will not work, as the second will -- require the final state of the first. type StreamMapST s = StreamArrow (Kleisli (ST s)) -- | Encapsulate a local state. runStreamST :: (forall s. StreamMapST s e c) -> StreamMap e c runStreamST cf = StreamArrow $ \ input -> runST (let StreamArrow (Kleisli f) = cf in f input) arrows-0.4.4.1/Control/Arrow/Transformer/Writer.hs0000644000000000000000000001216712023105557020214 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.Writer -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Arrow transformer that adds accumulation of output. module Control.Arrow.Transformer.Writer( WriterArrow(WriterArrow), runWriter, ArrowAddWriter(..), ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative import Control.Arrow import Control.Category import Data.Monoid import Prelude hiding (id,(.)) -- | An arrow type that augments an existing arrow with accumulating -- output. The 'ArrowWriter' class contains the relevant operations. newtype WriterArrow w a b c = WriterArrow (a b (c, w)) -- | Encapsulation of a writer computation, providing the accumulated output. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > (result, output) <- (|runWriter cmd|) runWriter :: (Arrow a, Monoid w) => WriterArrow w a e b -> a e (b,w) runWriter (WriterArrow f) = f rstrength :: ((a, w), b) -> ((a, b), w) rstrength ((a, w), b) = ((a, b), w) unit :: Monoid w => a -> (a, w) unit a = (a, mempty) join :: Monoid w => ((a, w), w) -> (a, w) join ((a, w2), w1) = (a, w1 `mappend` w2) -- arrow transformer instance (Arrow a, Monoid w) => ArrowTransformer (WriterArrow w) a where lift f = WriterArrow (f >>> arr unit) -- liftings of standard classes instance (Arrow a, Monoid w) => Category (WriterArrow w a) where id = WriterArrow (arr unit) WriterArrow f . WriterArrow g = WriterArrow (arr join . first f . g) instance (Arrow a, Monoid w) => Arrow (WriterArrow w a) where arr f = WriterArrow (arr (unit . f)) first (WriterArrow f) = WriterArrow (first f >>> arr rstrength) instance (ArrowChoice a, Monoid w) => ArrowChoice (WriterArrow w a) where left (WriterArrow f) = WriterArrow (left f >>> arr lift_monoid) where lift_monoid (Left (x, w)) = (Left x, w) lift_monoid (Right y) = unit (Right y) instance (ArrowApply a, Monoid w) => ArrowApply (WriterArrow w a) where app = WriterArrow (arr (\(WriterArrow f, x) -> (f, x)) >>> app) instance (ArrowZero a, Monoid w) => ArrowZero (WriterArrow w a) where zeroArrow = WriterArrow zeroArrow instance (ArrowPlus a, Monoid w) => ArrowPlus (WriterArrow w a) where WriterArrow f <+> WriterArrow g = WriterArrow (f <+> g) instance (ArrowLoop a, Monoid w) => ArrowLoop (WriterArrow w a) where loop (WriterArrow f) = WriterArrow (loop (f >>> arr swapenv)) where swapenv ~(~(x, y), w) = ((x, w), y) -- Other instances instance (Arrow a, Monoid w) => Functor (WriterArrow w a b) where fmap f g = g >>> arr f instance (Arrow a, Monoid w) => Applicative (WriterArrow w a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance (ArrowPlus a, Monoid w) => Alternative (WriterArrow w a b) where empty = zeroArrow f <|> g = f <+> g instance (ArrowPlus a, Monoid w) => Monoid (WriterArrow w a b c) where mempty = zeroArrow mappend f g = f <+> g -- new instances instance (Arrow a, Monoid w) => ArrowWriter w (WriterArrow w a) where write = WriterArrow (arr (\x -> ((), x))) newWriter (WriterArrow f) = WriterArrow (f >>> arr (\(x, w) -> ((x, w), w))) instance (Arrow a, Monoid w) => ArrowAddWriter w (WriterArrow w a) a where liftWriter = lift elimWriter = runWriter -- liftings of other classes instance (ArrowCircuit a, Monoid w) => ArrowCircuit (WriterArrow w a) where delay x = lift (delay x) instance (ArrowError ex a, Monoid w) => ArrowError ex (WriterArrow w a) where raise = lift raise handle (WriterArrow f) (WriterArrow h) = WriterArrow (handle f h) tryInUnless (WriterArrow f) (WriterArrow s) (WriterArrow h) = WriterArrow (tryInUnless f s' h) where s' = arr lstrength >>> first s >>> arr join lstrength (x, (y, w)) = ((x, y), w) newError (WriterArrow f) = WriterArrow (newError f >>> arr h) where h (Left ex) = unit (Left ex) h (Right (c, w)) = (Right c, w) instance (ArrowReader r a, Monoid w) => ArrowReader r (WriterArrow w a) where readState = lift readState newReader (WriterArrow f) = WriterArrow (newReader f) instance (ArrowState s a, Monoid w) => ArrowState s (WriterArrow w a) where fetch = lift fetch store = lift store -- promotions of encapsulation operators instance (ArrowAddError ex a a', Monoid w) => ArrowAddError ex (WriterArrow w a) (WriterArrow w a') where liftError (WriterArrow f) = WriterArrow (liftError f) elimError (WriterArrow f) (WriterArrow h) = WriterArrow (elimError f h) instance (ArrowAddReader r a a', Monoid w) => ArrowAddReader r (WriterArrow w a) (WriterArrow w a') where liftReader (WriterArrow f) = WriterArrow (liftReader f) elimReader (WriterArrow f) = WriterArrow (elimReader f) instance (ArrowAddState s a a', Monoid w) => ArrowAddState s (WriterArrow w a) (WriterArrow w a') where liftState (WriterArrow f) = WriterArrow (liftState f) elimState (WriterArrow f) = WriterArrow (elimState f >>> arr rstrength) arrows-0.4.4.1/Control/Arrow/Transformer/Static.hs0000644000000000000000000001266412023105557020171 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.Static -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Arrow transformer adding static information. module Control.Arrow.Transformer.Static( StaticArrow(StaticArrow), StaticMonadArrow, StaticArrowArrow, wrap, unwrap, wrapA, unwrapA, wrapM, unwrapM, ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative import Control.Arrow import Control.Category import Control.Monad import Data.Monoid import Prelude hiding (id,(.)) -- | An arrow type that augments the underlying arrow with static information. newtype StaticArrow f a b c = StaticArrow (f (a b c)) instance (Arrow a, Applicative f) => ArrowTransformer (StaticArrow f) a where lift f = StaticArrow (pure f) instance (Category a, Applicative f) => Category (StaticArrow f a) where id = StaticArrow (pure id) StaticArrow f . StaticArrow g = StaticArrow ((.) <$> f <*> g) instance (Arrow a, Applicative f) => Arrow (StaticArrow f a) where arr f = StaticArrow (pure (arr f)) first (StaticArrow f) = StaticArrow (first <$> f) -- The following promotions follow directly from the arrow transformer. instance (ArrowZero a, Applicative f) => ArrowZero (StaticArrow f a) where zeroArrow = lift zeroArrow instance (ArrowCircuit a, Applicative f) => ArrowCircuit (StaticArrow f a) where delay x = lift (delay x) instance (ArrowError ex a, Applicative f) => ArrowError ex (StaticArrow f a) where raise = lift raise handle (StaticArrow f) (StaticArrow h) = StaticArrow (handle <$> f <*> h) tryInUnless (StaticArrow f) (StaticArrow s) (StaticArrow h) = StaticArrow (tryInUnless <$> f <*> s <*> h) instance (ArrowReader r a, Applicative f) => ArrowReader r (StaticArrow f a) where readState = lift readState newReader (StaticArrow f) = StaticArrow (newReader <$> f) instance (ArrowState s a, Applicative f) => ArrowState s (StaticArrow f a) where fetch = lift fetch store = lift store instance (ArrowWriter w a, Applicative f) => ArrowWriter w (StaticArrow f a) where write = lift write newWriter (StaticArrow f) = StaticArrow (newWriter <$> f) -- Classes that are preserved. instance (ArrowChoice a, Applicative f) => ArrowChoice (StaticArrow f a) where left (StaticArrow f) = StaticArrow (left <$> f) -- ArrowApply is generally not preserved. instance (ArrowLoop a, Applicative f) => ArrowLoop (StaticArrow f a) where loop (StaticArrow f) = StaticArrow (loop <$> f) instance (ArrowPlus a, Applicative f) => ArrowPlus (StaticArrow f a) where StaticArrow f <+> StaticArrow g = StaticArrow ((<+>) <$> f <*> g) -- Other instances instance (Arrow a, Applicative f) => Functor (StaticArrow f a b) where fmap f g = g >>> arr f instance (Arrow a, Applicative f) => Applicative (StaticArrow f a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance (ArrowPlus a, Applicative f) => Alternative (StaticArrow f a b) where empty = zeroArrow f <|> g = f <+> g instance (ArrowPlus a, Applicative f) => Monoid (StaticArrow f a b c) where mempty = zeroArrow mappend f g = f <+> g -- promotions instance (ArrowAddStream a a', Applicative f) => ArrowAddStream (StaticArrow f a) (StaticArrow f a') where liftStream (StaticArrow f) = StaticArrow (liftStream <$> f) elimStream (StaticArrow f) = StaticArrow (elimStream <$> f) instance (ArrowAddState s a a', Applicative f) => ArrowAddState s (StaticArrow f a) (StaticArrow f a') where liftState (StaticArrow f) = StaticArrow (liftState <$> f) elimState (StaticArrow f) = StaticArrow (elimState <$> f) instance (ArrowAddReader r a a', Applicative f) => ArrowAddReader r (StaticArrow f a) (StaticArrow f a') where liftReader (StaticArrow f) = StaticArrow (liftReader <$> f) elimReader (StaticArrow f) = StaticArrow (elimReader <$> f) instance (ArrowAddWriter w a a', Applicative f) => ArrowAddWriter w (StaticArrow f a) (StaticArrow f a') where liftWriter (StaticArrow f) = StaticArrow (liftWriter <$> f) elimWriter (StaticArrow f) = StaticArrow (elimWriter <$> f) instance (ArrowAddError ex a a', Applicative f) => ArrowAddError ex (StaticArrow f a) (StaticArrow f a') where liftError (StaticArrow f) = StaticArrow (liftError <$> f) elimError (StaticArrow f) (StaticArrow h) = StaticArrow (elimError <$> f <*> h) wrap :: (Applicative f, Arrow a) => f (a b c) -> StaticArrow f a b c wrap = StaticArrow unwrap :: (Applicative f, Arrow a) => StaticArrow f a b c -> f (a b c) unwrap (StaticArrow f) = f -- | A special case. type StaticArrowArrow a s = StaticArrow (WrappedArrow a s) wrapA :: (Arrow a, Arrow a') => a s (a' b c) -> StaticArrowArrow a s a' b c wrapA x = StaticArrow (WrapArrow x) unwrapA :: (Arrow a, Arrow a') => StaticArrowArrow a s a' b c -> a s (a' b c) unwrapA (StaticArrow (WrapArrow x)) = x -- | A special case is monads applied to the whole arrow, in contrast to -- 'Kleisli' arrows, in which the monad is applied to the output. type StaticMonadArrow m = StaticArrow (WrappedMonad m) wrapM :: (Monad m, Arrow a) => m (a b c) -> StaticMonadArrow m a b c wrapM x = StaticArrow (WrapMonad x) unwrapM :: (Monad m, Arrow a) => StaticMonadArrow m a b c -> m (a b c) unwrapM (StaticArrow (WrapMonad x)) = x arrows-0.4.4.1/Control/Arrow/Transformer/Automaton.hs0000644000000000000000000001406012023105557020701 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer.Automaton -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Simple Mealy-style automata. module Control.Arrow.Transformer.Automaton( Automaton(Automaton), runAutomaton, ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative import Control.Arrow import Control.Category import Data.Monoid import Data.Stream import Prelude hiding (id,(.)) -- | An arrow type comprising Mealy-style automata, each step of which is -- is a computation in the original arrow type. newtype Automaton a b c = Automaton (a b (c, Automaton a b c)) instance Arrow a => ArrowTransformer Automaton a where lift f = c where c = Automaton (f &&& arr (const c)) instance Arrow a => Category (Automaton a) where id = lift id Automaton f . Automaton g = Automaton (arr (\((z, cf), cg) -> (z, cf . cg)) . first f . g) instance Arrow a => Arrow (Automaton a) where arr f = lift (arr f) first (Automaton f) = Automaton (first f >>> arr (\((x', c), y) -> ((x', y), first c))) second (Automaton f) = Automaton (second f >>> arr (\(x, (y', c)) -> ((x, y'), second c))) Automaton f1 *** Automaton f2 = Automaton ((f1 *** f2) >>> arr (\((x', c1), (y', c2)) -> ((x', y'), c1 *** c2))) Automaton f1 &&& Automaton f2 = Automaton ((f1 &&& f2) >>> arr (\((x1, c1), (x2, c2)) -> ((x1, x2), c1 &&& c2))) instance ArrowChoice a => ArrowChoice (Automaton a) where left (Automaton f) = left_f where left_f = Automaton (left f >>> arr combine) combine (Left (y, cf)) = (Left y, left cf) combine (Right z) = (Right z, left_f) right (Automaton f) = right_f where right_f = Automaton (right f >>> arr combine) combine (Left z) = (Left z, right_f) combine (Right (y, cf)) = (Right y, right cf) Automaton f1 +++ Automaton f2 = Automaton ((f1 +++ f2) >>> arr combine) where combine (Left (x, c)) = (Left x, c +++ Automaton f2) combine (Right (x, c)) = (Right x, Automaton f1 +++ c) Automaton f1 ||| Automaton f2 = Automaton ((f1 +++ f2) >>> arr combine) where combine (Left (x, c)) = (x, c ||| Automaton f2) combine (Right (x, c)) = (x, Automaton f1 ||| c) instance ArrowZero a => ArrowZero (Automaton a) where zeroArrow = Automaton zeroArrow instance ArrowPlus a => ArrowPlus (Automaton a) where Automaton f <+> Automaton g = Automaton (f <+> g) -- Circuit combinators instance ArrowLoop a => ArrowLoop (Automaton a) where loop (Automaton f) = Automaton (loop (f >>> arr (\((x, y), cf) -> ((x, loop cf), y)))) instance ArrowLoop a => ArrowCircuit (Automaton a) where delay x = Automaton (arr (\x' -> (x, delay x'))) -- Other instances instance Arrow a => Functor (Automaton a b) where fmap f g = g >>> arr f instance Arrow a => Applicative (Automaton a b) where pure x = arr (const x) f <*> g = f &&& g >>> arr (uncurry id) instance ArrowPlus a => Alternative (Automaton a b) where empty = zeroArrow f <|> g = f <+> g instance ArrowPlus a => Monoid (Automaton a b c) where mempty = zeroArrow mappend f g = f <+> g -- runAutomaton (Automaton f) = proc (e, Cons x xs) -> do -- (y, c) <- f <- (e, x) -- ys <- runAutomaton c -<< (e, xs) -- returnA -< Cons y ys -- | Encapsulating an automaton by running it on a stream of inputs, -- obtaining a stream of outputs. -- -- Typical usage in arrow notation: -- -- > proc p -> do -- > ... -- > ys <- (|runAutomaton (\x -> ...)|) xs -- -- Here @xs@ refers to the input stream and @x@ to individual -- elements of that stream. @ys@ is bound to the output stream. runAutomaton :: (ArrowLoop a, ArrowApply a) => Automaton a (e,b) c -> a (e,Stream b) (Stream c) runAutomaton (Automaton f) = arr (\(e, Cons x xs) -> ((e, x), (e, xs))) >>> first f >>> arr (\((y, c), (e, xs)) -> (y, (runAutomaton c, (e, xs)))) >>> second app >>> arr (uncurry Cons) instance (ArrowLoop a, ArrowApply a) => ArrowAddStream (Automaton a) a where liftStream = lift elimStream = runAutomaton -- other promotions instance ArrowWriter w a => ArrowWriter w (Automaton a) where write = lift write newWriter (Automaton f) = Automaton (newWriter f >>> arr (\((c, f'), w) -> ((c, w), newWriter f'))) instance ArrowError r a => ArrowError r (Automaton a) where raise = lift raise tryInUnless f0@(Automaton f) s0@(Automaton s) h0@(Automaton h) = Automaton (tryInUnless f sA hA) where sA = arr (\(b,(c,f')) -> ((b,c),f')) >>> first s >>> arr (\((d,s'),f') -> (d, tryInUnless f' s' h0)) hA = h >>> arr (\(d,h') -> (d, tryInUnless f0 s0 h')) newError (Automaton f) = Automaton (newError f >>> arr h) where h (Left ex) = (Left ex, newError (Automaton f)) h (Right (c, f')) = (Right c, newError f') instance ArrowReader r a => ArrowReader r (Automaton a) where readState = lift readState newReader (Automaton f) = Automaton (newReader f >>> second (arr newReader)) instance ArrowState s a => ArrowState s (Automaton a) where fetch = lift fetch store = lift store -- encapsulations instance ArrowAddWriter w a a' => ArrowAddWriter w (Automaton a) (Automaton a') where liftWriter (Automaton f) = Automaton (liftWriter f >>> arr (\(c, f') -> (c, liftWriter f'))) elimWriter (Automaton f) = Automaton (elimWriter f >>> arr (\((c, f'), w) -> ((c, w), elimWriter f'))) instance ArrowAddReader r a a' => ArrowAddReader r (Automaton a) (Automaton a') where liftReader (Automaton f) = Automaton (liftReader f >>> arr (\(c, f') -> (c, liftReader f'))) elimReader (Automaton f) = Automaton (elimReader f >>> second (arr elimReader)) instance ArrowAddState r a a' => ArrowAddState r (Automaton a) (Automaton a') where liftState (Automaton f) = Automaton (liftState f >>> arr (\(c, f') -> (c, liftState f'))) elimState (Automaton f) = Automaton (elimState f >>> arr (\((c, f'), s) -> ((c, s), elimState f')))