diff --git a/Control/Arrow/Internals.hs b/Control/Arrow/Internals.hs --- a/Control/Arrow/Internals.hs +++ b/Control/Arrow/Internals.hs @@ -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) diff --git a/Control/Arrow/Operations.hs b/Control/Arrow/Operations.hs --- a/Control/Arrow/Operations.hs +++ b/Control/Arrow/Operations.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} - ----------------------------------------------------------------------------- -- | -- Module : Control.Arrow.Operations @@ -16,21 +14,21 @@ -- notation for arrows, cf. . 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. diff --git a/Control/Arrow/Transformer.hs b/Control/Arrow/Transformer.hs --- a/Control/Arrow/Transformer.hs +++ b/Control/Arrow/Transformer.hs @@ -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 diff --git a/Control/Arrow/Transformer/All.hs b/Control/Arrow/Transformer/All.hs --- a/Control/Arrow/Transformer/All.hs +++ b/Control/Arrow/Transformer/All.hs @@ -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 diff --git a/Control/Arrow/Transformer/Automaton.hs b/Control/Arrow/Transformer/Automaton.hs --- a/Control/Arrow/Transformer/Automaton.hs +++ b/Control/Arrow/Transformer/Automaton.hs @@ -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'))) diff --git a/Control/Arrow/Transformer/CoState.hs b/Control/Arrow/Transformer/CoState.hs --- a/Control/Arrow/Transformer/CoState.hs +++ b/Control/Arrow/Transformer/CoState.hs @@ -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 diff --git a/Control/Arrow/Transformer/Error.hs b/Control/Arrow/Transformer/Error.hs --- a/Control/Arrow/Transformer/Error.hs +++ b/Control/Arrow/Transformer/Error.hs @@ -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) diff --git a/Control/Arrow/Transformer/Reader.hs b/Control/Arrow/Transformer/Reader.hs --- a/Control/Arrow/Transformer/Reader.hs +++ b/Control/Arrow/Transformer/Reader.hs @@ -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 diff --git a/Control/Arrow/Transformer/State.hs b/Control/Arrow/Transformer/State.hs --- a/Control/Arrow/Transformer/State.hs +++ b/Control/Arrow/Transformer/State.hs @@ -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)) diff --git a/Control/Arrow/Transformer/Static.hs b/Control/Arrow/Transformer/Static.hs --- a/Control/Arrow/Transformer/Static.hs +++ b/Control/Arrow/Transformer/Static.hs @@ -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 diff --git a/Control/Arrow/Transformer/Stream.hs b/Control/Arrow/Transformer/Stream.hs --- a/Control/Arrow/Transformer/Stream.hs +++ b/Control/Arrow/Transformer/Stream.hs @@ -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) diff --git a/Control/Arrow/Transformer/Writer.hs b/Control/Arrow/Transformer/Writer.hs --- a/Control/Arrow/Transformer/Writer.hs +++ b/Control/Arrow/Transformer/Writer.hs @@ -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) diff --git a/arrows.cabal b/arrows.cabal --- a/arrows.cabal +++ b/arrows.cabal @@ -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 -Maintainer: Ross Paterson +Author: Ross Paterson +Maintainer: Ross Paterson +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