{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

{- |
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.
-}
module FRP.Rhine.Clock.Select where

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

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

-- base
import Data.Maybe (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
  { forall cl a. 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'.
  , forall cl 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
      { mainClock :: cl
mainClock = forall cl a. SelectClock cl a -> cl
mainClock SelectClock cl a
cl1 forall a. Semigroup a => a -> a -> a
<> forall cl a. SelectClock cl a -> cl
mainClock SelectClock cl a
cl2
      , select :: Tag cl -> Maybe a
select = \Tag cl
tag -> forall cl a. SelectClock cl a -> Tag cl -> Maybe a
select SelectClock cl a
cl1 Tag cl
tag forall a. Semigroup a => a -> a -> 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
      { mainClock :: cl
mainClock = forall a. Monoid a => a
mempty
      , select :: Tag cl -> Maybe a
select = forall a b. a -> b -> a
const 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) <- 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 = forall (m :: Type -> Type) b.
Monad m =>
MSF m () (Maybe b) -> MSF m () b
filterS forall a b. (a -> b) -> a -> b
$ proc ()
_ -> do
        (Time cl
time, Tag cl
tag) <- MSF m () (Time cl, Tag cl)
runningClock -< ()
        forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (Time cl
time,) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Tag cl -> Maybe a
select Tag cl
tag
    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)

{- | 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 :: forall (m :: Type -> Type) b.
Monad m =>
MSF m () (Maybe b) -> MSF m () b
filterS = forall (m :: Type -> Type) b.
Monad m =>
MStream m [b] -> MStream m b
concatS forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr forall a. Maybe a -> [a]
maybeToList)