mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 12:05:35 +03:00
Fix space leak when rebuilding UI and handling events (#19)
* Basic tests with Strict/StrictData. These will be progressively replaced by strict fields/bang patterns, and also squashed before merging. * Change pragmas, reduce Strict, replace with StrictData/BangPatterns in containers. Reduce space leaks * Format package.yaml * Remove unneeded bangs, restore tutorial main * Bump version and update Changelog
This commit is contained in:
parent
999ad5f7ae
commit
2bfe8a8fe8
@ -1,11 +1,13 @@
|
||||
### 1.0.0.3
|
||||
|
||||
- Consume and forward all available messages from Producers on each cycle.
|
||||
- Add Nix and GitHub Actions support (thanks @smunix!).
|
||||
- Fix space leak when rebuilding the UI or handling events.
|
||||
|
||||
### 1.0.0.2
|
||||
|
||||
- Use the recently published nanovg-0.8.0.0 from Hackage, instead of the version from the PR's commit.
|
||||
- Added `appRenderOnMainThread` option.
|
||||
- Add `appRenderOnMainThread` option.
|
||||
|
||||
### 1.0.0.1
|
||||
|
||||
|
@ -5,7 +5,7 @@ cabal-version: 1.12
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: monomer
|
||||
version: 1.0.0.2
|
||||
version: 1.0.0.3
|
||||
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.
|
||||
|
146
package.yaml
146
package.yaml
@ -1,5 +1,5 @@
|
||||
name: monomer
|
||||
version: 1.0.0.2
|
||||
version: 1.0.0.3
|
||||
github: fjvallarino/monomer
|
||||
license: BSD3
|
||||
author: Francisco Vallarino
|
||||
@ -7,8 +7,8 @@ maintainer: fjvallarino@gmail.com
|
||||
copyright: 2018 Francisco Vallarino
|
||||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
- ChangeLog.md
|
||||
- README.md
|
||||
- ChangeLog.md
|
||||
|
||||
# Metadata used when publishing your package
|
||||
synopsis: A GUI library for writing native Haskell applications.
|
||||
@ -23,51 +23,51 @@ description: |
|
||||
Please see the README on Github at <https://github.com/fjvallarino/monomer#readme>
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
- OverloadedStrings
|
||||
|
||||
dependencies:
|
||||
- async >= 2.1 && < 2.3
|
||||
- attoparsec >= 0.12 && < 0.15
|
||||
- base >= 4.11 && < 5
|
||||
- bytestring >= 0.10 && < 0.12
|
||||
- bytestring-to-vector >= 0.3 && < 0.4
|
||||
- containers >= 0.5.11 && < 0.7
|
||||
- data-default >= 0.5 && < 0.8
|
||||
- exceptions >= 0.10 && < 0.11
|
||||
- extra >= 1.6 && < 1.9
|
||||
- formatting >= 6.0 && < 8.0
|
||||
- http-client >= 0.6 && < 0.9
|
||||
- JuicyPixels >= 3.2.9 && < 3.5
|
||||
- lens >= 4.16 && < 5.1
|
||||
- mtl >= 2.1 && < 2.3
|
||||
- nanovg >= 0.8 && < 1.0
|
||||
- OpenGL >= 3.0 && < 3.1
|
||||
- process >= 1.6 && < 1.7
|
||||
- safe >= 0.3 && < 0.4
|
||||
- sdl2 >= 2.4.0 && < 2.6
|
||||
- stm >= 2.5 && < 2.6
|
||||
- text >= 1.2 && < 1.3
|
||||
- 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
|
||||
- async >= 2.1 && < 2.3
|
||||
- attoparsec >= 0.12 && < 0.15
|
||||
- base >= 4.11 && < 5
|
||||
- bytestring >= 0.10 && < 0.12
|
||||
- bytestring-to-vector >= 0.3 && < 0.4
|
||||
- containers >= 0.5.11 && < 0.7
|
||||
- data-default >= 0.5 && < 0.8
|
||||
- exceptions >= 0.10 && < 0.11
|
||||
- extra >= 1.6 && < 1.9
|
||||
- formatting >= 6.0 && < 8.0
|
||||
- http-client >= 0.6 && < 0.9
|
||||
- JuicyPixels >= 3.2.9 && < 3.5
|
||||
- lens >= 4.16 && < 5.1
|
||||
- mtl >= 2.1 && < 2.3
|
||||
- nanovg >= 0.8 && < 1.0
|
||||
- OpenGL >= 3.0 && < 3.1
|
||||
- process >= 1.6 && < 1.7
|
||||
- safe >= 0.3 && < 0.4
|
||||
- sdl2 >= 2.4.0 && < 2.6
|
||||
- stm >= 2.5 && < 2.6
|
||||
- text >= 1.2 && < 1.3
|
||||
- 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
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
include-dirs: cbits
|
||||
install-includes:
|
||||
- fontmanager.h
|
||||
- fontmanager.h
|
||||
c-sources:
|
||||
- cbits/dpi.c
|
||||
- cbits/fontmanager.c
|
||||
- cbits/glew.c
|
||||
- cbits/dpi.c
|
||||
- cbits/fontmanager.c
|
||||
- cbits/glew.c
|
||||
build-tools: c2hs
|
||||
cc-options:
|
||||
- -fPIC
|
||||
- -fPIC
|
||||
ghc-options:
|
||||
- -fwarn-incomplete-patterns
|
||||
- -fwarn-incomplete-patterns
|
||||
when:
|
||||
- condition: os(windows)
|
||||
then:
|
||||
@ -80,71 +80,71 @@ executables:
|
||||
main: Main.hs
|
||||
source-dirs: examples/todo
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -threaded
|
||||
dependencies:
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- text-show >= 3.7 && < 3.10
|
||||
|
||||
books:
|
||||
main: Main.hs
|
||||
source-dirs: examples/books
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -threaded
|
||||
dependencies:
|
||||
- aeson >= 1.4 && < 1.6
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- wreq >= 0.5.2 && < 0.6
|
||||
- aeson >= 1.4 && < 1.6
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- wreq >= 0.5.2 && < 0.6
|
||||
|
||||
ticker:
|
||||
main: Main.hs
|
||||
source-dirs: examples/ticker
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -threaded
|
||||
dependencies:
|
||||
- aeson >= 1.4 && < 1.6
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- scientific >= 0.3 && < 0.4
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- websockets >= 0.12 && < 0.13
|
||||
- wuss >= 1.1 && < 1.2
|
||||
- aeson >= 1.4 && < 1.6
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- scientific >= 0.3 && < 0.4
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- websockets >= 0.12 && < 0.13
|
||||
- wuss >= 1.1 && < 1.2
|
||||
|
||||
generative:
|
||||
main: Main.hs
|
||||
source-dirs: examples/generative
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -threaded
|
||||
dependencies:
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- random >= 1.1 && < 1.3
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- random >= 1.1 && < 1.3
|
||||
- text-show >= 3.7 && < 3.10
|
||||
|
||||
tutorial:
|
||||
main: Main.hs
|
||||
source-dirs: examples/tutorial
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -threaded
|
||||
dependencies:
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- random >= 1.1 && < 1.3
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- time >= 1.8 && < 1.13
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- random >= 1.1 && < 1.3
|
||||
- text-show >= 3.7 && < 3.10
|
||||
- time >= 1.8 && < 1.13
|
||||
|
||||
tests:
|
||||
monomer-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test/unit
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -fwarn-incomplete-patterns
|
||||
- -threaded
|
||||
- -fwarn-incomplete-patterns
|
||||
dependencies:
|
||||
- directory >= 1.3 && < 1.4
|
||||
- monomer
|
||||
- hspec >= 2.4 && < 3.0
|
||||
- HUnit >= 1.6 && < 1.7
|
||||
- silently >= 1.2 && < 1.3
|
||||
- directory >= 1.3 && < 1.4
|
||||
- monomer
|
||||
- hspec >= 2.4 && < 3.0
|
||||
- HUnit >= 1.6 && < 1.7
|
||||
- silently >= 1.2 && < 1.3
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Helper functions creating, validating and merging size requirements.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Core.SizeReq (
|
||||
SizeReqUpdater(..),
|
||||
clearExtra,
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Helper functions for creating style configurations, and corresponding instances.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Core.Style (
|
||||
module Monomer.Core.StyleTypes,
|
||||
module Monomer.Core.ThemeTypes,
|
||||
|
@ -9,6 +9,7 @@ Portability : non-portable
|
||||
Basic types for styling widgets.
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Core.StyleTypes where
|
||||
|
||||
|
@ -10,6 +10,7 @@ Helper functions for style types.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Core.StyleUtil (
|
||||
getContentArea,
|
||||
|
@ -9,6 +9,7 @@ Portability : non-portable
|
||||
Theme configuration types.
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Core.ThemeTypes where
|
||||
|
||||
|
@ -12,6 +12,7 @@ Basic types and definitions for Widgets.
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Core.WidgetTypes where
|
||||
|
||||
@ -342,29 +343,29 @@ data WidgetEnv s e = WidgetEnv {
|
||||
data WidgetNodeInfo =
|
||||
WidgetNodeInfo {
|
||||
-- | Type of the widget.
|
||||
_wniWidgetType :: !WidgetType,
|
||||
_wniWidgetType :: WidgetType,
|
||||
-- | The identifier at creation time of the widget (runtime generated).
|
||||
_wniWidgetId :: !WidgetId,
|
||||
_wniWidgetId :: WidgetId,
|
||||
-- | Key/Identifier of the widget (user provided). Used for merging.
|
||||
_wniKey :: Maybe WidgetKey,
|
||||
-- | The path of the instance in the widget tree, as a set of indexes.
|
||||
_wniPath :: !Path,
|
||||
_wniPath :: Path,
|
||||
-- | The requested width for the widget. The one in style takes precedence.
|
||||
_wniSizeReqW :: !SizeReq,
|
||||
_wniSizeReqW :: SizeReq,
|
||||
-- | The requested height for the widget. The one in style takes precedence.
|
||||
_wniSizeReqH :: !SizeReq,
|
||||
_wniSizeReqH :: SizeReq,
|
||||
-- | Indicates if the widget is enabled for user interaction.
|
||||
_wniEnabled :: !Bool,
|
||||
_wniEnabled :: Bool,
|
||||
-- | Indicates if the widget is visible.
|
||||
_wniVisible :: !Bool,
|
||||
_wniVisible :: Bool,
|
||||
-- | Indicates whether the widget can receive focus.
|
||||
_wniFocusable :: !Bool,
|
||||
_wniFocusable :: Bool,
|
||||
{-|
|
||||
The area of the window where the widget can draw. Could be out of bounds or
|
||||
partially invisible if inside a scroll. The viewport on 'WidgetEnv' defines
|
||||
what is currently visible.
|
||||
-}
|
||||
_wniViewport :: !Rect,
|
||||
_wniViewport :: Rect,
|
||||
-- | Style attributes of the widget instance.
|
||||
_wniStyle :: Style
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
@ -9,6 +9,7 @@ Portability : non-portable
|
||||
Provides functions for getting text dimensions and metrics.
|
||||
-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Graphics.FontManager (
|
||||
makeFontManager
|
||||
|
@ -11,6 +11,7 @@ Renderer based on the nanovg library.
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Monomer.Graphics.NanoVGRenderer (makeRenderer) where
|
||||
|
@ -11,6 +11,7 @@ Helper functions for calculating text size.
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Graphics.Text (
|
||||
calcTextSize,
|
||||
@ -193,7 +194,7 @@ getTextLinesSize textLines = size where
|
||||
spaceV = unFontSpace $ maybe def _tlFontSpaceV (textLines ^? ix 0)
|
||||
lineW line = line ^. L.size . L.w
|
||||
lineH line = line ^. L.size . L.h + unFontSpace (_tlFontSpaceV line)
|
||||
width = maximum (fmap lineW textLines)
|
||||
~width = maximum (fmap lineW textLines)
|
||||
height = sum (fmap lineH textLines) - spaceV
|
||||
size
|
||||
| Seq.null textLines = def
|
||||
|
@ -11,6 +11,7 @@ Basic types for Graphics.
|
||||
Angles are always expressed in degrees, not radians.
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Graphics.Types where
|
||||
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Helper functions for graphics related operations.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Graphics.Util (
|
||||
clampChannel,
|
||||
clampAlpha,
|
||||
@ -59,14 +61,17 @@ rgba r g b a = Color {
|
||||
-- | Creates a Color from a hex string. It may include a # prefix or not.
|
||||
rgbHex :: String -> Color
|
||||
rgbHex hex
|
||||
| length hex == 7 = rgbHex (tail hex)
|
||||
| length hex == 6 = rgb r g b
|
||||
| length hex == 7 = rgbHexSix (tail hex)
|
||||
| length hex == 6 = rgbHexSix hex
|
||||
| otherwise = rgb 0 0 0
|
||||
where
|
||||
[r1, r2, g1, g2, b1, b2] = hex
|
||||
r = digitToInt r1 * 16 + digitToInt r2
|
||||
g = digitToInt g1 * 16 + digitToInt g2
|
||||
b = digitToInt b1 * 16 + digitToInt b2
|
||||
|
||||
-- | Creates a color from a six characters hex string. Fails if len is invalid.
|
||||
rgbHexSix :: [Char] -> Color
|
||||
rgbHexSix hex = rgb r g b where
|
||||
[r1, r2, g1, g2, b1, b2] = hex
|
||||
r = digitToInt r1 * 16 + digitToInt r2
|
||||
g = digitToInt g1 * 16 + digitToInt g2
|
||||
b = digitToInt b1 * 16 + digitToInt b2
|
||||
|
||||
{-|
|
||||
Creates a Color from a hex string plus an alpha component. It may include a #
|
||||
|
@ -8,9 +8,9 @@ Portability : non-portable
|
||||
|
||||
Core glue for running an application.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Main.Core (
|
||||
AppEventResponse(..),
|
||||
@ -143,7 +143,7 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
|
||||
startTs <- fmap fromIntegral SDL.ticks
|
||||
model <- use L.mainModel
|
||||
os <- getPlatform
|
||||
os <- liftIO getPlatform
|
||||
widgetSharedMVar <- liftIO $ newMVar Map.empty
|
||||
renderer <- if useRenderThread
|
||||
then return Nothing
|
||||
@ -231,8 +231,8 @@ mainLoop window fontManager config loopArgs = do
|
||||
dragged <- getDraggedMsgInfo
|
||||
mainPress <- use L.mainBtnPress
|
||||
inputStatus <- use L.inputStatus
|
||||
mousePos <- getCurrentMousePos epr
|
||||
currWinSize <- getViewportSize window dpr
|
||||
mousePos <- liftIO $ getCurrentMousePos epr
|
||||
currWinSize <- liftIO $ getViewportSize window dpr
|
||||
|
||||
let Size rw rh = windowSize
|
||||
let ts = startTicks - _mlFrameStartTs
|
||||
@ -419,29 +419,29 @@ renderWidgets
|
||||
-> WidgetEnv s e
|
||||
-> WidgetNode s e
|
||||
-> IO ()
|
||||
renderWidgets !window dpr renderer clearColor wenv widgetRoot = do
|
||||
renderWidgets window dpr renderer clearColor wenv widgetRoot = do
|
||||
Size dwW dwH <- getDrawableSize window
|
||||
Size vpW vpH <- getViewportSize window dpr
|
||||
|
||||
let position = GL.Position 0 0
|
||||
let size = GL.Size (round dwW) (round dwH)
|
||||
|
||||
liftIO $ GL.viewport GL.$= (position, size)
|
||||
GL.viewport GL.$= (position, size)
|
||||
|
||||
liftIO $ GL.clearColor GL.$= clearColor4
|
||||
liftIO $ GL.clear [GL.ColorBuffer]
|
||||
GL.clearColor GL.$= clearColor4
|
||||
GL.clear [GL.ColorBuffer]
|
||||
|
||||
liftIO $ beginFrame renderer vpW vpH
|
||||
liftIO $ widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer
|
||||
liftIO $ endFrame renderer
|
||||
beginFrame renderer vpW vpH
|
||||
widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer
|
||||
endFrame renderer
|
||||
|
||||
liftIO $ renderRawTasks renderer
|
||||
renderRawTasks renderer
|
||||
|
||||
liftIO $ beginFrame renderer vpW vpH
|
||||
liftIO $ renderOverlays renderer
|
||||
liftIO $ endFrame renderer
|
||||
beginFrame renderer vpW vpH
|
||||
renderOverlays renderer
|
||||
endFrame renderer
|
||||
|
||||
liftIO $ renderRawOverlays renderer
|
||||
renderRawOverlays renderer
|
||||
|
||||
SDL.glSwapWindow window
|
||||
where
|
||||
|
@ -12,6 +12,7 @@ overlays and all SystemEvent related operations and updates.
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Main.Handlers (
|
||||
HandlerStep,
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Helper functions for SDL platform related operations.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Main.Platform (
|
||||
defaultWindowSize,
|
||||
initSDLWindow,
|
||||
@ -138,20 +140,20 @@ detroySDLWindow window = do
|
||||
SDL.quit
|
||||
|
||||
-- | Returns the current mouse position.
|
||||
getCurrentMousePos :: (MonadIO m) => Double -> m Point
|
||||
getCurrentMousePos :: Double -> IO Point
|
||||
getCurrentMousePos epr = do
|
||||
SDL.P (SDL.V2 x y) <- Mouse.getAbsoluteMouseLocation
|
||||
return $ Point (epr * fromIntegral x) (epr * fromIntegral y)
|
||||
|
||||
-- | Returns the drawable size of the provided window. May differ from window
|
||||
-- size if HDPI is enabled.
|
||||
getDrawableSize :: (MonadIO m) => SDL.Window -> m Size
|
||||
getDrawableSize :: SDL.Window -> IO Size
|
||||
getDrawableSize window = do
|
||||
SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window
|
||||
return $ Size (fromIntegral fbWidth) (fromIntegral fbHeight)
|
||||
|
||||
-- | Returns the size of the provided window.
|
||||
getWindowSize :: (MonadIO m) => SDL.Window -> m Size
|
||||
getWindowSize :: SDL.Window -> IO Size
|
||||
getWindowSize window = do
|
||||
SDL.V2 rw rh <- SDL.get (SDL.windowSize window)
|
||||
|
||||
@ -163,16 +165,16 @@ render to and, depending on the platform, may match window size or not. For
|
||||
example, on Windows and Linux Wayland this size may be smaller than the window
|
||||
size because of dpr scaling.
|
||||
-}
|
||||
getViewportSize :: (MonadIO m) => SDL.Window -> Double -> m Size
|
||||
getViewportSize :: SDL.Window -> Double -> IO Size
|
||||
getViewportSize window dpr = do
|
||||
SDL.V2 fw fh <- SDL.glGetDrawableSize window
|
||||
|
||||
return $ Size (fromIntegral fw / dpr) (fromIntegral fh / dpr)
|
||||
|
||||
-- | Returns the name of the host OS.
|
||||
getPlatform :: (MonadIO m) => m Text
|
||||
getPlatform :: IO Text
|
||||
getPlatform = do
|
||||
platform <- liftIO . peekCString =<< Raw.getPlatform
|
||||
platform <- peekCString =<< Raw.getPlatform
|
||||
|
||||
return $ T.pack platform
|
||||
|
||||
|
@ -14,6 +14,7 @@ Basic types for Main module.
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Main.Types where
|
||||
|
||||
@ -85,7 +86,7 @@ data MonomerCtx s e = MonomerCtx {
|
||||
-- | Main application model.
|
||||
_mcMainModel :: s,
|
||||
-- | Active window.
|
||||
_mcWindow :: SDL.Window,
|
||||
_mcWindow :: ~SDL.Window,
|
||||
-- | Main window size.
|
||||
_mcWindowSize :: Size,
|
||||
-- | Device pixel rate.
|
||||
|
@ -9,6 +9,8 @@ Portability : non-portable
|
||||
Helper functions for Monomer users, to simplify common operations such as focus
|
||||
change and clipboard requests.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Main.UserUtil where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
|
@ -10,6 +10,7 @@ Helper functions for the Main module.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Main.Util where
|
||||
|
||||
@ -45,7 +46,7 @@ initMonomerCtx
|
||||
-> Double
|
||||
-> s
|
||||
-> MonomerCtx s e
|
||||
initMonomerCtx win channel winSize dpr epr model = MonomerCtx {
|
||||
initMonomerCtx ~win channel winSize dpr epr model = MonomerCtx {
|
||||
_mcMainModel = model,
|
||||
_mcWindow = win,
|
||||
_mcWindowSize = winSize,
|
||||
|
@ -10,6 +10,7 @@ Handles the lifecycle and reporting of generated events of WidgetTasks (single
|
||||
message) and Producers (multiple messages).
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Main.WidgetTask (handleWidgetTasks) where
|
||||
|
||||
|
@ -17,6 +17,7 @@ Messages:
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Animation.Fade (
|
||||
-- * Configuration
|
||||
|
@ -16,6 +16,7 @@ Messages:
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Animation.Slide (
|
||||
-- * Configuration
|
||||
|
@ -19,6 +19,7 @@ containers and singles.
|
||||
- Event Handler: processes user defined events which are raised by the widgets
|
||||
created when building the UI.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@ -266,9 +267,9 @@ compositeMergeReqs fn = def {
|
||||
}
|
||||
|
||||
data Composite s e sp ep = Composite {
|
||||
_cmpWidgetData :: WidgetData sp s,
|
||||
_cmpEventHandler :: EventHandler s e sp ep,
|
||||
_cmpUiBuilder :: UIBuilder s e,
|
||||
_cmpWidgetData :: !(WidgetData sp s),
|
||||
_cmpEventHandler :: !(EventHandler s e sp ep),
|
||||
_cmpUiBuilder :: !(UIBuilder s e),
|
||||
_cmpMergeRequired :: MergeRequired s,
|
||||
_cmpMergeReqs :: [MergeReqsHandler s e],
|
||||
_cmpOnInit :: [e],
|
||||
@ -280,8 +281,8 @@ data Composite s e sp ep = Composite {
|
||||
}
|
||||
|
||||
data CompositeState s e = CompositeState {
|
||||
_cpsModel :: Maybe s,
|
||||
_cpsRoot :: WidgetNode s e,
|
||||
_cpsModel :: !(Maybe s),
|
||||
_cpsRoot :: !(WidgetNode s e),
|
||||
_cpsWidgetKeyMap :: WidgetKeyMap s e
|
||||
}
|
||||
|
||||
@ -366,7 +367,7 @@ compositeD_
|
||||
compositeD_ wType wData uiBuilder evtHandler configs = newNode where
|
||||
config = mconcat configs
|
||||
mergeReq = fromMaybe (/=) (_cmcMergeRequired config)
|
||||
widgetRoot = spacer
|
||||
!widgetRoot = spacer
|
||||
composite = Composite {
|
||||
_cmpWidgetData = wData,
|
||||
_cmpEventHandler = evtHandler,
|
||||
@ -382,14 +383,14 @@ compositeD_ wType wData uiBuilder evtHandler configs = newNode where
|
||||
}
|
||||
state = CompositeState Nothing widgetRoot M.empty
|
||||
widget = createComposite composite state
|
||||
newNode = defaultWidgetNode wType widget
|
||||
!newNode = defaultWidgetNode wType widget
|
||||
|
||||
createComposite
|
||||
:: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
|
||||
=> Composite s e sp ep
|
||||
-> CompositeState s e
|
||||
-> Widget sp ep
|
||||
createComposite comp state = widget where
|
||||
createComposite !comp !state = widget where
|
||||
widget = Widget {
|
||||
widgetInit = compositeInit comp state,
|
||||
widgetMerge = compositeMerge comp state,
|
||||
@ -416,15 +417,15 @@ compositeInit
|
||||
-> WidgetResult sp ep
|
||||
compositeInit comp state wenv widgetComp = newResult where
|
||||
CompositeState{..} = state
|
||||
model = getModel comp wenv
|
||||
cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
!model = getModel comp wenv
|
||||
!cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
-- Creates UI using provided function
|
||||
builtRoot = _cmpUiBuilder comp cwenv model
|
||||
tempRoot = cascadeCtx wenv widgetComp builtRoot
|
||||
!builtRoot = _cmpUiBuilder comp cwenv model
|
||||
!tempRoot = cascadeCtx wenv widgetComp builtRoot
|
||||
|
||||
WidgetResult root reqs = widgetInit (tempRoot ^. L.widget) cwenv tempRoot
|
||||
newEvts = RaiseEvent <$> Seq.fromList (_cmpOnInit comp)
|
||||
newState = state {
|
||||
!newState = state {
|
||||
_cpsModel = Just model,
|
||||
_cpsRoot = root,
|
||||
_cpsWidgetKeyMap = collectWidgetKeys M.empty root
|
||||
@ -433,7 +434,7 @@ compositeInit comp state wenv widgetComp = newResult where
|
||||
getBaseStyle wenv node = Nothing
|
||||
styledComp = initNodeStyle getBaseStyle wenv widgetComp
|
||||
tempResult = WidgetResult root (reqs <> newEvts)
|
||||
newResult = toParentResult comp newState wenv styledComp tempResult
|
||||
!newResult = toParentResult comp newState wenv styledComp tempResult
|
||||
|
||||
-- | Merge
|
||||
compositeMerge
|
||||
@ -467,11 +468,11 @@ compositeMerge comp state wenv newComp oldComp = newResult where
|
||||
| otherwise = True
|
||||
initRequired = not (nodeMatches tempRoot oldRoot)
|
||||
|
||||
WidgetResult newRoot tmpReqs
|
||||
WidgetResult !newRoot !tmpReqs
|
||||
| initRequired = widgetInit tempWidget cwenv tempRoot
|
||||
| mergeRequired = widgetMerge tempWidget cwenv tempRoot oldRoot
|
||||
| otherwise = resultNode oldRoot
|
||||
newState = validState {
|
||||
!newState = validState {
|
||||
_cpsModel = Just model,
|
||||
_cpsRoot = newRoot,
|
||||
_cpsWidgetKeyMap = collectWidgetKeys M.empty newRoot
|
||||
@ -492,7 +493,7 @@ compositeMerge comp state wenv newComp oldComp = newResult where
|
||||
|
||||
tmpResult = WidgetResult newRoot (tmpReqs <> extraReqs <> evts)
|
||||
reducedResult = toParentResult comp newState wenv styledComp tmpResult
|
||||
newResult = handleWidgetIdChange oldComp reducedResult
|
||||
!newResult = handleWidgetIdChange oldComp reducedResult
|
||||
|
||||
-- | Dispose
|
||||
compositeDispose
|
||||
@ -605,18 +606,18 @@ compositeHandleEvent
|
||||
compositeHandleEvent comp state wenv widgetComp target evt = result where
|
||||
CompositeState{..} = state
|
||||
widget = _cpsRoot ^. L.widget
|
||||
model = getModel comp wenv
|
||||
cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
!model = getModel comp wenv
|
||||
!cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
rootEnabled = _cpsRoot ^. L.info . L.enabled
|
||||
compVisible = widgetComp ^. L.info . L.visible
|
||||
compEnabled = widgetComp ^. L.info . L.enabled
|
||||
|
||||
processEvent = toParentResult comp state wenv widgetComp
|
||||
evtResult
|
||||
!evtResult
|
||||
| not (compVisible && compEnabled) = Nothing
|
||||
| rootEnabled = widgetHandleEvent widget cwenv _cpsRoot target evt
|
||||
| otherwise = Nothing
|
||||
result = fmap processEvent evtResult
|
||||
!result = fmap processEvent evtResult
|
||||
|
||||
-- | Message handling
|
||||
compositeHandleMessage
|
||||
@ -628,7 +629,7 @@ compositeHandleMessage
|
||||
-> Path
|
||||
-> i
|
||||
-> Maybe (WidgetResult sp ep)
|
||||
compositeHandleMessage comp state@CompositeState{..} wenv widgetComp target arg
|
||||
compositeHandleMessage comp state@CompositeState{..} !wenv !widgetComp !target arg
|
||||
| isTargetReached widgetComp target = case cast arg of
|
||||
Just evt -> Just $ handleMsgEvent comp state wenv widgetComp evt
|
||||
Nothing -> case cast arg of
|
||||
@ -637,8 +638,8 @@ compositeHandleMessage comp state@CompositeState{..} wenv widgetComp target arg
|
||||
| otherwise = fmap processEvent result where
|
||||
processEvent = toParentResult comp state wenv widgetComp
|
||||
cmpWidget = _cpsRoot ^. L.widget
|
||||
model = getModel comp wenv
|
||||
cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
!model = getModel comp wenv
|
||||
!cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
result = widgetHandleMessage cmpWidget cwenv _cpsRoot target arg
|
||||
|
||||
-- Preferred size
|
||||
@ -717,9 +718,9 @@ compositeRender
|
||||
compositeRender comp state wenv widgetComp renderer = action where
|
||||
CompositeState{..} = state
|
||||
widget = _cpsRoot ^. L.widget
|
||||
model = getModel comp wenv
|
||||
cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
action = widgetRender widget cwenv _cpsRoot renderer
|
||||
!model = getModel comp wenv
|
||||
!cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
!action = widgetRender widget cwenv _cpsRoot renderer
|
||||
|
||||
handleMsgEvent
|
||||
:: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
|
||||
@ -735,10 +736,10 @@ handleMsgEvent comp state wenv widgetComp event = newResult where
|
||||
| isJust _cpsModel = fromJust _cpsModel
|
||||
| otherwise = getModel comp wenv
|
||||
evtHandler = _cmpEventHandler comp
|
||||
cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
response = evtHandler cwenv _cpsRoot model event
|
||||
newReqs = evtResponseToRequest widgetComp _cpsWidgetKeyMap <$> response
|
||||
newResult = WidgetResult widgetComp (Seq.fromList (catMaybes newReqs))
|
||||
!cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
|
||||
!response = evtHandler cwenv _cpsRoot model event
|
||||
!newReqs = evtResponseToRequest widgetComp _cpsWidgetKeyMap <$> response
|
||||
!newResult = WidgetResult widgetComp (Seq.fromList (catMaybes newReqs))
|
||||
|
||||
handleMsgUpdate
|
||||
:: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
|
||||
@ -753,8 +754,8 @@ handleMsgUpdate comp state wenv widgetComp fnUpdate = result where
|
||||
model
|
||||
| isJust _cpsModel = fromJust _cpsModel
|
||||
| otherwise = getModel comp wenv
|
||||
newModel = fnUpdate model
|
||||
result
|
||||
!newModel = fnUpdate model
|
||||
!result
|
||||
| model == newModel = resultNode widgetComp
|
||||
| otherwise = mergeChild comp state wenv newModel _cpsRoot widgetComp
|
||||
|
||||
@ -766,7 +767,7 @@ toParentResult
|
||||
-> WidgetNode sp ep
|
||||
-> WidgetResult s e
|
||||
-> WidgetResult sp ep
|
||||
toParentResult comp state wenv widgetComp result = newResult where
|
||||
toParentResult comp state !wenv !widgetComp !result = newResult where
|
||||
WidgetResult newRoot reqs = result
|
||||
widgetId = widgetComp ^. L.info . L.widgetId
|
||||
newState = state {
|
||||
@ -776,7 +777,7 @@ toParentResult comp state wenv widgetComp result = newResult where
|
||||
& L.widget .~ createComposite comp newState
|
||||
newNode = updateSizeReq comp newState wenv newComp
|
||||
newReqs = seqCatMaybes (toParentReq widgetId <$> reqs)
|
||||
newResult = WidgetResult newNode newReqs
|
||||
!newResult = WidgetResult newNode newReqs
|
||||
|
||||
evtResponseToRequest
|
||||
:: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
|
||||
@ -814,15 +815,15 @@ mergeChild comp state wenv newModel widgetRoot widgetComp = newResult where
|
||||
& L.info . L.widgetId .~ _cpsRoot ^. L.info . L.widgetId
|
||||
builtWidget = builtRoot ^. L.widget
|
||||
mergedResult = widgetMerge builtWidget cwenv builtRoot widgetRoot
|
||||
mergedState = state {
|
||||
!mergedState = state {
|
||||
_cpsModel = Just newModel,
|
||||
_cpsRoot = mergedResult ^. L.node,
|
||||
_cpsWidgetKeyMap = collectWidgetKeys M.empty (mergedResult ^. L.node)
|
||||
}
|
||||
result = toParentResult comp mergedState wenv widgetComp mergedResult
|
||||
newReqs = widgetDataSet (_cmpWidgetData comp) newModel
|
||||
!result = toParentResult comp mergedState wenv widgetComp mergedResult
|
||||
!newReqs = widgetDataSet (_cmpWidgetData comp) newModel
|
||||
++ fmap ($ newModel) (_cmpOnChangeReq comp)
|
||||
newResult = result
|
||||
!newResult = result
|
||||
& L.requests <>~ Seq.fromList newReqs
|
||||
|
||||
getModel
|
||||
|
@ -8,6 +8,7 @@ Portability : non-portable
|
||||
|
||||
Helper for creating widgets with children elements.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
@ -433,7 +434,7 @@ createContainer
|
||||
=> a
|
||||
-> Container s e a
|
||||
-> Widget s e
|
||||
createContainer state container = Widget {
|
||||
createContainer !state !container = Widget {
|
||||
widgetInit = initWrapper container,
|
||||
widgetMerge = mergeWrapper container,
|
||||
widgetDispose = disposeWrapper container,
|
||||
@ -466,16 +467,16 @@ getUpdateCWenv
|
||||
-> WidgetNode s e
|
||||
-> Int
|
||||
-> WidgetEnv s e
|
||||
getUpdateCWenv container wenv node cnode cidx = newWenv where
|
||||
getUpdateCWenv container !wenv !node !cnode !cidx = newWenv where
|
||||
cOffset = containerChildrenOffset container
|
||||
updateCWenv = containerUpdateCWenv container
|
||||
layoutDirection = containerLayoutDirection container
|
||||
offsetWenv wenv
|
||||
offsetWenv !wenv
|
||||
| isJust cOffset = updateWenvOffset container wenv node
|
||||
| otherwise = wenv
|
||||
directionWenv = wenv
|
||||
!directionWenv = wenv
|
||||
& L.layoutDirection .~ layoutDirection
|
||||
newWenv = updateCWenv (offsetWenv directionWenv) node cnode cidx
|
||||
!newWenv = updateCWenv (offsetWenv directionWenv) node cnode cidx
|
||||
|
||||
{-|
|
||||
Helper function that updates widget environment based on current container
|
||||
@ -621,7 +622,7 @@ mergeChildren
|
||||
-> WidgetNode s e
|
||||
-> WidgetResult s e
|
||||
-> WidgetResult s e
|
||||
mergeChildren updateCWenv wenv newNode oldNode result = newResult where
|
||||
mergeChildren updateCWenv !wenv !newNode !oldNode !result = newResult where
|
||||
WidgetResult uNode uReqs = result
|
||||
oldChildren = oldNode ^. L.children
|
||||
oldIts = Seq.mapWithIndex (,) oldChildren
|
||||
@ -639,7 +640,7 @@ mergeChildren updateCWenv wenv newNode oldNode result = newResult where
|
||||
removedReqs = foldMap _wrRequests removedResults
|
||||
mergedNode = uNode & L.children .~ mergedChildren
|
||||
newReqs = uReqs <> mergedReqs <> removedReqs
|
||||
newResult = WidgetResult mergedNode newReqs
|
||||
!newResult = WidgetResult mergedNode newReqs
|
||||
|
||||
mergeChildSeq
|
||||
:: (Int -> WidgetNode s e -> WidgetEnv s e)
|
||||
@ -651,25 +652,26 @@ mergeChildSeq
|
||||
-> Seq (Int, WidgetNode s e)
|
||||
-> (Seq (WidgetResult s e), Seq (WidgetResult s e))
|
||||
mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts Empty = res where
|
||||
dispose (idx, child) = case flip M.member newKeys <$> child^. L.info. L.key of
|
||||
isMember = flip M.member newKeys
|
||||
dispose (!idx, !child) = case isMember <$> child ^. L.info . L.key of
|
||||
Just True -> WidgetResult child Empty
|
||||
_ -> widgetDispose (child ^. L.widget) wenv child
|
||||
removed = fmap dispose oldIts
|
||||
res = (Empty, removed)
|
||||
!removed = fmap dispose oldIts
|
||||
!res = (Empty, removed)
|
||||
mergeChildSeq updateCWenv wenv oldKeys newKeys newNode Empty newIts = res where
|
||||
init (idx, child) = widgetInit (child ^. L.widget) wenv child
|
||||
merged = fmap init newIts
|
||||
res = (merged, Empty)
|
||||
init (idx, !child) = widgetInit (child ^. L.widget) wenv child
|
||||
!merged = fmap init newIts
|
||||
!res = (merged, Empty)
|
||||
mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts = res where
|
||||
(_, oldChild) :<| oldChildren = oldIts
|
||||
(newIdx, newChild) :<| newChildren = newIts
|
||||
newWidget = newChild ^. L.widget
|
||||
newWidgetId = newChild ^. L.info . L.widgetId
|
||||
newChildKey = newChild ^. L.info . L.key
|
||||
cwenv = updateCWenv newIdx newChild
|
||||
(_, !oldChild) :<| oldChildren = oldIts
|
||||
(!newIdx, !newChild) :<| newChildren = newIts
|
||||
!newWidget = newChild ^. L.widget
|
||||
!newWidgetId = newChild ^. L.info . L.widgetId
|
||||
!newChildKey = newChild ^. L.info . L.key
|
||||
!cwenv = updateCWenv newIdx newChild
|
||||
|
||||
oldKeyMatch = newChildKey >>= \key -> M.lookup key oldKeys
|
||||
oldMatch = fromJust oldKeyMatch
|
||||
oldMatch = fromMaybe newNode oldKeyMatch
|
||||
isMergeKey = isJust oldKeyMatch && nodeMatches newChild oldMatch
|
||||
|
||||
mergedOld = widgetMerge newWidget cwenv newChild oldChild
|
||||
@ -677,15 +679,15 @@ mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts = res where
|
||||
initNew = widgetInit newWidget cwenv newChild
|
||||
& L.requests %~ (|> ResizeWidgets newWidgetId)
|
||||
|
||||
(child, oldRest)
|
||||
(!child, !oldRest)
|
||||
| nodeMatches newChild oldChild = (mergedOld, oldChildren)
|
||||
| isMergeKey = (mergedKey, oldIts)
|
||||
| otherwise = (initNew, oldIts)
|
||||
|
||||
(cmerged, cremoved)
|
||||
(!cmerged, !cremoved)
|
||||
= mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldRest newChildren
|
||||
merged = child <| cmerged
|
||||
res = (merged, cremoved)
|
||||
!merged = child <| cmerged
|
||||
!res = (merged, cremoved)
|
||||
|
||||
mergeChildrenCheckVisible
|
||||
:: WidgetNode s e
|
||||
@ -695,7 +697,7 @@ mergeChildrenCheckVisible oldNode result = newResult where
|
||||
newNode = result ^. L.node
|
||||
widgetId = newNode ^. L.info . L.widgetId
|
||||
resizeRequired = childrenVisibleChanged oldNode newNode
|
||||
newResult
|
||||
!newResult
|
||||
| resizeRequired = result & L.requests %~ (|> ResizeWidgets widgetId)
|
||||
| otherwise = result
|
||||
|
||||
@ -733,15 +735,15 @@ disposeWrapper container wenv node = result where
|
||||
widgetId = node ^. L.info . L.widgetId
|
||||
children = tempNode ^. L.children
|
||||
|
||||
dispose idx child = widgetDispose (child ^. L.widget) cwenv child where
|
||||
dispose !idx !child = widgetDispose (child ^. L.widget) cwenv child where
|
||||
cwenv = updateCWenv wenv node child idx
|
||||
results = Seq.mapWithIndex dispose children
|
||||
newReqs = foldMap _wrRequests results |> ResetWidgetPath widgetId
|
||||
result = WidgetResult node (reqs <> newReqs)
|
||||
!result = WidgetResult node (reqs <> newReqs)
|
||||
|
||||
-- | Find next focusable item
|
||||
defaultFindNextFocus :: ContainerFindNextFocusHandler s e
|
||||
defaultFindNextFocus wenv node direction start = vchildren where
|
||||
defaultFindNextFocus !wenv !node !direction !start = vchildren where
|
||||
vchildren = Seq.filter (^. L.info . L.visible) (node ^. L.children)
|
||||
|
||||
findNextFocusWrapper
|
||||
@ -751,13 +753,13 @@ findNextFocusWrapper
|
||||
-> FocusDirection
|
||||
-> Path
|
||||
-> Maybe WidgetNodeInfo
|
||||
findNextFocusWrapper container wenv node dir start = nextFocus where
|
||||
findNextFocusWrapper container !wenv !node !dir !start = nextFocus where
|
||||
handler = containerFindNextFocus container
|
||||
handlerResult = handler wenv node dir start
|
||||
children
|
||||
| dir == FocusBwd = Seq.reverse handlerResult
|
||||
| otherwise = handlerResult
|
||||
nextFocus
|
||||
!nextFocus
|
||||
| isFocusCandidate node start dir = Just (node ^. L.info)
|
||||
| otherwise = findFocusCandidate container wenv dir start node children
|
||||
|
||||
@ -770,12 +772,12 @@ findFocusCandidate
|
||||
-> Seq (WidgetNode s e)
|
||||
-> Maybe WidgetNodeInfo
|
||||
findFocusCandidate _ _ _ _ _ Empty = Nothing
|
||||
findFocusCandidate container wenv dir start node (ch :<| chs) = result where
|
||||
findFocusCandidate container !wenv !dir !start !node (ch :<| chs) = result where
|
||||
updateCWenv = getUpdateCWenv container
|
||||
path = node ^. L.info . L.path
|
||||
idx = fromMaybe 0 (Seq.lookup (length path - 1) path)
|
||||
cwenv = updateCWenv wenv node ch idx
|
||||
isWidgetAfterStart
|
||||
!path = node ^. L.info . L.path
|
||||
!idx = fromMaybe 0 (Seq.lookup (length path - 1) path)
|
||||
!cwenv = updateCWenv wenv node ch idx
|
||||
!isWidgetAfterStart
|
||||
| dir == FocusBwd = isNodeBeforePath ch start
|
||||
| otherwise = isNodeParentOfPath ch start || isNodeAfterPath ch start
|
||||
|
||||
@ -786,7 +788,7 @@ findFocusCandidate container wenv dir start node (ch :<| chs) = result where
|
||||
|
||||
-- | Find instance matching point
|
||||
defaultFindByPoint :: ContainerFindByPointHandler s e
|
||||
defaultFindByPoint wenv node start point = result where
|
||||
defaultFindByPoint !wenv !node !start !point = result where
|
||||
children = node ^. L.children
|
||||
pointInWidget wi = wi ^. L.visible && pointInRect point (wi ^. L.viewport)
|
||||
result = Seq.findIndexL (pointInWidget . _wnInfo) children
|
||||
@ -798,7 +800,7 @@ findByPointWrapper
|
||||
-> Path
|
||||
-> Point
|
||||
-> Maybe WidgetNodeInfo
|
||||
findByPointWrapper container wenv node start point = result where
|
||||
findByPointWrapper !container !wenv !node !start !point = result where
|
||||
offset = fromMaybe def (containerChildrenOffset container)
|
||||
updateCWenv = getUpdateCWenv container
|
||||
ignoreEmpty = containerIgnoreEmptyArea container
|
||||
@ -832,7 +834,7 @@ containerFindBranchByPath
|
||||
-> WidgetNode s e
|
||||
-> Path
|
||||
-> Seq WidgetNodeInfo
|
||||
containerFindBranchByPath wenv node path
|
||||
containerFindBranchByPath !wenv !node !path
|
||||
| info ^. L.path == path = Seq.singleton info
|
||||
| isJust nextChild = info <| nextInst (fromJust nextChild)
|
||||
| otherwise = Seq.empty
|
||||
@ -858,54 +860,56 @@ handleEventWrapper
|
||||
-> Path
|
||||
-> SystemEvent
|
||||
-> Maybe (WidgetResult s e)
|
||||
handleEventWrapper container wenv node baseTarget baseEvt
|
||||
handleEventWrapper container !wenv !node !baseTarget !baseEvt
|
||||
| not (node ^. L.info . L.visible) || isNothing filteredEvt = Nothing
|
||||
| targetReached || not targetValid = pResultStyled
|
||||
| otherwise = cResultStyled
|
||||
| otherwise = nextTargetStep pNode target >>= cResultStyled
|
||||
where
|
||||
-- Having targetValid = False means the next path step is not in
|
||||
-- _wiChildren, but may still be valid in the receiving widget
|
||||
-- For example, Composite has its own tree of child widgets with (possibly)
|
||||
-- different types for Model and Events, and is candidate for the next step
|
||||
offset = fromMaybe def (containerChildrenOffset container)
|
||||
style = containerGetCurrentStyle container wenv node
|
||||
doCursor = not (containerUseCustomCursor container)
|
||||
!offset = fromMaybe def (containerChildrenOffset container)
|
||||
!style = containerGetCurrentStyle container wenv node
|
||||
!doCursor = not (containerUseCustomCursor container)
|
||||
updateCWenv = getUpdateCWenv container
|
||||
filterHandler = containerFilterEvent container
|
||||
eventHandler = containerHandleEvent container
|
||||
|
||||
targetReached = isTargetReached node target
|
||||
targetValid = isTargetValid node target
|
||||
filteredEvt = filterHandler wenv node baseTarget baseEvt
|
||||
(target, evt) = fromMaybe (baseTarget, baseEvt) filteredEvt
|
||||
!targetReached = isTargetReached node target
|
||||
!targetValid = isTargetValid node target
|
||||
!filteredEvt = filterHandler wenv node baseTarget baseEvt
|
||||
(!target, !evt) = fromMaybe (baseTarget, baseEvt) filteredEvt
|
||||
-- Event targeted at parent
|
||||
pResult = eventHandler wenv node target evt
|
||||
!pResult = eventHandler wenv node target evt
|
||||
pResultStyled = handleStyleChange wenv target style doCursor node evt
|
||||
$ handleSizeReqChange container wenv node (Just evt) pResult
|
||||
-- Event targeted at children
|
||||
pNode = maybe node (^. L.node) pResult
|
||||
cwenv = updateCWenv wenv pNode child childIdx
|
||||
childIdx = fromJust $ nextTargetStep pNode target
|
||||
children = pNode ^. L.children
|
||||
child = Seq.index children childIdx
|
||||
childWidget = child ^. L.widget
|
||||
cevt = translateEvent (negPoint offset) evt
|
||||
|
||||
childrenIgnored = isJust pResult && ignoreChildren (fromJust pResult)
|
||||
parentIgnored = isJust cResult && ignoreParent (fromJust cResult)
|
||||
-- Event targeted at children
|
||||
cResultStyled childIdx = result where
|
||||
--childIdx = fromJust $ nextTargetStep pNode target
|
||||
children = pNode ^. L.children
|
||||
child = Seq.index children childIdx
|
||||
childWidget = child ^. L.widget
|
||||
cevt = translateEvent (negPoint offset) evt
|
||||
cwenv = updateCWenv wenv pNode child childIdx
|
||||
|
||||
cResult
|
||||
| childrenIgnored || not (child ^. L.info . L.enabled) = Nothing
|
||||
| otherwise = widgetHandleEvent childWidget cwenv child target cevt
|
||||
cResultMerged
|
||||
| parentIgnored = mergeParentChildEvts node Nothing cResult childIdx
|
||||
| otherwise = mergeParentChildEvts pNode pResult cResult childIdx
|
||||
childrenIgnored = isJust pResult && ignoreChildren (fromJust pResult)
|
||||
parentIgnored = isJust cResult && ignoreParent (fromJust cResult)
|
||||
|
||||
cpNode
|
||||
| parentIgnored = node
|
||||
| otherwise = pNode
|
||||
cResultStyled = handleStyleChange cwenv target style doCursor cpNode cevt
|
||||
$ handleSizeReqChange container cwenv cpNode (Just cevt) cResultMerged
|
||||
cResult
|
||||
| childrenIgnored || not (child ^. L.info . L.enabled) = Nothing
|
||||
| otherwise = widgetHandleEvent childWidget cwenv child target cevt
|
||||
cResultMerged
|
||||
| parentIgnored = mergeParentChildEvts node Nothing cResult childIdx
|
||||
| otherwise = mergeParentChildEvts pNode pResult cResult childIdx
|
||||
|
||||
cpNode
|
||||
| parentIgnored = node
|
||||
| otherwise = pNode
|
||||
!result = handleStyleChange cwenv target style doCursor cpNode cevt
|
||||
$ handleSizeReqChange container cwenv cpNode (Just cevt) cResultMerged
|
||||
|
||||
mergeParentChildEvts
|
||||
:: WidgetNode s e
|
||||
@ -943,7 +947,7 @@ handleMessageWrapper
|
||||
-> Path
|
||||
-> i
|
||||
-> Maybe (WidgetResult s e)
|
||||
handleMessageWrapper container wenv node target arg
|
||||
handleMessageWrapper container !wenv !node !target arg
|
||||
| not targetReached && not targetValid = Nothing
|
||||
| otherwise = handleSizeReqChange container wenv node Nothing result
|
||||
where
|
||||
@ -952,19 +956,20 @@ handleMessageWrapper container wenv node target arg
|
||||
|
||||
targetReached = isTargetReached node target
|
||||
targetValid = isTargetValid node target
|
||||
childIdx = fromJust $ nextTargetStep node target
|
||||
children = node ^. L.children
|
||||
child = Seq.index children childIdx
|
||||
cwenv = updateCWenv wenv node child childIdx
|
||||
|
||||
message = widgetHandleMessage (child ^. L.widget) cwenv child target arg
|
||||
messageResult = updateChild <$> message
|
||||
updateChild cr = cr {
|
||||
_wrNode = replaceChild node (_wrNode cr) childIdx
|
||||
}
|
||||
messageResult childIdx = updateChild <$> message where
|
||||
children = node ^. L.children
|
||||
child = Seq.index children childIdx
|
||||
cwenv = updateCWenv wenv node child childIdx
|
||||
|
||||
message = widgetHandleMessage (child ^. L.widget) cwenv child target arg
|
||||
updateChild !cr = cr {
|
||||
_wrNode = replaceChild node (_wrNode cr) childIdx
|
||||
}
|
||||
|
||||
result
|
||||
| targetReached = handler wenv node target arg
|
||||
| otherwise = messageResult
|
||||
| otherwise = nextTargetStep node target >>= messageResult
|
||||
|
||||
-- | Preferred size
|
||||
defaultGetSizeReq :: ContainerGetSizeReqHandler s e
|
||||
@ -1049,12 +1054,12 @@ resizeWrapper container wenv node viewport resizeReq = result where
|
||||
children = node ^. L.children
|
||||
|
||||
(tempRes, assigned) = handler wenv node viewport children
|
||||
resize idx (child, vp) = newChildRes where
|
||||
cwenv = updateCWenv wenv node child idx
|
||||
resize idx (!child, !vp) = newChildRes where
|
||||
!cwenv = updateCWenv wenv node child idx
|
||||
tempChildRes = widgetResize (child ^. L.widget) cwenv child vp resizeReq
|
||||
cvp = tempChildRes ^. L.node . L.info . L.viewport
|
||||
icvp = fromMaybe vp (intersectRects vp cvp)
|
||||
newChildRes = tempChildRes
|
||||
!newChildRes = tempChildRes
|
||||
& L.node . L.info . L.viewport .~ (if useChildSize then icvp else vp)
|
||||
|
||||
newChildrenRes = Seq.mapWithIndex resize (Seq.zip children assigned)
|
||||
@ -1082,7 +1087,7 @@ renderWrapper
|
||||
-> WidgetNode s e
|
||||
-> Renderer
|
||||
-> IO ()
|
||||
renderWrapper container wenv node renderer =
|
||||
renderWrapper container wenv !node !renderer =
|
||||
drawInScissor renderer useScissor viewport $
|
||||
drawStyledAction renderer viewport style $ \_ -> do
|
||||
renderBefore wenv node renderer
|
||||
@ -1115,7 +1120,7 @@ renderWrapper container wenv node renderer =
|
||||
useChildrenScissor = isJust childrenScissor
|
||||
childrenScissorRect = fromMaybe def childrenScissor
|
||||
pairs = Seq.mapWithIndex (,) children
|
||||
cwenv child idx = updateCWenv wenv node child idx
|
||||
cwenv !child !idx = updateCWenv wenv node child idx
|
||||
|
||||
-- | Event Handling Helpers
|
||||
ignoreChildren :: WidgetResult s e -> Bool
|
||||
@ -1128,19 +1133,19 @@ ignoreParent result = not (Seq.null ignoreReqs) where
|
||||
|
||||
replaceChild
|
||||
:: WidgetNode s e -> WidgetNode s e -> Int -> WidgetNode s e
|
||||
replaceChild parent child idx = parent & L.children .~ newChildren where
|
||||
replaceChild !parent !child !idx = parent & L.children .~ newChildren where
|
||||
newChildren = Seq.update idx child (parent ^. L.children)
|
||||
|
||||
cascadeCtx
|
||||
:: WidgetEnv s e -> WidgetNode s e -> WidgetNode s e -> Int -> WidgetNode s e
|
||||
cascadeCtx wenv parent child idx = newChild where
|
||||
cascadeCtx !wenv !parent !child !idx = newChild where
|
||||
pInfo = parent ^. L.info
|
||||
cInfo = child ^. L.info
|
||||
parentPath = pInfo ^. L.path
|
||||
parentVisible = pInfo ^. L.visible
|
||||
parentEnabled = pInfo ^. L.enabled
|
||||
newPath = parentPath |> idx
|
||||
newChild = child
|
||||
!newPath = parentPath |> idx
|
||||
!newChild = child
|
||||
& L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) newPath
|
||||
& L.info . L.path .~ newPath
|
||||
& L.info . L.visible .~ (cInfo ^. L.visible && parentVisible)
|
||||
|
@ -9,6 +9,8 @@ Portability : non-portable
|
||||
Simple alert dialog, displaying a close button and optional title. Usually
|
||||
embedded in a zstack component and displayed/hidden depending on context.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Alert (
|
||||
-- * Configuration
|
||||
AlertCfg,
|
||||
|
@ -24,6 +24,7 @@ label with an image at its side).
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Box (
|
||||
-- * Configuration
|
||||
|
@ -12,6 +12,7 @@ context.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Confirm (
|
||||
-- * Configuration
|
||||
|
@ -13,6 +13,7 @@ having to implement a custom widget. Usually works in tandem with
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Draggable (
|
||||
-- * Configuration
|
||||
|
@ -16,6 +16,7 @@ the dragged message, otherwise it will not be raised.
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.DropTarget (
|
||||
-- * Configuration
|
||||
|
@ -18,6 +18,7 @@ to use.
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Dropdown (
|
||||
-- * Configuration
|
||||
|
@ -11,6 +11,7 @@ it requests max width * elements as its width, and the max height as its height.
|
||||
The reverse happens for vgrid.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Grid (
|
||||
-- * Configuration
|
||||
@ -108,7 +109,7 @@ makeFixedGrid isHorizontal config = widget where
|
||||
where
|
||||
vreqs = accesor <$> vchildren
|
||||
nreqs = Seq.length vreqs
|
||||
maxSize = foldl1 sizeReqMergeMax vreqs
|
||||
~maxSize = foldl1 sizeReqMergeMax vreqs
|
||||
|
||||
resize wenv node viewport children = resized where
|
||||
style = currentStyle wenv node
|
||||
|
@ -32,6 +32,7 @@ These can be combined, for example:
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Keystroke (
|
||||
-- * Configuration
|
||||
|
@ -23,6 +23,7 @@ Messages:
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Scroll (
|
||||
-- * Configuration
|
||||
@ -375,7 +376,9 @@ makeScroll config state = widget where
|
||||
checkFwdStyle wenv node = newNode where
|
||||
fwdStyle = _scScrollFwdStyle config
|
||||
style = node ^. L.info . L.style
|
||||
(parentStyle, childStyle) = fromJust fwdStyle wenv style
|
||||
(parentStyle, childStyle)
|
||||
| isJust fwdStyle = fromJust fwdStyle wenv style
|
||||
| otherwise = def
|
||||
newNode
|
||||
| isJust fwdStyle = node
|
||||
& L.info . L.style .~ parentStyle
|
||||
|
@ -14,6 +14,7 @@ customizable, plus its styling.
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Containers.SelectList (
|
||||
-- * Configuration
|
||||
|
@ -14,6 +14,7 @@ size requirements of each child node.
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Split (
|
||||
-- * Configuration
|
||||
|
@ -11,6 +11,8 @@ considers the different type of size requirements and assigns space according to
|
||||
the logic defined in 'SizeReq'. If the requested fixed space is larger that the
|
||||
viewport of the stack, the content will overflow.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Stack (
|
||||
-- * Configuration
|
||||
StackCfg,
|
||||
|
@ -13,6 +13,7 @@ other kind of style configuration, set it on the child node or wrap the
|
||||
themeSwitch widget in a "Monomer.Widgets.Containers.Box".
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Containers.ThemeSwitch (
|
||||
-- * Configuration
|
||||
|
@ -16,6 +16,7 @@ element, you may want to use a box.
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Containers.Tooltip (
|
||||
-- * Configuration
|
||||
|
@ -15,9 +15,9 @@ The order of the widgets is from bottom to top.
|
||||
The container will request the largest combination of horizontal and vertical
|
||||
size requested by its child nodes.
|
||||
-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Containers.ZStack (
|
||||
-- * Configuration
|
||||
|
@ -10,6 +10,7 @@ Helper for creating widgets without children elements.
|
||||
-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Single (
|
||||
-- * Re-exported modules
|
||||
|
@ -18,6 +18,7 @@ and "Monomer.Widgets.Singles.TimeField".
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Base.InputField (
|
||||
-- * Configuration
|
||||
@ -226,7 +227,7 @@ makeInputField
|
||||
=> InputFieldCfg s e a
|
||||
-> InputFieldState a
|
||||
-> Widget s e
|
||||
makeInputField config state = widget where
|
||||
makeInputField !config !state = widget where
|
||||
widget = createSingle state def {
|
||||
singleFocusOnBtnPressed = False,
|
||||
singleUseCustomCursor = True,
|
||||
@ -242,25 +243,25 @@ makeInputField config state = widget where
|
||||
}
|
||||
|
||||
-- Simpler access to state members
|
||||
currPlaceholder = _ifsPlaceholder state
|
||||
currVal = _ifsCurrValue state
|
||||
currText = _ifsCurrText state
|
||||
currGlyphs = _ifsGlyphs state
|
||||
currPos = _ifsCursorPos state
|
||||
currSel = _ifsSelStart state
|
||||
currOffset = _ifsOffset state
|
||||
currHistory = _ifsHistory state
|
||||
currHistIdx = _ifsHistIdx state
|
||||
!currPlaceholder = _ifsPlaceholder state
|
||||
!currVal = _ifsCurrValue state
|
||||
!currText = _ifsCurrText state
|
||||
!currGlyphs = _ifsGlyphs state
|
||||
!currPos = _ifsCursorPos state
|
||||
!currSel = _ifsSelStart state
|
||||
!currOffset = _ifsOffset state
|
||||
!currHistory = _ifsHistory state
|
||||
!currHistIdx = _ifsHistIdx state
|
||||
-- Text/value conversion functions
|
||||
caretW = fromMaybe defCaretW (_ifcCaretWidth config)
|
||||
caretMs = fromMaybe defCaretMs (_ifcCaretMs config)
|
||||
fromText = _ifcFromText config
|
||||
toText = _ifcToText config
|
||||
getModelValue wenv = widgetDataGet (_weModel wenv) (_ifcValue config)
|
||||
!caretW = fromMaybe defCaretW (_ifcCaretWidth config)
|
||||
!caretMs = fromMaybe defCaretMs (_ifcCaretMs config)
|
||||
!fromText = _ifcFromText config
|
||||
!toText = _ifcToText config
|
||||
getModelValue !wenv = widgetDataGet (_weModel wenv) (_ifcValue config)
|
||||
-- Mouse select handling options
|
||||
wheelHandler = _ifcWheelHandler config
|
||||
dragHandler = _ifcDragHandler config
|
||||
dragCursor = _ifcDragCursor config
|
||||
!wheelHandler = _ifcWheelHandler config
|
||||
!dragHandler = _ifcDragHandler config
|
||||
!dragCursor = _ifcDragCursor config
|
||||
|
||||
getBaseStyle wenv node = _ifcStyle config >>= handler where
|
||||
handler lstyle = Just $ collectTheme wenv (cloneLens lstyle)
|
||||
@ -504,8 +505,8 @@ makeInputField config state = widget where
|
||||
| isKeyboardUndo wenv evt -> moveHistory wenv node state config (-1)
|
||||
| isKeyboardRedo wenv evt -> moveHistory wenv node state config 1
|
||||
| otherwise -> fmap handleKeyRes keyRes <|> cursorRes where
|
||||
keyRes = handleKeyPress wenv mod code
|
||||
handleKeyRes (newText, newPos, newSel) = result where
|
||||
!keyRes = handleKeyPress wenv mod code
|
||||
handleKeyRes (!newText, !newPos, !newSel) = result where
|
||||
result = genInputResult wenv node False newText newPos newSel []
|
||||
cursorReq = changeCursorReq validCursor
|
||||
cursorRes
|
||||
@ -613,8 +614,8 @@ makeInputField config state = widget where
|
||||
newOffset = _ifsOffset tempState
|
||||
history = _ifsHistory tempState
|
||||
histIdx = _ifsHistIdx tempState
|
||||
newStep = HistoryStep stVal newText newPos newSel newOffset
|
||||
newState
|
||||
!newStep = HistoryStep stVal newText newPos newSel newOffset
|
||||
!newState
|
||||
| currText == newText = tempState
|
||||
| length history == histIdx = tempState {
|
||||
_ifsHistory = history |> newStep,
|
||||
@ -624,10 +625,10 @@ makeInputField config state = widget where
|
||||
_ifsHistory = Seq.take (histIdx - 1) history |> newStep,
|
||||
_ifsHistIdx = histIdx
|
||||
}
|
||||
newNode = node
|
||||
!newNode = node
|
||||
& L.widget .~ makeInputField config newState
|
||||
(reqs, events) = genReqsEvents node config state newText newReqs
|
||||
result
|
||||
!result
|
||||
| acceptInput || not textAdd = resultReqsEvts newNode reqs events
|
||||
| otherwise = resultReqsEvts node reqs events
|
||||
|
||||
@ -769,7 +770,7 @@ genReqsEvents
|
||||
-> Text
|
||||
-> [WidgetRequest s e]
|
||||
-> ([WidgetRequest s e], [e])
|
||||
genReqsEvents node config state newText newReqs = result where
|
||||
genReqsEvents node config !state !newText !newReqs = result where
|
||||
widgetId = node ^. L.info . L.widgetId
|
||||
resizeOnChange = _ifcResizeOnChange config
|
||||
fromText = _ifcFromText config
|
||||
@ -782,7 +783,7 @@ genReqsEvents node config state newText newReqs = result where
|
||||
stateVal = fromMaybe currVal newVal
|
||||
txtChanged = newText /= currText
|
||||
valChanged = stateVal /= currVal
|
||||
evtValid
|
||||
!evtValid
|
||||
| txtChanged = fmap ($ isValid) (_ifcValidV config)
|
||||
| otherwise = []
|
||||
reqValid = setModelValid config isValid
|
||||
@ -795,8 +796,8 @@ genReqsEvents node config state newText newReqs = result where
|
||||
reqOnChange
|
||||
| accepted && valChanged = fmap ($ stateVal) (_ifcOnChangeReq config)
|
||||
| otherwise = []
|
||||
reqs = newReqs ++ reqUpdateModel ++ reqValid ++ reqResize ++ reqOnChange
|
||||
result = (reqs, evtValid)
|
||||
!reqs = newReqs ++ reqUpdateModel ++ reqValid ++ reqResize ++ reqOnChange
|
||||
!result = (reqs, evtValid)
|
||||
|
||||
moveHistory
|
||||
:: (InputFieldValue a, WidgetEvent e)
|
||||
@ -824,7 +825,8 @@ moveHistory wenv node state config steps = result where
|
||||
newState = tempState {
|
||||
_ifsHistIdx = clamp 0 lenHistory reqHistIdx
|
||||
}
|
||||
newNode = node & L.widget .~ makeInputField config newState
|
||||
!newNode = node
|
||||
& L.widget .~ makeInputField config newState
|
||||
|
||||
newStateFromHistory
|
||||
:: WidgetEnv s e
|
||||
@ -835,7 +837,7 @@ newStateFromHistory
|
||||
-> InputFieldState a
|
||||
newStateFromHistory wenv node oldState config inputHist = newState where
|
||||
HistoryStep hValue hText hPos hSel hOffset = inputHist
|
||||
tempState = oldState { _ifsOffset = hOffset }
|
||||
!tempState = oldState { _ifsOffset = hOffset }
|
||||
newState = newTextState wenv node oldState config hValue hText hPos hSel
|
||||
|
||||
newTextState
|
||||
@ -888,8 +890,8 @@ newTextState wenv node oldState config value text cursor sel = newState where
|
||||
| Just cursor == sel = Nothing
|
||||
| isJust sel && (justSel < 0 || justSel > T.length text) = Nothing
|
||||
| otherwise = sel
|
||||
tmpState = updatePlaceholder wenv node oldState config
|
||||
newState = tmpState {
|
||||
!tmpState = updatePlaceholder wenv node oldState config
|
||||
!newState = tmpState {
|
||||
_ifsCurrValue = value,
|
||||
_ifsCurrText = text,
|
||||
_ifsCursorPos = cursor,
|
||||
@ -906,7 +908,7 @@ updatePlaceholder
|
||||
-> InputFieldState a
|
||||
-> InputFieldCfg s e a
|
||||
-> InputFieldState a
|
||||
updatePlaceholder wenv node state config = newState where
|
||||
updatePlaceholder wenv node !state !config = newState where
|
||||
fontMgr = wenv ^. L.fontManager
|
||||
style = currentStyle wenv node
|
||||
Rect cx cy cw ch = getContentArea node style
|
||||
|
@ -9,9 +9,11 @@ Portability : non-portable
|
||||
Button widget, with support for multiline text. At the most basic level, a
|
||||
button consists of a caption and an event to raise when clicked.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Button (
|
||||
-- * Configuration
|
||||
@ -181,11 +183,11 @@ button_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e
|
||||
button_ caption handler configs = buttonNode where
|
||||
config = onClick handler <> mconcat configs
|
||||
widget = makeButton caption config
|
||||
buttonNode = defaultWidgetNode "button" widget
|
||||
!buttonNode = defaultWidgetNode "button" widget
|
||||
& L.info . L.focusable .~ True
|
||||
|
||||
makeButton :: WidgetEvent e => Text -> ButtonCfg s e -> Widget s e
|
||||
makeButton caption config = widget where
|
||||
makeButton !caption !config = widget where
|
||||
widget = createContainer () def {
|
||||
containerAddStyleReq = False,
|
||||
containerUseScissor = True,
|
||||
@ -198,7 +200,7 @@ makeButton caption config = widget where
|
||||
containerResize = resize
|
||||
}
|
||||
|
||||
buttonType = fromMaybe ButtonNormal (_btnButtonType config)
|
||||
!buttonType = fromMaybe ButtonNormal (_btnButtonType config)
|
||||
|
||||
getBaseStyle wenv node
|
||||
| ignoreTheme = Nothing
|
||||
@ -220,9 +222,9 @@ makeButton caption config = widget where
|
||||
nodeStyle = node ^. L.info . L.style
|
||||
labelCfg = _btnLabelCfg config
|
||||
labelCurrStyle = labelCurrentStyle childOfFocusedStyle
|
||||
labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
|
||||
!labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
|
||||
& L.info . L.style .~ nodeStyle
|
||||
newNode = node
|
||||
!newNode = node
|
||||
& L.children .~ Seq.singleton labelNode
|
||||
|
||||
init wenv node = result where
|
||||
|
@ -11,8 +11,10 @@ text, which can be added with a label in the desired position (usually with
|
||||
hstack). Alternatively, "Monomer.Widgets.Singles.LabeledCheckbox" provides this
|
||||
functionality out of the box.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Checkbox (
|
||||
-- * Configuration
|
||||
@ -169,7 +171,7 @@ checkboxD_ widgetData configs = checkboxNode where
|
||||
|
||||
makeCheckbox
|
||||
:: WidgetEvent e => WidgetData s Bool -> CheckboxCfg s e -> Widget s e
|
||||
makeCheckbox widgetData config = widget where
|
||||
makeCheckbox !widgetData !config = widget where
|
||||
widget = createSingle () def {
|
||||
singleGetBaseStyle = getBaseStyle,
|
||||
singleHandleEvent = handleEvent,
|
||||
|
@ -11,6 +11,7 @@ Color picker using sliders and numeric fields.
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Monomer.Widgets.Singles.ColorPicker (
|
||||
|
@ -11,12 +11,14 @@ value by keyboard arrows, dragging the mouse or using the wheel.
|
||||
|
||||
Similar in objective to "Monomer.Widgets.Singles.Slider", but uses less space.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Dial (
|
||||
-- * Configuration
|
||||
@ -222,7 +224,7 @@ makeDial
|
||||
-> DialCfg s e a
|
||||
-> DialState
|
||||
-> Widget s e
|
||||
makeDial field minVal maxVal config state = widget where
|
||||
makeDial !field !minVal !maxVal !config !state = widget where
|
||||
widget = createSingle state def {
|
||||
singleFocusOnBtnPressed = False,
|
||||
singleGetBaseStyle = getBaseStyle,
|
||||
@ -285,12 +287,12 @@ makeDial field minVal maxVal config state = widget where
|
||||
fastSpeed = max 1 $ round (fromIntegral maxPos / 100)
|
||||
warpSpeed = max 1 $ round (fromIntegral maxPos / 10)
|
||||
vPos pos = clamp 0 maxPos pos
|
||||
newResult newPos = addReqsEvts (resultNode newNode) newVal where
|
||||
newResult !newPos = addReqsEvts (resultNode newNode) newVal where
|
||||
newVal = valueFromPos minVal dragRate newPos
|
||||
newState = state { _dlsPos = newPos }
|
||||
newNode = node
|
||||
!newState = state { _dlsPos = newPos }
|
||||
!newNode = node
|
||||
& L.widget .~ makeDial field minVal maxVal config newState
|
||||
handleNewPos newPos
|
||||
handleNewPos !newPos
|
||||
| vPos newPos /= pos = Just $ newResult (vPos newPos)
|
||||
| otherwise = Nothing
|
||||
|
||||
@ -383,7 +385,7 @@ posFromPoint minVal maxVal state dragRate stPoint point = (newPos, newVal) where
|
||||
newVal = valueFromPos minVal dragRate newPos
|
||||
|
||||
valueFromPos :: DialValue a => a -> Rational -> Integer -> a
|
||||
valueFromPos minVal dragRate newPos = newVal where
|
||||
valueFromPos !minVal !dragRate !newPos = newVal where
|
||||
newVal = minVal + fromFractional (dragRate * fromIntegral newPos)
|
||||
|
||||
getDialInfo :: WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
|
||||
@ -395,8 +397,8 @@ getDialInfo wenv node config = (dialCenter, dialArea) where
|
||||
dialW = fromMaybe (theme ^. L.dialWidth) (_dlcWidth config)
|
||||
dialL = _rX carea + (_rW carea - dialW) / 2
|
||||
dialT = _rY carea + (_rH carea - dialW) / 2
|
||||
dialCenter = Point (dialL + dialW / 2) (dialT + dialW / 2)
|
||||
dialArea = Rect dialL dialT dialW dialW
|
||||
!dialCenter = Point (dialL + dialW / 2) (dialT + dialW / 2)
|
||||
!dialArea = Rect dialL dialT dialW dialW
|
||||
|
||||
currentStyleConfig :: Rect -> CurrentStyleCfg s e
|
||||
currentStyleConfig dialArea = def
|
||||
|
@ -9,9 +9,11 @@ Portability : non-portable
|
||||
Provides a clickable link that opens in the system's browser. It uses OS
|
||||
services to open the URI, which means not only URLs can be opened.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.ExternalLink (
|
||||
-- * Configuration
|
||||
@ -145,7 +147,7 @@ externalLink_ caption url configs = externalLinkNode where
|
||||
|
||||
makeExternalLink
|
||||
:: WidgetEvent e => Text -> Text -> ExternalLinkCfg s e -> Widget s e
|
||||
makeExternalLink caption url config = widget where
|
||||
makeExternalLink !caption !url !config = widget where
|
||||
widget = createContainer () def {
|
||||
containerAddStyleReq = False,
|
||||
containerUseScissor = True,
|
||||
@ -164,11 +166,10 @@ makeExternalLink caption url config = widget where
|
||||
nodeStyle = node ^. L.info . L.style
|
||||
labelCfg = _elcLabelCfg config
|
||||
labelCurrStyle = labelCurrentStyle childOfFocusedStyle
|
||||
labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
|
||||
!labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
|
||||
& L.info . L.style .~ nodeStyle
|
||||
childNode = labelNode
|
||||
newNode = node
|
||||
& L.children .~ Seq.singleton childNode
|
||||
!newNode = node
|
||||
& L.children .~ Seq.singleton labelNode
|
||||
|
||||
init wenv node = result where
|
||||
result = resultNode (createChildNode wenv node)
|
||||
|
@ -15,10 +15,12 @@ Notes:
|
||||
- If you choose 'fitNone', adding 'imageRepeatX' and 'imageRepeatY' won't have
|
||||
any kind of effect.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Image (
|
||||
-- * Configuration
|
||||
@ -277,7 +279,7 @@ imageMem_ name imgData imgSize configs = defaultWidgetNode "image" widget where
|
||||
|
||||
makeImage
|
||||
:: WidgetEvent e => ImageSource -> ImageCfg e -> ImageState -> Widget s e
|
||||
makeImage imgSource config state = widget where
|
||||
makeImage !imgSource !config !state = widget where
|
||||
widget = createSingle state def {
|
||||
singleUseScissor = True,
|
||||
singleInit = init,
|
||||
@ -288,11 +290,11 @@ makeImage imgSource config state = widget where
|
||||
singleRender = render
|
||||
}
|
||||
|
||||
isImageMem = case imgSource of
|
||||
!isImageMem = case imgSource of
|
||||
ImageMem{} -> True
|
||||
_ -> False
|
||||
|
||||
imgName source = case source of
|
||||
imgName !source = case source of
|
||||
ImageMem path -> path
|
||||
ImagePath path -> path
|
||||
|
||||
|
@ -9,6 +9,7 @@ Portability : non-portable
|
||||
Label widget, with support for multiline text.
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Label (
|
||||
-- * Configuration
|
||||
|
@ -11,6 +11,7 @@ clickable label.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Singles.LabeledCheckbox (
|
||||
-- * Configuration
|
||||
|
@ -12,6 +12,7 @@ value.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Singles.LabeledRadio (
|
||||
-- * Configuration
|
||||
|
@ -12,8 +12,10 @@ which should be added as a label in the desired position (usually with hstack).
|
||||
Alternatively, 'Monomer.Widgets.Singles.LabeledRadio' provides this
|
||||
functionality out of the box.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Radio (
|
||||
-- * Configuration
|
||||
@ -154,7 +156,7 @@ radioD_ option widgetData configs = radioNode where
|
||||
& L.info . L.focusable .~ True
|
||||
|
||||
makeRadio :: (Eq a, WidgetEvent e) => WidgetData s a -> a -> RadioCfg s e a -> Widget s e
|
||||
makeRadio field option config = widget where
|
||||
makeRadio !field !option !config = widget where
|
||||
widget = createSingle () def {
|
||||
singleGetBaseStyle = getBaseStyle,
|
||||
singleGetCurrentStyle = getCurrentStyle,
|
||||
|
@ -14,7 +14,9 @@ The line has the provided width in the direction orthogonal to the layout
|
||||
direction, and takes all the available space in the other direction. In case of
|
||||
wanting a shorter line, padding should be used.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.SeparatorLine (
|
||||
-- * Configuration
|
||||
@ -81,15 +83,13 @@ separatorLine_ configs = defaultWidgetNode "separatorLine" widget where
|
||||
widget = makeSeparatorLine config
|
||||
|
||||
makeSeparatorLine :: SeparatorLineCfg -> Widget s e
|
||||
makeSeparatorLine config = widget where
|
||||
makeSeparatorLine !config = widget where
|
||||
widget = createSingle () def {
|
||||
singleGetBaseStyle = getBaseStyle,
|
||||
singleGetSizeReq = getSizeReq,
|
||||
singleRender = render
|
||||
}
|
||||
|
||||
factor = fromMaybe 0 (_slcFactor config)
|
||||
|
||||
getBaseStyle wenv node = Just style where
|
||||
style = collectTheme wenv L.separatorLineStyle
|
||||
|
||||
@ -97,6 +97,7 @@ makeSeparatorLine config = widget where
|
||||
theme = currentTheme wenv node
|
||||
direction = wenv ^. L.layoutDirection
|
||||
width = fromMaybe (theme ^. L.separatorLineWidth) (_slcWidth config)
|
||||
factor = fromMaybe 0 (_slcFactor config)
|
||||
|
||||
isFixed = factor < 0.01
|
||||
flexSide = flexSize 10 0.5
|
||||
|
@ -12,12 +12,14 @@ value by keyboard arrows, dragging the mouse or using the wheel.
|
||||
Similar in objective to 'Monomer.Widgets.Singles.Dial', but more convenient in
|
||||
some layouts.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.Slider (
|
||||
-- * Configuration
|
||||
@ -317,7 +319,7 @@ makeSlider
|
||||
-> SliderCfg s e a
|
||||
-> SliderState
|
||||
-> Widget s e
|
||||
makeSlider isHz field minVal maxVal config state = widget where
|
||||
makeSlider !isHz !field !minVal !maxVal !config !state = widget where
|
||||
widget = createSingle state def {
|
||||
singleFocusOnBtnPressed = False,
|
||||
singleGetBaseStyle = getBaseStyle,
|
||||
@ -373,7 +375,7 @@ makeSlider isHz field minVal maxVal config state = widget where
|
||||
fastSpeed = max 1 $ round (fromIntegral maxPos / 100)
|
||||
warpSpeed = max 1 $ round (fromIntegral maxPos / 10)
|
||||
|
||||
handleNewPos newPos
|
||||
handleNewPos !newPos
|
||||
| validPos /= pos = resultFromPos validPos []
|
||||
| otherwise = Nothing
|
||||
where
|
||||
@ -403,22 +405,22 @@ makeSlider isHz field minVal maxVal config state = widget where
|
||||
shiftPressed = wenv ^. L.inputStatus . L.keyMod . L.leftShift
|
||||
SliderState maxPos pos = state
|
||||
|
||||
resultFromPoint point reqs = resultFromPos newPos reqs where
|
||||
newPos = posFromMouse isHz vp point
|
||||
resultFromPoint !point !reqs = resultFromPos newPos reqs where
|
||||
!newPos = posFromMouse isHz vp point
|
||||
|
||||
resultFromPos newPos extraReqs = Just newResult where
|
||||
newState = state {
|
||||
resultFromPos !newPos !extraReqs = Just newResult where
|
||||
!newState = state {
|
||||
_slsPos = newPos
|
||||
}
|
||||
newNode = node
|
||||
!newNode = node
|
||||
& L.widget .~ makeSlider isHz field minVal maxVal config newState
|
||||
result = resultReqs newNode [RenderOnce]
|
||||
newVal = valueFromPos newPos
|
||||
!result = resultReqs newNode [RenderOnce]
|
||||
!newVal = valueFromPos newPos
|
||||
|
||||
reqs = widgetDataSet field newVal
|
||||
!reqs = widgetDataSet field newVal
|
||||
++ fmap ($ newVal) (_slcOnChangeReq config)
|
||||
++ extraReqs
|
||||
newResult
|
||||
!newResult
|
||||
| pos /= newPos = result
|
||||
& L.requests <>~ Seq.fromList reqs
|
||||
| otherwise = result
|
||||
|
@ -8,11 +8,13 @@ Portability : non-portable
|
||||
|
||||
Input field for multiline 'Text'.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Monomer.Widgets.Singles.TextArea (
|
||||
-- * Configuration
|
||||
@ -239,7 +241,7 @@ makeTextArea
|
||||
-> TextAreaCfg s e
|
||||
-> TextAreaState
|
||||
-> Widget s e
|
||||
makeTextArea wdata config state = widget where
|
||||
makeTextArea !wdata !config !state = widget where
|
||||
widget = createSingle state def {
|
||||
singleInit = init,
|
||||
singleMerge = merge,
|
||||
@ -249,25 +251,25 @@ makeTextArea wdata config state = widget where
|
||||
singleRender = render
|
||||
}
|
||||
|
||||
caretMs = fromMaybe defCaretMs (_tacCaretMs config)
|
||||
maxLength = _tacMaxLength config
|
||||
maxLines = _tacMaxLines config
|
||||
getModelValue wenv = widgetDataGet (_weModel wenv) wdata
|
||||
!caretMs = fromMaybe defCaretMs (_tacCaretMs config)
|
||||
!maxLength = _tacMaxLength config
|
||||
!maxLines = _tacMaxLines config
|
||||
getModelValue !wenv = widgetDataGet (_weModel wenv) wdata
|
||||
-- State
|
||||
currText = _tasText state
|
||||
textLines = _tasTextLines state
|
||||
!currText = _tasText state
|
||||
!textLines = _tasTextLines state
|
||||
-- Helpers
|
||||
validText state = validLen && validLines where
|
||||
validText !state = validLen && validLines where
|
||||
text = _tasText state
|
||||
lines = _tasTextLines state
|
||||
validLen = T.length text <= fromMaybe maxBound maxLength
|
||||
validLines = length lines <= fromMaybe maxBound maxLines
|
||||
line idx
|
||||
line !idx
|
||||
| idx >= 0 && idx < length textLines = Seq.index textLines idx ^. L.text
|
||||
| otherwise = ""
|
||||
lineLen = T.length . line
|
||||
totalLines = length textLines
|
||||
lastPos = (lineLen (totalLines - 1), totalLines)
|
||||
!lineLen = T.length . line
|
||||
!totalLines = length textLines
|
||||
!lastPos = (lineLen (totalLines - 1), totalLines)
|
||||
|
||||
init wenv node = resultNode newNode where
|
||||
text = getModelValue wenv
|
||||
|
@ -11,6 +11,7 @@ Both header and list content is text based. In case a customizable version is
|
||||
is needed, 'Monomer.Widgets.Containers.Dropdown' can be used.
|
||||
-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Singles.TextDropdown (
|
||||
-- * Configuratiom
|
||||
|
@ -12,6 +12,7 @@ Input field for single line 'Text'.
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Singles.TextField (
|
||||
-- * Configuration
|
||||
|
@ -10,6 +10,7 @@ Utility drawing functions. Built on top the lower level primitives provided by
|
||||
"Monomer.Graphics.Types.Renderer".
|
||||
-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Drawing (
|
||||
drawInScissor,
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Helper functions for focus handling.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Focus (
|
||||
isNodeFocused,
|
||||
isNodeInfoFocused,
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Helper functions for hover related actions.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Hover (
|
||||
isPointInNodeVp,
|
||||
isPointInNodeEllipse,
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Utility functions for widget keyboard handling.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Keyboard (
|
||||
isShortCutControl,
|
||||
isKeyboardCopy,
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Very basic parsing helpers used by numeric input fields.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Parser where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
|
@ -10,6 +10,7 @@ Helper functions for style related operations.
|
||||
-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Style (
|
||||
collectStyleField,
|
||||
|
@ -8,7 +8,7 @@ Portability : non-portable
|
||||
|
||||
Helper functions to text related operations in widgets.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Text (
|
||||
getTextMetrics,
|
||||
@ -32,13 +32,13 @@ import qualified Monomer.Core.Lens as L
|
||||
getTextMetrics :: WidgetEnv s e -> StyleState -> TextMetrics
|
||||
getTextMetrics wenv style = textMetrics where
|
||||
fontMgr = wenv ^. L.fontManager
|
||||
!textMetrics = computeTextMetrics fontMgr font fontSize
|
||||
textMetrics = computeTextMetrics fontMgr font fontSize
|
||||
font = styleFont style
|
||||
fontSize = styleFontSize style
|
||||
|
||||
-- | Returns the size of the text using the active style and default options.
|
||||
getTextSize :: WidgetEnv s e -> StyleState -> Text -> Size
|
||||
getTextSize wenv style !text = size where
|
||||
getTextSize wenv style text = size where
|
||||
fontMgr = wenv ^. L.fontManager
|
||||
size = calcTextSize_ fontMgr style SingleLine KeepSpaces Nothing Nothing text
|
||||
|
||||
@ -65,7 +65,7 @@ getSingleTextLineRect
|
||||
-> AlignTV -- ^ The vertical alignment.
|
||||
-> Text -- ^ The text to measure.
|
||||
-> Rect -- ^ The used rect. May be larger than the bounding rect.
|
||||
getSingleTextLineRect wenv style !rect !alignH !alignV !text = textRect where
|
||||
getSingleTextLineRect wenv style rect alignH alignV text = textRect where
|
||||
fontMgr = wenv ^. L.fontManager
|
||||
font = styleFont style
|
||||
fSize = styleFontSize style
|
||||
@ -93,9 +93,9 @@ getSingleTextLineRect wenv style !rect !alignH !alignV !text = textRect where
|
||||
|
||||
-- | Returns the glyphs of a single line of text.
|
||||
getTextGlyphs :: WidgetEnv s e -> StyleState -> Text -> Seq GlyphPos
|
||||
getTextGlyphs wenv style !text = glyphs where
|
||||
getTextGlyphs wenv style text = glyphs where
|
||||
fontMgr = wenv ^. L.fontManager
|
||||
font = styleFont style
|
||||
fSize = styleFontSize style
|
||||
fSpcH = styleFontSpaceH style
|
||||
!glyphs = computeGlyphsPos fontMgr font fSize fSpcH text
|
||||
glyphs = computeGlyphsPos fontMgr font fSize fSpcH text
|
||||
|
@ -9,6 +9,7 @@ Portability : non-portable
|
||||
Helper functions for loading theme values.
|
||||
-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Theme where
|
||||
|
||||
|
@ -8,6 +8,8 @@ Portability : non-portable
|
||||
|
||||
Common types for widget related functions.
|
||||
-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Types (
|
||||
IsHovered,
|
||||
IsFocused,
|
||||
|
@ -10,6 +10,7 @@ Helper functions for widget lifecycle.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
module Monomer.Widgets.Util.Widget (
|
||||
defaultWidgetNode,
|
||||
|
@ -33,7 +33,6 @@ import Monomer.Graphics
|
||||
import Monomer.Main.Handlers
|
||||
import Monomer.Main.Types
|
||||
import Monomer.Main.Util
|
||||
import Monomer.Widgets.Util.Widget
|
||||
|
||||
import qualified Monomer.Lens as L
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user