{-# 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
-- <https://wiki.haskell.org/Weak_head_normal_form weak head normal form>.
--
-- 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 { UniqDynamic t a -> Dynamic t a
unUniqDynamic :: Dynamic t a }

-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'.
uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a
uniqDynamic :: Dynamic t a -> UniqDynamic t a
uniqDynamic d :: Dynamic t a
d = Dynamic t a -> UniqDynamic t a
forall t a. Dynamic t a -> UniqDynamic t a
UniqDynamic (Dynamic t a -> UniqDynamic t a) -> Dynamic t a -> UniqDynamic t a
forall a b. (a -> b) -> a -> b
$ PullM t a -> Event t a -> Dynamic t a
forall k (t :: k) a.
Reflex t =>
PullM t a -> Event t a -> Dynamic t a
unsafeBuildDynamic (Behavior t a -> PullM t a
forall k (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample (Behavior t a -> PullM t a) -> Behavior t a -> PullM t a
forall a b. (a -> b) -> a -> b
$ Dynamic t a -> Behavior t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t a
d) (Event t a -> Dynamic t a) -> Event t a -> Dynamic t a
forall a b. (a -> b) -> a -> b
$ ((a -> PushM t (Maybe a)) -> Event t a -> Event t a)
-> Event t a -> (a -> PushM t (Maybe a)) -> Event t a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> PushM t (Maybe a)) -> Event t a -> Event t a
forall k (t :: k) a b.
Reflex t =>
(a -> PushM t (Maybe b)) -> Event t a -> Event t b
pushCheap (Dynamic t a -> Event t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t a
d) ((a -> PushM t (Maybe a)) -> Event t a)
-> (a -> PushM t (Maybe a)) -> Event t a
forall a b. (a -> b) -> a -> b
$ \new :: a
new -> do
  a
old <- Behavior t a -> PushM t a
forall k (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample (Behavior t a -> PushM t a) -> Behavior t a -> PushM t a
forall a b. (a -> b) -> a -> b
$ Dynamic t a -> Behavior t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t a
d --TODO: Is it better to sample ourselves here?
  Maybe a -> PushM t (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> PushM t (Maybe a)) -> Maybe a -> PushM t (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> a -> Maybe a
forall a. a -> a -> Maybe a
unsafeJustChanged a
old a
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 t a -> Dynamic t a
fromUniqDynamic (UniqDynamic d :: Dynamic t a
d) = Behavior t a -> Event t a -> Dynamic t a
forall k (t :: k) a.
Reflex t =>
Behavior t a -> Event t a -> Dynamic t a
unsafeDynamic (Dynamic t a -> Behavior t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t a
d) Event t a
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 -> a -> Bool
superEq a :: a
a b :: a
b = a
a a -> a -> Bool
forall a. a -> a -> Bool
`unsafePtrEq` a
b Bool -> Bool -> Bool
|| a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b
    e' :: Event t a
e' = (a -> a -> Maybe a) -> Behavior t a -> Event t a -> Event t a
forall k (t :: k) a b c.
Reflex t =>
(a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
attachWithMaybe (\x :: a
x x' :: a
x' -> if a
x' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
`superEq` a
x then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just a
x') (Dynamic t a -> Behavior t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t a
d) (Dynamic t a -> Event t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t a
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 :: Dynamic t a -> UniqDynamic t a
alreadyUniqDynamic = Dynamic t a -> UniqDynamic t a
forall t a. Dynamic t a -> UniqDynamic t a
UniqDynamic

unsafePtrEq :: a -> a -> Bool
unsafePtrEq :: a -> a -> Bool
unsafePtrEq a :: a
a b :: a
b = case a
a a -> Int# -> Int#
forall a b. a -> b -> b
`seq` a
b a -> Int# -> Int#
forall a b. a -> b -> b
`seq` a -> a -> Int#
forall a. a -> a -> Int#
reallyUnsafePtrEquality# a
a a
b of
  0# -> Bool
False
  _ -> Bool
True

unsafeJustChanged :: a -> a -> Maybe a
unsafeJustChanged :: a -> a -> Maybe a
unsafeJustChanged old :: a
old new :: a
new =
  if a
old a -> a -> Bool
forall a. a -> a -> Bool
`unsafePtrEq` a
new
  then Maybe a
forall a. Maybe a
Nothing
  else a -> Maybe a
forall a. a -> Maybe a
Just a
new

instance Reflex t => Accumulator t (UniqDynamic t) where
  accumMaybeM :: (a -> b -> PushM t (Maybe a))
-> a -> Event t b -> m (UniqDynamic t a)
accumMaybeM f :: a -> b -> PushM t (Maybe a)
f z :: a
z e :: Event t b
e = do
    let f' :: a -> b -> PushM t (Maybe a)
f' old :: a
old change :: b
change = do
          Maybe a
mNew <- a -> b -> PushM t (Maybe a)
f a
old b
change
          Maybe a -> PushM t (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> PushM t (Maybe a)) -> Maybe a -> PushM t (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> a -> Maybe a
forall a. a -> a -> Maybe a
unsafeJustChanged a
old (a -> Maybe a) -> Maybe a -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe a
mNew
    Dynamic t a
d <- (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)
accumMaybeMDyn a -> b -> PushM t (Maybe a)
f' a
z Event t b
e
    UniqDynamic t a -> m (UniqDynamic t a)
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqDynamic t a -> m (UniqDynamic t a))
-> UniqDynamic t a -> m (UniqDynamic t a)
forall a b. (a -> b) -> a -> b
$ Dynamic t a -> UniqDynamic t a
forall t a. Dynamic t a -> UniqDynamic t a
UniqDynamic Dynamic t a
d
  mapAccumMaybeM :: (a -> b -> PushM t (Maybe a, Maybe c))
-> a -> Event t b -> m (UniqDynamic t a, Event t c)
mapAccumMaybeM f :: a -> b -> PushM t (Maybe a, Maybe c)
f z :: a
z e :: Event t b
e = do
    let f' :: a -> b -> PushM t (Maybe a, Maybe c)
f' old :: a
old change :: b
change = do
          (mNew :: Maybe a
mNew, output :: Maybe c
output) <- a -> b -> PushM t (Maybe a, Maybe c)
f a
old b
change
          (Maybe a, Maybe c) -> PushM t (Maybe a, Maybe c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> Maybe a
forall a. a -> a -> Maybe a
unsafeJustChanged a
old (a -> Maybe a) -> Maybe a -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe a
mNew, Maybe c
output)
    (d :: Dynamic t a
d, out :: Event t c
out) <- (a -> b -> PushM t (Maybe a, Maybe c))
-> a -> Event t b -> m (Dynamic t a, Event t c)
forall k (t :: k) (m :: * -> *) a b c.
(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 a -> b -> PushM t (Maybe a, Maybe c)
f' a
z Event t b
e
    (UniqDynamic t a, Event t c) -> m (UniqDynamic t a, Event t c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic t a -> UniqDynamic t a
forall t a. Dynamic t a -> UniqDynamic t a
UniqDynamic Dynamic t a
d, Event t c
out)

instance Reflex t => Functor (UniqDynamic t) where
  fmap :: (a -> b) -> UniqDynamic t a -> UniqDynamic t b
fmap f :: a -> b
f (UniqDynamic d :: Dynamic t a
d) = Dynamic t b -> UniqDynamic t b
forall t a. Reflex t => Dynamic t a -> UniqDynamic t a
uniqDynamic (Dynamic t b -> UniqDynamic t b) -> Dynamic t b -> UniqDynamic t b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Dynamic t a -> Dynamic t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Dynamic t a
d

instance Reflex t => Applicative (UniqDynamic t) where
  pure :: a -> UniqDynamic t a
pure = Dynamic t a -> UniqDynamic t a
forall t a. Dynamic t a -> UniqDynamic t a
UniqDynamic (Dynamic t a -> UniqDynamic t a)
-> (a -> Dynamic t a) -> a -> UniqDynamic t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Dynamic t a
forall k (t :: k) a. Reflex t => a -> Dynamic t a
constDyn
  UniqDynamic a :: Dynamic t (a -> b)
a <*> :: UniqDynamic t (a -> b) -> UniqDynamic t a -> UniqDynamic t b
<*> UniqDynamic b :: Dynamic t a
b = Dynamic t b -> UniqDynamic t b
forall t a. Reflex t => Dynamic t a -> UniqDynamic t a
uniqDynamic (Dynamic t b -> UniqDynamic t b) -> Dynamic t b -> UniqDynamic t b
forall a b. (a -> b) -> a -> b
$ Dynamic t (a -> b)
a Dynamic t (a -> b) -> Dynamic t a -> Dynamic t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t a
b
  _ *> :: UniqDynamic t a -> UniqDynamic t b -> UniqDynamic t b
*> b :: UniqDynamic t b
b = UniqDynamic t b
b
  a :: UniqDynamic t a
a <* :: UniqDynamic t a -> UniqDynamic t b -> UniqDynamic t a
<* _ = UniqDynamic t a
a

instance Reflex t => Monad (UniqDynamic t) where
  UniqDynamic x :: Dynamic t a
x >>= :: UniqDynamic t a -> (a -> UniqDynamic t b) -> UniqDynamic t b
>>= f :: a -> UniqDynamic t b
f = Dynamic t b -> UniqDynamic t b
forall t a. Reflex t => Dynamic t a -> UniqDynamic t a
uniqDynamic (Dynamic t b -> UniqDynamic t b) -> Dynamic t b -> UniqDynamic t b
forall a b. (a -> b) -> a -> b
$ Dynamic t a
x Dynamic t a -> (a -> Dynamic t b) -> Dynamic t b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UniqDynamic t b -> Dynamic t b
forall t a. UniqDynamic t a -> Dynamic t a
unUniqDynamic (UniqDynamic t b -> Dynamic t b)
-> (a -> UniqDynamic t b) -> a -> Dynamic t b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> UniqDynamic t b
f
  _ >> :: UniqDynamic t a -> UniqDynamic t b -> UniqDynamic t b
>> b :: UniqDynamic t b
b = UniqDynamic t b
b
  return :: a -> UniqDynamic t a
return = a -> UniqDynamic t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure