A lot of internals as I tried to do a switch based logic

src/AFRP.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Arrows #-}
 
 module AFRP
   ( Mealy(..)
   , eff
+  , withEntities
   , Event(..)
   , hold
   , events
@@ -20,6 +22,7 @@ module AFRP
   , lMerge
   , Request(..)
   , edge
+  , dropFirst
   , duration
   , tag
   , isEvent
@@ -29,12 +32,14 @@ module AFRP
   , sliding
   , fixed
   , debounce
+  , currentTime
+  , onEvent
   ) where
 
 import Control.Category (Category(..), (>>>))
 import Prelude hiding ((.), id)
 import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..))
-import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)
+import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime)
 import Control.Monad.Fix (MonadFix (mfix))
 import Data.Either (fromLeft)
 import Data.Bool (bool)
@@ -45,6 +50,7 @@ import qualified Data.Text as T
 
 data Request = Request
   { requestTime :: !UTCTime
+  , requestTimeZone :: !TimeZone
   , requestTraceId :: !UUID
   } deriving Show
 
@@ -56,10 +62,27 @@ data Mealy eff a b = Mealy
   , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b)
   }
 
+
+instance Semigroup b => Semigroup (Mealy eff a b) where
+  Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt r a -> do
+    (x, af') <- af nt r a
+    (x', bf') <- bf nt r a
+    pure (x <> x', af' <> bf')
+
+
+instance Monoid b => Monoid (Mealy eff a b) where
+  mempty = Mealy mempty $ \_ _ _ -> pure (mempty, mempty)
+
 eff :: (Request -> a -> eff b) -> Mealy eff a b
 eff f = Mealy mempty $ \nt req x ->
   nt (f req x) >>= \b -> pure (b, eff f)
 
+-- | Override the static entity set of an arrow. Use when a combinator
+-- (e.g. 'switch') hides continuation entities from the runtime's
+-- startup subscription scan.
+withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b
+withEntities es (Mealy _ f) = Mealy es f
+
 instance Category (Mealy eff) where
   id = Mealy mempty (\_ _ x -> pure (x, id))
   (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do
@@ -102,6 +125,12 @@ data Event a
   | Event a
   deriving (Show, Eq, Functor, Foldable, Traversable)
 
+instance Semigroup (Event a) where
+  (<>) = lMerge
+
+instance Monoid (Event a) where
+  mempty = Tick
+
 hold :: a -> Mealy eff (Event a) a
 hold a = Mealy mempty $ \_ _ -> \case
   Tick -> pure (a, hold a)
@@ -243,6 +272,18 @@ edge = go False
       False -> pure (Tick, go False)
 
 
+-- | Drop the first 'Event' and pass through everything after. Useful for
+-- ignoring a self-triggered event (e.g. a service call that changes the
+-- very entity the arrow listens to).
+dropFirst :: Mealy eff (Event a) (Event a)
+dropFirst = go False
+  where
+    go seen = Mealy mempty $ \_ _ input ->
+      case input of
+        Event _ | not seen -> pure (Tick, go True)
+        _ -> pure (input, go seen)
+
+
 duration :: forall eff a. Mealy eff a NominalDiffTime
 duration = mapAccumRequest go (Nothing @(UTCTime, NominalDiffTime)) (maybe 0 snd)
   where
@@ -295,3 +336,12 @@ fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
                 | otherwise -> Just (end, acc)
            Event a | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, e a)
                    | otherwise -> Just (end, acc <> e a)
+
+
+currentTime :: Mealy eff a LocalTime
+currentTime = Mealy mempty $ \_ Request{requestTime, requestTimeZone} _ ->
+  pure (utcToLocalTime requestTimeZone requestTime, currentTime)
+
+
+onEvent :: Mealy eff a () -> Mealy eff (Event a) ()
+onEvent f = events >>> (arr (const ()) ||| f)