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 #-}

module Reflex.GI.Gtk.Output
  ( Sinkable(toSinkEvent)
  , MonadGtkSink
  , sink1
  , sink
  , ReactiveAttrOp(..)
  ) 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 GHC.TypeLits (Symbol)
import Reflex ( Dynamic
              , Event
              , PerformEvent
              , Performable
              , PostBuild
              , (<@)
              , current
              , getPostBuild
              , leftmost
              , performEvent_
              , updated
              )
import Reflex.GI.Gtk.Run.Class ( MonadRunGtk
                               , runGtk
                               )

type MonadGtkSink t m = ( PerformEvent t m
                        , PostBuild t m
                        , MonadRunGtk (Performable m)
                        )

class Sinkable t s | s -> t where
  toSinkEvent :: (MonadGtkSink t m) => s a -> m (Event t a)

instance Sinkable t (Event t) where
  toSinkEvent = pure

instance Sinkable t (Dynamic t) where
  toSinkEvent d = do
    postBuild <- getPostBuild
    pure $ leftmost
      [ updated d
      , current d <@ postBuild
      ]

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 :==, :==>, :~~, :~~>
data ReactiveAttrOp t obj (tag :: AttrOpTag) where
  (:==) :: ( 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
  (:==>) :: ( 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
  (:~~) :: ( 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
  (:~~>) :: ( 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

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

sink :: ( MonadGtkSink t m
        )
     => object -> [ReactiveAttrOp t object 'AttrSet] -> m ()
sink object = mapM_ (sink1 object)