Select.hs

{-# 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

-- base
import Control.Arrow
import Data.Maybe (maybeToList)

-- automaton
import Data.Automaton (Automaton, concatS)

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

{- | 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
  { 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'.
  , select :: Tag cl -> Maybe a
  }

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

instance (Monoid cl, Semigroup a) => Monoid (SelectClock cl a) where
  mempty =
    SelectClock
      { mainClock = mempty
      , select = const 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 {..} = do
    (runningClock, initialTime) <- initClock mainClock
    let
      runningSelectClock = filterS $ proc _ -> do
        (time, tag) <- runningClock -< ()
        returnA -< (time,) <$> select tag
    return (runningSelectClock, initialTime)

instance GetClockProxy (SelectClock cl a)

{- | Helper function that runs an 'Automaton' with 'Maybe' output
   until it returns a value.
-}
filterS :: (Monad m) => Automaton m () (Maybe b) -> Automaton m () b
filterS = concatS . (>>> arr maybeToList)