Add alignment options to image

.ghcid

@@ -1,3 +1,3 @@
---command "stack repl --main-is monomer:exe:todo"
+--command "stack repl --main-is monomer:exe:books"
 --test ":main"
 --restart=package.yaml

app/TestComposite.hs

@@ -13,8 +13,8 @@ import TextShow
 
 import Monomer.Core.Combinators
 import Monomer.Core.Style
-import Monomer.Graphics.Color
 import Monomer.Graphics.ColorTable (gray)
+import Monomer.Graphics.Util
 import Monomer.Core.WidgetTypes
 import Monomer.Core.Util
 import Monomer.Widgets

examples/books/Main.hs

@@ -26,7 +26,7 @@ buildUI wenv model = widgetTree where
   bookImage imgId size = maybe filler coverImg imgId where
     baseUrl = "http://covers.openlibrary.org/b/id/<id>-<size>.jpg"
     imgUrl i = T.replace "<size>" size $ T.replace "<id>" (showt i) baseUrl
-    coverImg i = image_ (imgUrl i) [fitFill]
+    coverImg i = image_ (imgUrl i) [fitHeight, alignRight]
   bookRow b = box_ cfg content `style` [padding 10, paddingT 0] where
     cfg = [expandContent, onClick (BooksShowDetails b)]
     content = bookRowContent b

monomer.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0034398fa73a706ff4f38ec5d91fd53a82457809731868c37b24630a6c431354
+-- hash: e9cd0fb27bcf456724b1c412cf85e4063c1b7d69e6d55a9c36b6260203aeb70d
 
 name:           monomer
 version:        0.1.0.0
@@ -54,12 +54,12 @@ library
       Monomer.Event.Types
       Monomer.Event.Util
       Monomer.Graphics
-      Monomer.Graphics.Color
       Monomer.Graphics.ColorTable
       Monomer.Graphics.Lens
       Monomer.Graphics.NanoVGRenderer
       Monomer.Graphics.Text
       Monomer.Graphics.Types
+      Monomer.Graphics.Util
       Monomer.Helper
       Monomer.Lens
       Monomer.Main

src/Monomer/Core/StyleTypes.hs

@@ -17,8 +17,8 @@ import Data.Default
 import GHC.Generics
 
 import Monomer.Common
-import Monomer.Graphics.Color
 import Monomer.Graphics.Types
+import Monomer.Graphics.Util
 
 {-|
 Represents a size requirement for a specific axis. Mainly used by stack and box,

src/Monomer/Core/Themes/BaseTheme.hs

@@ -21,7 +21,6 @@ import Data.Default
 
 import Monomer.Core.Combinators
 import Monomer.Core.Style
-import Monomer.Graphics.Color
 import Monomer.Graphics.Types
 
 import qualified Monomer.Core.Lens as L

src/Monomer/Graphics.hs

@@ -10,13 +10,13 @@ Graphics module, including all related types, low level renderer interface,
 nanovg implementation and higher level drawing helpers.
 -}
 module Monomer.Graphics (
-  module Monomer.Graphics.Color,
   module Monomer.Graphics.NanoVGRenderer,
   module Monomer.Graphics.Text,
-  module Monomer.Graphics.Types
+  module Monomer.Graphics.Types,
+  module Monomer.Graphics.Util
 ) where
 
-import Monomer.Graphics.Color
 import Monomer.Graphics.NanoVGRenderer
 import Monomer.Graphics.Text
 import Monomer.Graphics.Types
+import Monomer.Graphics.Util

src/Monomer/Graphics/ColorTable.hs

@@ -10,8 +10,7 @@ Color table imported from https://www.rapidtables.com/web/color/RGB_Color.html.
 -}
 module Monomer.Graphics.ColorTable where
 
-import Monomer.Graphics.Color
-import Monomer.Graphics.Types
+import Monomer.Graphics.Util (rgbHex)
 
 maroon = rgbHex "#800000"
 darkRed = rgbHex "#8B0000"

src/Monomer/Graphics/Util.hs

@@ -1,24 +1,28 @@
 {-|
-Module      : Monomer.Graphics.Color
+Module      : Monomer.Graphics.Util
 Copyright   : (c) 2018 Francisco Vallarino
 License     : BSD-3-Clause (see the LICENSE file)
 Maintainer  : fjvallarino@gmail.com
 Stability   : experimental
 Portability : non-portable
 
-Helper functions for color related operations.
+Helper functions for graphics related operations.
 -}
-module Monomer.Graphics.Color (
+module Monomer.Graphics.Util (
   clampChannel,
   clampAlpha,
   rgb,
   rgbHex,
   rgba,
-  transparent
+  transparent,
+  alignInRect,
+  alignHInRect,
+  alignVInRect
 ) where
 
 import Data.Char (digitToInt)
 
+import Monomer.Common.BasicTypes
 import Monomer.Graphics.Types
 import Monomer.Helper
 
@@ -58,3 +62,35 @@ rgba r g b a = Color {
 -- | Creates a non visible color.
 transparent :: Color
 transparent = rgba 0 0 0 0
+
+{-|
+Aligns the child rect inside the parent given the alignment constraints.
+
+Note: The child rect can overflow the parent.
+-}
+alignInRect :: Rect -> Rect -> AlignH -> AlignV -> Rect
+alignInRect parent child ah av = newRect where
+  tempRect = alignVInRect parent child av
+  newRect = alignHInRect parent tempRect ah
+
+-- | Aligns the child rect horizontally inside the parent.
+alignHInRect :: Rect -> Rect -> AlignH -> Rect
+alignHInRect parent child ah = newRect where
+  Rect px _ pw _ = parent
+  Rect _ cy cw ch = child
+  newX = case ah of
+    ALeft -> px
+    ACenter -> px + (pw - cw) / 2
+    ARight -> px + pw - cw
+  newRect = Rect newX cy cw ch
+
+-- | Aligns the child rect vertically inside the parent.
+alignVInRect :: Rect -> Rect -> AlignV -> Rect
+alignVInRect parent child av = newRect where
+  Rect _ py _ ph = parent
+  Rect cx _ cw ch = child
+  newY = case av of
+    ATop -> py
+    AMiddle -> py + (ph - ch) / 2
+    ABottom -> py + ph - ch
+  newRect = Rect cx newY cw ch

src/Monomer/Widgets/Containers/Box.hs

@@ -334,33 +334,8 @@ makeBox config = widget where
     raChild = Rect cx cy (min cw contentW) (min ch contentH)
     ah = fromMaybe ACenter (_boxAlignH config)
     av = fromMaybe AMiddle (_boxAlignV config)
-    raAligned = alignInRect ah av contentArea raChild
+    raAligned = alignInRect contentArea raChild ah av
     expand = fromMaybe False (_boxExpandContent config)
     resized
       | expand = (resultNode node, Seq.singleton contentArea)
       | otherwise = (resultNode node, Seq.singleton raAligned)
-
-alignInRect :: AlignH -> AlignV -> Rect -> Rect -> Rect
-alignInRect ah av parent child = newRect where
-  tempRect = alignVInRect av parent child
-  newRect = alignHInRect ah parent tempRect
-
-alignHInRect :: AlignH -> Rect -> Rect -> Rect
-alignHInRect ah parent child = newRect where
-  Rect px _ pw _ = parent
-  Rect _ cy cw ch = child
-  newX = case ah of
-    ALeft -> px
-    ACenter -> px + (pw - cw) / 2
-    ARight -> px + pw - cw
-  newRect = Rect newX cy cw ch
-
-alignVInRect :: AlignV -> Rect -> Rect -> Rect
-alignVInRect av parent child = newRect where
-  Rect _ py _ ph = parent
-  Rect cx _ cw ch = child
-  newY = case av of
-    ATop -> py
-    AMiddle -> py + (ph - ch) / 2
-    ABottom -> py + ph - ch
-  newRect = Rect cx newY cw ch

src/Monomer/Widgets/Singles/Icon.hs

@@ -28,7 +28,7 @@ import Data.Maybe
 
 import qualified Data.Text as T
 
-import Monomer.Graphics.Color
+import Monomer.Graphics.Util
 
 import Monomer.Widgets.Single
 

src/Monomer/Widgets/Singles/Image.hs

@@ -8,6 +8,9 @@ Portability : non-portable
 
 Displays an image from local storage or a url.
 
+Note: depending on the type of image fit chosen and the assigned viewport, extra
+space may remain unused. The alignment options exist to handle this situation.
+
 Configs:
 
 - transparency: the alpha to apply when rendering the image.
@@ -19,6 +22,12 @@ Configs:
 - fitFill: stretches the image to match the viewport.
 - fitWidth: stretches the image to match the viewport width. Maintains ratio.
 - fitHeight: stretches the image to match the viewport height. Maintains ratio.
+- alignLeft: aligns left if extra space is available.
+- alignRight: aligns right if extra space is available.
+- alignCenter: aligns center if extra space is available.
+- alignTop: aligns top if extra space is available.
+- alignMiddle: aligns middle if extra space is available.
+- alignBottom: aligns bottom if extra space is available.
 -}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -75,6 +84,8 @@ data ImageCfg e = ImageCfg {
   _imcLoadError :: [ImageLoadError -> e],
   _imcFlags :: [ImageFlag],
   _imcFit :: Maybe ImageFit,
+  _imcAlignH :: Maybe AlignH,
+  _imcAlignV :: Maybe AlignV,
   _imcTransparency :: Maybe Double
 }
 
@@ -83,6 +94,8 @@ instance Default (ImageCfg e) where
     _imcLoadError = [],
     _imcFlags = [],
     _imcFit = Nothing,
+    _imcAlignH = Nothing,
+    _imcAlignV = Nothing,
     _imcTransparency = Nothing
   }
 
@@ -91,6 +104,8 @@ instance Semigroup (ImageCfg e) where
     _imcLoadError = _imcLoadError i1 ++ _imcLoadError i2,
     _imcFlags = _imcFlags i1 ++ _imcFlags i2,
     _imcFit = _imcFit i2 <|> _imcFit i1,
+    _imcAlignH = _imcAlignH i2 <|> _imcAlignH i1,
+    _imcAlignV = _imcAlignV i2 <|> _imcAlignV i1,
     _imcTransparency = _imcTransparency i2 <|> _imcTransparency i1
   }
 
@@ -142,6 +157,42 @@ instance CmbFitHeight (ImageCfg e) where
     _imcFit = Just FitHeight
   }
 
+instance CmbAlignLeft (ImageCfg e) where
+  alignLeft_ False = def
+  alignLeft_ True = def {
+    _imcAlignH = Just ALeft
+  }
+
+instance CmbAlignCenter (ImageCfg e) where
+  alignCenter_ False = def
+  alignCenter_ True = def {
+    _imcAlignH = Just ACenter
+  }
+
+instance CmbAlignRight (ImageCfg e) where
+  alignRight_ False = def
+  alignRight_ True = def {
+    _imcAlignH = Just ARight
+  }
+
+instance CmbAlignTop (ImageCfg e) where
+  alignTop_ False = def
+  alignTop_ True = def {
+    _imcAlignV = Just ATop
+  }
+
+instance CmbAlignMiddle (ImageCfg e) where
+  alignMiddle_ False = def
+  alignMiddle_ True = def {
+    _imcAlignV = Just AMiddle
+  }
+
+instance CmbAlignBottom (ImageCfg e) where
+  alignBottom_ False = def
+  alignBottom_ True = def {
+    _imcAlignV = Just ABottom
+  }
+
 data ImageSource
   = ImageMem String
   | ImagePath String
@@ -272,23 +323,26 @@ makeImage imgSource config state = widget where
       contentArea = getContentArea style node
       alpha = fromMaybe 1 (_imcTransparency config)
       fitMode = fromMaybe FitNone (_imcFit config)
+      alignH = fromMaybe ALeft (_imcAlignH config)
+      alignV = fromMaybe ATop (_imcAlignV config)
       imgPath = imgName imgSource
       imgFlags = _imcFlags config
-      imageRect = fitImage fitMode imgSize contentArea
+      imageRect = fitImage contentArea imgSize fitMode alignH alignV
       ImageState _ imgData = state
       imageLoaded = isJust imgData
       (imgBytes, imgSize) = fromJust imgData
       imageExists = isJust (getImage renderer imgPath)
 
-fitImage :: ImageFit -> Size -> Rect -> Rect
-fitImage fitMode imageSize viewport = case fitMode of
-  FitNone -> Rect x y iw ih
-  FitFill -> Rect x y w h
-  FitWidth -> Rect x y w ih
-  FitHeight -> Rect x y iw h
+fitImage :: Rect -> Size -> ImageFit -> AlignH -> AlignV -> Rect
+fitImage viewport imageSize fitMode alignH alignV = case fitMode of
+  FitNone -> alignImg iw ih
+  FitFill -> alignImg w h
+  FitWidth -> alignImg w (w * ih / iw)
+  FitHeight -> alignImg (h * iw / ih) h
   where
     Rect x y w h = viewport
     Size iw ih = imageSize
+    alignImg nw nh = alignInRect viewport (Rect x y nw nh) alignH alignV
 
 handleImageLoad :: ImageCfg e -> WidgetEnv s e -> String -> IO ImageMessage
 handleImageLoad config wenv path =