packages feed

monomer 1.0.0.3 → 1.1.0.0

raw patch · 58 files changed

+965/−121 lines, 58 filesdep +OpenGLRawnew-component:exe:opengl

Dependencies added: OpenGLRaw

Files

ChangeLog.md view
@@ -1,3 +1,16 @@+### 1.1.0.0++- Reduce memory usage by sharing wreq session among image widget instances.+- Add sizeUpdater helpers. Support multiple handlers in box, grid and stack.+- Add `dpr` field to `WidgetEnv`.+- Add `RunInRenderThread` to support initialization of low level OpenGL resources.+- Set correct `WidgetEnv` viewport from scroll (it looked good because of scissoring).+- Fix issue with scrollbars using child coordinates for detecting clicks.+- Add OpenGL example.+- Add `containerDrawDecorations`. Simplify button/externalLink internals.+- Add ThemeState entries for optionButton and toggleButton widgets.+- Add `singleDrawDecorations`. Make it consistent with Container.+ ### 1.0.0.3  - Consume and forward all available messages from Producers on each cycle.
README.md view
@@ -54,6 +54,7 @@ - [Books](docs/examples/02-books.md) - [Ticker](docs/examples/03-ticker.md) - [Generative](docs/examples/04-generative.md)+- [Custom OpenGL](docs/examples/05-opengl.md)  ### Haddock
cbits/fontmanager.c view
@@ -2,6 +2,7 @@  #include <stdio.h> #include <stdlib.h>+#include <string.h> #include <memory.h>  #include "fontstash.h"
examples/books/BookTypes.hs view
@@ -1,3 +1,13 @@+{-|+Module      : BookTypes+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Types for the 'Books' example.+-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-}
examples/books/Main.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the 'Books' example.+-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -14,6 +24,7 @@  import qualified Data.Text as T import qualified Network.Wreq as W+import qualified Network.Wreq.Session as Sess  import BookTypes import Monomer@@ -123,16 +134,17 @@     ]  handleEvent-  :: WidgetEnv BooksModel BooksEvt+  :: Sess.Session+  -> WidgetEnv BooksModel BooksEvt   -> WidgetNode BooksModel BooksEvt   -> BooksModel   -> BooksEvt   -> [EventResponse BooksModel BooksEvt BooksModel ()]-handleEvent wenv node model evt = case evt of+handleEvent sess wenv node model evt = case evt of   BooksInit -> [setFocusOnKey wenv "query"]   BooksSearch -> [     Model $ model & searching .~ True,-    Task $ searchBooks (model ^. query)+    Task $ searchBooks sess (model ^. query)     ]   BooksSearchResult resp -> [     Message "mainScroll" ScrollReset,@@ -151,8 +163,8 @@   BooksCloseDetails -> [Model $ model & selected .~ Nothing]   BooksCloseError -> [Model $ model & errorMsg .~ Nothing] -searchBooks :: Text -> IO BooksEvt-searchBooks query = do+searchBooks :: Sess.Session -> Text -> IO BooksEvt+searchBooks sess query = do   putStrLn . T.unpack $ "Searching: " <> query   result <- catchAny (fetch url) (return . Left . T.pack . show) @@ -165,7 +177,7 @@       | null (resp ^. docs) = Nothing       | otherwise = Just resp     fetch url = do-      resp <- W.get url+      resp <- Sess.get sess url         >>= W.asJSON         >>= return . preview (W.responseBody . _Just) @@ -173,7 +185,8 @@  main :: IO () main = do-  startApp initModel handleEvent buildUI config+  sess <- Sess.newAPISession+  startApp initModel (handleEvent sess) buildUI config   where     config = [       appWindowTitle "Book search",
examples/generative/GenerativeTypes.hs view
@@ -1,3 +1,14 @@+{-|+Module      : GenerativeTypes+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Types for the 'Generative' example.+-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}
examples/generative/Main.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the 'Generative' example.+-} {-# LANGUAGE ScopedTypeVariables #-}  module Main where
examples/generative/Widgets/BoxesPalette.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Widgets.BoxesPalette+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Widget representing a set of boxes with varying colors.+-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}
examples/generative/Widgets/CirclesGrid.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Widgets.CirclesGrid+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Widget representing a grid of circles.+-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}
+ examples/opengl/Main.hs view
@@ -0,0 +1,101 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the 'Custom OpenGL' example.+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Control.Lens+import Data.Text (Text)+import Monomer++import qualified Data.Map as M+import qualified Monomer.Lens as L++import OpenGLWidget++data AppModel = AppModel {+  _color1 :: Color,+  _color2 :: Color,+  _color3 :: Color,+  _color4 :: Color+} deriving (Eq, Show)++data AppEvent+  = AppInit+  deriving (Eq, Show)++makeLenses 'AppModel++buildUI+  :: WidgetEnv AppModel AppEvent+  -> AppModel+  -> WidgetNode AppModel AppEvent+buildUI wenv model = widgetTree where+  colorsMap = M.fromList [(red, "Red"), (green, "Green"), (blue, "Blue"), (orange, "Orange")]+  colors = M.keys colorsMap+  colorDropdown field = textDropdown_ field colors (colorsMap M.!) []++  widgetTree = vstack [+      hstack [+        label "Color 1:",+        spacer,+        colorDropdown color1,+        spacer,+        label "Color 2:",+        spacer,+        colorDropdown color2,+        spacer,+        label "Color 3:",+        spacer,+        colorDropdown color3,+        spacer,+        label "Color 4:",+        spacer,+        colorDropdown color4+      ],+      spacer,+      vgrid [+        hgrid [+          openGLWidget (model ^. color1)+            `styleBasic` [padding 20],+          scroll (openGLWidget (model ^. color2) `styleBasic` [width 800, height 800])+            `styleBasic` [padding 20]+        ],+        hgrid [+          openGLWidget (model ^. color3)+            `styleBasic` [padding 20],+          openGLWidget (model ^. color4)+            `styleBasic` [padding 20]+        ]+      ]+    ] `styleBasic` [padding 10]++handleEvent+  :: WidgetEnv AppModel AppEvent+  -> WidgetNode AppModel AppEvent+  -> AppModel+  -> AppEvent+  -> [AppEventResponse AppModel AppEvent]+handleEvent wenv node model evt = case evt of+  AppInit -> []++main :: IO ()+main = do+  startApp model handleEvent buildUI config+  where+    config = [+      appWindowTitle "OpenGL",+      appTheme darkTheme,+      appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",+      appInitEvent AppInit+      ]+    model = AppModel red green blue orange
+ examples/opengl/OpenGLWidget.hs view
@@ -0,0 +1,239 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Widget implementing low level rendering for the 'Custom OpenGL' example.++OpenGL code adapted from dmjio's [example](https://github.com/dmjio/LearnOpenGL.hs/blob/master/GettingStarted/ShadersEx2/Main.hs).+-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}++module OpenGLWidget (+  openGLWidget+) where++import Control.Lens ((&), (^.), (.~))+import Control.Monad+import Data.Default+import Data.Typeable (cast)+import Data.Vector.Storable (Vector)+import Foreign.C.String+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import Graphics.GL++import qualified Data.Vector.Storable as V++import Monomer+import Monomer.Widgets.Single++import qualified Monomer.Lens as L++data OpenGLWidgetMsg+  = OpenGLWidgetInit GLuint (Ptr GLuint) (Ptr GLuint)+  deriving (Show, Eq)++data OpenGLWidgetState = OpenGLWidgetState {+  _ogsLoaded :: Bool,+  _ogsShaderId :: GLuint,+  _ogsVao :: Ptr GLuint,+  _ogsVbo :: Ptr GLuint+} deriving (Show, Eq)++openGLWidget :: Color -> WidgetNode s e+openGLWidget color = defaultWidgetNode "openGLWidget" widget where+  widget = makeOpenGLWidget color state+  state = OpenGLWidgetState False 0 nullPtr nullPtr++makeOpenGLWidget :: Color -> OpenGLWidgetState -> Widget s e+makeOpenGLWidget color state = widget where+  widget = createSingle state def {+    singleInit = init,+    singleMerge = merge,+    singleDispose = dispose,+    singleHandleMessage = handleMessage,+    singleGetSizeReq = getSizeReq,+    singleRender = render+  }++  init wenv node = resultReqs node reqs where+    widgetId = node ^. L.info . L.widgetId+    path = node ^. L.info . L.path+    buffers = 2++    initOpenGL = do+      -- This needs to run in render thread+      program <- createShaderProgram+      vaoPtr <- malloc+      vboPtr <- malloc+      glGenVertexArrays buffers vaoPtr+      glGenBuffers buffers vboPtr++      return $ OpenGLWidgetInit program vaoPtr vboPtr++    reqs = [RunInRenderThread widgetId path initOpenGL]++  merge wenv node oldNode oldState = resultNode newNode where+    newNode = node+      & L.widget .~ makeOpenGLWidget color oldState++  dispose wenv node = resultReqs node reqs where+    OpenGLWidgetState _ shaderId vaoPtr vboPtr = state+    widgetId = node ^. L.info . L.widgetId+    path = node ^. L.info . L.path+    buffers = 2++    disposeOpenGL = do+      -- This needs to run in render thread+      glDeleteProgram shaderId+      glDeleteVertexArrays buffers vaoPtr+      glDeleteBuffers buffers vboPtr+      free vaoPtr+      free vboPtr++    reqs = [RunInRenderThread widgetId path disposeOpenGL]++  handleMessage wenv node target msg = case cast msg of+    Just (OpenGLWidgetInit shaderId vao vbo) -> Just result where+      newState = OpenGLWidgetState True shaderId vao vbo+      newNode = node+        & L.widget .~ makeOpenGLWidget color newState+      result = resultReqs newNode [RenderOnce]+    _ -> Nothing++  getSizeReq wenv node = (sizeReqW, sizeReqH) where+    sizeReqW = expandSize 100 1+    sizeReqH = expandSize 100 1++  render wenv node renderer =+    when (_ogsLoaded state) $+      createRawTask renderer $+        doInScissor winSize dpr offset activeVp $+          drawVertices state (toVectorVAO winSize offset color triangle)+    where+      dpr = wenv ^. L.dpr+      winSize = wenv ^. L.windowSize+      activeVp = wenv ^. L.viewport+      offset = wenv ^. L.offset++      -- Simple triangle+      style = currentStyle wenv node+      nodeVp = getContentArea node style++      Rect rx ry rw rh = nodeVp+      triangle = [(rx + rw, ry + rh), (rx, ry + rh), (rx + rw / 2, ry)]++doInScissor :: Size -> Double -> Point -> Rect -> IO () -> IO ()+doInScissor winSize dpr offset vp action = do+  glEnable GL_SCISSOR_TEST+  -- OpenGL's Y axis increases from bottom to top+  glScissor (round (rx + ox)) (round $ winH - ry - oy - rh) (round rw) (round rh)+  action+  glDisable GL_SCISSOR_TEST+  where+    winH = winSize ^. L.h * dpr+    Point ox oy = mulPoint dpr offset+    Rect rx ry rw rh = mulRect dpr vp++toVectorVAO :: Size -> Point -> Color -> [(Double, Double)] -> Vector Float+toVectorVAO (Size w h) (Point ox oy) (Color r g b a) points = vec where+  px x = realToFrac $ (x + ox - w / 2) / (w / 2)+  -- OpenGL's Y axis increases from bottom to top+  py y = realToFrac $ (h / 2 - y - oy) / (h / 2)+  col c = realToFrac (fromIntegral c / 255)+  row (x, y) = [px x, py y, 0, col r, col g, col b]+  vec = V.fromList . concat $ row <$> points++drawVertices+  :: forall a . Storable a+  => OpenGLWidgetState+  -> Vector a+  -> IO ()+drawVertices state vertices = do+  vao <- peek vaoPtr+  vbo <- peek vboPtr++  glBindVertexArray vao+  glBindBuffer GL_ARRAY_BUFFER vbo++  -- Copies raw data from vector to OpenGL memory+  V.unsafeWith vertices $ \vertsPtr ->+    glBufferData+      GL_ARRAY_BUFFER+      (fromIntegral (V.length vertices * floatSize))+      (castPtr vertsPtr)+      GL_STATIC_DRAW++  -- The vertex shader expects two arguments. Position:+  glVertexAttribPointer 0 3 GL_FLOAT GL_FALSE (fromIntegral (floatSize * 6)) nullPtr+  glEnableVertexAttribArray 0++  -- Color:+  glVertexAttribPointer 1 3 GL_FLOAT GL_FALSE (fromIntegral (floatSize * 6)) (nullPtr `plusPtr` (floatSize * 3))+  glEnableVertexAttribArray 1++  glUseProgram shaderId+  glBindVertexArray vao+  glDrawArrays GL_TRIANGLES 0 3++  where+    floatSize = sizeOf (undefined :: Float)+    OpenGLWidgetState _ shaderId vaoPtr vboPtr = state++createShaderProgram :: IO GLuint+createShaderProgram = do+  shaderProgram <- glCreateProgram+  vertexShader <- compileShader GL_VERTEX_SHADER "examples/opengl/shaders/vert.glsl"+  fragmentShader <- compileShader GL_FRAGMENT_SHADER "examples/opengl/shaders/frag.glsl"++  glAttachShader shaderProgram vertexShader+  glAttachShader shaderProgram fragmentShader++  glLinkProgram shaderProgram+  checkProgramLink shaderProgram++  glDeleteShader vertexShader+  glDeleteShader fragmentShader++  return shaderProgram++compileShader :: GLenum -> FilePath -> IO GLuint+compileShader shaderType shaderFile = do+  shader <- glCreateShader shaderType+  shaderSource <- readFile shaderFile >>= newCString++  alloca $ \shadersStr -> do+    shadersStr `poke` shaderSource+    glShaderSource shader 1 shadersStr nullPtr+    glCompileShader shader+    checkShaderCompile shader++  return shader++checkProgramLink :: GLuint -> IO ()+checkProgramLink programId = do+  alloca $ \successPtr -> do+    alloca $ \infoLogPtr -> do+      glGetProgramiv programId GL_LINK_STATUS successPtr+      success <- peek successPtr++      when (success <= 0) $ do+        glGetProgramInfoLog programId 512 nullPtr infoLogPtr+        putStrLn =<< peekCString infoLogPtr++checkShaderCompile :: GLuint -> IO ()+checkShaderCompile shaderId = do+  alloca $ \successPtr ->+    alloca $ \infoLogPtr -> do+      glGetShaderiv shaderId GL_COMPILE_STATUS successPtr+      success <- peek successPtr++      when (success <= 0) $ do+        glGetShaderInfoLog shaderId 512 nullPtr infoLogPtr+        putStrLn "Failed to compile shader "
examples/ticker/BinanceTypes.hs view
@@ -1,3 +1,13 @@+{-|+Module      : BinanceTypes+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Types for the Binance Exchange in the 'Ticker' example.+-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}
examples/ticker/Main.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the 'Ticker' example.+-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}
examples/ticker/TickerTypes.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Types for the 'Ticker' example.+-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RecordWildCards #-}
examples/todo/Main.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the 'Todo' example.+-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}
examples/todo/TodoTypes.hs view
@@ -1,3 +1,13 @@+{-|+Module      : TodoTypes+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Types for the 'Todo' example.+-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Main.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Main+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the tutorials.+-} module Main where  import qualified Tutorial01_Basics
examples/tutorial/Tutorial01_Basics.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial01_Basics+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '01 - Basics' tutorial.+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Tutorial02_Styling.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial02_Styling+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '02 - Styling' tutorial.+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Tutorial03_LifeCycle.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial03_LifeCycle+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '03 - LifeCycle' tutorial.+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Tutorial04_Tasks.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial04_Tasks+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '04 - Tasks' tutorial.+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Tutorial05_Producers.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial05_Producers+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '05 - Producers' tutorial.+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Tutorial06_Composite.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial06_Composite+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '06 - Composite' tutorial.+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Tutorial07_CustomWidget.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial07_CustomWidget+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '07 - Custom Widget' tutorial.+-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
examples/tutorial/Tutorial08_Themes.hs view
@@ -1,3 +1,13 @@+{-|+Module      : Tutorial08_Themes+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Main module for the '08 - Themes' tutorial.+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}
monomer.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           monomer-version:        1.0.0.3+version:        1.1.0.0 synopsis:       A GUI library for writing native Haskell applications. description:    Monomer is an easy to use, cross platform, GUI library for writing native                 Haskell applications.@@ -274,6 +274,49 @@     , wreq >=0.5.2 && <0.6   default-language: Haskell2010 +executable opengl+  main-is: Main.hs+  other-modules:+      OpenGLWidget+      Paths_monomer+  hs-source-dirs:+      examples/opengl+  default-extensions:+      OverloadedStrings+  ghc-options: -threaded+  build-depends:+      JuicyPixels >=3.2.9 && <3.5+    , OpenGL ==3.0.*+    , OpenGLRaw ==3.3.*+    , async >=2.1 && <2.3+    , attoparsec >=0.12 && <0.15+    , base >=4.11 && <5+    , bytestring >=0.10 && <0.12+    , bytestring-to-vector ==0.3.*+    , containers >=0.5.11 && <0.7+    , data-default >=0.5 && <0.8+    , exceptions ==0.10.*+    , extra >=1.6 && <1.9+    , formatting >=6.0 && <8.0+    , http-client >=0.6 && <0.9+    , lens >=4.16 && <5.1+    , monomer+    , mtl >=2.1 && <2.3+    , nanovg >=0.8 && <1.0+    , process ==1.6.*+    , random >=1.1 && <1.3+    , safe ==0.3.*+    , sdl2 >=2.4.0 && <2.6+    , stm ==2.5.*+    , text ==1.2.*+    , text-show >=3.7 && <3.10+    , time >=1.8 && <1.13+    , transformers >=0.5 && <0.7+    , unordered-containers >=0.2.8 && <0.3+    , vector >=0.12 && <0.14+    , wreq >=0.5.2 && <0.6+  default-language: Haskell2010+ executable ticker   main-is: Main.hs   other-modules:@@ -415,6 +458,7 @@   main-is: Spec.hs   other-modules:       Monomer.Common.CursorIconSpec+      Monomer.Core.SizeReqSpec       Monomer.Graphics.UtilSpec       Monomer.TestEventUtil       Monomer.TestUtil
src/Monomer/Common/BasicTypes.hs view
@@ -131,6 +131,10 @@ moveRect :: Point -> Rect -> Rect moveRect (Point x y) (Rect rx ry rw rh) = Rect (rx + x) (ry + y) rw rh +-- | Scales a rect by the provided factor.+mulRect :: Double -> Rect -> Rect+mulRect f (Rect rx ry rw rh) = Rect (f * rx) (f * ry) (f * rw) (f * rh)+ -- | Returns the middle point of a rect. rectCenter :: Rect -> Point rectCenter (Rect rx ry rw rh) = Point (rx + rw / 2) (ry + rh / 2)
src/Monomer/Core/Combinators.hs view
@@ -23,7 +23,6 @@ import Control.Lens (ALens') import Data.Text (Text) -import Monomer.Common import Monomer.Core.StyleTypes import Monomer.Core.WidgetTypes import Monomer.Event.Types
src/Monomer/Core/SizeReq.hs view
@@ -13,6 +13,12 @@ module Monomer.Core.SizeReq (   SizeReqUpdater(..),   clearExtra,+  fixedToMinW,+  fixedToMinH,+  fixedToMaxW,+  fixedToMaxH,+  fixedToExpandW,+  fixedToExpandH,   sizeReqBounded,   sizeReqValid,   sizeReqAddStyle,@@ -43,9 +49,51 @@ -- | 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/Core/ThemeTypes.hs view
@@ -74,6 +74,8 @@   _thsExternalLinkStyle :: StyleState,   _thsLabelStyle :: StyleState,   _thsNumericFieldStyle :: StyleState,+  _thsOptionBtnOnStyle :: StyleState,+  _thsOptionBtnOffStyle :: StyleState,   _thsRadioStyle :: StyleState,   _thsRadioWidth :: Double,   _thsScrollOverlay :: Bool,@@ -97,6 +99,8 @@   _thsTextAreaStyle :: StyleState,   _thsTextFieldStyle :: StyleState,   _thsTimeFieldStyle :: StyleState,+  _thsToggleBtnOnStyle :: StyleState,+  _thsToggleBtnOffStyle :: StyleState,   _thsTooltipStyle :: StyleState,   _thsUserStyleMap :: M.Map String StyleState,   _thsUserColorMap :: M.Map String Color@@ -126,6 +130,8 @@     _thsExternalLinkStyle = def,     _thsLabelStyle = def,     _thsNumericFieldStyle = def,+    _thsOptionBtnOnStyle = def,+    _thsOptionBtnOffStyle = def,     _thsRadioStyle = def,     _thsRadioWidth = 20,     _thsScrollOverlay = False,@@ -149,6 +155,8 @@     _thsTextAreaStyle = def,     _thsTextFieldStyle = def,     _thsTimeFieldStyle = def,+    _thsToggleBtnOnStyle = def,+    _thsToggleBtnOffStyle = def,     _thsTooltipStyle = def,     _thsUserStyleMap = M.empty,     _thsUserColorMap = M.empty@@ -178,6 +186,8 @@     _thsExternalLinkStyle = _thsExternalLinkStyle t1 <> _thsExternalLinkStyle t2,     _thsLabelStyle = _thsLabelStyle t1 <> _thsLabelStyle t2,     _thsNumericFieldStyle = _thsNumericFieldStyle t1 <> _thsNumericFieldStyle t2,+    _thsOptionBtnOnStyle = _thsOptionBtnOnStyle t1 <> _thsOptionBtnOnStyle t2,+    _thsOptionBtnOffStyle = _thsOptionBtnOffStyle t1 <> _thsOptionBtnOffStyle t2,     _thsRadioStyle = _thsRadioStyle t1 <> _thsRadioStyle t2,     _thsRadioWidth = _thsRadioWidth t2,     _thsScrollOverlay = _thsScrollOverlay t2,@@ -201,6 +211,8 @@     _thsTextAreaStyle = _thsTextAreaStyle t1 <> _thsTextAreaStyle t2,     _thsTextFieldStyle = _thsTextFieldStyle t1 <> _thsTextFieldStyle t2,     _thsTimeFieldStyle = _thsTimeFieldStyle t1 <> _thsTimeFieldStyle t2,+    _thsToggleBtnOnStyle = _thsToggleBtnOnStyle t1 <> _thsToggleBtnOnStyle t2,+    _thsToggleBtnOffStyle = _thsToggleBtnOffStyle t1 <> _thsToggleBtnOffStyle t2,     _thsTooltipStyle = _thsTooltipStyle t1 <> _thsTooltipStyle t2,     _thsUserStyleMap = _thsUserStyleMap t1 <> _thsUserStyleMap t2,     _thsUserColorMap = _thsUserColorMap t1 <> _thsUserColorMap t2
src/Monomer/Core/WidgetTypes.hs view
@@ -18,7 +18,6 @@  import Control.Concurrent (MVar) import Control.Lens (ALens')-import Data.ByteString.Lazy (ByteString) import Data.Default import Data.Map.Strict (Map) import Data.Sequence (Seq)@@ -226,6 +225,11 @@   --   for WebSockets and similar data sources. It receives a function that   --   can be used to send messages back to the producer owner.   | forall i . Typeable i => RunProducer WidgetId Path ((i -> IO ()) -> IO ())+  -- | Runs an asynchronous tasks in the render thread. It is mandatory to+  --   return a message that will be sent to the task owner (this is the only+  --   way to feed data back). This should only be used when implementing low+  --   level rendering widgets that need to create API specific resources.+  | forall i . Typeable i => RunInRenderThread WidgetId Path (IO i)  instance Eq e => Eq (WidgetRequest s e) where   IgnoreParentEvents == IgnoreParentEvents = True@@ -287,6 +291,8 @@ data WidgetEnv s e = WidgetEnv {   -- | The OS of the host.   _weOs :: Text,+  -- | Device pixel rate.+  _weDpr :: Double,   -- | Provides helper funtions for calculating text size.   _weFontManager :: FontManager,   -- | Returns the information of a node given a path from root, if any.@@ -704,6 +710,7 @@   show SendMessage{} = "SendMessage"   show RunTask{} = "RunTask"   show RunProducer{} = "RunProducer"+  show RunInRenderThread{} = "RunInRenderThread"  instance Show (WidgetResult s e) where   show result = "WidgetResult "
src/Monomer/Graphics/Types.hs view
@@ -40,7 +40,7 @@   _colorG :: {-# UNPACK #-} !Int,   _colorB :: {-# UNPACK #-} !Int,   _colorA :: {-# UNPACK #-} !Double-} deriving (Eq, Show, Generic)+} deriving (Eq, Show, Ord, Generic)  instance Default Color where   def = Color 255 255 255 1.0
src/Monomer/Helper.hs view
@@ -11,6 +11,7 @@ -} module Monomer.Helper where +import Control.Exception (SomeException, catch) import Control.Monad.IO.Class (MonadIO) import Data.Sequence (Seq(..)) @@ -48,6 +49,10 @@   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@@ -59,3 +64,7 @@ -- | Restricts a value to a given range. clamp :: (Ord a) => a -> a -> a -> a clamp mn mx = max mn . min mx++-- | Catches any exception thrown by the provided action+catchAny :: IO a -> (SomeException -> IO a) -> IO a+catchAny = catch
src/Monomer/Main/Core.hs view
@@ -47,6 +47,7 @@ import Monomer.Main.Util import Monomer.Main.WidgetTask import Monomer.Graphics+import Monomer.Helper (catchAny) import Monomer.Widgets.Composite  import qualified Monomer.Lens as L@@ -152,6 +153,7 @@    let wenv = WidgetEnv {     _weOs = os,+    _weDpr = dpr,     _weFontManager = fontManager,     _weFindByPath = const Nothing,     _weMainButton = mainBtn,@@ -258,6 +260,7 @@   let contextBtn = fromMaybe BtnRight (_apcContextButton config)   let wenv = WidgetEnv {     _weOs = _mlOS,+    _weDpr = dpr,     _weFontManager = fontManager,     _weFindByPath = findWidgetByPath wenv _mlWidgetRoot,     _weMainButton = mainBtn,@@ -409,6 +412,11 @@   return state handleRenderMsg window renderer fontMgr state (MsgRemoveImage name) = do   deleteImage renderer name+  return state+handleRenderMsg window renderer fontMgr state (MsgRunInRender chan task) = do+  flip catchAny print $ do+    value <- task+    atomically $ writeTChan chan value   return state  renderWidgets
src/Monomer/Main/Handlers.hs view
@@ -29,7 +29,7 @@ import Control.Lens   ((&), (^.), (^?), (.~), (?~), (%~), (.=), (?=), (%=), (%%~), _Just, _1, _2, ix, at, use) import Control.Monad.STM (atomically)-import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan)+import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan) import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.IO.Class@@ -251,6 +251,7 @@     SendMessage wid msg -> handleSendMessage wid msg step     RunTask wid path handler -> handleRunTask wid path handler step     RunProducer wid path handler -> handleRunProducer wid path handler step+    RunInRenderThread wid path handler -> handleRunInRenderThread wid path handler step  -- | Resizes the current root, and marks the render and resized flags. handleResizeWidgets@@ -653,6 +654,23 @@    return previousStep +handleRunInRenderThread+  :: forall s e m i . (MonomerM s e m, Typeable i)+  => WidgetId+  -> Path+  -> IO i+  -> HandlerStep s e+  -> m (HandlerStep s e)+handleRunInRenderThread widgetId path handler previousStep = do+  renderChannel <- use L.renderChannel++  handleRunTask widgetId path (taskWrapper renderChannel) previousStep+  where+    taskWrapper renderChannel = do+      msgChan <- newTChanIO+      atomically $ writeTChan renderChannel (MsgRunInRender msgChan handler)+      atomically $ readTChan msgChan+ sendMessage :: TChan e -> e -> IO () sendMessage channel message = atomically $ writeTChan channel message @@ -690,9 +708,7 @@   Move point -> do     (target, hoverEvts) <- addHoverEvents wenv widgetRoot point     -- Update input status-    status <- use L.inputStatus-    L.inputStatus . L.mousePosPrev .= status ^. L.mousePos-    L.inputStatus . L.mousePos .= point+    updateInputStatusMousePos point     -- Drag event     mainPress <- use L.mainBtnPress     draggedMsg <- getDraggedMsgInfo@@ -716,6 +732,7 @@     when (btn == mainBtn) $       L.mainBtnPress .= fmap (, point) curr +    updateInputStatusMousePos point     L.inputStatus . L.buttons . at btn ?= BtnPressed      SDLE.captureMouse True@@ -739,6 +756,7 @@           Just (path, msg) -> [(Drop point path msg, target) | not isPressed]           _ -> [] +    updateInputStatusMousePos point     L.inputStatus . L.buttons . at btn ?= BtnReleased      SDLE.captureMouse False@@ -753,6 +771,13 @@   -- This will only be reached from `handleSystemEvents`   Click point btn clicks -> findEvtTargetByPoint wenv widgetRoot evt point   _ -> return [(evt, Nothing)]++updateInputStatusMousePos :: MonomerM s e m => Point -> m ()+updateInputStatusMousePos point = do+  -- Update input status+  status <- use L.inputStatus+  L.inputStatus . L.mousePosPrev .= status ^. L.mousePos+  L.inputStatus . L.mousePos .= point  addHoverEvents   :: MonomerM s e m
src/Monomer/Main/Types.hs view
@@ -50,7 +50,7 @@   = MsgRender (WidgetEnv s e) (WidgetNode s e)   | MsgResize Size   | MsgRemoveImage Text-  deriving Show+  | forall i . MsgRunInRender (TChan i) (IO i)  {-| Requirements for periodic rendering by a widget. Start time is stored to
src/Monomer/Widgets/Composite.hs view
@@ -70,7 +70,6 @@ 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 @@ -867,6 +866,7 @@ toParentReq _ (SendMessage wid message) = Just (SendMessage wid message) toParentReq _ (RunTask wid path action) = Just (RunTask wid path action) toParentReq _ (RunProducer wid path action) = Just (RunProducer wid path action)+toParentReq _ (RunInRenderThread wid path action) = Just (RunInRenderThread wid path action)  collectWidgetKeys   :: Map WidgetKey (WidgetNode s e)@@ -883,6 +883,7 @@ convertWidgetEnv :: WidgetEnv sp ep -> WidgetKeyMap s e -> s -> WidgetEnv s e convertWidgetEnv wenv widgetKeyMap model = WidgetEnv {   _weOs = _weOs wenv,+  _weDpr = _weDpr wenv,   _weFontManager = _weFontManager wenv,   _weFindByPath = _weFindByPath wenv,   _weMainButton = _weMainButton wenv,
src/Monomer/Widgets/Container.hs view
@@ -329,6 +329,9 @@   -- | Scissor to apply to child widgets. This is not the same as the widget   --   enabled by containerUseScissor   containerChildrenScissor :: Maybe Rect,+  -- | If True, the container will render its background and border. In some+  --   cases passing rendering control to children is useful. Defaults to True.+  containerDrawDecorations :: Bool,   -- | The layout direction generated by this widget. If one is indicated, it   --   can be used by widgets such as "Monomer.Widgets.Singles.Spacer"   containerLayoutDirection :: LayoutDirection,@@ -391,6 +394,7 @@     containerAddStyleReq = True,     containerChildrenOffset = Nothing,     containerChildrenScissor = Nothing,+    containerDrawDecorations = True,     containerLayoutDirection = LayoutNone,     containerIgnoreEmptyArea = False,     containerUseCustomCursor = False,@@ -471,11 +475,17 @@   cOffset = containerChildrenOffset container   updateCWenv = containerUpdateCWenv container   layoutDirection = containerLayoutDirection container++  pViewport = node ^. L.info . L.viewport+  cViewport = cnode ^. L.info . L.viewport+  newViewport = fromMaybe def (intersectRects pViewport cViewport)+   offsetWenv !wenv-    | isJust cOffset = updateWenvOffset container wenv node+    | isJust cOffset = updateWenvOffset container wenv node newViewport     | otherwise = wenv   !directionWenv = wenv     & L.layoutDirection .~ layoutDirection+   !newWenv = updateCWenv (offsetWenv directionWenv) node cnode cidx  {-|@@ -487,15 +497,16 @@   :: Container s e a  -- ^ The container config   -> WidgetEnv s e    -- ^ The widget environment.   -> WidgetNode s e   -- ^ The widget node.+  -> Rect             -- ^ The target viewport.   -> WidgetEnv s e    -- ^ THe updated widget environment.-updateWenvOffset container wenv node = newWenv where+updateWenvOffset container wenv node viewport = newWenv where   cOffset = containerChildrenOffset container   offset = fromMaybe def cOffset-  accumOffset = addPoint offset (wenv ^. L.offset)-  viewport = node ^. L.info . L.viewport+   updateMain (path, point)     | isNodeParentOfPath node path = (path, addPoint (negPoint offset) point)     | otherwise = (path, point)+   newWenv = wenv     & L.viewport .~ moveRect (negPoint offset) viewport     & L.inputStatus . L.mousePos %~ addPoint (negPoint offset)@@ -1089,7 +1100,7 @@   -> IO () renderWrapper container wenv !node !renderer =   drawInScissor renderer useScissor viewport $-    drawStyledAction renderer viewport style $ \_ -> do+    drawStyledAction_ renderer drawDecorations viewport style $ \_ -> do       renderBefore wenv node renderer        drawInScissor renderer useChildrenScissor childrenScissorRect $ do@@ -1109,6 +1120,7 @@   where     style = containerGetCurrentStyle container wenv node     updateCWenv = getUpdateCWenv container+    drawDecorations = containerDrawDecorations container     useScissor = containerUseScissor container     childrenScissor = containerChildrenScissor container     offset = containerChildrenOffset container
src/Monomer/Widgets/Containers/Box.hs view
@@ -42,6 +42,7 @@  import qualified Data.Sequence as Seq +import Monomer.Helper (applyFnList) import Monomer.Widgets.Container import Monomer.Widgets.Containers.Stack @@ -78,7 +79,7 @@ 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 @@   def = BoxCfg {     _boxExpandContent = Nothing,     _boxIgnoreEmptyArea = Nothing,-    _boxSizeReqUpdater = Nothing,+    _boxSizeReqUpdater = [],     _boxMergeRequired = Nothing,     _boxAlignH = Nothing,     _boxAlignV = Nothing,@@ -114,7 +115,7 @@   (<>) 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 CmbSizeReqUpdater (BoxCfg s e) where   sizeReqUpdater updater = def {-    _boxSizeReqUpdater = Just updater+    _boxSizeReqUpdater = [updater]   }  instance CmbMergeRequired (BoxCfg s e) s where@@ -384,11 +385,11 @@    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/Dropdown.hs view
@@ -496,7 +496,7 @@       scOffset = wenv ^. L.offset       offset = _ddsOffset state       totalOffset = addPoint scOffset offset-      cwenv = updateWenvOffset container wenv node+      cwenv = updateWenvOffset container wenv node listOverlayVp         & L.viewport .~ listOverlayVp    renderArrow renderer style contentArea =
src/Monomer/Widgets/Containers/Grid.hs view
@@ -32,6 +32,7 @@  import qualified Data.Sequence as Seq +import Monomer.Helper (applyFnList) import Monomer.Widgets.Container  import qualified Monomer.Lens as L@@ -42,17 +43,17 @@ - '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 CmbSizeReqUpdater GridCfg where   sizeReqUpdater updater = def {-    _grcSizeReqUpdater = Just updater+    _grcSizeReqUpdater = [updater]   }  -- | Creates a grid of items with the same width.@@ -96,11 +97,11 @@   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/Scroll.hs view
@@ -350,6 +350,7 @@     containerLayoutDirection = layoutDirection,     containerGetBaseStyle = getBaseStyle,     containerGetCurrentStyle = scrollCurrentStyle,+    containerUpdateCWenv = updateCWenv,     containerInit = init,     containerMerge = merge,     containerFindByPoint = findByPoint,@@ -385,6 +386,28 @@         & L.children . ix 0 . L.info . L.style .~ childStyle       | otherwise = node +  -- This is overriden to account for space used by scroll bars+  updateCWenv wenv node cnode cidx = newWenv where+    theme = currentTheme wenv node+    barW = fromMaybe (theme ^. L.scrollBarWidth) (_scBarWidth config)+    overlay = fromMaybe (theme ^. L.scrollOverlay) (_scScrollOverlay config)++    ScrollContext{..} = scrollStatus config wenv node state (Point 0 0)+    style = currentStyle wenv node+    carea = getContentArea node style++    -- barH consumes vertical space, barV consumes horizontal space+    barH+      | hScrollRequired && not overlay = barW+      | otherwise = 0+    barV+      | vScrollRequired && not overlay = barW+      | otherwise = 0+    clientArea = subtractFromRect carea 0 barV 0 barH++    newWenv = wenv+      & L.viewport .~ moveRect (negPoint offset) (fromMaybe carea clientArea)+   init wenv node = resultNode newNode where     newNode = checkFwdStyle wenv node @@ -393,14 +416,15 @@       & L.widget .~ makeScroll config oldState    findByPoint wenv node start point = result where-    sctx = scrollStatus config wenv node state point+    -- The point argument already has offset applied+    scrollPoint = subPoint point offset+    sctx = scrollStatus config wenv node state scrollPoint     mouseInScroll       =  (hMouseInScroll sctx && hScrollRequired sctx)       || (vMouseInScroll sctx && vScrollRequired sctx)-    childPoint = addPoint point offset      child = Seq.index (node ^. L.children) 0-    childHovered = isPointInNodeVp child childPoint+    childHovered = isPointInNodeVp child point     childDragged = isNodePressed wenv child     result       | (not mouseInScroll && childHovered) || childDragged = Just 0@@ -425,33 +449,34 @@         | otherwise = Nothing      ButtonAction point btn status _ -> result where-      leftPressed = status == BtnPressed && btn == wenv ^. L.mainButton-      btnReleased = status == BtnReleased && btn == wenv ^. L.mainButton+      mainPressed = status == BtnPressed && btn == wenv ^. L.mainButton+      mainReleased = status == BtnReleased && btn == wenv ^. L.mainButton        isDragging = isJust $ _sstDragging state-      startDrag = leftPressed && not isDragging -      jumpScrollH = btnReleased && not isDragging && hMouseInScroll sctx-      jumpScrollV = btnReleased && not isDragging && vMouseInScroll sctx+      startDragH = mainPressed && not isDragging && hMouseInThumb sctx+      startDragV = mainPressed && not isDragging && vMouseInThumb sctx -      mouseInScroll = hMouseInScroll sctx || vMouseInScroll sctx+      jumpScrollH = mainPressed && not isDragging && hMouseInScroll sctx+      jumpScrollV = mainPressed && not isDragging && vMouseInScroll sctx+       mouseInThumb = hMouseInThumb sctx || vMouseInThumb sctx+      mouseInScroll = hMouseInScroll sctx || vMouseInScroll sctx        newState-        | startDrag && hMouseInThumb sctx = state { _sstDragging = Just HBar }-        | startDrag && vMouseInThumb sctx = state { _sstDragging = Just VBar }+        | startDragH = state { _sstDragging = Just HBar }+        | startDragV = state { _sstDragging = Just VBar }         | jumpScrollH = updateScrollThumb state HBar point contentArea sctx         | jumpScrollV = updateScrollThumb state VBar point contentArea sctx-        | btnReleased = state { _sstDragging = Nothing }+        | mainReleased = state { _sstDragging = Nothing }         | otherwise = state        newRes = rebuildWidget wenv node newState       handledResult = Just $ newRes         & L.requests <>~ Seq.fromList scrollReqs       result-        | leftPressed && mouseInThumb = handledResult-        | btnReleased && mouseInScroll = handledResult-        | btnReleased && isDragging = handledResult+        | mainPressed && (mouseInThumb || mouseInScroll) = handledResult+        | mainReleased && isDragging = handledResult         | otherwise = Nothing      Move point | isJust dragging -> result where
src/Monomer/Widgets/Containers/Stack.hs view
@@ -35,6 +35,7 @@  import qualified Data.Sequence as Seq +import Monomer.Helper (applyFnList) import Monomer.Widgets.Container  import qualified Monomer.Lens as L@@ -49,19 +50,19 @@ -} 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 CmbSizeReqUpdater StackCfg where   sizeReqUpdater updater = def {-    _stcSizeReqUpdater = Just updater+    _stcSizeReqUpdater = [updater]   }  -- | Creates a horizontal stack.@@ -121,11 +122,11 @@   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/Single.hs view
@@ -236,11 +236,14 @@   -- | True if border and padding should be added to size requirement. Defaults   --   to True.   singleAddStyleReq :: Bool,+  -- | If True, the widget will render its background and border. Defaults to+  --   True.+  singleDrawDecorations :: Bool,   -- | True if focus should be requested when mouse button is pressed (before   --   click). Defaults to True.   singleFocusOnBtnPressed :: Bool,-  -- | True if style cursor should be ignored. If it's False, cursor changes need-  --   to be handled in custom code. Defaults to False.+  -- | True if style cursor should be ignored. If it's False, cursor changes+  --   need to be handled in custom code. Defaults to False.   singleUseCustomCursor :: Bool,   -- | If true, it will ignore extra space assigned by the parent container, but   --   it will not use more space than assigned. Defaults to False.@@ -277,6 +280,7 @@   def = Single {     singleAddStyleReq = True,     singleFocusOnBtnPressed = True,+    singleDrawDecorations = True,     singleUseCustomCursor = False,     singleUseCustomSize = False,     singleUseScissor = False,@@ -597,10 +601,11 @@   -> IO () renderWrapper single wenv node renderer =   drawInScissor renderer useScissor viewport $-    drawStyledAction renderer viewport style $ \_ ->+    drawStyledAction_ renderer drawDecorations viewport style $ \_ ->       handler wenv node renderer   where     handler = singleRender single+    drawDecorations = singleDrawDecorations single     useScissor = singleUseScissor single     style = singleGetCurrentStyle single wenv node     viewport = node ^. L.info . L.viewport
src/Monomer/Widgets/Singles/Button.hs view
@@ -50,15 +50,15 @@ - 'ellipsis': if ellipsis should be used for overflown text. - 'multiline': if text may be split in multiple lines. - 'maxLines': maximum number of text lines to show.+- 'resizeFactor': flexibility to have more or less spaced assigned.+- 'resizeFactorW': flexibility to have more or less horizontal spaced assigned.+- 'resizeFactorH': flexibility to have more or less vertical spaced assigned. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. - 'onBlurReq': 'WidgetRequest' to generate when focus is lost. - 'onClick': event to raise when button is clicked. - 'onClickReq': 'WidgetRequest' to generate when button is clicked.-- 'resizeFactor': flexibility to have more or less spaced assigned.-- 'resizeFactorW': flexibility to have more or less horizontal spaced assigned.-- 'resizeFactorH': flexibility to have more or less vertical spaced assigned. -} data ButtonCfg s e = ButtonCfg {   _btnButtonType :: Maybe ButtonType,@@ -190,13 +190,12 @@ makeButton !caption !config = widget where   widget = createContainer () def {     containerAddStyleReq = False,+    containerDrawDecorations = False,     containerUseScissor = True,     containerGetBaseStyle = getBaseStyle,-    containerGetCurrentStyle = getCurrentStyle,     containerInit = init,     containerMerge = merge,     containerHandleEvent = handleEvent,-    containerGetSizeReq = getSizeReq,     containerResize = resize   } @@ -210,14 +209,6 @@     where       ignoreTheme = _btnIgnoreTheme config == Just True -  getCurrentStyle wenv node = styleState where-    style = node ^. L.info . L.style-    isEnabled = node ^. L.info . L.enabled-    isActive = isNodeTreeActive wenv node-    styleState-      | isEnabled && isActive = fromMaybe def (_styleActive style)-      | otherwise = currentStyle wenv node-   createChildNode wenv node = newNode where     nodeStyle = node ^. L.info . L.style     labelCfg = _btnLabelCfg config@@ -256,13 +247,6 @@       reqs = _btnOnClickReq config       result = resultReqs node reqs       resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)]--  getSizeReq :: ContainerGetSizeReqHandler s e-  getSizeReq wenv node children = (newReqW, newReqH) where-    -- Main section reqs-    child = Seq.index children 0-    newReqW = child ^. L.info . L.sizeReqW-    newReqH = child ^. L.info . L.sizeReqH    resize wenv node viewport children = resized where     assignedAreas = Seq.fromList [viewport]
src/Monomer/Widgets/Singles/ExternalLink.hs view
@@ -24,7 +24,6 @@ ) where  import Control.Applicative ((<|>))-import Control.Exception (SomeException, catch) import Control.Lens ((&), (^.), (.~)) import Data.Default import Data.Maybe@@ -34,6 +33,7 @@ import qualified Data.Sequence as Seq import qualified Data.Text as T +import Monomer.Helper (catchAny) import Monomer.Widgets.Container import Monomer.Widgets.Singles.Label @@ -46,15 +46,15 @@ - 'ellipsis': if ellipsis should be used for overflown text. - 'multiline': if text may be split in multiple lines. - 'maxLines': maximum number of text lines to show.+- 'resizeFactor': flexibility to have more or less spaced assigned.+- 'resizeFactorW': flexibility to have more or less horizontal spaced assigned.+- 'resizeFactorH': flexibility to have more or less vertical spaced assigned. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. - 'onBlurReq': 'WidgetRequest' to generate when focus is lost. - 'onClick': event to raise when button is clicked. - 'onClickReq': 'WidgetRequest' to generate when button is clicked.-- 'resizeFactor': flexibility to have more or less spaced assigned.-- 'resizeFactorW': flexibility to have more or less horizontal spaced assigned.-- 'resizeFactorH': flexibility to have more or less vertical spaced assigned. -} data ExternalLinkCfg s e = ExternalLinkCfg {   _elcLabelCfg :: LabelCfg s e,@@ -150,12 +150,12 @@ makeExternalLink !caption !url !config = widget where   widget = createContainer () def {     containerAddStyleReq = False,+    containerDrawDecorations = False,     containerUseScissor = True,     containerGetBaseStyle = getBaseStyle,     containerInit = init,     containerMerge = merge,     containerHandleEvent = handleEvent,-    containerGetSizeReq = getSizeReq,     containerResize = resize   } @@ -209,13 +209,6 @@       result = resultReqs node requests       resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)] -  getSizeReq :: ContainerGetSizeReqHandler s e-  getSizeReq wenv node children = (newReqW, newReqH) where-    -- Main section reqs-    child = Seq.index children 0-    newReqW = child ^. L.info . L.sizeReqW-    newReqH = child ^. L.info . L.sizeReqH-   resize wenv node viewport children = resized where     assignedAreas = Seq.fromList [viewport]     resized = (resultNode node, assignedAreas)@@ -232,6 +225,3 @@  catchIgnore :: IO () -> IO () catchIgnore task = catchAny task (const $ return ())--catchAny :: IO a -> (SomeException -> IO a) -> IO a-catchAny = catch
src/Monomer/Widgets/Singles/Image.hs view
@@ -51,13 +51,14 @@ import GHC.Generics import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) import Network.Wreq+import Network.Wreq.Session (Session)  import qualified Codec.Picture as Pic import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Map as Map import qualified Data.Text as T-import qualified Network.Wreq as Wreq+import qualified Network.Wreq.Session as Sess  import Monomer.Widgets.Single @@ -438,7 +439,7 @@   -- Get the image's MVar. One MVar per image name/path is created, to allow   -- loading images in parallel. The main MVar is only taken until the image's   -- MVar is retrieved/created.-  sharedMap <- takeMVar sharedMapMVar+  (sharedMap, sess) <- takeMVar sharedMapMVar >>= getImagesSession   sharedImgMVar <- case useShared (Map.lookup key sharedMap) of     Just mvar -> return mvar     Nothing -> newMVar emptyImgState@@ -450,7 +451,7 @@     Just (oldState, oldCount) -> do       return (ImageLoaded oldState, Just (oldState, oldCount + 1))     Nothing -> do-      res <- loadImage path+      res <- loadImage sess path        case res >>= decodeImage of         Left loadError -> return (ImageFailed loadError, Nothing)@@ -486,10 +487,10 @@ imgKey :: Text -> Text imgKey path = "image-widget-key-" <> path -loadImage :: Text -> IO (Either ImageLoadError ByteString)-loadImage path+loadImage :: Session -> Text -> IO (Either ImageLoadError ByteString)+loadImage sess path   | not (isUrl path) = loadLocal path-  | otherwise = loadRemote path+  | otherwise = loadRemote sess path  decodeImage :: ByteString -> Either ImageLoadError DynamicImage decodeImage bs = either (Left . ImageInvalid) Right (Pic.decodeImage bs)@@ -503,8 +504,8 @@     then return . Left . ImageLoadFailed $ "Failed to load: " ++ path     else return . Right $ content -loadRemote :: Text -> IO (Either ImageLoadError ByteString)-loadRemote name = do+loadRemote :: Session -> Text -> IO (Either ImageLoadError ByteString)+loadRemote sess name = do   let path = T.unpack name   eresp <- try $ getUrl path @@ -513,7 +514,7 @@     Right r -> Right $ respBody r   where     respBody r = BSL.toStrict $ r ^. responseBody-    getUrl = getWith (defaults & checkResponse ?~ (\_ _ -> return ()))+    getUrl = Sess.getWith (defaults & checkResponse ?~ (\_ _ -> return ())) sess  remoteException   :: String -> HttpException -> Either ImageLoadError ByteString@@ -544,6 +545,17 @@     isImageSource = ImagePath name,     isImageData = Just (bs, size)   }++getImagesSession+  :: Map Text WidgetShared+  -> IO (Map Text WidgetShared, Sess.Session)+getImagesSession sharedMap = case useShared (Map.lookup key sharedMap) of+  Just sess -> return (sharedMap, sess)+  Nothing -> do+    sess <- Sess.newAPISession+    return (sharedMap & at key ?~ WidgetShared sess, sess)+  where+    key = "image-widget-wreq-session"  isUrl :: Text -> Bool isUrl url = T.isPrefixOf "http://" lurl || T.isPrefixOf "https://" lurl where
src/Monomer/Widgets/Singles/Label.hs view
@@ -133,8 +133,8 @@ labelCurrentStyle   :: (WidgetEnv s e -> WidgetNode s e -> StyleState)   -> LabelCfg s e-labelCurrentStyle style = def {-  _lscCurrentStyle = Just style+labelCurrentStyle styleFn = def {+  _lscCurrentStyle = Just styleFn }  data LabelState = LabelState {
src/Monomer/Widgets/Util/Drawing.hs view
@@ -28,6 +28,7 @@   drawArrowDown,   drawTimesX,   drawStyledAction,+  drawStyledAction_,   drawRoundedRect,   drawRectRoundedBorder ) where@@ -35,7 +36,6 @@ 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)@@ -341,12 +341,27 @@   -> StyleState       -- ^ The style defining background and border.   -> (Rect -> IO ())  -- ^ The drawing actions. They receive the content area.   -> IO ()            -- ^ The resulting action.-drawStyledAction renderer rect style action = do-  drawRect renderer rect _sstBgColor _sstRadius+drawStyledAction renderer rect style action =+  drawStyledAction_ renderer True rect style action +{-|+Runs a set of rendering operations after conditionally drawing the style's+background, and before drawing the style's border.+-}+drawStyledAction_+  :: Renderer         -- ^ The renderer.+  -> Bool             -- ^ Whether background and border should be drawn.+  -> Rect             -- ^ The rect where background and border will be drawn.+  -> StyleState       -- ^ The style defining background and border.+  -> (Rect -> IO ())  -- ^ The drawing actions. They receive the content area.+  -> IO ()            -- ^ The resulting action.+drawStyledAction_ renderer drawDecorations rect style action = do+  when drawDecorations $+    drawRect renderer rect _sstBgColor _sstRadius+   forM_ contentRect action -  when (isJust _sstBorder) $+  when (drawDecorations && isJust _sstBorder) $     drawRectBorder renderer rect (fromJust _sstBorder) _sstRadius   where     StyleState{..} = style
src/Monomer/Widgets/Util/Widget.hs view
@@ -40,7 +40,6 @@  import Control.Concurrent (threadDelay) import Control.Lens ((&), (^#), (#~), (^.), (^?), (.~), (%~), _Just)-import Data.ByteString.Lazy (ByteString) import Data.Default import Data.Maybe import Data.Map.Strict (Map)
+ test/unit/Monomer/Core/SizeReqSpec.hs view
@@ -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 view
@@ -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/TestUtil.hs view
@@ -159,6 +159,7 @@ mockWenv :: s -> WidgetEnv s e mockWenv model = WidgetEnv {   _weOs = "Mac OS X",+  _weDpr = 2,   _weFontManager = mockFontManager,   _weFindByPath = const Nothing,   _weMainButton = BtnLeft,
test/unit/Monomer/Widgets/Containers/BoxSpec.hs view
@@ -170,8 +170,7 @@    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 view
@@ -133,8 +133,7 @@    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/ScrollSpec.hs view
@@ -19,6 +19,7 @@  import Monomer.Core import Monomer.Core.Combinators+import Monomer.Core.Themes.SampleThemes import Monomer.Event import Monomer.Graphics.ColorTable import Monomer.TestEventUtil@@ -47,9 +48,48 @@  handleEvent :: Spec handleEvent = describe "handleEvent" $ do+  handleBarClick   handleChildrenFocus   handleNestedWheel   handleMessageReset++handleBarClick :: Spec+handleBarClick = describe "handleBarClick" $ do+  it "should click the first button" $ do+    evts [evtClick point] `shouldBe` Seq.fromList [Button1]++  it "should scroll right and click the third button" $ do+    evts [evtPress midHBar, evtClick point] `shouldBe` Seq.fromList [Button2]++  it "should scroll down and click the third button" $ do+    evts [evtPress midVBar, evtClick point] `shouldBe` Seq.fromList [Button3]++  it "should scroll down and click the third button" $ do+    evts [evtPress midVBar, evtClick point] `shouldBe` Seq.fromList [Button3]++  it "should scroll down and right and click the fourth button" $ do+    evts [evtPress midHBar, evtPress midVBar, evtClick point] `shouldBe` Seq.fromList [Button4]++  where+    wenv = mockWenv ()+      & L.theme .~ darkTheme+      & L.windowSize .~ Size 640 480+    point = Point 320 200+    midHBar = Point 630 476+    midVBar = Point 636 470+    st = [width 640, height 480]+    stackNode = vstack [+        hstack [+          button "Button 1" Button1 `styleBasic` st,+          button "Button 2" Button2 `styleBasic` st+        ],+        hstack [+          button "Button 3" Button3 `styleBasic` st,+          button "Button 4" Button4 `styleBasic` st+        ]+      ]+    scrollNode = scroll stackNode+    evts es = nodeHandleEventEvts wenv es scrollNode  handleChildrenFocus :: Spec handleChildrenFocus = describe "handleChildrenFocus" $ do
test/unit/Monomer/Widgets/Containers/StackSpec.hs view
@@ -73,16 +73,24 @@ 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 view
@@ -6,6 +6,7 @@ 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 @@ spec :: Spec spec = do   common+  core   graphics   widgets   widgetsUtil@@ -72,6 +74,10 @@ common :: Spec common = describe "Common" $ do   CursorIconSpec.spec++core :: Spec+core = describe "Core" $ do+  SizeReqSpec.spec  graphics :: Spec graphics = describe "Graphics" $ do