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

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
              , widgetShowAll
              )
import Reflex ( Dynamic
              , PerformEvent
              , Performable
              , PostBuild
              , (<@)
              , (<@>)
              , current
              , performEvent_
              , getPostBuild
              , updated
              )
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

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
           , MonadRunGtk m
           , MonadRunGtk (Performable m)
           )
        => box
        -> Dynamic t (f (w, Bool, Bool, Word32, PackType))
        -> m ()
sinkBox box widgets = do
  performEvent_ $ update <$> current widgets <@> updated widgets
  postBuild <- getPostBuild
  performEvent_
    $ runGtk . foldl' (\acc (w, expand, fill, padding, packType) ->
                          acc >> pack box w expand fill padding packType
                      ) (pure ())
    <$> current widgets <@ postBuild
  where update 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
              widgetShowAll w
          , 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)

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)
                  )
               => box
               -> Dynamic t (f w)
               -> Bool
               -> Bool
               -> Word32
               -> PackType
               -> m ()
sinkBoxUniform box widgets expand fill padding packType =
  sinkBox box $ fmap (, expand, fill, padding, packType) <$> widgets