Add support for NanoVG image flags

app/Main.hs

@@ -146,6 +146,7 @@ handleAppEvent wenv node model evt = case evt of
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
 buildUI wenv model = traceShow "Creating UI" widgetSlider where
   widgetSlider = vstack [
+      image_ "assets/images/pecans.jpg" [fitFill],
       hstack [externalLink "Launch GitHub" "http://www.github.com"],
       colorPicker_ color [onChange UpdateColor, onFocus FocusColor, onBlur BlurColor],
       labelS (model ^. int1),

src/Monomer/Graphics/Drawing.hs

@@ -249,9 +249,16 @@ drawImage renderer imgName rect alpha = action where
   action = renderImage renderer imgName rect alpha
 
 drawNewImage
-  :: Renderer -> String -> Size -> ByteString -> Rect -> Double -> IO ()
-drawNewImage renderer imgName size imgData rect alpha = action where
-  action = renderNewImage renderer imgName size imgData rect alpha
+  :: Renderer
+  -> String
+  -> Rect
+  -> Double
+  -> Size
+  -> ByteString
+  -> [ImageFlag]
+  -> IO ()
+drawNewImage renderer imgName rect alpha size imgData flags = action where
+  action = renderNewImage renderer imgName rect alpha size imgData flags
 
 drawStyledImage :: Renderer -> String -> Rect -> Double -> StyleState -> IO ()
 drawStyledImage renderer imgName rect alpha style = forM_ tempRect action where

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -53,7 +53,8 @@ data ImageReq = ImageReq {
   _irName :: String,
   _irSize :: Size,
   _irImgData :: Maybe BS.ByteString,
-  _irAction :: ImageAction
+  _irAction :: ImageAction,
+  _irFlags :: [ImageFlag]
 }
 
 data Env = Env {
@@ -64,6 +65,10 @@ data Env = Env {
   addedImages :: Seq ImageReq
 }
 
+data CSize
+  = CSize CFloat CFloat
+  deriving (Eq, Show)
+
 data CPoint
   = CPoint CFloat CFloat
   deriving (Eq, Show)
@@ -299,21 +304,21 @@ newRenderer c dpr lock envRef = Renderer {..} where
     let image = M.lookup name (imagesMap env)
     return $ fmap _imImageDef image
 
-  addImage name size imgData = L.with lock (addPending c envRef imgReq) where
-    imgReq = ImageReq name size (Just imgData) ImageAdd
+  addImage name size imgData flags = L.with lock (addPending c envRef req) where
+    req = ImageReq name size (Just imgData) ImageAdd flags
 
-  updateImage name size imgData = L.with lock (addPending c envRef imgReq) where
-    imgReq = ImageReq name size (Just imgData) ImageUpdate
+  updateImage name size imgData = L.with lock (addPending c envRef req) where
+    req = ImageReq name size (Just imgData) ImageUpdate []
 
-  deleteImage name = L.with lock (addPending c envRef imgReq) where
-    imgReq = ImageReq name def Nothing ImageDelete
+  deleteImage name = L.with lock (addPending c envRef req) where
+    req = ImageReq name def Nothing ImageDelete []
 
   renderImage name rect alpha = do
     env <- readIORef envRef
     mapM_ (handleImageRender c dpr rect alpha) $ M.lookup name (imagesMap env)
 
-  renderNewImage name size imgData rect alpha = L.with lock $ do
-    addPending c envRef $ ImageReq name size (Just imgData) ImageUpdate
+  renderNewImage name rect alpha size imgData flags = L.with lock $ do
+    addPending c envRef $ ImageReq name size (Just imgData) ImageUpdate flags
     newEnv <- handlePendingImages c envRef
     mapM_ (handleImageRender c dpr rect alpha) $ M.lookup name (imagesMap newEnv)
 
@@ -369,13 +374,15 @@ addPending c envRef imageReq = do
 
 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
+  imgPaint <- VG.imagePattern c x y iw ih 0 nvImg calpha
   VG.beginPath c
   VG.rect c x y w h
   VG.fillPaint c imgPaint
   VG.fill c
   where
     CRect x y w h = rectToCRect rect dpr
+    imgDef = _imImageDef image
+    CSize iw ih = sizeToCSize (_idfSize imgDef) dpr
     nvImg = _imNvImage image
     calpha = realToFrac alpha
 
@@ -426,12 +433,18 @@ handlePendingImage c imagesMap imageReq
     cw = round (size ^. L.w)
     ch = round (size ^. L.h)
     imgData = fromJust $ _irImgData imageReq
+    flags = Set.fromList (toVGImgFlag <$> _irFlags imageReq)
     imgDef = ImageDef name size imgData
     mimage = M.lookup name imagesMap
     imageExists = isJust mimage
     image = fromJust mimage
     sizeMatches = size == _imImageDef image ^. L.size
-    createImage = VG.createImageRGBA c cw ch VGI.ImageNearest imgData
+    createImage = VG.createImageRGBA c cw ch flags imgData
+
+toVGImgFlag :: ImageFlag -> VGI.ImageFlags
+toVGImgFlag ImageNearest = VGI.ImageNearest
+toVGImgFlag ImageRepeatX = VGI.ImageRepeatx
+toVGImgFlag ImageRepeatY = VGI.ImageRepeaty
 
 imgIncreaseCount :: String -> ImagesMap -> ImagesMap
 imgIncreaseCount name imagesMap = newImageMap where
@@ -470,6 +483,11 @@ convertWinding :: Winding -> VG.Winding
 convertWinding CW = VG.CW
 convertWinding CCW = VG.CCW
 
+sizeToCSize :: Size -> Double -> CSize
+sizeToCSize (Size w h) dpr = CSize cw ch where
+  cw = realToFrac $ w * dpr
+  ch = realToFrac $ h * dpr
+
 pointToCPoint :: Point -> Double -> CPoint
 pointToCPoint (Point x y) dpr = CPoint cx cy where
   cx = realToFrac $ x * dpr

src/Monomer/Graphics/Types.hs

@@ -142,6 +142,12 @@ data TextLine = TextLine {
   _tlMetrics :: !TextMetrics
 } deriving (Eq, Show, Generic)
 
+data ImageFlag
+  = ImageNearest
+  | ImageRepeatX
+  | ImageRepeatY
+  deriving (Eq, Show, Generic)
+
 data ImageDef = ImageDef {
   _idfName :: String,
   _idfSize :: Size,
@@ -198,9 +204,9 @@ data Renderer = Renderer {
   renderText :: Point -> Font -> FontSize -> Text -> IO (),
   -- Image
   getImage :: String -> Maybe ImageDef,
-  addImage :: String -> Size -> ByteString -> IO (),
+  addImage :: String -> Size -> ByteString -> [ImageFlag] -> IO (),
   updateImage :: String -> Size -> ByteString -> IO (),
   deleteImage :: String -> IO (),
   renderImage :: String -> Rect -> Double -> IO (),
-  renderNewImage :: String -> Size -> ByteString -> Rect -> Double -> IO ()
+  renderNewImage :: String -> Rect -> Double -> Size -> ByteString -> [ImageFlag] -> IO ()
 }

stack.yaml

@@ -43,7 +43,7 @@ packages:
 # (e.g., acme-missiles-0.3)
 extra-deps:
   - git: https://github.com/fjvallarino/nanovg-hs
-    commit: 89a33f177a7dc59c017d7ce916da89ee4a02ffbf
+    commit: b79fa2bfd60e26f49eea6fcafd668396835714b4
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack.yaml.lock

@@ -10,11 +10,11 @@ packages:
     git: https://github.com/fjvallarino/nanovg-hs
     pantry-tree:
       size: 5707
-      sha256: a9471540404d76a1747d9c32e786d4a3f95e5debf30a7873a122857b24accd99
-    commit: 89a33f177a7dc59c017d7ce916da89ee4a02ffbf
+      sha256: b08e642c255d38cd38a3d1ac49212ee74a1eefbd06559e3b70e99261d46765cf
+    commit: b79fa2bfd60e26f49eea6fcafd668396835714b4
   original:
     git: https://github.com/fjvallarino/nanovg-hs
-    commit: 89a33f177a7dc59c017d7ce916da89ee4a02ffbf
+    commit: b79fa2bfd60e26f49eea6fcafd668396835714b4
 snapshots:
 - completed:
     size: 565712

tasks.md

@@ -602,6 +602,7 @@ Next
   - Create Color Selector
     - Add lens/value version
     - Show pattern to test alpha
+    - Handle blur/focus/onchange
   - Add externalLink component
     - https://stackoverflow.com/questions/3037088/how-to-open-the-default-web-browser-in-windows-in-c/54334181
   - Review onChangeReq (a parameter should be provided)