arrows 0.4 → 0.4.4.2
raw patch · 13 files changed
Files
- Control/Arrow/Internals.hs +102/−104
- Control/Arrow/Operations.hs +83/−82
- Control/Arrow/Transformer.hs +10/−12
- Control/Arrow/Transformer/All.hs +9/−9
- Control/Arrow/Transformer/Automaton.hs +128/−85
- Control/Arrow/Transformer/CoState.hs +37/−22
- Control/Arrow/Transformer/Error.hs +89/−69
- Control/Arrow/Transformer/Reader.hs +77/−58
- Control/Arrow/Transformer/State.hs +83/−58
- Control/Arrow/Transformer/Static.hs +77/−51
- Control/Arrow/Transformer/Stream.hs +74/−52
- Control/Arrow/Transformer/Writer.hs +79/−58
- arrows.cabal +28/−19
Control/Arrow/Internals.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -fglasgow-exts #-}- ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Internals@@ -18,12 +16,12 @@ -- #hide module Control.Arrow.Internals (- ArrowAddState(..),- ArrowAddReader(..),- ArrowAddWriter(..),- ArrowAddError(..),- ArrowAddStream(..),- ) where+ ArrowAddState(..),+ ArrowAddReader(..),+ ArrowAddWriter(..),+ ArrowAddError(..),+ ArrowAddStream(..),+ ) where import Control.Arrow import Control.Arrow.Operations@@ -42,36 +40,36 @@ -- 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+-- > 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')+-- > 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|)+ -- | 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+ 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+ -- | 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)+ 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.@@ -86,35 +84,35 @@ -- 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+-- > 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')+-- > 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|)+ -- | 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+ 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+ -- | 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+ 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.@@ -129,36 +127,36 @@ -- 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+-- > 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')+-- > 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|)+ -- | 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+ 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|)+ -- | 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)+ 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.@@ -173,14 +171,14 @@ -- 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+-- > 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')+-- > 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.@@ -189,24 +187,24 @@ 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|)+ -- | 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+ 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+ -- | 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+ 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.@@ -221,36 +219,36 @@ -- The methods of this class add and remove state transformers anywhere -- in the stack. In the instance ----- > instance Arrow a => ArrowAddStream (ArrowStream a) a+-- > 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')+-- > 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|)+ -- | 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+ 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.+ -- | 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)+ elimStream :: a (e,b) c -> a' (e,Stream b) (Stream c)
Control/Arrow/Operations.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -fglasgow-exts #-}- ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Operations@@ -16,21 +14,21 @@ -- notation for arrows, cf. <http://www.haskell.org/arrows/>. module Control.Arrow.Operations (- -- * Conventions- -- $conventions+ -- * Conventions+ -- $conventions - -- * State transformers- ArrowState(..),- -- * State readers- ArrowReader(..),- -- * Monoid writers- ArrowWriter(..),- -- * Errors- ArrowError(..),- tryInUnlessDefault,- -- * Synchronous circuits- ArrowCircuit(..),- ) where+ -- * State transformers+ ArrowState(..),+ -- * State readers+ ArrowReader(..),+ -- * Monoid writers+ ArrowWriter(..),+ -- * Errors+ ArrowError(..),+ tryInUnlessDefault,+ -- * Synchronous circuits+ ArrowCircuit(..),+ ) where import Control.Arrow import Data.Monoid@@ -62,46 +60,46 @@ -- 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+ -- | 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+ -- | 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+ 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 ()+ -- | 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 ()+ -- | 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|)+ -- | 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)+ newWriter :: a e b -> a e (b,w) -- | An arrow type that includes errors (or exceptions). --@@ -110,52 +108,55 @@ -- /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+ -- | Raise an error.+ raise :: a ex b - -- | Traditional exception construct.- --- -- Typical usage in arrow notation:- --- -- > proc p -> ...- -- > body `handle` \ex -> handler+ -- | 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+ 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+ -- | 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))+ -- | 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+ 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)+ 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.@@ -165,7 +166,7 @@ -- | 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.+ -- | A delay component.+ delay ::+ b -- ^ the value to return initially.+ -> a b b -- ^ an arrow that propagates its input with a one-tick delay.
Control/Arrow/Transformer.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -fglasgow-exts #-}- ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Transformer@@ -8,24 +6,24 @@ -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental--- Portability : non-portable (multi-parameter type classes)+-- Portability : portable -- -- Arrow transformers, for making new arrow types out of old ones. module Control.Arrow.Transformer (- ArrowTransformer(..)- ) where+ 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|)+ -- | 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+ lift :: a b c -> f a b c
Control/Arrow/Transformer/All.hs view
@@ -1,14 +1,14 @@ -- #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+ 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
Control/Arrow/Transformer/Automaton.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -6,166 +7,208 @@ -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ross@soi.city.ac.uk+-- Maintainer : R.Paterson@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+ Automaton(Automaton), runAutomaton,+ ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative-import Control.Arrow hiding (pure)+import Control.Arrow+import Control.Category import Data.Monoid+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif 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))+ 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)- Automaton f >>> Automaton g =- Automaton (f >>>- first g >>>- arr (\((z, cg), cf) -> (z, cf >>> cg)))- first (Automaton f) =- Automaton (first f >>>- arr (\((x', c), y) -> ((x', y), first c)))+ 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)+ 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+ zeroArrow = Automaton zeroArrow instance ArrowPlus a => ArrowPlus (Automaton a) where- Automaton f <+> Automaton g = Automaton (f <+> g)+ 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))))+ 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')))+ delay x = Automaton (arr (\x' -> (x, delay x'))) -- Other instances instance Arrow a => Functor (Automaton a b) where- fmap f g = g >>> arr f+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance ArrowPlus a => Semigroup (Automaton a b c) where+ (<>) = (<+>)+#endif+ instance ArrowPlus a => Monoid (Automaton a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif --- runAutomaton (Automaton f) = proc (e, Cons x xs) -> do--- (y, c) <- f <- (e, x)--- ys <- runAutomaton c -<< (e, xs)--- returnA -< Cons y ys+-- 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+-- > 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)+ 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)+ 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+ 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')))+ 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')+ 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))+ 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+ 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')))+ 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))+ 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')))+ 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')))
Control/Arrow/Transformer/CoState.hs view
@@ -1,12 +1,11 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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+-- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) --@@ -15,21 +14,29 @@ -- /TODO:/ define operations for this arrow. module Control.Arrow.Transformer.CoState(- CoStateArrow,- ) where--import Control.Arrow.Operations+ CoStateArrow(CoStateArrow),+ ) where import Control.Applicative-import Control.Arrow hiding (pure)+import Control.Arrow+import Control.Category+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif import Data.Monoid -newtype CoStateArrow s a b c = CST (a (s -> b) (s -> c))+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 = CST (arr (f .))- CST f >>> CST g = CST (f >>> g)- first (CST f) = CST (arr unzipMap >>> first f >>> arr zipMap)+ 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)@@ -42,27 +49,35 @@ -- promotions of standard classes instance ArrowLoop a => ArrowLoop (CoStateArrow s a) where- loop (CST f) = CST (loop (arr zipMap >>> f >>> arr unzipMap))+ loop (CoStateArrow f) =+ CoStateArrow (loop (arr zipMap >>> f >>> arr unzipMap)) instance ArrowZero a => ArrowZero (CoStateArrow s a) where- zeroArrow = CST zeroArrow+ zeroArrow = CoStateArrow zeroArrow instance ArrowPlus a => ArrowPlus (CoStateArrow s a) where- CST f <+> CST g = CST (f <+> g)+ CoStateArrow f <+> CoStateArrow g = CoStateArrow (f <+> g) -- Other instances instance Arrow a => Functor (CoStateArrow s a b) where- fmap f g = g >>> arr f+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance ArrowPlus a => Semigroup (CoStateArrow s a b c) where+ (<>) = (<+>)+#endif+ instance ArrowPlus a => Monoid (CoStateArrow s a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif
Control/Arrow/Transformer/Error.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -6,7 +7,7 @@ -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ross@soi.city.ac.uk+-- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) --@@ -15,19 +16,25 @@ -- /TODO:/ the operations here are inconsistent with other arrow transformers. module Control.Arrow.Transformer.Error(- ErrorArrow,- runError,- ArrowAddError(..),- ) where+ ErrorArrow(ErrorArrow),+ runError,+ ArrowAddError(..),+ ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative-import Control.Arrow hiding (pure)+import Control.Arrow+import Control.Category import Data.Monoid+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif +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.@@ -43,33 +50,37 @@ -- -- Typical usage in arrow notation: ----- > proc p -> ...--- > body `runError` \ex -> handler+-- > 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+ 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+ 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)+ 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))- ErrorArrow f >>> ErrorArrow g =- ErrorArrow (f >>> right g >>> arr (either Left id))- first (ErrorArrow f) = ErrorArrow (first f >>> arr rstrength)+ 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)+ 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@@ -77,93 +88,102 @@ 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)+ 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+ 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+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance (Monoid ex, ArrowChoice a) => Semigroup (ErrorArrow ex a b c) where+ (<>) = (<+>)+#endif+ instance (Monoid ex, ArrowChoice a) => Monoid (ErrorArrow ex a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif -- 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)+ 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+ liftError = lift+ elimError = runError instance (Monoid ex, ArrowChoice a) => ArrowZero (ErrorArrow ex a) where- zeroArrow = ErrorArrow (arr (const (Left mempty)))+ 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)))+ 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 (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+ 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)+ 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)+ 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)+ 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)+ ArrowAddWriter w (ErrorArrow ex a) (ErrorArrow ex a') where+ liftWriter (ErrorArrow f) = ErrorArrow (liftWriter f)+ elimWriter (ErrorArrow f) = ErrorArrow (elimWriter f >>> arr rstrength)
Control/Arrow/Transformer/Reader.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -6,29 +7,36 @@ -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ross@soi.city.ac.uk+-- Maintainer : R.Paterson@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,- runReader,- ArrowAddReader(..),- ) where+ ReaderArrow(ReaderArrow),+ runReader,+ ArrowAddReader(..),+ ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative-import Control.Arrow hiding (pure)+import Control.Arrow+import Control.Category import Data.Monoid+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif +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@@ -36,8 +44,8 @@ -- -- Typical usage in arrow notation: ----- > proc p -> ...--- > (|runReader cmd|) env+-- > proc p -> ...+-- > (|runReader cmd|) env runReader :: Arrow a => ReaderArrow r a e b -> a (e,r) b runReader (ReaderArrow f) = f@@ -45,105 +53,116 @@ -- arrow transformer instance Arrow a => ArrowTransformer (ReaderArrow r) a where- lift f = ReaderArrow (arr fst >>> f)+ 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))- ReaderArrow f >>> ReaderArrow g =- ReaderArrow (arr dupenv >>> first f >>> g)- where dupenv (a, r) = ((a, r), r)- first (ReaderArrow f) = ReaderArrow (arr swapsnd >>> first f)+ 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+ 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)+ app = ReaderArrow+ (arr (\((ReaderArrow f, a), r) -> (f, (a, r))) >>> app) instance ArrowZero a => ArrowZero (ReaderArrow r a) where- zeroArrow = lift zeroArrow+ zeroArrow = lift zeroArrow instance ArrowPlus a => ArrowPlus (ReaderArrow r a) where- ReaderArrow f <+> ReaderArrow g = ReaderArrow (f <+> g)+ ReaderArrow f <+> ReaderArrow g = ReaderArrow (f <+> g) instance ArrowLoop a => ArrowLoop (ReaderArrow r a) where- loop (ReaderArrow f) = ReaderArrow (loop (arr swapsnd >>> f))+ 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 (\((x, _), r) -> (x, r)) >>> f)+ 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+ liftReader = lift+ elimReader = runReader -- liftings of other classes instance ArrowCircuit a => ArrowCircuit (ReaderArrow r a) where- delay x = lift (delay x)+ 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)+ 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+ 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)+ 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))+ 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)+ 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)+-- 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)+ 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+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance ArrowPlus a => Semigroup (ReaderArrow r a b c) where+ (<>) = (<+>)+#endif+ instance ArrowPlus a => Monoid (ReaderArrow r a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif
Control/Arrow/Transformer/State.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -6,7 +7,7 @@ -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ross@soi.city.ac.uk+-- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) --@@ -15,132 +16,156 @@ -- /Science of Computer Programming/ 37:67-111, May 2000. module Control.Arrow.Transformer.State(- StateArrow,- runState,- ArrowAddState(..),- ) where+ StateArrow(StateArrow),+ runState,+ ArrowAddState(..),+ ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative-import Control.Arrow hiding (pure)+import Control.Arrow+import Control.Category import Data.Monoid+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif +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 = ST (a (b, s) (c, s)) +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 = ST (arr (\(x, s) -> (f x, s)))- ST f >>> ST g = ST (f >>> g)- first (ST f) = ST (arr swapsnd >>> first f >>> arr swapsnd)+ 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 = ST (first f)+ 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+-- > proc p -> do+-- > ...+-- > (result, final_state) <- (|runState cmd|) init_state runState :: Arrow a => StateArrow s a e b -> a (e,s) (b,s)-runState (ST f) = f+runState (StateArrow f) = f -- operations instance Arrow a => ArrowState s (StateArrow s a) where- fetch = ST (arr (\(_, s) -> (s, s)))- store = ST (arr (\(s, _) -> ((), s)))+ 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+ liftState = lift+ elimState = runState -- The following promotions follow directly from the arrow transformer. instance ArrowZero a => ArrowZero (StateArrow s a) where- zeroArrow = ST zeroArrow+ zeroArrow = StateArrow zeroArrow instance ArrowCircuit a => ArrowCircuit (StateArrow s a) where- delay x = lift (delay x)+ delay x = lift (delay x) instance ArrowError ex a => ArrowError ex (StateArrow s a) where- raise = lift raise- handle (ST f) (ST h) = ST (handle f (arr swapsnd >>> h))- tryInUnless (ST f) (ST s) (ST h) =- ST (tryInUnless f (arr new_state >>> s) (arr swapsnd >>> h))- where new_state ((b,_),(c,s')) = ((b,c),s')- newError (ST f) = ST (newError f &&& arr snd >>> arr h)- where h (Left ex, s) = (Left ex, s)- h (Right (c, s'), _) = (Right c, s')+ 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 (ST f) = ST (arr swapsnd >>> newReader f)+ 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 (ST f) = ST (newWriter f >>> arr swapsnd)+ write = lift write+ newWriter (StateArrow f) = StateArrow (newWriter f >>> arr swapsnd) -- liftings of standard classes instance ArrowChoice a => ArrowChoice (StateArrow s a) where- left (ST f) = ST (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)+ 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 = ST (arr (\((ST f, x), s) -> (f, (x, s))) >>> app)+ app = StateArrow (arr (\((StateArrow f, x), s) -> (f, (x, s))) >>> app) instance ArrowLoop a => ArrowLoop (StateArrow s a) where- loop (ST f) = ST (loop (arr swapsnd >>> f >>> arr swapsnd))+ loop (StateArrow f) =+ StateArrow (loop (arr swapsnd >>> f >>> arr swapsnd)) instance ArrowPlus a => ArrowPlus (StateArrow s a) where- ST f <+> ST g = ST (f <+> g)+ StateArrow f <+> StateArrow g = StateArrow (f <+> g) -- Other instances instance Arrow a => Functor (StateArrow s a b) where- fmap f g = g >>> arr f+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance ArrowPlus a => Semigroup (StateArrow s a b c) where+ (<>) = (<+>)+#endif+ instance ArrowPlus a => Monoid (StateArrow s a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif -- promotions instance ArrowAddReader r a a' =>- ArrowAddReader r (StateArrow s a) (StateArrow s a') where- liftReader (ST f) = ST (liftReader f)- elimReader (ST f) = ST (arr swapsnd >>> elimReader f)+ 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 (ST f) = ST (liftWriter f)- elimWriter (ST f) = ST (elimWriter f >>> arr swapsnd)+ 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 (ST f) = ST (liftError f)- elimError (ST f) (ST h) = ST (elimError f (arr swapsnd >>> h))+ 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))
Control/Arrow/Transformer/Static.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -6,129 +7,154 @@ -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ross@soi.city.ac.uk+-- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : non-portable (multi-parameter type classes) -- -- Arrow transformer adding static information. module Control.Arrow.Transformer.Static(- StaticArrow, StaticMonadArrow, StaticArrowArrow,- wrapA, unwrapA, wrapM, unwrapM,- ) where+ 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 hiding (pure)+import Control.Arrow+import Control.Category import Control.Monad import Data.Monoid+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif +import Prelude hiding (id,(.))+ -- | An arrow type that augments the underlying arrow with static information. -newtype StaticArrow f a b c = SA (f (a b c))+newtype StaticArrow f a b c = StaticArrow (f (a b c)) instance (Arrow a, Applicative f) => ArrowTransformer (StaticArrow f) a where- lift f = SA (pure f)+ 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 = SA (pure (arr f))- SA f >>> SA g = SA ((>>>) <$> f <*> g)- first (SA f) = SA (first <$> f)+ 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+ zeroArrow = lift zeroArrow instance (ArrowCircuit a, Applicative f) => ArrowCircuit (StaticArrow f a) where- delay x = lift (delay x)+ delay x = lift (delay x) instance (ArrowError ex a, Applicative f) => ArrowError ex (StaticArrow f a) where- raise = lift raise- handle (SA f) (SA h) = SA (handle <$> f <*> h)- tryInUnless (SA f) (SA s) (SA h) = SA (tryInUnless <$> f <*> s <*> h)+ 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 (SA f) = SA (newReader <$> f)+ 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+ fetch = lift fetch+ store = lift store instance (ArrowWriter w a, Applicative f) => ArrowWriter w (StaticArrow f a) where- write = lift write- newWriter (SA f) = SA (newWriter <$> f)+ write = lift write+ newWriter (StaticArrow f) = StaticArrow (newWriter <$> f) -- Classes that are preserved. instance (ArrowChoice a, Applicative f) => ArrowChoice (StaticArrow f a) where- left (SA f) = SA (left <$> f)+ left (StaticArrow f) = StaticArrow (left <$> f) -- ArrowApply is generally not preserved. instance (ArrowLoop a, Applicative f) => ArrowLoop (StaticArrow f a) where- loop (SA f) = SA (loop <$> f)+ loop (StaticArrow f) = StaticArrow (loop <$> f) instance (ArrowPlus a, Applicative f) => ArrowPlus (StaticArrow f a) where- SA f <+> SA g = SA ((<+>) <$> f <*> g)+ 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+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance (ArrowPlus a, Applicative f) => Semigroup (StaticArrow f a b c) where+ (<>) = (<+>)+#endif+ instance (ArrowPlus a, Applicative f) => Monoid (StaticArrow f a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif -- promotions instance (ArrowAddStream a a', Applicative f) =>- ArrowAddStream (StaticArrow f a) (StaticArrow f a') where- liftStream (SA f) = SA (liftStream <$> f)- elimStream (SA f) = SA (elimStream <$> 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 (SA f) = SA (liftState <$> f)- elimState (SA f) = SA (elimState <$> 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 (SA f) = SA (liftReader <$> f)- elimReader (SA f) = SA (elimReader <$> 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 (SA f) = SA (liftWriter <$> f)- elimWriter (SA f) = SA (elimWriter <$> 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 (SA f) = SA (liftError <$> f)- elimError (SA f) (SA h) = SA (elimError <$> f <*> h)+ 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 = SA (WrapArrow x)+wrapA x = StaticArrow (WrapArrow x) unwrapA :: (Arrow a, Arrow a') => StaticArrowArrow a s a' b c -> a s (a' b c)-unwrapA (SA (WrapArrow x)) = x+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.@@ -136,7 +162,7 @@ type StaticMonadArrow m = StaticArrow (WrappedMonad m) wrapM :: (Monad m, Arrow a) => m (a b c) -> StaticMonadArrow m a b c-wrapM x = SA (WrapMonad x)+wrapM x = StaticArrow (WrapMonad x) unwrapM :: (Monad m, Arrow a) => StaticMonadArrow m a b c -> m (a b c)-unwrapM (SA (WrapMonad x)) = x+unwrapM (StaticArrow (WrapMonad x)) = x
Control/Arrow/Transformer/Stream.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- |@@ -6,47 +8,56 @@ -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ross@soi.city.ac.uk+-- Maintainer : R.Paterson@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,- runStream,- StreamMap,- StreamMapST, runStreamST,- ArrowAddStream(..),- ) where+ StreamArrow(StreamArrow),+ runStream,+ StreamMap,+ StreamMapST, runStreamST,+ ArrowAddStream(..),+ ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer -import Data.Stream (Stream(..))-import qualified Data.Stream as Stream- import Control.Applicative-import Control.Arrow hiding (pure)+import Control.Arrow+import Control.Category import Control.Monad.ST import Data.Monoid+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+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 = Str (a (Stream b) (Stream c))+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 = Str (arr (fmap f))- Str f >>> Str g = Str (f >>> g)- first (Str f) =- Str (arr Stream.unzip >>> first f >>> arr (uncurry Stream.zip))+ 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))+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.)@@ -54,40 +65,43 @@ -- but won't preserve composition unless *** does. instance Arrow a => ArrowTransformer (StreamArrow) a where- lift f = Str (genmap f)+ lift f = StreamArrow (genmap f) -- The following promotions follow directly from the arrow transformer. instance ArrowZero a => ArrowZero (StreamArrow a) where- zeroArrow = lift zeroArrow+ zeroArrow = lift zeroArrow instance ArrowState s a => ArrowState s (StreamArrow a) where- fetch = lift fetch- store = lift store+ fetch = lift fetch+ store = lift store instance ArrowWriter w a => ArrowWriter w (StreamArrow a) where- write = lift write- newWriter (Str f) = Str (newWriter f >>> arr strength)- where strength :: Functor w' => (w' a',b) -> w' (a',b)- strength (v, y) = fmap (\x -> (x, y)) v+ 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 (Str f) = Str ((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))+ 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 (Str f) =- Str (loop (arr (uncurry Stream.zip) >>> f >>> arr Stream.unzip))+ loop (StreamArrow f) =+ StreamArrow (loop (arr (uncurry Stream.zip) >>> f >>> arr Stream.unzip)) instance ArrowPlus a => ArrowPlus (StreamArrow a) where- Str f <+> Str g = Str (f <+> g)+ 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.)@@ -95,43 +109,50 @@ -- Circuits instance ArrowLoop a => ArrowCircuit (StreamArrow a) where- delay x = Str (arr (Cons x))+ delay x = StreamArrow (arr (Cons x)) -- Other instances instance Arrow a => Functor (StreamArrow a b) where- fmap f g = g >>> arr f+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance ArrowPlus a => Semigroup (StreamArrow a b c) where+ (<>) = (<+>)+#endif+ instance ArrowPlus a => Monoid (StreamArrow a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif -- | 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+-- > 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 (Str f) = arr (\(e, xs) -> fmap (\x -> (e, x)) xs) >>> f+runStream (StreamArrow f) = arr (\(e, xs) -> fmap (\x -> (e, x)) xs) >>> f instance ArrowLoop a => ArrowAddStream (StreamArrow a) a where- liftStream = lift- elimStream = runStream+ liftStream = lift+ elimStream = runStream -- | Mappings of streams type StreamMap = StreamArrow (->)@@ -151,4 +172,5 @@ -- | Encapsulate a local state. runStreamST :: (forall s. StreamMapST s e c) -> StreamMap e c-runStreamST cf = Str $ \ input -> runST (let Str (Kleisli f) = cf in f input)+runStreamST cf = StreamArrow $ \ input ->+ runST (let StreamArrow (Kleisli f) = cf in f input)
Control/Arrow/Transformer/Writer.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -6,26 +7,32 @@ -- Copyright : (c) Ross Paterson 2003 -- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ross@soi.city.ac.uk+-- Maintainer : R.Paterson@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,- runWriter,- ArrowAddWriter(..),- ) where+ WriterArrow(WriterArrow),+ runWriter,+ ArrowAddWriter(..),+ ) where import Control.Arrow.Internals import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Applicative-import Control.Arrow hiding (pure)+import Control.Arrow+import Control.Category import Data.Monoid+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif +import Prelude hiding (id,(.))+ -- | An arrow type that augments an existing arrow with accumulating -- output. The 'ArrowWriter' class contains the relevant operations. @@ -35,9 +42,9 @@ -- -- Typical usage in arrow notation: ----- > proc p -> do--- > ...--- > (result, output) <- (|runWriter cmd|)+-- > 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@@ -54,99 +61,113 @@ -- arrow transformer instance (Arrow a, Monoid w) => ArrowTransformer (WriterArrow w) a where- lift f = WriterArrow (f >>> arr unit)+ 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))- WriterArrow f >>> WriterArrow g =- WriterArrow (f >>> first g >>> arr join)- first (WriterArrow f) = WriterArrow (first f >>> arr rstrength)+ 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)+ 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)+ app = WriterArrow (arr (\(WriterArrow f, x) -> (f, x)) >>> app) instance (ArrowZero a, Monoid w) => ArrowZero (WriterArrow w a) where- zeroArrow = WriterArrow zeroArrow+ zeroArrow = WriterArrow zeroArrow instance (ArrowPlus a, Monoid w) => ArrowPlus (WriterArrow w a) where- WriterArrow f <+> WriterArrow g = WriterArrow (f <+> g)+ 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)+ 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+ 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)+ 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+ empty = zeroArrow+ f <|> g = f <+> g +#if MIN_VERSION_base(4,9,0)+instance (ArrowPlus a, Monoid w) => Semigroup (WriterArrow w a b c) where+ (<>) = (<+>)+#endif+ instance (ArrowPlus a, Monoid w) => Monoid (WriterArrow w a b c) where- mempty = zeroArrow- mappend f g = f <+> g+ mempty = zeroArrow+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<+>)+#endif -- 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)))+ 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+ liftWriter = lift+ elimWriter = runWriter -- liftings of other classes instance (ArrowCircuit a, Monoid w) => ArrowCircuit (WriterArrow w a) where- delay x = lift (delay x)+ 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)+ 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)+ 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+ 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)+ 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)+ 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)+ ArrowAddState s (WriterArrow w a) (WriterArrow w a') where+ liftState (WriterArrow f) = WriterArrow (liftState f)+ elimState (WriterArrow f) = WriterArrow (elimState f >>> arr rstrength)
arrows.cabal view
@@ -1,28 +1,37 @@ Name: arrows-Version: 0.4-Build-Depends: base >= 2.0 && < 3.1, Stream+Version: 0.4.4.2 Build-Type: Simple License: BSD3 License-file: LICENSE-Author: Ross Paterson <ross@soi.city.ac.uk>-Maintainer: Ross Paterson <ross@soi.city.ac.uk>+Author: Ross Paterson <R.Paterson@city.ac.uk>+Maintainer: Ross Paterson <R.Paterson@city.ac.uk>+Bug-Reports: http://hub.darcs.net/ross/arrows/issues 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+Cabal-Version: >= 1.6++library+ Build-Depends: base >= 4.0 && < 6, Stream+ 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++source-repository head+ type: darcs+ location: http://hub.darcs.net/ross/arrows