Output.hs

-- 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 =
    (\initial -> leftmost
      [ sinkUpdates s
      , catMaybes initial
      ]
    ) <$> sinkPostBuild 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 _ = (Nothing <$) <$> getPostBuild
  sinkUpdates = id
  toSinkEvent = 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 s = (Just <$> current s <@) <$> getPostBuild
  sinkUpdates = 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 reactiveOp =
  withReactiveAttrOp reactiveOp $ \plainOp updates ->
      toSinkEvent updates >>= performEvent_ . fmap (\x -> runGtk $ set object [plainOp 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 (attr :== updates) f = f (attr :=) updates
withReactiveAttrOp (attr :==> updates) f = f (attr :=>) updates
withReactiveAttrOp (attr :~~ updates) f = f (attr :~) updates
withReactiveAttrOp (attr :~~> updates) f = f (attr :~>) 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 = mapM_ (sink1 object)