{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Transformer.Writer(
WriterArrow(WriterArrow),
runWriter,
ArrowAddWriter(..),
) where
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Control.Applicative
import Control.Arrow
import Control.Category
import Data.Monoid
#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif
import Prelude hiding (id,(.))
newtype WriterArrow w a b c = WriterArrow (a b (c, w))
runWriter :: (Arrow a, Monoid w) => WriterArrow w a e b -> a e (b,w)
runWriter :: forall (a :: * -> * -> *) w e b.
(Arrow a, Monoid w) =>
WriterArrow w a e b -> a e (b, w)
runWriter (WriterArrow a e (b, w)
f) = a e (b, w)
f
rstrength :: ((a, w), b) -> ((a, b), w)
rstrength :: forall a w b. ((a, w), b) -> ((a, b), w)
rstrength ((a
a, w
w), b
b) = ((a
a, b
b), w
w)
unit :: Monoid w => a -> (a, w)
unit :: forall w a. Monoid w => a -> (a, w)
unit a
a = (a
a, forall a. Monoid a => a
mempty)
join :: Monoid w => ((a, w), w) -> (a, w)
join :: forall w a. Monoid w => ((a, w), w) -> (a, w)
join ((a
a, w
w2), w
w1) = (a
a, w
w1 forall a. Monoid a => a -> a -> a
`mappend` w
w2)
instance (Arrow a, Monoid w) => ArrowTransformer (WriterArrow w) a where
lift :: forall b c. a b c -> WriterArrow w a b c
lift a b c
f = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (a b c
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall w a. Monoid w => a -> (a, w)
unit)
instance (Arrow a, Monoid w) => Category (WriterArrow w a) where
id :: forall a. WriterArrow w a a a
id = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall w a. Monoid w => a -> (a, w)
unit)
WriterArrow a b (c, w)
f . :: forall b c a.
WriterArrow w a b c -> WriterArrow w a a b -> WriterArrow w a a c
. WriterArrow a a (b, w)
g =
forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall w a. Monoid w => ((a, w), w) -> (a, w)
join forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b (c, w)
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a a (b, w)
g)
instance (Arrow a, Monoid w) => Arrow (WriterArrow w a) where
arr :: forall b c. (b -> c) -> WriterArrow w a b c
arr b -> c
f = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall w a. Monoid w => a -> (a, w)
unit forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> c
f))
first :: forall b c d. WriterArrow w a b c -> WriterArrow w a (b, d) (c, d)
first (WriterArrow a b (c, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b (c, w)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a w b. ((a, w), b) -> ((a, b), w)
rstrength)
instance (ArrowChoice a, Monoid w) => ArrowChoice (WriterArrow w a) where
left :: forall b c d.
WriterArrow w a b c -> WriterArrow w a (Either b d) (Either c d)
left (WriterArrow a b (c, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left a b (c, w)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {b} {a} {b}. Monoid b => Either (a, b) b -> (Either a b, b)
lift_monoid)
where
lift_monoid :: Either (a, b) b -> (Either a b, b)
lift_monoid (Left (a
x, b
w)) = (forall a b. a -> Either a b
Left a
x, b
w)
lift_monoid (Right b
y) = forall w a. Monoid w => a -> (a, w)
unit (forall a b. b -> Either a b
Right b
y)
instance (ArrowApply a, Monoid w) => ArrowApply (WriterArrow w a) where
app :: forall b c. WriterArrow w a (WriterArrow w a b c, b) c
app = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(WriterArrow a b (c, w)
f, b
x) -> (a b (c, w)
f, b
x)) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app)
instance (ArrowZero a, Monoid w) => ArrowZero (WriterArrow w a) where
zeroArrow :: forall b c. WriterArrow w a b c
zeroArrow = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
instance (ArrowPlus a, Monoid w) => ArrowPlus (WriterArrow w a) where
WriterArrow a b (c, w)
f <+> :: forall b c.
WriterArrow w a b c -> WriterArrow w a b c -> WriterArrow w a b c
<+> WriterArrow a b (c, w)
g = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (a b (c, w)
f forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> a b (c, w)
g)
instance (ArrowLoop a, Monoid w) => ArrowLoop (WriterArrow w a) where
loop :: forall b d c. WriterArrow w a (b, d) (c, d) -> WriterArrow w a b c
loop (WriterArrow a (b, d) ((c, d), w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop (a (b, d) ((c, d), w)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a w b. ((a, w), b) -> ((a, b), w)
swapenv))
where
swapenv :: ((a, b), b) -> ((a, b), b)
swapenv ~(~(a
x, b
y), b
w) = ((a
x, b
w), b
y)
instance (Arrow a, Monoid w) => Functor (WriterArrow w a b) where
fmap :: forall a b. (a -> b) -> WriterArrow w a b a -> WriterArrow w a b b
fmap a -> b
f WriterArrow w a b a
g = WriterArrow w a b a
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f
instance (Arrow a, Monoid w) => Applicative (WriterArrow w a b) where
pure :: forall a. a -> WriterArrow w a b a
pure a
x = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. a -> b -> a
const a
x)
WriterArrow w a b (a -> b)
f <*> :: forall a b.
WriterArrow w a b (a -> b)
-> WriterArrow w a b a -> WriterArrow w a b b
<*> WriterArrow w a b a
g = WriterArrow w a b (a -> b)
f forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& WriterArrow w a b a
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
instance (ArrowPlus a, Monoid w) => Alternative (WriterArrow w a b) where
empty :: forall a. WriterArrow w a b a
empty = forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
WriterArrow w a b a
f <|> :: forall a.
WriterArrow w a b a -> WriterArrow w a b a -> WriterArrow w a b a
<|> WriterArrow w a b a
g = WriterArrow w a b a
f forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> WriterArrow w a b a
g
#if MIN_VERSION_base(4,9,0)
instance (ArrowPlus a, Monoid w) => Semigroup (WriterArrow w a b c) where
<> :: WriterArrow w a b c -> WriterArrow w a b c -> WriterArrow w a b c
(<>) = forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
(<+>)
#endif
instance (ArrowPlus a, Monoid w) => Monoid (WriterArrow w a b c) where
mempty :: WriterArrow w a b c
mempty = forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
#if !(MIN_VERSION_base(4,11,0))
mappend = (<+>)
#endif
instance (Arrow a, Monoid w) => ArrowWriter w (WriterArrow w a) where
write :: WriterArrow w a w ()
write = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\w
x -> ((), w
x)))
newWriter :: forall e b. WriterArrow w a e b -> WriterArrow w a e (b, w)
newWriter (WriterArrow a e (b, w)
f) =
forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (a e (b, w)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(b
x, w
w) -> ((b
x, w
w), w
w)))
instance (Arrow a, Monoid w) => ArrowAddWriter w (WriterArrow w a) a where
liftWriter :: forall e b. a e b -> WriterArrow w a e b
liftWriter = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift
elimWriter :: forall e b. WriterArrow w a e b -> a e (b, w)
elimWriter = forall (a :: * -> * -> *) w e b.
(Arrow a, Monoid w) =>
WriterArrow w a e b -> a e (b, w)
runWriter
instance (ArrowCircuit a, Monoid w) => ArrowCircuit (WriterArrow w a) where
delay :: forall b. b -> WriterArrow w a b b
delay b
x = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift (forall (a :: * -> * -> *) b. ArrowCircuit a => b -> a b b
delay b
x)
instance (ArrowError ex a, Monoid w) => ArrowError ex (WriterArrow w a) where
raise :: forall b. WriterArrow w a ex b
raise = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall ex (a :: * -> * -> *) b. ArrowError ex a => a ex b
raise
handle :: forall e b.
WriterArrow w a e b
-> WriterArrow w a (e, ex) b -> WriterArrow w a e b
handle (WriterArrow a e (b, w)
f) (WriterArrow a (e, ex) (b, w)
h) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a (e, ex) b -> a e b
handle a e (b, w)
f a (e, ex) (b, w)
h)
tryInUnless :: forall e b c.
WriterArrow w a e b
-> WriterArrow w a (e, b) c
-> WriterArrow w a (e, ex) c
-> WriterArrow w a e c
tryInUnless (WriterArrow a e (b, w)
f) (WriterArrow a (e, b) (c, w)
s) (WriterArrow a (e, ex) (c, w)
h) =
forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall ex (a :: * -> * -> *) e b c.
ArrowError ex a =>
a e b -> a (e, b) c -> a (e, ex) c -> a e c
tryInUnless a e (b, w)
f a (e, (b, w)) (c, w)
s' a (e, ex) (c, w)
h)
where
s' :: a (e, (b, w)) (c, w)
s' = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {a} {b} {b}. (a, (b, b)) -> ((a, b), b)
lstrength forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a (e, b) (c, w)
s forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall w a. Monoid w => ((a, w), w) -> (a, w)
join
lstrength :: (a, (b, b)) -> ((a, b), b)
lstrength (a
x, (b
y, b
w)) = ((a
x, b
y), b
w)
newError :: forall e b. WriterArrow w a e b -> WriterArrow w a e (Either ex b)
newError (WriterArrow a e (b, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a e (Either ex b)
newError a e (b, w)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {w} {a} {b}. Monoid w => Either a (b, w) -> (Either a b, w)
h)
where
h :: Either a (b, w) -> (Either a b, w)
h (Left a
ex) = forall w a. Monoid w => a -> (a, w)
unit (forall a b. a -> Either a b
Left a
ex)
h (Right (b
c, w
w)) = (forall a b. b -> Either a b
Right b
c, w
w)
instance (ArrowReader r a, Monoid w) => ArrowReader r (WriterArrow w a) where
readState :: forall b. WriterArrow w a b r
readState = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall r (a :: * -> * -> *) b. ArrowReader r a => a b r
readState
newReader :: forall e b. WriterArrow w a e b -> WriterArrow w a (e, r) b
newReader (WriterArrow a e (b, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall r (a :: * -> * -> *) e b.
ArrowReader r a =>
a e b -> a (e, r) b
newReader a e (b, w)
f)
instance (ArrowState s a, Monoid w) => ArrowState s (WriterArrow w a) where
fetch :: forall e. WriterArrow w a e s
fetch = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall s (a :: * -> * -> *) e. ArrowState s a => a e s
fetch
store :: WriterArrow w a s ()
store = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall s (a :: * -> * -> *). ArrowState s a => a s ()
store
instance (ArrowAddError ex a a', Monoid w) =>
ArrowAddError ex (WriterArrow w a) (WriterArrow w a') where
liftError :: forall e b. WriterArrow w a' e b -> WriterArrow w a e b
liftError (WriterArrow a' e (b, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall ex (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddError ex a a' =>
a' e b -> a e b
liftError a' e (b, w)
f)
elimError :: forall e b.
WriterArrow w a e b
-> WriterArrow w a' (e, ex) b -> WriterArrow w a' e b
elimError (WriterArrow a e (b, w)
f) (WriterArrow a' (e, ex) (b, w)
h) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall ex (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddError ex a a' =>
a e b -> a' (e, ex) b -> a' e b
elimError a e (b, w)
f a' (e, ex) (b, w)
h)
instance (ArrowAddReader r a a', Monoid w) =>
ArrowAddReader r (WriterArrow w a) (WriterArrow w a') where
liftReader :: forall e b. WriterArrow w a' e b -> WriterArrow w a e b
liftReader (WriterArrow a' e (b, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a' e b -> a e b
liftReader a' e (b, w)
f)
elimReader :: forall e b. WriterArrow w a e b -> WriterArrow w a' (e, r) b
elimReader (WriterArrow a e (b, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a e b -> a' (e, r) b
elimReader a e (b, w)
f)
instance (ArrowAddState s a a', Monoid w) =>
ArrowAddState s (WriterArrow w a) (WriterArrow w a') where
liftState :: forall e b. WriterArrow w a' e b -> WriterArrow w a e b
liftState (WriterArrow a' e (b, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a' e b -> a e b
liftState a' e (b, w)
f)
elimState :: forall e b. WriterArrow w a e b -> WriterArrow w a' (e, s) (b, s)
elimState (WriterArrow a e (b, w)
f) = forall w (a :: * -> * -> *) b c. a b (c, w) -> WriterArrow w a b c
WriterArrow (forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a e b -> a' (e, s) (b, s)
elimState a e (b, w)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a w b. ((a, w), b) -> ((a, b), w)
rstrength)