RPanel.hs

-- | "Rowed Panel." 
-- Expandable framed panel with a two-dimensional layout
-- (rows of widgets, but not with aligned columns like in a table).

module Sifflet.UI.RPanel
    (
     RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent
    , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow
    , rpanelAddRows
    )

where

import Control.Monad

import Sifflet.UI.LittleGtk
import Sifflet.Util

debugTracing :: Bool
debugTracing = False

data RPanel 
    = RPanel {
        -- Public
        rpId :: String   -- ^ text for the expander button
      , rpRoot :: GtkFrame -- ^ use the root to add rpanel to a container
      , rpContent :: [[String]] -- ^ ids of widgets added, in rows

      -- Widgets that make up the RPanel
      , rpFrame :: GtkFrame -- ^ frame, same as root
      , rpExpander :: Expander -- ^ expander
      , rpVBox :: VBox         -- ^ vbox to contain the rows
      , rpCurrentRow :: HBox   -- ^ next element goes here if it fits

      -- Geometry book-keeping
      , rpCurrentRowFreeWidth :: Int -- ^ free width in current row
      , rpMaxWidth :: Int            -- ^ maximum row width
      , rpHPad :: Int -- ^ horizontal padding
      }

rpanelId :: RPanel -> String
rpanelId = rpId

rpanelRoot :: RPanel -> GtkFrame
rpanelRoot = rpRoot

rpanelContent :: RPanel -> [[String]]
rpanelContent = rpContent

newRPanel :: String -> Int -> Int -> Int -> IO RPanel
newRPanel cid hpad vpad maxWidth = do
  {
    frame <- frameNew -- adds a border (not labeled, since the expander is)
             
  ; expander <- expanderNew cid
  ; expanderSetExpanded expander True
  ; set frame [containerChild := expander]

  ; vbox <- vBoxNew False vpad  -- non-homogeneous heights
  ; widgetSetSizeRequest vbox maxWidth (-1) -- height = don't care
  ; set expander [containerChild := vbox]

  ; hbox <- hBoxNew False hpad  -- non-homogeoneous widths
  ; boxPackStart vbox hbox PackNatural 0

  ; return $ RPanel {rpId = cid
                    , rpRoot = frame
                    , rpFrame = frame
                    , rpExpander = expander
                    , rpVBox = vbox
                    , rpCurrentRow = hbox
                    , rpContent = [[]]
                    , rpCurrentRowFreeWidth = maxWidth - hpad
                    , rpMaxWidth = maxWidth - hpad
                    , rpHPad = hpad
                    }
              }

-- | Given a list of (name, widget) pairs, add each of the widgets
-- and its name to the rpanel
rpanelAddWidgets :: (WidgetClass widget) =>
                    RPanel -> [(String, widget)] -> IO RPanel
rpanelAddWidgets rp pairs = 
    let addPair rp' (widgetId, widget) = rpanelAddWidget rp' widgetId widget
    in foldM addPair rp pairs

-- | Add a single named widget to the RPanel
rpanelAddWidget :: (WidgetClass widget) =>
                   RPanel -> String -> widget -> IO RPanel
rpanelAddWidget rp widgetId widget = do
  {
    Requisition widgetWidth _ <- widgetSizeRequest widget
  ; let freeWidth = rpCurrentRowFreeWidth rp
        freeWidth' = freeWidth - widgetWidth - rpHPad rp
  ; if freeWidth' >= 0 || freeWidth == rpMaxWidth rp
       -- Either there is room enough, OR we're at the start of a row
       -- so starting another won't help -- in fact it would lead to
       -- infinite recursion
    then do
      {
        let content' = insertLastLast (rpContent rp) widgetId
            packMode = -- PackNatural -- to left justify
                       PackGrow -- to fill
                       -- PackRepel -- to center

      ; boxPackStart (rpCurrentRow rp) widget packMode 0
      -- ; widgetShow widget -- do this here???
      ; when debugTracing $
             putStr (unlines ["Adding " ++ widgetId ++ 
                              " width " ++ show widgetWidth
                             , "Free width = " ++ show freeWidth ++
                              " -> " ++ show freeWidth'
                             , "Content -> " ++ show content'])

      ; return $ rp {rpContent = content'
                     , rpCurrentRowFreeWidth = freeWidth'}
      }
    else 
        -- We're out of room, but not at the start of the current row,
        -- so start a new row
        do
      {
        rp' <- rpanelNewRow rp
      ; rpanelAddWidget rp' widgetId widget
      }
    }

-- | Force the RPanel to begin a new row

rpanelNewRow :: RPanel -> IO RPanel
rpanelNewRow rp = do
  {
    hbox <- hBoxNew False (rpHPad rp)
  ; boxPackStart (rpVBox rp) hbox PackNatural 0
  ; return $ rp {rpCurrentRow = hbox
                , rpContent = insertLast (rpContent rp) []
                , rpCurrentRowFreeWidth = rpMaxWidth rp}
  }

-- | Given a list of lists, each sublist representing a row of widgets,
-- add the widgets to the RPanel, preserving the row structure
-- as much as possible.
-- (Row structure will be broken if any intended row is too wide.)
rpanelAddRows :: (WidgetClass widget) =>
                 RPanel -> [[(String, widget)]] -> IO RPanel
rpanelAddRows rp rows = foldM rpanelAddRow rp rows

-- | Add a row of widgets to an RPanel.
-- This does not start a new row before the first widget,
-- but after the last, so at the end, the current row will be empty.
rpanelAddRow :: (WidgetClass widget) =>
                RPanel -> [(String, widget)] -> IO RPanel
rpanelAddRow rp row = 
    rpanelAddWidgets rp row >>= rpanelNewRow