{- |
In the Rhine philosophy, _event sources are clocks_.
Often, we want to extract certain subevents from event sources,
e.g. single out only left mouse button clicks from all input device events.
This module provides a general purpose selection clock
that ticks only on certain subevents.
-}

{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Clock.Select where

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
import FRP.Rhine.Schedule

-- dunai
import Data.MonadicStreamFunction.Async (concatS)

-- base
import Data.Maybe (catMaybes, maybeToList)

-- | A clock that selects certain subevents of type 'a',
--   from the tag of a main clock.
--
--   If two 'SelectClock's would tick on the same type of subevents,
--   but should not have the same type,
--   one should @newtype@ the subevent.
data SelectClock cl a = SelectClock
  { SelectClock cl a -> cl
mainClock :: cl -- ^ The main clock
  -- | Return 'Nothing' if no tick of the subclock is required,
  --   or 'Just a' if the subclock should tick, with tag 'a'.
  , SelectClock cl a -> Tag cl -> Maybe a
select    :: Tag cl -> Maybe a
  }

instance (Semigroup a, Semigroup cl) => Semigroup (SelectClock cl a) where
  SelectClock cl a
cl1 <> :: SelectClock cl a -> SelectClock cl a -> SelectClock cl a
<> SelectClock cl a
cl2 = SelectClock :: forall cl a. cl -> (Tag cl -> Maybe a) -> SelectClock cl a
SelectClock
    { mainClock :: cl
mainClock = SelectClock cl a -> cl
forall cl a. SelectClock cl a -> cl
mainClock SelectClock cl a
cl1 cl -> cl -> cl
forall a. Semigroup a => a -> a -> a
<> SelectClock cl a -> cl
forall cl a. SelectClock cl a -> cl
mainClock SelectClock cl a
cl2
    , select :: Tag cl -> Maybe a
select = \Tag cl
tag -> SelectClock cl a -> Tag cl -> Maybe a
forall cl a. SelectClock cl a -> Tag cl -> Maybe a
select SelectClock cl a
cl1 Tag cl
tag Maybe a -> Maybe a -> Maybe a
forall a. Semigroup a => a -> a -> a
<> SelectClock cl a -> Tag cl -> Maybe a
forall cl a. SelectClock cl a -> Tag cl -> Maybe a
select SelectClock cl a
cl2 Tag cl
tag
    }

instance (Monoid cl, Semigroup a) => Monoid (SelectClock cl a) where
  mempty :: SelectClock cl a
mempty = SelectClock :: forall cl a. cl -> (Tag cl -> Maybe a) -> SelectClock cl a
SelectClock
    { mainClock :: cl
mainClock = cl
forall a. Monoid a => a
mempty
    , select :: Tag cl -> Maybe a
select = Maybe a -> Tag cl -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Monoid a => a
mempty
    }


instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where
  type Time (SelectClock cl a) = Time cl
  type Tag  (SelectClock cl a) = a
  initClock :: SelectClock cl a
-> RunningClockInit
     m (Time (SelectClock cl a)) (Tag (SelectClock cl a))
initClock SelectClock {cl
Tag cl -> Maybe a
select :: Tag cl -> Maybe a
mainClock :: cl
select :: forall cl a. SelectClock cl a -> Tag cl -> Maybe a
mainClock :: forall cl a. SelectClock cl a -> cl
..} = do
    (MSF m () (Time cl, Tag cl)
runningClock, Time cl
initialTime) <- cl -> m (MSF m () (Time cl, Tag cl), Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
mainClock
    let
      runningSelectClock :: MSF m () (Time cl, a)
runningSelectClock = MSF m () (Maybe (Time cl, a)) -> MSF m () (Time cl, a)
forall (m :: Type -> Type) b.
Monad m =>
MSF m () (Maybe b) -> MSF m () b
filterS (MSF m () (Maybe (Time cl, a)) -> MSF m () (Time cl, a))
-> MSF m () (Maybe (Time cl, a)) -> MSF m () (Time cl, a)
forall a b. (a -> b) -> a -> b
$ proc ()
_ -> do
        (Time cl
time, Tag cl
tag) <- MSF m () (Time cl, Tag cl)
runningClock -< ()
        MSF m (Maybe (Time cl, a)) (Maybe (Time cl, a))
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA                     -< (Time cl
time, ) (a -> (Time cl, a)) -> Maybe a -> Maybe (Time cl, a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Tag cl -> Maybe a
select Tag cl
tag
    (MSF m () (Time cl, a), Time cl)
-> m (MSF m () (Time cl, a), Time cl)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MSF m () (Time cl, a)
runningSelectClock, Time cl
initialTime)

instance GetClockProxy (SelectClock cl a)

-- | A universal schedule for two subclocks of the same main clock.
--   The main clock must be a 'Semigroup' (e.g. a singleton).
schedSelectClocks
  :: (Monad m, Semigroup cl, Clock m cl)
  => Schedule m (SelectClock cl a) (SelectClock cl b)
schedSelectClocks :: Schedule m (SelectClock cl a) (SelectClock cl b)
schedSelectClocks = Schedule :: forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
 -> cl2
 -> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule {SelectClock cl a
-> SelectClock cl b
-> m (MSF
        m
        ()
        (Time (SelectClock cl a),
         Either (Tag (SelectClock cl a)) (Tag (SelectClock cl b))),
      Time (SelectClock cl a))
forall (m :: Type -> Type) cl a b.
(Monad m, Clock m cl, Semigroup cl) =>
SelectClock cl a
-> SelectClock cl b -> m (MStream m (Time cl, Either a b), Time cl)
initSchedule :: SelectClock cl a
-> SelectClock cl b
-> m (MSF
        m
        ()
        (Time (SelectClock cl a),
         Either (Tag (SelectClock cl a)) (Tag (SelectClock cl b))),
      Time (SelectClock cl a))
initSchedule :: forall (m :: Type -> Type) cl a b.
(Monad m, Clock m cl, Semigroup cl) =>
SelectClock cl a
-> SelectClock cl b -> m (MStream m (Time cl, Either a b), Time cl)
..}
  where
    initSchedule :: SelectClock cl a
-> SelectClock cl b -> m (MStream m (Time cl, Either a b), Time cl)
initSchedule SelectClock cl a
subClock1 SelectClock cl b
subClock2 = do
      (MSF m () (Time cl, Tag cl)
runningClock, Time cl
initialTime) <- cl -> RunningClockInit m (Time cl) (Tag cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock
        (cl -> RunningClockInit m (Time cl) (Tag cl))
-> cl -> RunningClockInit m (Time cl) (Tag cl)
forall a b. (a -> b) -> a -> b
$ SelectClock cl a -> cl
forall cl a. SelectClock cl a -> cl
mainClock SelectClock cl a
subClock1 cl -> cl -> cl
forall a. Semigroup a => a -> a -> a
<> SelectClock cl b -> cl
forall cl a. SelectClock cl a -> cl
mainClock SelectClock cl b
subClock2
      let
        runningSelectClocks :: MStream m (Time cl, Either a b)
runningSelectClocks = MStream m [(Time cl, Either a b)]
-> MStream m (Time cl, Either a b)
forall (m :: Type -> Type) b.
Monad m =>
MStream m [b] -> MStream m b
concatS (MStream m [(Time cl, Either a b)]
 -> MStream m (Time cl, Either a b))
-> MStream m [(Time cl, Either a b)]
-> MStream m (Time cl, Either a b)
forall a b. (a -> b) -> a -> b
$ proc ()
_ -> do
          (Time cl
time, Tag cl
tag) <- MSF m () (Time cl, Tag cl)
runningClock -< ()
          MSF m [(Time cl, Either a b)] [(Time cl, Either a b)]
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA                     -< [Maybe (Time cl, Either a b)] -> [(Time cl, Either a b)]
forall a. [Maybe a] -> [a]
catMaybes
            [ (Time cl
time, ) (Either a b -> (Time cl, Either a b))
-> (a -> Either a b) -> a -> (Time cl, Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left  (a -> (Time cl, Either a b))
-> Maybe a -> Maybe (Time cl, Either a b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectClock cl a -> Tag cl -> Maybe a
forall cl a. SelectClock cl a -> Tag cl -> Maybe a
select SelectClock cl a
subClock1 Tag cl
tag
            , (Time cl
time, ) (Either a b -> (Time cl, Either a b))
-> (b -> Either a b) -> b -> (Time cl, Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right (b -> (Time cl, Either a b))
-> Maybe b -> Maybe (Time cl, Either a b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectClock cl b -> Tag cl -> Maybe b
forall cl a. SelectClock cl a -> Tag cl -> Maybe a
select SelectClock cl b
subClock2 Tag cl
tag ]
      (MStream m (Time cl, Either a b), Time cl)
-> m (MStream m (Time cl, Either a b), Time cl)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MStream m (Time cl, Either a b)
runningSelectClocks, Time cl
initialTime)

-- | A universal schedule for a subclock and its main clock.
schedSelectClockAndMain
  :: (Monad m, Semigroup cl, Clock m cl)
  => Schedule m cl (SelectClock cl a)
schedSelectClockAndMain :: Schedule m cl (SelectClock cl a)
schedSelectClockAndMain = Schedule :: forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
 -> cl2
 -> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule {cl
-> SelectClock cl a
-> m (MSF m () (Time cl, Either (Tag cl) (Tag (SelectClock cl a))),
      Time cl)
forall (m :: Type -> Type) cl b.
(Monad m, Clock m cl, Semigroup cl) =>
cl
-> SelectClock cl b
-> m (MStream m (Time cl, Either (Tag cl) b), Time cl)
initSchedule :: forall (m :: Type -> Type) cl b.
(Monad m, Clock m cl, Semigroup cl) =>
cl
-> SelectClock cl b
-> m (MStream m (Time cl, Either (Tag cl) b), Time cl)
initSchedule :: cl
-> SelectClock cl a
-> m (MSF m () (Time cl, Either (Tag cl) (Tag (SelectClock cl a))),
      Time cl)
..}
  where
    initSchedule :: cl
-> SelectClock cl b
-> m (MStream m (Time cl, Either (Tag cl) b), Time cl)
initSchedule cl
mainClock' SelectClock {cl
Tag cl -> Maybe b
select :: Tag cl -> Maybe b
mainClock :: cl
select :: forall cl a. SelectClock cl a -> Tag cl -> Maybe a
mainClock :: forall cl a. SelectClock cl a -> cl
..} = do
      (MSF m () (Time cl, Tag cl)
runningClock, Time cl
initialTime) <- cl -> RunningClockInit m (Time cl) (Tag cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock
        (cl -> RunningClockInit m (Time cl) (Tag cl))
-> cl -> RunningClockInit m (Time cl) (Tag cl)
forall a b. (a -> b) -> a -> b
$ cl
mainClock' cl -> cl -> cl
forall a. Semigroup a => a -> a -> a
<> cl
mainClock
      let
        runningSelectClock :: MStream m (Time cl, Either (Tag cl) b)
runningSelectClock = MStream m [(Time cl, Either (Tag cl) b)]
-> MStream m (Time cl, Either (Tag cl) b)
forall (m :: Type -> Type) b.
Monad m =>
MStream m [b] -> MStream m b
concatS (MStream m [(Time cl, Either (Tag cl) b)]
 -> MStream m (Time cl, Either (Tag cl) b))
-> MStream m [(Time cl, Either (Tag cl) b)]
-> MStream m (Time cl, Either (Tag cl) b)
forall a b. (a -> b) -> a -> b
$ proc ()
_ -> do
          (Time cl
time, Tag cl
tag) <- MSF m () (Time cl, Tag cl)
runningClock -< ()
          MSF m [(Time cl, Either (Tag cl) b)] [(Time cl, Either (Tag cl) b)]
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA                     -< [Maybe (Time cl, Either (Tag cl) b)]
-> [(Time cl, Either (Tag cl) b)]
forall a. [Maybe a] -> [a]
catMaybes
            [ (Time cl, Either (Tag cl) b) -> Maybe (Time cl, Either (Tag cl) b)
forall a. a -> Maybe a
Just (Time cl
time, Tag cl -> Either (Tag cl) b
forall a b. a -> Either a b
Left Tag cl
tag)
            , (Time cl
time, ) (Either (Tag cl) b -> (Time cl, Either (Tag cl) b))
-> (b -> Either (Tag cl) b) -> b -> (Time cl, Either (Tag cl) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either (Tag cl) b
forall a b. b -> Either a b
Right (b -> (Time cl, Either (Tag cl) b))
-> Maybe b -> Maybe (Time cl, Either (Tag cl) b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Tag cl -> Maybe b
select Tag cl
tag ]
      (MStream m (Time cl, Either (Tag cl) b), Time cl)
-> m (MStream m (Time cl, Either (Tag cl) b), Time cl)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MStream m (Time cl, Either (Tag cl) b)
runningSelectClock, Time cl
initialTime)


-- | Helper function that runs an 'MSF' with 'Maybe' output
--   until it returns a value.
filterS :: Monad m => MSF m () (Maybe b) -> MSF m () b
filterS :: MSF m () (Maybe b) -> MSF m () b
filterS = MStream m [b] -> MSF m () b
forall (m :: Type -> Type) b.
Monad m =>
MStream m [b] -> MStream m b
concatS (MStream m [b] -> MSF m () b)
-> (MSF m () (Maybe b) -> MStream m [b])
-> MSF m () (Maybe b)
-> MSF m () b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MSF m () (Maybe b) -> MSF m (Maybe b) [b] -> MStream m [b]
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe b -> [b]) -> MSF m (Maybe b) [b]
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr Maybe b -> [b]
forall a. Maybe a -> [a]
maybeToList)