-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{-# LANGUAGE RankNTypes, KindSignatures, DataKinds, ConstraintKinds, FlexibleContexts, GADTs #-}
{-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}

{-|
Description : Output reactive values to attributes of GTK widgets
Copyright   : Sven Bartscher 2020
License     : MPL-2.0
Maintainer  : sven.bartscher@weltraumschlangen.de
Stability   : experimental

This module provides helpers for outputting 'Event's or 'Dynamic's to
attributes of GTK 'GI.Gtk.Widget's (or any other object that has
attributes).
-}
module Reflex.GI.Gtk.Output
  ( sink
  , sink1
  , ReactiveAttrOp(..)
  , Sinkable( sinkPostBuild
            , sinkUpdates
            , toSinkEvent
            )
  , MonadGtkSink
  ) where

import Data.GI.Base.Attributes ( AttrBaseTypeConstraint
                               , AttrGetType
                               , AttrInfo
                               , AttrLabelProxy
                               , AttrOp ( (:=)
                                        , (:=>)
                                        , (:~)
                                        , (:~>)
                                        )
                               , AttrOpAllowed
                               , AttrOpTag( AttrGet
                                          , AttrSet
                                          )
                               , AttrSetTypeConstraint
                               , set
                               )
import Data.GI.Base.Overloading ( HasAttributeList
                                , ResolveAttribute
                                )
import Data.Witherable (catMaybes)
import GHC.TypeLits (Symbol)
import Reflex ( Dynamic
              , Event
              , PerformEvent
              , Performable
              , PostBuild
              , Reflex
              , (<@)
              , current
              , getPostBuild
              , leftmost
              , performEvent_
              , updated
              )
import Reflex.GI.Gtk.Run.Class ( MonadRunGtk
                               , runGtk
                               )

-- | This constraint is necessary for output operations to GTK
-- widgets. Note that it is a subclass of
-- 'Reflex.GI.Gtk.Class.MonadReflexGtk' and implemented by
-- 'Reflex.GI.Gtk.Host.ReflexGtk'.
type MonadGtkSink t m = ( PerformEvent t m
                        , PostBuild t m
                        , MonadRunGtk (Performable m)
                        )

-- | This is a typeclass for reactive values that that can give
-- notifications about updates and thus be used to trigger actions in
-- the real world based on those updates.
class (Functor s) => Sinkable t s | s -> t where
  -- | Turn the reactive value into an event that fires at post build
  -- time 'Just' the current value or 'Nothing' if no value is
  -- available at post build time.
  sinkPostBuild :: (PostBuild t m) => s a -> m (Event t (Maybe a))

  -- | Turn the reactive value into an event that fires the new value
  -- whenever it is changed. This should not include 'sinkPostBuild'
  -- itself, though it may coincide with it, when the value changes at
  -- post build time.
  sinkUpdates :: (Reflex t) => s a -> Event t a

  -- | Turn the reactive value into an event that fires when the
  -- available for the first time (possibly at post build time) and
  -- whenever the value is replaced afterwards. This can be thought of
  -- as a combination of 'sinkPostBuild' and 'sinkUpdates'.
  toSinkEvent :: (PostBuild t m) => s a -> m (Event t a)
  toSinkEvent s :: s a
s =
    (\initial :: Event t (Maybe a)
initial -> [Event t a] -> Event t a
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
      [ s a -> Event t a
forall t (s :: * -> *) a.
(Sinkable t s, Reflex t) =>
s a -> Event t a
sinkUpdates s a
s
      , Event t (Maybe a) -> Event t a
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes Event t (Maybe a)
initial
      ]
    ) (Event t (Maybe a) -> Event t a)
-> m (Event t (Maybe a)) -> m (Event t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s a -> m (Event t (Maybe a))
forall t (s :: * -> *) (m :: * -> *) a.
(Sinkable t s, PostBuild t m) =>
s a -> m (Event t (Maybe a))
sinkPostBuild s a
s

-- | An Event has no value available at post build time, but is
-- updated whenever it fires.
instance (Reflex t) => Sinkable t (Event t) where
  sinkPostBuild :: Event t a -> m (Event t (Maybe a))
sinkPostBuild _ = (Maybe a
forall a. Maybe a
Nothing Maybe a -> Event t () -> Event t (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Event t () -> Event t (Maybe a))
-> m (Event t ()) -> m (Event t (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  sinkUpdates :: Event t a -> Event t a
sinkUpdates = Event t a -> Event t a
forall a. a -> a
id
  toSinkEvent :: Event t a -> m (Event t a)
toSinkEvent = Event t a -> m (Event t a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | A dynamic has a value at post build time and can be updated
-- later.
instance (Functor (Dynamic t)) => Sinkable t (Dynamic t) where
  sinkPostBuild :: Dynamic t a -> m (Event t (Maybe a))
sinkPostBuild s :: Dynamic t a
s = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Behavior t a -> Behavior t (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t a -> Behavior t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t a
s Behavior t (Maybe a) -> Event t () -> Event t (Maybe a)
forall k (t :: k) b a.
Reflex t =>
Behavior t b -> Event t a -> Event t b
<@) (Event t () -> Event t (Maybe a))
-> m (Event t ()) -> m (Event t (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  sinkUpdates :: Dynamic t a -> Event t a
sinkUpdates = Dynamic t a -> Event t a
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated

-- | Arranges that a given attribute is kept in sync with a reactive
-- value on a given object, i.e.
--
-- @sink1 labelWidget '$' #label :== reactiveLabelText@
--
-- will arrange that the attribute @#label@ on
-- @labelWidget@ will always be updated to the value of
-- @reactiveLabelText@.
--
-- Essentially the single value case of 'sink'.
--
-- Alos see the note on 'sink' for updated from more than one source
-- to the targeted attribute.
sink1 :: (MonadGtkSink t m)
      => object
      -> ReactiveAttrOp t object 'AttrSet
      -> m ()
sink1 :: object -> ReactiveAttrOp t object 'AttrSet -> m ()
sink1 object :: object
object reactiveOp :: ReactiveAttrOp t object 'AttrSet
reactiveOp =
  ReactiveAttrOp t object 'AttrSet
-> (forall a (s :: * -> *).
    Sinkable t s =>
    (a -> AttrOp object 'AttrSet) -> s a -> m ())
-> m ()
forall t obj (tag :: AttrOpTag) b.
ReactiveAttrOp t obj tag
-> (forall a (s :: * -> *).
    Sinkable t s =>
    (a -> AttrOp obj tag) -> s a -> b)
-> b
withReactiveAttrOp ReactiveAttrOp t object 'AttrSet
reactiveOp ((forall a (s :: * -> *).
  Sinkable t s =>
  (a -> AttrOp object 'AttrSet) -> s a -> m ())
 -> m ())
-> (forall a (s :: * -> *).
    Sinkable t s =>
    (a -> AttrOp object 'AttrSet) -> s a -> m ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \plainOp :: a -> AttrOp object 'AttrSet
plainOp updates :: s a
updates ->
      s a -> m (Event t a)
forall t (s :: * -> *) (m :: * -> *) a.
(Sinkable t s, PostBuild t m) =>
s a -> m (Event t a)
toSinkEvent s a
updates m (Event t a) -> (Event t a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> (Event t a -> Event t (Performable m ())) -> Event t a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Performable m ()) -> Event t a -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: a
x -> IO () -> Performable m ()
forall (m :: * -> *) a. MonadRunGtk m => IO a -> m a
runGtk (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ object -> [AttrOp object 'AttrSet] -> IO ()
forall o (m :: * -> *).
MonadIO m =>
o -> [AttrOp o 'AttrSet] -> m ()
set object
object [a -> AttrOp object 'AttrSet
plainOp a
x])

infixr 0 :==, :==>, :~~, :~~>
-- | Reactive pendant to 'AttrOp'.
data ReactiveAttrOp t obj (tag :: AttrOpTag) where
  -- | Reactive pendant to ':='.
  (:==) :: ( HasAttributeList obj
           , info ~ ResolveAttribute attr obj
           , AttrInfo info
           , AttrBaseTypeConstraint info obj
           , AttrOpAllowed tag info obj
           , AttrSetTypeConstraint info a
           , Sinkable t s
           )
        => AttrLabelProxy (attr :: Symbol)
        -> s a
        -> ReactiveAttrOp t obj tag
  -- | Reactive pendant to ':=>'.
  (:==>) :: ( HasAttributeList obj
            , info ~ ResolveAttribute attr obj
            , AttrInfo info
            , AttrBaseTypeConstraint info obj
            , AttrOpAllowed tag info obj
            , AttrSetTypeConstraint info a
            , Sinkable t s
            )
         => AttrLabelProxy (attr :: Symbol)
         -> s (IO a)
         -> ReactiveAttrOp t obj tag
  -- | Reactive pendant to ':~'.
  (:~~) :: ( HasAttributeList obj
           , info ~ ResolveAttribute attr obj
           , AttrInfo info
           , AttrBaseTypeConstraint info obj
           , tag ~ 'AttrSet
           , AttrOpAllowed 'AttrSet info obj
           , AttrOpAllowed 'AttrGet info obj
           , AttrSetTypeConstraint info a
           , a ~ AttrGetType info
           , Sinkable t s
           )
        => AttrLabelProxy (attr :: Symbol)
        -> s (a -> a)
        -> ReactiveAttrOp t obj tag
  -- | Reactive pendant to ':~>'.
  (:~~>) :: ( HasAttributeList obj
            , info ~ ResolveAttribute attr obj
            , AttrInfo info
            , AttrBaseTypeConstraint info obj
            , tag ~ 'AttrSet
            , AttrOpAllowed 'AttrSet info obj
            , AttrOpAllowed 'AttrGet info obj
            , AttrSetTypeConstraint info a
            , a ~ AttrGetType info
            , Sinkable t s
            )
         => AttrLabelProxy (attr :: Symbol)
         -> s (a -> IO a)
         -> ReactiveAttrOp t obj tag

-- | Splits the type information from a 'ReactiveAttrOp' into the
-- underlying 'AttrOp' and the 'Sinkable'. This makes it easier to use
-- the underlying 'AttrOp' with its associated operations and
-- established the mapping of the constructors of 'ReactiveAttrOp' and
-- those of 'AttrOp'.
withReactiveAttrOp :: ReactiveAttrOp t obj tag
                   -> (forall a s. Sinkable t s => (a -> AttrOp obj tag) -> s a -> b)
                   -> b
withReactiveAttrOp :: ReactiveAttrOp t obj tag
-> (forall a (s :: * -> *).
    Sinkable t s =>
    (a -> AttrOp obj tag) -> s a -> b)
-> b
withReactiveAttrOp (attr :: AttrLabelProxy attr
attr :== updates :: s a
updates) f :: forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f = (a -> AttrOp obj tag) -> s a -> b
forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f (AttrLabelProxy attr
attr AttrLabelProxy attr -> a -> AttrOp obj tag
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj,
 AttrOpAllowed tag info obj, AttrSetTypeConstraint info b) =>
AttrLabelProxy attr -> b -> AttrOp obj tag
:=) s a
updates
withReactiveAttrOp (attr :: AttrLabelProxy attr
attr :==> updates :: s (IO a)
updates) f :: forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f = (IO a -> AttrOp obj tag) -> s (IO a) -> b
forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f (AttrLabelProxy attr
attr AttrLabelProxy attr -> IO a -> AttrOp obj tag
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj,
 AttrOpAllowed tag info obj, AttrSetTypeConstraint info b) =>
AttrLabelProxy attr -> IO b -> AttrOp obj tag
:=>) s (IO a)
updates
withReactiveAttrOp (attr :: AttrLabelProxy attr
attr :~~ updates :: s (a -> a)
updates) f :: forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f = ((a -> a) -> AttrOp obj tag) -> s (a -> a) -> b
forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f (AttrLabelProxy attr
attr AttrLabelProxy attr -> (a -> a) -> AttrOp obj tag
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b a.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj, tag ~ 'AttrSet,
 AttrOpAllowed 'AttrSet info obj, AttrOpAllowed 'AttrGet info obj,
 AttrSetTypeConstraint info b, a ~ AttrGetType info) =>
AttrLabelProxy attr -> (a -> b) -> AttrOp obj tag
:~) s (a -> a)
updates
withReactiveAttrOp (attr :: AttrLabelProxy attr
attr :~~> updates :: s (a -> IO a)
updates) f :: forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f = ((a -> IO a) -> AttrOp obj tag) -> s (a -> IO a) -> b
forall a (s :: * -> *).
Sinkable t s =>
(a -> AttrOp obj tag) -> s a -> b
f (AttrLabelProxy attr
attr AttrLabelProxy attr -> (a -> IO a) -> AttrOp obj tag
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b a.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj, tag ~ 'AttrSet,
 AttrOpAllowed 'AttrSet info obj, AttrOpAllowed 'AttrGet info obj,
 AttrSetTypeConstraint info b, a ~ AttrGetType info) =>
AttrLabelProxy attr -> (a -> IO b) -> AttrOp obj tag
:~>) s (a -> IO a)
updates

-- | A reactive version of 'set'.
--
-- For example
--
-- @sink object [#attr1 :== attr1Dynamic, #attr2 :== attr2Event]@
--
-- Will arrange that @#attr1@ is updated to the current value of
-- @attr1Dynamic@ whenever it is updated, just as @#attr2@ will always
-- be updated to the value of @attr2Event@ whenever it fires.
--
-- When a single attribute is changed by multiple sources, (such as
-- different calls to 'sink', 'sink1', specifying the same attribute
-- multiple times in the same call to 'sink', or manual updates
-- through 'set') the most recent update wins (until a newer update
-- occurs). However, you should generally not rely on this and instead
-- make sure that at most one call to 'sink' or 'sink1' targets the
-- same attribute.
sink :: ( MonadGtkSink t m
        )
     => object -> [ReactiveAttrOp t object 'AttrSet] -> m ()
sink :: object -> [ReactiveAttrOp t object 'AttrSet] -> m ()
sink object :: object
object = (ReactiveAttrOp t object 'AttrSet -> m ())
-> [ReactiveAttrOp t object 'AttrSet] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (object -> ReactiveAttrOp t object 'AttrSet -> m ()
forall t (m :: * -> *) object.
MonadGtkSink t m =>
object -> ReactiveAttrOp t object 'AttrSet -> m ()
sink1 object
object)