Box.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 FlexibleContexts, LambdaCase, TupleSections #-}

{-|
Description : Reactive helpers for 'Box'es
Copyright   : Sven Bartscher 2020
License     : MPL-2.0
Maintainer  : sven.bartscher@weltraumschlangen.de
Stability   : experimental

This module provides helpers for dealing with 'Box'es in reactive
contexts.
-}
module Reflex.GI.Gtk.Widget.Box
  ( sinkBox
  , sinkBoxUniform
  ) where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO)
import Data.Align ( Semialign
                  , align
                  )
import Data.Foldable (foldl')
import Data.GI.Base (GObject)
import Data.GI.Base.Overloading (IsDescendantOf)
import qualified Data.Map as M
import Data.These ( These( This
                         , That
                         , These
                         )
                  )
import Data.Word (Word32)
import GI.Gtk ( Box
              , Container
              , PackType( PackTypeStart
                        , PackTypeEnd
                        )
              , Widget
              , boxPackEnd
              , boxPackStart
              , boxReorderChild
              , boxSetChildPacking
              , containerRemove
              )
import Reflex ( MonadHold
              , PerformEvent
              , Performable
              , PostBuild
              , (<@>)
              , performEvent_
              , hold
              )
import Reflex.GI.Gtk.Output ( Sinkable
                            , toSinkEvent
                            )
import Reflex.GI.Gtk.Run.Class ( MonadRunGtk
                               , runGtk
                               )
import Reflex.GI.Gtk.Widget.Ord (OrdWidget(OrdWidget))

pack :: ( MonadIO m
        , GObject box
        , IsDescendantOf Box box
        , GObject child
        , IsDescendantOf Widget child
        )
       => box -> child -> Bool -> Bool -> Word32 -> PackType -> m ()
pack box child expand fill padding PackTypeStart = boxPackStart box child expand fill padding
pack box child expand fill padding PackTypeEnd = boxPackEnd box child expand fill padding
pack box child expand fill padding unknownPackType = do
  -- We don't know this packing, but boxSetChildPacking may know it,
  -- so we pack at start and then set the correct packing.
  boxPackStart box child expand fill padding
  boxSetChildPacking box child expand fill padding unknownPackType

-- | Pack a dynamically changing sequence of widgets into a box. Each
-- widget has individual dynamic packing parameters.
--
-- The widgets will be packed into the 'Box' in left-fold order.
sinkBox :: ( GObject box
           , IsDescendantOf Container box
           , IsDescendantOf Box box
           , Foldable f
           , Semialign f
           , GObject w
           , IsDescendantOf Widget w
           , Eq w
           , PerformEvent t m
           , PostBuild t m
           , MonadHold t m
           , MonadRunGtk m
           , MonadRunGtk (Performable m)
           , Sinkable t s
           )
        => box
        -- ^ The 'Box' to pack into
        -> s (f (w, Bool, Bool, Word32, PackType))
        -- ^ The dynamic sequence of 'Widget's. The arguments are the
        -- same as those for 'boxSetChildPacking'.
        -> m ()
sinkBox box widgetSinkable = do
  widgetUpdates <- toSinkEvent widgetSinkable
  currentWidgets <- hold Nothing $ Just <$> widgetUpdates
  performEvent_ $ update <$> currentWidgets <@> widgetUpdates
  where update Nothing widgets =
          runGtk $ foldl' (\acc (w, expand, fill, padding, packType) ->
                              acc
                              >> pack box w expand fill padding packType
                          ) (pure ()) widgets
        update (Just olds) neww =
          let (reorder, _, removed) =
                foldl' (\wacc -> \case
                           This old -> markOld wacc old
                           That new -> otherWidget wacc new
                           These
                             wold@(old, oldExpand, oldFill, oldPadding, oldPackType)
                             wnew@(new, newExpand, newFill, newPadding, newPackType)
                             | old == new ->
                                 repackWidget wacc new
                                 (oldExpand, oldFill, oldPadding, oldPackType)
                                 (newExpand, newFill, newPadding, newPackType)
                             | otherwise ->
                                 otherWidget (markOld wacc wold) wnew
                       ) (pure (), 0, M.empty) $ align olds neww
          in runGtk $
             M.foldlWithKey' (\acc (OrdWidget w) _ ->
                                acc >> containerRemove box w
                             ) (pure ()) removed
             >> reorder
        markOld (acc, i, oldWidgets) (w, expand, fill, padding, packType) =
          ( acc
          , i
          , M.insert (OrdWidget w) (expand, fill, padding, packType) oldWidgets
          )
        otherWidget wacc@(_, _, oldWidgets) ww@(w, _, _, _, _) =
          case oldWidgets M.!? OrdWidget w of
            Nothing -> newWidget wacc ww
            Just oldPacking -> reuseWidget wacc ww oldPacking
        newWidget (acc, i, oldWidgets) (w, expand, fill, padding, packType) =
          ( do
              _ <- acc
              pack box w expand fill padding packType
              boxReorderChild box w i
          , succ i
          , oldWidgets
          )
        repackWidget (acc, i, oldWidgets) w oldPacking
          newPacking@(expand, fill, padding, packType) =
          ( do
              _ <- acc
              when (oldPacking /= newPacking)
                $ boxSetChildPacking box w expand fill padding packType
          , succ i
          , oldWidgets
          )
        reuseWidget (acc, i, oldWidgets) (w, expand, fill, padding, packType) oldPacking =
          repackWidget ( do
                           _ <- acc
                           boxReorderChild box w i
                       , i -- repack widget already increases this
                       , M.delete (OrdWidget w) oldWidgets
                       ) w oldPacking (expand, fill, padding, packType)

-- | Like 'sinkBox', but the packing parameters are statically
-- specified for all widgets.
sinkBoxUniform :: ( GObject box
                  , IsDescendantOf Container box
                  , IsDescendantOf Box box
                  , Foldable f
                  , Semialign f
                  , GObject w
                  , IsDescendantOf Widget w
                  , Eq w
                  , PerformEvent t m
                  , PostBuild t m
                  , MonadRunGtk m
                  , MonadRunGtk (Performable m)
                  , MonadHold t m
                  , Sinkable t s
                  )
               => box
               -- ^ The 'Box' to pack into
               -> s (f w)
               -- ^ The dynamic sequence of 'Widget's
               -> Bool
               -> Bool
               -> Word32
               -> PackType
               -> m ()
sinkBoxUniform box widgets expand fill padding packType =
  sinkBox box $ fmap (, expand, fill, padding, packType) <$> widgets