diff --git a/Quickref.md b/Quickref.md new file mode 100644 --- /dev/null +++ b/Quickref.md @@ -0,0 +1,311 @@ +# Reflex Quick(ish) Reference + +## Typeclasses + +Many Reflex functions operate in monadic context `m a`, where the monad 'm' supports various additional typeclasses such as MonadWidget, MonadHold, or MonadSample in addition to Monad itself. The actual 'm' in use will be determined by the top-level entry point of the FRP host (such as Reflex-Dom -- see the bottom of the Reflex-Dom quick reference for details). + +The function signatures here have been simplified by removing many typeclass constraints and adding simple annotations to each function. Also the ubiquitous 't' type parameter has been removed. + +Some of these functions are *pure*: They operate on Events, Behaviors, or Dynamics uniformly without regard to the "current time". Other functions must operate in some monadic context, because they produce a result "as of now" (e.g., any function that takes an "initial" value, or returns a "current" value). Annotations are used to distinguish these cases: + +```haskell +[ ] -- Pure function +[S] -- Function runs in any monad supporting MonadSample +[H] -- Function runs in any monad supporting MonadHold +``` +Since MonadHold depends on MonadSample, any [S] function also runs in [H] context. + +## Functions producing Event + +```haskell +-- Trivial Event +[ ] never :: Event a + +-- Extract Event from Dynamic +[ ] updated :: Dynamic a -> Event a + +-- Transform Event to Event using function +[ ] fmap :: (a -> b) -> Event a -> Event b +[ ] fmapMaybe :: (a -> Maybe b) -> Event a -> Event b +[ ] ffilter :: (a -> Bool) -> Event a -> Event a +[ ] ffor :: Event a -> (a -> b) -> Event b +[ ] fforMaybe :: Event a -> (a -> Maybe b) -> Event b +[ ] <$ :: a -> Event b -> Event a + +-- Event to identical Event with debug trace. (Only prints if Event is ultimately used.) +[ ] traceEvent :: Show a => String -> Event a -> Event a +[ ] traceEventWith :: (a -> String) -> Event a -> Event a + +-- Transform Event to Event by sampling Behavior or Dynamic +[ ] gate :: Behavior Bool -> Event a -> Event a +[ ] tag :: Behavior a -> Event b -> Event a +[ ] tagPromptlyDyn :: Dynamic a -> Event b -> Event a +[ ] attach :: Behavior a -> Event b -> Event (a, b) +[ ] attachPromptlyDyn :: Dynamic a -> Event b -> Event (a, b) +[ ] attachWith :: (a -> b -> c) -> Behavior a -> Event b -> Event c +[ ] attachPromptlyDynWith :: (a -> b -> c) -> Dynamic a -> Event b -> Event c +[ ] attachWithMaybe :: (a -> b -> Maybe c) -> Behavior a -> Event b -> Event c +[ ] attachPromptlyDynWithMaybe :: (a -> b -> Maybe c) -> Dynamic a -> Event b -> Event c +[ ] <@> :: Behavior (a -> b) -> Event a -> Event b +[ ] <@ :: Behavior a -> Event b -> Event a + +-- Combine multiple Events +[ ] <> :: Semigroup a => Event a -> Event a -> Event a +[ ] difference :: Event a -> Event b -> Event a +[ ] align :: Event a -> Event b -> Event (These a b) +[ ] alignWith :: (These a b -> c) -> Event a -> Event b -> Event c +[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a +[ ] leftmost :: [Event a] -> Event a +[ ] mergeList :: [Event a] -> Event (NonEmpty a) +[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k) +[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a) + +-- Efficient one-to-many fanout +[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a) +[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k +[ ] select :: EventSelector k -> k a -> Event a +[ ] fanEither :: Event (Either a b) -> (Event a, Event b) +[ ] fanThese :: Event (These a b) -> (Event a, Event b) + +-- Event to Event via function that can sample current values +[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b +[ ] pushAlways :: (a -> m b ) -> Event a -> Event b + -- Note supplied function operates in [H] context + +-- Split Event into next occurrence and all other future occurrences, as of now. +[H] headE :: Event a -> m (Event a) +[H] tailE :: Event a -> m (Event a) +[H] headTailE :: Event a -> m (Event a, Event a) +``` + +## Functions producing Behavior + +```haskell +-- Trivial Behavior +[ ] constant :: a -> Behavior a + +-- Extract Behavior from Dynamic +[ ] current :: Dynamic a -> Behavior a + +-- Create Behavior with given initial value, updated when the Event fires. +[H] hold :: a -> Event a -> m (Behavior a) + +-- Transform Behavior to Behavior using function +[ ] fmap :: (a -> b) -> Behavior a -> Behavior b +[ ] ffor :: Behavior a -> (a -> b) -> Behavior b +[ ] <*> :: Behavior (a -> b) -> Behavior a -> Behavior b +[ ] >>= :: Behavior a -> (a -> Behavior b) -> Behavior b +[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a +-- ... plus many more due to typeclass membership + +-- Combine multiple behaviors via applicative instance +[ ] ffor2 :: Behavior a -> Behavior b -> (a -> b -> c) -> Behavior c +[ ] ffor3 :: Behavior a -> Behavior b -> Behavior c -> (a -> b -> c -> d) -> Behavior d + +-- Behavior to Behavior by sampling current values +[S] sample :: Behavior a -> m a +[ ] pull :: m a -> Behavior a + -- Note supplied value is in [S] context +``` + +## Functions producing Dynamic + +```haskell +-- Trivial Dynamic +[ ] constDyn :: a -> Dynamic a + +-- Create Dynamic with given initial value, updated (various ways) when the Event fires. +[H] holdDyn :: a -> Event a -> m (Dynamic a) +[H] foldDyn :: (a -> b -> b ) -> b -> Event a -> m (Dynamic b) +[H] foldDynMaybe :: (a -> b -> Maybe b ) -> b -> Event a -> m (Dynamic b) +[H] foldDynM :: (a -> b -> m' b ) -> b -> Event a -> m (Dynamic b) +[H] foldDynMaybeM :: (a -> b -> m' (Maybe b)) -> b -> Event a -> m (Dynamic b) + -- Note m' supplies [H] context + +-- Initial value is 0; counts Event firings from now. +[H] count :: Num b => Event a -> m (Dynamic b) +-- Initial Bool value is supplied; toggles at each Event firing. +[H] toggle :: Bool -> Event a -> m (Dynamic Bool) + +-- Transform Dynamic to Dynamic using function +[ ] ffor :: Dynamic a -> (a -> b) -> Dynamic b +[ ] fmap :: (a -> b) -> Dynamic a -> Dynamic b +[ ] splitDynPure :: Dynamic (a, b) -> (Dynamic a, Dynamic b) + +-- Combine multiple Dynamics +[ ] mconcat :: Monoid a => [Dynamic a] -> Dynamic a +[ ] distributeDMapOverDynPure :: GCompare k => DMap (WrapArg Dynamic k) -> Dynamic (DMap k) +[ ] <*> :: Dynamic (a -> b) -> Dynamic a -> Dynamic b +[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b +[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c + +-- Combine multiple dynamics via applicative instance +[ ] ffor2 :: Dynamic a -> Dynamic b -> (a -> b -> c) -> Dynamic c +[ ] ffor3 :: Dynamic a -> Dynamic b -> Dynamic c -> (a -> b -> c -> d) -> Dynamic d + +-- Efficient one-to-many fanout +[ ] demux :: Ord k => Dynamic k -> Demux k +[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool + +-- Dynamic to Dynamic, removing updates w/o value change +[H] holdUniqDyn :: Eq a => Dynamic a -> m (Dynamic a) +[H] holdUniqDynBy :: (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a) + +-- Dynamic to identical Dynamic with debug trace. (Only prints if Dynamic is ultimately used.) +[ ] traceDyn :: Show a => String -> Dynamic a -> Dynamic a +[ ] traceDynWith :: (a -> String) -> Dynamic a -> Dynamic a +``` + +## Flattening functions + +These functions flatten nested types such as Event-of-Event, Behavior-of-Event, Event-of-Behavior etc, removing the outer wrapper. + +For Events, the returned Event fires whenever the latest Event supplied by the wrapper fires. There are differences in how the functions handle *coincidences* -- situations where the old or new Event fires at the same instant that we switch from old to new. In some cases, the output Event tracks the old Event at the instant of switchover, while in other cases it tracks the new Event. + +```haskell +-- Flatten Behavior-of-Event to Event. Old Event is used during switchover. +[ ] switch :: Behavior (Event a) -> Event a + +-- Flatten Dyanmic-of-Event to Event. New Event is used immediately. +[ ] switchDyn :: Dynamic (Event a) -> Event a + +-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire. +[ ] coincidence :: Event (Event a) -> Event a + +-- Flatten Behavior-of-Behavior to Behavior. Behavior is an instance of Monad, +-- so the 'join' function from 'Control.Monad' suffices. The output of 'join' is +-- a Behavior whose value is equal to the current value of the current value of +-- the input. +[ ] join :: Behavior (Behavior a) -> Behavior a + + +-- Flatten Dynamic-of-Dynamic to Dynamic. New Dynamic is used immediately. +-- Output updated whenever inner OR outer Dynamic updates. +[ ] join :: Dynamic (Dynamic a) -> Dynamic a +[ ] joinDynThroughMap :: Ord k => Dynamic (Map k (Dynamic a)) -> Dynamic (Map k a) + +-- Analogous to 'hold': Create a Behavior that is initially identical to the +-- supplied Behavior. Updated to track a new Behavior whenever the Event fires. +[H] switcher :: Behavior a -> Event (Behavior a) -> m (Behavior a) + +-- Similar to above, for Events. Created Event initially tracks the first argument. +-- At switchover, the output Event immediately tracks the new Event. +[H] switchHold :: Event a -> Event (Event a) -> m (Event a) +``` + +## Typeclasses to introspect and modify an FRP network. + +The functions mentioned above are used to create a static FRP network. +There are additional typeclasses that can be used to modify the FRP network, to have it interact with IO action, or to introspect the building of the network. + +Th typeclasses and their associated annotations include: + +- `PostBuild` + Fire an Event when an FRP network has been set up. + ```haskell + [B] -- Function runs in any monad supporting PostBuild + ``` + +- `Adjustable` + Use Events to add or remove pieces of an FRP network. + ```haskell + [A] -- Function runs in any monad supporting Adjustable + ``` + +- `TriggerEvent` + Create new externally-fired Events from within an FRP network. + ```haskell + [T] -- Function runs in any monad supporting TriggerEvent + ``` + +- `PerformEvent` + Use Events to trigger IO actions and to collect their results. + ```haskell + [P] -- Function runs in any monad supporting PerformEvent + ``` + +## Startup + +```haskell +-- One-shot Event that is triggered once the FRP network has been built +[B] getPostBuild :: m (Event ()) +``` + +## Collection management functions + +```haskell +-- Turn a Dynamic key/value map into a set of dynamically-changing widgets. +[H,A,B] listWithKey :: Ord k => + Dynamic (Map k v) -> (k -> Dynamic v -> m a ) -> m (Dynamic (Map k a)) + +-- Same as above where the widget constructor doesn't care about the key. +[H,A,B] list :: Ord k => + Dynamic (Map k v) -> ( Dynamic v -> m a ) -> m (Dynamic (Map k a)) + +-- Even simpler version where there are no keys and we just use a list. +[H,A,B] simpleList :: + Dynamic [v] -> ( Dynamic v -> m a ) -> m (Dynamic [a]) + +-- Like listWithKey specialized for widgets returning (Event a). +[H,A,B] listViewWithKey :: Ord k => + Dynamic (Map k v) -> (k -> Dynamic v -> m (Event a)) -> m (Event (Map k a)) + +-- Create a dynamically-changing set of widgets, one of which is selected at any time. +[H,A,B] selectViewListWithKey_ :: Ord k => Dynamic k -> + Dynamic (Map k v) -> (k -> Dynamic v -> Dynamic Bool -> m (Event a)) -> m (Event k) + +-- Same as listWithKey, but takes initial values and an updates Event instead of a Dynamic. +[H,A] listWithKeyShallowDiff :: Ord k => + Map k v -> Event (Map k (Maybe v)) -> (k -> v -> Event v -> m a) -> m (Dynamic (Map k a)) +``` + +## Creating new events from within an FRP network. + +```haskell +-- Create a new Event and a function that will cause the Event to fire, from within an FRP network +[T] newTriggerEvent :: m (Event a, a -> IO ()) +``` + +## Connecting to the real world (I/O) + +```haskell +-- Run side-effecting actions in Event when it occurs; returned Event contains +-- results. Side effects run in the (Performable m) monad which is associated with +-- the (PerformEvent t m) typeclass constraint. +-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available. +[P] performEvent :: Event (Performable m a ) -> m (Event a) + +-- Just run side-effects; no return Event +[P] performEvent_ :: Event (Performable m ()) -> m () + +-- Actions run asynchronously; actions are given a callback to send return values +[P,T] performEventAsync :: Event ((a -> IO ()) -> Performable m ()) -> m (Event a) +``` + +### Time + +```haskell +-- Create Event at given interval with given basis time. +[P,T] tickLossy :: NominalDiffTime -> UTCTime -> m (Event t TickInfo) + +-- Delay an Event's occurrences by a given amount in seconds. +[P,T] delay :: NominalDiffTime -> Event t a -> m (Event t a) +``` + +## Networks + +```haskell +-- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a) + +-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates. +-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event, +-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold). +[P,A] networkView :: Dynamic (m a) -> m (Event a) + +-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the +-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an +-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened. +[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a) + +-- Render a placeholder network to be shown while another network is not yet done building +[P,A] untilReady :: m a -> m b -> m (a, Event b) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +## Reflex +### Practical Functional Reactive Programming + +Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface. + +[Reflex-DOM](https://github.com/reflex-frp/reflex-dom) is a framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps. + +Comprehensive documentation is still a work in progress, but a tutorial for Reflex and Reflex-DOM is available at https://github.com/reflex-frp/reflex-platform and an introductory talk given at the New York Haskell Meetup is available here: [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c). + +A summary of Reflex functions is available in the [quick reference](Quickref.md). + +### Additional resources +[Get started with Reflex](https://github.com/reflex-frp/reflex-platform) + +[/r/reflexfrp](https://www.reddit.com/r/reflexfrp) + +[hackage](https://hackage.haskell.org/package/reflex) + +[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4) diff --git a/bench-cbits/checkCapability.c b/bench-cbits/checkCapability.c new file mode 100644 --- /dev/null +++ b/bench-cbits/checkCapability.c @@ -0,0 +1,208 @@ +#include + +// The InCall structure represents either a single in-call from C to +// Haskell, or a worker thread. +typedef struct InCall_ { + StgTSO * tso; // the bound TSO (or NULL for a worker) + + StgTSO * suspended_tso; // the TSO is stashed here when we + // make a foreign call (NULL otherwise); + + Capability *suspended_cap; // The capability that the + // suspended_tso is on, because + // we can't read this from the TSO + // without owning a Capability in the + // first place. + + SchedulerStatus rstat; // return status + StgClosure ** ret; // return value + + struct Task_ *task; + + // When a Haskell thread makes a foreign call that re-enters + // Haskell, we end up with another Task associated with the + // current thread. We have to remember the whole stack of InCalls + // associated with the current Task so that we can correctly + // save & restore the InCall on entry to and exit from Haskell. + struct InCall_ *prev_stack; + + // Links InCalls onto suspended_ccalls, spare_incalls + struct InCall_ *prev; + struct InCall_ *next; +} InCall; + +typedef struct Task_ { +#if defined(THREADED_RTS) + OSThreadId id; // The OS Thread ID of this task + + Condition cond; // used for sleeping & waking up this task + Mutex lock; // lock for the condition variable + + // this flag tells the task whether it should wait on task->cond + // or just continue immediately. It's a workaround for the fact + // that signalling a condition variable doesn't do anything if the + // thread is already running, but we want it to be sticky. + HsBool wakeup; +#endif + + // This points to the Capability that the Task "belongs" to. If + // the Task owns a Capability, then task->cap points to it. If + // the task does not own a Capability, then either (a) if the task + // is a worker, then task->cap points to the Capability it belongs + // to, or (b) it is returning from a foreign call, then task->cap + // points to the Capability with the returning_worker queue that this + // this Task is on. + // + // When a task goes to sleep, it may be migrated to a different + // Capability. Hence, we always check task->cap on wakeup. To + // syncrhonise between the migrater and the migratee, task->lock + // must be held when modifying task->cap. + struct Capability_ *cap; + + // The current top-of-stack InCall + struct InCall_ *incall; + + uint32_t n_spare_incalls; + struct InCall_ *spare_incalls; + + HsBool worker; // == rtsTrue if this is a worker Task + HsBool stopped; // this task has stopped or exited Haskell + + // So that we can detect when a finalizer illegally calls back into Haskell + HsBool running_finalizers; + + // Links tasks on the returning_tasks queue of a Capability, and + // on spare_workers. + struct Task_ *next; + + // Links tasks on the all_tasks list; need ACQUIRE_LOCK(&all_tasks_mutex) + struct Task_ *all_next; + struct Task_ *all_prev; + +} Task; + +struct Capability_ { + // State required by the STG virtual machine when running Haskell + // code. During STG execution, the BaseReg register always points + // to the StgRegTable of the current Capability (&cap->r). + StgFunTable f; + StgRegTable r; + + uint32_t no; // capability number. + + // The Task currently holding this Capability. This task has + // exclusive access to the contents of this Capability (apart from + // returning_tasks_hd/returning_tasks_tl). + // Locks required: cap->lock. + Task *running_task; + + // true if this Capability is running Haskell code, used for + // catching unsafe call-ins. + HsBool in_haskell; + + // Has there been any activity on this Capability since the last GC? + uint32_t idle; + + HsBool disabled; + + // The run queue. The Task owning this Capability has exclusive + // access to its run queue, so can wake up threads without + // taking a lock, and the common path through the scheduler is + // also lock-free. + StgTSO *run_queue_hd; + StgTSO *run_queue_tl; + + // Tasks currently making safe foreign calls. Doubly-linked. + // When returning, a task first acquires the Capability before + // removing itself from this list, so that the GC can find all + // the suspended TSOs easily. Hence, when migrating a Task from + // the returning_tasks list, we must also migrate its entry from + // this list. + InCall *suspended_ccalls; + + // One mutable list per generation, so we don't need to take any + // locks when updating an old-generation thunk. This also lets us + // keep track of which closures this CPU has been mutating, so we + // can traverse them using the right thread during GC and avoid + // unnecessarily moving the data from one cache to another. + bdescr **mut_lists; + bdescr **saved_mut_lists; // tmp use during GC + + // block for allocating pinned objects into + bdescr *pinned_object_block; + // full pinned object blocks allocated since the last GC + bdescr *pinned_object_blocks; + + // per-capability weak pointer list associated with nursery (older + // lists stored in generation object) + StgWeak *weak_ptr_list_hd; + StgWeak *weak_ptr_list_tl; + + // Context switch flag. When non-zero, this means: stop running + // Haskell code, and switch threads. + int context_switch; + + // Interrupt flag. Like the context_switch flag, this also + // indicates that we should stop running Haskell code, but we do + // *not* switch threads. This is used to stop a Capability in + // order to do GC, for example. + // + // The interrupt flag is always reset before we start running + // Haskell code, unlike the context_switch flag which is only + // reset after we have executed the context switch. + int interrupt; + + // Total words allocated by this cap since rts start + // See [Note allocation accounting] in Storage.c + W_ total_allocated; + +#if defined(THREADED_RTS) + // Worker Tasks waiting in the wings. Singly-linked. + Task *spare_workers; + uint32_t n_spare_workers; // count of above + + // This lock protects: + // running_task + // returning_tasks_{hd,tl} + // wakeup_queue + // inbox + Mutex lock; + + // Tasks waiting to return from a foreign call, or waiting to make + // a new call-in using this Capability (NULL if empty). + // NB. this field needs to be modified by tasks other than the + // running_task, so it requires cap->lock to modify. A task can + // check whether it is NULL without taking the lock, however. + Task *returning_tasks_hd; // Singly-linked, with head/tail + Task *returning_tasks_tl; + + // Messages, or END_TSO_QUEUE. + // Locks required: cap->lock + Message *inbox; + + SparkPool *sparks; + + // Stats on spark creation/conversion + SparkCounters spark_stats; +#if !defined(mingw32_HOST_OS) + // IO manager for this cap + int io_manager_control_wr_fd; +#endif +#endif + + // Per-capability STM-related data + StgTVarWatchQueue *free_tvar_watch_queues; + StgTRecChunk *free_trec_chunks; + StgTRecHeader *free_trec_headers; + uint32_t transaction_tokens; +} // typedef Capability is defined in RtsAPI.h + // We never want a Capability to overlap a cache line with anything + // else, so round it up to a cache line size: +#ifndef mingw32_HOST_OS + ATTRIBUTE_ALIGNED(64) +#endif + ; + +HsBool myCapabilityHasOtherRunnableThreads() { + return rts_unsafeGetMyCapability()->run_queue_hd == END_TSO_QUEUE ? HS_BOOL_FALSE : HS_BOOL_TRUE; +} diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,31 +1,29 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} + +-- The instance for NFData (TVar a) is an orphan, but necessary here +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Main where -import Data.Functor.Misc -import Control.Monad.Primitive -import Control.Monad.IO.Class -import Control.Monad.Identity -import Data.Dependent.Sum import Control.Concurrent.STM -import Control.Applicative -import System.IO.Unsafe -import Data.IORef import Control.DeepSeq import Control.Exception (evaluate) -import Control.Monad +import Control.Monad.Identity +import Control.Monad.IO.Class +import Criterion.Main +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.Functor.Misc +import Data.IORef +import Data.Maybe (fromJust) import Reflex import Reflex.Host.Class -import System.Mem -import System.IO -import Criterion.Main -import qualified Data.Dependent.Map as DM - - main :: IO () main = defaultMain [ bgroup "micro" micros ] @@ -42,15 +40,14 @@ instance NFData (WHNF a) where rnf (WHNF a) = seq a () -withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark +withSetup :: NFData b => String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) -> bench name . nfIO $ runSpiderHost (action a) -withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark +withSetupWHNF :: String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) -> bench name . whnfIO $ runSpiderHost (action a) - micros :: [Benchmark] micros = [ bench "newIORef" $ whnfIO $ void $ newIORef () @@ -73,40 +70,41 @@ (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd) , withSetupWHNF "fireEventsOnly" (newEventWithTriggerRef >>= subscribePair) - (\(subd, trigger) -> do - Just key <- liftIO $ readIORef trigger + (\(_, trigger) -> do + key <- fromJust <$> liftIO (readIORef trigger) fireEvents [key :=> Identity (42 :: Int)]) , withSetupWHNF "fireEventsAndRead(head/merge1)" (setupMerge 1 >>= subscribePair) - (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd) + (\(subd, t:_) -> fireAndRead t (42 :: Int) subd) , withSetupWHNF "fireEventsAndRead(head/merge100)" (setupMerge 100 >>= subscribePair) - (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd) + (\(subd, t:_) -> fireAndRead t (42 :: Int) subd) , withSetupWHNF "fireEventsAndRead(head/merge10000)" (setupMerge 10000 >>= subscribePair) - (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd) + (\(subd, t:_) -> fireAndRead t (42 :: Int) subd) , withSetupWHNF "fireEventsOnly(head/merge100)" (setupMerge 100 >>= subscribePair) - (\(subd, t:riggers) -> do - Just key <- liftIO $ readIORef t + (\(_, t:_) -> do + key <- fromJust <$> liftIO (readIORef t) fireEvents [key :=> Identity (42 :: Int)]) - , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev - , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample + , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev + , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample ] setupMerge :: Int - -> SpiderHost (Event Spider (DM.DMap (Const2 Int a) Identity), - [IORef (Maybe (EventTrigger Spider a))]) + -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity) + , [IORef (Maybe (EventTrigger Spider a))] + ) setupMerge num = do - (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef - let !m = DM.fromList [(Const2 i) :=> v | (i,v) <- zip [0..] evs] + (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef + let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs] pure (merge m, triggers) -subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b) +subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b) subscribePair (ev, b) = (,b) <$> subscribeEvent ev -fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b - -> SpiderHost (Maybe b) +fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b + -> SpiderHost Global (Maybe b) fireAndRead trigger val subd = do - Just key <- liftIO $ readIORef trigger + key <- fromJust <$> liftIO (readIORef trigger) fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence diff --git a/bench/RunAll.hs b/bench/RunAll.hs --- a/bench/RunAll.hs +++ b/bench/RunAll.hs @@ -1,4 +1,18 @@ -{-# LANGUAGE ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where @@ -9,78 +23,135 @@ import Reflex import Reflex.Host.Class -import Reflex.TestPlan import Reflex.Plan.Reflex +import Reflex.TestPlan -import Reflex.Spider.Internal (SpiderEventHandle) import qualified Reflex.Bench.Focused as Focused +import Reflex.Spider.Internal (SpiderEventHandle) import Control.Applicative import Control.DeepSeq (NFData (..)) +import Prelude import System.IO import System.Mem -import Prelude +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Data.Bool +import Data.Function +import Data.Int +import Data.IORef +import Data.Monoid +import Data.Time.Clock +import Debug.Trace.LocationTH +import GHC.Stats +import System.Environment +import System.Mem.Weak +import System.Process +import Text.Read + +import Unsafe.Coerce + +import Data.Map (Map) +import qualified Data.Map as Map + type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t)) -setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (Ignore (EventHandle t a), Schedule t) +setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (EventHandle t a, Schedule t) setupFiring p = do (e, s) <- runPlan p h <- subscribeEvent e - return (Ignore h, s) + return (h, s) -- Hack to avoid the NFData constraint for EventHandle which is a synonym newtype Ignore a = Ignore a instance NFData (Ignore a) where rnf !_ = () -instance NFData (SpiderEventHandle a) where +instance NFData (SpiderEventHandle x a) where rnf !_ = () instance NFData (Behavior t a) where rnf !_ = () instance NFData (Firing t) where - rnf !(Firing _ _) = () + rnf !_ = () -- Measure the running time -benchFiring :: (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> (String, TestCase) -> Benchmark -benchFiring runHost (name, TestE p) = env setup (\e -> bench name $ whnfIO $ run e) where - run (Ignore h, s) = runHost (readSchedule s (readEvent' h)) >> performGC - setup = runHost $ setupFiring p - -benchFiring runHost (name, TestB p) = env setup (\e -> bench name $ whnfIO $ run e) where - run (b, s) = runHost (readSchedule s (sample b)) >> performGC - setup = runHost $ do +benchFiring :: forall t m. (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> TestCase -> Int -> IO () +benchFiring runHost tc n = runHost $ do + let runIterations :: m a -> m () + runIterations test = replicateM_ (10*n) $ do + result <- test + liftIO $ evaluate result + case tc of + TestE p -> do + (h, s) <- setupFiring p + runIterations $ readSchedule_ s $ readEvent' h + TestB p -> do (b, s) <- runPlan p - return (b, makeDense s) + runIterations $ readSchedule_ (makeDense s) $ sample b -main :: IO () -main = do - hSetBuffering stdout LineBuffering - defaultMainWith (defaultConfig { timeLimit = 10, csvFile = Just "dmap-original.csv" }) - [ benchImpl "spider" runSpiderHost - ] +waitForFinalizers :: IO () +waitForFinalizers = do + performGC + x <- getCurrentTime + isFinalized <- newIORef False + mkWeakPtr x $ Just $ writeIORef isFinalized True + performGC + fix $ \loop -> do + f <- readIORef isFinalized + unless f $ do + threadDelay 1 + loop -benchImpl :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> Benchmark -benchImpl name runHost = bgroup name [ sub 100 40 - , dynamics 100 - , dynamics 1000 - , firing 1000 - , firing 10000 - , merging 10 - , merging 50 - , merging 100 - , merging 200] +benchmarks :: [(String, Int -> IO ())] +benchmarks = implGroup "spider" runSpiderHost cases where - sub n frames = runGroup ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames - firing n = runGroup ("firing " ++ show n) $ Focused.firing n - merging n = runGroup ("merging " ++ show n) $ Focused.merging n - dynamics n = runGroup ("dynamics " ++ show n) $ Focused.dynamics n + implGroup :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> [(String, TestCase)] -> [(String, Int -> IO ())] + implGroup name runHost = group name . fmap (second (benchFiring runHost)) + group name = fmap $ first ((name <> "/") <>) + sub n frames = group ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames + firing n = group ("firing " <> show n) $ Focused.firing n + merging n = group ("merging " <> show n) $ Focused.merging n + dynamics n = group ("dynamics " <> show n) $ Focused.dynamics n + cases = concat + [ sub 100 40 + , dynamics 100 + , dynamics 1000 + , firing 1000 + , firing 10000 + , merging 10 + , merging 50 + , merging 100 + , merging 200 + ] - runGroup name' benchmarks = bgroup name' (benchFiring runHost <$> benchmarks) +pattern RunTestCaseFlag = "--run-test-case" +spawnBenchmark :: String -> Benchmark +spawnBenchmark name = bench name . toBenchmarkable $ \n -> do + self <- getExecutablePath + callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"] +foreign import ccall unsafe "myCapabilityHasOtherRunnableThreads" myCapabilityHasOtherRunnableThreads :: IO Bool +main :: IO () +main = do + args <- getArgs + case args of + RunTestCaseFlag : t -> case t of + [name, readMaybe -> Just count] -> do + case lookup name benchmarks of + Just testCase -> testCase count + performGC + fix $ \loop -> bool (return ()) (yield >> loop) =<< myCapabilityHasOtherRunnableThreads + return () + _ -> $failure "--run-test-case: expected test name and iteration count to follow" + _ -> defaultMainWith (defaultConfig { timeLimit = 20, csvFile = Just "dmap-original.csv", reportFile = Just "report.html" }) $ fmap (spawnBenchmark . fst) benchmarks diff --git a/reflex.cabal b/reflex.cabal --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.4.0.1 +Version: 0.5 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 @@ -10,94 +10,354 @@ Category: FRP Build-type: Simple Cabal-version: >=1.9.2 -homepage: https://github.com/reflex-frp/reflex +homepage: https://reflex-frp.org bug-reports: https://github.com/reflex-frp/reflex/issues +extra-source-files: + README.md + Quickref.md +flag use-reflex-optimizer + description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental. + default: False + manual: True + +flag use-template-haskell + description: Use template haskell to generate lenses + default: True + manual: True + +flag debug-trace-events + description: Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow! + default: False + manual: True + +flag fast-weak + description: Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default + default: False + manual: True + library hs-source-dirs: src build-depends: - base >= 4.7 && < 4.10, - dependent-sum >= 0.3 && < 0.5, - dependent-map == 0.2.*, - semigroups >= 0.16 && < 0.19, + MemoTrie == 0.6.*, + base >= 4.9 && < 4.13, + bifunctors >= 5.2 && < 5.6, + comonad, + containers >= 0.5 && < 0.7, + data-default >= 0.5 && < 0.8, + dependent-map >= 0.2.4 && < 0.3, + exception-transformers == 0.4.*, + lens >= 4.7 && < 5, + monad-control >= 1.0.1 && < 1.1, + monoidal-containers == 0.4.*, mtl >= 2.1 && < 2.3, - containers == 0.5.*, - these >= 0.4 && < 0.8, + prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7, - template-haskell >= 2.9 && < 2.13, + random == 1.1.*, ref-tf == 0.4.*, - exception-transformers == 0.4.*, + reflection == 2.1.*, + semigroupoids >= 4.0 && < 6, + semigroups >= 0.16 && < 0.19, + stm >= 2.4 && < 2.6, + syb >= 0.5 && < 0.8, + these >= 0.4 && < 0.8, + time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3, - haskell-src-exts >= 1.16 && < 1.20, - haskell-src-meta >= 0.6 && < 0.9, - syb >= 0.4.4 && < 0.8 + unbounded-delays >= 0.1.0.0 && < 0.2 exposed-modules: + Data.AppendMap, + Data.FastMutableIntMap, + Data.FastWeakBag, + Data.Functor.Misc, + Data.Map.Misc, + Data.WeakBag, Reflex, - Reflex.Spider, - Reflex.Spider.Internal, Reflex.Class, + Reflex.Adjustable.Class, + Reflex.BehaviorWriter.Base, + Reflex.BehaviorWriter.Class, + Reflex.Collection, Reflex.Dynamic, - Reflex.Dynamic.TH, + Reflex.Dynamic.Uniq, + Reflex.DynamicWriter, + Reflex.DynamicWriter.Base, + Reflex.DynamicWriter.Class, + Reflex.EventWriter, + Reflex.EventWriter.Base, + Reflex.EventWriter.Class, + Reflex.FastWeak, + Reflex.FunctorMaybe, Reflex.Host.Class, - Data.Functor.Misc + Reflex.Network, + Reflex.NotReady.Class, + Reflex.Patch, + Reflex.Patch.Class, + Reflex.Patch.DMap, + Reflex.Patch.DMapWithMove, + Reflex.Patch.IntMap, + Reflex.Patch.Map, + Reflex.Patch.MapWithMove, + Reflex.PerformEvent.Base, + Reflex.PerformEvent.Class, + Reflex.PostBuild.Base, + Reflex.PostBuild.Class, + Reflex.Profiled, + Reflex.Pure, + Reflex.Query.Base, + Reflex.Query.Class, + Reflex.Requester.Base, + Reflex.Requester.Class, + Reflex.Spider, + Reflex.Spider.Internal, + Reflex.Time, + Reflex.TriggerEvent.Base, + Reflex.TriggerEvent.Class, + Reflex.Widget.Basic, + Reflex.Workflow - other-extensions: TemplateHaskell - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -test-suite cross-impl + if flag(debug-trace-events) + cpp-options: -DDEBUG_TRACE_EVENTS + build-depends: bytestring + + if flag(use-reflex-optimizer) + cpp-options: -DUSE_REFLEX_OPTIMIZER + build-depends: ghc + exposed-modules: Reflex.Optimizer + + if flag(use-template-haskell) + cpp-options: -DUSE_TEMPLATE_HASKELL + build-depends: + dependent-sum >= 0.3 && < 0.5, + haskell-src-exts >= 1.16 && < 1.21, + haskell-src-meta >= 0.6 && < 0.9, + template-haskell >= 2.9 && < 2.15 + exposed-modules: + Reflex.Dynamic.TH + other-extensions: TemplateHaskell + else + build-depends: + dependent-sum == 0.4.* + + if flag(fast-weak) && impl(ghcjs) + cpp-options: -DGHCJS_FAST_WEAK + + if impl(ghcjs) + build-depends: ghcjs-base + +test-suite semantics type: exitcode-stdio-1.0 - main-is: Reflex/Test/CrossImpl.hs - other-modules: - Reflex.Pure - ghc-options: -O2 -main-is Reflex.Test.CrossImpl.test + main-is: semantics.hs hs-source-dirs: test + ghc-options: -O2 -Wall -rtsopts build-depends: base, - reflex, - ref-tf, + bifunctors, + containers, + deepseq >= 1.3 && < 1.5, + dependent-map, + dependent-sum, mtl, + ref-tf, + reflex, + split, + transformers >= 0.3 + other-modules: + Reflex.Bench.Focused + Reflex.Plan.Pure + Reflex.Plan.Reflex + Reflex.Test + Reflex.Test.Micro + Reflex.TestPlan + +test-suite CrossImpl + type: exitcode-stdio-1.0 + main-is: Reflex/Test/CrossImpl.hs + hs-source-dirs: test + ghc-options: -O2 -Wall -rtsopts + build-depends: + base, containers, dependent-map, - MemoTrie == 0.6.* + dependent-sum, + deepseq >= 1.3 && < 1.5, + mtl, + transformers, + ref-tf, + reflex + other-modules: + Reflex.Test + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Plan.Pure +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + hs-source-dirs: test + build-depends: base + , directory + , filepath + , filemanip + , hlint + if impl(ghcjs) + buildable: False + +test-suite EventWriterT + type: exitcode-stdio-1.0 + main-is: EventWriterT.hs + hs-source-dirs: test + build-depends: base + , containers + , deepseq >= 1.3 && < 1.5 + , dependent-map + , dependent-sum + , lens + , mtl + , these + , transformers + , reflex + , ref-tf + other-modules: + Reflex.Test + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Plan.Pure + Test.Run + +test-suite RequesterT + type: exitcode-stdio-1.0 + main-is: RequesterT.hs + hs-source-dirs: test + build-depends: base + , dependent-sum + , dependent-map + , lens + , these + , transformers + , reflex + , ref-tf + buildable: False + other-modules: + Reflex.TestPlan + Reflex.Plan.Pure + +test-suite QueryT + type: exitcode-stdio-1.0 + main-is: QueryT.hs + hs-source-dirs: test + build-depends: base + , containers + , dependent-map + , dependent-sum + , deepseq >= 1.3 && < 1.5 + , lens + , monoidal-containers + , mtl + , ref-tf + , reflex + , semigroups + , these + , transformers + other-modules: + Test.Run + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Plan.Pure + +test-suite GC-Semantics + type: exitcode-stdio-1.0 + main-is: GC.hs + hs-source-dirs: test + build-depends: base + , containers + , dependent-sum + , dependent-map + , deepseq >= 1.3 && < 1.5 + , mtl + , these + , transformers + , reflex + , ref-tf + if impl(ghc < 8) + build-depends: semigroups + other-modules: + Reflex.Plan.Pure + Reflex.Plan.Reflex + Reflex.TestPlan + Test.Run + +test-suite rootCleanup + type: exitcode-stdio-1.0 + main-is: rootCleanup.hs + hs-source-dirs: test + build-depends: base + , containers + , deepseq >= 1.3 && < 1.5 + , dependent-sum + , mtl + , reflex + , ref-tf + , these + other-modules: + Reflex.Plan.Pure + Reflex.TestPlan + Test.Run + benchmark spider-bench type: exitcode-stdio-1.0 - hs-source-dirs: bench + hs-source-dirs: bench test main-is: Main.hs - ghc-options: -O2 -rtsopts + ghc-options: -Wall -O2 -rtsopts build-depends: base, - dependent-sum, - dependent-map, - transformers >= 0.3 && < 0.6, - stm == 2.4.*, + containers, + criterion >= 1.1 && < 1.6, deepseq >= 1.3 && < 1.5, + dependent-map, + dependent-sum, + ref-tf, mtl, primitive, - criterion >= 1.1 && < 1.3, - reflex + reflex, + split, + stm, + transformers >= 0.3 + other-modules: + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Bench.Focused benchmark saulzar-bench type: exitcode-stdio-1.0 hs-source-dirs: bench test + c-sources: bench-cbits/checkCapability.c main-is: RunAll.hs - ghc-options: -O2 -rtsopts + ghc-options: -Wall -O2 -rtsopts -threaded build-depends: base, - containers == 0.5.*, - ref-tf == 0.4.*, - dependent-sum, - dependent-map, - transformers >= 0.3 && < 0.6, - stm == 2.4.*, + containers >= 0.5 && < 0.7, + criterion >= 1.1 && < 1.6, deepseq >= 1.3 && < 1.5, + dependent-map, + dependent-sum, + loch-th, mtl, primitive, - criterion >= 1.1 && < 1.3, + process, + ref-tf, + reflex, split, - reflex + stm, + time, + transformers >= 0.3 + other-modules: + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Bench.Focused source-repository head type: git diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/AppendMap.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | 'Data.Map' with a better 'Monoid' instance +-- +-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has +-- @mappend = unionWith mappend@ instead. +module Data.AppendMap + ( module Data.AppendMap + , module Data.Map.Monoidal + ) where + +import Prelude hiding (map, null) + +import Data.Coerce +import Data.Default +import Data.Map (Map) +#if MIN_VERSION_containers(0,5,11) +import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) +#else +import qualified Data.Map as Map (showTree, showTreeWith) +#endif +import Data.Map.Monoidal +import Reflex.Class (FunctorMaybe (..)) +import Reflex.Patch (Additive, Group (..)) + +{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} +type AppendMap = MonoidalMap + +{-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-} +_unAppendMap :: MonoidalMap k v -> Map k v +_unAppendMap = getMonoidalMap + +pattern AppendMap :: Map k v -> MonoidalMap k v +pattern AppendMap m = MonoidalMap m + +instance FunctorMaybe (MonoidalMap k) where + fmapMaybe = mapMaybe + +-- | Deletes a key, returning 'Nothing' if the result is empty. +nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) +nonEmptyDelete k vs = + let deleted = delete k vs + in if null deleted + then Nothing + else Just deleted + +mapMaybeNoNull :: (a -> Maybe b) + -> MonoidalMap token a + -> Maybe (MonoidalMap token b) +mapMaybeNoNull f as = + let bs = fmapMaybe f as + in if null bs + then Nothing + else Just bs + +-- TODO: Move instances to `Reflex.Patch` +instance (Ord k, Group q) => Group (MonoidalMap k q) where + negateG = map negateG + +instance (Ord k, Additive q) => Additive (MonoidalMap k q) + +showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String +showTree = coerce (Map.showTree :: Map k a -> String) + +showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String +showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String) + +instance Default (MonoidalMap k a) where + def = empty diff --git a/src/Data/FastMutableIntMap.hs b/src/Data/FastMutableIntMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/FastMutableIntMap.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TypeFamilies #-} +module Data.FastMutableIntMap + ( FastMutableIntMap + , new + , newEmpty + , insert + , isEmpty + , getFrozenAndClear + , size + , applyPatch + , PatchIntMap (..) + , traverseIntMapPatchWithKey + , lookup + , forIntersectionWithImmutable_ + , for_ + , patchIntMapNewElements + , patchIntMapNewElementsMap + , getDeletions + ) where + +--TODO: Pure JS version +--TODO: Fast copy to FastIntMap +--TODO: Fast patch type + +import Prelude hiding (lookup) + +import Control.Monad.IO.Class +import Data.Foldable (traverse_) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.IORef +import Reflex.Patch.Class +import Reflex.Patch.IntMap + +newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a)) + +new :: IntMap a -> IO (FastMutableIntMap a) +new m = FastMutableIntMap <$> newIORef m + +newEmpty :: IO (FastMutableIntMap a) +newEmpty = FastMutableIntMap <$> newIORef IntMap.empty + +insert :: FastMutableIntMap a -> Int -> a -> IO () +insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v + +lookup :: FastMutableIntMap a -> Int -> IO (Maybe a) +lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r + +forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m () +forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do + a <- liftIO $ readIORef r + traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b + +for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m () +for_ (FastMutableIntMap r) f = do + a <- liftIO $ readIORef r + traverse_ f a + +isEmpty :: FastMutableIntMap a -> IO Bool +isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r + +size :: FastMutableIntMap a -> IO Int +size (FastMutableIntMap r) = IntMap.size <$> readIORef r + +-- | Make an immutable snapshot of the datastructure and clear it +getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a) +getFrozenAndClear (FastMutableIntMap r) = do + result <- readIORef r + writeIORef r IntMap.empty + return result + +applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a) +applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do + v <- readIORef r + writeIORef r $! applyAlways p v + return $ IntMap.intersection v m diff --git a/src/Data/FastWeakBag.hs b/src/Data/FastWeakBag.hs new file mode 100644 --- /dev/null +++ b/src/Data/FastWeakBag.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +#ifdef GHCJS_FAST_WEAK +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +#endif +-- | This module defines the 'FastWeakBag' type, which represents a mutable +-- collection of items that does not cause the items to be retained in memory. +-- This is useful for situations where a value needs to be inspected or modified +-- if it is still alive, but can be ignored if it is dead. +module Data.FastWeakBag + ( FastWeakBag + , FastWeakBagTicket + , empty + , isEmpty + , insert + , traverse + , remove + -- * Internal functions + -- These will not always be available. +#ifndef GHCJS_FAST_WEAK + , _weakBag_children --TODO: Don't export this +#endif + ) where + +import Prelude hiding (traverse) + +import Control.Monad +import Control.Monad.IO.Class + +#ifdef GHCJS_FAST_WEAK +import GHCJS.Types +import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal) +#else +import Control.Exception +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.IORef +import System.Mem.Weak +#endif + +-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them - +-- that is, they can still be garbage-collected. As long as the @/a/@ values remain +-- alive, the 'FastWeakBag' will continue to refer to them. +#ifdef GHCJS_FAST_WEAK +newtype FastWeakBag a = FastWeakBag JSVal +#else +data FastWeakBag a = FastWeakBag + { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around? + , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) + } +#endif + +-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If +-- the caller retains the ticket, the item is guranteed to stay in memory (and +-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from +-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'. +#ifdef GHCJS_FAST_WEAK +newtype FastWeakBagTicket a = FastWeakBagTicket JSVal +#else +data FastWeakBagTicket a = FastWeakBagTicket + { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a) + , _weakBagTicket_item :: {-# NOUNPACK #-} !a + } +#endif + +-- | Insert an item into a 'FastWeakBag'. +{-# INLINE insert #-} +insert :: a -- ^ The item + -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into + -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item + -- is retained and allows the item to be removed. +#ifdef GHCJS_FAST_WEAK +insert a wb = js_insert (unsafeToRawJSVal a) wb +foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a) +#else +insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do + a' <- evaluate a + myId <- atomicModifyIORef' nextId $ \n -> (succ n, n) + let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ()) + wa <- mkWeakPtr a' $ Just cleanup + atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ()) + return $ FastWeakBagTicket + { _weakBagTicket_weakItem = wa + , _weakBagTicket_item = a' + } +#endif + +-- | Create an empty 'FastWeakBag'. +{-# INLINE empty #-} +empty :: IO (FastWeakBag a) +#ifdef GHCJS_FAST_WEAK +empty = js_empty +foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a) +#else +empty = {-# SCC "empty" #-} do + nextId <- newIORef 1 + children <- newIORef IntMap.empty + let bag = FastWeakBag + { _weakBag_nextId = nextId + , _weakBag_children = children + } + return bag +#endif + +-- | Check whether a 'FastWeakBag' is empty. +{-# INLINE isEmpty #-} +isEmpty :: FastWeakBag a -> IO Bool +#ifdef GHCJS_FAST_WEAK +isEmpty = js_isEmpty +foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time +#else +isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag) +#endif + +{-# INLINE traverse #-} +-- | Visit every node in the given list. If new nodes are appended during the +-- traversal, they will not be visited. Every live node that was in the list +-- when the traversal began will be visited exactly once; however, no guarantee +-- is made about the order of the traversal. +traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m () +#ifdef GHCJS_FAST_WEAK +traverse wb f = do + let go cursor = when (not $ js_isNull cursor) $ do + val <- liftIO $ js_getTicketValue cursor + f $ unsafeFromRawJSVal val + go =<< liftIO (js_getNext (FastWeakBagTicket cursor)) + go =<< liftIO (js_getInitial wb) +foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a +foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal +--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag +foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a +#else +traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do + cs <- liftIO $ readIORef children + forM_ cs $ \c -> do + ma <- liftIO $ deRefWeak c + mapM_ f ma +#endif + +-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times +-- on the same 'FastWeakBagTicket'. +{-# INLINE remove #-} +remove :: FastWeakBagTicket a -> IO () +#ifdef GHCJS_FAST_WEAK +remove = js_remove +foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here +#else +remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w +#endif +--TODO: Should 'remove' also drop the reference to the item? + +--TODO: can/should we provide a null FastWeakBagTicket? diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs --- a/src/Data/Functor/Misc.hs +++ b/src/Data/Functor/Misc.hs @@ -1,31 +1,94 @@ -{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds #-} -module Data.Functor.Misc where +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +-- | This module provides types and functions with no particular theme, but +-- which are relevant to the use of 'Functor'-based datastructures like +-- 'Data.Dependent.Map.DMap'. +module Data.Functor.Misc + ( -- * Const2 + Const2 (..) + , unConst2 + , dmapToMap + , dmapToIntMap + , dmapToMapWith + , mapToDMap + , weakenDMapWith + -- * WrapArg + , WrapArg (..) + -- * Convenience functions for DMap + , mapWithFunctorToDMap + , intMapWithFunctorToDMap + , mapKeyValuePairsMonotonic + , combineDMapsWithKey + , EitherTag (..) + , dmapToThese + , eitherToDSum + , dsumToEither + -- * Deprecated functions + , sequenceDmap + , wrapDMap + , rewrapDMap + , unwrapDMap + , unwrapDMapMaybe + , extractFunctorDMap + , ComposeMaybe (..) + ) where +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.Identity +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum import Data.GADT.Compare +import Data.GADT.Show +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Dependent.Map (DMap, DSum (..)) -import qualified Data.Dependent.Map as DMap -import Data.Typeable hiding (Refl) +import Data.Some (Some) +import qualified Data.Some as Some import Data.These -import Control.Monad.Identity - -data WrapArg :: (k -> *) -> (k -> *) -> * -> * where - WrapArg :: f a -> WrapArg g f (g a) - -instance GEq f => GEq (WrapArg g f) where - geq (WrapArg a) (WrapArg b) = fmap (\Refl -> Refl) $ geq a b +import Data.Typeable hiding (Refl) -instance GCompare f => GCompare (WrapArg g f) where - gcompare (WrapArg a) (WrapArg b) = case gcompare a b of - GLT -> GLT - GEQ -> GEQ - GGT -> GGT +-------------------------------------------------------------------------------- +-- Const2 +-------------------------------------------------------------------------------- -data Const2 :: * -> * -> * -> * where +-- | 'Const2' stores a value of a given type 'k' and ensures that a particular +-- type 'v' is always given for the last type parameter +data Const2 :: * -> x -> x -> * where Const2 :: k -> Const2 k v v deriving (Typeable) +-- | Extract the value from a Const2 +unConst2 :: Const2 k v v' -> k +unConst2 (Const2 k) = k + +deriving instance Eq k => Eq (Const2 k v v') +deriving instance Ord k => Ord (Const2 k v v') +deriving instance Show k => Show (Const2 k v v') +deriving instance Read k => Read (Const2 k v v) + +instance Show k => GShow (Const2 k v) where + gshowsPrec n x@(Const2 _) = showsPrec n x + +instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where + showTaggedPrec (Const2 _) = showsPrec + instance Eq k => GEq (Const2 k v) where geq (Const2 a) (Const2 b) = if a == b @@ -38,13 +101,81 @@ EQ -> GEQ GT -> GGT -{-# INLINE sequenceDmap #-} -sequenceDmap :: (Monad m, GCompare f) => DMap f m -> m (DMap f Identity) -sequenceDmap = DMap.foldrWithKey (\k mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k (Identity v) x) - (return DMap.empty) +-- | Convert a 'DMap' to a regular 'Map' +dmapToMap :: DMap (Const2 k v) Identity -> Map k v +dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList +-- | Convert a 'DMap' to an 'IntMap' +dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v +dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList + +-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove +-- the wrapping 'Functor' +dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v' +dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList + +-- | Convert a regular 'Map' to a 'DMap' +mapToDMap :: Map k v -> DMap (Const2 k v) Identity +mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList + +-- | Convert a regular 'Map', where the values are already wrapped in a functor, +-- to a 'DMap' +mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f +mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList + +-- | Convert a regular 'IntMap', where the values are already wrapped in a +-- functor, to a 'DMap' +intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f +intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList + +-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with +-- the keys, using a function to remove the wrapping 'Functor' +weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v' +weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList + +-------------------------------------------------------------------------------- +-- WrapArg +-------------------------------------------------------------------------------- + +-- | 'WrapArg' can be used to tag a value in one functor with a type +-- representing another functor. This was primarily used with dependent-map < +-- 0.2, in which the value type was not wrapped in a separate functor. +data WrapArg :: (k -> *) -> (k -> *) -> * -> * where + WrapArg :: f a -> WrapArg g f (g a) + +deriving instance Eq (f a) => Eq (WrapArg g f (g' a)) +deriving instance Ord (f a) => Ord (WrapArg g f (g' a)) +deriving instance Show (f a) => Show (WrapArg g f (g' a)) +deriving instance Read (f a) => Read (WrapArg g f (g a)) + +instance GEq f => GEq (WrapArg g f) where + geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b + +instance GCompare f => GCompare (WrapArg g f) where + gcompare (WrapArg a) (WrapArg b) = case gcompare a b of + GLT -> GLT + GEQ -> GEQ + GGT -> GGT + +-------------------------------------------------------------------------------- +-- Convenience functions for DMap +-------------------------------------------------------------------------------- + +-- | Map over all key/value pairs in a 'DMap', potentially altering the key as +-- well as the value. The provided function MUST preserve the ordering of the +-- keys, or the resulting 'DMap' will be malformed. +mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v' +mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList + {-# INLINE combineDMapsWithKey #-} -combineDMapsWithKey :: forall f g h i. GCompare f => (forall (a :: *). f a -> These (g a) (h a) -> i a) -> DMap f g -> DMap f h -> DMap f i +-- | Union two 'DMap's of different types, yielding another type. Each key that +-- is present in either input map will be present in the output. +combineDMapsWithKey :: forall f g h i. + GCompare f + => (forall a. f a -> These (g a) (h a) -> i a) + -> DMap f g + -> DMap f h + -> DMap f i combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh) where go :: [DSum f g] -> [DSum f h] -> [DSum f i] go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs @@ -54,23 +185,103 @@ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs' GGT -> (hk :=> f hk (That hv)) : go gs hs' -wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f -wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList +-- | Extract the values of a 'DMap' of 'EitherTag's. +dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b) +dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of + (Nothing, Nothing) -> Nothing + (Just (Identity a), Nothing) -> Just $ This a + (Nothing, Just (Identity b)) -> Just $ That b + (Just (Identity a), Just (Identity b)) -> Just $ These a b -rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g -rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList +-- | Tag type for 'Either' to use it as a 'DSum'. +data EitherTag l r a where + LeftTag :: EitherTag l r l + RightTag :: EitherTag l r r + deriving (Typeable) -unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity -unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList +deriving instance Show (EitherTag l r a) +deriving instance Eq (EitherTag l r a) +deriving instance Ord (EitherTag l r a) -unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity -unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]] +instance GEq (EitherTag l r) where + geq a b = case (a, b) of + (LeftTag, LeftTag) -> Just Refl + (RightTag, RightTag) -> Just Refl + _ -> Nothing -mapToDMap :: Map k v -> DMap (Const2 k v) Identity -mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList +instance GCompare (EitherTag l r) where + gcompare a b = case (a, b) of + (LeftTag, LeftTag) -> GEQ + (LeftTag, RightTag) -> GLT + (RightTag, LeftTag) -> GGT + (RightTag, RightTag) -> GEQ -mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f -mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList +instance GShow (EitherTag l r) where + gshowsPrec _ a = case a of + LeftTag -> showString "LeftTag" + RightTag -> showString "RightTag" -dmapToMap :: DMap (Const2 k v) Identity -> Map k v -dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList +instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where + showTaggedPrec t n (Identity a) = case t of + LeftTag -> showsPrec n a + RightTag -> showsPrec n a + +-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'. +eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity +eitherToDSum = \case + Left a -> (LeftTag :=> Identity a) + Right b -> (RightTag :=> Identity b) + +-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'. +dsumToEither :: DSum (EitherTag a b) Identity -> Either a b +dsumToEither = \case + (LeftTag :=> Identity a) -> Left a + (RightTag :=> Identity b) -> Right b + +-------------------------------------------------------------------------------- +-- ComposeMaybe +-------------------------------------------------------------------------------- + +-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would +-- make the 'f' parameter have a nominal type role. We need f to be +-- representational so that we can use safe 'coerce'. +newtype ComposeMaybe f a = + ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord) + +deriving instance Functor f => Functor (ComposeMaybe f) + +-------------------------------------------------------------------------------- +-- Deprecated functions +-------------------------------------------------------------------------------- + +{-# INLINE sequenceDmap #-} +{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-} +-- | Run the actions contained in the 'DMap' +sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity) +sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t + +{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-} +-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor +wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f +wrapDMap f = DMap.map $ f . runIdentity + +{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-} +-- | Replace one functor for a 'DMap''s values with a different functor +rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g +rewrapDMap = DMap.map + +{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-} +-- | Replace one functor for a 'DMap''s values with the 'Identity' functor +unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity +unwrapDMap f = DMap.map $ Identity . f + +{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-} +-- | Like 'unwrapDMap', but possibly delete some values from the DMap +unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity +unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a + +{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-} +-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the +-- underlying functor +extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f +extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v diff --git a/src/Data/Map/Misc.hs b/src/Data/Map/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Data/Map/Misc.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE LambdaCase #-} +-- | Additional functions for manipulating 'Map's. +module Data.Map.Misc + ( + -- * Working with Maps + diffMapNoEq + , diffMap + , applyMap + , mapPartitionEithers + , applyMapKeysSet + ) where + +import Data.Align +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Data.These + +-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new@ respectively. @Just@ represents an association present in @new@ and @Nothing@ +-- represents an association only present in @old@ but no longer present in @new@. +-- +-- Similar to 'diffMap' but doesn't require 'Eq' on the values, thus can't tell if a value has changed or not. +diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v) +diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case + This _ -> Just Nothing + These _ new -> Just $ Just new + That new -> Just $ Just new + +-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new respectively. @Just@ represents an association present in @new@ and either not +-- present in @old@ or where the value has changed. @Nothing@ represents an association only present in @old@ but no longer present in @new@. +-- +-- See also 'diffMapNoEq' for a similar but weaker version which does not require 'Eq' on the values but thus can't indicated a value not changing between +-- @old@ and @new@ with @Nothing@. +diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v) +diffMap olds news = flip Map.mapMaybe (align olds news) $ \case + This _ -> Just Nothing + These old new + | old == new -> Nothing + | otherwise -> Just $ Just new + That new -> Just $ Just new + +-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@. +-- +-- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'. +applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v +applyMap patch old = insertions `Map.union` (old `Map.difference` deletions) + where (deletions, insertions) = Map.mapEither maybeToEither patch + maybeToEither = \case + Nothing -> Left () + Just r -> Right r + +-- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@ +{-# DEPRECATED mapPartitionEithers "Use 'mapEither' instead" #-} +mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b) +mapPartitionEithers = Map.mapEither id + +-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new @'Set' k@ from the given input set. +-- +-- Equivalent to: +-- +-- @ +-- applyMapKeysSet patch ('Map.keysSet' m) == 'Map.keysSet' ('applyMap' patch m) +-- @ +-- +-- but avoids the intervening @Map@ and needs no values. +applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k +applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions) + where (insertions, deletions) = Map.partition isJust patch + diff --git a/src/Data/WeakBag.hs b/src/Data/WeakBag.hs new file mode 100644 --- /dev/null +++ b/src/Data/WeakBag.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +-- | This module defines the 'WeakBag' type, which represents a mutable +-- collection of items that does not cause the items to be retained in memory. +-- This is useful for situations where a value needs to be inspected or modified +-- if it is still alive, but can be ignored if it is dead. +module Data.WeakBag + ( WeakBag + , WeakBagTicket + , empty + , singleton + , insert + , traverse + , remove + -- * Internal functions + -- These will not always be available. + , _weakBag_children --TODO: Don't export this + ) where + +import Prelude hiding (traverse) + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.IORef +import System.Mem.Weak + +-- | A 'WeakBag' holds a set of values of type @/a/@, but does not retain them - +-- that is, they can still be garbage-collected. As long as the @/a/@ values remain +-- alive, the 'WeakBag' will continue to refer to them. +data WeakBag a = WeakBag + { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around? + , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ The items referenced by the WeakBag + } + +-- | When inserting an item into a 'WeakBag', a 'WeakBagTicket' is returned. If +-- the caller retains the ticket, the item is guranteed to stay in memory (and +-- thus in the 'WeakBag'). The ticket can also be used to remove the item from +-- the 'WeakBag' prematurely (i.e. while it is still alive), using 'remove'. +data WeakBagTicket = forall a. WeakBagTicket + { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a) + , _weakBagTicket_item :: {-# NOUNPACK #-} !a + } + +-- | Insert an item into a 'WeakBag'. +{-# INLINE insert #-} +insert :: a -- ^ The item + -> WeakBag a -- ^ The 'WeakBag' to insert into + -> IORef (Weak b) -- ^ An arbitrary value to be used in the following + -- callback + -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed + -- (whether automatically by the item being garbage + -- collected or manually via 'remove') + -> IO WeakBagTicket -- ^ Returns a 'WeakBagTicket' that ensures the item + -- is retained and allows the item to be removed. +insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do + a' <- evaluate a + wbRef' <- evaluate wbRef + myId <- atomicModifyIORef' nextId $ \n -> (succ n, n) + let cleanup = do + wb <- readIORef wbRef' + mb <- deRefWeak wb + forM_ mb $ \b -> do + csWithoutMe <- atomicModifyIORef children $ \cs -> + let !csWithoutMe = IntMap.delete myId cs + in (csWithoutMe, csWithoutMe) + when (IntMap.null csWithoutMe) $ finalizer b + wa <- mkWeakPtr a' $ Just cleanup + atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ()) + return $ WeakBagTicket + { _weakBagTicket_weakItem = wa + , _weakBagTicket_item = a' + } + +-- | Create an empty 'WeakBag'. +{-# INLINE empty #-} +empty :: IO (WeakBag a) +empty = {-# SCC "empty" #-} do + nextId <- newIORef 1 + children <- newIORef IntMap.empty + let bag = WeakBag + { _weakBag_nextId = nextId + , _weakBag_children = children + } + return bag + +-- | Create a 'WeakBag' with one item; equivalent to creating the 'WeakBag' with +-- 'empty', then using 'insert'. +{-# INLINE singleton #-} +singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket) +singleton a wbRef finalizer = {-# SCC "singleton" #-} do + bag <- empty + ticket <- insert a bag wbRef finalizer + return (bag, ticket) + +{-# INLINE traverse #-} +-- | Visit every node in the given list. If new nodes are appended during the +-- traversal, they will not be visited. Every live node that was in the list +-- when the traversal began will be visited exactly once; however, no guarantee +-- is made about the order of the traversal. +traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m () +traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do + cs <- liftIO $ readIORef children + forM_ cs $ \c -> do + ma <- liftIO $ deRefWeak c + mapM_ f ma + +-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times +-- on the same 'WeakBagTicket'. +{-# INLINE remove #-} +remove :: WeakBagTicket -> IO () +remove (WeakBagTicket w _) = {-# SCC "remove" #-} finalize w +--TODO: Should 'remove' also drop the reference to the item? + +--TODO: can/should we provide a null WeakBagTicket? diff --git a/src/Reflex.hs b/src/Reflex.hs --- a/src/Reflex.hs +++ b/src/Reflex.hs @@ -1,10 +1,34 @@ -module Reflex ( module Reflex.Class - , module Reflex.Dynamic - , module Reflex.Dynamic.TH - , module Reflex.Spider - ) where +{-# LANGUAGE CPP #-} +-- | This module exports all of the commonly-used functionality of Reflex; if +-- you are just getting started with Reflex, this is probably what you want. +module Reflex + ( module X + ) where -import Reflex.Class -import Reflex.Dynamic -import Reflex.Dynamic.TH -import Reflex.Spider +import Reflex.Class as X +import Reflex.Adjustable.Class as X +import Reflex.BehaviorWriter.Base as X +import Reflex.BehaviorWriter.Class as X +import Reflex.Collection as X +import Reflex.Dynamic as X +import Reflex.EventWriter.Base as X +import Reflex.EventWriter.Class as X +#ifdef USE_TEMPLATE_HASKELL +import Reflex.Dynamic.TH as X +#endif +import Reflex.Dynamic.Uniq as X +import Reflex.DynamicWriter.Base as X +import Reflex.DynamicWriter.Class as X +import Reflex.PerformEvent.Base as X +import Reflex.PerformEvent.Class as X +import Reflex.PostBuild.Base as X +import Reflex.PostBuild.Class as X +import Reflex.Profiled as X +import Reflex.Query.Base as X +import Reflex.Query.Class as X +import Reflex.Requester.Base as X +import Reflex.Requester.Class as X +import Reflex.Spider as X +import Reflex.Time as X +import Reflex.TriggerEvent.Base as X +import Reflex.TriggerEvent.Class as X diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Adjustable/Class.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.Adjustable.Class + ( + -- * The Adjustable typeclass + Adjustable(..) + , sequenceDMapWithAdjust + , sequenceDMapWithAdjustWithMove + , mapMapWithAdjustWithMove + -- * Deprecated aliases + , MonadAdjust + ) where + +import Control.Monad.Identity +import Control.Monad.Reader +import Data.Dependent.Map (DMap, GCompare (..)) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Constant +import Data.Functor.Misc +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Map (Map) + +import Reflex.Class +import Reflex.Patch.DMapWithMove + +-- | A 'Monad' that supports adjustment over time. After an action has been +-- run, if the given events fire, it will adjust itself so that its net effect +-- is as though it had originally been run with the new value. Note that there +-- is some issue here with persistent side-effects: obviously, IO (and some +-- other side-effects) cannot be undone, so it is up to the instance implementer +-- to determine what the best meaning for this class is in such cases. +class (Reflex t, Monad m) => Adjustable t m | m -> t where + runWithReplace + :: m a + -> Event t (m b) + -> m (a, Event t b) + + traverseIntMapWithKeyWithAdjust + :: (IntMap.Key -> v -> m v') + -> IntMap v + -> Event t (PatchIntMap v) + -> m (IntMap v', Event t (PatchIntMap v')) + + traverseDMapWithKeyWithAdjust + :: GCompare k + => (forall a. k a -> v a -> m (v' a)) + -> DMap k v + -> Event t (PatchDMap k v) + -> m (DMap k v', Event t (PatchDMap k v')) + {-# INLINABLE traverseDMapWithKeyWithAdjust #-} + traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $ + traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm' + where + toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m + toNodeInfoWithMove = \case + ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing + ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing + fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m + fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of + From_Insert v -> Just v + From_Delete -> Nothing + From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move" + + traverseDMapWithKeyWithAdjustWithMove + :: GCompare k + => (forall a. k a -> v a -> m (v' a)) + -> DMap k v + -> Event t (PatchDMapWithMove k v) + -> m (DMap k v', Event t (PatchDMapWithMove k v')) + +instance Adjustable t m => Adjustable t (ReaderT r m) where + runWithReplace a0 a' = do + r <- ask + lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a' + traverseIntMapWithKeyWithAdjust f dm0 dm' = do + r <- ask + lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm' + traverseDMapWithKeyWithAdjust f dm0 dm' = do + r <- ask + lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm' + traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do + r <- ask + lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm' + +sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity)) +sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity + +sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity)) +sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity + +mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v')) +mapMapWithAdjustWithMove f m0 m' = do + (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m') + return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out') + +-------------------------------------------------------------------------------- +-- Deprecated functions +-------------------------------------------------------------------------------- + +{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-} +type MonadAdjust = Adjustable diff --git a/src/Reflex/BehaviorWriter/Base.hs b/src/Reflex/BehaviorWriter/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/BehaviorWriter/Base.hs @@ -0,0 +1,202 @@ +{-| +Module: Reflex.BehaviorWriter.Base +Description: Implementation of MonadBehaviorWriter +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.BehaviorWriter.Base + ( BehaviorWriterT (..) + , runBehaviorWriterT + , withBehaviorWriterT + ) where + +import Control.Monad.Exception +import Control.Monad.Identity +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Misc +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Some (Some) + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.BehaviorWriter.Class +import Reflex.Host.Class +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.Query.Class +import Reflex.Requester.Class +import Reflex.TriggerEvent.Class + +-- | A basic implementation of 'MonadBehaviorWriter'. +newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order + +-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided +-- along with the result of the action. +runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w) +runBehaviorWriterT (BehaviorWriterT a) = do + (result, ws) <- runStateT a [] + return (result, mconcat $ reverse ws) + +-- | Map a function over the output of a 'BehaviorWriterT'. +withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m) + => (w -> w') + -> BehaviorWriterT t w m a + -> BehaviorWriterT t w' m a +withBehaviorWriterT f dw = do + (r, d) <- lift $ do + (r, d) <- runBehaviorWriterT dw + let d' = fmap f d + return (r, d') + tellBehavior d + return r + +deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m) +deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m) + +instance MonadTrans (BehaviorWriterT t w) where + lift = BehaviorWriterT . lift + +instance MonadRef m => MonadRef (BehaviorWriterT t w m) where + type Ref (BehaviorWriterT t w m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where + atomicModifyRef r = lift . atomicModifyRef r + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where + tellBehavior w = BehaviorWriterT $ modify (w :) + +instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where + ask = lift ask + local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a + reader = lift . reader + +instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where + type Performable (BehaviorWriterT t w m) = Performable m + performEvent_ = lift . performEvent_ + performEvent = lift . performEvent + +instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where + getPostBuild = lift getPostBuild + +instance MonadState s m => MonadState s (BehaviorWriterT t w m) where + get = lift get + put = lift . put + +instance Requester t m => Requester t (BehaviorWriterT t w m) where + type Request (BehaviorWriterT t w m) = Request m + type Response (BehaviorWriterT t w m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where + tellQueryIncremental = lift . tellQueryIncremental + askQueryResult = lift askQueryResult + queryIncremental = lift . queryIncremental + +instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where + runWithReplace a0 a' = do + (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a' + tellBehavior . join =<< hold (snd result0) (snd <$> result') + return (fst result0, fst <$> result') + traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust + traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith + +traverseIntMapWithKeyWithAdjustImpl + :: forall t w v' p p' v m. + ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w) + , Patch (p' (Behavior t w)) + , Monoid w + , Reflex t + , MonadHold t m + , Functor p + , p ~ p' + ) + => ( (IntMap.Key -> v -> m (v', Behavior t w)) + -> IntMap v + -> Event t (p v) + -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w))) + ) + -> (IntMap.Key -> v -> BehaviorWriterT t w m v') + -> IntMap v + -> Event t (p v) + -> BehaviorWriterT t w m (IntMap v', Event t (p v')) +traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do + (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm' + let liftedResult0 = fmap fst result0 + liftedResult' = fmap (fmap fst) result' + liftedWritten0 :: IntMap (Behavior t w) + liftedWritten0 = fmap snd result0 + liftedWritten' = fmap (fmap snd) result' + i <- holdIncremental liftedWritten0 liftedWritten' + tellBehavior $ pull $ do + m <- sample $ currentIncremental i + mconcat . IntMap.elems <$> traverse sample m + return (liftedResult0, liftedResult') + +newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w) + +traverseDMapWithKeyWithAdjustImpl + :: forall t w k v' p p' v m. + ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w) + , Patch (p' (Some k) (Behavior t w)) + , Monoid w + , Reflex t + , MonadHold t m + ) + => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a)) + -> DMap k v + -> Event t (p k v) + -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v'))) + ) + -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v') + -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w)) + -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a)) + -> DMap k v + -> Event t (p k v) + -> BehaviorWriterT t w m (DMap k v', Event t (p k v')) +traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do + (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm' + let getValue (BehaviorWriterTLoweredResult (v, _)) = v + getWritten (BehaviorWriterTLoweredResult (_, w)) = w + liftedResult0 = DMap.map getValue result0 + liftedResult' = ffor result' $ mapPatch getValue + liftedWritten0 :: Map (Some k) (Behavior t w) + liftedWritten0 = weakenDMapWith getWritten result0 + liftedWritten' = ffor result' $ weakenPatchWith getWritten + i <- holdIncremental liftedWritten0 liftedWritten' + tellBehavior $ pull $ do + m <- sample $ currentIncremental i + mconcat . Map.elems <$> traverse sample m + return (liftedResult0, liftedResult') diff --git a/src/Reflex/BehaviorWriter/Class.hs b/src/Reflex/BehaviorWriter/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/BehaviorWriter/Class.hs @@ -0,0 +1,26 @@ +{-| +Module: Reflex.BehaviorWriter.Class +Description: This module defines the 'MonadBehaviorWriter' class +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.BehaviorWriter.Class + ( MonadBehaviorWriter (..) + ) where + +import Control.Monad.Reader (ReaderT, lift) +import Reflex.Class (Behavior) + +-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior' +-- and combines them monoidally to provide a 'Behavior' result. +class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where + tellBehavior :: Behavior t w -> m () + +instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where + tellBehavior = lift . tellBehavior diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -1,374 +1,1358 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, CPP #-} -module Reflex.Class where - -import Control.Applicative -import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Control.Monad.Trans.Writer (WriterT()) -import Control.Monad.Trans.Except (ExceptT()) -import Control.Monad.Trans.Cont (ContT()) -import Control.Monad.Trans.RWS (RWST()) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.These -import Data.Align -import Data.GADT.Compare (GEq (..), (:~:) (..)) -import Data.GADT.Show (GShow (..)) -import Data.Dependent.Sum (ShowTag (..)) -import Data.Map (Map) -import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..)) -import qualified Data.Dependent.Map as DMap -import Data.Functor.Misc -import Data.Semigroup -import Data.Traversable - --- Note: must come last to silence warnings due to AMP on GHC < 7.10 -import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl) - -import Debug.Trace (trace) - -class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t)) => Reflex t where - -- | A container for a value that can change over time. Behaviors can be sampled at will, but it is not possible to be notified when they change - data Behavior t :: * -> * - -- | A stream of occurrences. During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type") - data Event t :: * -> * - -- | An Event with no occurrences - never :: Event t a - -- | Create a Behavior that always has the given value - constant :: a -> Behavior t a --TODO: Refactor to use 'pure' from Applicative instead; however, we need to make sure that encouraging Applicative-style use of Behaviors doesn't have a negative performance impact - -- | Create an Event from another Event; the provided function can sample Behaviors and hold Events, and use the results to produce a occurring (Just) or non-occurring (Nothing) result - push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b - -- | A monad for doing complex push-based calculations efficiently - type PushM t :: * -> * - -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes - pull :: PullM t a -> Behavior t a - -- | A monad for doing complex pull-based calculations efficiently - type PullM t :: * -> * - -- | Merge a collection of events; the resulting Event will only occur if at least one input event is occuring, and will contain all of the input keys that are occurring simultaneously - merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty - -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events - fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it - -- | Create an Event that will occur whenever the currently-selected input Event occurs - switch :: Behavior t (Event t a) -> Event t a - -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring - coincidence :: Event t (Event t a) -> Event t a - -class (Applicative m, Monad m) => MonadSample t m | m -> t where - -- | Get the current value in the Behavior - sample :: Behavior t a -> m a - -class MonadSample t m => MonadHold t m where - -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs. The update takes effect immediately after the Event occurs; if the occurrence that sets the Behavior (or one that is simultaneous with it) is used to sample the Behavior, it will see the *old* value of the Behavior, not the new one. - hold :: a -> Event t a -> m (Behavior t a) - -newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a } - --------------------------------------------------------------------------------- --- Instances --------------------------------------------------------------------------------- - -instance MonadSample t m => MonadSample t (ReaderT r m) where - sample = lift . sample - -instance MonadHold t m => MonadHold t (ReaderT r m) where - hold a0 = lift . hold a0 - -instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where - sample = lift . sample - -instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where - hold a0 = lift . hold a0 - -instance MonadSample t m => MonadSample t (StateT s m) where - sample = lift . sample - -instance MonadHold t m => MonadHold t (StateT s m) where - hold a0 = lift . hold a0 - -instance MonadSample t m => MonadSample t (ExceptT e m) where - sample = lift . sample - -instance MonadHold t m => MonadHold t (ExceptT e m) where - hold a0 = lift . hold a0 - -instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where - sample = lift . sample - -instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where - hold a0 = lift . hold a0 - -instance MonadSample t m => MonadSample t (ContT r m) where - sample = lift . sample - -instance MonadHold t m => MonadHold t (ContT r m) where - hold a0 = lift . hold a0 - --------------------------------------------------------------------------------- --- Convenience functions --------------------------------------------------------------------------------- - --- | Create an Event from another Event. --- The provided function can sample 'Behavior's and hold 'Event's. -pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b -pushAlways f = push (liftM Just . f) - --- | Flipped version of 'fmap'. -ffor :: Functor f => f a -> (a -> b) -> f b -ffor = flip fmap - -instance Reflex t => Functor (Behavior t) where - fmap f = pull . liftM f . sample - -instance Reflex t => Applicative (Behavior t) where - pure = constant - f <*> x = pull $ sample f `ap` sample x - _ *> b = b - a <* _ = a - -instance Reflex t => Monad (Behavior t) where - a >>= f = pull $ sample a >>= sample . f - -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine Behaviors other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above. - return = constant - fail = error "Monad (Behavior t) does not support fail" - -instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where - a <> b = pull $ liftM2 (<>) (sample a) (sample b) - sconcat = pull . liftM sconcat . mapM sample -#if MIN_VERSION_semigroups(0,17,0) - stimes n = fmap $ stimes n -#else - times1p n = fmap $ times1p n -#endif - -instance (Reflex t, Monoid a) => Monoid (Behavior t a) where - mempty = constant mempty - mappend a b = pull $ liftM2 mappend (sample a) (sample b) - mconcat = pull . liftM mconcat . mapM sample - ---TODO: See if there's a better class in the standard libraries already --- | A class for values that combines filtering and mapping using 'Maybe'. -class FunctorMaybe f where - -- | Combined mapping and filtering function. - fmapMaybe :: (a -> Maybe b) -> f a -> f b - --- | Flipped version of 'fmapMaybe'. -fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b -fforMaybe = flip fmapMaybe - --- | Filter 'f a' using the provided predicate. --- Relies on 'fforMaybe'. -ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a -ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing - -instance Reflex t => FunctorMaybe (Event t) where - fmapMaybe f = push $ return . f - -instance Reflex t => Functor (Event t) where - fmap f = fmapMaybe $ Just . f - --- | Create a new 'Event' by combining each occurence with the next value --- of the list using the supplied function. If the list runs out of items, --- all subsequent 'Event' occurrences will be ignored. -zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c) -zipListWithEvent f l e = do - rec lb <- hold l eTail - let eBoth = flip push e $ \o -> do - l' <- sample lb - return $ case l' of - (h : t) -> Just (f h o, t) - [] -> Nothing - let eTail = fmap snd eBoth - lb `seq` eBoth `seq` eTail `seq` return () - return $ fmap fst eBoth - --- | Replace each occurrence value of the 'Event' with the value of the --- 'Behavior' at the time of that occurrence. -tag :: Reflex t => Behavior t b -> Event t a -> Event t b -tag b = pushAlways $ \_ -> sample b - --- | Create a new 'Event' that combines occurences of supplied 'Event' --- with the current value of the 'Behavior'. -attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b) -attach = attachWith (,) - --- | Create a new 'Event' that occurs when the supplied 'Event' occurs --- by combining it with the current value of the 'Behavior'. -attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c -attachWith f = attachWithMaybe $ \a b -> Just $ f a b - --- | Create a new 'Event' by combining each occurence with the current --- value of the 'Behavior'. The occurrence is discarded if the combining function --- returns Nothing -attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c -attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b - --- | Alias for 'headE' -onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) -onceE = headE - --- | Create a new 'Event' that only occurs on the first occurence of --- the supplied 'Event'. -headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) -headE e = do - rec be <- hold e $ fmap (const never) e' - let e' = switch be - e' `seq` return () - return e' - --- | Create a new 'Event' that occurs on all but the first occurence --- of the supplied 'Event'. -tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) -tailE e = liftM snd $ headTailE e - --- | Create a tuple of two 'Event's with the first one occuring only --- the first time the supplied 'Event' occurs and the second occuring --- on all but the first occurence. -headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a) -headTailE e = do - eHead <- headE e - be <- hold never $ fmap (const e) eHead - return (eHead, switch be) - --- | Split the supplied 'Event' into two individual 'Event's occuring --- at the same time with the respective values from the tuple. -splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b) -splitE e = (fmap fst e, fmap snd e) - --- | Print the supplied 'String' and the value of the 'Event' on each --- occurence. This should /only/ be used for debugging. --- --- Note: As with Debug.Trace.trace, the message will only be printed if --- the 'Event' is actually used. -traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a -traceEvent s = traceEventWith $ \x -> s <> ": " <> show x - --- | Print the output of the supplied function on each occurence of --- the 'Event'. This should /only/ be used for debugging. --- --- Note: As with Debug.Trace.trace, the message will only be printed if --- the 'Event' is actually used. -traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a -traceEventWith f = push $ \x -> trace (f x) $ return $ Just x - --- | Tag type for 'Either' to use it as a 'DSum'. -data EitherTag l r a where - LeftTag :: EitherTag l r l - RightTag :: EitherTag l r r - -instance GEq (EitherTag l r) where - geq a b = case (a, b) of - (LeftTag, LeftTag) -> Just Refl - (RightTag, RightTag) -> Just Refl - _ -> Nothing - -instance GCompare (EitherTag l r) where - gcompare a b = case (a, b) of - (LeftTag, LeftTag) -> GEQ - (LeftTag, RightTag) -> GLT - (RightTag, LeftTag) -> GGT - (RightTag, RightTag) -> GEQ - -instance GShow (EitherTag l r) where - gshowsPrec _ a = case a of - LeftTag -> showString "LeftTag" - RightTag -> showString "RightTag" - -instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where - showTaggedPrec t n (Identity a) = case t of - LeftTag -> showsPrec n a - RightTag -> showsPrec n a - --- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'. -eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity -eitherToDSum = \case - Left a -> (LeftTag :=> Identity a) - Right b -> (RightTag :=> Identity b) - --- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'. -dsumToEither :: DSum (EitherTag a b) Identity -> Either a b -dsumToEither = \case - (LeftTag :=> Identity a) -> Left a - (RightTag :=> Identity b) -> Right b - --- | Extract the values of a 'DMap' of 'EitherTag's. -dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b) -dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of - (Nothing, Nothing) -> Nothing - (Just (Identity a), Nothing) -> Just $ This a - (Nothing, Just (Identity b)) -> Just $ That b - (Just (Identity a), Just (Identity b)) -> Just $ These a b - --- | Create a new 'Event' that occurs if at least one of the supplied --- 'Event's occurs. If both occur at the same time they are combined --- using 'mappend'. -appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a -appendEvents e1 e2 = mergeThese mappend <$> align e1 e2 - -{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-} -sequenceThese :: Monad m => These (m a) (m b) -> m (These a b) -sequenceThese t = case t of - This ma -> liftM This ma - These ma mb -> liftM2 These ma mb - That mb -> liftM That mb - -instance (Semigroup a, Reflex t) => Monoid (Event t a) where - mempty = never - mappend a b = mconcat [a, b] - mconcat = fmap sconcat . mergeList - --- | Create a new 'Event' that occurs if at least one of the 'Event's --- in the list occurs. If multiple occur at the same time they are --- folded from the left with the given function. -mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a -mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) - . merge - . DMap.fromDistinctAscList - . map (\(k, v) -> (Const2 k) :=> v) - $ zip [0 :: Int ..] es - --- | Create a new 'Event' that occurs if at least one of the 'Event's --- in the list occurs. If multiple occur at the same time the value is --- the value of the leftmost event. -leftmost :: Reflex t => [Event t a] -> Event t a -leftmost = mergeWith const - --- | Create a new 'Event' that occurs if at least one of the 'Event's --- in the list occurs and has a list of the values of all 'Event's --- occuring at that time. -mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a) -mergeList [] = never -mergeList es = mergeWith (<>) $ map (fmap (:|[])) es - --- | Create a new 'Event' combining the map of 'Event's into an --- 'Event' that occurs if at least one of them occurs and has a map of --- values of all 'Event's occuring at that time. -mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a) -mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap - --- | Split the event into an 'EventSelector' that allows efficient --- selection of the individual 'Event's. -fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a) -fanMap = fan . fmap mapToDMap - --- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to -switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) -switchPromptly ea0 eea = do - bea <- hold ea0 eea - let eLag = switch bea - eCoincidences = coincidence eea - return $ leftmost [eCoincidences, eLag] - -instance Reflex t => Align (Event t) where - nil = never - align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] - --- | Create a new 'Event' that only occurs if the supplied 'Event' --- occurs and the 'Behavior' is true at the time of occurence. -gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a -gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing - --- | Create a new behavior given a starting behavior and switch to a the --- behvior carried by the event when it fires. -switcher :: (Reflex t, MonadHold t m) - => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a) -switcher b eb = pull . (sample <=< sample) <$> hold b eb +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif + +-- | This module contains the Reflex interface, as well as a variety of +-- convenience functions for working with 'Event's, 'Behavior's, and other +-- signals. +module Reflex.Class + ( module Reflex.Patch + -- * Primitives + , Reflex (..) + , mergeInt + , coerceBehavior + , coerceEvent + , coerceDynamic + , MonadSample (..) + , MonadHold (..) + -- ** 'fan' related types + , EventSelector (..) + , EventSelectorInt (..) + -- * Convenience functions + , constDyn + , pushAlways + -- ** Combining 'Event's + , leftmost + , mergeMap + , mergeIntMap + , mergeMapIncremental + , mergeMapIncrementalWithMove + , mergeIntMapIncremental + , coincidencePatchMap + , coincidencePatchMapWithMove + , coincidencePatchIntMap + , mergeList + , mergeWith + , difference + , alignEventWithMaybe + -- ** Breaking up 'Event's + , splitE + , fanEither + , fanThese + , fanMap + , dmapToThese + , EitherTag (..) + , eitherToDSum + , dsumToEither + , factorEvent + , filterEventKey + -- ** Collapsing 'Event . Event' + , switchHold + , switchHoldPromptly + , switchHoldPromptOnly + , switchHoldPromptOnlyIncremental + -- ** Using 'Event's to sample 'Behavior's + , tag + , tagMaybe + , attach + , attachWith + , attachWithMaybe + -- ** Blocking an 'Event' based on a 'Behavior' + , gate + -- ** Combining 'Dynamic's + , distributeDMapOverDynPure + , distributeListOverDyn + , distributeListOverDynWith + , zipDyn + , zipDynWith + -- ** Accumulating state + , Accumulator (..) + , accumDyn + , accumMDyn + , accumMaybeDyn + , accumMaybeMDyn + , mapAccumDyn + , mapAccumMDyn + , mapAccumMaybeDyn + , mapAccumMaybeMDyn + , accumB + , accumMB + , accumMaybeB + , accumMaybeMB + , mapAccumB + , mapAccumMB + , mapAccumMaybeB + , mapAccumMaybeMB + , mapAccum_ + , mapAccumM_ + , mapAccumMaybe_ + , mapAccumMaybeM_ + , accumIncremental + , accumMIncremental + , accumMaybeIncremental + , accumMaybeMIncremental + , mapAccumIncremental + , mapAccumMIncremental + , mapAccumMaybeIncremental + , mapAccumMaybeMIncremental + , zipListWithEvent + , numberOccurrences + , numberOccurrencesFrom + , numberOccurrencesFrom_ + , (<@>) + , (<@) + , tailE + , headTailE + , takeWhileE + , takeWhileJustE + , dropWhileE + , takeDropWhileJustE + , switcher + -- * Debugging functions + , traceEvent + , traceEventWith + -- * Unsafe functions + , unsafeDynamic + , unsafeMapIncremental + -- * 'FunctorMaybe' + , FunctorMaybe (..) + , fforMaybe + , ffilter + , filterLeft + , filterRight + -- * Miscellaneous convenience functions + , ffor + , ffor2 + , ffor3 + -- * Deprecated functions + , appendEvents + , onceE + , sequenceThese + , fmapMaybeCheap + , fmapCheap + , fforCheap + , fforMaybeCheap + , pushAlwaysCheap + , tagCheap + , mergeWithCheap + , mergeWithCheap' + , switchPromptly + , switchPromptOnly + -- * Slow, but general, implementations + , slowHeadE + ) where + +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Cont (ContT) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.RWS (RWST) +import Control.Monad.Trans.Writer (WriterT) +import Data.Align +import Data.Bifunctor +import Data.Coerce +import Data.Default +import Data.Dependent.Map (DMap, DSum (..)) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Compose +import Data.Functor.Product +import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..)) +import Data.FastMutableIntMap (PatchIntMap) +import Data.Foldable +import Data.Functor.Bind +import Data.Functor.Misc +import Data.Functor.Plus +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import Data.Semigroup (Semigroup, sconcat, stimes, (<>)) +import Data.Some (Some) +import qualified Data.Some as Some +import Data.String +import Data.These +import Data.Type.Coercion +import Reflex.FunctorMaybe +import Reflex.Patch +import qualified Reflex.Patch.MapWithMove as PatchMapWithMove + +import Debug.Trace (trace) + +-- | The 'Reflex' class contains all the primitive functionality needed for +-- Functional Reactive Programming (FRP). The @/t/@ type parameter indicates +-- which "timeline" is in use. Timelines are fully-independent FRP contexts, +-- and the type of the timeline determines the FRP engine to be used. For most +-- purposes, the 'Reflex.Spider' implementation is recommended. +class ( MonadHold t (PushM t) + , MonadSample t (PullM t) + , MonadFix (PushM t) + , Functor (Dynamic t) + , Applicative (Dynamic t) -- Necessary for GHC <= 7.8 + , Monad (Dynamic t) + ) => Reflex t where + -- | A container for a value that can change over time. 'Behavior's can be + -- sampled at will, but it is not possible to be notified when they change + data Behavior t :: * -> * + -- | A stream of occurrences. During any given frame, an 'Event' is either + -- occurring or not occurring; if it is occurring, it will contain a value of + -- the given type (its "occurrence type") + data Event t :: * -> * + -- | A container for a value that can change over time and allows + -- notifications on changes. Basically a combination of a 'Behavior' and an + -- 'Event', with a rule that the 'Behavior' will change if and only if the + -- 'Event' fires. + data Dynamic t :: * -> * + -- | An 'Incremental' is a more general form of a 'Dynamic'. + -- Instead of always fully replacing the value, only parts of it can be patched. + -- This is only needed for performance critical code via `mergeIncremental` to make small + -- changes to large values. + data Incremental t :: * -> * + -- | A monad for doing complex push-based calculations efficiently + type PushM t :: * -> * + -- | A monad for doing complex pull-based calculations efficiently + type PullM t :: * -> * + -- | An 'Event' with no occurrences + never :: Event t a + -- | Create a 'Behavior' that always has the given value + constant :: a -> Behavior t a --TODO: Refactor to use 'pure' from Applicative instead; however, we need to make sure that encouraging Applicative-style use of 'Behavior's doesn't have a negative performance impact + -- | Create an 'Event' from another 'Event'; the provided function can sample + -- 'Behavior's and hold 'Event's, and use the results to produce a occurring + -- (Just) or non-occurring (Nothing) result + push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b + -- | Like 'push' but intended for functions that the implementation can consider cheap to compute for performance considerations. WARNING: The function passed to 'pushCheap' may be run multiple times without any caching. + pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b + -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be + -- recomputed whenever any of the read 'Behavior's changes + pull :: PullM t a -> Behavior t a + -- | Merge a collection of events; the resulting 'Event' will only occur if at + -- least one input event is occurring, and will contain all of the input keys + -- that are occurring simultaneously + merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty + -- | Efficiently fan-out an event to many destinations. This function should + -- be partially applied, and then the result applied repeatedly to create + -- child events + fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it + -- | Create an 'Event' that will occur whenever the currently-selected input + -- 'Event' occurs + switch :: Behavior t (Event t a) -> Event t a + -- | Create an 'Event' that will occur whenever the input event is occurring + -- and its occurrence value, another 'Event', is also occurring + coincidence :: Event t (Event t a) -> Event t a + -- | Extract the 'Behavior' of a 'Dynamic'. + current :: Dynamic t a -> Behavior t a + -- | Extract the 'Event' of the 'Dynamic'. + updated :: Dynamic t a -> Event t a + -- | Create a new 'Dynamic'. The given 'PullM' must always return the most + -- recent firing of the given 'Event', if any. + unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a + -- | Create a new 'Incremental'. The given "PullM"'s value must always change + -- in the same way that the accumulated application of patches would change + -- that value. + unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p + -- | Create a merge whose parents can change over time + mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity) + -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental + mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity) + -- | Extract the 'Behavior' component of an 'Incremental' + currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p) + -- | Extract the 'Event' component of an 'Incremental' + updatedIncremental :: Patch p => Incremental t p -> Event t p + -- | Convert an 'Incremental' to a 'Dynamic' + incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p) + -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its + -- occurrence type + behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b) + -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its + -- occurrence type + eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b) + -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its + -- occurrence type + dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b) + mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a) + fanInt :: Event t (IntMap a) -> EventSelectorInt t a + +--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on +mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a) +mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never + +-- | Coerce a 'Behavior' between representationally-equivalent value types +coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b +coerceBehavior = coerceWith $ behaviorCoercion Coercion + +-- | Coerce an 'Event' between representationally-equivalent occurrence types +coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b +coerceEvent = coerceWith $ eventCoercion Coercion + +-- | Coerce a 'Dynamic' between representationally-equivalent value types +coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b +coerceDynamic = coerceWith $ dynamicCoercion Coercion + +-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior' +-- __must__ change when and only when the 'Event' fires, such that the +-- 'Behavior''s value is always equal to the most recent firing of the 'Event'; +-- if this is not the case, the resulting 'Dynamic' will behave +-- nondeterministically. +unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a +unsafeDynamic = unsafeBuildDynamic . sample + +-- | Construct a 'Dynamic' value that never changes +constDyn :: Reflex t => a -> Dynamic t a +constDyn = pure + +instance (Reflex t, Default a) => Default (Dynamic t a) where + def = pure def + +-- | 'MonadSample' designates monads that can read the current value of a +-- 'Behavior'. This includes both 'PullM' and 'PushM'. +class (Applicative m, Monad m) => MonadSample t m | m -> t where + -- | Get the current value in the 'Behavior' + sample :: Behavior t a -> m a + +-- | 'MonadHold' designates monads that can create new 'Behavior's based on +-- 'Event's; usually this will be 'PushM' or a monad based on it. 'MonadHold' +-- is required to create any stateful computations with Reflex. +class MonadSample t m => MonadHold t m where + -- | Create a new 'Behavior' whose value will initially be equal to the given + -- value and will be updated whenever the given 'Event' occurs. The update + -- takes effect immediately after the 'Event' occurs; if the occurrence that + -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample + -- the 'Behavior', it will see the __old__ value of the 'Behavior', not the new + -- one. + hold :: a -> Event t a -> m (Behavior t a) + default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a) + hold v0 = lift . hold v0 + -- | Create a 'Dynamic' value using the given initial value that changes every + -- time the 'Event' occurs. + holdDyn :: a -> Event t a -> m (Dynamic t a) + default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a) + holdDyn v0 = lift . holdDyn v0 + -- | Create an 'Incremental' value using the given initial value that changes + -- every time the 'Event' occurs. + holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p) + default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p) + holdIncremental v0 = lift . holdIncremental v0 + buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a) + {- + default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a) + buildDynamic getV0 = lift . buildDynamic getV0 + -} + -- | Create a new 'Event' that only occurs only once, on the first occurrence of + -- the supplied 'Event'. + headE :: Event t a -> m (Event t a) + +accumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> p) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o +accumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t p) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o +accumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> Maybe p) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o +accumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p)) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumMaybeMIncremental f z e = do + rec let e' = flip push e $ \o -> do + v <- sample $ currentIncremental d' + f v o + d' <- holdIncremental z e' + return d' +mapAccumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o +mapAccumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o +mapAccumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o +mapAccumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumMaybeMIncremental f z e = do + rec let e' = flip push e $ \o -> do + v <- sample $ currentIncremental d' + result <- f v o + return $ case result of + (Nothing, Nothing) -> Nothing + _ -> Just result + d' <- holdIncremental z $ fmapMaybe fst e' + return (d', fmapMaybe snd e') + +slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) +slowHeadE e = do + rec be <- hold e $ fmapCheap (const never) e' + let e' = switch be + return e' + +-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a +-- key. This is much more efficient than filtering for each key with +-- 'fmapMaybe'. +newtype EventSelector t k = EventSelector + { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is + -- determined by the type of the key, so this can be used to fan-out + -- 'Event's whose sub-'Event's have different types. + -- + -- Using 'EventSelector's and the 'fan' primitive is far more efficient than + -- (but equivalent to) using 'fmapMaybe' to select only the relevant + -- occurrences of an 'Event'. + select :: forall a. k a -> Event t a + } + +newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a } + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +instance MonadSample t m => MonadSample t (ReaderT r m) where + sample = lift . sample + +instance MonadHold t m => MonadHold t (ReaderT r m) where + hold a0 = lift . hold a0 + holdDyn a0 = lift . holdDyn a0 + holdIncremental a0 = lift . holdIncremental a0 + buildDynamic a0 = lift . buildDynamic a0 + headE = lift . headE + +instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where + sample = lift . sample + +instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where + hold a0 = lift . hold a0 + holdDyn a0 = lift . holdDyn a0 + holdIncremental a0 = lift . holdIncremental a0 + buildDynamic a0 = lift . buildDynamic a0 + headE = lift . headE + +instance MonadSample t m => MonadSample t (StateT s m) where + sample = lift . sample + +instance MonadHold t m => MonadHold t (StateT s m) where + hold a0 = lift . hold a0 + holdDyn a0 = lift . holdDyn a0 + holdIncremental a0 = lift . holdIncremental a0 + buildDynamic a0 = lift . buildDynamic a0 + headE = lift . headE + +instance MonadSample t m => MonadSample t (ExceptT e m) where + sample = lift . sample + +instance MonadHold t m => MonadHold t (ExceptT e m) where + hold a0 = lift . hold a0 + holdDyn a0 = lift . holdDyn a0 + holdIncremental a0 = lift . holdIncremental a0 + buildDynamic a0 = lift . buildDynamic a0 + headE = lift . headE + +instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where + sample = lift . sample + +instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where + hold a0 = lift . hold a0 + holdDyn a0 = lift . holdDyn a0 + holdIncremental a0 = lift . holdIncremental a0 + buildDynamic a0 = lift . buildDynamic a0 + headE = lift . headE + +instance MonadSample t m => MonadSample t (ContT r m) where + sample = lift . sample + +instance MonadHold t m => MonadHold t (ContT r m) where + hold a0 = lift . hold a0 + holdDyn a0 = lift . holdDyn a0 + holdIncremental a0 = lift . holdIncremental a0 + buildDynamic a0 = lift . buildDynamic a0 + headE = lift . headE + +-------------------------------------------------------------------------------- +-- Convenience functions +-------------------------------------------------------------------------------- + +-- | Create an 'Event' from another 'Event'. The provided function can sample +-- 'Behavior's and hold 'Event's. +pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b +pushAlways f = push (fmap Just . f) + +-- | Flipped version of 'fmap'. +ffor :: Functor f => f a -> (a -> b) -> f b +ffor = flip fmap + +-- | Rotated version of 'liftA2'. +ffor2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c +ffor2 a b f = liftA2 f a b + +-- | Rotated version of 'liftA3'. +ffor3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d +ffor3 a b c f = liftA3 f a b c + +instance Reflex t => Applicative (Behavior t) where + pure = constant + f <*> x = pull $ sample f `ap` sample x + _ *> b = b + a <* _ = a + +instance Reflex t => Apply (Behavior t) where + (<.>) = (<*>) + +instance Reflex t => Bind (Behavior t) where + (>>-) = (>>=) + +instance (Reflex t, Fractional a) => Fractional (Behavior t a) where + (/) = liftA2 (/) + fromRational = pure . fromRational + recip = fmap recip + +instance Reflex t => Functor (Behavior t) where + fmap f = pull . fmap f . sample + +instance (Reflex t, IsString a) => IsString (Behavior t a) where + fromString = pure . fromString + +instance Reflex t => Monad (Behavior t) where + a >>= f = pull $ sample a >>= sample . f + -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above. + return = constant + fail = error "Monad (Behavior t) does not support fail" + +instance (Reflex t, Monoid a) => Monoid (Behavior t a) where + mempty = constant mempty + mappend a b = pull $ liftM2 mappend (sample a) (sample b) + mconcat = pull . fmap mconcat . mapM sample + +instance (Reflex t, Num a) => Num (Behavior t a) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + abs = fmap abs + fromInteger = pure . fromInteger + negate = fmap negate + signum = fmap signum + +instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where + a <> b = pull $ liftM2 (<>) (sample a) (sample b) + sconcat = pull . fmap sconcat . mapM sample +#if MIN_VERSION_semigroups(0,17,0) + stimes n = fmap $ stimes n +#else + times1p n = fmap $ times1p n +#endif + +-- | Flipped version of 'fmapMaybe'. +fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b +fforMaybe = flip fmapMaybe + +-- | Filter 'f a' using the provided predicate. +-- Relies on 'fforMaybe'. +ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a +ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing + +-- | Filter 'Left's from 'f (Either a b)' into 'a'. +filterLeft :: FunctorMaybe f => f (Either a b) -> f a +filterLeft = fmapMaybe (either Just (const Nothing)) + +-- | Filter 'Right's from 'f (Either a b)' into 'b'. +filterRight :: FunctorMaybe f => f (Either a b) -> f b +filterRight = fmapMaybe (either (const Nothing) Just) + +-- | Left-biased event union (prefers left event on simultaneous +-- occurrence). +instance Reflex t => Alt (Event t) where + ev1 ev2 = leftmost [ev1, ev2] + +-- | 'Event' intersection (convenient interface to 'coincidence'). +instance Reflex t => Apply (Event t) where + evf <.> evx = coincidence (fmap (<$> evx) evf) + +-- | 'Event' intersection (convenient interface to 'coincidence'). +instance Reflex t => Bind (Event t) where + evx >>- f = coincidence (f <$> evx) + join = coincidence + +instance Reflex t => Functor (Event t) where + {-# INLINE fmap #-} + fmap f = fmapMaybe $ Just . f + {-# INLINE (<$) #-} + x <$ e = fmapCheap (const x) e + +instance Reflex t => FunctorMaybe (Event t) where + {-# INLINE fmapMaybe #-} + fmapMaybe f = push $ return . f + +-- | Never: @'zero' = 'never'@. +instance Reflex t => Plus (Event t) where + zero = never + +-- | Replace each occurrence value of the 'Event' with the value of the +-- 'Behavior' at the time of that occurrence. +tag :: Reflex t => Behavior t b -> Event t a -> Event t b +tag b = pushAlways $ \_ -> sample b + +-- | Replace each occurrence value of the 'Event' with the value of the +-- 'Behavior' at that time; if it is 'Just', fire with the contained value; if +-- it is 'Nothing', drop the occurrence. +tagMaybe :: Reflex t => Behavior t (Maybe b) -> Event t a -> Event t b +tagMaybe b = push $ \_ -> sample b + +-- | Create a new 'Event' that combines occurrences of supplied 'Event' with the +-- current value of the 'Behavior'. +attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b) +attach = attachWith (,) + +-- | Create a new 'Event' that occurs when the supplied 'Event' occurs by +-- combining it with the current value of the 'Behavior'. +attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c +attachWith f = attachWithMaybe $ \a b -> Just $ f a b + +-- | Create a new 'Event' by combining each occurrence with the current value of +-- the 'Behavior'. The occurrence is discarded if the combining function returns +-- Nothing +attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c +attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b + +-- | Create a new 'Event' that occurs on all but the first occurrence of the +-- supplied 'Event'. +tailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a) +tailE e = snd <$> headTailE e + +-- | Create a tuple of two 'Event's with the first one occurring only the first +-- time the supplied 'Event' occurs and the second occurring on all but the first +-- occurrence. +headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a) +headTailE e = do + eHead <- headE e + be <- hold never $ fmap (const e) eHead + return (eHead, switch be) + +-- | Take the streak of occurrences starting at the current time for which the +-- event returns 'True'. +-- +-- Starting at the current time, fire all the occurrences of the 'Event' for +-- which the given predicate returns 'True'. When first 'False' is returned, +-- do not fire, and permanently stop firing, even if 'True' values would have +-- been encountered later. +takeWhileE + :: forall t m a + . (Reflex t, MonadFix m, MonadHold t m) + => (a -> Bool) + -> Event t a + -> m (Event t a) +takeWhileE f = takeWhileJustE $ \v -> guard (f v) $> v + +-- | Take the streak of occurrences starting at the current time for which the +-- event returns 'Just b'. +-- +-- Starting at the current time, fire all the occurrences of the 'Event' for +-- which the given predicate returns 'Just b'. When first 'Nothing' is returned, +-- do not fire, and permanently stop firing, even if 'Just b' values would have +-- been encountered later. +takeWhileJustE + :: forall t m a b + . (Reflex t, MonadFix m, MonadHold t m) + => (a -> Maybe b) + -> Event t a + -> m (Event t b) +takeWhileJustE f e = do + rec let (eBad, eTrue) = fanEither $ ffor e' $ \a -> case f a of + Nothing -> Left never + Just b -> Right b + eFirstBad <- headE eBad + e' <- switchHold e eFirstBad + return eTrue + +-- | Drop the streak of occurrences starting at the current time for which the +-- event returns 'True'. +-- +-- Starting at the current time, do not fire all the occurrences of the 'Event' +-- for which the given predicate returns 'True'. When 'False' is first +-- returned, do fire, and permanently continue firing, even if 'True' values +-- would have been encountered later. +dropWhileE + :: forall t m a + . (Reflex t, MonadFix m, MonadHold t m) + => (a -> Bool) + -> Event t a + -> m (Event t a) +dropWhileE f e = snd <$> takeDropWhileJustE (\v -> guard (f v) $> v) e + +-- | Both take and drop the streak of occurrences starting at the current time +-- for which the event returns 'Just b'. +-- +-- For the left event, starting at the current time, fire all the occurrences +-- of the 'Event' for which the given function returns 'Just b'. When +-- 'Nothing' is returned, do not fire, and permanently stop firing, even if +-- 'Just b' values would have been encountered later. +-- +-- For the right event, do not fire until the first occurrence where the given +-- function returns 'Nothing', and fire that one and all subsequent +-- occurrences. Even if the function would have again returned 'Just b', keep +-- on firing. +takeDropWhileJustE + :: forall t m a b + . (Reflex t, MonadFix m, MonadHold t m) + => (a -> Maybe b) + -> Event t a + -> m (Event t b, Event t a) +takeDropWhileJustE f e = do + rec let (eBad, eGood) = fanEither $ ffor e' $ \a -> case f a of + Nothing -> Left () + Just b -> Right b + eFirstBad <- headE eBad + e' <- switchHold e (never <$ eFirstBad) + eRest <- switchHoldPromptOnly never (e <$ eFirstBad) + return (eGood, eRest) + +-- | Split the supplied 'Event' into two individual 'Event's occurring at the +-- same time with the respective values from the tuple. +splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b) +splitE e = (fmap fst e, fmap snd e) + +-- | Print the supplied 'String' and the value of the 'Event' on each +-- occurrence. This should /only/ be used for debugging. +-- +-- Note: As with Debug.Trace.trace, the message will only be printed if the +-- 'Event' is actually used. +traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a +traceEvent s = traceEventWith $ \x -> s <> ": " <> show x + +-- | Print the output of the supplied function on each occurrence of the +-- 'Event'. This should /only/ be used for debugging. +-- +-- Note: As with Debug.Trace.trace, the message will only be printed if the +-- 'Event' is actually used. +traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a +traceEventWith f = push $ \x -> trace (f x) $ return $ Just x + +instance (Semigroup a, Reflex t) => Semigroup (Event t a) where + (<>) = alignWith (mergeThese (<>)) + sconcat = fmap sconcat . mergeList . toList +#if MIN_VERSION_semigroups(0,17,0) + stimes n = fmap $ stimes n +#else + times1p n = fmap $ times1p n +#endif + +instance (Semigroup a, Reflex t) => Monoid (Event t a) where + mempty = never + mappend = (<>) + mconcat = fmap sconcat . mergeList + +-- | Create a new 'Event' that occurs if at least one of the 'Event's in the +-- list occurs. If multiple occur at the same time they are folded from the left +-- with the given function. +{-# INLINE mergeWith #-} +mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a +mergeWith = mergeWith' id + +{-# INLINE mergeWith' #-} +mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b +mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f) + . mergeInt + . IntMap.fromDistinctAscList + $ zip [0 :: Int ..] es + +-- | Create a new 'Event' that occurs if at least one of the 'Event's in the +-- list occurs. If multiple occur at the same time the value is the value of the +-- leftmost event. +{-# INLINE leftmost #-} +leftmost :: Reflex t => [Event t a] -> Event t a +leftmost = mergeWith const + +-- | Create a new 'Event' that occurs if at least one of the 'Event's in the +-- list occurs and has a list of the values of all 'Event's occurring at that +-- time. +mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a) +mergeList [] = never +mergeList es = mergeWithFoldCheap' id es + +unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p' +unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a + +-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that +-- occurs if at least one of them occurs and has a map of values of all 'Event's +-- occurring at that time. +mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a) +mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap + +-- | Like 'mergeMap' but for 'IntMap'. +mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a) +mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap + +-- | Create a merge whose parents can change over time +mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a) +mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id) + +-- | Create a merge whose parents can change over time +mergeIntMapIncremental :: Reflex t => Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a) +mergeIntMapIncremental = fmap dmapToIntMap . mergeIncremental . unsafeMapIncremental intMapWithFunctorToDMap (const2IntPatchDMapWith id) + +-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental +mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a) +mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id) + +-- | Split the event into separate events for 'Left' and 'Right' values. +fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b) +fanEither e = + let justLeft = either Just (const Nothing) + justRight = either (const Nothing) Just + in (fmapMaybe justLeft e, fmapMaybe justRight e) + +-- | Split the event into separate events for 'This' and 'That' values, +-- allowing them to fire simultaneously when the input value is 'These'. +fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b) +fanThese e = + let this (This x) = Just x + this (These x _) = Just x + this _ = Nothing + that (That y) = Just y + that (These _ y) = Just y + that _ = Nothing + in (fmapMaybe this e, fmapMaybe that e) + +-- | Split the event into an 'EventSelector' that allows efficient selection of +-- the individual 'Event's. +fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a) +fanMap = fan . fmap mapToDMap + +-- | Switches to the new event whenever it receives one. Only the old event is +-- considered the moment a new one is switched in; the output event will fire at +-- that moment only if the old event does. +-- +-- Because the simultaneous firing case is irrelevant, this function imposes +-- laxer "timing requirements" on the overall circuit, avoiding many potential +-- cyclic dependency / metastability failures. It's also more performant. Use +-- this rather than 'switchHoldPromptly' and 'switchHoldPromptOnly' unless you +-- are absolutely sure you need to act on the new event in the coincidental +-- case. +switchHold :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) +switchHold ea0 eea = switch <$> hold ea0 eea + +-- | Switches to the new event whenever it receives one. Whenever a new event is +-- provided, if it is firing, its value will be the resulting event's value; if +-- it is not firing, but the old one is, the old one's value will be used. +-- +-- 'switchHold', by always forwarding the old event the moment it is switched +-- out, avoids many potential cyclic dependency problems / metastability +-- problems. It's also more performant. Use it instead unless you are sure you +-- cannot. +switchHoldPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) +switchHoldPromptly ea0 eea = do + bea <- hold ea0 eea + let eLag = switch bea + eCoincidences = coincidence eea + return $ leftmost [eCoincidences, eLag] + +-- | switches to a new event whenever it receives one. At the moment of +-- switching, the old event will be ignored if it fires, and the new one will be +-- used if it fires; this is the opposite of 'switch', which will use only the +-- old value. +-- +-- 'switchHold', by always forwarding the old event the moment it is switched +-- out, avoids many potential cyclic dependency problems / metastability +-- problems. It's also more performant. Use it instead unless you are sure you +-- cannot. +switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) +switchHoldPromptOnly e0 e' = do + eLag <- switch <$> hold e0 e' + return $ coincidence $ leftmost [e', eLag <$ eLag] + +-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions. +coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v) +coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case + Nothing -> fmapCheap (const Nothing) e + Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e] + +-- | See 'coincidencePatchMap' +coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v) +coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case + Nothing -> fmapCheap (const Nothing) e + Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e] + +-- | See 'coincidencePatchMap' +coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v) +coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of + PatchMapWithMove.From_Delete -> fforCheap e $ \_ -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete } + PatchMapWithMove.From_Move k -> fforCheap e $ \_ -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k } + PatchMapWithMove.From_Insert ev -> leftmost + [ fforCheap ev $ \v -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v } + , fforCheap e $ \_ -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete } + ] + +switchHoldPromptOnlyIncremental + :: forall t m p pt w + . ( Reflex t + , MonadHold t m + , Patch (p (Event t w)) + , PatchTarget (p (Event t w)) ~ pt (Event t w) + , Patch (p w) + , PatchTarget (p w) ~ pt w + , Monoid (pt w) + ) + => (Incremental t (p (Event t w)) -> Event t (pt w)) + -> (Event t (p (Event t w)) -> Event t (p w)) + -> pt (Event t w) + -> Event t (p (Event t w)) + -> m (Event t (pt w)) +switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do + lag <- mergePatchIncremental <$> holdIncremental e0 e' + pure $ ffor (align lag (coincidencePatch e')) $ \case + This old -> old + That new -> new `applyAlways` mempty + These old new -> new `applyAlways` old + +instance Reflex t => Align (Event t) where + nil = never + align = alignEventWithMaybe Just + +-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and +-- the 'Behavior' is true at the time of occurrence. +gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a +gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing + +-- | Create a new behavior given a starting behavior and switch to the behavior +-- carried by the event when it fires. +switcher :: (Reflex t, MonadHold t m) + => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a) +switcher b eb = pull . (sample <=< sample) <$> hold b eb + +instance (Reflex t, IsString a) => IsString (Dynamic t a) where + fromString = pure . fromString + +-- | Combine two 'Dynamic's. The result will change whenever either (or both) +-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@. +zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b) +zipDyn = zipDynWith (,) + +-- | Combine two 'Dynamic's with a combining function. The result will change +-- whenever either (or both) input 'Dynamic' changes. +-- More efficient than 'liftA2'. +zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c +zipDynWith f da db = + let eab = align (updated da) (updated db) + ec = flip push eab $ \o -> do + (a, b) <- case o of + This a -> do + b <- sample $ current db + return (a, b) + That b -> do + a <- sample $ current da + return (a, b) + These a b -> return (a, b) + return $ Just $ f a b + in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec + +instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where + (<>) = zipDynWith (<>) +#if MIN_VERSION_semigroups(0,17,0) + stimes n = fmap $ stimes n +#else + times1p n = fmap $ times1p n +#endif + +instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where + mconcat = distributeListOverDynWith mconcat + mempty = constDyn mempty + mappend = zipDynWith mappend + +-- | This function converts a 'DMap' whose elements are 'Dynamic's into a +-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same +-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators. +distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity) +distributeDMapOverDynPure dm = case DMap.toList dm of + [] -> constDyn DMap.empty + [k :=> v] -> fmap (DMap.singleton k . Identity) v + _ -> + let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm + edmPre = merge $ DMap.map updated dm + result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do + olds <- sample $ current result + return $ DMap.unionWithKey (\_ _ new -> new) olds news + in result + +-- | Convert a list of 'Dynamic's into a 'Dynamic' list. +distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a] +distributeListOverDyn = distributeListOverDynWith id + +-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's +distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b +distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..] + +-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs +-- unless the second supplied 'Event' occurs simultaneously. +difference :: Reflex t => Event t a -> Event t b -> Event t a +difference = alignEventWithMaybe $ \case + This a -> Just a + _ -> Nothing + +alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c +alignEventWithMaybe f ea eb = + fmapMaybe (f <=< dmapToThese) + $ merge + $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] + +filterEventKey + :: forall t m k v a. + ( Reflex t + , MonadFix m + , MonadHold t m + , GEq k + ) + => k a + -> Event t (DSum k v) + -> m (Event t (v a)) +filterEventKey k kv' = do + let f :: DSum k v -> Maybe (v a) + f (newK :=> newV) = case newK `geq` k of + Just Refl -> Just newV + Nothing -> Nothing + takeWhileJustE f kv' + + +factorEvent + :: forall t m k v a. + ( Reflex t + , MonadFix m + , MonadHold t m + , GEq k + ) + => k a + -> Event t (DSum k v) + -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v)))) +factorEvent k0 kv' = do + key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv' + let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case + Some.This oldKey -> case newKey `geq` oldKey of + Just Refl -> return Nothing + Nothing -> do + newInner <- filterEventKey newKey kv' + return $ Just $ newKey :=> Pair newVal (Compose newInner) + eInitial <- filterEventKey k0 kv' + return (eInitial, update) + +-------------------------------------------------------------------------------- +-- Accumulator +-------------------------------------------------------------------------------- + +-- | An 'Accumulator' type can be built by accumulating occurrences of an +-- 'Event'. +#if __GLASGOW_HASKELL__ < 802 +{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-} +{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-} +{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-} +{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-} +#endif +class Reflex t => Accumulator t f | f -> t where + accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a) + accum f = accumMaybe $ \v o -> Just $ f v o + accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a) + accumM f = accumMaybeM $ \v o -> Just <$> f v o + accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a) + accumMaybe f = accumMaybeM $ \v o -> return $ f v o + accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a) + mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c) + mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o + mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c) + mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o + mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c) + mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o + mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c) + +accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a) +accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o +accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a) +accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o +accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a) +accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o +accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a) +accumMaybeMDyn f z e = do + rec let e' = flip push e $ \o -> do + v <- sample $ current d' + f v o + d' <- holdDyn z e' + return d' +mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c) +mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o +mapAccumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c) +mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o +mapAccumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c) +mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o +mapAccumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c) +mapAccumMaybeMDyn f z e = do + rec let e' = flip push e $ \o -> do + v <- sample $ current d' + result <- f v o + return $ case result of + (Nothing, Nothing) -> Nothing + _ -> Just result + d' <- holdDyn z $ fmapMaybe fst e' + return (d', fmapMaybe snd e') + +{-# INLINE accumB #-} +accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a) +accumB f = accumMaybeB $ \v o -> Just $ f v o +{-# INLINE accumMB #-} +accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a) +accumMB f = accumMaybeMB $ \v o -> Just <$> f v o +{-# INLINE accumMaybeB #-} +accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a) +accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o +{-# INLINE accumMaybeMB #-} +accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a) +accumMaybeMB f z e = do + rec let e' = flip push e $ \o -> do + v <- sample d' + f v o + d' <- hold z e' + return d' +{-# INLINE mapAccumB #-} +mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c) +mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o +{-# INLINE mapAccumMB #-} +mapAccumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c) +mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o +{-# INLINE mapAccumMaybeB #-} +mapAccumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c) +mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o + +{-# INLINE mapAccumMaybeMB #-} +mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c) +mapAccumMaybeMB f z e = do + rec let e' = flip push e $ \o -> do + v <- sample d' + result <- f v o + return $ case result of + (Nothing, Nothing) -> Nothing + _ -> Just result + d' <- hold z $ fmapMaybe fst e' + return (d', fmapMaybe snd e') + +-- | Accumulate occurrences of an 'Event', producing an output occurrence each +-- time. Discard the underlying 'Accumulator'. +{-# INLINE mapAccum_ #-} +mapAccum_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c) +mapAccum_ f z e = do + (_, result) <- mapAccumB f z e + return result + +-- | Accumulate occurrences of an 'Event', possibly producing an output +-- occurrence each time. Discard the underlying 'Accumulator'. +{-# INLINE mapAccumMaybe_ #-} +mapAccumMaybe_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c) +mapAccumMaybe_ f z e = do + (_, result) <- mapAccumMaybeB f z e + return result + +-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing +-- an output occurrence each time. Discard the underlying 'Accumulator'. +{-# INLINE mapAccumM_ #-} +mapAccumM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c) +mapAccumM_ f z e = do + (_, result) <- mapAccumMB f z e + return result + +-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly +-- producing an output occurrence each time. Discard the underlying +-- 'Accumulator'. +{-# INLINE mapAccumMaybeM_ #-} +mapAccumMaybeM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c) +mapAccumMaybeM_ f z e = do + (_, result) <- mapAccumMaybeMB f z e + return result + +instance Reflex t => Accumulator t (Dynamic t) where + accumMaybeM = accumMaybeMDyn + mapAccumMaybeM = mapAccumMaybeMDyn + +instance Reflex t => Accumulator t (Behavior t) where + accumMaybeM = accumMaybeMB + mapAccumMaybeM = mapAccumMaybeMB + +instance Reflex t => Accumulator t (Event t) where + accumMaybeM f z e = updated <$> accumMaybeM f z e + mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e + +-- | Create a new 'Event' by combining each occurrence with the next value of the +-- list using the supplied function. If the list runs out of items, all +-- subsequent 'Event' occurrences will be ignored. +zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c) +zipListWithEvent f l e = do + let f' a b = case a of + h:t -> (Just t, Just $ f h b) + _ -> (Nothing, Nothing) --TODO: Unsubscribe the event? + mapAccumMaybe_ f' l e + +-- | Assign a number to each occurrence of the given 'Event', starting from 0 +{-# INLINE numberOccurrences #-} +numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a)) +numberOccurrences = numberOccurrencesFrom 0 + +-- | Assign a number to each occurrence of the given 'Event' +{-# INLINE numberOccurrencesFrom #-} +numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a)) +numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a))) + +-- | Assign a number to each occurrence of the given 'Event'; discard the occurrences' values +{-# INLINE numberOccurrencesFrom_ #-} +numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b) +numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n)) + +-- | This is used to sample the value of a 'Behavior' using an 'Event'. +-- +-- The '<@>' operator is intended to be used in conjunction with +-- the 'Applicative' instance for 'Behavior'. +-- +-- This is useful when we want to combine the values of one 'Event' and +-- the value of several 'Behavior's at the time the 'Event' is firing. +-- +-- If we have: +-- +-- > f :: a -> b -> c -> d +-- > b1 :: Behavior t a +-- > b2 :: Behavior t b +-- > e :: Event t c +-- +-- then we can do: +-- +-- > f <$> b1 <*> b2 <@> e :: Event t d +-- +-- in order to apply the function 'f' to the relevant values. +-- +-- The alternative would be something like: +-- +-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d +-- +-- or a variation involing a custom data type to hold the combination of +-- 'Behavior's even when that combination might only ever be used by 'f'. +-- +-- A more suggestive example might be: +-- +-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState) +-- +(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b +(<@>) b = push $ \x -> do + f <- sample b + return . Just . f $ x +infixl 4 <@> + +-- | An version of '<@>' that does not use the value of the 'Event'. +-- +-- Alternatively, it is 'tag' in operator form. +-- +-- This is useful when we want to combine the values of several +-- 'Behavior's at particular points in time using an 'Applicative' +-- style syntax. +-- +-- If we have: +-- +-- > g :: a -> b -> d +-- > b1 :: Behavior t a +-- > b2 :: Behavior t b +-- > e :: Event t c +-- +-- where 'e' is firing at the points in time of interest. +-- +-- Then we can use '<@': +-- +-- > g <$> b1 <*> b2 <@ e :: Event t d +-- +-- to combine the values of 'b1' and 'b2' at each of those points of time, +-- with the function 'g' being used to combine the values. +-- +-- This is the same as '<@>' except that the 'Event' is being used only +-- to act as a trigger. +(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b +(<@) = tag +infixl 4 <@ + +------------------ +-- Cheap Functions +------------------ + +{-# INLINE pushAlwaysCheap #-} +pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b +pushAlwaysCheap f = pushCheap (fmap Just . f) + +{-# INLINE fmapMaybeCheap #-} +fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b +fmapMaybeCheap f = pushCheap $ return . f + +{-# INLINE fforMaybeCheap #-} +fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b +fforMaybeCheap = flip fmapMaybeCheap + +{-# INLINE fforCheap #-} +fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b +fforCheap = flip fmapCheap + +{-# INLINE fmapCheap #-} +fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b +fmapCheap f = pushCheap $ return . Just . f + +{-# INLINE tagCheap #-} +tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b +tagCheap b = pushAlwaysCheap $ \_ -> sample b + +{-# INLINE mergeWithCheap #-} +mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a +mergeWithCheap = mergeWithCheap' id + +{-# INLINE mergeWithCheap' #-} +mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b +mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f + +{-# INLINE mergeWithFoldCheap' #-} +mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b +mergeWithFoldCheap' f es = + fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems) + . mergeInt + . IntMap.fromDistinctAscList + $ zip [0 :: Int ..] es + +-------------------------------------------------------------------------------- +-- Deprecated functions +-------------------------------------------------------------------------------- + +-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's +-- occurs. If both occur at the same time they are combined using 'mappend'. +{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-} +appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a +appendEvents = alignWith $ mergeThese mappend + +-- | Alias for 'headE' +{-# DEPRECATED onceE "Use 'headE' instead" #-} +onceE :: MonadHold t m => Event t a -> m (Event t a) +onceE = headE + +-- | Run both sides of a 'These' monadically, combining the results. +{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-} +#ifdef USE_TEMPLATE_HASKELL +{-# ANN sequenceThese "HLint: ignore Use fmap" #-} +#endif +sequenceThese :: Monad m => These (m a) (m b) -> m (These a b) +sequenceThese t = case t of + This ma -> fmap This ma + These ma mb -> liftM2 These ma mb + That mb -> fmap That mb + +{-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-} +switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) +switchPromptly = switchHoldPromptly +{-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-} +switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) +switchPromptOnly = switchHoldPromptOnly diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Collection.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.Collection + ( + -- * Widgets on Collections + listHoldWithKey + , listWithKey + , listWithKey' + , listWithKeyShallowDiff + , listViewWithKey + , selectViewListWithKey + , selectViewListWithKey_ + -- * List Utils + , list + , simpleList + ) where + +import Control.Monad.Identity +import Data.Align +import Data.Functor.Misc +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Map.Misc +import Data.These + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.Dynamic +import Reflex.PostBuild.Class + +listHoldWithKey + :: forall t m k v a + . (Ord k, Adjustable t m, MonadHold t m) + => Map k v + -> Event t (Map k (Maybe v)) + -> (k -> v -> m a) + -> m (Dynamic t (Map k a)) +listHoldWithKey m0 m' f = do + let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0 + dm' = fmap + (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey + (\k v -> ComposeMaybe $ fmap (f k) v) + ) + m' + (a0, a') <- sequenceDMapWithAdjust dm0 dm' + + --TODO: Move the dmapToMap to the righthand side so it doesn't get + --fully redone every time + fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' + +--TODO: Something better than Dynamic t (Map k v) - we want something +--where the Events carry diffs, not the whole value +listWithKey + :: forall t k v m a + . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) + => Dynamic t (Map k v) + -> (k -> Dynamic t v -> m a) + -> m (Dynamic t (Map k a)) +listWithKey vals mkChild = do + postBuild <- getPostBuild + let childValChangedSelector = fanMap $ updated vals + + -- We keep track of changes to children values in the mkChild + -- function we pass to listHoldWithKey The other changes we need + -- to keep track of are child insertions and + -- deletions. diffOnlyKeyChanges keeps track of insertions and + -- deletions but ignores value changes, since they're already + -- accounted for. + diffOnlyKeyChanges olds news = + flip Map.mapMaybe (align olds news) $ \case + This _ -> Just Nothing + These _ _ -> Nothing + That new -> Just $ Just new + rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals + let changeVals :: Event t (Map k (Maybe v)) + changeVals = + attachWith diffOnlyKeyChanges (current sentVals) $ leftmost + [ updated vals + + -- TODO: This should probably be added to the + -- attachWith, not to the updated; if we were using + -- diffMap instead of diffMapNoEq, I think it might not + -- work + , tag (current vals) postBuild + ] + listHoldWithKey Map.empty changeVals $ \k v -> + mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k) + +{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-} +listWithKey' + :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) + => Map k v + -> Event t (Map k (Maybe v)) + -> (k -> v -> Event t v -> m a) + -> m (Dynamic t (Map k a)) +listWithKey' = listWithKeyShallowDiff + +-- | Display the given map of items (in key order) using the builder +-- function provided, and update it with the given event. 'Nothing' +-- update entries will delete the corresponding children, and 'Just' +-- entries will create them if they do not exist or send an update +-- event to them if they do. +listWithKeyShallowDiff + :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) + => Map k v + -> Event t (Map k (Maybe v)) + -> (k -> v -> Event t v -> m a) + -> m (Dynamic t (Map k a)) +listWithKeyShallowDiff initialVals valsChanged mkChild = do + let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged + sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged + let relevantPatch patch _ = case patch of + + -- Even if we let a Nothing through when the element doesn't + -- already exist, this doesn't cause a problem because it is + -- ignored + Nothing -> Just Nothing + + -- We don't want to let spurious re-creations of items through + Just _ -> Nothing + listHoldWithKey + initialVals + (attachWith (flip (Map.differenceWith relevantPatch)) + (current sentVals) + valsChanged + ) + $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k + +--TODO: Something better than Dynamic t (Map k v) - we want something +--where the Events carry diffs, not the whole value +-- | Create a dynamically-changing set of Event-valued widgets. This +-- is like 'listWithKey', specialized for widgets returning @/Event t a/@. +-- 'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in +-- this scenario, but 'listViewWithKey' flattens this to +-- @/Event t (Map k a)/@ via 'switch'. +listViewWithKey + :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t (Map k v) + -> (k -> Dynamic t v -> m (Event t a)) + -> m (Event t (Map k a)) +listViewWithKey vals mkChild = + switch . fmap mergeMap <$> listViewWithKey' vals mkChild + +listViewWithKey' + :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t (Map k v) + -> (k -> Dynamic t v -> m a) + -> m (Behavior t (Map k a)) +listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild + +-- | Create a dynamically-changing set of widgets, one of which is +-- selected at any time. +selectViewListWithKey + :: forall t m k v a + . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t k + -- ^ Current selection key + -> Dynamic t (Map k v) + -- ^ Dynamic key/value map + -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) + -- ^ Function to create a widget for a given key from Dynamic value + -- and Dynamic Bool indicating if this widget is currently selected + -> m (Event t (k, a)) + -- ^ Event that fires when any child's return Event fires. Contains + -- key of an arbitrary firing widget. +selectViewListWithKey selection vals mkChild = do + -- For good performance, this value must be shared across all children + let selectionDemux = demux selection + selectChild <- listWithKey vals $ \k v -> do + let selected = demuxed selectionDemux k + selectSelf <- mkChild k v selected + return $ fmap ((,) k) selectSelf + return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild + +selectViewListWithKey_ + :: forall t m k v a + . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t k + -- ^ Current selection key + -> Dynamic t (Map k v) + -- ^ Dynamic key/value map + -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) + -- ^ Function to create a widget for a given key from Dynamic value + -- and Dynamic Bool indicating if this widget is currently selected + -> m (Event t k) + -- ^ Event that fires when any child's return Event fires. Contains + -- key of an arbitrary firing widget. +selectViewListWithKey_ selection vals mkChild = + fmap fst <$> selectViewListWithKey selection vals mkChild + +-- | Create a dynamically-changing set of widgets from a Dynamic +-- key/value map. Unlike the 'withKey' variants, the child widgets +-- are insensitive to which key they're associated with. +list + :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) + => Dynamic t (Map k v) + -> (Dynamic t v -> m a) + -> m (Dynamic t (Map k a)) +list dm mkChild = listWithKey dm (\_ dv -> mkChild dv) + +-- | Create a dynamically-changing set of widgets from a Dynamic list. +simpleList + :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) + => Dynamic t [v] + -> (Dynamic t v -> m a) + -> m (Dynamic t [a]) +simpleList xs mkChild = + fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap + (Map.fromList . zip [(1 :: Int) ..]) + xs diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -1,188 +1,181 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-} -module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update - , current - , updated - , constDyn - , holdDyn - , nubDyn - , count - , toggle - , switchPromptlyDyn - , tagDyn - , attachDyn - , attachDynWith - , attachDynWithMaybe - , mapDyn - , forDyn - , mapDynM - , foldDyn - , foldDynM - , foldDynMaybe - , foldDynMaybeM - , combineDyn - , collectDyn - , mconcatDyn - , distributeDMapOverDyn - , joinDyn - , joinDynThroughMap - , traceDyn - , traceDynWith - , splitDyn - , Demux - , demux - , getDemuxed - -- Things that probably aren't very useful: - , HList (..) - , FHList (..) - , distributeFHListOverDyn - -- Unsafe - , unsafeDynamic - ) where - -import Prelude hiding (mapM, mapM_) +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +-- | This module contains various functions for working with 'Dynamic' values. +-- 'Dynamic' and its primitives have been moved to the 'Reflex' class. +module Reflex.Dynamic + ( -- * Basics + Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update + , current + , updated + , holdDyn + , mapDynM + , forDynM + , constDyn + , count + , toggle + , switchDyn + , switchPromptlyDyn + , tagPromptlyDyn + , attachPromptlyDyn + , attachPromptlyDynWith + , attachPromptlyDynWithMaybe + , maybeDyn + , eitherDyn + , factorDyn + , scanDyn + , scanDynMaybe + , holdUniqDyn + , holdUniqDynBy + , improvingMaybe + , foldDyn + , foldDynM + , foldDynMaybe + , foldDynMaybeM + , joinDynThroughMap + , traceDyn + , traceDynWith + , splitDynPure + , distributeMapOverDynPure + , distributeDMapOverDynPure + , distributeListOverDynPure + , Demux + , demux + , demuxed + -- * Miscellaneous + -- Things that probably aren't very useful: + , HList (..) + , FHList (..) + , collectDynPure + , RebuildSortedHList (..) + , IsHList (..) + , AllAreFunctors (..) + , HListPtr (..) + , distributeFHListOverDynPure + -- * Unsafe + , unsafeDynamic + -- * Deprecated functions + , apDyn + , attachDyn + , attachDynWith + , attachDynWithMaybe + , collectDyn + , combineDyn + , distributeDMapOverDyn + , distributeFHListOverDyn + , forDyn + , getDemuxed + , joinDyn + , mapDyn + , mconcatDyn + , nubDyn + , splitDyn + , tagDyn + , uniqDyn + , uniqDynBy + ) where -import Reflex.Class +import Data.Functor.Compose import Data.Functor.Misc +import Reflex.Class -import Control.Monad hiding (mapM, mapM_, forM, forM_) +import Control.Applicative ((<*>)) +import Control.Monad import Control.Monad.Fix -import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_) -import Data.These -import Data.Traversable (mapM, forM) +import Control.Monad.Identity import Data.Align -import Data.Map (Map) -import qualified Data.Map as Map import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..)) -import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..)) -import Data.Monoid ---import Data.HList (HList (..), hBuild) - -data HList (l::[*]) where - HNil :: HList '[] - HCons :: e -> HList l -> HList (e ': l) - -infixr 2 `HCons` - -type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k] -type instance HRevApp '[] l = l -type instance HRevApp (e ': l) l' = HRevApp l (e ': l') - -hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2) -hRevApp HNil l = l -hRevApp (HCons x l) l' = hRevApp l (HCons x l') - -hReverse :: HList l -> HList (HRevApp l '[]) -hReverse l = hRevApp l HNil - -hBuild :: (HBuild' '[] r) => r -hBuild = hBuild' HNil - -class HBuild' l r where - hBuild' :: HList l -> r - -instance (l' ~ HRevApp l '[]) - => HBuild' l (HList l') where - hBuild' l = hReverse l - -instance HBuild' (a ': l) r - => HBuild' l (a->r) where - hBuild' l x = hBuild' (HCons x l) - --- | A container for a value that can change over time and allows notifications on changes. --- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will --- change if and only if the Event fires. --- --- Although @Dynamic@ logically has a 'Functor' instance, currently it can\'t --- be implemented without potentially requiring the mapped function to be --- evaluated twice. Instead, you can use 'mapDyn', which runs in a 'MonadHold' --- instance, to achieve the same result. -data Dynamic t a - = Dynamic (Behavior t a) (Event t a) - -unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a -unsafeDynamic = Dynamic - --- | Extract the 'Behavior' of a 'Dynamic'. -current :: Dynamic t a -> Behavior t a -current (Dynamic b _) = b +import Data.Functor.Product +import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) +import Data.Map (Map) +import Data.Maybe +import Data.Monoid hiding (Product) +import Data.These --- | Extract the 'Event' of the 'Dynamic'. -updated :: Dynamic t a -> Event t a -updated (Dynamic _ e) = e +import Debug.Trace --- | 'Dynamic' with the constant supplied value. -constDyn :: Reflex t => a -> Dynamic t a -constDyn x = Dynamic (constant x) never +-- | Map a sampling function over a 'Dynamic'. +mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b) +mapDynM f d = buildDynamic (f =<< sample (current d)) $ pushAlways f (updated d) --- | Create a 'Dynamic' using the initial value that changes every --- time the 'Event' occurs. -holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a) -holdDyn v0 e = do - b <- hold v0 e - return $ Dynamic b e +-- | Flipped version of 'mapDynM' +forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b) +forDynM d f = mapDynM f d --- | Create a new 'Dynamic' that only signals changes if the values --- actually changed. -nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a -nubDyn d = - let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d) - in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior +-- | Create a new 'Dynamic' that only signals changes if the values actually +-- changed. +holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a) +holdUniqDyn = holdUniqDynBy (==) -{- -instance Reflex t => Functor (Dynamic t) where - fmap f d = - let e' = fmap f $ updated d - eb' = push (\b' -> liftM Just $ constant b') e' - b0 = fmap f $ current d - --} +-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic' +-- changes and the given function returns 'False' when given both the old and +-- the new values. +holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a) +holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new) --- | Map a function over a 'Dynamic'. -mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b) -mapDyn f = mapDynM $ return . f +-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@) +improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a)) +improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing) --- | Flipped version of 'mapDyn'. -forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b) -forDyn = flip mapDyn +-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'. This +-- function does not force its input 'Dynamic' until the output 'Dynamic' is +-- forced. +scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b) +scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b) --- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can --- perform is 'sample'. -{-# INLINE mapDynM #-} -mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b) -mapDynM f d = do - let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d - eb' = fmap constant e' - v0 = pull $ f =<< sample (current d) - bb' :: Behavior t (Behavior t b) <- hold v0 eb' - let b' = pull $ sample =<< sample bb' - return $ Dynamic b' e' +-- | Like 'scanDyn', but the the accumulator function may decline to update the +-- result 'Dynamic''s value. +scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b) +scanDynMaybe z f d = do + rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do + b <- sample $ current d' + return $ f a b + return d' --- | Create a 'Dynamic' using the initial value and change it each --- time the 'Event' occurs using a folding function on the previous --- value and the value of the 'Event'. +-- | Create a 'Dynamic' using the initial value and change it each time the +-- 'Event' occurs using a folding function on the previous value and the value +-- of the 'Event'. foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b) -foldDyn f = foldDynMaybe $ \o v -> Just $ f o v +foldDyn = accumDyn . flip --- | Create a 'Dynamic' using the initial value and change it each --- time the 'Event' occurs using a monadic folding function on the --- previous value and the value of the 'Event'. +-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it +-- can 'sample' existing 'Behaviors' and 'hold' new ones. foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b) -foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v +foldDynM = accumMDyn . flip +-- | Create a 'Dynamic' using the provided initial value and change it each time +-- the provided 'Event' occurs, using a function to combine the old value with +-- the 'Event''s value. If the function returns 'Nothing', the value is not +-- changed; this is distinct from returning 'Just' the old value, since the +-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire +-- in the 'Nothing' case. foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b) -foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v +foldDynMaybe = accumMaybeDyn . flip +-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it +-- can 'sample' existing 'Behaviors' and 'hold' new ones. foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b) -foldDynMaybeM f z e = do - rec let e' = flip push e $ \o -> do - v <- sample b' - f o v - b' <- hold z e' - return $ Dynamic b' e' +foldDynMaybeM = accumMaybeMDyn . flip --- | Create a new 'Dynamic' that counts the occurences of the 'Event'. +-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'. count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b) count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e @@ -191,124 +184,63 @@ toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool) toggle = foldDyn (const not) --- | Switches to the new 'Event' whenever it receives one. Switching --- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new --- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'. +-- | Switches to the new 'Event' whenever it receives one. Only the old event is +-- considered the moment a new one is switched in; the output event will fire at +-- that moment if only if the old event does. +-- +-- Prefer this to 'switchPromptlyDyn' where possible. The lack of doing double +-- work when the outer and (new) inner fires means this imposes fewer "timing +-- requirements" and thus is far more easy to use without introducing fresh +-- failure cases. 'switchDyn' is also more performant. +switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a +switchDyn d = switch (current d) + +-- | Switches to the new 'Event' whenever it receives one. Switching occurs +-- __before__ the inner 'Event' fires - so if the 'Dynamic' changes and both the +-- old and new inner Events fire simultaneously, the output will fire with the +-- value of the __new__ 'Event'. +-- +-- Prefer 'switchDyn' to this where possible. The timing requirements that +-- switching before imposes are likely to bring down your app unless you are +-- very careful. 'switchDyn' is also more performant. switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a switchPromptlyDyn de = let eLag = switch $ current de eCoincidences = coincidence $ updated de in leftmost [eCoincidences, eLag] -{- - -mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a) -mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb - -firstE :: (Reflex t m) => [Event t a] -> m (Event t a) -firstE [] = return never -firstE (h:t) = mergeEventsLeftBiased h =<< firstE t - -concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a) -concatEventsWith _ [] = return never -concatEventsWith _ [e] = return e -concatEventsWith f es = mapEM (liftM (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es ---concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t - -mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a) -mconcatE = concatEventsWith mappend --} - --- | Split the 'Dynamic' into two 'Dynamic's, each taking the --- respective value of the tuple. -splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b) -splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d) - --- | Merge the 'Dynamic' values using their 'Monoid' instance. -mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a) -mconcatDyn es = do - ddm :: Dynamic t (DMap (Const2 Int a) Identity) <- distributeDMapOverDyn . DMap.fromList . map (\(k, v) -> Const2 k :=> v) $ zip [0 :: Int ..] es - mapDyn (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) ddm - --- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of --- Dynamic values. -distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity)) -distributeDMapOverDyn dm = case DMap.toList dm of - [] -> return $ constDyn DMap.empty - [k :=> v] -> mapDyn (DMap.singleton k . Identity) v - _ -> do - let edmPre = merge $ rewrapDMap updated dm - edm :: Event t (DMap k Identity) = flip push edmPre $ \o -> return . Just =<< do - let f _ = \case - This origDyn -> sample $ current origDyn - That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap" - These _ (Identity newVal) -> return newVal - sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o) - dm0 :: Behavior t (DMap k Identity) = pull $ do - liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv - bbdm :: Behavior t (Behavior t (DMap k Identity)) <- hold dm0 $ fmap constant edm - let bdm = pull $ sample =<< sample bbdm - return $ Dynamic bdm edm - --- | Merge two 'Dynamic's into a new one using the provided --- function. The new 'Dynamic' changes its value each time one of the --- original 'Dynamic's changes its value. -combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) -combineDyn f da db = do - let eab = align (updated da) (updated db) - ec = flip push eab $ \o -> do - (a, b) <- case o of - This a -> do - b <- sample $ current db - return (a, b) - That b -> do - a <- sample $ current da - return (a, b) - These a b -> return (a, b) - return $ Just $ f a b - c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db) - bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec - let bc :: Behavior t c = pull $ sample =<< sample bbc - return $ Dynamic bc ec +-- | Split a 'Dynamic' pair into a pair of 'Dynamic's +splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b) +splitDynPure d = (fmap fst d, fmap snd d) -{- -tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a -tagInnerDyn e = - let eSlow = push (liftM Just . sample . current) e - eFast = coincidence $ fmap updated e - in leftmost [eFast, eSlow] --} +-- | Convert a 'Map' with 'Dynamic' elements into a 'Dynamic' of a 'Map' with +-- non-'Dynamic' elements. +distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v) +distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap --- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value --- of the inner 'Dynamic'. -joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a -joinDyn dd = - let b' = pull $ sample . current =<< sample (current dd) - eOuter :: Event t a = pushAlways (sample . current) $ updated dd - eInner :: Event t a = switch $ fmap updated (current dd) - eBoth :: Event t a = coincidence $ fmap updated (updated dd) - e' = leftmost [eBoth, eOuter, eInner] - in Dynamic b' e' +-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with +-- non-'Dynamic' elements, preserving the order of the elements. +distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v] +distributeListOverDynPure = + fmap (map fromDSum . DMap.toAscList) . + distributeDMapOverDynPure . + DMap.fromDistinctAscList . + zipWith toDSum [0..] + where + toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t) + toDSum k v = Const2 k :=> v + fromDSum :: DSum (Const2 Int a) Identity -> a + fromDSum (Const2 _ :=> Identity v) = v --TODO: Generalize this to functors other than Maps -- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic' -- with the current values of the 'Dynamic's in a map. joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a) -joinDynThroughMap dd = - let b' = pull $ mapM (sample . current) =<< sample (current dd) - eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd - eInner :: Event t (Map k a) = attachWith (flip Map.union) b' $ switch $ fmap (mergeMap . fmap updated) (current dd) --Note: the flip is important because Map.union is left-biased - readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a - readNonFiring = \case - This d -> sample $ current d - That a -> return a - These _ a -> return a - eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd) - e' = leftmost [eBoth, eOuter, eInner] - in Dynamic b' e' +joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure --- | Print the value of the 'Dynamic' on each change and prefix it --- with the provided string. This should /only/ be used for debugging. +-- | Print the value of the 'Dynamic' when it is first read and on each +-- subsequent change that is observed (as 'traceEvent'), prefixed with the +-- provided string. This should /only/ be used for debugging. -- -- Note: Just like Debug.Trace.trace, the value will only be shown if something -- else in the system is depending on it. @@ -316,7 +248,8 @@ traceDyn s = traceDynWith $ \x -> s <> ": " <> show x -- | Print the result of applying the provided function to the value --- of the 'Dynamic' on each change. This should /only/ be used for +-- of the 'Dynamic' when it is first read and on each subsequent change +-- that is observed (as 'traceEvent'). This should /only/ be used for -- debugging. -- -- Note: Just like Debug.Trace.trace, the value will only be shown if something @@ -324,82 +257,124 @@ traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a traceDynWith f d = let e' = traceEventWith f $ updated d - in Dynamic (current d) e' + getV0 = do + x <- sample $ current d + trace (f x) $ return x + in unsafeBuildDynamic getV0 e' -- | Replace the value of the 'Event' with the current value of the 'Dynamic' -- each time the 'Event' occurs. -- --- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing --- at the same time that `d` is changing. With `tagDyn d e`, the *new* value of `d` --- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value +-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing +-- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@ +-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value -- will be used, since the 'Behavior' won't be updated until the end of the frame. -- Additionally, this means that the output 'Event' may not be used to directly change --- the input 'Dynamic', because that would mean its value depends on itself. When creating --- cyclic data flows, generally `tag (current d) e` is preferred. -tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a -tagDyn = attachDynWith const +-- the input 'Dynamic', because that would mean its value depends on itself. __When creating__ +-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__ +tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a +tagPromptlyDyn = attachPromptlyDynWith const -- | Attach the current value of the 'Dynamic' to the value of the -- 'Event' each time it occurs. -- --- Note: `attachDyn d` is not the same as `attach (current d)`. See 'tagDyn' for details. -attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) -attachDyn = attachDynWith (,) +-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@. See 'tagPromptlyDyn' for details. +attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) +attachPromptlyDyn = attachPromptlyDynWith (,) -- | Combine the current value of the 'Dynamic' with the value of the -- 'Event' each time it occurs. -- --- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`. See 'tagDyn' for details. -attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c -attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b +-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@. See 'tagPromptlyDyn' for details. +attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c +attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b --- | Create a new 'Event' by combining the value at each occurence --- with the current value of the 'Dynamic' value and possibly --- filtering if the combining function returns 'Nothing'. +-- | Create a new 'Event' by combining the value at each occurrence with the +-- current value of the 'Dynamic' value and possibly filtering if the combining +-- function returns 'Nothing'. -- --- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`. See 'tagDyn' for details. -attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c -attachDynWithMaybe f d e = +-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@. See 'tagPromptlyDyn' for details. +attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c +attachPromptlyDynWithMaybe f d e = let e' = attach (current d) e in fforMaybe (align e' $ updated d) $ \case This (a, b) -> f a b -- Only the tagging event is firing, so use that These (_, b) a -> f a b -- Both events are firing, so use the newer value That _ -> Nothing -- The tagging event isn't firing, so don't fire +-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@, +-- such that the outer 'Dynamic' is updated only when the "Maybe"'s constructor +-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor +-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track +-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the +-- existing inner 'Dynamic' will become constant, and will not change when the +-- outer constructor changes back to 'Nothing'. +maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a))) +maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack + where pack = \case + Nothing -> Left () + Just a -> Right a + unpack = \case + Left _ -> Nothing + Right a -> Just a + +eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b))) +eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum + where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b) + unpack = \case + LeftTag :=> Compose a -> Left $ coerceDynamic a + RightTag :=> Compose b -> Right $ coerceDynamic b + +factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k) + => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v))) +factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where + update :: Event t (DSum k (Compose (Dynamic t) v)) + update = flip push (updated d) $ \(newKey :=> newVal) -> do + (oldKey :=> _) <- sample (current d) + case newKey `geq` oldKey of + Just Refl -> return Nothing + Nothing -> Just <$> holdKey (newKey :=> newVal) + + holdKey (k :=> v) = do + inner' <- filterEventKey k (updated d) + inner <- holdDyn v inner' + return $ k :=> Compose inner -------------------------------------------------------------------------------- -- Demux -------------------------------------------------------------------------------- --- | Represents a time changing value together with an 'EventSelector' --- that can efficiently detect when the underlying Dynamic has a particular value. --- This is useful for representing data like the current selection of a long list. +-- | Represents a time changing value together with an 'EventSelector' that can +-- efficiently detect when the underlying 'Dynamic' has a particular value. +-- This is useful for representing data like the current selection of a long +-- list. -- -- Semantically, --- > getDemuxed (demux d) k === mapDyn (== k) d --- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/, --- rather than /O(n)/ for mapDyn. +-- +-- > demuxed (demux d) k === fmap (== k) d +-- +-- However, the when getDemuxed is used multiple times, the complexity is only +-- /O(log(n))/, rather than /O(n)/ for fmap. data Demux t k = Demux { demuxValue :: Behavior t k , demuxSelector :: EventSelector t (Const2 k Bool) } --- | Demultiplex an input value to a 'Demux' with many outputs. At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'. +-- | Demultiplex an input value to a 'Demux' with many outputs. At any given +-- time, whichever output is indicated by the given 'Dynamic' will be 'True'. demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k demux k = Demux (current k) - (fan $ attachWith (\k0 k1 -> if k0 == k1 + (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> Identity False, Const2 k1 :=> Identity True]) (current k) (updated k)) ---TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out --- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than) --- mapping over the original 'Dynamic' and checking whether it is equal to the given key. -getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool) -getDemuxed d k = do +-- | Select a particular output of the 'Demux'; this is equivalent to (but much +-- faster than) mapping over the original 'Dynamic' and checking whether it is +-- equal to the given key. +demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool +demuxed d k = let e = select (demuxSelector d) (Const2 k) - bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e - let b = pull $ join $ sample bb - return $ Dynamic b e + in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e -------------------------------------------------------------------------------- -- collectDyn @@ -407,6 +382,41 @@ --TODO: This whole section is badly in need of cleanup +-- | A heterogeneous list whose type and length are fixed statically. This is +-- reproduced from the 'HList' package due to integration issues, and because +-- very little other functionality from that library is needed. +data HList (l::[*]) where + HNil :: HList '[] + HCons :: e -> HList l -> HList (e ': l) + +infixr 2 `HCons` + +type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k] +type instance HRevApp '[] l = l +type instance HRevApp (e ': l) l' = HRevApp l (e ': l') + +hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2) +hRevApp HNil l = l +hRevApp (HCons x l) l' = hRevApp l (HCons x l') + +hReverse :: HList l -> HList (HRevApp l '[]) +hReverse l = hRevApp l HNil + +hBuild :: (HBuild' '[] r) => r +hBuild = hBuild' HNil + +class HBuild' l r where + hBuild' :: HList l -> r + +instance (l' ~ HRevApp l '[]) + => HBuild' l (HList l') where + hBuild' = hReverse + +instance HBuild' (a ': l) r + => HBuild' l (a->r) where + hBuild' l x = hBuild' (HCons x l) + +-- | Like 'HList', but with a functor wrapping each element. data FHList f l where FHNil :: FHList f '[] FHCons :: f e -> FHList f l -> FHList f (e ': l) @@ -423,17 +433,23 @@ HTailPtr _ `gcompare` HHeadPtr = GGT HTailPtr a `gcompare` HTailPtr b = a `gcompare` b +-- | A typed index into a typed heterogeneous list. data HListPtr l a where HHeadPtr :: HListPtr (h ': t) h HTailPtr :: HListPtr t a -> HListPtr (h ': t) a +deriving instance Eq (HListPtr l a) +deriving instance Ord (HListPtr l a) + fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f fhlistToDMap = DMap.fromList . go where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f] go = \case FHNil -> [] - FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> (HTailPtr p) :=> v) (go t) + FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t) +-- | This class allows 'HList's and 'FHlist's to be built from regular lists; +-- they must be contiguous and sorted. class RebuildSortedHList l where rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l @@ -457,17 +473,14 @@ dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l dmapToHList = rebuildSortedHList . DMap.toList -distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l)) -distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l) -{- -distributeFHListOverDyn l = do - let ec = undefined - c0 = pull $ sequenceFHList $ natMap (sample . current) l - bbc <- hold c0 $ fmap constant ec - let bc = pull $ sample =<< sample bbc - return $ Dynamic bc ec --} +-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a +-- single 'Dynamic' whose value represents the current values of all of the +-- input 'Dynamic's. +distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l) +distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l +-- | Indicates that all elements in a type-level list are applications of the +-- same functor. class AllAreFunctors (f :: a -> *) (l :: [a]) where type FunctorList f l :: [*] toFHList :: HList (FunctorList f l) -> FHList f l @@ -477,26 +490,32 @@ type FunctorList f '[] = '[] toFHList l = case l of HNil -> FHNil +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 +#endif fromFHList FHNil = HNil instance AllAreFunctors f t => AllAreFunctors f (h ': t) where type FunctorList f (h ': t) = f h ': FunctorList f t toFHList l = case l of a `HCons` b -> a `FHCons` toFHList b +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 +#endif fromFHList (a `FHCons` b) = a `HCons` fromFHList b -collectDyn :: ( RebuildSortedHList (HListElems b) - , IsHList a, IsHList b - , AllAreFunctors (Dynamic t) (HListElems b) - , Reflex t, MonadHold t m - , HListElems a ~ FunctorList (Dynamic t) (HListElems b) - ) => a -> m (Dynamic t b) -collectDyn ds = - mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds) +-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a +-- single 'Dynamic' whose value represents all the current values of the input's +-- consitutent 'Dynamic's. +collectDynPure :: ( RebuildSortedHList (HListElems b) + , IsHList a, IsHList b + , AllAreFunctors (Dynamic t) (HListElems b) + , Reflex t + , HListElems a ~ FunctorList (Dynamic t) (HListElems b) + ) => a -> Dynamic t b +collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds --- Poor man's Generic +-- | Poor man's 'Generic's for product types only. class IsHList a where type HListElems a :: [*] toHList :: a -> HList (HListElems a) @@ -507,18 +526,155 @@ toHList (a, b) = hBuild a b fromHList l = case l of a `HCons` b `HCons` HNil -> (a, b) +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 +#endif instance IsHList (a, b, c, d) where type HListElems (a, b, c, d) = [a, b, c, d] toHList (a, b, c, d) = hBuild a b c d fromHList l = case l of a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d) +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 +#endif instance IsHList (a, b, c, d, e, f) where type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f] toHList (a, b, c, d, e, f) = hBuild a b c d e f fromHList l = case l of a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f) +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 +#endif + +-------------------------------------------------------------------------------- +-- Deprecated functions +-------------------------------------------------------------------------------- + +-- | Map a function over a 'Dynamic'. +{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-} +mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b) +mapDyn f = return . fmap f + +-- | Flipped version of 'mapDyn'. +{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-} +forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b) +forDyn a = return . ffor a + +-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value +-- of the tuple. +{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-} +splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b) +splitDyn = return . splitDynPure + +-- | Merge the 'Dynamic' values using their 'Monoid' instance. +{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-} +mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a) +mconcatDyn = return . mconcat + +-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'. +{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-} +distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity)) +distributeDMapOverDyn = return . distributeDMapOverDynPure + +-- | Merge two 'Dynamic's into a new one using the provided function. The new +-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes +-- its value. +{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-} +combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) +combineDyn f a b = return $ zipDynWith f a b + +-- | A psuedo applicative version of ap for 'Dynamic'. Example useage: +-- +-- > do +-- > person <- Person `mapDyn` dynFirstName +-- > `apDyn` dynListName +-- > `apDyn` dynAge +-- > `apDyn` dynAddress +{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-} +#ifdef USE_TEMPLATE_HASKELL +{-# ANN apDyn "HLint: ignore Use fmap" #-} +#endif +apDyn :: forall t m a b. (Reflex t, Monad m) + => m (Dynamic t (a -> b)) + -> Dynamic t a + -> m (Dynamic t b) +apDyn m a = fmap (<*> a) m + +--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out +-- | This function no longer needs to be monadic, so it has been replaced by +-- 'demuxed', which is pure. +{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-} +getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool) +getDemuxed d = return . demuxed d + +-- | This function no longer needs to be monadic, so it has been replaced by +-- 'distributeFHListOverDynPure', which is pure. +{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-} +distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l)) +distributeFHListOverDyn = return . distributeFHListOverDynPure + +-- | This function no longer needs to be monadic, so it has been replaced by +-- 'collectDynPure', which is pure. +{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-} +collectDyn :: ( RebuildSortedHList (HListElems b) + , IsHList a, IsHList b + , AllAreFunctors (Dynamic t) (HListElems b) + , Reflex t, Monad m + , HListElems a ~ FunctorList (Dynamic t) (HListElems b) + ) => a -> m (Dynamic t b) +collectDyn = return . collectDynPure + +-- | This function has been renamed to 'tagPromptlyDyn' to clarify its +-- semantics. +{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-} +tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a +tagDyn = tagPromptlyDyn + +-- | This function has been renamed to 'attachPromptlyDyn' to clarify its +-- semantics. +{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-} +attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) +attachDyn = attachPromptlyDyn + +-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its +-- semantics. +{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-} +attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c +attachDynWith = attachPromptlyDynWith + +-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify +-- its semantics. +{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-} +attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c +attachDynWithMaybe = attachPromptlyDynWithMaybe + +-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s +-- current value will always be equal to the current value's current value, and +-- will change whenever either the inner or the outer (or both) values change. +{-# DEPRECATED joinDyn "Use 'join' instead" #-} +joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a +joinDyn = join + +-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests +-- representational equality. Use 'holdUniqDyn' instead, which is pure in all +-- circumstances. Also, note that, unlike 'nub', this function does not prevent +-- all recurrences of a value, only consecutive recurrences. +{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} +nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a +nubDyn = uniqDyn + +-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests +-- representational equality. Use 'holdUniqDyn' instead, which is pure in all +-- circumstances. +{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} +uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a +uniqDyn = uniqDynBy (==) + +-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead. +{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} +uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a +uniqDynBy eq d = + let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d) + in unsafeDynamic (current d) e' diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -5,23 +5,36 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} -module Reflex.Dynamic.TH (qDyn, unqDyn, mkDyn) where +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +-- | Template Haskell helper functions for building complex 'Dynamic' values. +module Reflex.Dynamic.TH + ( qDynPure + , unqDyn + , mkDynPure + -- * Deprecated functions + , qDyn + , mkDyn + ) where import Reflex.Dynamic -import Language.Haskell.TH -import qualified Language.Haskell.TH.Syntax as TH -import Language.Haskell.TH.Quote -import Data.Data import Control.Monad.State +import Data.Data +import Data.Generics +import Data.Monoid import qualified Language.Haskell.Exts as Hs import qualified Language.Haskell.Meta.Syntax.Translate as Hs -import Data.Monoid -import Data.Generics +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import qualified Language.Haskell.TH.Syntax as TH --- | Quote a Dynamic expression. Within the quoted expression, you can use '$(unqDyn [| x |])' to refer to any expression 'x' of type 'Dynamic t a'; the unquoted result will be of type 'a' -qDyn :: Q Exp -> Q Exp -qDyn qe = do +-- | Quote a 'Dynamic' expression. Within the quoted expression, you can use +-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the +-- unquoted result will be of type @a@ +qDynPure :: Q Exp -> Q Exp +qDynPure qe = do e <- qe let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d f d = case eqT of @@ -34,23 +47,36 @@ _ -> gmapM f d (e', exprsReversed) <- runStateT (gmapM f e) [] let exprs = reverse exprsReversed - arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs - param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs - [| mapDyn $(return $ LamE [param] e') =<< distributeFHListOverDyn $(return arg) |] + arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs + param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs + [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |] +-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a +-- 'qDyn' quotation. unqDyn :: Q Exp -> Q Exp unqDyn e = [| unqMarker $e |] --- | This type represents an occurrence of unqDyn before it has been processed by qDyn. If you see it in a type error, it probably means that unqDyn has been used outside of a qDyn context. +-- | This type represents an occurrence of unqDyn before it has been processed +-- by qDyn. If you see it in a type error, it probably means that unqDyn has +-- been used outside of a qDyn context. data UnqDyn --- unqMarker must not be exported; it is used only as a way of smuggling data from unqDyn to qDyn +-- unqMarker must not be exported; it is used only as a way of smuggling data +-- from unqDyn to qDyn + --TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery unqMarker :: a -> UnqDyn unqMarker = error "An unqDyn expression was used outside of a qDyn expression" -mkDyn :: QuasiQuoter -mkDyn = QuasiQuoter +-- | Create a 'Dynamic' value using other 'Dynamic's as inputs. The result is +-- sometimes more concise and readable than the equivalent 'Applicative'-based +-- expression. For example: +-- +-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |] +-- +-- would have a very cumbersome 'Applicative' encoding. +mkDynPure :: QuasiQuoter +mkDynPure = QuasiQuoter { quoteExp = mkDynExp , quotePat = error "mkDyn: pattern splices are not supported" , quoteType = error "mkDyn: type splices are not supported" @@ -60,7 +86,7 @@ mkDynExp :: String -> Q Exp mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err - Hs.ParseOk e -> qDyn $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e + Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker #if MIN_VERSION_haskell_src_exts(1,18,0) antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo @@ -81,3 +107,24 @@ reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName'))) | modName == modName' && occName == occName' = 'unqMarker reinstateUnqDyn x = x + +-------------------------------------------------------------------------------- +-- Deprecated +-------------------------------------------------------------------------------- + +{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-} +-- | Like 'qDynPure', but wraps its result monadically using 'return'. This is +-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'. +qDyn :: Q Exp -> Q Exp +qDyn qe = [| return $(qDynPure qe) |] + +{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-} +-- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is +-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'. +mkDyn :: QuasiQuoter +mkDyn = QuasiQuoter + { quoteExp = \s -> [| return $(mkDynExp s) |] + , quotePat = error "mkDyn: pattern splices are not supported" + , quoteType = error "mkDyn: type splices are not supported" + , quoteDec = error "mkDyn: declaration splices are not supported" + } diff --git a/src/Reflex/Dynamic/Uniq.hs b/src/Reflex/Dynamic/Uniq.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dynamic/Uniq.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +-- | This module provides a variation of 'Dynamic' values that uses cheap +-- pointer equality checks to reduce the amount of signal propagation needed. +module Reflex.Dynamic.Uniq + ( UniqDynamic + , uniqDynamic + , fromUniqDynamic + , alreadyUniqDynamic + ) where + +import Control.Applicative (Applicative (..)) +import GHC.Exts +import Reflex.Class + +-- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as +-- the 'current' 'Behavior''s contents. In order to maintain this constraint, +-- the value inside a 'UniqDynamic' is always evaluated to +-- . +-- +-- Internally, 'UniqDynamic' uses pointer equality as a heuristic to avoid +-- unnecessary update propagation; this is much more efficient than performing +-- full comparisons. However, when the 'UniqDynamic' is converted back into a +-- regular 'Dynamic', a full comparison is performed. +newtype UniqDynamic t a = UniqDynamic { unUniqDynamic :: Dynamic t a } + +-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'. +uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a +uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pushCheap (updated d) $ \new -> do + old <- sample $ current d --TODO: Is it better to sample ourselves here? + return $ unsafeJustChanged old new + +-- | Retrieve a normal 'Dynamic' from a 'UniqDynamic'. This will perform a +-- final check using the output type's 'Eq' instance to ensure deterministic +-- behavior. +-- +-- WARNING: If used with a type whose 'Eq' instance is not law-abiding - +-- specifically, if there are cases where @x /= x@, 'fromUniqDynamic' may +-- eliminate more 'updated' occurrences than it should. For example, NaN values +-- of 'Double' and 'Float' are considered unequal to themselves by the 'Eq' +-- instance, but can be equal by pointer equality. This may cause 'UniqDynamic' +-- to lose changes from NaN to NaN. +fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a +fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e' + where + -- Only consider values different if they fail both pointer equality /and/ + -- 'Eq' equality. This is to make things a bit more deterministic in the + -- case of unlawful 'Eq' instances. However, it is still possible to + -- achieve nondeterminism by constructing elements that are identical in + -- value, unequal according to 'Eq', and nondeterministically equal or + -- nonequal by pointer quality. I suspect that it is impossible to make the + -- behavior deterministic in this case. + superEq a b = a `unsafePtrEq` b || a == b + e' = attachWithMaybe (\x x' -> if x' `superEq` x then Nothing else Just x') (current d) (updated d) + +-- | Create a UniqDynamic without uniqing it on creation. This will be slightly +-- faster than uniqDynamic when used with a Dynamic whose values are always (or +-- nearly always) different from its previous values; if used with a Dynamic +-- whose values do not change frequently, it may be much slower than uniqDynamic +alreadyUniqDynamic :: Dynamic t a -> UniqDynamic t a +alreadyUniqDynamic = UniqDynamic + +unsafePtrEq :: a -> a -> Bool +unsafePtrEq a b = case a `seq` b `seq` reallyUnsafePtrEquality# a b of + 0# -> False + _ -> True + +unsafeJustChanged :: a -> a -> Maybe a +unsafeJustChanged old new = + if old `unsafePtrEq` new + then Nothing + else Just new + +instance Reflex t => Accumulator t (UniqDynamic t) where + accumMaybeM f z e = do + let f' old change = do + mNew <- f old change + return $ unsafeJustChanged old =<< mNew + d <- accumMaybeMDyn f' z e + return $ UniqDynamic d + mapAccumMaybeM f z e = do + let f' old change = do + (mNew, output) <- f old change + return (unsafeJustChanged old =<< mNew, output) + (d, out) <- mapAccumMaybeMDyn f' z e + return (UniqDynamic d, out) + +instance Reflex t => Functor (UniqDynamic t) where + fmap f (UniqDynamic d) = uniqDynamic $ fmap f d + +instance Reflex t => Applicative (UniqDynamic t) where + pure = UniqDynamic . constDyn + UniqDynamic a <*> UniqDynamic b = uniqDynamic $ a <*> b + _ *> b = b + a <* _ = a + +instance Reflex t => Monad (UniqDynamic t) where + UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f + _ >> b = b + return = pure diff --git a/src/Reflex/DynamicWriter.hs b/src/Reflex/DynamicWriter.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/DynamicWriter.hs @@ -0,0 +1,7 @@ +module Reflex.DynamicWriter + {-# DEPRECATED "Use 'Reflex.DynamicWriter.Class' and 'Reflex.DynamicWrite.Base' instead, or just import 'Reflex'" #-} + ( module X + ) where + +import Reflex.DynamicWriter.Base as X +import Reflex.DynamicWriter.Class as X diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/DynamicWriter/Base.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.DynamicWriter.Base + ( DynamicWriterT (..) + , runDynamicWriterT + , withDynamicWriterT + ) where + +import Control.Monad.Exception +import Control.Monad.Identity +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict +import Data.Align +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.FastMutableIntMap +import Data.Functor.Misc +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Semigroup +import Data.Some (Some) +import Data.These + +import Reflex.Adjustable.Class +import Reflex.Class +import Reflex.DynamicWriter.Class +import Reflex.EventWriter.Class (EventWriter, tellEvent) +import Reflex.Host.Class +import qualified Reflex.Patch.MapWithMove as MapWithMove +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.Query.Class +import Reflex.Requester.Class +import Reflex.TriggerEvent.Class + +instance MonadTrans (DynamicWriterT t w) where + lift = DynamicWriterT . lift + +mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v') +mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f) + +mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v) +mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues + where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a + addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m + +mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v) +mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues + where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a + addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m + +mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v) +mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues + where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a + addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove + f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v + f x = unsafePatchMapWithMove $ + let (p, changed) = case x of + This p_ -> (unPatchMapWithMove p_, mempty) + That c -> (mempty, c) + These p_ c -> (unPatchMapWithMove p_, c) + (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case + MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v + MapWithMove.From_Delete -> return MapWithMove.From_Delete + MapWithMove.From_Move k -> case Map.lookup k changed of + Nothing -> return $ MapWithMove.From_Move k + Just v -> do + modify (k:) + return $ MapWithMove.From_Insert v + noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved + in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered? + +-- | A basic implementation of 'MonadDynamicWriter'. +newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order + +deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m) +deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m) + + +instance MonadRef m => MonadRef (DynamicWriterT t w m) where + type Ref (DynamicWriterT t w m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where + atomicModifyRef r = lift . atomicModifyRef r + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided +-- along with the result of the action. +runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w) +runDynamicWriterT (DynamicWriterT a) = do + (result, ws) <- runStateT a [] + return (result, mconcat $ reverse ws) + +instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where + tellDyn w = DynamicWriterT $ modify (w :) + +instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where + ask = lift ask + local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a + reader = lift . reader + +instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where + type Performable (DynamicWriterT t w m) = Performable m + performEvent_ = lift . performEvent_ + performEvent = lift . performEvent + +instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where + getPostBuild = lift getPostBuild + +instance MonadState s m => MonadState s (DynamicWriterT t w m) where + get = lift get + put = lift . put + +newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w) + +-- | When the execution of a 'DynamicWriterT' action is adjusted using +-- 'Adjustable', the 'Dynamic' output of that action will also be updated to +-- match. +instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where + runWithReplace a0 a' = do + (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a' + tellDyn . join =<< holdDyn (snd result0) (snd <$> result') + return (fst result0, fst <$> result') + traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental + traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental + traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove + +traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m) + => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a)) + -> DMap k v + -> Event t (p k v) + -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v'))) + ) + -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v') + -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w)) + -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w)) + -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a)) + -> DMap k v + -> Event t (p k v) + -> DynamicWriterT t w m (DMap k v', Event t (p k v')) +traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do + (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm' + let getValue (DynamicWriterTLoweredResult (v, _)) = v + getWritten (DynamicWriterTLoweredResult (_, w)) = w + liftedResult0 = DMap.map getValue result0 + liftedResult' = ffor result' $ mapPatch getValue + liftedWritten0 :: Map (Some k) (Dynamic t w) + liftedWritten0 = weakenDMapWith getWritten result0 + liftedWritten' = ffor result' $ weakenPatchWith getWritten + --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics + i <- holdIncremental liftedWritten0 liftedWritten' + tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i + return (liftedResult0, liftedResult') + +traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p') + => ( (IntMap.Key -> v -> m (v', Dynamic t w)) + -> IntMap v + -> Event t (p v) + -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w))) + ) + -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w)) + -> (IntMap.Key -> v -> DynamicWriterT t w m v') + -> IntMap v + -> Event t (p v) + -> DynamicWriterT t w m (IntMap v', Event t (p v')) +traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do + (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm' + let liftedResult0 = fmap fst result0 + liftedResult' = fmap (fmap fst) result' + liftedWritten0 :: IntMap (Dynamic t w) + liftedWritten0 = fmap snd result0 + liftedWritten' = fmap (fmap snd) result' + --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics + i <- holdIncremental liftedWritten0 liftedWritten' + tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i + return (liftedResult0, liftedResult') + +-- | Map a function over the output of a 'DynamicWriterT'. +withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m) + => (w -> w') + -> DynamicWriterT t w m a + -> DynamicWriterT t w' m a +withDynamicWriterT f dw = do + (r, d) <- lift $ do + (r, d) <- runDynamicWriterT dw + let d' = fmap f d + return (r, d') + tellDyn d + return r + +instance Requester t m => Requester t (DynamicWriterT t w m) where + type Request (DynamicWriterT t w m) = Request m + type Response (DynamicWriterT t w m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where + tellQueryIncremental = lift . tellQueryIncremental + askQueryResult = lift askQueryResult + queryIncremental = lift . queryIncremental + +instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where + tellEvent = lift . tellEvent diff --git a/src/Reflex/DynamicWriter/Class.hs b/src/Reflex/DynamicWriter/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/DynamicWriter/Class.hs @@ -0,0 +1,24 @@ +-- | This module defines the 'MonadDynamicWriter' class. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.DynamicWriter.Class + ( MonadDynamicWriter (..) + ) where + +import Control.Monad.Reader (ReaderT, lift) +import Reflex.Class (Dynamic) + +-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn' +-- and combines them monoidally to provide a 'Dynamic' result. +class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where + tellDyn :: Dynamic t w -> m () + +instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where + tellDyn = lift . tellDyn + diff --git a/src/Reflex/EventWriter.hs b/src/Reflex/EventWriter.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/EventWriter.hs @@ -0,0 +1,7 @@ +module Reflex.EventWriter + {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-} + ( module X + ) where + +import Reflex.EventWriter.Base as X +import Reflex.EventWriter.Class as X diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/EventWriter/Base.hs @@ -0,0 +1,306 @@ +-- | This module provides 'EventWriterT', the standard implementation of +-- 'EventWriter'. +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.EventWriter.Base + ( EventWriterT (..) + , runEventWriterT + , runWithReplaceEventWriterTWith + , sequenceDMapWithAdjustEventWriterTWith + , mapEventWriterT + , withEventWriterT + ) where + +import Reflex.Adjustable.Class +import Reflex.Class +import Reflex.EventWriter.Class (EventWriter, tellEvent) +import Reflex.DynamicWriter.Class (MonadDynamicWriter, tellDyn) +import Reflex.Host.Class +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.Query.Class +import Reflex.Requester.Class +import Reflex.TriggerEvent.Class + +import Control.Monad.Exception +import Control.Monad.Identity +import Control.Monad.Primitive +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict +import Data.Dependent.Map (DMap, DSum (..)) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Compose +import Data.Functor.Misc +import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..)) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Semigroup +import Data.Some (Some) +import Data.Tuple +import Data.Type.Equality hiding (apply) + +import Unsafe.Coerce + +{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-} +newtype TellId w x + = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead + deriving (Show, Eq, Ord, Enum) + +tellId :: Int -> TellId w w +tellId = TellId +{-# INLINE tellId #-} + +tellIdRefl :: TellId w x -> w :~: x +tellIdRefl _ = unsafeCoerce Refl + +withTellIdRefl :: TellId w x -> (w ~ x => r) -> r +withTellIdRefl tid r = case tellIdRefl tid of + Refl -> r + +instance GEq (TellId w) where + a `geq` b = + withTellIdRefl a $ + withTellIdRefl b $ + if a == b + then Just Refl + else Nothing + +instance GCompare (TellId w) where + a `gcompare` b = + withTellIdRefl a $ + withTellIdRefl b $ + case a `compare` b of + LT -> GLT + EQ -> GEQ + GT -> GGT + +data EventWriterState t w = EventWriterState + { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time) + , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order + } + +-- | A basic implementation of 'EventWriter'. +newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a } + deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) + +-- | Run a 'EventWriterT' action. +runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w) +runEventWriterT (EventWriterT a) = do + (result, requests) <- runStateT a $ EventWriterState (-1) [] + let combineResults :: DMap (TellId w) Identity -> w + combineResults = sconcat + . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps + . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order + return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help + +instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where + tellEvent w = EventWriterT $ modify $ \old -> + let myId = _eventWriterState_nextId old + in EventWriterState + { _eventWriterState_nextId = pred myId + , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old + } + +instance MonadTrans (EventWriterT t w) where + lift = EventWriterT . lift + +instance MonadSample t m => MonadSample t (EventWriterT t w m) where + sample = lift . sample + +instance MonadHold t m => MonadHold t (EventWriterT t w m) where + {-# INLINABLE hold #-} + hold v0 = lift . hold v0 + {-# INLINABLE holdDyn #-} + holdDyn v0 = lift . holdDyn v0 + {-# INLINABLE holdIncremental #-} + holdIncremental v0 = lift . holdIncremental v0 + {-# INLINABLE buildDynamic #-} + buildDynamic a0 = lift . buildDynamic a0 + {-# INLINABLE headE #-} + headE = lift . headE + +instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where + runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm' + traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap + traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap + traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove + +instance Requester t m => Requester t (EventWriterT t w m) where + type Request (EventWriterT t w m) = Request m + type Response (EventWriterT t w m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +-- | Given a function like 'runWithReplace' for the underlying monad, implement +-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying +-- monad doesn't have a 'Adjustable' instance or to override the default +-- 'Adjustable' behavior. +runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w) + => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b')) + -> EventWriterT t w m a + -> Event t (EventWriterT t w m b) + -> EventWriterT t w m (a, Event t b) +runWithReplaceEventWriterTWith f a0 a' = do + (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a' + tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result') + return (fst result0, fmapCheap fst result') + +-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'. +sequenceIntMapWithAdjustEventWriterTWith + :: forall t m p w v v' + . ( Reflex t + , MonadHold t m + , Semigroup w + , Functor p + , Patch (p (Event t w)) + , PatchTarget (p (Event t w)) ~ IntMap (Event t w) + , Patch (p w) + , PatchTarget (p w) ~ IntMap w + ) + => ( (IntMap.Key -> v -> m (Event t w, v')) + -> IntMap v + -> Event t (p v) + -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v'))) + ) + -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w))) + -> (Event t (p (Event t w)) -> Event t (p w)) + -> (IntMap.Key -> v -> EventWriterT t w m v') + -> IntMap v + -> Event t (p v) + -> EventWriterT t w m (IntMap v', Event t (p v')) +sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do + let f' :: IntMap.Key -> v -> m (Event t w, v') + f' k v = swap <$> runEventWriterT (f k v) + (children0, children') <- base f' dm0 dm' + let result0 = fmap snd children0 + result' = fmapCheap (fmap snd) children' + requests0 :: IntMap (Event t w) + requests0 = fmap fst children0 + requests' :: Event t (p (Event t w)) + requests' = fmapCheap (fmap fst) children' + e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests' + tellEvent $ fforMaybeCheap e $ \m -> + case IntMap.elems m of + [] -> Nothing + h : t -> Just $ sconcat $ h :| t + return (result0, result') + +-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'. +sequenceDMapWithAdjustEventWriterTWith + :: forall t m p p' w k v v' + . ( Reflex t + , MonadHold t m + , Semigroup w + , Patch (p' (Some k) (Event t w)) + , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w) + , GCompare k + , Patch (p' (Some k) w) + , PatchTarget (p' (Some k) w) ~ Map (Some k) w + ) + => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)) + -> DMap k v + -> Event t (p k v) + -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v'))) + ) + -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v') + -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w)) + -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w))) + -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w)) + -> (forall a. k a -> v a -> EventWriterT t w m (v' a)) + -> DMap k v + -> Event t (p k v) + -> EventWriterT t w m (DMap k v', Event t (p k v')) +sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do + let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a) + f' k v = Compose . swap <$> runEventWriterT (f k v) + (children0, children') <- base f' dm0 dm' + let result0 = DMap.map (snd . getCompose) children0 + result' = fforCheap children' $ mapPatch $ snd . getCompose + requests0 :: Map (Some k) (Event t w) + requests0 = weakenDMapWith (fst . getCompose) children0 + requests' :: Event t (p' (Some k) (Event t w)) + requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose + e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests' + tellEvent $ fforMaybeCheap e $ \m -> + case Map.elems m of + [] -> Nothing + h : t -> Just $ sconcat $ h :| t + return (result0, result') + +instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where + type Performable (EventWriterT t w m) = Performable m + performEvent_ = lift . performEvent_ + performEvent = lift . performEvent + +instance PostBuild t m => PostBuild t (EventWriterT t w m) where + getPostBuild = lift getPostBuild + +instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance MonadReader r m => MonadReader r (EventWriterT t w m) where + ask = lift ask + local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a + reader = lift . reader + +instance MonadRef m => MonadRef (EventWriterT t w m) where + type Ref (EventWriterT t w m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where + atomicModifyRef r = lift . atomicModifyRef r + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where + tellQueryIncremental = lift . tellQueryIncremental + askQueryResult = lift askQueryResult + queryIncremental = lift . queryIncremental + +instance MonadDynamicWriter t w m => MonadDynamicWriter t w (EventWriterT t v m) where + tellDyn = lift . tellDyn + +instance PrimMonad m => PrimMonad (EventWriterT t w m) where + type PrimState (EventWriterT t w m) = PrimState m + primitive = lift . primitive + +-- | Map a function over the output of a 'EventWriterT'. +withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m) + => (w -> w') + -> EventWriterT t w m a + -> EventWriterT t w' m a +withEventWriterT f ew = do + (r, e) <- lift $ do + (r, e) <- runEventWriterT ew + let e' = fmap f e + return (r, e') + tellEvent e + return r + +-- | Change the monad underlying an EventWriterT +mapEventWriterT + :: (forall x. m x -> n x) + -> EventWriterT t w m a + -> EventWriterT t w n a +mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a diff --git a/src/Reflex/EventWriter/Class.hs b/src/Reflex/EventWriter/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/EventWriter/Class.hs @@ -0,0 +1,27 @@ +-- | This module defines the 'EventWriter' class. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.EventWriter.Class + ( EventWriter (..) + ) where + +import Control.Monad.Reader (ReaderT, lift) +import Data.Semigroup (Semigroup) + +import Reflex.Class (Event) + + +-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent' +-- and combines them via 'Semigroup' to provide an 'Event' result. +class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where + tellEvent :: Event t w -> m () + + +instance EventWriter t w m => EventWriter t w (ReaderT r m) where + tellEvent = lift . tellEvent diff --git a/src/Reflex/FastWeak.hs b/src/Reflex/FastWeak.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/FastWeak.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if GHCJS_FAST_WEAK +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +#endif + +-- | 'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value +-- referred to by a 'FastWeak' stays live while the ticket is held (live). +-- +-- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper +-- around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same. +-- +-- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly +-- in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS. +module Reflex.FastWeak + ( FastWeakTicket + , FastWeak + , mkFastWeakTicket + , getFastWeakTicketValue + , getFastWeakTicketWeak + , getFastWeakValue + , getFastWeakTicket + , emptyFastWeak +#ifdef GHCJS_FAST_WEAK + --TODO: Move these elsewhere + , unsafeFromRawJSVal + , unsafeToRawJSVal + , js_isNull +#endif + ) where + +import GHC.Exts (Any) +import Unsafe.Coerce + +#ifdef GHCJS_FAST_WEAK +import GHCJS.Types +#else +import Control.Exception (evaluate) +import System.IO.Unsafe +import System.Mem.Weak +#endif + + +#ifdef GHCJS_FAST_WEAK +-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue' +-- can be used to get the referred to value without fear of @Nothing, +-- and 'getFastWeakTicketWeak' can be used to get the weak version. +-- +-- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@. +newtype FastWeakTicket a = FastWeakTicket JSVal + +-- | A reference to some value which can be garbage collected if there are only +-- weak references to the value left. +-- +-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value. +-- +-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using +-- 'getFastWeakTicket' if the value hasn't been collected yet. +-- +-- Implemented by way of special support in the GHCJS RTS, @h$FastWeak@. +newtype FastWeak a = FastWeak JSVal + +-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two +data Val a = Val { unVal :: a } + +-- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@ +unsafeFromRawJSVal :: JSVal -> a +unsafeFromRawJSVal v = unVal (unsafeCoerce v) + +-- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object. +unsafeToRawJSVal :: a -> JSVal +unsafeToRawJSVal v = unsafeCoerce (Val v) +#else +-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue' +-- can be used to get the referred to value without fear of @Nothing@, +-- and 'getFastWeakTicketWeak' can be used to get the weak version. +data FastWeakTicket a = FastWeakTicket + { _fastWeakTicket_val :: !a + , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a) + } + +-- | A reference to some value which can be garbage collected if there are only weak references to the value left. +-- +-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value. +-- +-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket' +-- if the value hasn't been collected yet. +-- +-- Synonymous with 'Weak'. +type FastWeak a = Weak a +#endif + +-- | Return the @a@ kept alive by the given 'FastWeakTicket'. +-- +-- This needs to be in IO so we know that we've relinquished the ticket. +getFastWeakTicketValue :: FastWeakTicket a -> IO a +#ifdef GHCJS_FAST_WEAK +getFastWeakTicketValue t = do + v <- js_ticketVal t + return $ unsafeFromRawJSVal v + +foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal +#else +getFastWeakTicketValue = return . _fastWeakTicket_val +#endif + +-- | Get the value referred to by a 'FastWeak' if it hasn't yet been collected, +-- or @Nothing@ if it has been collected. +getFastWeakValue :: FastWeak a -> IO (Maybe a) +#ifdef GHCJS_FAST_WEAK +getFastWeakValue w = do + r <- js_weakVal w + case js_isNull r of + True -> return Nothing + False -> return $ Just $ unsafeFromRawJSVal r + +foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool + +foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal +#else +getFastWeakValue = deRefWeak +#endif + +-- | Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the value referred +-- remains alive. Returns @Just@ if the value hasn't been collected +-- and a ticket can therefore be obtained, @Nothing@ if it's been collected. +getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a)) +#ifdef GHCJS_FAST_WEAK +getFastWeakTicket w = do + r <- js_weakTicket w + case js_isNull r of + True -> return Nothing + False -> return $ Just $ FastWeakTicket r + +foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal +#else +getFastWeakTicket w = do + deRefWeak w >>= \case + Nothing -> return Nothing + Just v -> return $ Just $ FastWeakTicket + { _fastWeakTicket_val = v + , _fastWeakTicket_weak = w + } +#endif + +-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process +-- which can be obtained with 'getFastWeakTicketValue'. +mkFastWeakTicket :: a -> IO (FastWeakTicket a) +-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the +-- associated FastWeak to actually be weak +#ifdef GHCJS_FAST_WEAK +mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v) + +foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> IO (FastWeakTicket a) +#else +mkFastWeakTicket v = do + v' <- evaluate v + w <- mkWeakPtr v' Nothing + return $ FastWeakTicket + { _fastWeakTicket_val = v' + , _fastWeakTicket_weak = w + } +#endif + +-- | Demote a 'FastWeakTicket'; which ensures the value is alive, to a 'FastWeak' which doesn't. +-- Note that unless the ticket for the same 'FastWeak' is held in some other way +-- the value might be collected immediately. +getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a) +-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value +#ifdef GHCJS_FAST_WEAK +foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a) +{-# INLINE getFastWeakTicketWeak #-} +getFastWeakTicketWeak = getFastWeakTicketWeak' +#else +getFastWeakTicketWeak = return . _fastWeakTicket_weak +#endif + +-- | A weak reference that is always empty +emptyFastWeak :: FastWeak a +emptyFastWeak = unsafeCoerce w + where w :: FastWeak Any +#ifdef GHCJS_FAST_WEAK + w = js_emptyWeak +#else + w = unsafePerformIO $ do + w' <- mkWeakPtr undefined Nothing + finalize w' + return w' +#endif +{-# NOINLINE emptyFastWeak #-} + +#ifdef GHCJS_FAST_WEAK +foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any +#endif diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/FunctorMaybe.hs @@ -0,0 +1,43 @@ +-- | This module defines the FunctorMaybe class, which extends Functors with the +-- ability to delete values. +module Reflex.FunctorMaybe + ( FunctorMaybe (..) + ) where + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe + +--TODO: See if there's a better class in the standard libraries already + +-- | A class for values that combines filtering and mapping using 'Maybe'. +-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the +-- @Witherable@ typeclass, but it requires @Foldable f@ and @Traverable f@, +-- and e.g. 'Event' is instance of neither. +-- +-- A definition of 'fmapMaybe' must satisfy the following laws: +-- +-- [/identity/] +-- @'fmapMaybe' 'Just' ≡ 'id'@ +-- +-- [/composition/] +-- @'fmapMaybe' (f <=< g) ≡ 'fmapMaybe' f . 'fmapMaybe' g@ +class FunctorMaybe f where + -- | Combined mapping and filtering function. + fmapMaybe :: (a -> Maybe b) -> f a -> f b + +-- | @fmapMaybe = (=<<) +instance FunctorMaybe Maybe where + fmapMaybe = (=<<) + +-- | @fmapMaybe = mapMaybe@ +instance FunctorMaybe [] where + fmapMaybe = mapMaybe + +instance FunctorMaybe (Map k) where + fmapMaybe = Map.mapMaybe + +instance FunctorMaybe IntMap where + fmapMaybe = IntMap.mapMaybe diff --git a/src/Reflex/Host/Class.hs b/src/Reflex/Host/Class.hs --- a/src/Reflex/Host/Class.hs +++ b/src/Reflex/Host/Class.hs @@ -1,55 +1,90 @@ -{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies, FlexibleContexts #-} -module Reflex.Host.Class where +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +-- | This module provides the interface for hosting 'Reflex' engines. This +-- should only be necessary if you're writing a binding or some other library +-- that provides a core event loop. +module Reflex.Host.Class + ( ReflexHost (..) + , MonadSubscribeEvent (..) + , MonadReadEvent (..) + , MonadReflexCreateTrigger (..) + , MonadReflexHost (..) + , fireEvents + , newEventWithTriggerRef + , fireEventRef + , fireEventRefAndRead + ) where import Reflex.Class -import Control.Applicative -import Control.Monad import Control.Monad.Fix import Control.Monad.Identity +import Control.Monad.Ref import Control.Monad.Trans -import Control.Monad.Trans.Reader (ReaderT()) -import Control.Monad.Trans.Writer (WriterT()) -import Control.Monad.Trans.Cont (ContT()) -import Control.Monad.Trans.Except (ExceptT()) -import Control.Monad.Trans.RWS (RWST()) -import Control.Monad.Trans.State (StateT()) +import Control.Monad.Trans.Cont (ContT) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.RWS (RWST) +import Control.Monad.Trans.State (StateT) import qualified Control.Monad.Trans.State.Strict as Strict +import Control.Monad.Trans.Writer (WriterT) import Data.Dependent.Sum (DSum (..)) -import Data.Monoid import Data.GADT.Compare -import Control.Monad.Ref --- Note: this import must come last to silence warnings from AMP -import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl) - --- | Framework implementation support class for the reflex implementation represented by @t@. -class (Reflex t, MonadReflexCreateTrigger t (HostFrame t), MonadSample t (HostFrame t), MonadHold t (HostFrame t), MonadFix (HostFrame t), MonadSubscribeEvent t (HostFrame t)) => ReflexHost t where +-- | Framework implementation support class for the reflex implementation +-- represented by @t@. +class ( Reflex t + , MonadReflexCreateTrigger t (HostFrame t) + , MonadSample t (HostFrame t) + , MonadHold t (HostFrame t) + , MonadFix (HostFrame t) + , MonadSubscribeEvent t (HostFrame t) + ) => ReflexHost t where type EventTrigger t :: * -> * type EventHandle t :: * -> * type HostFrame t :: * -> * --- | Monad in which Events can be 'subscribed'. This forces all underlying event sources to be initialized, so that the event will fire whenever it ought to. Events must be subscribed before they are read using readEvent +-- | Monad in which Events can be 'subscribed'. This forces all underlying +-- event sources to be initialized, so that the event will fire whenever it +-- ought to. Events must be subscribed before they are read using readEvent class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where -- | Subscribe to an event and set it up if needed. -- - -- This function will create a new 'EventHandle' from an 'Event'. This handle may then be used via - -- 'readEvent' in the read callback of 'fireEventsAndRead'. + -- This function will create a new 'EventHandle' from an 'Event'. This handle + -- may then be used via 'readEvent' in the read callback of + -- 'fireEventsAndRead'. -- - -- If the event wasn't subscribed to before (either manually or through a dependent event or behavior) - -- then this function will cause the event and all dependencies of this event to be set up. - -- For example, if the event was created by 'newEventWithTrigger', then it's callback will be executed. + -- If the event wasn't subscribed to before (either manually or through a + -- dependent event or behavior) then this function will cause the event and + -- all dependencies of this event to be set up. For example, if the event was + -- created by 'newEventWithTrigger', then it's callback will be executed. -- -- It's safe to call this function multiple times. subscribeEvent :: Event t a -> m (EventHandle t a) -- | Monad that allows to read events' values. class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where - -- | Read the value of an 'Event' from an 'EventHandle' (created by calling 'subscribeEvent'). + -- | Read the value of an 'Event' from an 'EventHandle' (created by calling + -- 'subscribeEvent'). -- - -- After event propagation is done, all events can be in two states: either they are firing with some value or they are not firing. - -- In the former case, this function returns @Just act@, where @act@ in an action to read the current value of - -- the event. In the latter case, the function returns @Nothing@. + -- After event propagation is done, all events can be in two states: either + -- they are firing with some value or they are not firing. In the former + -- case, this function returns @Just act@, where @act@ in an action to read + -- the current value of the event. In the latter case, the function returns + -- @Nothing@. -- -- This function is normally used in the calllback for 'fireEventsAndRead'. readEvent :: EventHandle t a -> m (Maybe (m a)) @@ -58,42 +93,54 @@ class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where -- | Creates a root 'Event' (one that is not based on any other event). -- - -- When a subscriber first subscribes to an event (building another event - -- that depends on the subscription) the given callback function is run and - -- passed a trigger. The callback function can then set up the event source in IO. - -- After this is done, the callback function must return an accompanying teardown action. + -- When a subscriber first subscribes to an event (building another event that + -- depends on the subscription) the given callback function is run and passed + -- a trigger. The callback function can then set up the event source in IO. + -- After this is done, the callback function must return an accompanying + -- teardown action. -- - -- Any time between setup and teardown the trigger can be used to fire - -- the event, by passing it to 'fireEventsAndRead'. + -- Any time between setup and teardown the trigger can be used to fire the + -- event, by passing it to 'fireEventsAndRead'. -- - -- Note: An event may be set up multiple times. So after the teardown action is executed, the event may still be set up again in the future. + -- Note: An event may be set up multiple times. So after the teardown action + -- is executed, the event may still be set up again in the future. newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a) newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k) -class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, MonadReadEvent t (ReadPhase m), MonadSample t (ReadPhase m), MonadHold t (ReadPhase m)) => MonadReflexHost t m | m -> t where +-- | 'MonadReflexHost' designates monads that can run reflex frames. +class ( ReflexHost t + , MonadReflexCreateTrigger t m + , MonadSubscribeEvent t m + , MonadReadEvent t (ReadPhase m) + , MonadSample t (ReadPhase m) + , MonadHold t (ReadPhase m) + ) => MonadReflexHost t m | m -> t where type ReadPhase m :: * -> * -- | Propagate some events firings and read the values of events afterwards. -- - -- This function will create a new frame to fire the given events. It will then update all - -- dependent events and behaviors. After that is done, the given callback is executed which - -- allows to read the final values of events and check whether they have fired in this frame or - -- not. + -- This function will create a new frame to fire the given events. It will + -- then update all dependent events and behaviors. After that is done, the + -- given callback is executed which allows to read the final values of events + -- and check whether they have fired in this frame or not. -- -- All events that are given are fired at the same time. -- - -- This function is typically used in the main loop of a reflex framework implementation. - -- The main loop waits for external events to happen (such as keyboard input or a mouse click) - -- and then fires the corresponding events using this function. The read callback can be used - -- to read output events and perform a corresponding response action to the external event. - fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> (ReadPhase m a) -> m a + -- This function is typically used in the main loop of a reflex framework + -- implementation. The main loop waits for external events to happen (such as + -- keyboard input or a mouse click) and then fires the corresponding events + -- using this function. The read callback can be used to read output events + -- and perform a corresponding response action to the external event. + fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m a -- | Run a frame without any events firing. -- - -- This function should be used when you want to use 'sample' and 'hold' when no events are currently firing. - -- Using this function in that case can improve performance, since the implementation can assume that no events - -- are firing when 'sample' or 'hold' are called. + -- This function should be used when you want to use 'sample' and 'hold' when + -- no events are currently firing. Using this function in that case can + -- improve performance, since the implementation can assume that no events are + -- firing when 'sample' or 'hold' are called. -- - -- This function is commonly used to set up the basic event network when the application starts up. + -- This function is commonly used to set up the basic event network when the + -- application starts up. runHostFrame :: HostFrame t a -> m a -- | Like 'fireEventsAndRead', but without reading any events. @@ -103,10 +150,13 @@ -- | Create a new event and store its trigger in an 'IORef' while it's active. -- --- An event is only active between the set up (when it's first subscribed to) and the teardown phases (when noboby is subscribing the event anymore). --- This function returns an Event and an 'IORef'. As long as the event is active, the 'IORef' will contain 'Just' the event trigger to --- trigger this event. When the event is not active, the 'IORef' will contain 'Nothing'. This allows event sources to be more efficient, --- since they don't need to produce events when nobody is listening. +-- An event is only active between the set up (when it's first subscribed to) +-- and the teardown phases (when noboby is subscribing the event anymore). This +-- function returns an Event and an 'IORef'. As long as the event is active, the +-- 'IORef' will contain 'Just' the event trigger to trigger this event. When the +-- event is not active, the 'IORef' will contain 'Nothing'. This allows event +-- sources to be more efficient, since they don't need to produce events when +-- nobody is listening. newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a))) newEventWithTriggerRef = do rt <- newRef Nothing @@ -116,6 +166,7 @@ return (e, rt) {-# INLINE newEventWithTriggerRef #-} +-- | Fire the given trigger if it is not 'Nothing'. fireEventRef :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> m () fireEventRef mtRef input = do mt <- readRef mtRef @@ -123,6 +174,8 @@ Nothing -> return () Just trigger -> fireEvents [trigger :=> Identity input] +-- | Fire the given trigger if it is not 'Nothing', and read from the given +-- 'EventHandle'. fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b) fireEventRefAndRead mtRef input e = do mt <- readRef mtRef @@ -132,7 +185,7 @@ mGetValue <- readEvent e case mGetValue of Nothing -> return Nothing - Just getValue -> liftM Just getValue + Just getValue -> fmap Just getValue -------------------------------------------------------------------------------- @@ -174,8 +227,8 @@ type ReadPhase (StateT s m) = ReadPhase m fireEventsAndRead dm a = lift $ fireEventsAndRead dm a runHostFrame = lift . runHostFrame - - + + instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Strict.StateT s m) where newEventWithTrigger = lift . newEventWithTrigger newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer @@ -186,9 +239,9 @@ instance MonadReflexHost t m => MonadReflexHost t (Strict.StateT s m) where type ReadPhase (Strict.StateT s m) = ReadPhase m fireEventsAndRead dm a = lift $ fireEventsAndRead dm a - runHostFrame = lift . runHostFrame - - + runHostFrame = lift . runHostFrame + + instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where newEventWithTrigger = lift . newEventWithTrigger diff --git a/src/Reflex/Network.hs b/src/Reflex/Network.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Network.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.Network + ( networkView + , networkHold + , untilReady + ) where + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.NotReady.Class +import Reflex.PostBuild.Class + +-- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates. +-- The returned Event of network results occurs when the Dynamic does. +-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly'). +networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a) +networkView child = do + postBuild <- getPostBuild + let newChild = leftmost [updated child, tagCheap (current child) postBuild] + snd <$> runWithReplace notReady newChild + +-- | Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the Event fires. +-- The returned Dynamic of network results occurs when the Event does. +-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened. +networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a) +networkHold child0 newChild = do + (result0, newResult) <- runWithReplace child0 newChild + holdDyn result0 newResult + +-- | Render a placeholder network to be shown while another network is not yet +-- done building +untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b) +untilReady a b = do + postBuild <- getPostBuild + runWithReplace a $ b <$ postBuild diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/NotReady/Class.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.NotReady.Class + ( NotReady(..) + ) where + +import Control.Monad.Reader (ReaderT) +import Control.Monad.Trans + +import Reflex.Class +import Reflex.DynamicWriter.Base (DynamicWriterT) +import Reflex.EventWriter.Base (EventWriterT) +import Reflex.Host.Class +import Reflex.PerformEvent.Base (PerformEventT (..)) +import Reflex.PostBuild.Base (PostBuildT) +import Reflex.Query.Base (QueryT) +import Reflex.Requester.Base (RequesterT) +import Reflex.TriggerEvent.Base (TriggerEventT) + +class Monad m => NotReady t m | m -> t where + notReadyUntil :: Event t a -> m () + default notReadyUntil :: (MonadTrans f, m ~ f m', NotReady t m') => Event t a -> m () + notReadyUntil = lift . notReadyUntil + + notReady :: m () + default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m () + notReady = lift notReady + +instance NotReady t m => NotReady t (ReaderT r m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (PostBuildT t m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (EventWriterT t w m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (DynamicWriterT t w m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (QueryT t q m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where + notReadyUntil = PerformEventT . notReadyUntil + notReady = PerformEventT notReady + +instance NotReady t m => NotReady t (RequesterT t request response m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (TriggerEventT t m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady diff --git a/src/Reflex/Optimizer.hs b/src/Reflex/Optimizer.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Optimizer.hs @@ -0,0 +1,61 @@ +-- | This module provides a GHC plugin designed to improve code that uses +-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level +-- definition that doesn't have an explicit inlining pragma. In the future, +-- additional optimizations are likely to be added. +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Reflex.Optimizer + ( plugin + ) where + +#ifdef ghcjs_HOST_OS +import Plugins +#else +import Control.Arrow +import CoreMonad +import Data.String +import GhcPlugins + +#if MIN_VERSION_base(4,9,0) +import Prelude hiding ((<>)) +#endif + +#endif + +#ifdef ghcjs_HOST_OS + +-- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used. +plugin :: Plugin +plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS." + +#else + +-- | The GHC plugin itself. See "GhcPlugins" for more details. +plugin :: Plugin +plugin = defaultPlugin { installCoreToDos = install } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install [] p = do + liftIO $ putStrLn $ showSDocUnsafe $ ppr p + let f = \case + simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl] + x -> [x] + return $ makeInlinable : concatMap f p +install options@(_:_) p = do + warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options" + install [] p + +makeInlinable :: CoreToDo +makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do + let f v = setIdInfo v $ let i = idInfo v in + setInlinePragInfo i $ let p = inlinePragInfo i in + if isDefaultInlinePragma p + then defaultInlinePragma { inl_inline = Inlinable } + else p + newBinds = flip map (mg_binds modGuts) $ \case + NonRec b e -> NonRec (f b) e + Rec bes -> Rec $ map (first f) bes + return $ modGuts { mg_binds = newBinds } + +#endif diff --git a/src/Reflex/Patch.hs b/src/Reflex/Patch.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Patch.hs @@ -0,0 +1,39 @@ +-- | This module defines the 'Patch' class, which is used by Reflex to manage +-- changes to 'Reflex.Class.Incremental' values. +{-# LANGUAGE TypeFamilies #-} +module Reflex.Patch + ( module Reflex.Patch + , module X + ) where + +import Reflex.Patch.Class as X +import Reflex.Patch.DMap as X hiding (getDeletions) +import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove, + patchDMapWithMoveToPatchMapWithMoveWith, + traversePatchDMapWithMoveWithKey, unPatchDMapWithMove, + unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith) +import Reflex.Patch.IntMap as X hiding (getDeletions) +import Reflex.Patch.Map as X +import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, + patchMapWithMoveNewElementsMap, unPatchMapWithMove, + unsafePatchMapWithMove) + +import Data.Semigroup (Semigroup (..), (<>)) + +---- Patches based on commutative groups + +-- | A 'Group' is a 'Monoid' where every element has an inverse. +class (Semigroup q, Monoid q) => Group q where + negateG :: q -> q + (~~) :: q -> q -> q + r ~~ s = r <> negateG s + +-- | An 'Additive' 'Semigroup' is one where (<>) is commutative +class Semigroup q => Additive q where + +-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type. +newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p } + +instance Additive p => Patch (AdditivePatch p) where + type PatchTarget (AdditivePatch p) = p + apply (AdditivePatch p) q = Just $ p <> q diff --git a/src/Reflex/Patch/Class.hs b/src/Reflex/Patch/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Patch/Class.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeFamilies #-} +-- | The interface for types which represent changes made to other types +module Reflex.Patch.Class where + +import Control.Monad.Identity +import Data.Maybe +import Data.Semigroup + +-- | A 'Patch' type represents a kind of change made to a datastructure. +-- +-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey +-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@. +class Patch p where + type PatchTarget p :: * + -- | Apply the patch @p a@ to the value @a@. If no change is needed, return + -- 'Nothing'. + apply :: p -> PatchTarget p -> Maybe (PatchTarget p) + +-- | Apply a 'Patch'; if it does nothing, return the original value +applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p +applyAlways p t = fromMaybe t $ apply p t + +-- | 'Identity' can be used as a 'Patch' that always fully replaces the value +instance Patch (Identity a) where + type PatchTarget (Identity a) = a + apply (Identity a) _ = Just a + +-- | Like '(.)', but composes functions that return patches rather than +-- functions that return new values. The Semigroup instance for patches must +-- apply patches right-to-left, like '(.)'. +composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p +composePatchFunctions g f a = + let fp = f a + in g (applyAlways fp a) <> fp diff --git a/src/Reflex/Patch/DMap.hs b/src/Reflex/Patch/DMap.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Patch/DMap.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions. +module Reflex.Patch.DMap where + +import Reflex.Patch.Class +import Reflex.Patch.IntMap +import Reflex.Patch.Map + +import Data.Dependent.Map (DMap, DSum (..), GCompare (..)) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Constant +import Data.Functor.Misc +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Semigroup (Semigroup (..)) +import Data.Some (Some) + +-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted. +-- Insertions are represented as @'ComposeMaybe' (Just value)@, +-- while deletions are represented as @'ComposeMaybe' Nothing@. +newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) } + +deriving instance GCompare k => Semigroup (PatchDMap k v) + +deriving instance GCompare k => Monoid (PatchDMap k v) + +-- | Apply the insertions or deletions to a given 'DMap'. +instance GCompare k => Patch (PatchDMap k v) where + type PatchTarget (PatchDMap k v) = DMap k v + apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? + where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff + deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff + nothingToJust = \case + Nothing -> Just $ Constant () + Just _ -> Nothing + +-- | Map a function @v a -> v' a@ over any inserts/updates in the given +-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. +mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v' +mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p + +-- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given +-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. +traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v') +traversePatchDMap f = traversePatchDMapWithKey $ const f + +-- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates +-- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. +traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v') +traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p + +-- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function +-- @v a -> v'@ to weaken each value contained in the patch. +weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v' +weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p + +-- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of +-- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@. +patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v' +patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p + +-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@. +const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v' +const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p + where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v') + g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) + +-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@. +const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f +const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p + where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f) + g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) + +-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'. +getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v' +getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p diff --git a/src/Reflex/Patch/DMapWithMove.hs b/src/Reflex/Patch/DMapWithMove.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Patch/DMapWithMove.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and +-- move values between keys. +module Reflex.Patch.DMapWithMove where + +import Reflex.Patch.Class +import Reflex.Patch.MapWithMove (PatchMapWithMove (..)) +import qualified Reflex.Patch.MapWithMove as MapWithMove + +import Data.Dependent.Map (DMap, DSum (..), GCompare (..)) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum (EqTag (..)) +import Data.Functor.Constant +import Data.Functor.Misc +import Data.Functor.Product +import Data.GADT.Compare (GEq (..)) +import Data.GADT.Show (GShow, gshow) +import qualified Data.Map as Map +import Data.Maybe +import Data.Semigroup (Semigroup (..), (<>)) +import Data.Some (Some) +import qualified Data.Some as Some +import Data.These + +-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and +-- destinations. +-- +-- Invariants: +-- +-- * A key should not move to itself. +-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@) +newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v)) + +-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key +-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move. +data NodeInfo k v a = NodeInfo + { _nodeInfo_from :: !(From k v a) + -- ^Change applying to the current key, be it an insert, move, or delete. + , _nodeInfo_to :: !(To k a) + -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'. + } + deriving (Show) + +-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a +-- key (@From_Delete@), or moving a key (@From_Move@). +data From (k :: a -> *) (v :: a -> *) :: a -> * where + -- |Insert a new or update an existing key with the given value @v a@ + From_Insert :: v a -> From k v a + -- |Delete the existing key + From_Delete :: From k v a + -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@, + -- usually but not necessarily with @From_Delete@. + From_Move :: !(k a) -> From k v a + deriving (Show, Read, Eq, Ord) + +-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other +-- operation. +type To = ComposeMaybe + +-- |Test whether a 'PatchDMapWithMove' satisfies its invariants. +validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool +validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove + +-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid. +validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String] +validationErrorsForPatchDMapWithMove m = + noSelfMoves <> movesBalanced + where + noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m + selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side" + selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side" + selfMove _ = Nothing + movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m + unbalancedMove (dst :=> NodeInfo (From_Move src) _) = + case DMap.lookup src m of + Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch" + Just (NodeInfo _ (ComposeMaybe (Just dst'))) -> + if isNothing (dst' `geq` dst) + then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead" + else Nothing + _ -> + Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key" + unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) = + case DMap.lookup dst m of + Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch" + Just (NodeInfo (From_Move src') _) -> + if isNothing (src' `geq` src) + then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead" + else Nothing + + _ -> + Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving" + unbalancedMove _ = Nothing + +-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations. +instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where + PatchDMapWithMove a == PatchDMapWithMove b = a == b + +-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9 +data Pair1 f g a = Pair1 (f a) (g a) + +-- |Helper data structure used for composing patches using the monoid instance. +data Fixup k v a + = Fixup_Delete + | Fixup_Update (These (From k v a) (To k a)) + +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance GCompare k => Semigroup (PatchDMapWithMove k v) where + PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m + where + connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb + h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)] + h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of + (Just toAfter, From_Move fromBefore) + | isJust $ fromBefore `geq` toAfter + -> [toAfter :=> Fixup_Delete] + | otherwise + -> [ toAfter :=> Fixup_Update (This editBefore) + , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter)) + ] + (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map + (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)] + (Nothing, _) -> [] + mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete + mergeFixups _ (Fixup_Update a) (Fixup_Update b) + | This x <- a, That y <- b + = Fixup_Update $ These x y + | That y <- a, This x <- b + = Fixup_Update $ These x y + mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups" + fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections + combineNodeInfos _ nia nib = NodeInfo + { _nodeInfo_from = _nodeInfo_from nia + , _nodeInfo_to = _nodeInfo_to nib + } + applyFixup _ ni = \case + Fixup_Delete -> Nothing + Fixup_Update u -> Just $ NodeInfo + { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u + , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u + } + m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups + getHere :: These a b -> Maybe a + getHere = \case + This a -> Just a + These a _ -> Just a + That _ -> Nothing + getThere :: These a b -> Maybe b + getThere = \case + This _ -> Nothing + These _ b -> Just b + That b -> Just b + +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance GCompare k => Monoid (PatchDMapWithMove k v) where + mempty = PatchDMapWithMove mempty + mappend = (<>) + +{- +mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v +PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src + where + getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself + removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing + removeRedundantDst _ a = Just a + f :: forall a. k a -> From k v a -> Maybe (From k v a) + f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of + From_Move fromKey -> getDstAction fromKey dstBefore + nonMove -> nonMove + dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore + getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m + removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing + removeRedundantSrc _ a = Just a + g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a) + g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of + ComposeMaybe Nothing -> ComposeMaybe Nothing + ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter + src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore +-} + +-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'. +insertDMapKey :: k a -> v a -> PatchDMapWithMove k v +insertDMapKey k v = + PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing) + +-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to: +-- +-- @ +-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap)) +-- @ +moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v +moveDMapKey src dst = case src `geq` dst of + Nothing -> PatchDMapWithMove $ DMap.fromList + [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing) + , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst) + ] + Just _ -> mempty + +-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to: +-- +-- @ +-- let aMay = DMap.lookup a dmap +-- bMay = DMap.lookup b dmap +-- in maybe id (DMap.insert a) (bMay `mplus` aMay) +-- . maybe id (DMap.insert b) (aMay `mplus` bMay) +-- . DMap.delete a . DMap.delete b $ dmap +-- @ +swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v +swapDMapKey src dst = case src `geq` dst of + Nothing -> PatchDMapWithMove $ DMap.fromList + [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src) + , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst) + ] + Just _ -> mempty + +-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'. +deleteDMapKey :: k a -> PatchDMapWithMove k v +deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing + +{- +k1, k2 :: Const2 Int () () +k1 = Const2 1 +k2 = Const2 2 +p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity +p1 = moveDMapKey k1 k2 +p2 = moveDMapKey k2 k1 +p12 = p1 <> p2 +p21 = p2 <> p1 +p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2 +p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1 + +testPatchDMapWithMove = do + print p1 + print p2 + print $ p12 == deleteDMapKey k1 + print $ p21 == deleteDMapKey k2 + print $ p12Slow == deleteDMapKey k1 + print $ p21Slow == deleteDMapKey k2 + +dst (PatchDMapWithMove x _) = x +src (PatchDMapWithMove _ x) = x +-} + +-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'. +unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v) +unPatchDMapWithMove (PatchDMapWithMove p) = p + +-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants. +-- +-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked. +unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v +unsafePatchDMapWithMove = PatchDMapWithMove + +-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned +-- otherwise @Left errors@. +patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v) +patchDMapWithMove dm = + case validationErrorsForPatchDMapWithMove dm of + [] -> Right $ unsafePatchDMapWithMove dm + errs -> Left errs + +-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@. +mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v' +mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ + DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p + where g :: forall a. From k v a -> From k v' a + g = \case + From_Insert v -> From_Insert $ f v + From_Delete -> From_Delete + From_Move k -> From_Move k + +-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@. +traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v') +traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f + +-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@. +traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v') +traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p + where g :: forall a. k a -> From k v a -> m (From k v' a) + g k = \case + From_Insert v -> From_Insert <$> f k v + From_Delete -> pure From_Delete + From_Move fromKey -> pure $ From_Move fromKey + +-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@. +nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a +nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni } + +-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@. +nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a) +nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni + +-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to +-- values. +weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v' +weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p + where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v' + g ni = MapWithMove.NodeInfo + { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of + From_Insert v -> MapWithMove.From_Insert $ f v + From_Delete -> MapWithMove.From_Delete + From_Move k -> MapWithMove.From_Move $ Some.This k + , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni) + } + +-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any +-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank. +patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v' +patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p + where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v' + g ni = MapWithMove.NodeInfo + { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of + From_Insert v -> MapWithMove.From_Insert $ f v + From_Delete -> MapWithMove.From_Delete + From_Move (Const2 k) -> MapWithMove.From_Move k + , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni) + } + +-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed +-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@. +-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith' +const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v' +const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p + where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v') + g (k, ni) = Const2 k :=> NodeInfo + { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of + MapWithMove.From_Insert v -> From_Insert $ f v + MapWithMove.From_Delete -> From_Delete + MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey + , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni + } + +-- | Apply the insertions, deletions, and moves to a given 'DMap'. +instance GCompare k => Patch (PatchDMapWithMove k v) where + type PatchTarget (PatchDMapWithMove k v) = DMap k v + apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? + where insertions = DMap.mapMaybeWithKey insertFunc p + insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a) + insertFunc _ ni = case _nodeInfo_from ni of + From_Insert v -> Just v + From_Move k -> DMap.lookup k old + From_Delete -> Nothing + deletions = DMap.mapMaybeWithKey deleteFunc p + deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a) + deleteFunc _ ni = case _nodeInfo_from ni of + From_Delete -> Just $ Constant () + _ -> Nothing + +-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'. +getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k)) +getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p + where f _ v ni = Pair v $ _nodeInfo_to ni diff --git a/src/Reflex/Patch/IntMap.hs b/src/Reflex/Patch/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Patch/IntMap.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for +-- insert/update or delete of associations. +module Reflex.Patch.IntMap where + +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Maybe +import Data.Semigroup +import Reflex.Patch.Class + +-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping. +-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update +-- and @Nothing@ means delete. +newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid) + +-- | Apply the insertions or deletions to a given 'IntMap'. +instance Patch (PatchIntMap a) where + type PatchTarget (PatchIntMap a) = IntMap a + apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $ + let removes = IntMap.filter isNothing p + adds = IntMap.mapMaybe id p + in IntMap.union adds $ v `IntMap.difference` removes + +-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. +-- If the same key is modified by both patches, the one on the left will take +-- precedence. +instance Semigroup (PatchIntMap v) where + PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map + -- PatchMap is idempotent, so stimes n is id for every n +#if MIN_VERSION_semigroups(0,17,0) + stimes = stimesIdempotentMonoid +#else + times1p n x = case compare n 0 of + LT -> error "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x +#endif + +-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@ +-- (that is, all inserts/updates), producing a @PatchIntMap b@. +mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b +mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m + +-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@ +-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@. +traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b) +traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m + +-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@. +patchIntMapNewElements :: PatchIntMap a -> [a] +patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m + +-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all +-- the inserts/updates in the given patch. +patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a +patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m + +-- | Subset the given @'IntMap' a@ to contain only the keys that would be +-- deleted by the given @'PatchIntMap' a@. +getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v' +getDeletions (PatchIntMap m) v = IntMap.intersection v m diff --git a/src/Reflex/Patch/Map.hs b/src/Reflex/Patch/Map.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Patch/Map.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites) +-- and deletions +module Reflex.Patch.Map where + +import Reflex.Patch.Class + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Semigroup + +-- | A set of changes to a 'Map'. Any element may be inserted/updated or +-- deleted. Insertions are represented as values wrapped in 'Just', while +-- deletions are represented as 'Nothing's +newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) } + deriving (Show, Read, Eq, Ord) + +-- | Apply the insertions or deletions to a given 'Map'. +instance Ord k => Patch (PatchMap k v) where + type PatchTarget (PatchMap k v) = Map k v + {-# INLINABLE apply #-} + apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? + where insertions = Map.mapMaybeWithKey (const id) p + deletions = Map.mapMaybeWithKey (const nothingToJust) p + nothingToJust = \case + Nothing -> Just () + Just _ -> Nothing + +-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. +-- If the same key is modified by both patches, the one on the left will take +-- precedence. +instance Ord k => Semigroup (PatchMap k v) where + PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map + -- PatchMap is idempotent, so stimes n is id for every n +#if MIN_VERSION_semigroups(0,17,0) + stimes = stimesIdempotentMonoid +#else + times1p n x = case compare n 0 of + LT -> error "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x +#endif + +-- | The empty 'PatchMap' contains no insertions or deletions +instance Ord k => Monoid (PatchMap k v) where + mempty = PatchMap mempty + mappend = (<>) + +-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert. +-- Deletions are unaffected. +instance Functor (PatchMap k) where + fmap f = PatchMap . fmap (fmap f) . unPatchMap + +-- | Returns all the new elements that will be added to the 'Map' +patchMapNewElements :: PatchMap k v -> [v] +patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p + +-- | Returns all the new elements that will be added to the 'Map' +patchMapNewElementsMap :: PatchMap k v -> Map k v +patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Patch/MapWithMove.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to +-- another +module Reflex.Patch.MapWithMove where + +import Reflex.Patch.Class + +import Control.Arrow +import Control.Monad.State +import Data.Foldable +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Semigroup (Semigroup (..), (<>)) +import qualified Data.Set as Set +import Data.These +import Data.Tuple + +-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@ +-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@, +-- and vice versa. There should never be any unpaired From/To keys. +newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + +-- | Holds the information about each key: where its new value should come from, +-- and where its old value should go to +data NodeInfo k v = NodeInfo + { _nodeInfo_from :: !(From k v) + -- ^ Where do we get the new value for this key? + , _nodeInfo_to :: !(To k) + -- ^ If the old value is being kept (i.e. moved rather than deleted or + -- replaced), where is it going? + } + deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) + +-- | Describe how a key's new value should be produced +data From k v + = From_Insert v -- ^ Insert the given value here + | From_Delete -- ^ Delete the existing value, if any, from here + | From_Move !k -- ^ Move the value here from the given key + deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) + +-- | Describe where a key's old value will go. If this is 'Just', that means +-- the key's old value will be moved to the given other key; if it is 'Nothing', +-- that means it will be deleted. +type To = Maybe + +-- | Create a 'PatchMapWithMove', validating it +patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v) +patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing + where valid = forwardLinks == backwardLinks + forwardLinks = Map.mapMaybe _nodeInfo_to m + backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) -> + case _nodeInfo_from v of + From_Move from -> Just (from, to) + _ -> Nothing + +-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map' +patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v +patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo + { _nodeInfo_from = From_Insert v + , _nodeInfo_to = Nothing + } + +-- | Extract the internal representation of the 'PatchMapWithMove' +unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v) +unPatchMapWithMove (PatchMapWithMove p) = p + +-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'. +insertMapKey :: k -> v -> PatchMapWithMove k v +insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing + +-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to: +-- +-- @ +-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map)) +-- @ +moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v +moveMapKey src dst + | src == dst = mempty + | otherwise = + PatchMapWithMove $ Map.fromList + [ (dst, NodeInfo (From_Move src) Nothing) + , (src, NodeInfo From_Delete (Just dst)) + ] + +-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to: +-- +-- @ +-- let aMay = Map.lookup a map +-- bMay = Map.lookup b map +-- in maybe id (Map.insert a) (bMay `mplus` aMay) +-- . maybe id (Map.insert b) (aMay `mplus` bMay) +-- . Map.delete a . Map.delete b $ map +-- @ +swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v +swapMapKey src dst + | src == dst = mempty + | otherwise = + PatchMapWithMove $ Map.fromList + [ (dst, NodeInfo (From_Move src) (Just src)) + , (src, NodeInfo (From_Move dst) (Just dst)) + ] + +-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'. +deleteMapKey :: k -> PatchMapWithMove k v +deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing + +-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants. +-- +-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked. +unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v +unsafePatchMapWithMove = PatchMapWithMove + +-- | Apply the insertions, deletions, and moves to a given 'Map' +instance Ord k => Patch (PatchMapWithMove k v) where + type PatchTarget (PatchMapWithMove k v) = Map k v + apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? + where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of + From_Insert v -> Just v + From_Move k -> Map.lookup k old + From_Delete -> Nothing + deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of + From_Delete -> Just () + _ -> Nothing + +-- | Returns all the new elements that will be added to the 'Map'. +patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v] +patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap + +-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@. +patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v +patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p + where f ni = case _nodeInfo_from ni of + From_Insert v -> Just v + From_Move _ -> Nothing + From_Delete -> Nothing + +-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort +-- its values using the given ordering function. The set keys of the 'Map' is +-- not changed. +patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v +patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted + where unsorted = Map.toList m + sorted = sortBy (cmp `on` snd) unsorted + f (to, _) (from, _) = if to == from then Nothing else + Just (from, to) + reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted + g (to, _) (from, _) = if to == from then Nothing else + let Just movingTo = Map.lookup from reverseMapping + in Just (to, NodeInfo (From_Move from) $ Just movingTo) + +-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided, +-- will produce a 'Map' with the same values as the second 'Map' but with the +-- values sorted with the given ordering function. +patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v +patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex + where newList = Map.toList newByIndexUnsorted + newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList + +-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided, +-- will produce the second 'Map'. +patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v +patchThatChangesMap oldByIndex newByIndex = patch + where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex + (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do + let f k v = do + remainingValues <- get + let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys + then Map.delete v remainingValues + else Map.insert v remainingKeys remainingValues + case Map.lookup v remainingValues of + Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take + Just fromKs -> + if k `Set.member` fromKs + then do + putRemainingKeys $ Set.delete k fromKs + return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary + else do + (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here + putRemainingKeys remainingKeys + return $ NodeInfo (From_Move fromK) $ Just undefined + Map.traverseWithKey f newByIndex + unusedOldKeys = fold unusedValuesByValue + pointlessMove k = \case + From_Move k' | k == k' -> True + _ -> False + keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys) + then Just undefined + else Nothing + patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex + +-- | Change the 'From' value of a 'NodeInfo' +nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v +nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni } + +-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or +-- 'Applicative', 'Monad', etc.) action to get the new value +nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v) +nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni + +-- | Set the 'To' field of a 'NodeInfo' +nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v +nodeInfoSetTo to ni = ni { _nodeInfo_to = to } + +-- |Helper data structure used for composing patches using the monoid instance. +data Fixup k v + = Fixup_Delete + | Fixup_Update (These (From k v) (To k)) + +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance Ord k => Semigroup (PatchMapWithMove k v) where + PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m + where + connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb + h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)] + h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of + (Just toAfter, From_Move fromBefore) + | fromBefore == toAfter + -> [(toAfter, Fixup_Delete)] + | otherwise + -> [ (toAfter, Fixup_Update (This editBefore)) + , (fromBefore, Fixup_Update (That mToAfter)) + ] + (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map + (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))] + (Nothing, _) -> [] + mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete + mergeFixups _ (Fixup_Update a) (Fixup_Update b) + | This x <- a, That y <- b + = Fixup_Update $ These x y + | That y <- a, This x <- b + = Fixup_Update $ These x y + mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups" + fixups = Map.fromListWithKey mergeFixups $ concatMap h connections + combineNodeInfos _ nia nib = NodeInfo + { _nodeInfo_from = _nodeInfo_from nia + , _nodeInfo_to = _nodeInfo_to nib + } + applyFixup _ ni = \case + Fixup_Delete -> Nothing + Fixup_Update u -> Just $ NodeInfo + { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u + , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u + } + m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups + getHere :: These a b -> Maybe a + getHere = \case + This a -> Just a + These a _ -> Just a + That _ -> Nothing + getThere :: These a b -> Maybe b + getThere = \case + This _ -> Nothing + These _ b -> Just b + That b -> Just b + +--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance Ord k => Monoid (PatchMapWithMove k v) where + mempty = PatchMapWithMove mempty + mappend = (<>) diff --git a/src/Reflex/PerformEvent/Base.hs b/src/Reflex/PerformEvent/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/PerformEvent/Base.hs @@ -0,0 +1,179 @@ +-- | This module provides 'PerformEventT', the standard implementation of +-- 'PerformEvent'. +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.PerformEvent.Base + ( PerformEventT (..) + , FireCommand (..) + , hostPerformEventT + ) where + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.Host.Class +import Reflex.PerformEvent.Class +import Reflex.Requester.Base +import Reflex.Requester.Class + +import Control.Lens +import Control.Monad.Exception +import Control.Monad.Identity +import Control.Monad.Primitive +import Control.Monad.Reader +import Control.Monad.Ref +import Data.Coerce +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Semigroup as S + +-- | A function that fires events for the given 'EventTrigger's and then runs +-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase' +-- action will be run once for the initial trigger execution as well as once for +-- each followup. +newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in? + +-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the +-- name, 'PerformEventT' is not an instance of 'MonadTrans'. +newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a } + +deriving instance ReflexHost t => Functor (PerformEventT t m) +deriving instance ReflexHost t => Applicative (PerformEventT t m) +deriving instance ReflexHost t => Monad (PerformEventT t m) +deriving instance ReflexHost t => MonadFix (PerformEventT t m) +deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m) +deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m) +deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a) +deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a) + +instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where + type PrimState (PerformEventT t m) = PrimState (HostFrame t) + primitive = PerformEventT . lift . primitive + +instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where + type Performable (PerformEventT t m) = HostFrame t + {-# INLINABLE performEvent_ #-} + performEvent_ = PerformEventT . requesting_ + {-# INLINABLE performEvent #-} + performEvent = PerformEventT . requestingIdentity + +instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where + runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA') + where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b) + f a0 a' = do + result0 <- lift a0 + result' <- requestingIdentity a' + return (result0, result') + traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') + traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') + traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') + +defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t) + => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2)) + -> (forall a. k' a -> v a -> HostFrame t (v2 a)) + -> DMap k' v + -> Event t (p k' v) + -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2)) +defaultAdjustBase traversePatchWithKey f' dm0 dm' = do + result0 <- lift $ DMap.traverseWithKey f' dm0 + result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' + return (result0, result') + +defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t) + => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2)) + -> (IntMap.Key -> v -> HostFrame t v2) + -> IntMap v + -> Event t (p v) + -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2)) +defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do + result0 <- lift $ IntMap.traverseWithKey f' dm0 + result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' + return (result0, result') + +instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where + {-# INLINABLE newEventWithTrigger #-} + newEventWithTrigger = PerformEventT . lift . newEventWithTrigger + {-# INLINABLE newFanEventWithTrigger #-} + newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f + +-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the +-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run +-- at the appropriate time. +{-# INLINABLE hostPerformEventT #-} +hostPerformEventT :: forall t m a. + ( Monad m + , MonadSubscribeEvent t m + , MonadReflexHost t m + , MonadRef m + , Ref m ~ Ref IO + ) + => PerformEventT t m a + -> m (a, FireCommand t m) +hostPerformEventT a = do + (response, responseTrigger) <- newEventWithTriggerRef + (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response + eventToPerformHandle <- subscribeEvent eventToPerform + return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do + let go :: [DSum (EventTrigger t) Identity] -> m [a'] + go ts = do + (result', mToPerform) <- fireEventsAndRead ts $ do + mToPerform <- sequence =<< readEvent eventToPerformHandle + result' <- readPhase + return (result', mToPerform) + case mToPerform of + Nothing -> return [result'] + Just toPerform -> do + responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform + mrt <- readRef responseTrigger + let followupEventTriggers = case mrt of + Just rt -> [rt :=> Identity responses] + Nothing -> [] + (result':) <$> go followupEventTriggers + go triggers + +instance ReflexHost t => MonadSample t (PerformEventT t m) where + {-# INLINABLE sample #-} + sample = PerformEventT . lift . sample + +instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where + {-# INLINABLE hold #-} + hold v0 v' = PerformEventT $ lift $ hold v0 v' + {-# INLINABLE holdDyn #-} + holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v' + {-# INLINABLE holdIncremental #-} + holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v' + {-# INLINABLE buildDynamic #-} + buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v' + {-# INLINABLE headE #-} + headE = PerformEventT . lift . headE + +instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where + type Ref (PerformEventT t m) = Ref (HostFrame t) + {-# INLINABLE newRef #-} + newRef = PerformEventT . lift . newRef + {-# INLINABLE readRef #-} + readRef = PerformEventT . lift . readRef + {-# INLINABLE writeRef #-} + writeRef r = PerformEventT . lift . writeRef r + +instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where + {-# INLINABLE atomicModifyRef #-} + atomicModifyRef r = PerformEventT . lift . atomicModifyRef r diff --git a/src/Reflex/PerformEvent/Class.hs b/src/Reflex/PerformEvent/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/PerformEvent/Class.hs @@ -0,0 +1,64 @@ +-- | This module defines 'PerformEvent' and 'TriggerEvent', which mediate the +-- interaction between a "Reflex"-based program and the external side-effecting +-- actions such as 'IO'. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.PerformEvent.Class + ( PerformEvent (..) + , performEventAsync + ) where + +import Reflex.Class +import Reflex.TriggerEvent.Class + +import Control.Monad.Reader + +-- | 'PerformEvent' represents actions that can trigger other actions based on +-- 'Event's. +class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where + -- | The type of action to be triggered; this is often not the same type as + -- the triggering action. + type Performable m :: * -> * + -- | Perform the action contained in the given 'Event' whenever the 'Event' + -- fires. Return the result in another 'Event'. Note that the output 'Event' + -- will generally occur later than the input 'Event', since most 'Performable' + -- actions cannot be performed during 'Event' propagation. + performEvent :: Event t (Performable m a) -> m (Event t a) + -- | Like 'performEvent', but do not return the result. May have slightly + -- better performance. + performEvent_ :: Event t (Performable m ()) -> m () + +-- | Like 'performEvent', but the resulting 'Event' occurs only when the +-- callback (@a -> IO ()@) is called, not when the included action finishes. +-- +-- NOTE: Despite the name, 'performEventAsync' does not run its action in a +-- separate thread - although the action is free to invoke forkIO and then call +-- the callback whenever it is ready. This will work properly, even in GHCJS +-- (which fully implements concurrency even though JavaScript does not have +-- built in concurrency). +{-# INLINABLE performEventAsync #-} +performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a) +performEventAsync e = do + (eOut, triggerEOut) <- newTriggerEvent + performEvent_ $ fmap ($ triggerEOut) e + return eOut + +instance PerformEvent t m => PerformEvent t (ReaderT r m) where + type Performable (ReaderT r m) = ReaderT r (Performable m) + performEvent_ e = do + r <- ask + lift $ performEvent_ $ flip runReaderT r <$> e + performEvent e = do + r <- ask + lift $ performEvent $ flip runReaderT r <$> e diff --git a/src/Reflex/PostBuild/Base.hs b/src/Reflex/PostBuild/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/PostBuild/Base.hs @@ -0,0 +1,197 @@ +-- | This module defines 'PostBuildT', the standard implementation of +-- 'PostBuild'. +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.PostBuild.Base + ( PostBuildT (..) + , runPostBuildT + -- * Internal + , mapIntMapWithAdjustImpl + , mapDMapWithAdjustImpl + ) where + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.Host.Class +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.TriggerEvent.Class + +import Control.Applicative (liftA2) +import Control.Monad.Exception +import Control.Monad.Identity +import Control.Monad.Primitive +import Control.Monad.Reader +import Control.Monad.Ref +import qualified Control.Monad.Trans.Control as TransControl +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Compose +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Semigroup as S + +-- | Provides a basic implementation of 'PostBuild'. +newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException) + +-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires +-- immediately after the action is finished running; no other 'Event's should +-- fire first. +{-# INLINABLE runPostBuildT #-} +runPostBuildT :: PostBuildT t m a -> Event t () -> m a +runPostBuildT (PostBuildT a) = runReaderT a + +-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them. +instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where + mempty = pure mempty + mappend = liftA2 mappend + +instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where + (<>) = liftA2 (S.<>) + +instance PrimMonad m => PrimMonad (PostBuildT x m) where + type PrimState (PostBuildT x m) = PrimState m + primitive = lift . primitive + +instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where + {-# INLINABLE getPostBuild #-} + getPostBuild = PostBuildT ask + +instance MonadSample t m => MonadSample t (PostBuildT t m) where + {-# INLINABLE sample #-} + sample = lift . sample + +instance MonadHold t m => MonadHold t (PostBuildT t m) where + {-# INLINABLE hold #-} + hold v0 = lift . hold v0 + {-# INLINABLE holdDyn #-} + holdDyn v0 = lift . holdDyn v0 + {-# INLINABLE holdIncremental #-} + holdIncremental v0 = lift . holdIncremental v0 + {-# INLINABLE buildDynamic #-} + buildDynamic a0 = lift . buildDynamic a0 + {-# INLINABLE headE #-} + headE = lift . headE + +instance PerformEvent t m => PerformEvent t (PostBuildT t m) where + type Performable (PostBuildT t m) = Performable m + {-# INLINABLE performEvent_ #-} + performEvent_ = lift . performEvent_ + {-# INLINABLE performEvent #-} + performEvent = lift . performEvent + +instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where + {-# INLINABLE newEventWithTrigger #-} + newEventWithTrigger = PostBuildT . lift . newEventWithTrigger + {-# INLINABLE newFanEventWithTrigger #-} + newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f + +instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where + {-# INLINABLE newTriggerEvent #-} + newTriggerEvent = lift newTriggerEvent + {-# INLINABLE newTriggerEventWithOnComplete #-} + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance MonadRef m => MonadRef (PostBuildT t m) where + type Ref (PostBuildT t m) = Ref m + {-# INLINABLE newRef #-} + newRef = lift . newRef + {-# INLINABLE readRef #-} + readRef = lift . readRef + {-# INLINABLE writeRef #-} + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where + {-# INLINABLE atomicModifyRef #-} + atomicModifyRef r = lift . atomicModifyRef r + +instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where + runWithReplace a0 a' = do + postBuild <- getPostBuild + lift $ do + rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a' + let voidResult' = fmapCheap (\_ -> ()) result' + return result + {-# INLINABLE traverseIntMapWithKeyWithAdjust #-} + traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust + {-# INLINABLE traverseDMapWithKeyWithAdjust #-} + traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap + traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove + +{-# INLINABLE mapIntMapWithAdjustImpl #-} +mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p) + => ( (IntMap.Key -> (Event t (), v) -> m v') + -> IntMap (Event t (), v) + -> Event t (p (Event t (), v)) + -> m (IntMap v', Event t (p v')) + ) + -> (IntMap.Key -> v -> PostBuildT t m v') + -> IntMap v + -> Event t (p v) + -> PostBuildT t m (IntMap v', Event t (p v')) +mapIntMapWithAdjustImpl base f dm0 dm' = do + postBuild <- getPostBuild + let loweredDm0 = fmap ((,) postBuild) dm0 + f' :: IntMap.Key -> (Event t (), v) -> m v' + f' k (e, v) = do + runPostBuildT (f k v) e + lift $ do + rec (result0, result') <- base f' loweredDm0 loweredDm' + cohortDone <- numberOccurrencesFrom_ 1 result' + numberedDm' <- numberOccurrencesFrom 1 dm' + let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone + loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do + return $ fmap ((,) (selectInt postBuild' n)) p + return (result0, result') + +{-# INLINABLE mapDMapWithAdjustImpl #-} +mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m) + => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)) + -> DMap k (Compose ((,) (Bool, Event t ())) v) + -> Event t (p k (Compose ((,) (Bool, Event t ())) v)) + -> m (DMap k v', Event t (p k v')) + ) + -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v)) + -> (forall a. k a -> v a -> PostBuildT t m (v' a)) + -> DMap k v + -> Event t (p k v) + -> PostBuildT t m (DMap k v', Event t (p k v')) +mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do + postBuild <- getPostBuild + let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0 + f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a) + f' k (Compose ((shouldHeadE, e), v)) = do + eOnce <- if shouldHeadE + then headE e --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence + else return e + runPostBuildT (f k v) eOnce + lift $ do + rec (result0, result') <- base f' loweredDm0 loweredDm' + let voidResult' = fmapCheap (\_ -> ()) result' + let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult')) + return (result0, result') + +-------------------------------------------------------------------------------- +-- Deprecated functionality +-------------------------------------------------------------------------------- + +-- | Deprecated +instance TransControl.MonadTransControl (PostBuildT t) where + type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a + {-# INLINABLE liftWith #-} + liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT + {-# INLINABLE restoreT #-} + restoreT = TransControl.defaultRestoreT PostBuildT diff --git a/src/Reflex/PostBuild/Class.hs b/src/Reflex/PostBuild/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/PostBuild/Class.hs @@ -0,0 +1,42 @@ +-- | This module defines 'PostBuild', which indicates that an action will be +-- notified when it, and any action it's a part of, has finished executing. +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.PostBuild.Class + ( PostBuild (..) + ) where + +import Reflex.Class + +import Control.Monad.Reader +import Control.Monad.State +import qualified Control.Monad.State.Strict as Strict + +-- | 'PostBuild' represents an action that is notified via an 'Event' when it +-- has finished executing. Note that the specific definition of "finished" is +-- determined by the instance of 'PostBuild', but the intent is to allow +-- 'Behavior's and 'Dynamic's to be safely sampled, regardless of where they +-- were created, when the post-build 'Event' fires. The post-build 'Event' will +-- fire exactly once for an given action. +class (Reflex t, Monad m) => PostBuild t m | m -> t where + -- | Retrieve the post-build 'Event' for this action. + getPostBuild :: m (Event t ()) + +instance PostBuild t m => PostBuild t (ReaderT r m) where + getPostBuild = lift getPostBuild + +instance PostBuild t m => PostBuild t (StateT s m) where + getPostBuild = lift getPostBuild + +instance PostBuild t m => PostBuild t (Strict.StateT s m) where + getPostBuild = lift getPostBuild diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Profiled.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.Profiled where + +import Control.Lens hiding (children) +import Control.Monad +import Control.Monad.Exception +import Control.Monad.Fix +import Control.Monad.Primitive +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict (StateT, execStateT, modify) +import Data.Coerce +import Data.Dependent.Map (DMap, GCompare) +import Data.FastMutableIntMap +import Data.IORef +import Data.List +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Monoid ((<>)) +import Data.Ord +import qualified Data.Semigroup as S +import Data.Type.Coercion +import Foreign.Ptr +import GHC.Foreign +import GHC.IO.Encoding +import GHC.Stack +import Reflex.Class +import Reflex.Host.Class +import Reflex.PerformEvent.Class + +import System.IO.Unsafe +import Unsafe.Coerce + +data ProfiledTimeline t + +{-# NOINLINE profilingData #-} +profilingData :: IORef (Map (Ptr CostCentreStack) Int) +profilingData = unsafePerformIO $ newIORef Map.empty + +data CostCentreTree = CostCentreTree + { _costCentreTree_ownEntries :: !Int + , _costCentreTree_cumulativeEntries :: !Int + , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree) + } + deriving (Show, Eq, Ord) + +instance S.Semigroup CostCentreTree where + (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) = + CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb + +instance Monoid CostCentreTree where + mempty = CostCentreTree 0 0 mempty + mappend = (S.<>) + +getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre] +getCostCentreStack = go [] + where go l ccs = if ccs == nullPtr + then return l + else do + cc <- ccsCC ccs + parent <- ccsParent ccs + go (cc : l) parent + +toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree +toCostCentreTree ccs n = do + ccList <- getCostCentreStack ccs + return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList + +getCostCentreTree :: IO CostCentreTree +getCostCentreTree = do + vals <- readIORef profilingData + mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals) + +formatCostCentreTree :: CostCentreTree -> IO String +formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) [] + where go :: Int -> CostCentreTree -> StateT [String] IO () + go depth cct = do + let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct + indent = mconcat $ replicate depth " " + forM_ children $ \(cc, childCct) -> do + lbl <- liftIO $ peekCString utf8 =<< ccLabel cc + mdl <- liftIO $ peekCString utf8 =<< ccModule cc + loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc + let description = mdl <> "." <> lbl <> " (" <> loc <> ")" + modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct) + go (succ depth) childCct + +showProfilingData :: IO () +showProfilingData = do + putStr =<< formatCostCentreTree =<< getCostCentreTree + +writeProfilingData :: FilePath -> IO () +writeProfilingData p = do + writeFile p =<< formatCostCentreTree =<< getCostCentreTree + +newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } + deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException) + +profileEvent :: Reflex t => Event t a -> Event t a +profileEvent e = unsafePerformIO $ do + stack <- getCurrentCCS e + let f x = unsafePerformIO $ do + modifyIORef' profilingData $ Map.insertWith (+) stack 1 + return $ return $ Just x + return $ pushCheap f e + +--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs + +instance Reflex t => Reflex (ProfiledTimeline t) where + newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a } + newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a } + newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a } + newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p } + type PushM (ProfiledTimeline t) = ProfiledM (PushM t) + type PullM (ProfiledTimeline t) = ProfiledM (PullM t) + never = Event_Profiled never + constant = Behavior_Profiled . constant + push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us + pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e + pull = Behavior_Profiled . pull . coerce + merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity) + merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t)) + fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e) + switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b) + coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e) + current (Dynamic_Profiled d) = coerce $ current d + updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d + unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a' + unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a' + mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t))) + mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t))) + currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i + updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i + incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i + behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of + Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce + eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of + Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce + dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of + Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce + mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a))) + fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e + +deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t)) +deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t)) +deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t)) + +instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where + hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v' + holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v' + holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v' + buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v' + headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e + +instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where + sample (Behavior_Profiled b) = ProfiledM $ sample b + +instance MonadTrans ProfiledM where + lift = ProfiledM + +instance MonadIO m => MonadIO (ProfiledM m) where + liftIO = lift . liftIO + +instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where + type Performable (ProfiledM m) = Performable m + performEvent_ = lift . performEvent_ . coerce + performEvent = lift . fmap coerce . performEvent . coerce + +instance MonadRef m => MonadRef (ProfiledM m) where + type Ref (ProfiledM m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where + newEventWithTrigger = lift . fmap coerce . newEventWithTrigger + newFanEventWithTrigger f = do + es <- lift $ newFanEventWithTrigger f + return $ EventSelector $ \k -> coerce $ select es k + +instance MonadReader r m => MonadReader r (ProfiledM m) where + ask = lift ask + local f (ProfiledM a) = ProfiledM $ local f a + reader = lift . reader + +instance ReflexHost t => ReflexHost (ProfiledTimeline t) where + type EventTrigger (ProfiledTimeline t) = EventTrigger t + type EventHandle (ProfiledTimeline t) = EventHandle t + type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t) + +instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where + subscribeEvent = lift . subscribeEvent . coerce + +instance PrimMonad m => PrimMonad (ProfiledM m) where + type PrimState (ProfiledM m) = PrimState m + primitive = lift . primitive + +instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where + type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m) + fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r + runHostFrame = lift . runHostFrame . coerce + +instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where + readEvent = lift . fmap coerce . readEvent diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Pure.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif + +-- There are two expected orphan instances in this module: +-- * MonadSample (Pure t) ((->) t) +-- * MonadHold (Pure t) ((->) t) +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module provides a pure implementation of Reflex, which is intended to +-- serve as a reference for the semantics of the Reflex class. All +-- implementations of Reflex should produce the same results as this +-- implementation, although performance and laziness/strictness may differ. +module Reflex.Pure + ( Pure + , Behavior (..) + , Event (..) + , Dynamic (..) + , Incremental (..) + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Control.Monad +import Data.Dependent.Map (DMap, GCompare) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Identity +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Maybe +import Data.MemoTrie +import Data.Monoid +import Data.Type.Coercion +import Reflex.Class + +-- | A completely pure-functional 'Reflex' timeline, identifying moments in time +-- with the type @/t/@. +data Pure t + +-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist +-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used +-- exclusively to memoize functions of @/t/@, not for any of its other capabilities. +instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where + + newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a } + newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a } + newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) } + newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) } + + type PushM (Pure t) = (->) t + type PullM (Pure t) = (->) t + + never :: Event (Pure t) a + never = Event $ \_ -> Nothing + + constant :: a -> Behavior (Pure t) a + constant x = Behavior $ \_ -> x + + push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b + push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t + + pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b + pushCheap = push + + pull :: PullM (Pure t) a -> Behavior (Pure t) a + pull = Behavior . memo + + -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a + -- warning because the GCompare instance is not used; however, removing the + -- GCompare instance produces a different warning, due to that constraint + -- being present in the original class definition + + --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity) + merge events = Event $ memo $ \t -> + let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events + in if DMap.null currentOccurrences + then Nothing + else Just currentOccurrences + + fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k + fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k + + switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a + switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t + + coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a + coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t + + current :: Dynamic (Pure t) a -> Behavior (Pure t) a + current d = Behavior $ \t -> fst $ unDynamic d t + + updated :: Dynamic (Pure t) a -> Event (Pure t) a + updated d = Event $ \t -> snd $ unDynamic d t + + unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a + unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t) + + -- See UNUSED_CONSTRAINT, above. + + --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p + --a) -> Incremental (Pure t) p a + unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t) + + mergeIncremental = mergeIncrementalImpl + mergeIncrementalWithMove = mergeIncrementalImpl + + currentIncremental i = Behavior $ \t -> fst $ unIncremental i t + + updatedIncremental i = Event $ \t -> snd $ unIncremental i t + + incrementalToDynamic i = Dynamic $ \t -> + let (old, mPatch) = unIncremental i t + e = case mPatch of + Nothing -> Nothing + Just patch -> apply patch old + in (old, e) + behaviorCoercion Coercion = Coercion + eventCoercion Coercion = Coercion + dynamicCoercion Coercion = Coercion + + fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k + + mergeIntIncremental = mergeIntIncrementalImpl + +mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity) +mergeIncrementalImpl i = Event $ \t -> + let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t + in if DMap.null results + then Nothing + else Just results + +mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a) +mergeIntIncrementalImpl i = Event $ \t -> + let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t + in if IntMap.null results + then Nothing + else Just results + +instance Functor (Dynamic (Pure t)) where + fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t + in (f cur, fmap f upd) + +instance Applicative (Dynamic (Pure t)) where + pure a = Dynamic $ \_ -> (a, Nothing) + (<*>) = ap + +instance Monad (Dynamic (Pure t)) where + return = pure + (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t -> + let (curX :: a, updX :: Maybe a) = unDynamic x t + (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t + (updInner :: Maybe b, updBoth :: Maybe b) = case updX of + Nothing -> (Nothing, Nothing) + Just nextX -> let (c, u) = unDynamic (f nextX) t + in (Just c, u) + in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner]) + +instance MonadSample (Pure t) ((->) t) where + + sample :: Behavior (Pure t) a -> (t -> a) + sample = unBehavior + +instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where + + hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a + hold initialValue e initialTime = Behavior f + where f = memo $ \sampleTime -> + -- Really, the sampleTime should never be prior to the initialTime, + -- because that would mean the Behavior is being sampled before + -- being created. + if sampleTime <= initialTime + then initialValue + else let lastTime = pred sampleTime + in fromMaybe (f lastTime) $ unEvent e lastTime + + holdDyn v0 = buildDynamic (return v0) + + buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a + buildDynamic initialValue e initialTime = + let Behavior f = hold (initialValue initialTime) e initialTime + in Dynamic $ \t -> (f t, unEvent e t) + + holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p + holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t) + where f = memo $ \sampleTime -> + -- Really, the sampleTime should never be prior to the initialTime, + -- because that would mean the Behavior is being sampled before + -- being created. + if sampleTime <= initialTime + then initialValue + else let lastTime = pred sampleTime + lastValue = f lastTime + in case unEvent e lastTime of + Nothing -> lastValue + Just x -> fromMaybe lastValue $ apply x lastValue + + headE = slowHeadE diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Query/Base.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Reflex.Query.Base + ( QueryT (..) + , runQueryT + , mapQuery + , mapQueryResult + , dynWithQueryT + , withQueryT + ) where + +import Control.Applicative (liftA2) +import Control.Monad.Exception +import Control.Monad.Fix +import Control.Monad.Primitive +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict +import Data.Align +import Data.Dependent.Map (DMap, DSum (..)) +import qualified Data.Dependent.Map as DMap +import Data.Foldable +import Data.Functor.Compose +import Data.Functor.Misc +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import qualified Data.Semigroup as S +import Data.Some (Some) +import qualified Data.Some as Some +import Data.These + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.DynamicWriter.Class +import Reflex.EventWriter.Base +import Reflex.EventWriter.Class +import Reflex.Host.Class +import qualified Reflex.Patch.MapWithMove as MapWithMove +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.Query.Class +import Reflex.Requester.Class +import Reflex.TriggerEvent.Class + +newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a } + deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef) + +deriving instance MonadHold t m => MonadHold t (QueryT t q m) +deriving instance MonadSample t m => MonadSample t (QueryT t q m) + +runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q)) +runQueryT (QueryT a) qr = do + ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr + return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es)) + +newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q]) + +getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v +getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v + +getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q] +getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w + +{- +let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q + sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty + bs' = fmapCheap snd $ r' + patches = unsafeBuildIncremental (sampleBs bs0) $ + flip pushCheap bs' $ \bs -> do + p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches) + return (Just (AdditivePatch p)) +-} + +instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where + runWithReplace (QueryT a0) a' = do + ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a' + let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q + sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty + bs' = fmapCheap snd $ r' + bbs <- hold bs0 bs' + let patches = flip pushAlwaysCheap bs' $ \newBs -> do + oldBs <- sample bbs + (~~) <$> sampleBs newBs <*> sampleBs oldBs + QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs + QueryT $ lift $ tellEvent patches + return (r0, fmapCheap fst r') + + traverseIntMapWithKeyWithAdjust :: forall v v'. (IntMap.Key -> v -> QueryT t q m v') -> IntMap v -> Event t (PatchIntMap v) -> QueryT t q m (IntMap v', Event t (PatchIntMap v')) + traverseIntMapWithKeyWithAdjust f im0 im' = do + let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v') + f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v + (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im' + let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0 + liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $ + IntMap.map (fmap getQueryTLoweredResultValue) p + liftedBs0 :: IntMap [Behavior t q] + liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0 + liftedBs' :: Event t (PatchIntMap [Behavior t q]) + liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $ + IntMap.map (fmap getQueryTLoweredResultWritten) p + sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q + sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty + accumBehaviors :: forall m'. MonadHold t m' + => IntMap [Behavior t q] + -> PatchIntMap [Behavior t q] + -> m' ( Maybe (IntMap [Behavior t q]) + , Maybe (AdditivePatch q)) + -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad. + -- When an update occurs, it also computes a patch to communicate to the parent QueryT state. + -- bs0 is a Map denoting the behaviors of the current children. + -- pbs is a PatchMap denoting an update to the behaviors of the current children + accumBehaviors bs0 pbs@(PatchIntMap bs') = do + let p k bs = case IntMap.lookup k bs0 of + Nothing -> case bs of + -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. + Nothing -> return mempty + -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. + Just newBs -> sampleBs newBs + Just oldBs -> case bs of + -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state + Nothing -> negateG <$> sampleBs oldBs + -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state + -- composed with the sampling the child's new state. + Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the + -- child patches and wrap them in AdditivePatch. + patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs' + return (apply pbs bs0, Just patch) + (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs' + tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch + return (liftedResult0, liftedResult') + + traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v')) + traverseDMapWithKeyWithAdjust f dm0 dm' = do + let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a) + f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v + (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm' + let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0 + liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $ + mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p + liftedBs0 :: Map (Some k) [Behavior t q] + liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 + liftedBs' :: Event t (PatchMap (Some k) [Behavior t q]) + liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $ + Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p + sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q + sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty + accumBehaviors :: forall m'. MonadHold t m' + => Map (Some k) [Behavior t q] + -> PatchMap (Some k) [Behavior t q] + -> m' ( Maybe (Map (Some k) [Behavior t q]) + , Maybe (AdditivePatch q)) + -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad. + -- When an update occurs, it also computes a patch to communicate to the parent QueryT state. + -- bs0 is a Map denoting the behaviors of the current children. + -- pbs is a PatchMap denoting an update to the behaviors of the current children + accumBehaviors bs0 pbs@(PatchMap bs') = do + let p k bs = case Map.lookup k bs0 of + Nothing -> case bs of + -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. + Nothing -> return mempty + -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. + Just newBs -> sampleBs newBs + Just oldBs -> case bs of + -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state + Nothing -> negateG <$> sampleBs oldBs + -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state + -- composed with the sampling the child's new state. + Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the + -- child patches and wrap them in AdditivePatch. + patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs' + return (apply pbs bs0, Just patch) + (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs' + tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch + return (liftedResult0, liftedResult') + + traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v')) + traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do + let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a) + f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v + (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm' + let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0 + liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose) + liftedBs0 :: Map (Some k) [Behavior t q] + liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 + liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q]) + liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $ + Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -} + sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q + sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty + accumBehaviors' :: forall m'. MonadHold t m' + => Map (Some k) [Behavior t q] + -> PatchMapWithMove (Some k) [Behavior t q] + -> m' ( Maybe (Map (Some k) [Behavior t q]) + , Maybe (AdditivePatch q)) + -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad. + -- When an update occurs, it also computes a patch to communicate to the parent QueryT state. + -- bs0 is a Map denoting the behaviors of the current children. + -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children + accumBehaviors' bs0 pbs = do + let bs' = unPatchMapWithMove pbs + p k bs = case Map.lookup k bs0 of + Nothing -> case MapWithMove._nodeInfo_from bs of + -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. + MapWithMove.From_Delete -> return mempty + -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. + MapWithMove.From_Insert newBs -> sampleBs newBs + MapWithMove.From_Move k' -> case Map.lookup k' bs0 of + Nothing -> return mempty + Just newBs -> sampleBs newBs + Just oldBs -> case MapWithMove._nodeInfo_from bs of + -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state + MapWithMove.From_Delete -> negateG <$> sampleBs oldBs + -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state + -- composed with the sampling the child's new state. + MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + MapWithMove.From_Move k' + | k' == k -> return mempty + | otherwise -> case Map.lookup k' bs0 of + -- If we are moving from a non-existent key, that is a delete + Nothing -> negateG <$> sampleBs oldBs + Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the + -- child patches and wrap them in AdditivePatch. + patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs' + return (apply pbs bs0, Just patch) + (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs' + tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch + return (liftedResult0, liftedResult') + +instance MonadTrans (QueryT t q) where + lift = QueryT . lift . lift . lift + +instance PrimMonad m => PrimMonad (QueryT t q m) where + type PrimState (QueryT t q m) = PrimState m + primitive = lift . primitive + +instance PostBuild t m => PostBuild t (QueryT t q m) where + getPostBuild = lift getPostBuild + +instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where + mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT + +instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance PerformEvent t m => PerformEvent t (QueryT t q m) where + type Performable (QueryT t q m) = Performable m + performEvent_ = lift . performEvent_ + performEvent = lift . performEvent + +instance MonadRef m => MonadRef (QueryT t q m) where + type Ref (QueryT t q m) = Ref m + newRef = QueryT . newRef + readRef = QueryT . readRef + writeRef r = QueryT . writeRef r + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where + newEventWithTrigger = QueryT . newEventWithTrigger + newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a + +-- TODO: Monoid and Semigroup can likely be derived once StateT has them. +instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where + mempty = pure mempty + mappend = (<>) + +instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where + (<>) = liftA2 (S.<>) + +-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly +withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q') + => QueryMorphism q q' + -> QueryT t q m a + -> QueryT t q' m a +withQueryT f a = do + r' <- askQueryResult + (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r' + tellQueryIncremental $ unsafeBuildIncremental + (fmap (mapQuery f) (sample (currentIncremental q))) + (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q) + return result + +-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly +dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q') + => Dynamic t (QueryMorphism q q') + -> QueryT t q m a + -> QueryT t q' m a +dynWithQueryT f q = do + r' <- askQueryResult + (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r' + tellQueryIncremental $ zipDynIncrementalWith mapQuery f q' + return result + where zipDynIncrementalWith g da ib = + let eab = align (updated da) (updatedIncremental ib) + ec = flip push eab $ \case + This a -> do + aOld <- sample $ current da + b <- sample $ currentIncremental ib + return $ Just $ AdditivePatch (g a b ~~ g aOld b) + That (AdditivePatch b) -> do + a <- sample $ current da + return $ Just $ AdditivePatch $ g a b + These a (AdditivePatch b) -> do + aOld <- sample $ current da + bOld <- sample $ currentIncremental ib + return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b] + in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec + +instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where + tellQueryIncremental q = do + QueryT (modify (currentIncremental q:)) + QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q)))) + askQueryResult = QueryT ask + queryIncremental q = do + tellQueryIncremental q + zipDynWith crop (incrementalToDynamic q) <$> askQueryResult + +instance Requester t m => Requester t (QueryT t q m) where + type Request (QueryT t q m) = Request m + type Response (QueryT t q m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +instance EventWriter t w m => EventWriter t w (QueryT t q m) where + tellEvent = lift . tellEvent + +instance MonadDynamicWriter t w m => MonadDynamicWriter t w (QueryT t q m) where + tellDyn = lift . tellDyn diff --git a/src/Reflex/Query/Class.hs b/src/Reflex/Query/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Query/Class.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.Query.Class + ( Query (..) + , QueryMorphism (..) + , SelectedCount (..) + , combineSelectedCounts + + , MonadQuery (..) + , tellQueryDyn + , queryDyn + , mapQuery + , mapQueryResult + ) where + +import Control.Category (Category) +import qualified Control.Category as Cat +import Control.Monad.Reader +import Data.Bits +import Data.Data +import Data.Ix +import Data.Map.Monoidal (MonoidalMap) +import qualified Data.Map.Monoidal as MonoidalMap +import Data.Semigroup +import Foreign.Storable + +import Reflex.Class + +class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where + type QueryResult a :: * + crop :: a -> QueryResult a -> QueryResult a + +instance (Ord k, Query v) => Query (MonoidalMap k v) where + type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v) + crop q r = MonoidalMap.intersectionWith (flip crop) r q + +-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type +-- and compatible with the query relationship when acting on the query result +data QueryMorphism q q' = QueryMorphism + { _queryMorphism_mapQuery :: q -> q' + , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q + } + +instance Category QueryMorphism where + id = QueryMorphism id id + qm . qm' = QueryMorphism + { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm' + , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm + } + +mapQuery :: QueryMorphism q q' -> q -> q' +mapQuery = _queryMorphism_mapQuery + +mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q +mapQueryResult = _queryMorphism_mapQueryResult + +-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app +newtype SelectedCount = SelectedCount { unSelectedCount :: Int } + deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data) + +instance Semigroup SelectedCount where + SelectedCount a <> SelectedCount b = SelectedCount (a + b) + +instance Monoid SelectedCount where + mempty = SelectedCount 0 + mappend = (<>) + +instance Group SelectedCount where + negateG (SelectedCount a) = SelectedCount (negate a) + +instance Additive SelectedCount + +-- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted. +combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount +combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j) + +class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where + tellQueryIncremental :: Incremental t (AdditivePatch q) -> m () + askQueryResult :: m (Dynamic t (QueryResult q)) + queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q)) + +instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where + tellQueryIncremental = lift . tellQueryIncremental + askQueryResult = lift askQueryResult + queryIncremental = lift . queryIncremental + +tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m () +tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d) + +queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q)) +queryDyn q = do + tellQueryDyn q + zipDynWith crop q <$> askQueryResult diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Requester/Base.hs @@ -0,0 +1,434 @@ +-- | This module provides 'RequesterT', the standard implementation of +-- 'Requester'. +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.Requester.Base + ( RequesterT (..) + , runRequesterT + , runWithReplaceRequesterTWith + , traverseIntMapWithKeyWithAdjustRequesterTWith + , traverseDMapWithKeyWithAdjustRequesterTWith + , RequesterData + , RequesterDataKey + , traverseRequesterData + , forRequesterData + , requesterDataToList + , singletonRequesterData + ) where + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.Dynamic +import Reflex.Host.Class +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.Requester.Class +import Reflex.TriggerEvent.Class + +import Control.Applicative (liftA2) +import Control.Monad.Exception +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict +import Data.Bits +import Data.Coerce +import Data.Dependent.Map (DMap, DSum (..)) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Compose +import Data.Functor.Misc +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.Proxy +import qualified Data.Semigroup as S +import Data.Some (Some) +import qualified Data.Some as Some +import Data.Type.Equality +import Data.Unique.Tag + +import GHC.Exts (Any) +import Unsafe.Coerce + +--TODO: Make this module type-safe + +newtype TagMap (f :: * -> *) = TagMap (IntMap Any) + +newtype RequesterData f = RequesterData (TagMap (Entry f)) + +data RequesterDataKey a where + RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a + RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead + RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a + RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a + +singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f +singletonRequesterData rdk v = case rdk of + RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v + RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v + RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v + RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v + +requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f] +requesterDataToList (RequesterData m) = do + k :=> Entry e <- tagMapToList m + case myKeyType k of + MyTagType_Single -> return $ RequesterDataKey_Single k :=> e + MyTagType_Multi -> do + (k', e') <- IntMap.toList e + k'' :=> e'' <- requesterDataToList e' + return $ RequesterDataKey_Multi k k' k'' :=> e'' + MyTagType_Multi2 -> do + (k', e') <- Map.toList e + (k'', e'') <- IntMap.toList e' + k''' :=> e''' <- requesterDataToList e'' + return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e''' + MyTagType_Multi3 -> do + (k', e') <- IntMap.toList e + (k'', e'') <- IntMap.toList e' + k''' :=> e''' <- requesterDataToList e'' + return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e''' + +singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f +singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v + +tagMapToList :: forall f. TagMap f -> [DSum MyTag f] +tagMapToList (TagMap m) = f <$> IntMap.toList m + where f :: (Int, Any) -> DSum MyTag f + f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v + +traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g) +traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m + where + g :: Int -> Any -> t Any + g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v) + +-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse +traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response) +traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order + where go :: forall x. MyTag x -> Entry request x -> m (Entry response x) + go k (Entry request) = Entry <$> case myKeyType k of + MyTagType_Single -> f request + MyTagType_Multi -> traverse (traverseRequesterData f) request + MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request + MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request + +-- | 'traverseRequesterData' with its arguments flipped +forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response) +forRequesterData r f = traverseRequesterData f r + +data MyTagType :: * -> * where + MyTagType_Single :: MyTagType (Single a) + MyTagType_Multi :: MyTagType Multi + MyTagType_Multi2 :: MyTagType (Multi2 k) + MyTagType_Multi3 :: MyTagType Multi3 + +myKeyType :: MyTag x -> MyTagType x +myKeyType (MyTag k) = case k .&. 0x3 of + 0x0 -> unsafeCoerce MyTagType_Single + 0x1 -> unsafeCoerce MyTagType_Multi + 0x2 -> unsafeCoerce MyTagType_Multi2 + 0x3 -> unsafeCoerce MyTagType_Multi3 + t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t + +data Single a +data Multi +data Multi2 (k :: * -> *) +data Multi3 + +class MyTagTypeOffset x where + myTagTypeOffset :: proxy x -> Int + +instance MyTagTypeOffset (Single a) where + myTagTypeOffset _ = 0x0 + +instance MyTagTypeOffset Multi where + myTagTypeOffset _ = 0x1 + +instance MyTagTypeOffset (Multi2 k) where + myTagTypeOffset _ = 0x2 + +instance MyTagTypeOffset Multi3 where + myTagTypeOffset _ = 0x3 + +type family EntryContents request a where + EntryContents request (Single a) = request a + EntryContents request Multi = IntMap (RequesterData request) + EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request)) + EntryContents request Multi3 = IntMap (IntMap (RequesterData request)) + +newtype Entry request x = Entry { unEntry :: EntryContents request x } + +{-# INLINE singleEntry #-} +singleEntry :: f a -> Entry f (Single a) +singleEntry = Entry + +{-# INLINE multiEntry #-} +multiEntry :: IntMap (RequesterData f) -> Entry f Multi +multiEntry = Entry + +{-# INLINE unMultiEntry #-} +unMultiEntry :: Entry f Multi -> IntMap (RequesterData f) +unMultiEntry = unEntry + +-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes +-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another +newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum) + +newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum) + +{-# INLINE castMyTagWrap #-} +castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x) +castMyTagWrap = coerce + +instance GEq MyTag where + (MyTag a) `geq` (MyTag b) = + if a == b + then Just $ unsafeCoerce Refl + else Nothing + +instance GCompare MyTag where + (MyTag a) `gcompare` (MyTag b) = + case a `compare` b of + LT -> GLT + EQ -> unsafeCoerce GEQ + GT -> GGT + +instance GEq (MyTagWrap f) where + (MyTagWrap a) `geq` (MyTagWrap b) = + if a == b + then Just $ unsafeCoerce Refl + else Nothing + +instance GCompare (MyTagWrap f) where + (MyTagWrap a) `gcompare` (MyTagWrap b) = + case a `compare` b of + LT -> GLT + EQ -> unsafeCoerce GEQ + GT -> GGT + +data RequesterState t (request :: * -> *) = RequesterState + { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom + , _requesterState_requests :: ![(Int, Event t Any)] + } + +-- | A basic implementation of 'Requester'. +newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a } + deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException +-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2 +#if MIN_VERSION_base(4,9,1) + , MonadAsyncException +#endif + ) + +deriving instance MonadSample t m => MonadSample t (RequesterT t request response m) +deriving instance MonadHold t m => MonadHold t (RequesterT t request response m) +deriving instance PostBuild t m => PostBuild t (RequesterT t request response m) +deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m) + +-- TODO: Monoid and Semigroup can likely be derived once StateT has them. +instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where + mempty = pure mempty + mappend = liftA2 mappend + +instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where + (<>) = liftA2 (S.<>) + + +-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever +-- requests are made, and responses should be provided in the input 'Event'. +-- The 'Tag' keys will be used to return the responses to the same place the +-- requests were issued. + +runRequesterT :: (Reflex t, Monad m) + => RequesterT t request response m a + -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse + -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild +runRequesterT (RequesterT a) responses = do + (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $ + coerceEvent responses + return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s) + +instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where + type Request (RequesterT t request response m) = request + type Response (RequesterT t request response m) = response + requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a))) + requesting_ = void . tagRequest . fmapCheap singleEntry + +{-# INLINE tagRequest #-} +tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x)) +tagRequest req = do + old <- RequesterT get + let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x) + t = MyTagWrap n + RequesterT $ put $ RequesterState + { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4 + , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old + } + return t + +{-# INLINE responseFromTag #-} +responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x)) +responseFromTag (MyTagWrap t) = do + responses :: EventSelectorInt t Any <- RequesterT ask + return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t + +instance MonadTrans (RequesterT t request response) where + lift = RequesterT . lift . lift + +instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where + type Performable (RequesterT t request response m) = Performable m + performEvent_ = lift . performEvent_ + performEvent = lift . performEvent + +instance MonadRef m => MonadRef (RequesterT t request response m) where + type Ref (RequesterT t request response m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +instance MonadReader r m => MonadReader r (RequesterT t request response m) where + ask = lift ask + local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a + reader = lift . reader + +instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where + runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm' + traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental + {-# INLINABLE traverseDMapWithKeyWithAdjust #-} + traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental + traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove + +requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x)) +requesting' = responseFromTag . castMyTagWrap <=< tagRequest + +{-# INLINABLE runWithReplaceRequesterTWith #-} +runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m + , MonadFix m + ) + => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b')) + -> RequesterT t request response m a + -> Event t (RequesterT t request response m b) + -> RequesterT t request response m (a, Event t b) +runWithReplaceRequesterTWith f a0 a' = do + rec na' <- numberOccurrencesFrom 1 a' + responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here + let responses' = fanInt responses + ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na' + requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v' + return (result0, fmapCheap (fst . snd) v') + +{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-} +traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p. + ( Reflex t + , MonadHold t m + , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request))) + , Patch (p (Event t (IntMap (RequesterData request)))) + , Functor p + , MonadFix m + ) + => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v')) + -> IntMap (IntMap.Key, v) + -> Event t (p (IntMap.Key, v)) + -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v'))) + ) + -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request)))) + -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request)))) + -> (IntMap.Key -> v -> RequesterT t request response m v') + -> IntMap v + -> Event t (p v) + -> RequesterT t request response m (IntMap v', Event t (p v')) +traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do + rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here + let responses :: EventSelectorInt t (IntMap (RequesterData response)) + responses = fanInt $ fmapCheap unpack response + unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response)) + unpack = unEntry + pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3 + pack = Entry + f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v') + f' k (n, v) = do + (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time? + return (fmapCheap (IntMap.singleton n) myRequests, result) + ndm' <- numberOccurrencesFrom 1 dm' + (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable + let result0 = fmap snd children0 + result' = fforCheap children' $ fmap snd + requests0 :: IntMap (Event t (IntMap (RequesterData request))) + requests0 = fmap fst children0 + requests' :: Event t (p (Event t (IntMap (RequesterData request)))) + requests' = fforCheap children' $ fmap fst + promptRequests :: Event t (IntMap (IntMap (RequesterData request))) + promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence' + requests <- holdIncremental requests0 requests' + return (result0, result') + +{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-} +traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'. + ( GCompare k + , Reflex t + , MonadHold t m + , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request))) + , Patch (p' (Some k) (Event t (IntMap (RequesterData request)))) + , MonadFix m + ) + => (forall k' v1 v2. GCompare k' + => (forall a. k' a -> v1 a -> m (v2 a)) + -> DMap k' v1 + -> Event t (p k' v1) + -> RequesterT t request response m (DMap k' v2, Event t (p k' v2)) + ) + -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2) + -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2) + -> (forall v2. p' (Some k) v2 -> Map (Some k) v2) + -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a)) + -> (forall a. k a -> v a -> RequesterT t request response m (v' a)) + -> DMap k v + -> Event t (p k v) + -> RequesterT t request response m (DMap k v', Event t (p k v')) +traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do + rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here + let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response))) + responses = fanMap $ fmapCheap unpack response + unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response)) + unpack = unEntry + pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k) + pack = Entry + f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a) + f' k (Compose (n, v)) = do + (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k)) + return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result) + ndm' <- numberOccurrencesFrom 1 dm' + (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm' + let result0 = DMap.map (snd . getCompose) children0 + result' = fforCheap children' $ mapPatch $ snd . getCompose + requests0 :: Map (Some k) (Event t (IntMap (RequesterData request))) + requests0 = weakenDMapWith (fst . getCompose) children0 + requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request)))) + requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose + promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request))) + promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence' + requests <- holdIncremental requests0 requests' + return (result0, result') diff --git a/src/Reflex/Requester/Class.hs b/src/Reflex/Requester/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Requester/Class.hs @@ -0,0 +1,73 @@ +-- | This module defines 'Requester', which indicates that an action can make +-- requests and receive responses to them. Typically, this is used for things +-- like a WebSocket, where it's desirable to collect many potential sources of +-- events and send them over a single channel, then distribute the results back +-- out efficiently to their original request sites. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.Requester.Class + ( Requester (..) + , withRequesting + , requestingIdentity + ) where + +import Control.Monad.Identity +import Control.Monad.Reader +import qualified Control.Monad.State.Lazy as Lazy +import Control.Monad.State.Strict +import Reflex.Class + +-- | A 'Requester' action can trigger requests of type @Request m a@ based on +-- 'Event's, and receive responses of type @Response m a@ in return. Note that +-- the @a@ type can vary within the 'Requester' action, but will be linked for a +-- given request. For example, if @Request m@ is 'IO' and @Response m@ is +-- 'Identity', then 'requestingIdentity' has the same type as +-- 'Reflex.PerformEvent.Class.performEvent'. +class (Reflex t, Monad m) => Requester t m | m -> t where + -- | The type of requests that this 'Requester' can emit + type Request m :: * -> * + -- | The type of responses that this 'Requester' can receive + type Response m :: * -> * + -- | Emit a request whenever the given 'Event' fires, and return responses in + -- the resulting 'Event'. + requesting :: Event t (Request m a) -> m (Event t (Response m a)) + -- | Emit a request whenever the given 'Event' fires, and ignore all responses. + requesting_ :: Event t (Request m a) -> m () + + +instance Requester t m => Requester t (ReaderT r m) where + type Request (ReaderT r m) = Request m + type Response (ReaderT r m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +instance Requester t m => Requester t (StateT s m) where + type Request (StateT s m) = Request m + type Response (StateT s m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +instance Requester t m => Requester t (Lazy.StateT s m) where + type Request (Lazy.StateT s m) = Request m + type Response (Lazy.StateT s m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +-- | Emit a request whenever the given 'Event' fires, and unwrap the responses +-- before returning them. @Response m@ must be 'Identity'. +requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a) +requestingIdentity = fmap coerceEvent . requesting + +withRequesting :: (Requester t m, MonadFix m) => (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r +withRequesting f = do + rec response <- requesting request + (request, result) <- f response + return result diff --git a/src/Reflex/Spider.hs b/src/Reflex/Spider.hs --- a/src/Reflex/Spider.hs +++ b/src/Reflex/Spider.hs @@ -1,5 +1,17 @@ -module Reflex.Spider ( Spider - , SpiderHost (..) --Temporary, until Widget no longer uses unsafePerformIO - ) where +{-# LANGUAGE CPP #-} +-- | This module exports all of the user-facing functionality of the 'Spider' +-- 'Reflex' engine +module Reflex.Spider + ( Spider + , SpiderTimeline + , Global + , SpiderHost + , runSpiderHost + , runSpiderHostForTimeline + , newSpiderTimeline + , withSpiderTimeline + -- * Deprecated + , SpiderEnv + ) where import Reflex.Spider.Internal diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -1,1443 +1,2638 @@ -{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-} -module Reflex.Spider.Internal where - -import qualified Reflex.Class as R -import qualified Reflex.Host.Class as R - -import Data.IORef -import System.Mem.Weak -import Data.Foldable -import Data.Traversable -import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence) -import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence) -import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence) -import GHC.Exts -import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2 -import Data.Dependent.Map (DMap, DSum (..)) -import qualified Data.Dependent.Map as DMap -import Data.GADT.Compare -import Data.Maybe -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Control.Monad.Ref -import Control.Monad.Exception -import Data.Monoid ((<>)) -import Data.Coerce - -import System.IO.Unsafe -import Unsafe.Coerce -import Control.Monad.Primitive - --- Note: must come last to silence warnings due to AMP on GHC < 7.10 -import Prelude hiding (mapM, mapM_, any, sequence, concat) - -debugPropagate :: Bool - -debugInvalidateHeight :: Bool - -#ifdef DEBUG - -#define DEBUG_NODEIDS - -debugPropagate = True - -debugInvalidateHeight = True - -class HasNodeId a where - getNodeId :: a -> Int - -instance HasNodeId (Hold a) where - getNodeId = holdNodeId - -instance HasNodeId (PushSubscribed a b) where - getNodeId = pushSubscribedNodeId - -instance HasNodeId (SwitchSubscribed a) where - getNodeId = switchSubscribedNodeId - -instance HasNodeId (MergeSubscribed a) where - getNodeId = mergeSubscribedNodeId - -instance HasNodeId (FanSubscribed a) where - getNodeId = fanSubscribedNodeId - -instance HasNodeId (CoincidenceSubscribed a) where - getNodeId = coincidenceSubscribedNodeId - -instance HasNodeId (RootSubscribed a) where - getNodeId = rootSubscribedNodeId - -showNodeId :: HasNodeId a => a -> String -showNodeId = ("#"<>) . show . getNodeId - -#else - -debugPropagate = False - -debugInvalidateHeight = False - -showNodeId :: a -> String -showNodeId = const "" - -#endif - -#ifdef DEBUG_NODEIDS -{-# NOINLINE nextNodeIdRef #-} -nextNodeIdRef :: IORef Int -nextNodeIdRef = unsafePerformIO $ newIORef 1 - -{-# NOINLINE unsafeNodeId #-} -unsafeNodeId :: a -> Int -unsafeNodeId a = unsafePerformIO $ do - touch a - atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n) -#endif - ---TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce ---type role Hold representational -data Hold a - = Hold { holdValue :: !(IORef a) - , holdInvalidators :: !(IORef [Weak Invalidator]) - -- We need to use 'Any' for the next two things, because otherwise Hold inherits a nominal role for its 'a' parameter, and we want to be able to use 'coerce' - , holdSubscriber :: !(IORef Any) -- Keeps its subscription alive; for some reason, a regular (or strict) reference to the Subscriber itself wasn't working, so had to use an IORef - , holdParent :: !(IORef Any) -- Keeps its parent alive (will be undefined until the hold is initialized --TODO: Probably shouldn't be an IORef -#ifdef DEBUG_NODEIDS - , holdNodeId :: Int -#endif - } - -data EventEnv - = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment]) - , eventEnvHoldInits :: !(IORef [SomeHoldInit]) - , eventEnvClears :: !(IORef [SomeMaybeIORef]) - , eventEnvRootClears :: !(IORef [SomeDMapIORef]) - , eventEnvCurrentHeight :: !(IORef Int) - , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo]) - , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge])) - } - -runEventM :: EventM a -> EventEnv -> IO a -runEventM = runReaderT . unEventM - -askToAssignRef :: EventM (IORef [SomeAssignment]) -askToAssignRef = EventM $ asks eventEnvAssignments - -askHoldInitRef :: EventM (IORef [SomeHoldInit]) -askHoldInitRef = EventM $ asks eventEnvHoldInits - -getCurrentHeight :: EventM Int -getCurrentHeight = EventM $ do - heightRef <- asks eventEnvCurrentHeight - liftIO $ readIORef heightRef - -putCurrentHeight :: Int -> EventM () -putCurrentHeight h = EventM $ do - heightRef <- asks eventEnvCurrentHeight - liftIO $ writeIORef heightRef h - -scheduleClear :: IORef (Maybe a) -> EventM () -scheduleClear r = EventM $ do - clears <- asks eventEnvClears - liftIO $ modifyIORef' clears (SomeMaybeIORef r :) - -scheduleRootClear :: IORef (DMap k Identity) -> EventM () -scheduleRootClear r = EventM $ do - clears <- asks eventEnvRootClears - liftIO $ modifyIORef' clears (SomeDMapIORef r :) - -scheduleMerge :: Int -> MergeSubscribed a -> EventM () -scheduleMerge height subscribed = EventM $ do - delayedRef <- asks eventEnvDelayedMerges - liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) height [DelayedMerge subscribed] - -emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM () -emitCoincidenceInfo sci = EventM $ do - ciRef <- asks eventEnvCoincidenceInfos - liftIO $ modifyIORef' ciRef (sci:) - --- Note: hold cannot examine its event until after the phase is over -hold :: a -> Event a -> EventM (Behavior a) -hold v0 e = do - holdInitRef <- askHoldInitRef - liftIO $ do - valRef <- newIORef v0 - invsRef <- newIORef [] - parentRef <- newIORef $ error "hold not yet initialized (parent)" - subscriberRef <- newIORef $ error "hold not yet initialized (subscriber)" - let h = Hold - { holdValue = valRef - , holdInvalidators = invsRef - , holdSubscriber = subscriberRef - , holdParent = parentRef -#ifdef DEBUG_NODEIDS - , holdNodeId = unsafeNodeId (v0, e) -#endif - } - s <- newSubscriberHold h - writeIORef subscriberRef $ unsafeCoerce s - modifyIORef' holdInitRef (SomeHoldInit e h :) - return $ BehaviorHold h - -subscribeHold :: Event a -> Hold a -> EventM () -subscribeHold e h = do - toAssignRef <- askToAssignRef - !s <- liftIO $ liftM unsafeCoerce $ readIORef $ holdSubscriber h -- This must be performed strictly so that the weak pointer points at the actual item - ws <- liftIO $ mkWeakPtrWithDebug s "holdSubscriber" - subd <- subscribe e $ WeakSubscriberSimple ws - liftIO $ writeIORef (holdParent h) $ unsafeCoerce subd - occ <- liftIO $ getEventSubscribedOcc subd - case occ of - Nothing -> return () - Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :) - ---type role BehaviorM representational --- BehaviorM can sample behaviors -newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed])) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix) - -data BehaviorSubscribed a - = BehaviorSubscribedHold (Hold a) - | BehaviorSubscribedPull (PullSubscribed a) - -data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a) - ---type role PullSubscribed representational -data PullSubscribed a - = PullSubscribed { pullSubscribedValue :: !a - , pullSubscribedInvalidators :: !(IORef [Weak Invalidator]) - , pullSubscribedOwnInvalidator :: !Invalidator - , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated - } - ---type role Pull representational -data Pull a - = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a))) - , pullCompute :: !(BehaviorM a) - } - -data Invalidator - = forall a. InvalidatorPull (Pull a) - | forall a. InvalidatorSwitch (SwitchSubscribed a) - -data RootSubscribed a - = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a]) - , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence - } - -data Root (k :: * -> *) - = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event - , rootSubscribed :: !(IORef (DMap k RootSubscribed)) - , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ())) - } - -data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a) - --- EventM can do everything BehaviorM can, plus create holds -newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over - -data PushSubscribed a b - = PushSubscribed { pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are) - , pushSubscribedHeight :: !(IORef Int) - , pushSubscribedSubscribers :: !(IORef [WeakSubscriber b]) - , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die - , pushSubscribedParent :: !(EventSubscribed a) -#ifdef DEBUG_NODEIDS - , pushSubscribedNodeId :: Int -#endif - } - -data Push a b - = Push { pushCompute :: !(a -> EventM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed - , pushParent :: !(Event a) - , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk? - } - -data MergeSubscribed k - = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity))) - , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence - , mergeSubscribedHeight :: !(IORef Int) - , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)]) - , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory - , mergeSubscribedParents :: !(DMap k EventSubscribed) -#ifdef DEBUG_NODEIDS - , mergeSubscribedNodeId :: Int -#endif - } - ---TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key) -data Merge k - = Merge { mergeParents :: !(DMap k Event) - , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk? - } - -data FanSubscriberKey k a where - FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a] - -instance GEq k => GEq (FanSubscriberKey k) where - geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of - Nothing -> Nothing - Just Refl -> Just Refl - -instance GCompare k => GCompare (FanSubscriberKey k) where - gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of - GLT -> GLT - GEQ -> GEQ - GGT -> GGT - -data FanSubscribed k - = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity)) - , fanSubscribedParent :: !(EventSubscribed (DMap k Identity)) - , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity)) -#ifdef DEBUG_NODEIDS - , fanSubscribedNodeId :: Int -#endif - } - -data Fan k - = Fan { fanParent :: !(Event (DMap k Identity)) - , fanSubscribed :: !(IORef (Maybe (FanSubscribed k))) - } - -data SwitchSubscribed a - = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a)) - , switchSubscribedHeight :: !(IORef Int) - , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a]) - , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a) - , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a))) - , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator - , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator)) - , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed]) - , switchSubscribedParent :: !(Behavior (Event a)) - , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a)) -#ifdef DEBUG_NODEIDS - , switchSubscribedNodeId :: Int -#endif - } - -data Switch a - = Switch { switchParent :: !(Behavior (Event a)) - , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a))) - } - -data CoincidenceSubscribed a - = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a)) - , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a]) - , coincidenceSubscribedHeight :: !(IORef Int) - , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a)) - , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a)) - , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a))) -#ifdef DEBUG_NODEIDS - , coincidenceSubscribedNodeId :: Int -#endif - } - -data Coincidence a - = Coincidence { coincidenceParent :: !(Event (Event a)) - , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a))) - } - -data Box a = Box { unBox :: a } - ---type WeakSubscriber a = Weak (Subscriber a) -data WeakSubscriber a - = forall k. GCompare k => WeakSubscriberMerge !(k a) !(Weak (Box (MergeSubscribed k))) --TODO: Can we inline the GCompare? - | WeakSubscriberSimple !(Weak (Subscriber a)) - -showWeakSubscriberType :: WeakSubscriber a -> String -showWeakSubscriberType = \case - WeakSubscriberMerge _ _ -> "WeakSubscriberMerge" - WeakSubscriberSimple _ -> "WeakSubscriberSimple" - -deRefWeakSubscriber :: WeakSubscriber a -> IO (Maybe (Subscriber a)) -deRefWeakSubscriber ws = case ws of - WeakSubscriberSimple w -> deRefWeak w - WeakSubscriberMerge k w -> liftM (fmap $ SubscriberMerge k . unBox) $ deRefWeak w - -data Subscriber a - = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b) - | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare? - | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k) - | SubscriberHold !(Hold a) - | SubscriberSwitch (SwitchSubscribed a) - | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b) - | SubscriberCoincidenceInner (CoincidenceSubscribed a) - -showSubscriberType :: Subscriber a -> String -showSubscriberType = \case - SubscriberPush _ _ -> "SubscriberPush" - SubscriberMerge _ _ -> "SubscriberMerge" - SubscriberFan _ -> "SubscriberFan" - SubscriberHold _ -> "SubscriberHold" - SubscriberSwitch _ -> "SubscriberSwitch" - SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter" - SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner" - -data Event a - = forall k. GCompare k => EventRoot !(k a) !(Root k) - | EventNever - | forall b. EventPush !(Push b a) - | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k) - | forall k. GCompare k => EventFan !(k a) !(Fan k) - | EventSwitch !(Switch a) - | EventCoincidence !(Coincidence a) - -showEventType :: Event a -> String -showEventType = \case - EventRoot _ _ -> "EventRoot" - EventNever -> "EventNever" - EventPush _ -> "EventPush" - EventMerge _ -> "EventMerge" - EventFan _ _ -> "EventFan" - EventSwitch _ -> "EventSwitch" - EventCoincidence _ -> "EventCoincidence" - -data EventSubscribed a - = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a) - | EventSubscribedNever - | forall b. EventSubscribedPush !(PushSubscribed b a) - | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k) - | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k) - | EventSubscribedSwitch !(SwitchSubscribed a) - | EventSubscribedCoincidence !(CoincidenceSubscribed a) - --- These function are constructor functions that are marked NOINLINE so they are --- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away --- so any weak references that are attached to the constructors will have their --- finalizer run. Using the opaque constructor, does not see the --- constructor application, so it behaves like an IORef and cannot be fused away. --- --- The result is also evaluated to WHNF, since forcing a thunk invalidates --- the weak pointer to it in some cases. - -{-# NOINLINE newRootSubscribed #-} -newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a) -newRootSubscribed occ subs = - return $! RootSubscribed - { rootSubscribedOccurrence = occ - , rootSubscribedSubscribers = subs - } - -{-# NOINLINE newSubscriberPush #-} -newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a) -newSubscriberPush compute subd = return $! SubscriberPush compute subd - -{-# NOINLINE newSubscriberHold #-} -newSubscriberHold :: Hold a -> IO (Subscriber a) -newSubscriberHold h = return $! SubscriberHold h - -{-# NOINLINE newSubscriberFan #-} -newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity)) -newSubscriberFan subd = return $! SubscriberFan subd - -{-# NOINLINE newSubscriberSwitch #-} -newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a) -newSubscriberSwitch subd = return $! SubscriberSwitch subd - -{-# NOINLINE newSubscriberCoincidenceOuter #-} -newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b)) -newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd - -{-# NOINLINE newSubscriberCoincidenceInner #-} -newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a) -newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd - -{-# NOINLINE newInvalidatorSwitch #-} -newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator -newInvalidatorSwitch subd = return $! InvalidatorSwitch subd - -{-# NOINLINE newInvalidatorPull #-} -newInvalidatorPull :: Pull a -> IO Invalidator -newInvalidatorPull p = return $! InvalidatorPull p - -{-# NOINLINE newBox #-} -newBox :: a -> IO (Box a) -newBox a = return $! Box a - ---type role Behavior representational -data Behavior a - = BehaviorHold !(Hold a) - | BehaviorConst !a - | BehaviorPull !(Pull a) - --- ResultM can read behaviors and events -type ResultM = EventM - -{-# NOINLINE unsafeNewIORef #-} -unsafeNewIORef :: a -> b -> IORef b -unsafeNewIORef _ b = unsafePerformIO $ newIORef b - -instance Functor Event where - fmap f = push $ return . Just . f - -instance Functor Behavior where - fmap f = pull . liftM f . readBehaviorTracked - -{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly -push :: (a -> EventM (Maybe b)) -> Event a -> Event b -push f e = EventPush $ Push - { pushCompute = f - , pushParent = e - , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead? - } -{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-} - -{-# NOINLINE pull #-} -pull :: BehaviorM a -> Behavior a -pull a = BehaviorPull $ Pull - { pullCompute = a - , pullValue = unsafeNewIORef a Nothing - } -{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-} - -{-# NOINLINE switch #-} -switch :: Behavior (Event a) -> Event a -switch a = EventSwitch $ Switch - { switchParent = a - , switchSubscribed = unsafeNewIORef a Nothing - } -{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-} - -coincidence :: Event (Event a) -> Event a -coincidence a = EventCoincidence $ Coincidence - { coincidenceParent = a - , coincidenceSubscribed = unsafeNewIORef a Nothing - } - -newRoot :: IO (Root k) -newRoot = do - occRef <- newIORef DMap.empty - subscribedRef <- newIORef DMap.empty - return $ Root - { rootOccurrence = occRef - , rootSubscribed = subscribedRef - , rootInit = \_ _ -> return $ return () - } - -propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM () -propagateAndUpdateSubscribersRef subscribersRef a = do - subscribers <- liftIO $ readIORef subscribersRef - liftIO $ writeIORef subscribersRef [] - stillAlive <- propagate a subscribers - liftIO $ modifyIORef' subscribersRef (++stillAlive) - --- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors -run :: [DSum RootTrigger Identity] -> ResultM b -> IO b -run roots after = do - when debugPropagate $ putStrLn "Running an event frame" - result <- runFrame $ do - rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do - occBefore <- liftIO $ do - occBefore <- readIORef occRef - writeIORef occRef $ DMap.insert k a occBefore - return occBefore - if DMap.null occBefore - then do scheduleRootClear occRef - return $ Just r - else return Nothing - forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do - propagateAndUpdateSubscribersRef subscribersRef a - delayedRef <- EventM $ asks eventEnvDelayedMerges - let go = do - delayed <- liftIO $ readIORef delayedRef - case IntMap.minViewWithKey delayed of - Nothing -> return () - Just ((currentHeight, current), future) -> do - when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight - putCurrentHeight currentHeight - liftIO $ writeIORef delayedRef future - forM_ current $ \d -> case d of - DelayedMerge subscribed -> do - height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed - case height `compare` currentHeight of - LT -> error "Somehow a merge's height has been decreased after it was scheduled" - GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?) - EQ -> do - m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed - liftIO $ writeIORef (mergeSubscribedAccum subscribed) DMap.empty - --TODO: Assert that m is not empty - liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m - scheduleClear $ mergeSubscribedOccurrence subscribed - propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m - go - go - putCurrentHeight maxBound - after - when debugPropagate $ putStrLn "Done running an event frame" - return result - -data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a)) - -data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity)) - -data SomeAssignment = forall a. SomeAssignment (Hold a) a - -data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k) - -debugFinalize :: Bool -debugFinalize = False - -mkWeakPtrWithDebug :: a -> String -> IO (Weak a) -mkWeakPtrWithDebug x debugNote = mkWeakPtr x $ - if debugFinalize - then Just $ putStrLn $ "finalizing: " ++ debugNote - else Nothing - -type WeakList a = [Weak a] - ---TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed? -traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa] -traverseAndCleanWeakList_ deRef ws f = go ws - where go [] = return [] - go (h:t) = do - ma <- deRef h - case ma of - Just a -> do - f a - t' <- go t - return $ h : t' - Nothing -> go t - --- | Propagate everything at the current height -propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a] -propagate a subscribers = do - traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of - SubscriberPush compute subscribed -> do - when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed - occ <- compute a - case occ of - Nothing -> return () -- No need to write a Nothing back into the Ref - Just o -> do - liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ - scheduleClear $ pushSubscribedOccurrence subscribed - liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed)) - SubscriberMerge k subscribed -> do - when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed - oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed - liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM - when (DMap.null oldM) $ do -- Only schedule the firing once - height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed - --TODO: assertions about height - currentHeight <- getCurrentHeight - when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")" - scheduleMerge height subscribed - SubscriberFan subscribed -> do - subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed - when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing" - --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large - forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of - Nothing -> do - when debugPropagate $ liftIO $ putStrLn "No subscriber for key" - return () - Just (Identity subsubs) -> do - _ <- propagate v subsubs --TODO: use the value of this - return () - --TODO: The following is way too slow to do all the time - subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do - subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ()) - return $ if null subsubs' - then Nothing - else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity))) - liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs' - SubscriberHold h -> do - invalidators <- liftIO $ readIORef $ holdInvalidators h - when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators) - toAssignRef <- askToAssignRef - liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :) - SubscriberSwitch subscribed -> do - when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed - liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a - scheduleClear $ switchSubscribedOccurrence subscribed - subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed - liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs - SubscriberCoincidenceOuter subscribed -> do - when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed - outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed - when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight - (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed - when debugPropagate $ liftIO $ putStrLn $ " isJust occ = " <> show (isJust occ) - when debugPropagate $ liftIO $ putStrLn $ " innerHeight = " <> show innerHeight - liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd - scheduleClear $ coincidenceSubscribedInnerParent subscribed - case occ of - Nothing -> do - when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height - writeIORef (coincidenceSubscribedHeight subscribed) innerHeight - mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) - mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) - Just o -> do -- Since it's already firing, no need to adjust height - liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ - scheduleClear $ coincidenceSubscribedOccurrence subscribed - liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed)) - SubscriberCoincidenceInner subscribed -> do - when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed - liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a - scheduleClear $ coincidenceSubscribedOccurrence subscribed - liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed)) - -data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (Subscriber a) (Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset - -subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a) -subscribeCoincidenceInner o outerHeight subscribedUnsafe = do - subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe - wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner" - innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner) - innerOcc <- liftIO $ getEventSubscribedOcc innerSubd - innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd - let height = max innerHeight outerHeight - emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing - return (innerOcc, height, innerSubd) - -readBehavior :: Behavior a -> IO a -readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases - -runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a -runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi - -askInvalidator :: BehaviorM (Maybe (Weak Invalidator)) -askInvalidator = liftM (fmap fst) $ BehaviorM ask - -askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed])) -askParentsRef = liftM (fmap snd) $ BehaviorM ask - -readBehaviorTracked :: Behavior a -> BehaviorM a -readBehaviorTracked b = case b of - BehaviorHold h -> do - result <- liftIO $ readIORef $ holdValue h - askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:)) - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :)) - liftIO $ touch $ holdSubscriber h - return result - BehaviorConst a -> return a - BehaviorPull p -> do - val <- liftIO $ readIORef $ pullValue p - case val of - Just subscribed -> do - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :)) - askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:)) - liftIO $ touch $ pullSubscribedOwnInvalidator subscribed - return $ pullSubscribedValue subscribed - Nothing -> do - i <- liftIO $ newInvalidatorPull p - wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull" - parentsRef <- liftIO $ newIORef [] - a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef) - invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator - parents <- liftIO $ readIORef parentsRef - let subscribed = PullSubscribed - { pullSubscribedValue = a - , pullSubscribedInvalidators = invsRef - , pullSubscribedOwnInvalidator = i - , pullSubscribedParents = parents - } - liftIO $ writeIORef (pullValue p) $ Just subscribed - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :)) - return a - -readEvent :: Event a -> ResultM (Maybe a) -readEvent e = case e of - EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r - EventNever -> return Nothing - EventPush p -> do - subscribed <- getPushSubscribed p - liftIO $ do - result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid - touch $ pushSubscribedSelf subscribed - return result - EventMerge m -> do - subscribed <- getMergeSubscribed m - liftIO $ do - result <- readIORef $ mergeSubscribedOccurrence subscribed - touch $ mergeSubscribedSelf subscribed - return result - EventFan k f -> do - parentOcc <- readEvent $ fanParent f - return . coerce $ DMap.lookup k =<< parentOcc - EventSwitch s -> do - subscribed <- getSwitchSubscribed s - liftIO $ do - result <- readIORef $ switchSubscribedOccurrence subscribed - touch $ switchSubscribedSelf subscribed - touch $ switchSubscribedOwnInvalidator subscribed - return result - EventCoincidence c -> do - subscribed <- getCoincidenceSubscribed c - liftIO $ do - result <- readIORef $ coincidenceSubscribedOccurrence subscribed - touch $ coincidenceSubscribedOuter subscribed - --TODO: do we need to touch the inner subscriber? - return result - --- Always refers to 0 -{-# NOINLINE zeroRef #-} -zeroRef :: IORef Int -zeroRef = unsafePerformIO $ newIORef 0 - -getEventSubscribed :: Event a -> EventM (EventSubscribed a) -getEventSubscribed e = case e of - EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r - EventNever -> return EventSubscribedNever - EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p - EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f - EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m - EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s - EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c - -debugSubscribe :: Bool -debugSubscribe = False - -subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO () -subscribeEventSubscribed es ws = case es of - EventSubscribedRoot r -> do - when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root" - modifyIORef' (rootSubscribedSubscribers r) (ws:) - EventSubscribedNever -> do - when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never" - return () - EventSubscribedPush subscribed -> do - when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push" - modifyIORef' (pushSubscribedSubscribers subscribed) (ws:) - EventSubscribedFan k subscribed -> do - when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan" - modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws]) - EventSubscribedMerge subscribed -> do - when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge" - modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:) - EventSubscribedSwitch subscribed -> do - when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch" - modifyIORef' (switchSubscribedSubscribers subscribed) (ws:) - EventSubscribedCoincidence subscribed -> do - when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence" - modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:) - -getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a) -getEventSubscribedOcc es = case es of - EventSubscribedRoot r -> rootSubscribedOccurrence r - EventSubscribedNever -> return Nothing - EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed - EventSubscribedFan k subscribed -> do - parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed - let occ = coerce $ DMap.lookup k =<< parentOcc - return occ - EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed - EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed - EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed - -eventSubscribedHeightRef :: EventSubscribed a -> IORef Int -eventSubscribedHeightRef es = case es of - EventSubscribedRoot _ -> zeroRef - EventSubscribedNever -> zeroRef - EventSubscribedPush subscribed -> pushSubscribedHeight subscribed - EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed - EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed - EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed - EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed - -subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a) -subscribe e ws = do - subd <- getEventSubscribed e - liftIO $ subscribeEventSubscribed subd ws - return subd - -noinlineFalse :: Bool -noinlineFalse = False -{-# NOINLINE noinlineFalse #-} - -getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a) -getRootSubscribed k r = do - mSubscribed <- liftIO $ readIORef $ rootSubscribed r - case DMap.lookup k mSubscribed of - Just subscribed -> return subscribed - Nothing -> liftIO $ do - subscribersRef <- newIORef [] - subscribed <- newRootSubscribed (liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef - -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory - uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k) - addFinalizer subscribed $ do - when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should --- putStrLn "Uninit root" - uninit - liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed - return subscribed - --- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in -getPushSubscribed :: Push a b -> EventM (PushSubscribed a b) -getPushSubscribed p = do - mSubscribed <- liftIO $ readIORef $ pushSubscribed p - case mSubscribed of - Just subscribed -> return subscribed - Nothing -> do -- Not yet subscribed - subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p - s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe - ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush" - subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws - parentOcc <- liftIO $ getEventSubscribedOcc subd - occ <- liftM join $ mapM (pushCompute p) parentOcc - occRef <- liftIO $ newIORef occ - when (isJust occ) $ scheduleClear occRef - subscribersRef <- liftIO $ newIORef [] - let subscribed = PushSubscribed - { pushSubscribedOccurrence = occRef - , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref - , pushSubscribedSubscribers = subscribersRef - , pushSubscribedSelf = unsafeCoerce s - , pushSubscribedParent = subd -#ifdef DEBUG_NODEIDS - , pushSubscribedNodeId = unsafeNodeId p -#endif - } - liftIO $ writeIORef (pushSubscribed p) $ Just subscribed - return subscribed - -getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k) -getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do - mSubscribed <- liftIO $ readIORef $ mergeSubscribed m - case mSubscribed of - Just subscribed -> return subscribed - Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do - subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized" - subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef - s <- liftIO $ newBox subscribedUnsafe - ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge" - subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do - parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws - parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd - height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd - return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (\x -> k :=> Identity x) parentOcc, height, k :=> parentSubd) - let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers - subscriberHeights = map (\(_, _, x, _) -> x) subscribers - myHeight = - if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum' - then invalidHeight - else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here - currentHeight <- getCurrentHeight - let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now - then (if DMap.null dm then Nothing else Just dm, DMap.empty) - else (Nothing, dm) - when (not $ DMap.null accum) $ do - scheduleMerge myHeight subscribedUnsafe - occRef <- liftIO $ newIORef occ - when (isJust occ) $ scheduleClear occRef - accumRef <- liftIO $ newIORef accum - heightRef <- liftIO $ newIORef myHeight - subsRef <- liftIO $ newIORef [] - let subscribed = MergeSubscribed - { mergeSubscribedOccurrence = occRef - , mergeSubscribedAccum = accumRef - , mergeSubscribedHeight = heightRef - , mergeSubscribedSubscribers = subsRef - , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak? - , mergeSubscribedParents = DMap.fromDistinctAscList $ map (\(_, _, _, x) -> x) subscribers -#ifdef DEBUG_NODEIDS - , mergeSubscribedNodeId = unsafeNodeId m -#endif - } - liftIO $ writeIORef subscribedRef subscribed - return subscribed - where emptyMergeSubscribed = do --TODO: This should never happen - occRef <- liftIO $ newIORef Nothing - accumRef <- liftIO $ newIORef DMap.empty - subsRef <- liftIO $ newIORef [] - return $ MergeSubscribed - { mergeSubscribedOccurrence = occRef - , mergeSubscribedAccum = accumRef - , mergeSubscribedHeight = zeroRef - , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak - , mergeSubscribedSelf = unsafeCoerce () - , mergeSubscribedParents = DMap.empty -#ifdef DEBUG_NODEIDS - , mergeSubscribedNodeId = -1 -#endif - } - -getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k) -getFanSubscribed f = do - mSubscribed <- liftIO $ readIORef $ fanSubscribed f - case mSubscribed of - Just subscribed -> return subscribed - Nothing -> do - subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f - sub <- liftIO $ newSubscriberFan subscribedUnsafe - wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan" - subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub - subscribersRef <- liftIO $ newIORef DMap.empty - let subscribed = FanSubscribed - { fanSubscribedParent = subd - , fanSubscribedSubscribers = subscribersRef - , fanSubscribedSelf = sub -#ifdef DEBUG_NODEIDS - , fanSubscribedNodeId = unsafeNodeId f -#endif - } - liftIO $ writeIORef (fanSubscribed f) $ Just subscribed - return subscribed - -getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a) -getSwitchSubscribed s = do - mSubscribed <- liftIO $ readIORef $ switchSubscribed s - case mSubscribed of - Just subscribed -> return subscribed - Nothing -> do - subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created" - subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef - i <- liftIO $ newInvalidatorSwitch subscribedUnsafe - sub <- liftIO $ newSubscriberSwitch subscribedUnsafe - wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch" - wiRef <- liftIO $ newIORef wi - wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch" - selfWeakRef <- liftIO $ newIORef wsub - parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior - e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef) - subd <- subscribe e $ WeakSubscriberSimple wsub - subdRef <- liftIO $ newIORef subd - parentOcc <- liftIO $ getEventSubscribedOcc subd - occRef <- liftIO $ newIORef parentOcc - when (isJust parentOcc) $ scheduleClear occRef - heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd) - subscribersRef <- liftIO $ newIORef [] - let subscribed = SwitchSubscribed - { switchSubscribedOccurrence = occRef - , switchSubscribedHeight = heightRef - , switchSubscribedSubscribers = subscribersRef - , switchSubscribedSelf = sub - , switchSubscribedSelfWeak = selfWeakRef - , switchSubscribedOwnInvalidator = i - , switchSubscribedOwnWeakInvalidator = wiRef - , switchSubscribedBehaviorParents = parentsRef - , switchSubscribedParent = switchParent s - , switchSubscribedCurrentParent = subdRef -#ifdef DEBUG_NODEIDS - , switchSubscribedNodeId = unsafeNodeId s -#endif - } - liftIO $ writeIORef subscribedRef subscribed - liftIO $ writeIORef (switchSubscribed s) $ Just subscribed - return subscribed - -getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a) -getCoincidenceSubscribed c = do - mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c - case mSubscribed of - Just subscribed -> return subscribed - Nothing -> do - subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created" - subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef - subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe - wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter" - outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter - outerOcc <- liftIO $ getEventSubscribedOcc outerSubd - outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd - (occ, height, mInnerSubd) <- case outerOcc of - Nothing -> return (Nothing, outerHeight, Nothing) - Just o -> do - (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe - return (occ, height, Just innerSubd) - occRef <- liftIO $ newIORef occ - when (isJust occ) $ scheduleClear occRef - heightRef <- liftIO $ newIORef height - innerSubdRef <- liftIO $ newIORef mInnerSubd - scheduleClear innerSubdRef - subscribersRef <- liftIO $ newIORef [] - let subscribed = CoincidenceSubscribed - { coincidenceSubscribedOccurrence = occRef - , coincidenceSubscribedHeight = heightRef - , coincidenceSubscribedSubscribers = subscribersRef - , coincidenceSubscribedOuter = subOuter - , coincidenceSubscribedOuterParent = outerSubd - , coincidenceSubscribedInnerParent = innerSubdRef -#ifdef DEBUG_NODEIDS - , coincidenceSubscribedNodeId = unsafeNodeId c -#endif - } - liftIO $ writeIORef subscribedRef subscribed - liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed - return subscribed - -merge :: GCompare k => DMap k Event -> Event (DMap k Identity) -merge m = EventMerge $ Merge - { mergeParents = m - , mergeSubscribed = unsafeNewIORef m Nothing - } - -newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a } - -fan :: GCompare k => Event (DMap k Identity) -> EventSelector k -fan e = - let f = Fan - { fanParent = e - , fanSubscribed = unsafeNewIORef e Nothing - } - in EventSelector $ \k -> EventFan k f - --- | Run an event action outside of a frame -runFrame :: EventM a -> IO a -runFrame a = do - toAssignRef <- newIORef [] -- This should only actually get used when events are firing - holdInitRef <- newIORef [] - heightRef <- newIORef 0 - toClearRef <- newIORef [] - toClearRootRef <- newIORef [] - coincidenceInfosRef <- newIORef [] - delayedRef <- liftIO $ newIORef IntMap.empty - result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do - result <- a - let runHoldInits = do - holdInits <- liftIO $ readIORef holdInitRef - if null holdInits then return () else do - liftIO $ writeIORef holdInitRef [] - forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h - runHoldInits - runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events - return result - toClear <- readIORef toClearRef - forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing - toClearRoot <- readIORef toClearRootRef - forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty - toAssign <- readIORef toAssignRef - toReconnectRef <- newIORef [] - forM_ toAssign $ \(SomeAssignment h v) -> do - writeIORef (holdValue h) v - writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h) - coincidenceInfos <- readIORef coincidenceInfosRef - forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do - touch subInner - finalize wsubInner - mapM_ invalidateCoincidenceHeight mcs - toReconnect <- readIORef toReconnectRef - forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do - wsub <- readIORef $ switchSubscribedSelfWeak subscribed - finalize wsub - wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed - finalize wi - let !i = switchSubscribedOwnInvalidator subscribed - wi' <- mkWeakPtrWithDebug i "wi'" - writeIORef (switchSubscribedBehaviorParents subscribed) [] - e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) - --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times - let !sub = switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk - wsub' <- mkWeakPtrWithDebug sub "wsub'" - writeIORef (switchSubscribedSelfWeak subscribed) wsub' - subd' <- runFrame $ subscribe e $ WeakSubscriberSimple wsub' --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient - {- - stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed) - liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of - EventRoot _ -> "EventRoot" - EventNever -> "EventNever" - _ -> "something else" - -} - writeIORef (switchSubscribedCurrentParent subscribed) subd' - parentHeight <- readIORef $ eventSubscribedHeightRef subd' - myHeight <- readIORef $ switchSubscribedHeight subscribed - if parentHeight == myHeight then return () else do - writeIORef (switchSubscribedHeight subscribed) parentHeight - mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed) - forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs - forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do - mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed) - return result - -invalidHeight :: Int -invalidHeight = -1000 - -invalidateSubscriberHeight :: WeakSubscriber a -> IO () -invalidateSubscriberHeight ws = do - ms <- deRefWeakSubscriber ws - case ms of - Nothing -> return () --TODO: cleanup? - Just s -> case s of - SubscriberPush _ subscribed -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed - mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed) - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done" - SubscriberMerge _ subscribed -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed - oldHeight <- readIORef $ mergeSubscribedHeight subscribed - when (oldHeight /= invalidHeight) $ do - writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight - mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed) - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done" - SubscriberFan subscribed -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed - subscribers <- readIORef $ fanSubscribedSubscribers subscribed - forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ()) - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" - SubscriberHold _ -> return () - SubscriberSwitch subscribed -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed - oldHeight <- readIORef $ switchSubscribedHeight subscribed - when (oldHeight /= invalidHeight) $ do - writeIORef (switchSubscribedHeight subscribed) $ invalidHeight - mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed) - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done" - SubscriberCoincidenceOuter subscribed -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed - invalidateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done" - SubscriberCoincidenceInner subscribed -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed - invalidateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done" - -invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO () -invalidateCoincidenceHeight subscribed = do - oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed - when (oldHeight /= invalidHeight) $ do - writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight - mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) - ---TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy - -recalculateSubscriberHeight :: WeakSubscriber a -> IO () -recalculateSubscriberHeight ws = do - ms <- deRefWeakSubscriber ws - case ms of - Nothing -> return () --TODO: cleanup? - Just s -> case s of - SubscriberPush _ subscribed -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed - mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed) - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done" - SubscriberMerge _ subscribed -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed - oldHeight <- readIORef $ mergeSubscribedHeight subscribed - when (oldHeight == invalidHeight) $ do - height <- calculateMergeHeight subscribed - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height - when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated - writeIORef (mergeSubscribedHeight subscribed) height - mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed) - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done" - SubscriberFan subscribed -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed - subscribers <- readIORef $ fanSubscribedSubscribers subscribed - forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ()) - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" - SubscriberHold _ -> return () - SubscriberSwitch subscribed -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed - oldHeight <- readIORef $ switchSubscribedHeight subscribed - when (oldHeight == invalidHeight) $ do - height <- calculateSwitchHeight subscribed - when (height /= invalidHeight) $ do - writeIORef (switchSubscribedHeight subscribed) height - mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed) - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done" - SubscriberCoincidenceOuter subscribed -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed - void $ recalculateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done" - SubscriberCoincidenceInner subscribed -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed - void $ recalculateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done" - -recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO () -recalculateCoincidenceHeight subscribed = do - oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed - when (oldHeight == invalidHeight) $ do - height <- calculateCoincidenceHeight subscribed - when (height /= invalidHeight) $ do - writeIORef (coincidenceSubscribedHeight subscribed) height - mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones - -calculateMergeHeight :: MergeSubscribed k -> IO Int -calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do - heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do - readIORef $ eventSubscribedHeightRef es - return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum' - -calculateSwitchHeight :: SwitchSubscribed a -> IO Int -calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed) - -calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int -calculateCoincidenceHeight subscribed = do - outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed - innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed) - return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight - -{- -recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int -recalculateEventSubscribedHeight es = case es of - EventSubscribedRoot _ -> return 0 - EventSubscribedNever -> return 0 - EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed - EventSubscribedMerge subscribed -> do - oldHeight <- readIORef $ mergeSubscribedHeight subscribed - if oldHeight /= invalidHeight then return oldHeight else do - height <- calculateMergeHeight subscribed - writeIORef (mergeSubscribedHeight subscribed) height - return height - EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed - EventSubscribedSwitch subscribed -> do - oldHeight <- readIORef $ switchSubscribedHeight subscribed - if oldHeight /= invalidHeight then return oldHeight else do - height <- calculateSwitchHeight subscribed - writeIORef (switchSubscribedHeight subscribed) height - return height - EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed --} - -data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a) - -debugInvalidate :: Bool -debugInvalidate = False - -invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator) -invalidate toReconnectRef wis = do - forM_ wis $ \wi -> do - mi <- deRefWeak wi - case mi of - Nothing -> do - when debugInvalidate $ liftIO $ putStrLn "invalidate Dead" - return () --TODO: Should we clean this up here? - Just i -> do - finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict - case i of - InvalidatorPull p -> do - when debugInvalidate $ liftIO $ putStrLn "invalidate Pull" - mVal <- readIORef $ pullValue p - forM_ mVal $ \val -> do - writeIORef (pullValue p) Nothing - writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val) - InvalidatorSwitch subscribed -> do - when debugInvalidate $ liftIO $ putStrLn "invalidate Switch" - modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :) - return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them - --------------------------------------------------------------------------------- --- Reflex integration --------------------------------------------------------------------------------- - -data Spider - -instance R.Reflex Spider where - newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a } - newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a } - type PullM Spider = BehaviorM - type PushM Spider = EventM - {-# INLINE never #-} - {-# INLINE constant #-} - never = SpiderEvent EventNever - constant = SpiderBehavior . BehaviorConst - push f = SpiderEvent. push f . unSpiderEvent - pull = SpiderBehavior . pull - merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event) - fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e)) - switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior - coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent - -instance R.MonadSample Spider SpiderHost where - {-# INLINE sample #-} - sample = SpiderHost . readBehavior . unSpiderBehavior - -instance R.MonadHold Spider SpiderHost where - hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent - -instance R.MonadSample Spider BehaviorM where - {-# INLINE sample #-} - sample = readBehaviorTracked . unSpiderBehavior - -instance R.MonadSample Spider EventM where - {-# INLINE sample #-} - sample = liftIO . readBehavior . unSpiderBehavior - -instance R.MonadHold Spider EventM where - {-# INLINE hold #-} - hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e) - -data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a) -newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a } - -instance R.MonadSubscribeEvent Spider SpiderHostFrame where - subscribeEvent e = SpiderHostFrame $ do - _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used - return $ SpiderEventHandle (unSpiderEvent e) - -instance R.ReflexHost Spider where - type EventTrigger Spider = RootTrigger - type EventHandle Spider = SpiderEventHandle - type HostFrame Spider = SpiderHostFrame - -instance R.MonadReadEvent Spider ReadPhase where - {-# INLINE readEvent #-} - readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle - -instance MonadRef EventM where - type Ref EventM = Ref IO - {-# INLINE newRef #-} - {-# INLINE readRef #-} - {-# INLINE writeRef #-} - newRef = liftIO . newRef - readRef = liftIO . readRef - writeRef r a = liftIO $ writeRef r a - -instance MonadAtomicRef EventM where - {-# INLINE atomicModifyRef #-} - atomicModifyRef r f = liftIO $ atomicModifyRef r f - -newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) - -newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) - -instance R.MonadSample Spider SpiderHostFrame where - sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can - -instance R.MonadHold Spider SpiderHostFrame where - {-# INLINE hold #-} - hold v0 e = SpiderHostFrame $ R.hold v0 e - -newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a) -newEventWithTriggerIO f = do - es <- newFanEventWithTriggerIO $ \Refl -> f - return $ select es Refl - -newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k) -newFanEventWithTriggerIO f = do - occRef <- newIORef DMap.empty - subscribedRef <- newIORef DMap.empty - let !r = Root - { rootOccurrence = occRef - , rootSubscribed = subscribedRef - , rootInit = f - } - return $ EventSelector $ \k -> EventRoot k r - -instance R.MonadReflexCreateTrigger Spider SpiderHost where - newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO - newFanEventWithTrigger f = SpiderHost $ do - es <- newFanEventWithTriggerIO f - return $ R.EventSelector $ SpiderEvent . select es - -instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where - newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO - newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do - es <- newFanEventWithTriggerIO f - return $ R.EventSelector $ SpiderEvent . select es - -instance R.MonadSubscribeEvent Spider SpiderHost where - subscribeEvent e = SpiderHost $ do - _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used - return $ SpiderEventHandle (unSpiderEvent e) - -newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider) - -instance R.MonadReflexHost Spider SpiderHost where - type ReadPhase SpiderHost = ReadPhase - fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a - runHostFrame = SpiderHost . runFrame . runSpiderHostFrame - -instance MonadRef SpiderHost where - type Ref SpiderHost = Ref IO - newRef = SpiderHost . newRef - readRef = SpiderHost . readRef - writeRef r = SpiderHost . writeRef r - -instance MonadAtomicRef SpiderHost where - atomicModifyRef r = SpiderHost . atomicModifyRef r - -instance MonadRef SpiderHostFrame where - type Ref SpiderHostFrame = Ref IO - newRef = SpiderHostFrame . newRef - readRef = SpiderHostFrame . readRef - writeRef r = SpiderHostFrame . writeRef r - -instance MonadAtomicRef SpiderHostFrame where - atomicModifyRef r = SpiderHostFrame . atomicModifyRef r +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses +-- a graph traversal algorithm to propagate 'Event's and 'Behavior's. +module Reflex.Spider.Internal (module Reflex.Spider.Internal) where + +#if MIN_VERSION_base(4,10,0) +import Control.Applicative (liftA2) +#endif +import Control.Concurrent +import Control.Exception +import Control.Monad hiding (forM, forM_, mapM, mapM_) +import Control.Monad.Exception +import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_) +import Control.Monad.Primitive +import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_) +import Control.Monad.Ref +import Data.Align +import Data.Coerce +import Data.Dependent.Map (DMap, DSum (..)) +import qualified Data.Dependent.Map as DMap +import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..)) +import qualified Data.FastMutableIntMap as FastMutableIntMap +import Data.Foldable hiding (concat, elem, sequence_) +import Data.Functor.Constant +import Data.Functor.Misc +import Data.Functor.Product +import Data.GADT.Compare +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.IORef +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Proxy +import Data.These +import Data.Traversable +import GHC.Exts +import GHC.IORef (IORef (..)) +import GHC.Stack +import Reflex.FastWeak +import Reflex.FunctorMaybe +import System.IO.Unsafe +import System.Mem.Weak +import Unsafe.Coerce + +#ifdef DEBUG_CYCLES +import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid (mempty) +import Data.Tree (Forest, Tree (..), drawForest) +#endif + +import Data.FastWeakBag (FastWeakBag) +import qualified Data.FastWeakBag as FastWeakBag +import Data.Reflection +import Data.Some (Some) +import qualified Data.Some as Some +import Data.Type.Coercion +import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children) +import qualified Data.WeakBag as WeakBag +import qualified Reflex.Class +import qualified Reflex.Class as R +import qualified Reflex.Host.Class +import Reflex.NotReady.Class +import Reflex.Patch +import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove + +#ifdef DEBUG_TRACE_EVENTS +import qualified Data.ByteString.Char8 as BS8 +import System.IO (stderr) +#endif + +#ifdef DEBUG_TRACE_EVENTS + +withStackOneLine :: (BS8.ByteString -> a) -> a +withStackOneLine expr = unsafePerformIO $ do + stack <- currentCallStack + return (expr (BS8.pack (unwords (reverse stack)))) + +#endif + +debugPropagate :: Bool + +debugInvalidateHeight :: Bool + +debugInvalidate :: Bool + +#ifdef DEBUG + +#define DEBUG_NODEIDS + +debugPropagate = True + +debugInvalidateHeight = False + +debugInvalidate = True + +class HasNodeId a where + getNodeId :: a -> Int + +instance HasNodeId (Hold x p a) where + getNodeId = holdNodeId + +instance HasNodeId (PushSubscribed x a b) where + getNodeId = pushSubscribedNodeId + +instance HasNodeId (SwitchSubscribed x a) where + getNodeId = switchSubscribedNodeId + +instance HasNodeId (FanSubscribed x a) where + getNodeId = fanSubscribedNodeId + +instance HasNodeId (CoincidenceSubscribed x a) where + getNodeId = coincidenceSubscribedNodeId + +instance HasNodeId (RootSubscribed x a) where + getNodeId = rootSubscribedNodeId + +instance HasNodeId (Pull x a) where + getNodeId = pullNodeId + +{-# INLINE showNodeId #-} +showNodeId :: HasNodeId a => a -> String +showNodeId = ("#"<>) . show . getNodeId + +showSubscriberType :: Subscriber x a -> String +showSubscriberType = \case + SubscriberPush _ _ -> "SubscriberPush" + SubscriberMerge _ _ -> "SubscriberMerge" + SubscriberFan _ -> "SubscriberFan" + SubscriberMergeChange _ -> "SubscriberMergeChange" + SubscriberHold _ -> "SubscriberHold" + SubscriberHoldIdentity _ -> "SubscriberHoldIdentity" + SubscriberSwitch _ -> "SubscriberSwitch" + SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter" + SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner" + SubscriberHandle -> "SubscriberHandle" + +showEventType :: Event x a -> String +showEventType = \case + EventRoot _ _ -> "EventRoot" + EventNever -> "EventNever" + EventPush _ -> "EventPush" + EventMerge _ -> "EventMerge" + EventFan _ _ -> "EventFan" + EventSwitch _ -> "EventSwitch" + EventCoincidence _ -> "EventCoincidence" + EventHold _ -> "EventHold" + EventDyn _ -> "EventDyn" + EventHoldIdentity _ -> "EventHoldIdentity" + EventDynIdentity _ -> "EventDynIdentity" + +#else + +debugPropagate = False + +debugInvalidateHeight = False + +debugInvalidate = False + +-- This must be inline, or error messages will cause memory leaks due to retaining the node in question +{-# INLINE showNodeId #-} +showNodeId :: a -> String +showNodeId _ = "" + +#endif + +#ifdef DEBUG_NODEIDS +{-# NOINLINE nextNodeIdRef #-} +nextNodeIdRef :: IORef Int +nextNodeIdRef = unsafePerformIO $ newIORef 1 + +newNodeId :: IO Int +newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n) + +{-# NOINLINE unsafeNodeId #-} +unsafeNodeId :: a -> Int +unsafeNodeId a = unsafePerformIO $ do + touch a + newNodeId +#endif + +-------------------------------------------------------------------------------- +-- EventSubscription +-------------------------------------------------------------------------------- + +--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back +-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event. +data EventSubscription x = EventSubscription + { _eventSubscription_unsubscribe :: !(IO ()) + , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x) + } + +unsubscribe :: EventSubscription x -> IO () +unsubscribe (EventSubscription u _) = u + +-------------------------------------------------------------------------------- +-- Event +-------------------------------------------------------------------------------- + +newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) } + +{-# INLINE subscribeAndRead #-} +subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a) +subscribeAndRead = unEvent + +{-# RULES +"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e +"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e) +"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e + #-} + +-- | Construct an 'Event' equivalent to that constructed by 'push', but with no +-- caching; if the computation function is very cheap, this is (much) more +-- efficient than 'push' +{-# INLINE [1] pushCheap #-} +pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b +pushCheap !f e = Event $ \sub -> do + (subscription, occ) <- subscribeAndRead e $ sub + { subscriberPropagate = \a -> do + mb <- f a + mapM_ (subscriberPropagate sub) mb + } + occ' <- join <$> mapM f occ + return (subscription, occ') + +-- | A subscriber that never triggers other 'Event's +{-# INLINE terminalSubscriber #-} +terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a +terminalSubscriber p = Subscriber + { subscriberPropagate = p + , subscriberInvalidateHeight = \_ -> return () + , subscriberRecalculateHeight = \_ -> return () + } + +-- | Subscribe to an Event only for the duration of one occurrence +{-# INLINE subscribeAndReadHead #-} +subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a) +subscribeAndReadHead e sub = do + subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized" + (subscription, occ) <- subscribeAndRead e $ sub + { subscriberPropagate = \a -> do + liftIO $ unsubscribe =<< readIORef subscriptionRef + subscriberPropagate sub a + } + liftIO $ case occ of + Nothing -> writeIORef subscriptionRef $! subscription + Just _ -> unsubscribe subscription + return (subscription, occ) + +--TODO: Make this lazy in its input event +headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a) +headE originalE = do + parent <- liftIO $ newIORef $ Just originalE + defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately + let clearParent = liftIO $ writeIORef parent Nothing + (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent + when (isJust occ) clearParent + return $ Event $ \sub -> do + liftIO (readIORef parent) >>= \case + Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing) + Just e -> subscribeAndReadHead e sub + +data CacheSubscribed x a + = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a)) + , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x) + , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a)) + } + +-- | Construct an 'Event' whose value is guaranteed not to be recomputed +-- repeatedly +-- +--TODO: Try a caching strategy where we subscribe directly to the parent when +--there's only one subscriber, and then build our own FastWeakBag only when a second +--subscriber joins +{-# NOINLINE [0] cacheEvent #-} +cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a +cacheEvent e = +#ifdef DEBUG_TRACE_EVENTS + withStackOneLine $ \callSite -> Event $ +#else + Event $ +#endif + let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a)) + !mSubscribedRef = unsafeNewIORef e emptyFastWeak + in \sub -> {-# SCC "cacheEvent" #-} do +#ifdef DEBUG_TRACE_EVENTS + unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite +#endif + subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case + Just subscribedTicket -> return subscribedTicket + Nothing -> do + subscribers <- liftIO FastWeakBag.empty + occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below + (parentSub, occ) <- subscribeAndRead e $ Subscriber + { subscriberPropagate = \a -> do + liftIO $ writeIORef occRef $ Just a + scheduleClear occRef + propagateFast a subscribers + , subscriberInvalidateHeight = \old -> do + FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old + , subscriberRecalculateHeight = \new -> do + FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new + } + when (isJust occ) $ do + liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing + scheduleClear occRef + let !subscribed = CacheSubscribed + { _cacheSubscribed_subscribers = subscribers + , _cacheSubscribed_parent = parentSub + , _cacheSubscribed_occurrence = occRef + } + subscribedTicket <- liftIO $ mkFastWeakTicket subscribed + liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket + return subscribedTicket + liftIO $ do + subscribed <- getFastWeakTicketValue subscribedTicket + ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed + occ <- readIORef $ _cacheSubscribed_occurrence subscribed + let es = EventSubscription + { _eventSubscription_unsubscribe = do + FastWeakBag.remove ticket + isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed + when isEmpty $ do + writeIORef mSubscribedRef emptyFastWeak + unsubscribe $ _cacheSubscribed_parent subscribed + touch ticket + touch subscribedTicket + , _eventSubscription_subscribed = EventSubscribed + { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed + , eventSubscribedRetained = toAny subscribedTicket + } + } + return (es, occ) + +subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x) +subscribe e s = fst <$> subscribeAndRead e s + +{-# INLINE wrap #-} +wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a) +wrap tag getSpecificSubscribed sub = do + (sln, subd, occ) <- getSpecificSubscribed sub + let es = tag subd + return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ) + +eventRoot :: GCompare k => k a -> Root x k -> Event x a +eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r + +eventNever :: Event x a +eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing) + +eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a +eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f + +eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a +eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s + +eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a +eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c + +eventHold :: Hold x p -> Event x p +eventHold !h = Event $ subscribeHoldEvent h + +eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p +eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub + +{-# INLINE subscribeCoincidenceInner #-} +subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x) +subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do + subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe + (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner + innerHeight <- liftIO $ getEventSubscribedHeight innerSubd + let height = max innerHeight outerHeight + defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing + return (innerOcc, height, innerSubd) + +-------------------------------------------------------------------------------- +-- Subscriber +-------------------------------------------------------------------------------- + +data Subscriber x a = Subscriber + { subscriberPropagate :: !(a -> EventM x ()) + , subscriberInvalidateHeight :: !(Height -> IO ()) + , subscriberRecalculateHeight :: !(Height -> IO ()) + } + +--TODO: Move this comment to WeakBag +-- These function are constructor functions that are marked NOINLINE so they are +-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away +-- so any weak references that are attached to the constructors will have their +-- finalizer run. Using the opaque constructor, does not see the +-- constructor application, so it behaves like an IORef and cannot be fused away. +-- +-- The result is also evaluated to WHNF, since forcing a thunk invalidates +-- the weak pointer to it in some cases. + +newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p) +newSubscriberHold h = return $ Subscriber + { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h + , subscriberInvalidateHeight = \_ -> return () + , subscriberRecalculateHeight = \_ -> return () + } + +newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity)) +newSubscriberFan subscribed = return $ Subscriber + { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do + subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed + tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing" + liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a + scheduleClear $ fanSubscribedOccurrence subscribed + let f _ (Pair (Identity v) subsubs) = do + propagate v $ _fanSubscribedChildren_list subsubs + return $ Constant () + _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_ + return () + , subscriberInvalidateHeight = \old -> do + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed + subscribers <- readIORef $ fanSubscribedSubscribers subscribed + forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" + , subscriberRecalculateHeight = \new -> do + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed + subscribers <- readIORef $ fanSubscribedSubscribers subscribed + forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" + } + +newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a) +newSubscriberSwitch subscribed = return $ Subscriber + { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do + tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed + liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a + scheduleClear $ switchSubscribedOccurrence subscribed + propagate a $ switchSubscribedSubscribers subscribed + , subscriberInvalidateHeight = \_ -> do + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed + oldHeight <- readIORef $ switchSubscribedHeight subscribed + when (oldHeight /= invalidHeight) $ do + writeIORef (switchSubscribedHeight subscribed) $! invalidHeight + WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done" + , subscriberRecalculateHeight = \new -> do + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed + updateSwitchHeight new subscribed + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done" + } + +newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b)) +newSubscriberCoincidenceOuter subscribed = return $ Subscriber + { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do + tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed + outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed + tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight + (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed + tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ) + tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight + liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd + scheduleClear $ coincidenceSubscribedInnerParent subscribed + case occ of + Nothing -> do + when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height + writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight + WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight + WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight + Just o -> do -- Since it's already firing, no need to adjust height + liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ + scheduleClear $ coincidenceSubscribedOccurrence subscribed + propagate o $ coincidenceSubscribedSubscribers subscribed + , subscriberInvalidateHeight = \_ -> do + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed + invalidateCoincidenceHeight subscribed + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done" + , subscriberRecalculateHeight = \_ -> do + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed + recalculateCoincidenceHeight subscribed + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done" + } + +newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a) +newSubscriberCoincidenceInner subscribed = return $ Subscriber + { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do + tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed + occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed + case occ of + Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event + Nothing -> do + liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a + scheduleClear $ coincidenceSubscribedOccurrence subscribed + propagate a $ coincidenceSubscribedSubscribers subscribed + , subscriberInvalidateHeight = \_ -> do + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed + invalidateCoincidenceHeight subscribed + when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done" + , subscriberRecalculateHeight = \_ -> do + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed + recalculateCoincidenceHeight subscribed + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done" + } + +invalidateSubscriberHeight :: Height -> Subscriber x a -> IO () +invalidateSubscriberHeight = flip subscriberInvalidateHeight + +recalculateSubscriberHeight :: Height -> Subscriber x a -> IO () +recalculateSubscriberHeight = flip subscriberRecalculateHeight + +-- | Propagate everything at the current height +propagate :: a -> WeakBag (Subscriber x a) -> EventM x () +propagate a subscribers = withIncreasedDepth $ do + -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them + --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work + WeakBag.traverse subscribers $ \s -> subscriberPropagate s a + +-- | Propagate everything at the current height +propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x () +propagateFast a subscribers = withIncreasedDepth $ do + -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them + --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work + FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a + +-------------------------------------------------------------------------------- +-- EventSubscribed +-------------------------------------------------------------------------------- + +toAny :: a -> Any +toAny = unsafeCoerce + +data EventSubscribed x = EventSubscribed + { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height) + , eventSubscribedRetained :: {-# NOUNPACK #-} !Any +#ifdef DEBUG_CYCLES + , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops + , eventSubscribedHasOwnHeightRef :: !Bool + , eventSubscribedWhoCreated :: !(IO [String]) +#endif + } + +eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x +eventSubscribedRoot !r = EventSubscribed + { eventSubscribedHeightRef = zeroRef + , eventSubscribedRetained = toAny r +#ifdef DEBUG_CYCLES + , eventSubscribedGetParents = return [] + , eventSubscribedHasOwnHeightRef = False + , eventSubscribedWhoCreated = return ["root"] +#endif + } + +eventSubscribedNever :: EventSubscribed x +eventSubscribedNever = EventSubscribed + { eventSubscribedHeightRef = zeroRef + , eventSubscribedRetained = toAny () +#ifdef DEBUG_CYCLES + , eventSubscribedGetParents = return [] + , eventSubscribedHasOwnHeightRef = False + , eventSubscribedWhoCreated = return ["never"] +#endif + } + +eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x +eventSubscribedFan !subscribed = EventSubscribed + { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed + , eventSubscribedRetained = toAny subscribed +#ifdef DEBUG_CYCLES + , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed] + , eventSubscribedHasOwnHeightRef = False + , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed +#endif + } + +eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x +eventSubscribedSwitch !subscribed = EventSubscribed + { eventSubscribedHeightRef = switchSubscribedHeight subscribed + , eventSubscribedRetained = toAny subscribed +#ifdef DEBUG_CYCLES + , eventSubscribedGetParents = do + s <- readIORef $ switchSubscribedCurrentParent subscribed + return [Some.This $ _eventSubscription_subscribed s] + , eventSubscribedHasOwnHeightRef = True + , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed +#endif + } + +eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x +eventSubscribedCoincidence !subscribed = EventSubscribed + { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed + , eventSubscribedRetained = toAny subscribed +#ifdef DEBUG_CYCLES + , eventSubscribedGetParents = do + innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed + let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed + innerParents = maybeToList $ fmap Some.This innerSubscription + return $ outerParent : innerParents + , eventSubscribedHasOwnHeightRef = True + , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed +#endif + } + +getEventSubscribedHeight :: EventSubscribed x -> IO Height +getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es + +#ifdef DEBUG_CYCLES +whoCreatedEventSubscribed :: EventSubscribed x -> IO [String] +whoCreatedEventSubscribed = eventSubscribedWhoCreated + +walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)] +walkInvalidHeightParents s0 = do + subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do + h <- liftIO $ readIORef $ eventSubscribedHeightRef s + when (h == invalidHeight) $ do + when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed + modify (Some.This s :) + mapM_ loop =<< liftIO (eventSubscribedGetParents s) + forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight + return subscribers +#endif + +{-# INLINE subscribeHoldEvent #-} +subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p) +subscribeHoldEvent = subscribeAndRead . holdEvent + +-------------------------------------------------------------------------------- +-- Behavior +-------------------------------------------------------------------------------- + +newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a } + +behaviorHold :: Hold x p -> Behavior x (PatchTarget p) +behaviorHold !h = Behavior $ readHoldTracked h + +behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a +behaviorHoldIdentity = behaviorHold + +behaviorConst :: a -> Behavior x a +behaviorConst !a = Behavior $ return a + +behaviorPull :: Pull x a -> Behavior x a +behaviorPull !p = Behavior $ do + val <- liftIO $ readIORef $ pullValue p + case val of + Just subscribed -> do + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :)) + askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:)) + liftIO $ touch $ pullSubscribedOwnInvalidator subscribed + return $ pullSubscribedValue subscribed + Nothing -> do + i <- liftIO $ newInvalidatorPull p + wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull" + parentsRef <- liftIO $ newIORef [] + holdInits <- askBehaviorHoldInits + a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits) + invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator + parents <- liftIO $ readIORef parentsRef + let subscribed = PullSubscribed + { pullSubscribedValue = a + , pullSubscribedInvalidators = invsRef + , pullSubscribedOwnInvalidator = i + , pullSubscribedParents = parents + } + liftIO $ writeIORef (pullValue p) $ Just subscribed + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :)) + return a + +behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p) +behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d + +{-# INLINE readHoldTracked #-} +readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p) +readHoldTracked h = do + result <- liftIO $ readIORef $ holdValue h + askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:)) + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :)) + liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected + return result + +{-# INLINABLE readBehaviorUntracked #-} +readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a +readBehaviorUntracked b = do + holdInits <- getDeferralQueue + liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases + +-------------------------------------------------------------------------------- +-- Dynamic +-------------------------------------------------------------------------------- + +data Dynamic x p = Dynamic + { dynamicCurrent :: !(Behavior x (PatchTarget p)) + , dynamicUpdated :: !(Event x p) + } + +dynamicHold :: Hold x p -> Dynamic x p +dynamicHold !h = Dynamic + { dynamicCurrent = behaviorHold h + , dynamicUpdated = eventHold h + } + +dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a) +dynamicHoldIdentity = dynamicHold + +dynamicConst :: PatchTarget p -> Dynamic x p +dynamicConst !a = Dynamic + { dynamicCurrent = behaviorConst a + , dynamicUpdated = eventNever + } + +dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p +dynamicDyn !d = Dynamic + { dynamicCurrent = behaviorDyn d + , dynamicUpdated = eventDyn d + } + +dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a) +dynamicDynIdentity = dynamicDyn + +-------------------------------------------------------------------------------- +-- Combinators +-------------------------------------------------------------------------------- + +--TODO: Figure out why certain things are not 'representational', then make them +--representational so we can use coerce + +--type role Hold representational +data Hold x p + = Hold { holdValue :: !(IORef (PatchTarget p)) + , holdInvalidators :: !(IORef [Weak (Invalidator x)]) + , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events + , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef +#ifdef DEBUG_NODEIDS + , holdNodeId :: Int +#endif + } + +-- | A statically allocated 'SpiderTimeline' +data Global + +{-# NOINLINE globalSpiderTimelineEnv #-} +globalSpiderTimelineEnv :: SpiderTimelineEnv Global +globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv + +-- | Stores all global data relevant to a particular Spider timeline; only one +-- value should exist for each type @x@ +data SpiderTimelineEnv x = SpiderTimelineEnv + { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ()) + , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x) +#ifdef DEBUG + , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int) +#endif + } +type role SpiderTimelineEnv nominal + +instance Eq (SpiderTimelineEnv x) where + _ == _ = True -- Since only one exists of each type + +instance GEq SpiderTimelineEnv where + a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b + then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments + else Nothing + +data EventEnv x + = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe + , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe + , eventEnvDynInits :: !(IORef [SomeDynInit x]) + , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x]) + , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe + , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe + , eventEnvIntClears :: !(IORef [SomeIntClear]) + , eventEnvRootClears :: !(IORef [SomeRootClear]) + , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe + , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe + , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()])) + } + +{-# INLINE runEventM #-} +runEventM :: EventM x a -> IO a +runEventM = unEventM + +asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a +asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x) + +class MonadIO m => Defer a m where + getDeferralQueue :: m (IORef [a]) + +{-# INLINE defer #-} +defer :: Defer a m => a -> m () +defer a = do + q <- getDeferralQueue + liftIO $ modifyIORef' q (a:) + +instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvAssignments + +instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvHoldInits + +instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvDynInits + +instance Defer (SomeHoldInit x) (BehaviorM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = BehaviorM $ asks snd + +instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvMergeUpdates + +instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvMergeInits + +class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where + getCurrentHeight :: m Height + scheduleMerge :: Height -> EventM x () -> m () + +instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where + {-# INLINE getCurrentHeight #-} + getCurrentHeight = do + heightRef <- asksEventEnv eventEnvCurrentHeight + liftIO $ readIORef heightRef + {-# INLINE scheduleMerge #-} + scheduleMerge height subscribed = do + delayedRef <- asksEventEnv eventEnvDelayedMerges + liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed] + +class HasSpiderTimeline x where + -- | Retrieve the current SpiderTimelineEnv + spiderTimeline :: SpiderTimelineEnv x + +instance HasSpiderTimeline Global where + spiderTimeline = globalSpiderTimelineEnv + +putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x () +putCurrentHeight h = do + heightRef <- asksEventEnv eventEnvCurrentHeight + liftIO $ writeIORef heightRef $! h + +instance HasSpiderTimeline x => Defer SomeClear (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvClears + +{-# INLINE scheduleClear #-} +scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m () +scheduleClear r = defer $ SomeClear r + +instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvIntClears + +{-# INLINE scheduleIntClear #-} +scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m () +scheduleIntClear r = defer $ SomeIntClear r + +instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvRootClears + +{-# INLINE scheduleRootClear #-} +scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m () +scheduleRootClear r = defer $ SomeRootClear r + +instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where + {-# INLINE getDeferralQueue #-} + getDeferralQueue = asksEventEnv eventEnvResetCoincidences + +-- Note: hold cannot examine its event until after the phase is over +{-# INLINE [1] hold #-} +hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p) +hold v0 e = do + valRef <- liftIO $ newIORef v0 + invsRef <- liftIO $ newIORef [] + parentRef <- liftIO $ newIORef Nothing +#ifdef DEBUG_NODEIDS + nodeId <- liftIO newNodeId +#endif + let h = Hold + { holdValue = valRef + , holdInvalidators = invsRef + , holdEvent = e + , holdParent = parentRef +#ifdef DEBUG_NODEIDS + , holdNodeId = nodeId +#endif + } + defer $ SomeHoldInit h + return h + +{-# INLINE getHoldEventSubscription #-} +getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x) +getHoldEventSubscription h = do + ep <- liftIO $ readIORef $ holdParent h + case ep of + Just subd -> return subd + Nothing -> do + let e = holdEvent h + subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized" + (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h) + liftIO $ writeIORef subscriptionRef $! subscription + case occ of + Nothing -> return () + Just o -> do + old <- liftIO $ readIORef $ holdValue h + case apply o old of + Nothing -> return () + Just new -> do + -- Need to evaluate these so that we don't retain the Hold itself + v <- liftIO $ evaluate $ holdValue h + i <- liftIO $ evaluate $ holdInvalidators h + defer $ SomeAssignment v i new + liftIO $ writeIORef (holdParent h) $ Just subscription + return subscription + +type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x]) + +--type role BehaviorM representational +-- BehaviorM can sample behaviors +newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix) + +instance Monad (BehaviorM x) where + {-# INLINE (>>=) #-} + BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f + {-# INLINE (>>) #-} + BehaviorM x >> BehaviorM y = BehaviorM $ x >> y + {-# INLINE return #-} + return x = BehaviorM $ return x + {-# INLINE fail #-} + fail s = BehaviorM $ fail s + +data BehaviorSubscribed x a + = forall p. BehaviorSubscribedHold (Hold x p) + | BehaviorSubscribedPull (PullSubscribed x a) + +data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a) + +--type role PullSubscribed representational +data PullSubscribed x a + = PullSubscribed { pullSubscribedValue :: !a + , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)]) + , pullSubscribedOwnInvalidator :: !(Invalidator x) + , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated + } + +--type role Pull representational +data Pull x a + = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a))) + , pullCompute :: !(BehaviorM x a) +#ifdef DEBUG_NODEIDS + , pullNodeId :: Int +#endif + } + +data Invalidator x + = forall a. InvalidatorPull (Pull x a) + | forall a. InvalidatorSwitch (SwitchSubscribed x a) + +data RootSubscribed x a = forall k. GCompare k => RootSubscribed + { rootSubscribedKey :: !(k a) + , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root + , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a)) + , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence + , rootSubscribedUninit :: IO () + , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed x a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it? +#ifdef DEBUG_NODEIDS + , rootSubscribedNodeId :: Int +#endif + } + +data Root x (k :: * -> *) + = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event + , rootSubscribed :: !(IORef (DMap k (RootSubscribed x))) + , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ())) + } + +data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p) + +data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p) + +data SomeMergeUpdate x = SomeMergeUpdate + { _someMergeUpdate_update :: !(EventM x [EventSubscription x]) + , _someMergeUpdate_invalidateHeight :: !(IO ()) + , _someMergeUpdate_recalculateHeight :: !(IO ()) + } + +newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () } + +-- EventM can do everything BehaviorM can, plus create holds +newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over + +newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x } + +data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove + { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x) + , _mergeSubscribedParentWithMove_key :: !(IORef (k a)) + } + +data HeightBag = HeightBag + { _heightBag_size :: {-# UNPACK #-} !Int + , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket + } + deriving (Show, Read, Eq, Ord) + +heightBagEmpty :: HeightBag +heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty + +heightBagSize :: HeightBag -> Int +heightBagSize = _heightBag_size + +heightBagFromList :: [Height] -> HeightBag +heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights + +heightBagAdd :: Height -> HeightBag -> HeightBag +heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c + +heightBagRemove :: Height -> HeightBag -> HeightBag +heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of + Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b + Just old -> HeightBag (pred s) $ case old of + 0 -> IntMap.delete h c + _ -> IntMap.insert h (pred old) c + +heightBagMax :: HeightBag -> Height +heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of + Just ((h, _), _) -> Height h + Nothing -> zeroHeight + +heightBagVerify :: HeightBag -> HeightBag +#ifdef DEBUG +heightBagVerify b@(HeightBag s c) = if + | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c)) + -> error $ "heightBagVerify: size doesn't match: " <> show b + | unHeight invalidHeight `IntMap.member` c + -> error $ "heightBagVerify: contains invalid height: " <> show b + | otherwise -> b +#else +heightBagVerify = id +#endif + +data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren + { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a)) + , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k) + , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k))) + } + +data FanSubscribed (x :: *) k + = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k))) + , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity))) + , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty + , fanSubscribedParent :: !(EventSubscription x) +#ifdef DEBUG_NODEIDS + , fanSubscribedNodeId :: Int +#endif + } + +data Fan x k + = Fan { fanParent :: !(Event x (DMap k Identity)) + , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k))) + } + +data SwitchSubscribed x a + = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a))) + , switchSubscribedOccurrence :: !(IORef (Maybe a)) + , switchSubscribedHeight :: !(IORef Height) + , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a)) + , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x) + , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x))) + , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x]) + , switchSubscribedParent :: !(Behavior x (Event x a)) + , switchSubscribedCurrentParent :: !(IORef (EventSubscription x)) + , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a))) +#ifdef DEBUG_NODEIDS + , switchSubscribedNodeId :: Int +#endif + } + +data Switch x a + = Switch { switchParent :: !(Behavior x (Event x a)) + , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a))) + } + +#ifdef USE_TEMPLATE_HASKELL +{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-} +#endif +data CoincidenceSubscribed x a + = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a))) + , coincidenceSubscribedOccurrence :: !(IORef (Maybe a)) + , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a)) + , coincidenceSubscribedHeight :: !(IORef Height) + , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a)) + , coincidenceSubscribedOuterParent :: !(EventSubscription x) + , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x))) + , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a))) +#ifdef DEBUG_NODEIDS + , coincidenceSubscribedNodeId :: Int +#endif + } + +data Coincidence x a + = Coincidence { coincidenceParent :: !(Event x (Event x a)) + , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a))) + } + +{-# NOINLINE newInvalidatorSwitch #-} +newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x) +newInvalidatorSwitch subd = return $! InvalidatorSwitch subd + +{-# NOINLINE newInvalidatorPull #-} +newInvalidatorPull :: Pull x a -> IO (Invalidator x) +newInvalidatorPull p = return $! InvalidatorPull p + +instance HasSpiderTimeline x => FunctorMaybe (Event x) where + fmapMaybe f = push $ return . f + +instance HasSpiderTimeline x => Align (Event x) where + nil = eventNever + align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] + +data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) + | BuildDyn !(EventM x (PatchTarget p), Event x p) + | HoldDyn !(Hold x p) + +newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) } + +newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b) +newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d) + +--TODO: Avoid the duplication between this and R.zipDynWith +zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c) +zipDynWith f da db = + let eab = align (dynamicUpdated da) (dynamicUpdated db) + ec = flip push eab $ \o -> do + (a, b) <- case o of + This (Identity a) -> do + b <- readBehaviorUntracked $ dynamicCurrent db + return (a, b) + That (Identity b) -> do + a <- readBehaviorUntracked $ dynamicCurrent da + return (a, b) + These (Identity a) (Identity b) -> return (a, b) + return $ Just $ Identity $ f a b + in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec + +buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p) +buildDynamic readV0 v' = do + result <- liftIO $ newIORef $ BuildDyn (readV0, v') + let !d = Dyn result + defer $ SomeDynInit d + return d + +unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p +unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x + where x = (readV0, v') + +-- ResultM can read behaviors and events +type ResultM = EventM + +{-# NOINLINE unsafeNewIORef #-} +unsafeNewIORef :: a -> b -> IORef b +unsafeNewIORef a b = unsafePerformIO $ do + touch a + newIORef b + +instance HasSpiderTimeline x => Functor (Event x) where + fmap f = push $ return . Just . f + +instance Functor (Behavior x) where + fmap f = pull . fmap f . readBehaviorTracked + +{-# INLINE push #-} +push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b +push f e = cacheEvent (pushCheap f e) + +{-# INLINABLE pull #-} +pull :: BehaviorM x a -> Behavior x a +pull a = behaviorPull $ Pull + { pullCompute = a + , pullValue = unsafeNewIORef a Nothing +#ifdef DEBUG_NODEIDS + , pullNodeId = unsafeNodeId a +#endif + } + +{-# INLINABLE switch #-} +switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a +switch a = eventSwitch $ Switch + { switchParent = a + , switchSubscribed = unsafeNewIORef a Nothing + } + +coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a +coincidence a = eventCoincidence $ Coincidence + { coincidenceParent = a + , coincidenceSubscribed = unsafeNewIORef a Nothing + } + +-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors +run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b +run roots after = do + tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events" + let t = spiderTimeline :: SpiderTimelineEnv x + result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do + rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do + occBefore <- liftIO $ do + occBefore <- readIORef occRef + writeIORef occRef $! DMap.insert k a occBefore + return occBefore + if DMap.null occBefore + then do scheduleRootClear occRef + return $ Just r + else return Nothing + forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do + propagate a subscribersRef + delayedRef <- asksEventEnv eventEnvDelayedMerges + let go = do + delayed <- liftIO $ readIORef delayedRef + case IntMap.minViewWithKey delayed of + Nothing -> return () + Just ((currentHeight, cur), future) -> do + tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight + putCurrentHeight $ Height currentHeight + liftIO $ writeIORef delayedRef $! future + sequence_ cur + go + go + putCurrentHeight maxBound + after + tracePropagate (Proxy :: Proxy x) "Done running an event frame" + return result + +scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x () +scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do + height <- liftIO $ readIORef heightRef + currentHeight <- getCurrentHeight + case height `compare` currentHeight of + LT -> error "Somehow a merge's height has been decreased after it was scheduled" + GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?) + EQ -> a + +data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a)) + +data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a)) + +data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity)) + +data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a + +debugFinalize :: Bool +debugFinalize = False + +mkWeakPtrWithDebug :: a -> String -> IO (Weak a) +mkWeakPtrWithDebug x debugNote = do + x' <- evaluate x + mkWeakPtr x' $ + if debugFinalize + then Just $ putStrLn $ "finalizing: " ++ debugNote + else Nothing + +type WeakList a = [Weak a] + +{-# INLINE withIncreasedDepth #-} +#ifdef DEBUG +withIncreasedDepth :: CanTrace x m => m a -> m a +withIncreasedDepth a = do + spiderTimeline <- askSpiderTimelineEnv + liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ + result <- a + liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred + return result +#else +withIncreasedDepth :: m a -> m a +withIncreasedDepth = id +#endif + +type CanTrace x m = (HasSpiderTimeline x, MonadIO m) + +{-# INLINE tracePropagate #-} +tracePropagate :: (CanTrace x m) => proxy x -> String -> m () +tracePropagate p = traceWhen p debugPropagate + +{-# INLINE traceInvalidate #-} +traceInvalidate :: String -> IO () +traceInvalidate = when debugInvalidate . liftIO . putStrLn + +{-# INLINE traceWhen #-} +traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m () +traceWhen p b message = traceMWhen p b $ return message + +{-# INLINE traceMWhen #-} +traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m () +traceMWhen _ b getMessage = when b $ do + message <- getMessage +#ifdef DEBUG + spiderTimeline <- askSpiderTimelineEnv + d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline +#else + let d = 0 +#endif + liftIO $ putStrLn $ replicate d ' ' <> message + +whoCreatedIORef :: IORef a -> IO [String] +whoCreatedIORef (IORef a) = whoCreated $! a + +#ifdef DEBUG_CYCLES +groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])] +groupByHead = \case + [] -> [] + (x :| xs) : t -> case groupByHead t of + [] -> [(x, xs :| [])] + l@((y, yss) : t') + | x == y -> (x, xs `NonEmpty.cons` yss) : t' + | otherwise -> (x, xs :| []) : l + +listsToForest :: Eq a => [[a]] -> Forest a +listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l +#endif + +{-# INLINE propagateSubscriberHold #-} +propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x () +propagateSubscriberHold h a = do + {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do + invalidators <- liftIO $ readIORef $ holdInvalidators h + return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators) + v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h + case {-# SCC "apply" #-} apply a v of + Nothing -> return () + Just v' -> do + {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h + vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h + iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h + defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v' + +data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset + +runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a +runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits) + +askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x))) +askInvalidator = do + (!m, _) <- BehaviorM ask + case m of + Nothing -> return Nothing + Just (!wi, _) -> return $ Just wi + +askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x])) +askParentsRef = do + (!m, _) <- BehaviorM ask + case m of + Nothing -> return Nothing + Just (_, !p) -> return $ Just p + +askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x]) +askBehaviorHoldInits = do + (_, !his) <- BehaviorM ask + return his + +{-# INLINE getDynHold #-} +getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p) +getDynHold d = do + mh <- liftIO $ readIORef $ unDyn d + case mh of + HoldDyn h -> return h + UnsafeDyn (readV0, v') -> do + holdInits <- getDeferralQueue + v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits + hold' v0 v' + BuildDyn (readV0, v') -> do + v0 <- liftIO $ runEventM readV0 + hold' v0 v' + where + hold' v0 v' = do + h <- hold v0 v' + liftIO $ writeIORef (unDyn d) $ HoldDyn h + return h + + +-- Always refers to 0 +{-# NOINLINE zeroRef #-} +zeroRef :: IORef Height +zeroRef = unsafePerformIO $ newIORef zeroHeight + +getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a) +getRootSubscribed k r sub = do + mSubscribed <- readIORef $ rootSubscribed r + let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r + case DMap.lookup k mSubscribed of + Just subscribed -> {-# SCC "hitRoot" #-} do + sln <- subscribeRootSubscribed subscribed sub + occ <- getOcc + return (sln, subscribed, occ) + Nothing -> {-# SCC "missRoot" #-} do + weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized" + let !cached = rootSubscribed r + uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized" + (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed + when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit" + uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k) + writeIORef uninitRef $! uninit + let !subscribed = RootSubscribed + { rootSubscribedKey = k + , rootSubscribedCachedSubscribed = cached + , rootSubscribedOccurrence = getOcc + , rootSubscribedSubscribers = subs + , rootSubscribedUninit = uninit + , rootSubscribedWeakSelf = weakSelf +#ifdef DEBUG_NODEIDS + , rootSubscribedNodeId = unsafeNodeId (k, r, subs) +#endif + } + -- If we die at the same moment that all our children die, they will + -- try to clean us up but will fail because their Weak reference to us + -- will also be dead. So, if we are dying, check if there are any + -- children; since children don't bother cleaning themselves up if + -- their parents are already dead, I don't think there's a race + -- condition here. However, if there are any children, then we can + -- infer that we need to clean ourselves up, so we do. + finalCleanup = do + cs <- readIORef $ _weakBag_children subs + when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed) + writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup) + modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it + occ <- getOcc + return (sln, subscribed, occ) + +#ifdef USE_TEMPLATE_HASKELL +{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-} +#endif +cleanupRootSubscribed :: RootSubscribed x a -> IO () +cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do + rootSubscribedUninit self + modifyIORef' cached $ DMap.delete k + +{-# INLINE subscribeRootSubscribed #-} +subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket +subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed + +newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a } + +data FanInt x a = FanInt + { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty + , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty + , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a)) + } + +newFanInt :: IO (FanInt x a) +newFanInt = do + subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty + subscriptionRef <- newIORef $ error "fanInt: no subscription" + occRef <- newIORef $ error "fanInt: no occurrence" + return $ FanInt + { _fanInt_subscribers = subscribers + , _fanInt_subscriptionRef = subscriptionRef + , _fanInt_occRef = occRef + } + +{-# NOINLINE unsafeNewFanInt #-} +unsafeNewFanInt :: b -> FanInt x a +unsafeNewFanInt b = unsafePerformIO $ do + touch b + newFanInt + +fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a +fanInt p = + let self = unsafeNewFanInt p + in EventSelectorInt $ \k -> Event $ \sub -> do + isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self) + when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input + (subscription, parentOcc) <- subscribeAndRead p $ Subscriber + { subscriberPropagate = \m -> do + liftIO $ writeIORef (_fanInt_occRef self) m + scheduleIntClear $ _fanInt_occRef self + FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse? + FastWeakBag.traverse b $ \s -> do + subscriberPropagate s v + , subscriberInvalidateHeight = \old -> do + FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do + FastWeakBag.traverse b $ \s -> do + subscriberInvalidateHeight s old + , subscriberRecalculateHeight = \new -> do + FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do + FastWeakBag.traverse b $ \s -> do + subscriberRecalculateHeight s new + } + liftIO $ do + writeIORef (_fanInt_subscriptionRef self) subscription + writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc + scheduleIntClear $ _fanInt_occRef self + liftIO $ do + b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case + Nothing -> do + b <- FastWeakBag.empty + FastMutableIntMap.insert (_fanInt_subscribers self) k b + return b + Just b -> return b + t <- liftIO $ FastWeakBag.insert sub b + currentOcc <- readIORef (_fanInt_occRef self) + (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self) + return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc) + +{-# INLINABLE getFanSubscribed #-} +getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a) +getFanSubscribed k f sub = do + mSubscribed <- liftIO $ readIORef $ fanSubscribed f + case mSubscribed of + Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do + sln <- subscribeFanSubscribed k subscribed sub + occ <- readIORef $ fanSubscribedOccurrence subscribed + return (sln, subscribed, coerce $ DMap.lookup k =<< occ) + Nothing -> {-# SCC "missFan" #-} do + subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized" + subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef + s <- liftIO $ newSubscriberFan subscribedUnsafe + (subscription, parentOcc) <- subscribeAndRead (fanParent f) s + weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized" + (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed + subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized" + occRef <- liftIO $ newIORef parentOcc + when (isJust parentOcc) $ scheduleClear occRef + let subscribed = FanSubscribed + { fanSubscribedCachedSubscribed = fanSubscribed f + , fanSubscribedOccurrence = occRef + , fanSubscribedParent = subscription + , fanSubscribedSubscribers = subscribersRef +#ifdef DEBUG_NODEIDS + , fanSubscribedNodeId = unsafeNodeId f +#endif + } + let !self = (k, subscribed) + liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf + liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed" + liftIO $ writeIORef subscribedRef $! subscribed + liftIO $ writeIORef (fanSubscribed f) $ Just subscribed + return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc) + +cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO () +cleanupFanSubscribed (k, subscribed) = do + subscribers <- readIORef $ fanSubscribedSubscribers subscribed + let reducedSubscribers = DMap.delete k subscribers + if DMap.null reducedSubscribers + then do + unsubscribe $ fanSubscribedParent subscribed + -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers + writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing + else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers + +{-# INLINE subscribeFanSubscribed #-} +subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket +subscribeFanSubscribed k subscribed sub = do + subscribers <- readIORef $ fanSubscribedSubscribers subscribed + case DMap.lookup k subscribers of + Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do + let !self = (k, subscribed) + weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed" + (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed + writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeFanSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers + return sln + Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed + +{-# INLINABLE getSwitchSubscribed #-} +getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a) +getSwitchSubscribed s sub = do + mSubscribed <- liftIO $ readIORef $ switchSubscribed s + case mSubscribed of + Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do + sln <- subscribeSwitchSubscribed subscribed sub + occ <- readIORef $ switchSubscribedOccurrence subscribed + return (sln, subscribed, occ) + Nothing -> {-# SCC "missSwitch" #-} do + subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created" + subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef + i <- liftIO $ newInvalidatorSwitch subscribedUnsafe + mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe + wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch" + wiRef <- liftIO $ newIORef wi + parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior + holdInits <- getDeferralQueue + e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits + (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub + heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd + subscriptionRef <- liftIO $ newIORef subscription + occRef <- liftIO $ newIORef parentOcc + when (isJust parentOcc) $ scheduleClear occRef + weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized" + (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed + let !subscribed = SwitchSubscribed + { switchSubscribedCachedSubscribed = switchSubscribed s + , switchSubscribedOccurrence = occRef + , switchSubscribedHeight = heightRef + , switchSubscribedSubscribers = subs + , switchSubscribedOwnInvalidator = i + , switchSubscribedOwnWeakInvalidator = wiRef + , switchSubscribedBehaviorParents = parentsRef + , switchSubscribedParent = switchParent s + , switchSubscribedCurrentParent = subscriptionRef + , switchSubscribedWeakSelf = weakSelf +#ifdef DEBUG_NODEIDS + , switchSubscribedNodeId = unsafeNodeId s +#endif + } + liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf" + liftIO $ writeIORef subscribedRef $! subscribed + liftIO $ writeIORef (switchSubscribed s) $ Just subscribed + return (slnForSub, subscribed, parentOcc) + +cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO () +cleanupSwitchSubscribed subscribed = do + unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed) + finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead + writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing + +{-# INLINE subscribeSwitchSubscribed #-} +subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket +subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed + +{-# INLINABLE getCoincidenceSubscribed #-} +getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a) +getCoincidenceSubscribed c sub = do + mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c + case mSubscribed of + Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do + sln <- subscribeCoincidenceSubscribed subscribed sub + occ <- readIORef $ coincidenceSubscribedOccurrence subscribed + return (sln, subscribed, occ) + Nothing -> {-# SCC "missCoincidence" #-} do + subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created" + subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef + subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe + (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter + outerHeight <- liftIO $ getEventSubscribedHeight outerSubd + (occ, height, mInnerSubd) <- case outerOcc of + Nothing -> return (Nothing, outerHeight, Nothing) + Just o -> do + (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe + return (occ, height, Just innerSubd) + occRef <- liftIO $ newIORef occ + when (isJust occ) $ scheduleClear occRef + heightRef <- liftIO $ newIORef height + innerSubdRef <- liftIO $ newIORef mInnerSubd + scheduleClear innerSubdRef + weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented" + (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed + let subscribed = CoincidenceSubscribed + { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c + , coincidenceSubscribedOccurrence = occRef + , coincidenceSubscribedHeight = heightRef + , coincidenceSubscribedSubscribers = subs + , coincidenceSubscribedOuter = subOuter + , coincidenceSubscribedOuterParent = outerSubscription + , coincidenceSubscribedInnerParent = innerSubdRef + , coincidenceSubscribedWeakSelf = weakSelf +#ifdef DEBUG_NODEIDS + , coincidenceSubscribedNodeId = unsafeNodeId c +#endif + } + liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed" + liftIO $ writeIORef subscribedRef $! subscribed + liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed + return (slnForSub, subscribed, occ) + +cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO () +cleanupCoincidenceSubscribed subscribed = do + unsubscribe $ coincidenceSubscribedOuterParent subscribed + writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing + +{-# INLINE subscribeCoincidenceSubscribed #-} +subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket +subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed + +{-# INLINE merge #-} +merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) +merge d = cacheEvent (mergeCheap d) + +{-# INLINE mergeWithMove #-} +mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) +mergeWithMove d = cacheEvent (mergeCheapWithMove d) + +{-# INLINE [1] mergeCheap #-} +mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) +mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy + where + updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x) + updateMe subscriber heightBagRef oldParents (PatchDMap p) = do + let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do + (mOldSubd, newPs) <- case me of + Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps + Just e -> do + let s = subscriber $ return k + subscription@(EventSubscription _ subd) <- subscribe e s + newParentHeight <- liftIO $ getEventSubscribedHeight subd + let newParent = MergeSubscribedParent subscription + liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight + return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps + forM_ mOldSubd $ \oldSubd -> do + oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd + liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight + return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs) + foldM f ([], oldParents) $ DMap.toList p + getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x) + getInitialSubscribers initialParents subscriber = do + subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do + let s = subscriber $ return k + (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s + height <- liftIO $ getEventSubscribedHeight parentSubd + return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription) + return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers + , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here + , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers + ) + destroy :: MergeDestroyFunc k (MergeSubscribedParent x) + destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub + +{-# INLINE [1] mergeCheapWithMove #-} +mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) +mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy + where + updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k) + updateMe subscriber heightBagRef oldParents p = do + -- Prepare new parents for insertion + let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a) + subscribeParent k e = do + keyRef <- liftIO $ newIORef k + let s = subscriber $ liftIO $ readIORef keyRef + subscription@(EventSubscription _ subd) <- subscribe e s + liftIO $ do + newParentHeight <- getEventSubscribedHeight subd + modifyIORef' heightBagRef $ heightBagAdd newParentHeight + return $ MergeSubscribedParentWithMove subscription keyRef + p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p + -- Collect old parents for deletion and update the keys of moved parents + let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a + moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of + Nothing -> do + oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent + liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight + return $ Just $ _mergeSubscribedParentWithMove_subscription parent + Just toKey -> do + liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey + return Nothing + toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents + return (toDelete, applyAlways p' oldParents) + getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k) + getInitialSubscribers initialParents subscriber = do + subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do + keyRef <- liftIO $ newIORef k + let s = subscriber $ liftIO $ readIORef keyRef + (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s + height <- liftIO $ getEventSubscribedHeight parentSubd + return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) + return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers + , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here + , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers + ) + destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k) + destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub + +type MergeUpdateFunc k x p s + = (forall a. EventM x (k a) -> Subscriber x a) + -> IORef HeightBag + -> DMap k s + -> p + -> EventM x ([EventSubscription x], DMap k s) + +type MergeInitFunc k x s + = DMap k (Event x) + -> (forall a. EventM x (k a) -> Subscriber x a) + -> EventM x (DMap k Identity, [Height], DMap k s) + +type MergeDestroyFunc k s + = DMap k s + -> IO () + +data Merge x k s = Merge + { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s)) + , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag) + , _merge_heightRef :: {-# UNPACK #-} !(IORef Height) + , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity)) + , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity)) + } + +invalidateMergeHeight :: Merge x k s -> IO () +invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m) + +invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO () +invalidateMergeHeight' heightRef sub = do + oldHeight <- readIORef heightRef + when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents + writeIORef heightRef $! invalidHeight + subscriberInvalidateHeight sub oldHeight + + +revalidateMergeHeight :: Merge x k s -> IO () +revalidateMergeHeight m = do + currentHeight <- readIORef $ _merge_heightRef m + when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check + heights <- readIORef $ _merge_heightBagRef m + parents <- readIORef $ _merge_parentsRef m + -- When the number of heights in the bag reaches the number of parents, we should have a valid height + case heightBagSize heights `compare` DMap.size parents of + LT -> return () + EQ -> do + let height = succHeight $ heightBagMax heights + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height + writeIORef (_merge_heightRef m) $! height + subscriberRecalculateHeight (_merge_sub m) height + GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge" + +scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x () +scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do + vals <- liftIO $ readIORef $ _merge_accumRef m + liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers + --TODO: Assert that m is not empty + subscriberPropagate (_merge_sub m) vals + +mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a +mergeSubscriber m getKey = Subscriber + { subscriberPropagate = \a -> do + oldM <- liftIO $ readIORef $ _merge_accumRef m + k <- getKey + let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM + tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM) + liftIO $ writeIORef (_merge_accumRef m) $! newM + when (DMap.null oldM) $ do -- Only schedule the firing once + height <- liftIO $ readIORef $ _merge_heightRef m + --TODO: assertions about height + currentHeight <- getCurrentHeight + when (height <= currentHeight) $ do + if height /= invalidHeight + then do + myStack <- liftIO $ whoCreatedIORef undefined --TODO + error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack) + else liftIO $ do +#ifdef DEBUG_CYCLES + nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed + stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es + let cycleInfo = ":\n" <> drawForest (listsToForest stacks) +#else + let cycleInfo = "" +#endif + error $ "Causality loop found" <> cycleInfo + scheduleMergeSelf m height + , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating + modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old + invalidateMergeHeight m + , subscriberRecalculateHeight = \new -> do + modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new + revalidateMergeHeight m + } + +--TODO: Be able to run as much of this as possible promptly +updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x +updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m) + where updateMe = do + oldParents <- liftIO $ readIORef $ _merge_parentsRef m + (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p + liftIO $ writeIORef (_merge_parentsRef m) $! newParents + return subscriptionsToKill + +{-# INLINE mergeCheap' #-} +mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity) +mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do + initialParents <- readBehaviorUntracked $ dynamicCurrent d + accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" + heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized" + heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized" + parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized" + let m = Merge + { _merge_parentsRef = parentsRef + , _merge_heightBagRef = heightBagRef + , _merge_heightRef = heightRef + , _merge_sub = sub + , _merge_accumRef = accumRef + } + (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m + let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights + myHeight = if invalidHeight `elem` heights + then invalidHeight + else succHeight $ heightBagMax myHeightBag + currentHeight <- getCurrentHeight + let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now + then (if DMap.null dm then Nothing else Just dm, DMap.empty) + else (Nothing, dm) + unless (DMap.null accum) $ do + scheduleMergeSelf m myHeight + liftIO $ writeIORef accumRef $! accum + liftIO $ writeIORef heightRef $! myHeight + liftIO $ writeIORef heightBagRef $! myHeightBag + changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized" + liftIO $ writeIORef parentsRef $! initialParentState + defer $ SomeMergeInit $ do + let s = Subscriber + { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do + tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change" + defer $ updateMerge m updateFunc a + , subscriberInvalidateHeight = \_ -> return () + , subscriberRecalculateHeight = \_ -> return () + } + (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s + forM_ change $ \c -> defer $ updateMerge m updateFunc c + -- We explicitly hold on to the unsubscribe function from subscribing to the update event. + -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain + -- its subscription. + liftIO $ writeIORef changeSubdRef (s, changeSubscription) + let unsubscribeAll = destroy =<< readIORef parentsRef + return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef) + , occ + ) + +mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a) +mergeInt = cacheEvent . mergeIntCheap + +{-# INLINABLE mergeIntCheap #-} +mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a) +mergeIntCheap d = Event $ \sub -> do + initialParents <- readBehaviorUntracked $ dynamicCurrent d + accum <- liftIO $ FastMutableIntMap.newEmpty + heightRef <- liftIO $ newIORef zeroHeight + heightBagRef <- liftIO $ newIORef heightBagEmpty + parents <- liftIO $ FastMutableIntMap.newEmpty + let scheduleSelf = do + height <- liftIO $ readIORef $ heightRef + scheduleMerge' height heightRef $ do + vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum + subscriberPropagate sub vals + invalidateMyHeight = do + invalidateMergeHeight' heightRef sub + recalculateMyHeight = do + currentHeight <- readIORef heightRef + when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always? + heights <- readIORef heightBagRef + numParents <- FastMutableIntMap.size parents + case heightBagSize heights `compare` numParents of + LT -> return () + EQ -> do + let height = succHeight $ heightBagMax heights + when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height + writeIORef heightRef $! height + subscriberRecalculateHeight sub height + GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge" + mySubscriber k = Subscriber + { subscriberPropagate = \a -> do + wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum + liftIO $ FastMutableIntMap.insert accum k a + when wasEmpty scheduleSelf + , subscriberInvalidateHeight = \old -> do + modifyIORef' heightBagRef $ heightBagRemove old + invalidateMyHeight + , subscriberRecalculateHeight = \new -> do + modifyIORef' heightBagRef $ heightBagAdd new + recalculateMyHeight + } + forM_ (IntMap.toList initialParents) $ \(k, p) -> do + (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k + liftIO $ do + forM_ parentOcc $ FastMutableIntMap.insert accum k + FastMutableIntMap.insert parents k subscription + height <- getEventSubscribedHeight parentSubd + if height == invalidHeight + then writeIORef heightRef invalidHeight + else do + modifyIORef' heightBagRef $ heightBagAdd height + modifyIORef' heightRef $ \oldHeight -> + if oldHeight == invalidHeight + then invalidHeight + else max (succHeight height) oldHeight + myHeight <- liftIO $ readIORef heightRef + currentHeight <- getCurrentHeight + isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum + occ <- if currentHeight >= myHeight -- If we should have fired by now + then if isEmpty + then return Nothing + else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum + else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet + return Nothing + changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized" + defer $ SomeMergeInit $ do + let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight + where + u = do + let f k newParent = do + subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k + newParentHeight <- liftIO $ getEventSubscribedHeight subd + liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight + return subscription + newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a + oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions + liftIO $ for_ oldParents $ \oldParent -> do + oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent + modifyIORef' heightBagRef $ heightBagRemove oldParentHeight + return $ IntMap.elems oldParents + let s = Subscriber + { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do + tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change" + defer $ updateMe a + , subscriberInvalidateHeight = \_ -> return () + , subscriberRecalculateHeight = \_ -> return () + } + (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s + forM_ change $ \c -> defer $ updateMe c + -- We explicitly hold on to the unsubscribe function from subscribing to the update event. + -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain + -- its subscription. + liftIO $ writeIORef changeSubdRef (s, changeSubscription) + let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents + return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef) + , occ + ) + +newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a } + +fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k +fan e = + let f = Fan + { fanParent = e + , fanSubscribed = unsafeNewIORef e Nothing + } + in EventSelector $ \k -> eventFan k f + +runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x () +runHoldInits holdInitRef dynInitRef mergeInitRef = do + holdInits <- liftIO $ readIORef holdInitRef + dynInits <- liftIO $ readIORef dynInitRef + mergeInits <- liftIO $ readIORef mergeInitRef + unless (null holdInits && null dynInits && null mergeInits) $ do + liftIO $ writeIORef holdInitRef [] + liftIO $ writeIORef dynInitRef [] + liftIO $ writeIORef mergeInitRef [] + mapM_ initHold holdInits + mapM_ initDyn dynInits + mapM_ unSomeMergeInit mergeInits + runHoldInits holdInitRef dynInitRef mergeInitRef + +initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x () +initHold (SomeHoldInit h) = void $ getHoldEventSubscription h + +initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x () +initDyn (SomeDynInit d) = void $ getDynHold d + +newEventEnv :: IO (EventEnv x) +newEventEnv = do + toAssignRef <- newIORef [] -- This should only actually get used when events are firing + holdInitRef <- newIORef [] + dynInitRef <- newIORef [] + mergeUpdateRef <- newIORef [] + mergeInitRef <- newIORef [] + heightRef <- newIORef zeroHeight + toClearRef <- newIORef [] + toClearIntRef <- newIORef [] + toClearRootRef <- newIORef [] + coincidenceInfosRef <- newIORef [] + delayedRef <- newIORef IntMap.empty + return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef + +clearEventEnv :: EventEnv x -> IO () +clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do + writeIORef toAssignRef [] + writeIORef holdInitRef [] + writeIORef dynInitRef [] + writeIORef mergeUpdateRef [] + writeIORef mergeInitRef [] + writeIORef heightRef zeroHeight + writeIORef toClearRef [] + writeIORef toClearIntRef [] + writeIORef toClearRootRef [] + writeIORef coincidenceInfosRef [] + writeIORef delayedRef IntMap.empty + +-- | Run an event action outside of a frame +runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex +runFrame a = SpiderHost $ do + let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x) + let go = do + result <- a + runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events + return result + result <- runEventM go + toClear <- readIORef $ eventEnvClears env + forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing + toClearInt <- readIORef $ eventEnvIntClears env + forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty + toClearRoot <- readIORef $ eventEnvRootClears env + forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty + toAssign <- readIORef $ eventEnvAssignments env + toReconnectRef <- newIORef [] + coincidenceInfos <- readIORef $ eventEnvResetCoincidences env + forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do + writeIORef vRef v + when debugInvalidate $ putStrLn $ "Invalidating Hold" + writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef + mergeUpdates <- readIORef $ eventEnvMergeUpdates env + writeIORef (eventEnvMergeUpdates env) [] + when debugPropagate $ putStrLn "Updating merges" + mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates + when debugPropagate $ putStrLn "Updating merges done" + toReconnect <- readIORef toReconnectRef + clearEventEnv env + switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do + oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed + wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed + when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed + finalize wi + i <- evaluate $ switchSubscribedOwnInvalidator subscribed + wi' <- mkWeakPtrWithDebug i "wi'" + writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi' + writeIORef (switchSubscribedBehaviorParents subscribed) [] + writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this? + e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env + runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant + --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times + sub <- newSubscriberSwitch subscribed + subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient + {- + stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed) + liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of + EventRoot _ -> "EventRoot" + EventNever -> "EventNever" + _ -> "something else" + -} + writeIORef (switchSubscribedCurrentParent subscribed) $! subscription + return oldSubscription + liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill + liftIO $ mapM_ unsubscribe switchSubscriptionsToKill + forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do + EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed + parentHeight <- getEventSubscribedHeight subd' + myHeight <- readIORef $ switchSubscribedHeight subscribed + when (parentHeight /= myHeight) $ do + writeIORef (switchSubscribedHeight subscribed) $! invalidHeight + WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight + mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different + forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do + unsubscribe subscription + mapM_ invalidateCoincidenceHeight mcs + forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs + mapM_ _someMergeUpdate_recalculateHeight mergeUpdates + forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do + height <- calculateSwitchHeight subscribed + updateSwitchHeight height subscribed + return result + +newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded) + +{-# INLINE zeroHeight #-} +zeroHeight :: Height +zeroHeight = Height 0 + +{-# INLINE invalidHeight #-} +invalidHeight :: Height +invalidHeight = Height (-1000) + +#ifdef DEBUG_CYCLES +-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents +{-# INLINE invalidHeightBeingTraversed #-} +invalidHeightBeingTraversed :: Height +invalidHeightBeingTraversed = Height (-1001) +#endif + +{-# INLINE succHeight #-} +succHeight :: Height -> Height +succHeight h@(Height a) = + if h == invalidHeight + then invalidHeight + else Height $ succ a + +invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO () +invalidateCoincidenceHeight subscribed = do + oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed + when (oldHeight /= invalidHeight) $ do + writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight + WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight + +updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO () +updateSwitchHeight new subscribed = do + oldHeight <- readIORef $ switchSubscribedHeight subscribed + when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion + when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion + writeIORef (switchSubscribedHeight subscribed) $! new + WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new + +recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO () +recalculateCoincidenceHeight subscribed = do + oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed + when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion + height <- calculateCoincidenceHeight subscribed + when (height /= invalidHeight) $ do + writeIORef (coincidenceSubscribedHeight subscribed) $! height + WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height + +calculateSwitchHeight :: SwitchSubscribed x a -> IO Height +calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed) + +calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height +calculateCoincidenceHeight subscribed = do + outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed + innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed) + return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight + +data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a) + +invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x)) +invalidate toReconnectRef wis = do + forM_ wis $ \wi -> do + mi <- deRefWeak wi + case mi of + Nothing -> do + traceInvalidate "invalidate Dead" + return () --TODO: Should we clean this up here? + Just i -> do + finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict + case i of + InvalidatorPull p -> do + traceInvalidate $ "invalidate: Pull" <> showNodeId p + mVal <- readIORef $ pullValue p + forM_ mVal $ \val -> do + writeIORef (pullValue p) Nothing + writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val) + InvalidatorSwitch subscribed -> do + traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed + modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :) + return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them + +-------------------------------------------------------------------------------- +-- Reflex integration +-------------------------------------------------------------------------------- + +-- | Designates the default, global Spider timeline +data SpiderTimeline x +type role SpiderTimeline nominal + +-- | The default, global Spider environment +type Spider = SpiderTimeline Global + +instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where + {-# INLINABLE sample #-} + sample (SpiderBehavior b) = readBehaviorUntracked b + +instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where + {-# INLINABLE hold #-} + hold = holdSpiderEventM + {-# INLINABLE holdDyn #-} + holdDyn = holdDynSpiderEventM + {-# INLINABLE holdIncremental #-} + holdIncremental = holdIncrementalSpiderEventM + {-# INLINABLE buildDynamic #-} + buildDynamic = buildDynamicSpiderEventM + {-# INLINABLE headE #-} + headE = R.slowHeadE +-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e + +instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where + {-# INLINABLE sample #-} + sample = coerce . readBehaviorTracked . unSpiderBehavior + +instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where + {-# INLINABLE sample #-} + sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b + +instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where + {-# INLINABLE hold #-} + hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e + {-# INLINABLE holdDyn #-} + holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e + {-# INLINABLE holdIncremental #-} + holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e + {-# INLINABLE buildDynamic #-} + buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e + {-# INLINABLE headE #-} + headE = R.slowHeadE +-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e + +instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x + {-# INLINE (>>) #-} + (>>) = (*>) + {-# INLINE fail #-} + fail _ = error "Dynamic does not support 'fail'" + +{-# INLINABLE newJoinDyn #-} +newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a) +newJoinDyn d = + let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d) + eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d + eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d + eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d + v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner] + in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v' + +instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where + fmap = mapDynamicSpider + x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d + +mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b +mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic +{-# INLINE [1] mapDynamicSpider #-} + +instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where + pure = SpiderDynamic . dynamicConst +#if MIN_VERSION_base(4,10,0) + liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b) +#endif + SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b + a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a] + (<*) = flip (*>) -- There are no effects, so order doesn't matter + +holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a) +holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e + +holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a) +holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e + +holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p) +holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e + +buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a) +buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e + +instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where + {-# INLINABLE hold #-} + hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e + {-# INLINABLE holdDyn #-} + holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e + {-# INLINABLE holdIncremental #-} + holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e + {-# INLINABLE buildDynamic #-} + buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e + {-# INLINABLE headE #-} + headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e + +instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where + sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can + +instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where + {-# INLINABLE hold #-} + hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e + {-# INLINABLE holdDyn #-} + holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e + {-# INLINABLE holdIncremental #-} + holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e + {-# INLINABLE buildDynamic #-} + buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e + {-# INLINABLE headE #-} + headE = R.slowHeadE +-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e + +instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where + {-# INLINABLE sample #-} + sample = runFrame . readBehaviorUntracked . unSpiderBehavior + +instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where + {-# INLINABLE sample #-} + sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample + +instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where + {-# INLINABLE hold #-} + hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e + {-# INLINABLE holdDyn #-} + holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e + {-# INLINABLE holdIncremental #-} + holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e + {-# INLINABLE buildDynamic #-} + buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e + {-# INLINABLE headE #-} + headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e + +-------------------------------------------------------------------------------- +-- Deprecated items +-------------------------------------------------------------------------------- + +-- | 'SpiderEnv' is the old name for 'SpiderTimeline' +{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-} +type SpiderEnv = SpiderTimeline +instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where + {-# INLINABLE subscribeEvent #-} + subscribeEvent e = SpiderHostFrame $ do + --TODO: Unsubscribe eventually (manually and/or with weak ref) + val <- liftIO $ newIORef Nothing + subscription <- subscribe (unSpiderEvent e) $ Subscriber + { subscriberPropagate = \a -> do + liftIO $ writeIORef val $ Just a + scheduleClear val + , subscriberInvalidateHeight = \_ -> return () + , subscriberRecalculateHeight = \_ -> return () + } + return $ SpiderEventHandle + { spiderEventHandleSubscription = subscription + , spiderEventHandleValue = val + } + +instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where + type EventTrigger (SpiderTimeline x) = RootTrigger x + type EventHandle (SpiderTimeline x) = SpiderEventHandle x + type HostFrame (SpiderTimeline x) = SpiderHostFrame x + +instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where + {-# NOINLINE readEvent #-} + readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do + result <- readIORef $ spiderEventHandleValue h + touch h + return result + +instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where + newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO + newFanEventWithTrigger f = SpiderHost $ do + es <- newFanEventWithTriggerIO f + return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es + +instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where + newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO + newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do + es <- newFanEventWithTriggerIO f + return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es + +instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where + {-# INLINABLE subscribeEvent #-} + subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent + +instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where + type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x + fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a + runHostFrame = runFrame . runSpiderHostFrame + +unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x) +unsafeNewSpiderTimelineEnv = do + lock <- newMVar () + env <- newEventEnv +#ifdef DEBUG + depthRef <- newIORef 0 +#endif + return $ SpiderTimelineEnv + { _spiderTimeline_lock = lock + , _spiderTimeline_eventEnv = env +#ifdef DEBUG + , _spiderTimeline_depth = depthRef +#endif + } + +-- | Create a new SpiderTimelineEnv +newSpiderTimeline :: IO (Some SpiderTimelineEnv) +newSpiderTimeline = withSpiderTimeline (pure . Some.This) + +data LocalSpiderTimeline x s + +instance Reifies s (SpiderTimelineEnv x) => + HasSpiderTimeline (LocalSpiderTimeline x s) where + spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s) + +localSpiderTimeline + :: Proxy s + -> SpiderTimelineEnv x + -> SpiderTimelineEnv (LocalSpiderTimeline x s) +localSpiderTimeline _ = unsafeCoerce + +-- | Pass a new timeline to the given function. +withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r +withSpiderTimeline k = do + env <- unsafeNewSpiderTimelineEnv + reify env $ \s -> k $ localSpiderTimeline s env + +newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + +type ComputeM = EventM + +newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + +instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where + {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-} + newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a } + newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a } + newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad) + newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p } + type PullM (SpiderTimeline x) = SpiderPullM x + type PushM (SpiderTimeline x) = SpiderPushM x + {-# INLINABLE never #-} + never = SpiderEvent eventNever + {-# INLINABLE constant #-} + constant = SpiderBehavior . behaviorConst + {-# INLINE push #-} + push f = SpiderEvent . push (coerce f) . unSpiderEvent + {-# INLINE pushCheap #-} + pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent + {-# INLINABLE pull #-} + pull = SpiderBehavior . pull . coerce + {-# INLINABLE merge #-} + merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x)) + {-# INLINABLE fan #-} + fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e)) + {-# INLINABLE switch #-} + switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior + {-# INLINABLE coincidence #-} + coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent + {-# INLINABLE current #-} + current = SpiderBehavior . dynamicCurrent . unSpiderDynamic + {-# INLINABLE updated #-} + updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic + {-# INLINABLE unsafeBuildDynamic #-} + unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v' + {-# INLINABLE unsafeBuildIncremental #-} + unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv + {-# INLINABLE mergeIncremental #-} + mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental + {-# INLINABLE mergeIncrementalWithMove #-} + mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental + {-# INLINABLE currentIncremental #-} + currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental + {-# INLINABLE updatedIncremental #-} + updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental + {-# INLINABLE incrementalToDynamic #-} + incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do + c <- readBehaviorUntracked $ dynamicCurrent i + return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply' + eventCoercion Coercion = Coercion + behaviorCoercion Coercion = Coercion + dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance + {-# INLINABLE mergeIntIncremental #-} + mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental + {-# INLINABLE fanInt #-} + fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e)) + +data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a) + +data SpiderEventHandle x a = SpiderEventHandle + { spiderEventHandleSubscription :: EventSubscription x + , spiderEventHandleValue :: IORef (Maybe a) + } + +instance MonadRef (EventM x) where + type Ref (EventM x) = Ref IO + {-# INLINABLE newRef #-} + {-# INLINABLE readRef #-} + {-# INLINABLE writeRef #-} + newRef = liftIO . newRef + readRef = liftIO . readRef + writeRef r a = liftIO $ writeRef r a + +instance MonadAtomicRef (EventM x) where + {-# INLINABLE atomicModifyRef #-} + atomicModifyRef r f = liftIO $ atomicModifyRef r f + +-- | The monad for actions that manipulate a Spider timeline identified by @x@ +newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) + +instance Monad (SpiderHost x) where + {-# INLINABLE (>>=) #-} + SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f + {-# INLINABLE (>>) #-} + SpiderHost x >> SpiderHost y = SpiderHost $ x >> y + {-# INLINABLE return #-} + return x = SpiderHost $ return x + {-# INLINABLE fail #-} + fail s = SpiderHost $ fail s + +-- | Run an action affecting the global Spider timeline; this will be guarded by +-- a mutex for that timeline +runSpiderHost :: SpiderHost Global a -> IO a +runSpiderHost (SpiderHost a) = a + +-- | Run an action affecting a given Spider timeline; this will be guarded by a +-- mutex for that timeline +runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a +runSpiderHostForTimeline (SpiderHost a) _ = a + +newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } + deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) + +instance Monad (SpiderHostFrame x) where + {-# INLINABLE (>>=) #-} + SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f + {-# INLINABLE (>>) #-} + SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y + {-# INLINABLE return #-} + return x = SpiderHostFrame $ return x + {-# INLINABLE fail #-} + fail s = SpiderHostFrame $ fail s + +instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where + notReadyUntil _ = pure () + notReady = pure () + +newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a) +newEventWithTriggerIO f = do + es <- newFanEventWithTriggerIO $ \Refl -> f + return $ select es Refl + +newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k) +newFanEventWithTriggerIO f = do + occRef <- newIORef DMap.empty + subscribedRef <- newIORef DMap.empty + let !r = Root + { rootOccurrence = occRef + , rootSubscribed = subscribedRef + , rootInit = f + } + return $ EventSelector $ \k -> eventRoot k r + +newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix) + +instance MonadRef (SpiderHost x) where + type Ref (SpiderHost x) = Ref IO + newRef = SpiderHost . newRef + readRef = SpiderHost . readRef + writeRef r = SpiderHost . writeRef r + +instance MonadAtomicRef (SpiderHost x) where + atomicModifyRef r = SpiderHost . atomicModifyRef r + +instance MonadRef (SpiderHostFrame x) where + type Ref (SpiderHostFrame x) = Ref IO + newRef = SpiderHostFrame . newRef + readRef = SpiderHostFrame . readRef + writeRef r = SpiderHostFrame . writeRef r + +instance MonadAtomicRef (SpiderHostFrame x) where + atomicModifyRef r = SpiderHostFrame . atomicModifyRef r + +instance PrimMonad (SpiderHostFrame x) where + type PrimState (SpiderHostFrame x) = PrimState IO + primitive = SpiderHostFrame . EventM . primitive diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Time.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +#ifdef USE_TEMPLATE_HASKELL +{-# LANGUAGE TemplateHaskell #-} +#endif +module Reflex.Time where + +import Reflex.Class +import Reflex.Dynamic +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.TriggerEvent.Class + +import Control.Concurrent +import qualified Control.Concurrent.Thread.Delay as Concurrent +import Control.Lens hiding ((|>)) +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.Align +import Data.Fixed +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as Seq +import Data.These +import Data.Time.Clock +import Data.Typeable +import System.Random + +data TickInfo + = TickInfo { _tickInfo_lastUTC :: UTCTime + -- ^ UTC time immediately after the last tick. + , _tickInfo_n :: Integer + -- ^ Number of time periods since t0 + , _tickInfo_alreadyElapsed :: NominalDiffTime + -- ^ Amount of time already elapsed in the current tick period. + } + deriving (Eq, Ord, Show, Typeable) + +-- | Special case of 'tickLossyFrom' that uses the post-build event to start the +-- tick thread. +tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo) +tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild + +-- | Special case of 'tickLossyFrom' that uses the post-build event to start the +-- tick thread and the time of the post-build as the tick basis time. +tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo) +tickLossyFromPostBuildTime dt = do + postBuild <- getPostBuild + postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild + tickLossyFrom' $ (dt,) <$> postBuildTime + +-- | Send events over time with the given basis time and interval +-- If the system starts running behind, occurrences will be dropped rather than buffered +-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time +tickLossyFrom + :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) + => NominalDiffTime + -- ^ The length of a tick interval + -> UTCTime + -- ^ The basis time from which intervals count + -> Event t a + -- ^ Event that starts a tick generation thread. Usually you want this to + -- be something like the result of getPostBuild that only fires once. But + -- there could be uses for starting multiple timer threads. + -> m (Event t TickInfo) +tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e + +-- | Generalization of tickLossyFrom that takes dt and t0 in the event. +tickLossyFrom' + :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) + => Event t (NominalDiffTime, UTCTime) + -- ^ Event that starts a tick generation thread. Usually you want this to + -- be something like the result of getPostBuild that only fires once. But + -- there could be uses for starting multiple timer threads. + -> m (Event t TickInfo) +tickLossyFrom' e = do + rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result] + return $ fst <$> result + where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do + tick <- uncurry getCurrentTick pair + Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000 + cb (tick, pair) + +clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo) +clockLossy dt t0 = do + initial <- liftIO $ getCurrentTick dt t0 + e <- tickLossy dt t0 + holdDyn initial e + +getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo +getCurrentTick dt t0 = do + t <- getCurrentTime + let offset = t `diffUTCTime` t0 + (n, alreadyElapsed) = offset `divMod'` dt + return $ TickInfo t n alreadyElapsed + +-- | Delay an Event's occurrences by a given amount in seconds. +delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a) +delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do + Concurrent.delay $ ceiling $ dt * 1000000 + cb a + +-- | Send events with Poisson timing with the given basis and rate +-- Each occurrence of the resulting event will contain the index of +-- the current interval, with 0 representing the basis time +poissonLossyFrom + :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m) + => g + -> Double + -- ^ Poisson event rate (Hz) + -> UTCTime + -- ^ Baseline time for events + -> Event t a + -- ^ Event that starts a tick generation thread. Usually you want this to + -- be something like the result of getPostBuild that only fires once. But + -- there could be uses for starting multiple timer threads. + -- Start sending events in response to the event parameter. + -> m (Event t TickInfo) +poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate + + +-- | Send events with Poisson timing with the given basis and rate +-- Each occurrence of the resulting event will contain the index of +-- the current interval, with 0 representing the basis time. +-- Automatically begin sending events when the DOM is built +poissonLossy + :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m) + => g + -> Double + -- ^ Poisson event rate (Hz) + -> UTCTime + -- ^ Baseline time for events + -> m (Event t TickInfo) +poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild + +-- | Send events with inhomogeneous Poisson timing with the given basis +-- and variable rate. Provide a maxRate that you expect to support. +inhomogeneousPoissonFrom + :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m) + => g + -> Behavior t Double + -> Double + -> UTCTime + -> Event t a + -> m (Event t TickInfo) +inhomogeneousPoissonFrom rnd rate maxRate t0 e = do + + -- Create a thread for producing homogeneous poisson events + -- along with random Doubles (usage of Double's explained below) + ticksWithRateRand <- performEventAsync $ + fmap callAtNextInterval e + + -- Filter homogeneous events according to associated + -- random values and the current rate parameter + return $ attachWithMaybe filterFun rate ticksWithRateRand + + where + + -- Inhomogeneous poisson processes are built from faster + -- homogeneous ones by randomly dropping events from the + -- fast process. For each fast homogeneous event, choose + -- a uniform random sample from (0, rMax). If the + -- inhomogeneous rate at this moment is greater than the + -- random sample, then keep this event, otherwise drop it + filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo + filterFun r (tInfo, p) + | r >= p = Just tInfo + | otherwise = Nothing + + callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0 + + go tTargetLast lastGen cb lastN = do + t <- getCurrentTime + + -- Generate random numbers for this poisson interval (u) + -- and sample-retention likelihood (p) + let (u, nextGen) = randomR (0,1) lastGen + (p :: Double, nextGen') = randomR (0,maxRate) nextGen + + -- Inter-event interval is drawn from exponential + -- distribution accourding to u + let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime + nEvents = lastN + 1 + alreadyElapsed = diffUTCTime t tTargetLast + tTarget = addUTCTime dt tTargetLast + thisDelay = realToFrac $ diffUTCTime tTarget t :: Double + Concurrent.delay $ ceiling $ thisDelay * 1000000 + _ <- cb (TickInfo t nEvents alreadyElapsed, p) + go tTarget nextGen' cb nEvents + +-- | Send events with inhomogeneous Poisson timing with the given basis +-- and variable rate. Provide a maxRate that you expect to support +inhomogeneousPoisson + :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m) + => g + -> Behavior t Double + -> Double + -> UTCTime + -> m (Event t TickInfo) +inhomogeneousPoisson rnd rate maxRate t0 = + inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild + +-- | Block occurrences of an Event until the given number of seconds elapses without +-- the Event firing, at which point the last occurrence of the Event will fire. +debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a) +debounce dt e = do + n :: Dynamic t Integer <- count e + let tagged = attachPromptlyDynWith (,) n e + delayed <- delay dt tagged + return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed + +-- | When the given 'Event' occurs, wait the given amount of time and collect +-- all occurrences during that time. Then, fire the output 'Event' with the +-- collected output. +batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a)) +batchOccurrences t newValues = do + let f s x = (Just newState, out) + where newState = case x of + This a -> s |> a + That _ -> mempty + These a _ -> Seq.singleton a + out = case x of + This _ -> if Seq.null s then Just () else Nothing + That _ -> Nothing + These _ _ -> Just () + rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed + delayed <- delay t toDelay + return $ tag buffer delayed + +-- | Throttle an input event, ensuring that at least a given amount of time passes between occurrences of the output event. If the input event occurs too +-- frequently, the output event occurs with the most recently seen input value after the given delay passes since the last occurrence of the output. +-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately. +throttle :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a) +throttle t e = do + let f (immediate, buffer) x = case x of -- (Just newState, out) + This a -- If only the input event fires + | immediate -> -- and we're in immediate mode + -- Immediate mode turns off, and the buffer is empty. + -- We fire the output event with the input event value immediately. + (Just (False, Nothing), Just a) + | otherwise -> -- and we're not in immediate mode + -- Immediate mode remains off, and we replace the contents of the buffer (if any) with the input value. + -- We don't fire the output event. + (Just (False, Just a), Nothing) + That _ -> -- If only the delayed output event fires, + case buffer of + Nothing -> -- and the buffer is empty: + -- Immediate mode turns back on, and the buffer remains empty. + -- We don't fire. + (Just (True, Nothing), Nothing) + Just b -> -- and the buffer is full: + -- Immediate mode remains off, and the buffer is cleared. + -- We fire with the buffered value. + (Just (False, Nothing), Just b) + These a _ -> -- If both the input and delayed output event fire simultaneously: + -- Immediate mode turns off, and the buffer is empty. + -- We fire with the input event's value, as it is the most recent we have seen at this moment. + (Just (False, Nothing), Just a) + rec (_, outE) <- mapAccumMaybeDyn f (True, Nothing) $ align e delayed -- We start in immediate mode with an empty buffer. + delayed <- delay t outE + return outE + +#ifdef USE_TEMPLATE_HASKELL +makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo +#else +tickInfo_lastUTC :: Lens' TickInfo UTCTime +tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1 +{-# INLINE tickInfo_lastUTC #-} + +tickInfo_n :: Lens' TickInfo Integer +tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2 +{-# INLINE tickInfo_n #-} + +tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime +tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3 +{-# INLINE tickInfo_alreadyElapsed #-} +#endif + diff --git a/src/Reflex/TriggerEvent/Base.hs b/src/Reflex/TriggerEvent/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/TriggerEvent/Base.hs @@ -0,0 +1,148 @@ +-- | This module defines 'TriggerEventT', the standard implementation of +-- 'TriggerEvent'. +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Reflex.TriggerEvent.Base + ( TriggerEventT (..) + , runTriggerEventT + , askEvents + , TriggerInvocation (..) + , EventTriggerRef (..) + ) where + +import Control.Applicative (liftA2) +import Control.Concurrent +import Control.Monad.Exception +import Control.Monad.Primitive +import Control.Monad.Reader +import Control.Monad.Ref +import Data.Coerce +import Data.Dependent.Sum +import Data.IORef +import Data.Monoid ((<>)) +import qualified Data.Semigroup as S +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.Host.Class +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.TriggerEvent.Class + +-- | A value with which to fire an 'Event', as well as a callback to invoke +-- after its propagation has completed. +data TriggerInvocation a = TriggerInvocation a (IO ()) + +-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'. +newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) } + +-- | A basic implementation of 'TriggerEvent'. +newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a } + deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) + +-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which +-- 'TriggerInvocation's can be passed; it is expected that some other thread +-- will be responsible for popping values out of the 'Chan' and firing their +-- 'EventTrigger's. +runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a +runTriggerEventT = runReaderT . unTriggerEventT + +instance MonadTrans (TriggerEventT t) where + {-# INLINABLE lift #-} + lift = TriggerEventT . lift + +instance PrimMonad m => PrimMonad (TriggerEventT t m) where + type PrimState (TriggerEventT t m) = PrimState m + {-# INLINABLE primitive #-} + primitive = lift . primitive + +instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where + type Performable (TriggerEventT t m) = Performable m + {-# INLINABLE performEvent_ #-} + performEvent_ e = lift $ performEvent_ e + {-# INLINABLE performEvent #-} + performEvent e = lift $ performEvent e + +instance PostBuild t m => PostBuild t (TriggerEventT t m) where + {-# INLINABLE getPostBuild #-} + getPostBuild = lift getPostBuild + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where + {-# INLINABLE newEventWithTrigger #-} + newEventWithTrigger = lift . newEventWithTrigger + {-# INLINABLE newFanEventWithTrigger #-} + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where + {-# INLINABLE newTriggerEvent #-} + newTriggerEvent = do + (e, t) <- newTriggerEventWithOnComplete + return (e, \a -> t a $ return ()) + {-# INLINABLE newTriggerEventWithOnComplete #-} + newTriggerEventWithOnComplete = do + events <- askEvents + (eResult, reResultTrigger) <- lift newEventWithTriggerRef + return . (,) eResult $ \a cb -> + writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb] + {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-} + newEventWithLazyTriggerWithOnComplete f = do + events <- askEvents + lift . newEventWithTrigger $ \t -> + f $ \a cb -> do + reResultTrigger <- newRef $ Just t + writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb] + +instance MonadRef m => MonadRef (TriggerEventT t m) where + type Ref (TriggerEventT t m) = Ref m + {-# INLINABLE newRef #-} + newRef = lift . newRef + {-# INLINABLE readRef #-} + readRef = lift . readRef + {-# INLINABLE writeRef #-} + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where + {-# INLINABLE atomicModifyRef #-} + atomicModifyRef r = lift . atomicModifyRef r + +instance MonadSample t m => MonadSample t (TriggerEventT t m) where + {-# INLINABLE sample #-} + sample = lift . sample + +instance MonadHold t m => MonadHold t (TriggerEventT t m) where + {-# INLINABLE hold #-} + hold v0 v' = lift $ hold v0 v' + {-# INLINABLE holdDyn #-} + holdDyn v0 v' = lift $ holdDyn v0 v' + {-# INLINABLE holdIncremental #-} + holdIncremental v0 v' = lift $ holdIncremental v0 v' + {-# INLINABLE buildDynamic #-} + buildDynamic a0 = lift . buildDynamic a0 + {-# INLINABLE headE #-} + headE = lift . headE + +instance Adjustable t m => Adjustable t (TriggerEventT t m) where + {-# INLINABLE runWithReplace #-} + runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a') + {-# INLINABLE traverseIntMapWithKeyWithAdjust #-} + traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm' + {-# INLINABLE traverseDMapWithKeyWithAdjust #-} + traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm' + {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-} + traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm' + +-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them. +instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where + mempty = pure mempty + mappend = (<>) + +instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where + (<>) = liftA2 (S.<>) + + +-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will +-- be fired. +askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation]) +askEvents = TriggerEventT ask diff --git a/src/Reflex/TriggerEvent/Class.hs b/src/Reflex/TriggerEvent/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/TriggerEvent/Class.hs @@ -0,0 +1,50 @@ +-- | This module defines 'TriggerEvent', which describes actions that may create +-- new 'Event's that can be triggered from 'IO'. +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.TriggerEvent.Class + ( TriggerEvent (..) + ) where + +import Reflex.Class + +import Control.Monad.Reader +import Control.Monad.State +import qualified Control.Monad.State.Strict as Strict + +--TODO: Shouldn't have IO hard-coded +-- | 'TriggerEvent' represents actions that can create 'Event's that can be +-- triggered by 'IO' actions. +class Monad m => TriggerEvent t m | m -> t where + -- | Create a triggerable 'Event'. Whenever the resulting function is called, + -- the resulting 'Event' will fire at some point in the future. Note that + -- this may not be synchronous. + newTriggerEvent :: m (Event t a, a -> IO ()) + -- | Like 'newTriggerEvent', but the callback itself takes another callback, + -- to be invoked once the requested 'Event' occurrence has finished firing. + -- This allows synchronous operation. + newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow + -- | Like 'newTriggerEventWithOnComplete', but with setup and teardown. This + -- relatively complex type signature allows any external listeners to be + -- subscribed lazily and then removed whenever the returned 'Event' is no + -- longer being listened to. Note that the setup/teardown may happen multiple + -- times, and there is no guarantee that the teardown will be executed + -- promptly, or even at all, in the case of program termination. + newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a) + +instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance TriggerEvent t m => TriggerEvent t (StateT s m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete diff --git a/src/Reflex/Widget/Basic.hs b/src/Reflex/Widget/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Widget/Basic.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecursiveDo #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif + +module Reflex.Widget.Basic where + +import Control.Monad.Fix (MonadFix) +import Data.Map (Map) + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.Patch.MapWithMove + + +-- | Build sortable content in such a way that re-sorting it can cause minimal +-- disruption to an existing context. +-- +-- Naively re-sorting a list of images would destroy every image and add them back +-- in the new order. This framework is able to avoid that by preserving the +-- identity of each image and simply moving it to the new location. +-- +-- Example: +-- +-- > let sortByFst = buttonA $> comparing fst +-- > sortBySnd = buttonB $> comparing snd +-- > sortEvent = leftmost [sortByFst, sortBySnd] +-- > sortableList +-- > (\k v -> text $ "\n" ++ show k ++ " " ++ v) -- show each element on a new line +-- > (Map.fromList $ zip [0..] [(3, "a"), (2, "b"), (1, "c")]) +-- > sortEvent +sortableList :: forall t m k v a. (MonadHold t m, MonadFix m, Adjustable t m, Ord k) + => (k -> v -> m a) -- ^ Function to render the content for each key/value pair + -> Map k v -- ^ The sortable list with an initial ordering determined by the @Map@ keys in ascending order + -> Event t (v -> v -> Ordering) -- ^ An event carrying a sort function for the list + -> m (Map k a) +sortableList f m0 reSortFunc = do + rec let reSortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) reSortFunc + m <- holdIncremental m0 reSortPatch + (results, _) <- mapMapWithAdjustWithMove f m0 reSortPatch + pure results diff --git a/src/Reflex/Workflow.hs b/src/Reflex/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Workflow.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Reflex.Workflow ( + -- * Workflows + Workflow (..) + , workflow + , workflowView + , mapWorkflow + , mapWorkflowCheap + ) where + +import Control.Arrow ((***)) +import Control.Monad.Fix (MonadFix) + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.Network +import Reflex.NotReady.Class +import Reflex.PostBuild.Class + +newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } + +workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) +workflow w0 = do + rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult + return $ fmap fst eResult + +workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) +workflowView w0 = do + rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace + eReplace <- fmap switch $ hold never $ fmap snd eResult + return $ fmap fst eResult + +mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b +mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x) + +mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b +mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x) diff --git a/test/EventWriterT.hs b/test/EventWriterT.hs new file mode 100644 --- /dev/null +++ b/test/EventWriterT.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.Lens +import Control.Monad +import Control.Monad.Fix +import qualified Data.Dependent.Map as DMap +import Data.Functor.Misc +import qualified Data.Map as M +import Data.These + +import Reflex +import Reflex.EventWriter.Base +import Test.Run + +main :: IO () +main = do + os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $ + [ Just () + ] + print os1 + os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] + <- runApp' (unwrapApp testSimultaneous) $ map Just $ + [ This () + , That () + , This () + , These () () + ] + print os2 + os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()] + print os3 + os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()] + print os4 + os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()] + print os5 + return () + +unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int]) +unwrapApp x appIn = do + ((), e) <- runEventWriterT $ x appIn + return e + +testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m () +testOrdering pulse = do + forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse) + return () + +testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m () +testSimultaneous pulse = do + let e0 = fmapMaybe (^? here) pulse + e1 = fmapMaybe (^? there) pulse + forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0) + return () + +-- | Test that a widget telling and event which fires at the same time it has been replaced +-- doesn't count along with the new widget. +testMoribundTellEvent + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + ) + => Event t () + -> EventWriterT t [Int] m () +testMoribundTellEvent pulse = do + rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () + tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished + (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse + return () + +-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'. +testMoribundTellEventDMap + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + ) + => Event t () + -> EventWriterT t [Int] m () +testMoribundTellEventDMap pulse = do + rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () + tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished + (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <- + traverseDMapWithKeyWithAdjust + (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v) + (mapToDMap $ M.singleton () 1) + ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse) + return () + +-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's +-- during the same frame as other elements are updated. +testLiveTellEventDMap + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + ) + => Event t () + -> EventWriterT t [Int] m () +testLiveTellEventDMap pulse = do + rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () + tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished + (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <- + traverseDMapWithKeyWithAdjust + (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k) + (mapToDMap $ M.singleton 1 ()) + ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse) + return () diff --git a/test/GC.hs b/test/GC.hs new file mode 100644 --- /dev/null +++ b/test/GC.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Ref +import Data.Align +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.Functor.Identity +import Data.GADT.Compare +import Data.IORef +import Data.Semigroup +import Data.These + +import Data.Functor.Misc +import Reflex.Patch + +import qualified Reflex.Host.Class as Host +import qualified Reflex.Spider.Internal as S + +import System.Exit +import System.Mem + +main :: IO () +main = do + ref <- newIORef Nothing + hostPerf ref + readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show) + +hostPerf :: IORef (Maybe Int) -> IO () +hostPerf ref = S.runSpiderHost $ do + ---- body + liftIO $ putStrLn "#creating triggers" + (response', responseTrigger) <- Host.newEventWithTriggerRef + (eadd', addTriggerRef) <- Host.newEventWithTriggerRef + let response = S.unSpiderEvent response' + eadd = S.unSpiderEvent eadd' + liftIO $ putStrLn "#creating event graph" + eventToPerform <- Host.runHostFrame $ do + (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity)) + <- S.SpiderHostFrame + $ fmap ( S.merge + . S.dynamicHold) + $ S.hold DMap.empty + -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained + $ (\e -> S.Event $ \sub -> do + (s, o) <- S.subscribeAndRead e $ sub + { S.subscriberPropagate = S.subscriberPropagate sub + } + return (s, o)) + $ runIdentity <$> S.select + (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) + (WrapArg Request) + return $ alignWith (mergeThese (<>)) + (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do + liftIO $ putStrLn "#eadd fired" + return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just + $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd) + (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m) + ---- epilogue + eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform) + liftIO $ putStrLn "#performing GC" >> performMajorGC + liftIO $ putStrLn "#attempting to fire eadd" + mAddTrigger <- readRef addTriggerRef + forM_ mAddTrigger $ \t -> replicateM_ 2 $ do + liftIO $ putStrLn "#firing eadd" + mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle + case mToPerform of + Nothing -> return () + Just toPerform -> do + responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform + mrt <- readRef responseTrigger + let followupEventTriggers = case mrt of + Just rt -> [rt :=> Identity responses] + Nothing -> [] + Host.fireEventsAndRead followupEventTriggers $ return () + return () + return () + +data Tell a where + Action :: Tell () + Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global)) + +instance GEq Tell where + geq Action Action = Just Refl + geq Request Request = Just Refl + geq _ _ = Nothing + +instance GCompare Tell where + gcompare Action Action = GEQ + gcompare Request Request = GEQ + gcompare Action Request = GLT + gcompare Request Action = GGT diff --git a/test/QueryT.hs b/test/QueryT.hs new file mode 100644 --- /dev/null +++ b/test/QueryT.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +import Control.Lens +import Control.Monad.Fix +import Data.Align +import qualified Data.AppendMap as AMap +import Data.Functor.Misc +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Map.Monoidal (MonoidalMap) +import Data.Semigroup +import Data.These + +import Reflex +import Reflex.Patch.MapWithMove +import Test.Run + +newtype MyQuery = MyQuery SelectedCount + deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group) + +instance Query MyQuery where + type QueryResult MyQuery = () + crop _ _ = () + +instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where + type QueryResult (Selector k a) = Selector k (QueryResult a) + crop q r = undefined + +newtype Selector k a = Selector { unSelector :: MonoidalMap k a } + deriving (Show, Read, Eq, Ord, Functor) + +#if !(MIN_VERSION_monoidal_containers(0,4,1)) +deriving instance Ord k => Align (MonoidalMap k) +#endif + +instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where + (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b + where + f = alignWith $ \case + This x -> Just x + That y -> Just y + These x y -> + let z = x `mappend` y + in if z == mempty then Nothing else Just z + +instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where + mempty = Selector AMap.empty + mappend = (<>) + +instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where + negateG = fmap negateG + +instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a) + +main :: IO () +main = do + [0, 1, 1, 0] <- fmap (map fst . concat) $ + runApp (testQueryT testRunWithReplace) () $ map (Just . That) $ + [ That (), This (), That () ] + [0, 1, 1, 0] <- fmap (map fst . concat) $ + runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $ + [ That (), This (), That () ] + [0, 1, 1, 0] <- fmap (map fst . concat) $ + runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $ + [ That (), This (), That () ] + return () + +testQueryT :: (Reflex t, MonadFix m) + => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ()) + -> AppIn t () (These () ()) + -> m (AppOut t Int Int) +testQueryT w (AppIn _ pulse) = do + let replace = fmapMaybe (^? here) pulse + increment = fmapMaybe (^? there) pulse + (_, q) <- runQueryT (w replace increment) $ pure mempty + let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q + return $ AppOut + { _appOut_behavior = current qDyn + , _appOut_event = updated qDyn + } + +testRunWithReplace :: ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + , MonadQuery t (Selector Int MyQuery) m) + => Event t () + -> Event t () + -> m () +testRunWithReplace replace increment = do + let w = do + n <- count increment + queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1 + _ <- runWithReplace w $ w <$ replace + return () + +testSequenceDMapWithAdjust :: ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + , MonadQuery t (Selector Int MyQuery) m) + => Event t () + -> Event t () + -> m () +testSequenceDMapWithAdjust replace increment = do + _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do + n <- count increment + queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1 + return () + +testSequenceDMapWithAdjustWithMove :: ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + , MonadQuery t (Selector Int MyQuery) m) + => Event t () + -> Event t () + -> m () +testSequenceDMapWithAdjustWithMove replace increment = do + _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do + n <- count increment + queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1 + return () + +-- scam it out to test traverseDMapWithAdjustWithMove +listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, Adjustable t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a)) +listHoldWithKeyWithMove m0 m' f = do + (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing) + incrementalToDynamic <$> holdIncremental n0 n' +-- -} diff --git a/test/Reflex/Bench/Focused.hs b/test/Reflex/Bench/Focused.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Bench/Focused.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Reflex.Bench.Focused where + +import Reflex +import Reflex.TestPlan + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Identity +import Data.Traversable (for, traverse) + +import qualified Data.Dependent.Map as DMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe + +import Data.Functor.Misc + +import Data.List +import Data.List.Split +import Data.Tuple + +import Data.Monoid +import Data.Word + +import Control.DeepSeq + +import Prelude hiding (concat, sum) + + +mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a +mergeTree n es | length es <= n = sum' es + | otherwise = mergeTree n subTrees + where + merges = chunksOf n es + subTrees = map sum' merges + sum' = fmap sum . mconcat . fmap (fmap (:[]) ) + +mergeListDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a] +mergeListDyn = mconcat . fmap (fmap pure) + +mergeTreeDyn :: (Num a, Reflex t) => Int -> [Dynamic t a] -> Dynamic t a +mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns + | otherwise = mergeTreeDyn n $ fmap sumDyns merges + where + merges = chunksOf n dyns + sumDyns = fmap sum . mergeListDyn + + + +-- N events all firing for N frames +continuous :: TestPlan t m => Word -> Word -> m [Event t Word] +continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames] + +-- Fire N events once every P frames for total N frames (interspersed evenly) +occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word] +occasional n period frames = traverse plan $ zipWith occs [1..] phases + where + phases = take (fromIntegral n) $ concat (repeat [1..period]) + occs i phase = (, i) <$> [1, phase+1..frames] + + + +-- Event which never fires (but isn't 'never') +never' :: TestPlan t m => m (Event t Word) +never' = plan [] + + +-- Event which fires once on first frame +event :: TestPlan t m => m (Event t Word) +event = plan [(1, 0)] + +-- Event which fires constantly over N frames +events :: TestPlan t m => Word -> m (Event t Word) +events n = plan $ (\i -> (i, i)) <$> [1..n] + + +-- N events all originating from one event +fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word] +fmapFan n e = (\i -> (+i) <$> e) <$> [1..n] + + +-- Make a fan using the value in the event converting it to a singleton Map +-- use a fan of size n (key is the value mod n) +fanMerge :: Reflex t => Word -> Event t Word -> Event t Word +fanMerge n e = leftmost $ s <$> [0..n - 1] where + s k = select f (Const2 k) + f = fan (toMap <$> e) + toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k) + +-- Dumb version of the above using simple fmapMaybe to filter +fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word +fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where + s k = flip fmapMaybe e $ \j -> if k == j `mod` n + then Just k + else Nothing + + + +-- Create an Event with a Map which is dense to size N +denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word)) +denseMap n = plan [(1, m)] where + m = Map.fromList $ zip [1..n] [1..n] + +iter :: (a -> a) -> Word -> a -> a +iter _ 0 a = a +iter f n a = iter f (n - 1) (f a) + +iterM :: Monad m => (a -> m a) -> Word -> a -> m a +iterM _ 0 a = return a +iterM f n a = iterM f (n - 1) =<< f a + +fmapChain :: (Functor f) => Word -> f Word -> f Word +fmapChain = iter (fmap (+1)) + +mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) +mapDynChain = iterM (return . fmap (+1)) + +joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) +joinDynChain = iterM (\d -> return $ join $ fmap (const d) d) + +combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) +combineDynChain = iterM (\d -> return $ zipDynWith (+) d d) + +pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a) +pingPong e1 e2 = do + rec + d <- foldDyn (const swap) (e1, e2) e + let e = switch (fst <$> current d) + return e + +switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word) +switchFactors 0 e = return e +switchFactors i e = do + b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e) + switchFactors (i - 1) (switch b) + + +switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word) +switchChain = iterM (\e -> pingPong e ((+1) <$> e)) + + +switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word) +switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e])) + +switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word) +switchPromptlyChain = iterM $ \e -> + switchPromptlyDyn <$> holdDyn e (e <$ e) + + +coinChain :: Reflex t => Word -> Event t Word -> Event t Word +coinChain = iter $ \e -> coincidence (e <$ e) + +fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word +fanMergeChain width = iter $ fanMerge width + +fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word +fmapFanMergeChain width = iter $ fmapFanMerge width + +-- | Data type for a collection (a map) which is updated by providing differences +data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a))) + +-- This will hopefully become a primitive (faster!) +switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a)) +switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges + +-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a)) +-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes) + +switchMergeBehaviors :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Behavior t a) -> m (Behavior t (Map k a)) +switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges + where joinMap m = traverse sample =<< sample m + +-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value +holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a)) +holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes + + where + modify k Nothing items = Map.delete k items + modify k (Just item) items = Map.insert k item items + + +-- | Hold an UpdatedMap as a behavior by applying differences to the initial value +holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a)) +holdMap = (current <$>) . holdMapDyn + + +increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a) +increasingMerge xs = do + e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset]) + return (UpdatedMap Map.empty e) + where + reset = Map.fromList $ zip [1..] (const Nothing <$> xs) + +decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a) +decreasingMerge xs = do + e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset]) + return (UpdatedMap initial e) + where + initial = Map.fromList $ zip [1..] xs + reset = Just <$> initial + +modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a) +modifyMerge xs = do + e <- planList $ zipWith Map.singleton [1..] (Just <$> xs) + return (UpdatedMap initial e) + where + initial = Map.fromList $ zip [1..] xs + + +countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int] +countMany = traverse (fmap current . count) + +countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int] +countManyDyn = traverse count + + +-- Given a function which creates a sub-network (from a single event) +-- Create a plan which uses a switch to substitute it +switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a) +switches numFrames f = do + es <- events numFrames + switch <$> hold never (makeEvents es) + + where + makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es + + + +-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames) +-- the other, which we're only interested in time for running frames +subscribing :: Word -> Word -> [(String, TestCase)] +subscribing n frames = + [ testSub "fmapFanMerge" $ return . mergeList . fmapFan n + , testSub "fanMerge" $ return . fanMerge n + , testSub "fmapFan/mergeTree" $ return . mergeTree 8 . fmapFan n + , testSub "fmapChain" $ return . fmapChain n + , testSub "switchChain" $ switchChain n + , testSub "switchPromptlyChain" $ switchPromptlyChain n + , testSub "switchFactors" $ switchFactors n + , testSub "coincidenceChain" $ return . coinChain n + ] + + where + testSub :: (Eq a, Show a, NFData a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase) + testSub name test = testE name (switches frames test) + +-- Set of benchmark to test specifically merging dynamic collections +-- a pattern which occurs frequently in reflex-dom collections +merging :: Word -> [(String, TestCase)] +merging n = + [ testE "static events" $ mergeList <$> sparse + , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse + , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse + , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse + + , testB "static behaviors" $ pull . traverse sample <$> counters + , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters + , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters + , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters + + + -- , testE "increasing events/switchMerge" $ switchMergeMaybe =<< increasingMerge =<< sparse + -- , testE "decreasing events/switchMerge" $ switchMergeMaybe =<< decreasingMerge =<< sparse + -- , testE "modify events/switchMerge" $ switchMergeMaybe =<< modifyMerge =<< sparse + ] + + where + sparse :: TestPlan t m => m [Event t Word] + sparse = fmap (fmap (+1)) <$> occasional n 8 n + + counters :: TestPlan t m => m [Behavior t Int] + counters = countMany =<< sparse + + + +fans :: Word -> [(String, TestCase)] +fans n = + [ testE "fanMapChain" $ fanMergeChain n 10 <$> e + , testE "fmapFanMapChain" $ fmapFanMergeChain n 10 <$> e + + , testE "fanMerge " $ fanMerge n <$> events n + + , testE "fmapFanMerge " $ fmapFanMerge n <$> events n + , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)]) + + ] + where + + e :: TestPlan t m => m (Event t Word) + e = events 100 + + + + +dynamics :: Word -> [(String, TestCase)] +dynamics n = + [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d + , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d + , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d + , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense + , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse + , testE "mergeDyn" $ fmap (updated . fmap sum . mergeListDyn) sparse + ] where + + d :: TestPlan t m => m (Dynamic t Word) + d = count =<< events 10 + + sparse, dense :: TestPlan t m => m [Dynamic t Int] + sparse = countManyDyn =<< occasional n 8 16 + dense = countManyDyn =<< continuous n 2 + + +firing :: Word -> [(String, TestCase)] +firing n = + [ testE "fmapChain" $ fmapChain n <$> e + , testE "switchChain2" $ switchChain2 n =<< e + , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e + , testE "switchFactors" $ switchFactors n =<< e + , testE "coincidenceChain" $ coinChain n <$> e + + , testE "dense mergeTree" $ mergeTree 8 <$> dense + , testE "sparse mergeTree" $ mergeTree 8 <$> sparse + + -- Triggers test failure in Spider + --, testE "runFrame" $ events n + + , testB "sum counters" $ do + counts <- counters + return $ pull $ sum <$> traverse sample counts + + , testB "pullChain" $ fmapChain n . current <$> (count =<< events 4) + , testB "pullChain2" $ do + es <- events 4 + e' <- plan [(0, ())] + + b <- hold (constant 0) $ + pushAlways (const $ fmapChain n <$> hold 0 es) e' + + return (join b) + , testB "counters/pullTree" $ mergeTree 8 <$> counters + + ] + where + e :: TestPlan t m => m (Event t Word) + e = events 10 + + dense, sparse :: TestPlan t m => m [Event t Word] + dense = continuous n 2 + sparse = occasional n 8 16 + + counters :: TestPlan t m => m [Behavior t Int] + counters = countMany =<< sparse + + + + + diff --git a/test/Reflex/Plan/Pure.hs b/test/Reflex/Plan/Pure.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Plan/Pure.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Reflex.Plan.Pure where + +import Reflex +import Reflex.Pure +import Reflex.TestPlan + +import Control.Applicative +import Control.Monad.Fix +import Control.Monad.State +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Data.Bifunctor +import Data.Maybe +import Data.Monoid +import Prelude + + +mapToPureEvent :: IntMap a -> Event (Pure Int) a +mapToPureEvent m = Event $ flip IntMap.lookup m + +type TimeM = (->) Int +newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix) + +liftPlan :: TimeM a -> PurePlan a +liftPlan = PurePlan . lift + +instance MonadHold (Pure Int) PurePlan where + hold initial = liftPlan . hold initial + holdDyn initial = liftPlan . holdDyn initial + holdIncremental initial = liftPlan . holdIncremental initial + buildDynamic getInitial = liftPlan . buildDynamic getInitial + headE = liftPlan . headE + +instance MonadSample (Pure Int) PurePlan where + sample = liftPlan . sample + + +instance TestPlan (Pure Int) PurePlan where + plan occs = do + PurePlan . modify $ IntSet.union (IntMap.keysSet m) + return $ mapToPureEvent m + where m = IntMap.fromList (first fromIntegral <$> occs) + +runPure :: PurePlan a -> (a, IntSet) +runPure (PurePlan p) = runStateT p mempty $ 0 + +relevantTimes :: IntSet -> IntSet +relevantTimes occs = IntSet.fromList [0..l + 1] + where l = fromMaybe 0 (fst <$> IntSet.maxView occs) + +testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a +testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs) + +testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a) +testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs) + + + + + + diff --git a/test/Reflex/Plan/Reflex.hs b/test/Reflex/Plan/Reflex.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Plan/Reflex.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.Plan.Reflex + ( TestPlan(..) + , runPlan + , Plan (..) + , Schedule + , Firing (..) + , MonadIORef + + + , readSchedule + , readSchedule_ + , testSchedule + , readEvent' + , makeDense + + , runTestE + , runTestB + + ) where + +import Reflex.Class +import Reflex.Host.Class +import Reflex.TestPlan + +import Control.Applicative +import Control.Monad +import Control.Monad.Identity +import Control.Monad.State.Strict + +import Control.Monad.Ref +import Data.Dependent.Sum (DSum (..)) +import qualified Data.IntMap.Strict as IntMap +import Data.Maybe +import Data.Monoid +import Data.Traversable (sequenceA, traverse) + +import Control.DeepSeq +import Control.Exception +import Data.IntMap.Strict (IntMap) +import Data.IORef +import System.Mem + +-- Note: this import must come last to silence warnings from AMP +import Prelude + +type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO) + +data Firing t where + Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t + + +type Schedule t = IntMap [Firing t] + +-- Implementation of a TestPlan in terms of ReflexHost +newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a) + +deriving instance ReflexHost t => Functor (Plan t) +deriving instance ReflexHost t => Applicative (Plan t) +deriving instance ReflexHost t => Monad (Plan t) + +deriving instance ReflexHost t => MonadSample t (Plan t) +deriving instance ReflexHost t => MonadHold t (Plan t) +deriving instance ReflexHost t => MonadFix (Plan t) + + +instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where + plan occurrences = Plan $ do + (e, ref) <- newEventWithTriggerRef + modify (IntMap.unionWith mappend (firings ref)) + return e + + where + firings ref = IntMap.fromList (makeFiring ref <$> occurrences) + makeFiring ref (t, a) = (fromIntegral t, [Firing ref a]) + + +firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity)) +firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref + +runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t) +runPlan (Plan p) = runHostFrame $ runStateT p mempty + + +makeDense :: Schedule t -> Schedule t +makeDense s = fromMaybe (emptyRange 0) $ do + (end, _) <- fst <$> IntMap.maxViewWithKey s + return $ IntMap.union s (emptyRange end) + where + emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat [])) + + +-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors +-- after the last event) +-- performGC is called at each frame to test for GC issues +testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a) +testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule) + +readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a) +readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule + +readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m () +readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule + +triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a +triggerFrame readResult _ occs = do + triggers <- catMaybes <$> traverse firingTrigger occs + liftIO . evaluate . force =<< fireEventsAndRead triggers readResult + +readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a) +readEvent' = readEvent >=> sequenceA + + +-- Convenience functions for running tests producing Events/Behaviors +runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a) +runTestB p = do + (b, s) <- runPlan p + testSchedule s $ sample b + +runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a)) +runTestE p = do + (e, s) <- runPlan p + h <- subscribeEvent e + testSchedule s (readEvent' h) + + diff --git a/test/Reflex/Pure.hs b/test/Reflex/Pure.hs deleted file mode 100644 --- a/test/Reflex/Pure.hs +++ /dev/null @@ -1,76 +0,0 @@ -{- | This module provides a pure implementation of Reflex, which is intended -to serve as a reference for the semantics of the Reflex class. All implementations -of Reflex should produce the same results as this implementation, although performance -and laziness/strictness may differ. --} - -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls, InstanceSigs #-} -module Reflex.Pure where - -import Reflex.Class -import Data.Functor.Misc -import Control.Monad.Identity -import Control.Monad -import Data.MemoTrie -import Data.Dependent.Map (DMap, GCompare) -import qualified Data.Dependent.Map as DMap - -data Pure t - --- | The Enum instance of t must be dense: for all x :: t, there must not exist --- any y :: t such that pred x < y < x. The HasTrie instance will be used exclusively --- to memoize functions of t, not for any of its other capabilities. -instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where - - newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a } - newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a } - - type PushM (Pure t) = (->) t - type PullM (Pure t) = (->) t - - never :: Event (Pure t) a - never = Event $ \_ -> Nothing - - constant :: a -> Behavior (Pure t) a - constant x = Behavior $ \_ -> x - - push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b - push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t - - pull :: PullM (Pure t) a -> Behavior (Pure t) a - pull = Behavior . memo - - merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity) - merge events = Event $ memo $ \t -> - let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events - in if DMap.null currentOccurrences - then Nothing - else Just currentOccurrences - - fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k - fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k - - switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a - switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t - - coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a - coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t - -instance Ord t => MonadSample (Pure t) ((->) t) where - - sample :: Behavior (Pure t) a -> (t -> a) - sample = unBehavior - -instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where - - hold :: a -> Event (Pure t) a -> (t -> (Behavior (Pure t) a)) - hold initialValue e initialTime = Behavior f - where f = memo $ \sampleTime -> - -- Really, the sampleTime should never be prior to the initialTime, - -- because that would mean the Behavior is being sampled before being created. - if sampleTime <= initialTime - then initialValue - else let lastTime = pred sampleTime - in case unEvent e lastTime of - Nothing -> f lastTime - Just x -> x diff --git a/test/Reflex/Test.hs b/test/Reflex/Test.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Test.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Reflex.Test + ( testAgreement + , compareResult + , runTests + + , module Reflex.TestPlan + + ) where + +import Reflex.Spider + +import Reflex.TestPlan + +import Reflex.Plan.Pure +import Reflex.Plan.Reflex + +import Control.Monad +import Data.Monoid + +import Data.IntMap (IntMap) + +--import Data.Foldable +import System.Exit + +import Prelude + + +testAgreement :: TestCase -> IO Bool +testAgreement (TestE p) = do + spider <- runSpiderHost $ runTestE p + let results = [("spider", spider)] + + compareResult results (testEvent $ runPure p) + +testAgreement (TestB p) = do + spider <- runSpiderHost $ runTestB p + let results = [("spider", spider)] + + compareResult results (testBehavior $ runPure p) + + +compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool +compareResult results expected = fmap and $ forM results $ \(name, r) -> do + + when (r /= expected) $ do + putStrLn ("Got: " ++ show (name, r)) + putStrLn ("Expected: " ++ show expected) + return (r == expected) + + +runTests :: [(String, TestCase)] -> IO () +runTests testCases = do + results <- forM testCases $ \(name, test) -> do + putStrLn $ "Test: " <> name + testAgreement test + exitWith $ if and results + then ExitSuccess + else ExitFailure 1 + diff --git a/test/Reflex/Test/CrossImpl.hs b/test/Reflex/Test/CrossImpl.hs --- a/test/Reflex/Test/CrossImpl.hs +++ b/test/Reflex/Test/CrossImpl.hs @@ -1,27 +1,39 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, BangPatterns, ConstraintKinds #-} -module Reflex.Test.CrossImpl (test) where +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl, and) +import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_) +import Control.Monad.Ref import Reflex.Class -import Reflex.Host.Class import Reflex.Dynamic -import qualified Reflex.Spider.Internal as S +import Reflex.Host.Class import qualified Reflex.Pure as P -import Control.Monad.Ref +import qualified Reflex.Spider.Internal as S -import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import qualified Data.Set as Set +import Control.Arrow (second, (&&&)) +import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Dependent.Map (DSum (..)) +import Data.Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Control.Arrow (second, (&&&)) +import qualified Data.Set as Set +import Data.Monoid import Data.Traversable -import Data.Foldable -import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Control.Monad.Writer hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Data.Dependent.Map (DSum (..)) -import System.Mem import System.Exit +import System.Mem import System.IO.Unsafe @@ -73,7 +85,7 @@ outputs <- forM times $ \t -> do forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger bOutput <- sample b' - eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do + eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do mret <- readRef reTrigger let firing = case mret of Just ret -> [ret :=> Identity val] @@ -81,7 +93,7 @@ fireEventsAndRead firing $ sequence =<< readEvent e'Handle liftIO performGC return (t, (bOutput, eOutput)) - return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs) + return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs) tracePerf :: Show a => a -> b -> b tracePerf = flip const @@ -94,8 +106,9 @@ tracePerf "---------" $ return () let resultsAgree = identityResult == spiderResult if resultsAgree - then do putStrLn "Success:" - print identityResult + then do --putStrLn "Success:" + --print identityResult + return () else do putStrLn "Failure:" putStrLn $ "Pure result: " <> show identityResult putStrLn $ "Spider result: " <> show spiderResult @@ -111,11 +124,11 @@ b' <- hold "123" e return (b', e) , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do - e' <- liftM updated $ count e + e' <- updated <$> count e b' <- hold (0 :: Int) e' return (b', e') - , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do - e' <- onceE $ leftmost [e, e] + , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do + e' <- headE $ leftmost [e, e] return (b, e') , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = fmap (const e) e @@ -124,56 +137,52 @@ return (b, e'') , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = flip pushAlways e $ const $ do - let ea = fmap (const "a") e - let eb = fmap (const "b") e - let eab = leftmost [ea, eb] - liftM switch $ hold eab never + let eab = splitRecombineEvent e + switch <$> hold eab never e'' = coincidence e' return (b, e'') , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = flip pushAlways e $ const $ do - let ea = fmap (const "a") e - let eb = fmap (const "b") e - let eab = leftmost [ea, eb] - liftM switch $ hold eab (fmap (const e) e) + let eab = splitRecombineEvent e + switch <$> hold eab (fmap (const e) e) e'' = coincidence e' return (b, e'') , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = leftmost [e, e] - e'' <- liftM switch $ hold e' (fmap (const e) e) + e'' <- switch <$> hold e' (fmap (const e) e) return (b, e'') - , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do + , (,) "switchHoldPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = fmap (const e) e - e'' <- switchPromptly never e' + e'' <- switchHoldPromptly never e' return (b, e'') - , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do + , (,) "switchHoldPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = fmap (const e) e - e'' <- switchPromptly never $ leftmost [e', e'] + e'' <- switchHoldPromptly never $ leftmost [e', e'] return (b, e'') - , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do + , (,) "switchHoldPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = leftmost [e, e] - e'' <- switchPromptly never (fmap (const e) e') + e'' <- switchHoldPromptly never (fmap (const e) e') return (b, e'') - , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do + , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do let e' = leftmost [e, e] - e'' <- switchPromptly never (fmap (const e') e) + e'' <- switchHoldPromptly never (fmap (const e') e) return (b, e'') , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = leftmost [e, e] - e'' <- liftM switch $ hold never (fmap (const e') e) + e'' <- switch <$> hold never (fmap (const e') e) return (b, e'') - , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do + , (,) "switchHoldPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = flip push e $ \_ -> do - return . Just =<< onceE e - e'' <- switchPromptly never e' + Just <$> headE e + e'' <- switchHoldPromptly never e' return (b, e'') - , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do + , (,) "switchHoldPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do let e' = flip pushAlways e $ \_ -> do - switchPromptly e never - e'' <- switchPromptly never e' + switchHoldPromptly e never + e'' <- switchHoldPromptly never e' return (b, e'') , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do - let e' = flip pushAlways e $ \_ -> return $ fmap id e + let e' = flip pushAlways e $ \_ -> return e e'' = coincidence e' return (b, e'') , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do @@ -185,7 +194,7 @@ e'' = coincidence e' return (b, e'') , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do - let e' = flip pushAlways e $ \_ -> onceE e + let e' = flip pushAlways e $ \_ -> headE e e'' = coincidence e' return (b, e'') , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do @@ -205,21 +214,41 @@ eCoincidences = coincidence $ fmap (const e') e return (b, eCoincidences) , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do - eo <- onceE e + eo <- headE e bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo let b' = pull $ sample =<< sample bb return (b', e) , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do bb <- hold "b" e - bd <- hold never . fmap (const e) =<< onceE e - eOuter <- liftM (pushAlways sample . fmap (const bb)) $ onceE e + bd <- hold never . fmap (const e) =<< headE e + eOuter <- pushAlways sample . fmap (const bb) <$> headE e let eInner = switch bd e' = leftmost [eOuter, eInner] return (b, e') + , (,) "holdUniqDyn-laziness" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList (zip [1 :: Int ..] [1 :: Int, 2, 2, 3, 3, 3, 4, 4, 4, 4])) $ \(_, e :: Event t Int) -> do + rec result <- holdUniqDyn d + d <- holdDyn (0 :: Int) e + return (current result, updated result) + + + + {- + , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do + x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e + let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity) + return (b, e') + -} ] -test :: IO () -test = do +splitRecombineEvent :: Reflex t => Event t a -> Event t String +splitRecombineEvent e = + let ea = "a" <$ e + eb = "b" <$ e + in leftmost [ea, eb] + + +main :: IO () +main = do results <- forM testCases $ \(name, TestCase inputs builder) -> do putStrLn $ "Test: " <> name testAgreement builder inputs diff --git a/test/Reflex/Test/Micro.hs b/test/Reflex/Test/Micro.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Test/Micro.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} + +module Reflex.Test.Micro (testCases) where + +import Reflex +import Reflex.TestPlan + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Char +import Data.Foldable +import Data.Functor.Misc +import qualified Data.Map as Map +import Data.Monoid + +import Prelude + +pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b) +pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d)) + +foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a) +foldedDyn f d = fmap join $ flip buildDynamic never $ do + a <- sample (current d) + foldDyn f a (updated d) + +scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a]) +scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure + +scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a]) +scanInnerDyns d = do + scans <- scannedDyn d + return (join (fmap distributeListOverDynPure scans)) + + + +{-# ANN testCases "HLint: ignore Functor law" #-} +testCases :: [(String, TestCase)] +testCases = + [ testB "hold" $ hold "0" =<< events1 + + , testB "count" $ do + b <- current <$> (count =<< events2) + return $ (+ (0::Int)) <$> b + + , testB "pull-1" $ do + b <- hold "0" =<< events1 + return (pull $ sample $ pull $ sample b) + + , testB "pull-2" $ do + b1 <- behavior1 + return (pull $ liftA2 (<>) (sample b1) (sample b1)) + + , testB "pull-3" $ do + b1 <- behavior1 + b2 <- behavior2 + return (pull $ liftA2 (<>) (sample b1) (sample b2)) + + , testB "pull-4" $ do + es <- planList ["a", "b", "c"] + e <- plan [(0, ())] + b <- hold (constant "") $ + pushAlways (const $ hold "z" es) e + return (join b) + + , testE "id" $ do + events2 + + , testE "fmap-id" $ do + e <- events2 + return $ fmap id e + + , testE "tag-1" $ do + b1 <- behavior1 + e <- events2 + return (tag b1 e) + + , testE "tag-2" $ do + b1 <- behavior1 + e <- events2 + return (tag (map toUpper <$> b1) e) + + , testE "attach-1" $ do + b1 <- behavior1 + e <- events2 + return (attachWith (++) (map toUpper <$> b1) e) + + , testE "leftmost" $ liftA2 leftmost2 events1 events2 + + , testE "appendEvents-1" $ liftA2 mappend events1 events2 + + , testE "appendEvents-2" $ liftA2 mappend events3 events2 + + , testE "merge-1" $ do + e <- events1 + return $ leftmost ["x" <$ e, "y" <$ e] + + , testE "merge-2" $ do + e <- events1 + let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)] + let ee = flip pushAlways e $ const $ return m + return $ coincidence ee + + , testE "headE-1" $ do + e <- events1 + headE $ leftmost [e, e] + + , testE "headE-2" $ do + e <- events1 + b <- hold never (e <$ e) + headE $ switch b + + , testE "switch-1" $ do + e <- events1 + b <- hold never (e <$ e) + return $ switch b + + , testE "switch-2" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ const $ do + switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e) + + , testE "switch-3" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ const $ do + switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never + + , testE "switch-4" $ do + e <- events1 + switch <$> hold (deep e) (e <$ e) + + , testE "switch-5" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ const $ + return $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e] + + , testE "switch-6" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ const $ do + switch <$> hold ("x" <$ e) (e <$ e) + + , testE "switchHoldPromptly-1" $ do + e <- events1 + let e' = e <$ e + switchHoldPromptly never $ e <$ e' + + , testE "switchHoldPromptly-2" $ do + e <- events1 + switchHoldPromptly never $ deep (e <$ e) + + , testE "switchHoldPromptly-3" $ do + e <- events1 + switchHoldPromptly never $ (e <$ deep e) + + , testE "switchHoldPromptly-4" $ do + e <- events1 + switchHoldPromptly never $ (deep e <$ e) + + , testE "switch-5" $ do + e <- events1 + switch <$> hold never (deep e <$ e) + + , testE "switchHoldPromptly-5" $ do + e <- events1 + switchHoldPromptly never $ flip push e $ + const (Just <$> headE e) + + , testE "switchHoldPromptly-6" $ do + e <- events1 + switchHoldPromptly never $ flip pushAlways e $ + const (switchHoldPromptly e never) + + , testE "coincidence-1" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ + const $ return e + + , testE "coincidence-2" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ + const $ return (deep e) + + , testE "coincidence-3" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ + const $ return (coincidence (e <$ e)) + + , testE "coincidence-4" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ + const (headE e) + + , testE "coincidence-5" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ const $ do + let e' = deep e + return (coincidence (e' <$ e')) + + , testE "coincidence-6" $ do + e <- events1 + return $ coincidence $ flip pushAlways e $ const $ do + let e' = coincidence (e <$ e) + return $ deep e' + + , testE "coincidence-7" $ do + e <- events1 + return $ coincidence (deep e <$ e) + + , testB "holdWhileFiring" $ do + e <- events1 + eo <- headE e + bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo + return $ pull $ sample =<< sample bb + + + , testB "foldDynWhileFiring" $ do + e <- events1 + d <- foldDyn (:) [] $ + pushAlways (\a -> foldDyn (:) [a] e) e + + return $ current (join (fmap distributeListOverDynPure d)) + + , testE "joinDyn" $ do + e <- events1 + bb <- hold "b" e + bd <- hold never . fmap (const e) =<< headE e + + eOuter <- pushAlways sample . fmap (const bb) <$> headE e + let eInner = switch bd + return $ leftmost [eOuter, eInner] + + , testB "foldDyn" $ do + d <- foldDyn (++) "0" =<< events1 + return (current d) + + , testB "mapDyn" $ do + d <- foldDyn (++) "0" =<< events1 + return $ current $ fmap (map toUpper) d + + , testB "combineDyn" $ do + d1 <- foldDyn (++) "0" =<< events1 + d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2 + + return $ current $ zipDynWith (<>) d1 d2 + + , testB "buildDynamicStrictness" $ do + rec + d'' <- pushDyn return d' + d' <- pushDyn return d + d <- holdDyn "0" =<< events1 + + _ <- sample (current d'') + return (current d'') + + , testB "factorDyn" $ do + d <- holdDyn (Left "a") =<< eithers + + eithers' <- eitherDyn d + let unFactor = either id id + return $ current (join (fmap unFactor eithers')) + + , testB "pushDynDeep" $ do + _ <- events1 + _ <- events2 + + d1 <- holdDyn "d1" =<< events1 + d2 <- holdDyn "d2" =<< events2 + + d <- flip pushDyn d1 $ \a -> + flip pushDyn d2 $ \b -> + flip pushDyn d1 $ \c -> + return (a <> b <> c) + + d' <- pushDyn scanInnerDyns d >>= scanInnerDyns + return $ current d' + + , testE "fan-1" $ do + e <- fmap toMap <$> events1 + let es = select (fanMap e) . Const2 <$> values + + return (mergeList es) + + , testE "fan-2" $ do + e <- fmap toMap <$> events3 + let es = select (fanMap e) . Const2 <$> values + + return (mergeList es) + + , testE "fan-3" $ do + f <- fanMap . fmap toMap <$> events3 + return $ select f (Const2 'c') + + , testE "fan-4" $ do + e <- fmap toMap <$> events1 + return $ toUpper <$> select (fanMap e) (Const2 'a') + + , testE "fan-5" $ do + e <- fmap toMap <$> events2 + return $ toUpper <$> select (fanMap e) (Const2 'c') + + , testE "fan-6" $ do + f <- fanMap . fmap toMap <$> events1 + return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ] + + , testE "difference" $ do + e1 <- events1 + e2 <- events2 + return $ e1 `difference ` e2 + + , testE "lazy-hold" $ do + let lazyHold :: forall t m. (Reflex t, MonadHold t m, MonadFix m) => m (Event t ()) + lazyHold = do + rec !b <- hold never e + let e = never <$ switch b + return $ void e + lazyHold + + + ] where + + events1, events2, events3 :: TestPlan t m => m (Event t String) + events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")] + events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")] + events3 = liftA2 mappend events1 events2 + + eithers :: TestPlan t m => m (Event t (Either String String)) + eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")] + + + values = "abcde" + toMap str = Map.fromList $ map (\c -> (c, c)) str + + behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String) + behavior1 = hold "1" =<< events1 + behavior2 = hold "2" =<< events2 + + deep e = leftmost [e, e] + leftmost2 e1 e2 = leftmost [e1, e2] diff --git a/test/Reflex/TestPlan.hs b/test/Reflex/TestPlan.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/TestPlan.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.TestPlan + ( TestPlan(..) + + , TestCase (..) + , testE, testB + , TestE, TestB + + , planList + + ) where + +import Control.DeepSeq +import Control.Monad.Fix +import Data.Word +import Reflex.Class + + +import Prelude + +class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where + -- | Specify a plan of an input Event firing + -- Occurrences must be in the future (i.e. Time > 0) + -- Initial specification is + + plan :: [(Word, a)] -> m (Event t a) + + +planList :: TestPlan t m => [a] -> m (Event t a) +planList xs = plan $ zip [1..] xs + +type TestE a = forall t m. TestPlan t m => m (Event t a) +type TestB a = forall t m. TestPlan t m => m (Behavior t a) + +data TestCase where + TestE :: (Show a, Eq a, NFData a) => TestE a -> TestCase + TestB :: (Show a, Eq a, NFData a) => TestB a -> TestCase + +-- Helpers to declare test cases +testE :: (Eq a, Show a, NFData a) => String -> TestE a -> (String, TestCase) +testE name test = (name, TestE test) + +testB :: (Eq a, Show a, NFData a) => String -> TestB a -> (String, TestCase) +testB name test = (name, TestB test) + diff --git a/test/RequesterT.hs b/test/RequesterT.hs new file mode 100644 --- /dev/null +++ b/test/RequesterT.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.Lens +import Control.Monad +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.These + +import Reflex +import Reflex.Requester.Base +import Reflex.Requester.Class +import Test.Run + +data RequestInt a where + RequestInt :: Int -> RequestInt Int + +main :: IO () +main = do + os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $ + [ Just () + ] + print os1 + os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] + <- runApp' (unwrapApp testSimultaneous) $ map Just $ + [ This () + , That () + , This () + , These () () + ] + print os2 + return () + +unwrapRequest :: DSum tag RequestInt -> Int +unwrapRequest (_ :=> RequestInt i) = i + +unwrapApp :: ( Reflex t, Monad m ) + => (a -> RequesterT t RequestInt Identity m ()) + -> a + -> m (Event t [Int]) +unwrapApp x appIn = do + ((), e) <- runRequesterT (x appIn) never + return $ fmap (map unwrapRequest . DMap.toList) e + +testOrdering :: ( Response m ~ Identity + , Request m ~ RequestInt + , Requester t m + , Adjustable t m) + => Event t () + -> m () +testOrdering pulse = forM_ [10,9..1] $ \i -> + requestingIdentity (RequestInt i <$ pulse) + +testSimultaneous :: ( Response m ~ Identity + , Request m ~ RequestInt + , Requester t m + , Adjustable t m) + => Event t (These () ()) + -> m () +testSimultaneous pulse = do + let tellE = fmapMaybe (^? here) pulse + switchE = fmapMaybe (^? there) pulse + forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ -> + requestingIdentity (RequestInt (i+1) <$ tellE) diff --git a/test/Test/Run.hs b/test/Test/Run.hs new file mode 100644 --- /dev/null +++ b/test/Test/Run.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +module Test.Run where + +import Control.Monad +import Control.Monad.Ref +import Data.Dependent.Sum +import Data.Functor.Identity +import Data.These + +import Reflex +import Reflex.Host.Class + +data AppIn t b e = AppIn + { _appIn_behavior :: Behavior t b + , _appIn_event :: Event t e + } + +data AppOut t b e = AppOut + { _appOut_behavior :: Behavior t b + , _appOut_event :: Event t e + } + +runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) + => (AppIn t bIn eIn -> PerformEventT t m (AppOut t bOut eOut)) + -> bIn + -> [Maybe (These bIn eIn)] + -> IO [[(bOut, Maybe eOut)]] +runApp app b0 input = runSpiderHost $ do + (appInHoldE, pulseHoldTriggerRef) <- newEventWithTriggerRef + (appInE, pulseEventTriggerRef) <- newEventWithTriggerRef + appInB <- hold b0 appInHoldE + (out, FireCommand fire) <- hostPerformEventT $ app $ AppIn + { _appIn_event = appInE + , _appIn_behavior = appInB + } + hnd <- subscribeEvent (_appOut_event out) + mpulseB <- readRef pulseHoldTriggerRef + mpulseE <- readRef pulseEventTriggerRef + let readPhase = do + b <- sample (_appOut_behavior out) + frames <- sequence =<< readEvent hnd + return (b, frames) + forM input $ \case + Nothing -> + fire [] $ readPhase + Just i -> case i of + This b' -> case mpulseB of + Nothing -> error "tried to fire in-behavior but ref was empty" + Just pulseB -> fire [ pulseB :=> Identity b' ] $ readPhase + That e' -> case mpulseE of + Nothing -> error "tried to fire in-event but ref was empty" + Just pulseE -> fire [ pulseE :=> Identity e' ] $ readPhase + These b' e' -> case mpulseB of + Nothing -> error "tried to fire in-behavior but ref was empty" + Just pulseB -> case mpulseE of + Nothing -> error "tried to fire in-event but ref was empty" + Just pulseE -> fire [ pulseB :=> Identity b', pulseE :=> Identity e' ] $ readPhase + +runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) + => (Event t eIn -> PerformEventT t m (Event t eOut)) + -> [Maybe eIn] + -> IO [[Maybe eOut]] +runApp' app input = do + let app' = fmap (AppOut (pure ())) . app + map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input) + +runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) + => (Event t eIn -> PerformEventT t m (Behavior t bOut)) + -> [Maybe eIn] + -> IO [[bOut]] +runAppB app input = do + let app' = fmap (flip AppOut never) . app + map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input) diff --git a/test/hlint.hs b/test/hlint.hs new file mode 100644 --- /dev/null +++ b/test/hlint.hs @@ -0,0 +1,44 @@ +module Main where + +import Control.Monad +import Language.Haskell.HLint3 (hlint) +import System.Directory +import System.Exit (exitFailure, exitSuccess) +import System.FilePath +import System.FilePath.Find + +main :: IO () +main = do + pwd <- getCurrentDirectory + let runHlint f = hlint $ f: + [ "--ignore=Redundant do" + , "--ignore=Use camelCase" + , "--ignore=Redundant $" + , "--ignore=Use &&" + , "--ignore=Use &&&" + , "--ignore=Use const" + , "--ignore=Use >=>" + , "--ignore=Use ." + , "--ignore=Use unless" + , "--ignore=Reduce duplication" + , "--cpp-define=USE_TEMPLATE_HASKELL" + ] + recurseInto = and <$> sequence + [ fileType ==? Directory + , fileName /=? ".git" + ] + matchFile = and <$> sequence + [ extension ==? ".hs" + , let notElem' = liftOp notElem + in filePath `notElem'` filePathExceptions pwd + ] + files <- find recurseInto matchFile (pwd "src") --TODO: Someday fix all hints in tests, etc. + ideas <- fmap concat $ forM files $ \f -> do + putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... " + runHlint f + if null ideas then exitSuccess else exitFailure + +filePathExceptions :: FilePath -> [FilePath] +filePathExceptions pwd = map (pwd ) $ + [ "src/Data/AppendMap.hs" -- parse error when hlint runs + ] diff --git a/test/rootCleanup.hs b/test/rootCleanup.hs new file mode 100644 --- /dev/null +++ b/test/rootCleanup.hs @@ -0,0 +1,25 @@ +import Control.Concurrent +import Control.Monad +import Data.IORef +import Reflex +import Reflex.Host.Class +import System.Exit +import System.Mem + +main :: IO () +main = do + numSubscriptions <- newIORef 0 + replicateM_ 1000 $ do + runSpiderHost $ do + e <- newEventWithTrigger $ \_ -> do + modifyIORef' numSubscriptions succ + return $ modifyIORef' numSubscriptions pred + _ <- hold () e + return () + replicateM_ 100 $ do + performMajorGC + threadDelay 1 + n <- readIORef numSubscriptions + if n == 0 + then putStrLn "Succeeded" + else putStrLn "Failed" >> exitFailure diff --git a/test/semantics.hs b/test/semantics.hs new file mode 100644 --- /dev/null +++ b/test/semantics.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Main (main) where + +import Reflex.Test + +import Data.Bifunctor +import Data.Functor +import Data.List +import qualified Reflex.Bench.Focused as Focused +import qualified Reflex.Test.Micro as Micro + +import System.Environment +import System.Exit + +import Prelude + +matchPrefixes :: [String] -> (String -> Bool) +matchPrefixes [] = const True +matchPrefixes args = \name -> any (`isPrefixOf` name) args + + +main :: IO () +main = do + args <- getArgs + + case args of + ["--list"] -> mapM_ putStrLn (fst <$> allTests) >> exitWith (ExitFailure 1) + _ -> case filter (matchPrefixes args . fst) allTests of + [] -> putStrLn "filter did not match any tests" >> exitWith (ExitFailure 1) + tests -> runTests tests + + where + allTests = concat + [ makeGroup "micro" Micro.testCases + , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) + , makeGroup "firing 1000" (Focused.firing 1000) + , makeGroup "merge 100" (Focused.merging 100) + , makeGroup "fan 50" (Focused.fans 50) + ] + + makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests