Add sizeUpdater helpers. Support multiple handlers in box, grid and stack.

ChangeLog.md

@@ -1,6 +1,7 @@
 ### 1.0.0.4 - In development
 
 - Reduce memory usage by sharing wreq session among image widget instances.
+- Add sizeUpdater helpers. Support multiple handlers in box, grid and stack.
 
 ### 1.0.0.3
 

monomer.cabal

@@ -415,6 +415,7 @@ test-suite monomer-test
   main-is: Spec.hs
   other-modules:
       Monomer.Common.CursorIconSpec
+      Monomer.Core.SizeReqSpec
       Monomer.Graphics.UtilSpec
       Monomer.TestEventUtil
       Monomer.TestUtil

src/Monomer/Core/SizeReq.hs

@@ -13,6 +13,12 @@ Helper functions creating, validating and merging size requirements.
 module Monomer.Core.SizeReq (
   SizeReqUpdater(..),
   clearExtra,
+  fixedToMinW,
+  fixedToMinH,
+  fixedToMaxW,
+  fixedToMaxH,
+  fixedToExpandW,
+  fixedToExpandH,
   sizeReqBounded,
   sizeReqValid,
   sizeReqAddStyle,
@@ -43,9 +49,51 @@ import qualified Monomer.Core.Lens as L
 -- | Transforms a SizeReq pair by applying an arbitrary operation.
 type SizeReqUpdater = (SizeReq, SizeReq) -> (SizeReq, SizeReq)
 
--- | Clears the extra field of a SizeReq.
+-- | Clears the extra field of a pair of SizeReqs.
 clearExtra :: SizeReqUpdater
-clearExtra (req1, req2) = (req1 & L.extra .~ 0, req2 & L.extra .~ 0)
+clearExtra (reqW, reqH) = (reqW & L.extra .~ 0, reqH & L.extra .~ 0)
+
+-- | Switches a SizeReq pair from fixed width to minimum width.
+fixedToMinW
+  :: Double          -- ^ The resize factor.
+  -> SizeReqUpdater  -- ^ The updated SizeReq.
+fixedToMinW fw (SizeReq fixed _ _ _, reqH) = (newReqH, reqH) where
+  newReqH = SizeReq fixed 0 fixed fw
+
+-- | Switches a SizeReq pair from fixed height to minimum height.
+fixedToMinH
+  :: Double          -- ^ The resize factor.
+  -> SizeReqUpdater  -- ^ The updated SizeReq.
+fixedToMinH fh (reqW, SizeReq fixed _ _ _) = (reqW, newReqH) where
+  newReqH = SizeReq fixed 0 fixed fh
+
+-- | Switches a SizeReq pair from fixed width to maximum width.
+fixedToMaxW
+  :: Double          -- ^ The resize factor.
+  -> SizeReqUpdater  -- ^ The updated SizeReq.
+fixedToMaxW fw (SizeReq fixed _ _ _, reqH) = (newReqH, reqH) where
+  newReqH = SizeReq 0 fixed 0 fw
+
+-- | Switches a SizeReq pair from fixed height to maximum height.
+fixedToMaxH
+  :: Double          -- ^ The resize factor.
+  -> SizeReqUpdater  -- ^ The updated SizeReq.
+fixedToMaxH fh (reqW, SizeReq fixed _ _ _) = (reqW, newReqH) where
+  newReqH = SizeReq 0 fixed 0 fh
+
+-- | Switches a SizeReq pair from fixed width to expand width.
+fixedToExpandW
+  :: Double          -- ^ The resize factor.
+  -> SizeReqUpdater  -- ^ The updated SizeReq.
+fixedToExpandW fw (SizeReq fixed _ _ _, reqH) = (newReqH, reqH) where
+  newReqH = SizeReq 0 fixed fixed fw
+
+-- | Switches a SizeReq pair from fixed height to expand height.
+fixedToExpandH
+  :: Double          -- ^ The resize factor.
+  -> SizeReqUpdater  -- ^ The updated SizeReq.
+fixedToExpandH fh (reqW, SizeReq fixed _ _ _) = (reqW, newReqH) where
+  newReqH = SizeReq 0 fixed fixed fh
 
 -- | Returns a bounded value by the SizeReq, starting from value and offset.
 sizeReqBounded :: SizeReq -> Double -> Double -> Double

src/Monomer/Helper.hs

@@ -48,6 +48,10 @@ seqCatMaybes (x :<| xs) = case x of
   Just val -> val :<| seqCatMaybes xs
   _ -> seqCatMaybes xs
 
+-- | Folds a list of functions over an initial value.
+applyFnList :: [a -> a] -> a -> a
+applyFnList fns initial = foldl (flip ($)) initial fns
+
 -- | Returns the maximum value of a given floating type.
 maxNumericValue :: (RealFloat a) => a
 maxNumericValue = x where

src/Monomer/Widgets/Composite.hs

@@ -70,7 +70,6 @@ import Data.Maybe
 import Data.Sequence (Seq(..), (|>), (<|), fromList)
 import Data.Typeable (Typeable, cast, typeOf)
 
-import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Map.Strict as M
 import qualified Data.Sequence as Seq
 

src/Monomer/Widgets/Containers/Box.hs

@@ -42,6 +42,7 @@ import Data.Maybe
 
 import qualified Data.Sequence as Seq
 
+import Monomer.Helper (applyFnList)
 import Monomer.Widgets.Container
 import Monomer.Widgets.Containers.Stack
 
@@ -78,7 +79,7 @@ Configuration options for box:
 data BoxCfg s e = BoxCfg {
   _boxExpandContent :: Maybe Bool,
   _boxIgnoreEmptyArea :: Maybe Bool,
-  _boxSizeReqUpdater :: Maybe SizeReqUpdater,
+  _boxSizeReqUpdater :: [SizeReqUpdater],
   _boxMergeRequired :: Maybe (s -> s -> Bool),
   _boxAlignH :: Maybe AlignH,
   _boxAlignV :: Maybe AlignV,
@@ -96,7 +97,7 @@ instance Default (BoxCfg s e) where
   def = BoxCfg {
     _boxExpandContent = Nothing,
     _boxIgnoreEmptyArea = Nothing,
-    _boxSizeReqUpdater = Nothing,
+    _boxSizeReqUpdater = [],
     _boxMergeRequired = Nothing,
     _boxAlignH = Nothing,
     _boxAlignV = Nothing,
@@ -114,7 +115,7 @@ instance Semigroup (BoxCfg s e) where
   (<>) t1 t2 = BoxCfg {
     _boxExpandContent = _boxExpandContent t2 <|> _boxExpandContent t1,
     _boxIgnoreEmptyArea = _boxIgnoreEmptyArea t2 <|> _boxIgnoreEmptyArea t1,
-    _boxSizeReqUpdater = _boxSizeReqUpdater t2 <|> _boxSizeReqUpdater t1,
+    _boxSizeReqUpdater = _boxSizeReqUpdater t1 <> _boxSizeReqUpdater t2,
     _boxMergeRequired = _boxMergeRequired t2 <|> _boxMergeRequired t1,
     _boxAlignH = _boxAlignH t2 <|> _boxAlignH t1,
     _boxAlignV = _boxAlignV t2 <|> _boxAlignV t1,
@@ -138,7 +139,7 @@ instance CmbIgnoreEmptyArea (BoxCfg s e) where
 
 instance CmbSizeReqUpdater (BoxCfg s e) where
   sizeReqUpdater updater = def {
-    _boxSizeReqUpdater = Just updater
+    _boxSizeReqUpdater = [updater]
   }
 
 instance CmbMergeRequired (BoxCfg s e) s where
@@ -384,11 +385,11 @@ makeBox config state = widget where
 
   getSizeReq :: ContainerGetSizeReqHandler s e
   getSizeReq wenv node children = newSizeReq where
-    updateSizeReq = fromMaybe id (_boxSizeReqUpdater config)
+    sizeReqFns = _boxSizeReqUpdater config
     child = Seq.index children 0
     newReqW = child ^. L.info . L.sizeReqW
     newReqH = child ^. L.info . L.sizeReqH
-    newSizeReq = updateSizeReq (newReqW, newReqH)
+    newSizeReq = applyFnList sizeReqFns (newReqW, newReqH)
 
   resize wenv node viewport children = resized where
     style = getCurrentStyle wenv node

src/Monomer/Widgets/Containers/Grid.hs

@@ -32,6 +32,7 @@ import Data.Sequence (Seq(..), (|>))
 
 import qualified Data.Sequence as Seq
 
+import Monomer.Helper (applyFnList)
 import Monomer.Widgets.Container
 
 import qualified Monomer.Lens as L
@@ -42,17 +43,17 @@ Configuration options for grid:
 - 'sizeReqUpdater': allows modifying the 'SizeReq' generated by the grid.
 -}
 newtype GridCfg = GridCfg {
-  _grcSizeReqUpdater :: Maybe SizeReqUpdater
+  _grcSizeReqUpdater :: [SizeReqUpdater]
 }
 
 instance Default GridCfg where
   def = GridCfg {
-    _grcSizeReqUpdater = Nothing
+    _grcSizeReqUpdater = []
   }
 
 instance Semigroup GridCfg where
   (<>) s1 s2 = GridCfg {
-    _grcSizeReqUpdater = _grcSizeReqUpdater s2 <|> _grcSizeReqUpdater s1
+    _grcSizeReqUpdater = _grcSizeReqUpdater s1 <> _grcSizeReqUpdater s2
   }
 
 instance Monoid GridCfg where
@@ -60,7 +61,7 @@ instance Monoid GridCfg where
 
 instance CmbSizeReqUpdater GridCfg where
   sizeReqUpdater updater = def {
-    _grcSizeReqUpdater = Just updater
+    _grcSizeReqUpdater = [updater]
   }
 
 -- | Creates a grid of items with the same width.
@@ -96,11 +97,11 @@ makeFixedGrid isHorizontal config = widget where
   isVertical = not isHorizontal
 
   getSizeReq wenv node children = newSizeReq where
-    updateSizeReq = fromMaybe id (_grcSizeReqUpdater config)
+    sizeReqFns = _grcSizeReqUpdater config
     vchildren = Seq.filter (_wniVisible . _wnInfo) children
     newSizeReqW = getDimSizeReq isHorizontal (_wniSizeReqW . _wnInfo) vchildren
     newSizeReqH = getDimSizeReq isVertical (_wniSizeReqH . _wnInfo) vchildren
-    newSizeReq = updateSizeReq (newSizeReqW, newSizeReqH)
+    newSizeReq = applyFnList sizeReqFns (newSizeReqW, newSizeReqH)
 
   getDimSizeReq mainAxis accesor vchildren
     | Seq.null vreqs = fixedSize 0

src/Monomer/Widgets/Containers/Stack.hs

@@ -35,6 +35,7 @@ import Data.Sequence (Seq(..), (<|), (|>))
 
 import qualified Data.Sequence as Seq
 
+import Monomer.Helper (applyFnList)
 import Monomer.Widgets.Container
 
 import qualified Monomer.Lens as L
@@ -49,19 +50,19 @@ Configuration options for stack:
 -}
 data StackCfg = StackCfg {
   _stcIgnoreEmptyArea :: Maybe Bool,
-  _stcSizeReqUpdater :: Maybe SizeReqUpdater
+  _stcSizeReqUpdater :: [SizeReqUpdater]
 }
 
 instance Default StackCfg where
   def = StackCfg {
     _stcIgnoreEmptyArea = Nothing,
-    _stcSizeReqUpdater = Nothing
+    _stcSizeReqUpdater = []
   }
 
 instance Semigroup StackCfg where
   (<>) s1 s2 = StackCfg {
     _stcIgnoreEmptyArea = _stcIgnoreEmptyArea s2 <|> _stcIgnoreEmptyArea s1,
-    _stcSizeReqUpdater = _stcSizeReqUpdater s2 <|> _stcSizeReqUpdater s1
+    _stcSizeReqUpdater = _stcSizeReqUpdater s1 <> _stcSizeReqUpdater s2
   }
 
 instance Monoid StackCfg where
@@ -74,7 +75,7 @@ instance CmbIgnoreEmptyArea StackCfg where
 
 instance CmbSizeReqUpdater StackCfg where
   sizeReqUpdater updater = def {
-    _stcSizeReqUpdater = Just updater
+    _stcSizeReqUpdater = [updater]
   }
 
 -- | Creates a horizontal stack.
@@ -121,11 +122,11 @@ makeStack isHorizontal config = widget where
   ignoreEmptyArea = fromMaybe False (_stcIgnoreEmptyArea config)
 
   getSizeReq wenv node children = newSizeReq where
-    updateSizeReq = fromMaybe id (_stcSizeReqUpdater config)
+    sizeReqFns = _stcSizeReqUpdater config
     vchildren = Seq.filter (_wniVisible . _wnInfo) children
     newSizeReqW = getDimSizeReq isHorizontal (_wniSizeReqW . _wnInfo) vchildren
     newSizeReqH = getDimSizeReq isVertical (_wniSizeReqH . _wnInfo) vchildren
-    newSizeReq = updateSizeReq (newSizeReqW, newSizeReqH)
+    newSizeReq = applyFnList sizeReqFns (newSizeReqW, newSizeReqH)
 
   getDimSizeReq mainAxis accesor vchildren
     | Seq.null vreqs = fixedSize 0

src/Monomer/Widgets/Util/Drawing.hs

@@ -35,7 +35,6 @@ module Monomer.Widgets.Util.Drawing (
 import Control.Applicative ((<|>))
 import Control.Lens ((&), (^.), (^?), (^?!), (.~), non)
 import Control.Monad (forM_, void, when)
-import Data.ByteString (ByteString)
 import Data.Default
 import Data.Maybe
 import Data.Text (Text)

test/unit/Monomer/Core/SizeReqSpec.hs

@@ -0,0 +1,30 @@
+{-|
+Module      : Monomer.Core.SizeReqSpec
+Copyright   : (c) 2018 Francisco Vallarino
+License     : BSD-3-Clause (see the LICENSE file)
+Maintainer  : fjvallarino@gmail.com
+Stability   : experimental
+Portability : non-portable
+
+Unit tests for SizeReq functions.
+-}
+module Monomer.Core.SizeReqSpec (spec) where
+
+import Test.Hspec
+
+import Monomer.Core.Combinators
+import Monomer.Core.SizeReq
+
+spec :: Spec
+spec = describe "SizeReq" $ do
+  sizeReqUpdaterSpec
+
+sizeReqUpdaterSpec :: Spec
+sizeReqUpdaterSpec = describe "SizeReqUpdater" $ do
+  it "should update fixed size to minimum size" $ do
+    fixedToMinW 1 (width 100, height 100) `shouldBe` (minWidth 100, height 100)
+    fixedToMinH 1 (width 100, height 100) `shouldBe` (width 100, minHeight 100)
+
+  it "should update fixed size to expand size" $ do
+    fixedToExpandW 1 (width 100, height 100) `shouldBe` (expandWidth 100, height 100)
+    fixedToExpandH 1 (width 100, height 100) `shouldBe` (width 100, expandHeight 100)

test/unit/Monomer/Graphics/UtilSpec.hs

@@ -1,5 +1,5 @@
 {-|
-Module      : Monomer.Common.CursorIconSpec
+Module      : Monomer.Graphics.UtilSpec
 Copyright   : (c) 2018 Francisco Vallarino
 License     : BSD-3-Clause (see the LICENSE file)
 Maintainer  : fjvallarino@gmail.com

test/unit/Monomer/Widgets/Containers/BoxSpec.hs

@@ -170,8 +170,7 @@ getSizeReqUpdater = describe "getSizeReqUpdater" $ do
 
   where
     wenv = mockWenvEvtUnit ()
-    updater (rw, rh) = (minSize (rw ^. L.fixed) 2, maxSize (rh ^. L.fixed) 3)
-    boxNode = box_ [sizeReqUpdater updater] (label "Label")
+    boxNode = box_ [sizeReqUpdater (fixedToMinW 2), sizeReqUpdater (fixedToMaxH 3)] (label "Label")
     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv boxNode
 
 resize :: Spec

test/unit/Monomer/Widgets/Containers/GridSpec.hs

@@ -133,8 +133,7 @@ getSizeReqUpdater = describe "getSizeReqUpdater" $ do
 
   where
     wenv = mockWenv ()
-    updater (rw, rh) = (minSize (rw ^. L.fixed) 2, maxSize (rh ^. L.fixed) 3)
-    vgridNode = vgrid_ [sizeReqUpdater updater] [label "Label"]
+    vgridNode = vgrid_ [sizeReqUpdater (fixedToMinW 2), sizeReqUpdater (fixedToMaxH 3)] [label "Label"]
     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv vgridNode
 
 resize :: Spec

test/unit/Monomer/Widgets/Containers/StackSpec.hs

@@ -73,16 +73,24 @@ getSizeReqItems = describe "several items" $ do
 getSizeReqUpdater :: Spec
 getSizeReqUpdater = describe "getSizeReqUpdater" $ do
   it "should return width = Min 50 2" $
-    sizeReqW `shouldBe` minSize 50 2
+    sizeReqW1 `shouldBe` minSize 50 2
 
   it "should return height = Max 20" $
-    sizeReqH `shouldBe` maxSize 20 3
+    sizeReqH1 `shouldBe` maxSize 20 3
+
+  it "should return width = Min 50 10" $
+    sizeReqW2 `shouldBe` minSize 50 10
+
+  it "should return height = Max 20 15" $
+    sizeReqH2 `shouldBe` maxSize 20 15
 
   where
     wenv = mockWenv ()
     updater (rw, rh) = (minSize (rw ^. L.fixed) 2, maxSize (rh ^. L.fixed) 3)
-    vstackNode = vstack_ [sizeReqUpdater updater] [label "Label"]
-    (sizeReqW, sizeReqH) = nodeGetSizeReq wenv vstackNode
+    vstackNode1 = vstack_ [sizeReqUpdater updater] [label "Label"]
+    vstackNode2 = vstack_ [sizeReqUpdater (fixedToMinW 10), sizeReqUpdater (fixedToMaxH 15)] [label "Label"]
+    (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv vstackNode1
+    (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv vstackNode2
 
 resize :: Spec
 resize = describe "resize" $ do

test/unit/Spec.hs

@@ -6,6 +6,7 @@ import qualified SDL
 import qualified SDL.Raw as Raw
 
 import qualified Monomer.Common.CursorIconSpec as CursorIconSpec
+import qualified Monomer.Core.SizeReqSpec as SizeReqSpec
 import qualified Monomer.Graphics.UtilSpec as GraphicsUtilSpec
 
 import qualified Monomer.Widgets.CompositeSpec as CompositeSpec
@@ -65,6 +66,7 @@ main = do
 spec :: Spec
 spec = do
   common
+  core
   graphics
   widgets
   widgetsUtil
@@ -73,6 +75,10 @@ common :: Spec
 common = describe "Common" $ do
   CursorIconSpec.spec
 
+core :: Spec
+core = describe "Core" $ do
+  SizeReqSpec.spec
+
 graphics :: Spec
 graphics = describe "Graphics" $ do
   GraphicsUtilSpec.spec