module Control.Wire.Internal
(
Wire(..),
delayW,
Event(..),
event
)
where
import Control.Arrow
import Control.Category
import Control.DeepSeq
import Control.Monad.Fix
import Data.Align
import Data.Functor.Bind
import Data.Functor.Extend
import Data.Functor.Plus
import Data.Profunctor
import Data.Semigroup
import Data.These
import Prelude hiding ((.), id)
data Event a
= NotNow
| Now a
deriving (Functor)
instance Align Event where
nil = NotNow
alignWith f (Now x) (Now y) = Now (f (These x y))
alignWith f (Now x) _ = Now (f (This x))
alignWith f _ (Now y) = Now (f (That y))
alignWith _ _ _ = NotNow
instance Alt Event where
(<!>) = alignWith (mergeThese const)
instance Apply Event where
Now f <.> Now x = Now (f x)
_ <.> _ = NotNow
instance Bind Event where
Now x >>- f = event NotNow Now (f x)
NotNow >>- _ = NotNow
join (Now (Now x)) = Now x
join _ = NotNow
instance Extend Event where
duplicated = event NotNow (Now . Now)
extended f = event NotNow (Now . f . Now)
instance (Semigroup a) => Monoid (Event a) where
mappend = (<>)
mempty = nil
instance (NFData a) => NFData (Event a) where
rnf NotNow = ()
rnf (Now x) = rnf x
instance Plus Event where
zero = nil
instance (Semigroup a) => Semigroup (Event a) where
(<>) = alignWith (mergeThese (<>))
newtype Wire m a b =
Wire {
stepWire :: a -> m (b, Wire m a b)
}
deriving (Functor)
instance (Applicative m) => Applicative (Wire m a) where
pure x = let w = Wire (\_ -> pure (x, w)) in w
wf' <*> wx' =
Wire $ \x' ->
(\ ~(f, wf) ~(x, wx) -> (f x, wf <*> wx))
<$> stepWire wf' x'
<*> stepWire wx' x'
instance (Monad m) => Arrow (Wire m) where
arr f = let w = Wire (\x -> pure (f x, w)) in w
first = first'
second = second'
wx' &&& wy' =
Wire $ \x' ->
(\ ~(x, wx) ~(y, wy) -> ((x, y), wx &&& wy))
<$> stepWire wx' x'
<*> stepWire wy' x'
wx' *** wy' =
Wire $ \(x', y') ->
(\(x, wx) (y, wy) -> ((x, y), wx *** wy))
<$> stepWire wx' x'
<*> stepWire wy' y'
instance (Monad m) => ArrowChoice (Wire m) where
left = left'
right = right'
wl' +++ wr' =
Wire $
either (\x -> (\ ~(y, wl) -> (Left y, wl +++ wr')) <$> stepWire wl' x)
(\x -> (\ ~(y, wr) -> (Right y, wl' +++ wr)) <$> stepWire wr' x)
wl' ||| wr' =
Wire $
either (\x -> (\ ~(y, wl) -> (y, wl ||| wr')) <$> stepWire wl' x)
(\x -> (\ ~(y, wr) -> (y, wl' ||| wr)) <$> stepWire wr' x)
instance (MonadFix m) => ArrowLoop (Wire m) where
loop = unfirst
instance (Monad m) => Category (Wire m) where
id = let w = Wire (\x -> pure (x, w)) in w
w2' . w1' =
Wire $ \x0 -> do
~(x1, w1) <- stepWire w1' x0
~(x2, w2) <- stepWire w2' x1
pure (x2, w2 . w1)
instance (Applicative m) => Choice (Wire m) where
left' w' =
Wire $
either (\x -> (\ ~(y, w) -> (Left y, left' w)) <$> stepWire w' x)
(\x -> pure (Right x, left' w'))
right' w' =
Wire $
either (\x -> pure (Left x, right' w'))
(\x -> (\ ~(y, w) -> (Right y, right' w)) <$> stepWire w' x)
instance (MonadFix m) => Costrong (Wire m) where
unfirst w' =
Wire $ \x' ->
(\ ~(x, w) -> (fst x, unfirst w))
<$> mfix (\r -> stepWire w' (x', snd (fst r)))
unsecond w' =
Wire $ \x' ->
(\ ~(x, w) -> (snd x, unsecond w))
<$> mfix (\r -> stepWire w' (fst (fst r), x'))
instance (Functor m) => Profunctor (Wire m) where
dimap fl fr = go
where
go w' = Wire (fmap (\ ~(y, w) -> (fr y, go w)) . stepWire w' . fl)
lmap f = go
where
go w' = Wire (fmap (\ ~(y, w) -> (y, go w)) . stepWire w' . f)
rmap = fmap
instance (Functor m) => Strong (Wire m) where
first' w' =
Wire $ \ ~(x', y) ->
(\ ~(x, w) -> ((x, y), first' w))
<$> stepWire w' x'
second' w' =
Wire $ \ ~(x, y') ->
(\ ~(y, w) -> ((x, y), second' w))
<$> stepWire w' y'
delayW :: (Functor m) => b -> Wire m a b -> Wire m a b
delayW y' w' =
Wire $
fmap (\ ~(y, w) -> (y', delayW y w)) .
stepWire w'
event
:: r
-> (a -> r)
-> Event a
-> r
event k _ NotNow = k
event _ k (Now x) = k x