Add config options to image widget

app/Main.hs

@@ -152,7 +152,7 @@ buildUI model = trace "Creating UI" widgetTree where
       ],
       hgrid [
         image "assets/images/pecans.jpg",
-        image "https://picsum.photos/600/400"
+        image_ "https://picsum.photos/600/400" [fitHeight, transparency 0.3]
       ],
       button "Click me" (PrintMessage "Button clicked")
       --,

src/Monomer/Graphics/Drawing.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
 
 module Monomer.Graphics.Drawing (
+  drawInScissor,
   drawRect,
   drawRectBorder,
   drawEllipse,
@@ -24,6 +25,13 @@ import Monomer.Common.Style
 import Monomer.Common.StyleUtil
 import Monomer.Graphics.Types
 
+drawInScissor :: Renderer -> Bool -> Rect -> IO () -> IO ()
+drawInScissor renderer False _ action = action
+drawInScissor renderer True rect action = do
+  setScissor renderer rect
+  action
+  resetScissor renderer
+
 drawRect :: Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
 drawRect _ _ Nothing _ = pure ()
 drawRect renderer viewport (Just color) Nothing = do
@@ -108,14 +116,14 @@ drawText renderer viewport color font fontSize align txt = do
   setFillColor renderer color
   renderText renderer viewport font fontSize align txt
 
-drawImage :: Renderer -> Rect -> String -> IO ()
-drawImage renderer viewport imgName = action where
-  action = renderImage renderer viewport imgName
+drawImage :: Renderer -> String -> Rect -> Double -> IO ()
+drawImage renderer imgName viewport alpha = action where
+  action = renderImage renderer imgName viewport alpha
 
-drawStyledImage :: Renderer -> Rect -> StyleState -> String -> IO ()
-drawStyledImage renderer viewport style imgName = action where
+drawStyledImage :: Renderer -> String -> Rect -> Double -> StyleState -> IO ()
+drawStyledImage renderer imgName viewport alpha style = action where
   imgRect = removeOuterBounds style viewport
-  action = renderImage renderer imgRect imgName
+  action = renderImage renderer imgName imgRect alpha
 
 drawRoundedRect :: Renderer -> Rect -> Radius -> IO ()
 drawRoundedRect renderer (Rect x y w h) Radius{..} =

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -303,10 +303,11 @@ newRenderer c dpr lock envRef = Renderer {..} where
     env <- readIORef envRef
     return $ M.member name (imagesMap env)
 
-  renderImage rect name = do
+  renderImage name rect alpha = do
     env <- readIORef envRef
-    mapM_ (handleRender c dpr rect) $ M.lookup name (imagesMap env)
+    mapM_ (handleImageRender c dpr rect alpha) $ M.lookup name (imagesMap env)
 
+addPending :: L.Lock -> IORef Env -> ImageReq -> IO ()
 addPending lock envRef imageReq = L.with lock $ do
   env <- readIORef envRef
 
@@ -314,9 +315,9 @@ addPending lock envRef imageReq = L.with lock $ do
     addedImages = addedImages env |> imageReq
   }
 
-handleRender :: VG.Context -> Double -> Rect -> Image -> IO ()
-handleRender c dpr rect image = do
-  imgPaint <- VG.imagePattern c x y w h 0 nvImg 1
+handleImageRender :: VG.Context -> Double -> Rect -> Double -> Image -> IO ()
+handleImageRender c dpr rect alpha image = do
+  imgPaint <- VG.imagePattern c x y w h 0 nvImg calpha
   VG.beginPath c
   VG.rect c x y w h
   VG.fillPaint c imgPaint
@@ -324,6 +325,7 @@ handleRender c dpr rect image = do
   where
     CRect x y w h = rectToCRect rect dpr
     nvImg = _imNvImage image
+    calpha = realToFrac alpha
 
 textGlyphPositions
   :: VG.Context -> Double -> Double -> Text -> IO (V.Vector VG.GlyphPosition)

src/Monomer/Graphics/Types.hs

@@ -129,7 +129,7 @@ data Renderer = Renderer {
   updateImage :: String -> ByteString -> IO (),
   deleteImage :: String -> IO (),
   existsImage :: String -> Bool,
-  renderImage :: Rect -> String -> IO ()
+  renderImage :: String -> Rect -> Double -> IO ()
 }
 
 makeLensesWith abbreviatedFields ''Color

src/Monomer/Widget/Widgets/Image.hs

@@ -1,8 +1,16 @@
-module Monomer.Widget.Widgets.Image (image) where
+module Monomer.Widget.Widgets.Image (
+  image,
+  image_,
+  fitNone,
+  fitFill,
+  fitWidth,
+  fitHeight
+) where
 
 import Debug.Trace
 
 import Codec.Picture (DynamicImage, Image(..))
+import Control.Applicative ((<|>))
 import Control.Lens ((^.))
 import Control.Monad (when)
 import Data.ByteString (ByteString)
@@ -24,6 +32,51 @@ import Monomer.Graphics.Types
 import Monomer.Widget.BaseSingle
 import Monomer.Widget.Types
 import Monomer.Widget.Util
+import Monomer.Widget.Widgets.WidgetCombinators
+
+data ImageFit
+  = FitNone
+  | FitFill
+  | FitWidth
+  | FitHeight
+  deriving (Eq, Show)
+
+data ImageCfg = ImageCfg {
+  _imcFit :: Maybe ImageFit,
+  _imcTransparency :: Maybe Double
+}
+
+instance Default ImageCfg where
+  def = ImageCfg {
+    _imcFit = Nothing,
+    _imcTransparency = Nothing
+  }
+
+instance Semigroup ImageCfg where
+  (<>) i1 i2 = ImageCfg {
+    _imcFit = _imcFit i2 <|> _imcFit i1,
+    _imcTransparency = _imcTransparency i2 <|> _imcTransparency i1
+  }
+
+instance Monoid ImageCfg where
+  mempty = def
+
+instance Transparency ImageCfg where
+  transparency alpha = def {
+    _imcTransparency = Just alpha
+  }
+
+fitNone :: ImageCfg
+fitNone = def { _imcFit = Just FitNone }
+
+fitFill :: ImageCfg
+fitFill = def { _imcFit = Just FitFill }
+
+fitWidth :: ImageCfg
+fitWidth = def { _imcFit = Just FitWidth }
+
+fitHeight :: ImageCfg
+fitHeight = def { _imcFit = Just FitHeight }
 
 newtype ImageState = ImageState {
   isImageData :: Maybe (ByteString, Size)
@@ -37,10 +90,15 @@ imageState :: ImageState
 imageState = ImageState Nothing
 
 image :: String -> WidgetInstance s e
-image path = defaultWidgetInstance "image" (makeImage path imageState)
+image path = image_ path def
 
-makeImage :: String -> ImageState -> Widget s e
-makeImage imgPath state = widget where
+image_ :: String -> [ImageCfg] -> WidgetInstance s e
+image_ path configs = defaultWidgetInstance "image" widget where
+  config = mconcat configs
+  widget = makeImage path config imageState
+
+makeImage :: String -> ImageCfg -> ImageState -> Widget s e
+makeImage imgPath config state = widget where
   widget = createSingle def {
     singleInit = init,
     singleDispose = dispose,
@@ -64,7 +122,7 @@ makeImage imgPath state = widget where
   useImage inst (ImageFailed msg) = traceShow msg Nothing
   useImage inst (ImageLoaded newState) = result where
     newInst = inst {
-      _wiWidget = makeImage imgPath newState
+      _wiWidget = makeImage imgPath config newState
     }
     result = Just $ resultReqs [Resize] newInst
 
@@ -78,15 +136,30 @@ makeImage imgPath state = widget where
     when (imageLoaded && not imageExists) $
       addImage renderer imgPath ImageAddKeep imgSize imgBytes
 
-    drawStyledImage renderer contentRect style imgPath
+    when imageLoaded $
+      drawInScissor renderer True contentRect $
+        drawStyledImage renderer imgPath imageRect alpha style
     where
       style = activeStyle wenv inst
       contentRect = getContentRect style inst
+      alpha = fromMaybe 1 (_imcTransparency config)
+      fitMode = fromMaybe FitNone (_imcFit config)
+      imageRect = fitImage fitMode imgSize contentRect
       ImageState imgData = state
       imageLoaded = isJust imgData
       (imgBytes, imgSize) = fromJust imgData
       imageExists = existsImage renderer imgPath
 
+fitImage :: ImageFit -> Size -> Rect -> Rect
+fitImage fitMode imageSize renderArea = 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
+  where
+    Rect x y w h = renderArea
+    Size iw ih = imageSize
+
 handleImageLoad :: WidgetEnv s e -> String -> IO ImageMessage
 handleImageLoad wenv path = do
   res <- loadImage path

src/Monomer/Widget/Widgets/Label.hs

@@ -95,10 +95,9 @@ makeLabel config state = widget where
       _wiRenderArea = renderArea
     }
 
-  render renderer wenv inst = do
-    setScissor renderer contentRect
-    drawStyledText_ renderer contentRect style captionFit
-    resetScissor renderer
+  render renderer wenv inst =
+    drawInScissor renderer True contentRect $
+      drawStyledText_ renderer contentRect style captionFit
     where
       style = activeStyle wenv inst
       contentRect = getContentRect style inst

src/Monomer/Widget/Widgets/WidgetCombinators.hs

@@ -60,6 +60,9 @@ class HoverStyle t where
 class HighlightedColor t where
   highlightedColor :: Color -> t
 
+class Transparency t where
+  transparency :: Double -> t
+
 class OnTextOverflow t where
   textEllipsis :: t
   textClip :: t

tasks.md

@@ -185,9 +185,9 @@
     - Should value come before items/option?
     - Should we use a list of configs instead of <> operator?
   - Add options to label/button (ellipsis/cut)
+  - Add support for urls to image widget
 
 - Pending
-  - Add support for urls to image widget
   - Add options to image widget (stretch/crop/etc)
     - Check if re-adding image on render should be inside lock
   - Compare Cairo/Skia interfaces to make Renderer able to handle future implementations
@@ -210,6 +210,7 @@
   - Add user documentation
 
 Maybe postponed after release?
+  - Do not draw non visible items in grid/stack (outside viewport)
   - Further textField improvements
     - Handle mouse selection
     - Handle undo history
@@ -231,7 +232,3 @@ Maybe postponed after release?
     - Add new request types (drag started, drag stopped, drag cancelled)
     - Add new events (drag hover)
     - SDL supports Drag and Drop integration with OS
-  - Look for opportunities to reduce code duplication (CompositeWidget and BaseContainer)
-  - Check if using [lifted-async](https://github.com/maoe/lifted-async) is worth it
-  - Implement SDL_Surface + Cairo backend
-    - Can we cache some drawing operations?