{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Transformer.Static(
StaticArrow(StaticArrow), StaticMonadArrow, StaticArrowArrow,
wrap, unwrap, wrapA, unwrapA, wrapM, unwrapM,
) where
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Monad
import Data.Monoid
#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif
import Prelude hiding (id,(.))
newtype StaticArrow f a b c = StaticArrow (f (a b c))
instance (Arrow a, Applicative f) => ArrowTransformer (StaticArrow f) a where
lift :: forall b c. a b c -> StaticArrow f a b c
lift a b c
f = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (f :: * -> *) a. Applicative f => a -> f a
pure a b c
f)
instance (Category a, Applicative f) => Category (StaticArrow f a) where
id :: forall a. StaticArrow f a a a
id = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
StaticArrow f (a b c)
f . :: forall b c a.
StaticArrow f a b c -> StaticArrow f a a b -> StaticArrow f a a c
. StaticArrow f (a a b)
g = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a b c)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a a b)
g)
instance (Arrow a, Applicative f) => Arrow (StaticArrow f a) where
arr :: forall b c. (b -> c) -> StaticArrow f a b c
arr b -> c
f = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> c
f))
first :: forall b c d. StaticArrow f a b c -> StaticArrow f a (b, d) (c, d)
first (StaticArrow f (a b c)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a b c)
f)
instance (ArrowZero a, Applicative f) => ArrowZero (StaticArrow f a) where
zeroArrow :: forall b c. StaticArrow f a b c
zeroArrow = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
instance (ArrowCircuit a, Applicative f) => ArrowCircuit (StaticArrow f a) where
delay :: forall b. b -> StaticArrow f 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, Applicative f) => ArrowError ex (StaticArrow f a) where
raise :: forall b. StaticArrow f 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.
StaticArrow f a e b
-> StaticArrow f a (e, ex) b -> StaticArrow f a e b
handle (StaticArrow f (a e b)
f) (StaticArrow f (a (e, ex) b)
h) =
forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a (e, ex) b -> a e b
handle forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a (e, ex) b)
h)
tryInUnless :: forall e b c.
StaticArrow f a e b
-> StaticArrow f a (e, b) c
-> StaticArrow f a (e, ex) c
-> StaticArrow f a e c
tryInUnless (StaticArrow f (a e b)
f) (StaticArrow f (a (e, b) c)
s) (StaticArrow f (a (e, ex) c)
h) =
forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall ex (a :: * -> * -> *) e b c.
ArrowError ex a =>
a e b -> a (e, b) c -> a (e, ex) c -> a e c
tryInUnless forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a (e, b) c)
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a (e, ex) c)
h)
instance (ArrowReader r a, Applicative f) => ArrowReader r (StaticArrow f a) where
readState :: forall b. StaticArrow f 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. StaticArrow f a e b -> StaticArrow f a (e, r) b
newReader (StaticArrow f (a e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall r (a :: * -> * -> *) e b.
ArrowReader r a =>
a e b -> a (e, r) b
newReader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f)
instance (ArrowState s a, Applicative f) => ArrowState s (StaticArrow f a) where
fetch :: forall e. StaticArrow f 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 :: StaticArrow f 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 (ArrowWriter w a, Applicative f) => ArrowWriter w (StaticArrow f a) where
write :: StaticArrow f a w ()
write = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall w (a :: * -> * -> *). ArrowWriter w a => a w ()
write
newWriter :: forall e b. StaticArrow f a e b -> StaticArrow f a e (b, w)
newWriter (StaticArrow f (a e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall w (a :: * -> * -> *) e b.
ArrowWriter w a =>
a e b -> a e (b, w)
newWriter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f)
instance (ArrowChoice a, Applicative f) => ArrowChoice (StaticArrow f a) where
left :: forall b c d.
StaticArrow f a b c -> StaticArrow f a (Either b d) (Either c d)
left (StaticArrow f (a b c)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a b c)
f)
instance (ArrowLoop a, Applicative f) => ArrowLoop (StaticArrow f a) where
loop :: forall b d c. StaticArrow f a (b, d) (c, d) -> StaticArrow f a b c
loop (StaticArrow f (a (b, d) (c, d))
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a (b, d) (c, d))
f)
instance (ArrowPlus a, Applicative f) => ArrowPlus (StaticArrow f a) where
StaticArrow f (a b c)
f <+> :: forall b c.
StaticArrow f a b c -> StaticArrow f a b c -> StaticArrow f a b c
<+> StaticArrow f (a b c)
g = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
(<+>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a b c)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a b c)
g)
instance (Arrow a, Applicative f) => Functor (StaticArrow f a b) where
fmap :: forall a b. (a -> b) -> StaticArrow f a b a -> StaticArrow f a b b
fmap a -> b
f StaticArrow f a b a
g = StaticArrow f 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, Applicative f) => Applicative (StaticArrow f a b) where
pure :: forall a. a -> StaticArrow f 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)
StaticArrow f a b (a -> b)
f <*> :: forall a b.
StaticArrow f a b (a -> b)
-> StaticArrow f a b a -> StaticArrow f a b b
<*> StaticArrow f a b a
g = StaticArrow f a b (a -> b)
f forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& StaticArrow f 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, Applicative f) => Alternative (StaticArrow f a b) where
empty :: forall a. StaticArrow f a b a
empty = forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
StaticArrow f a b a
f <|> :: forall a.
StaticArrow f a b a -> StaticArrow f a b a -> StaticArrow f a b a
<|> StaticArrow f a b a
g = StaticArrow f a b a
f forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> StaticArrow f a b a
g
#if MIN_VERSION_base(4,9,0)
instance (ArrowPlus a, Applicative f) => Semigroup (StaticArrow f a b c) where
<> :: StaticArrow f a b c -> StaticArrow f a b c -> StaticArrow f a b c
(<>) = forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
(<+>)
#endif
instance (ArrowPlus a, Applicative f) => Monoid (StaticArrow f a b c) where
mempty :: StaticArrow f a b c
mempty = forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
#if !(MIN_VERSION_base(4,11,0))
mappend = (<+>)
#endif
instance (ArrowAddStream a a', Applicative f) =>
ArrowAddStream (StaticArrow f a) (StaticArrow f a') where
liftStream :: forall e b. StaticArrow f a' e b -> StaticArrow f a e b
liftStream (StaticArrow f (a' e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddStream a a' =>
a' e b -> a e b
liftStream forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a' e b)
f)
elimStream :: forall e b c.
StaticArrow f a (e, b) c
-> StaticArrow f a' (e, Stream b) (Stream c)
elimStream (StaticArrow f (a (e, b) c)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (a :: * -> * -> *) (a' :: * -> * -> *) e b c.
ArrowAddStream a a' =>
a (e, b) c -> a' (e, Stream b) (Stream c)
elimStream forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a (e, b) c)
f)
instance (ArrowAddState s a a', Applicative f) =>
ArrowAddState s (StaticArrow f a) (StaticArrow f a') where
liftState :: forall e b. StaticArrow f a' e b -> StaticArrow f a e b
liftState (StaticArrow f (a' e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a' e b -> a e b
liftState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a' e b)
f)
elimState :: forall e b. StaticArrow f a e b -> StaticArrow f a' (e, s) (b, s)
elimState (StaticArrow f (a e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a e b -> a' (e, s) (b, s)
elimState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f)
instance (ArrowAddReader r a a', Applicative f) =>
ArrowAddReader r (StaticArrow f a) (StaticArrow f a') where
liftReader :: forall e b. StaticArrow f a' e b -> StaticArrow f a e b
liftReader (StaticArrow f (a' e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a' e b -> a e b
liftReader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a' e b)
f)
elimReader :: forall e b. StaticArrow f a e b -> StaticArrow f a' (e, r) b
elimReader (StaticArrow f (a e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a e b -> a' (e, r) b
elimReader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f)
instance (ArrowAddWriter w a a', Applicative f) =>
ArrowAddWriter w (StaticArrow f a) (StaticArrow f a') where
liftWriter :: forall e b. StaticArrow f a' e b -> StaticArrow f a e b
liftWriter (StaticArrow f (a' e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a' e b -> a e b
liftWriter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a' e b)
f)
elimWriter :: forall e b. StaticArrow f a e b -> StaticArrow f a' e (b, w)
elimWriter (StaticArrow f (a e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a e b -> a' e (b, w)
elimWriter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f)
instance (ArrowAddError ex a a', Applicative f) =>
ArrowAddError ex (StaticArrow f a) (StaticArrow f a') where
liftError :: forall e b. StaticArrow f a' e b -> StaticArrow f a e b
liftError (StaticArrow f (a' e b)
f) = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall ex (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddError ex a a' =>
a' e b -> a e b
liftError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a' e b)
f)
elimError :: forall e b.
StaticArrow f a e b
-> StaticArrow f a' (e, ex) b -> StaticArrow f a' e b
elimError (StaticArrow f (a e b)
f) (StaticArrow f (a' (e, ex) b)
h) =
forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall ex (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddError ex a a' =>
a e b -> a' (e, ex) b -> a' e b
elimError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a e b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a' (e, ex) b)
h)
wrap :: (Applicative f, Arrow a) => f (a b c) -> StaticArrow f a b c
wrap :: forall (f :: * -> *) (a :: * -> * -> *) b c.
(Applicative f, Arrow a) =>
f (a b c) -> StaticArrow f a b c
wrap = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow
unwrap :: (Applicative f, Arrow a) => StaticArrow f a b c -> f (a b c)
unwrap :: forall (f :: * -> *) (a :: * -> * -> *) b c.
(Applicative f, Arrow a) =>
StaticArrow f a b c -> f (a b c)
unwrap (StaticArrow f (a b c)
f) = f (a b c)
f
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 :: forall (a :: * -> * -> *) (a' :: * -> * -> *) s b c.
(Arrow a, Arrow a') =>
a s (a' b c) -> StaticArrowArrow a s a' b c
wrapA a s (a' b c)
x = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow a s (a' b c)
x)
unwrapA :: (Arrow a, Arrow a') => StaticArrowArrow a s a' b c -> a s (a' b c)
unwrapA :: forall (a :: * -> * -> *) (a' :: * -> * -> *) s b c.
(Arrow a, Arrow a') =>
StaticArrowArrow a s a' b c -> a s (a' b c)
unwrapA (StaticArrow (WrapArrow a s (a' b c)
x)) = a s (a' b c)
x
type StaticMonadArrow m = StaticArrow (WrappedMonad m)
wrapM :: (Monad m, Arrow a) => m (a b c) -> StaticMonadArrow m a b c
wrapM :: forall (m :: * -> *) (a :: * -> * -> *) b c.
(Monad m, Arrow a) =>
m (a b c) -> StaticMonadArrow m a b c
wrapM m (a b c)
x = forall (f :: * -> *) (a :: * -> * -> *) b c.
f (a b c) -> StaticArrow f a b c
StaticArrow (forall (m :: * -> *) a. m a -> WrappedMonad m a
WrapMonad m (a b c)
x)
unwrapM :: (Monad m, Arrow a) => StaticMonadArrow m a b c -> m (a b c)
unwrapM :: forall (m :: * -> *) (a :: * -> * -> *) b c.
(Monad m, Arrow a) =>
StaticMonadArrow m a b c -> m (a b c)
unwrapM (StaticArrow (WrapMonad m (a b c)
x)) = m (a b c)
x