diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,64 @@ +## 1.4.0.0 + +### Breaking changes + +- Added `style...Set` family of functions ([PR #104](https://github.com/fjvallarino/monomer/pull/104)). +- `Composite`'s `onChange` event is now sent to its `handleEvent` function, not to its parent; the type of the + generated event was updated to reflect this change. The rationale is that since `onInit` is sent to + `handleEvent`, having `onChange` sent to its parent was confusing. At the same time there was not an easy way + in `handleEvent` to know when the model changed. Widgets that want to report model changes to its parent can + use `Report`/`RequestParent`; an example can be found in `ColorPicker` ([PR #71](https://github.com/fjvallarino/monomer/pull/71)). +- `Timestamp` is now a newtype. Enforce use of this type instead of `Int` when appropriate ([PR #103](https://github.com/fjvallarino/monomer/pull/103)). +- `Timestamp` was renamed to `Millisecond`. The rationale is that since both timestamps and durations are used frequently in calculations (and in the context of Monomer timestamps and durations indeed represent time in milliseconds), having separate types for Timestamp and Duration caused more harm than good ([PR #107](https://github.com/fjvallarino/monomer/pull/107)). +- `compositeMergeModel` (previously `customModelBuilder`) now receives `WidgetEnv` as its first parameter ([PR #114](https://github.com/fjvallarino/monomer/pull/114)). +- `compositeMergeReqs` now receives `parentModel` and `oldModel` too ([PR #114](https://github.com/fjvallarino/monomer/pull/114)). +- `mergeRequired` now receives an extra value as its first parameter, usually `WidgetEnv` ([PR #122](https://github.com/fjvallarino/monomer/pull/122)). + +### Fixed + +- Properly handle `SetFocusOnKey` for `textArea` ([#80](https://github.com/fjvallarino/monomer/issues/80)). +- Lens tutorial sample code ([PR #95](https://github.com/fjvallarino/monomer/pull/95) and [PR #98](https://github.com/fjvallarino/monomer/pull/98)). Thanks @Clindbergh! +- ColorPicker's numericFields vertical alignment ([PR #108](https://github.com/fjvallarino/monomer/pull/108)). +- Differences in glyphs positions used by `FontManager` and nanovg; temporary workaround ([PR #105](https://github.com/fjvallarino/monomer/pull/105)). +- `nodeInfoFromKey` relies on `nodeInfoFromPath` to retrieve information instead of fetching it directly from `WidgetEnv`'s `widgetKeyMap`, which can be stale ([PR #110](https://github.com/fjvallarino/monomer/pull/110)). +- Glyph positioning issues in `FontManager`; removed workaround added in #105 ([PR #125](https://github.com/fjvallarino/monomer/pull/125)). +- Will attempt to fall back to rendering on the main thread if threaded rendering setup fails ([PR #131](https://github.com/fjvallarino/monomer/pull/131)). +- Space leak in StyleUtil's mergeNodeStyleState ([PR #132](https://github.com/fjvallarino/monomer/pull/132)). + +### Added + +- Utility functions `rectFromPoints`, `nodeInfoFromKey`, `nodeInfoFromPath` and `findParentNodeInfoByType`. +- Allow setting the window icon via AppConfig ([PR #79](https://github.com/fjvallarino/monomer/pull/79)). Thanks @Dretch! +- Support for breaking text lines at character boundaries ([PR #86](https://github.com/fjvallarino/monomer/pull/86)). Thanks @toku-sa-n! +- Read-only mode for `textField`, `numericField`, `dateField`, `timeField` and `textArea` ([PR #93](https://github.com/fjvallarino/monomer/pull/93)). Thanks @Dretch! +- The `scroll` widget now supports a `thumbMinSize` configuration option that allows setting a minimum thumb size ([PR #100](https://github.com/fjvallarino/monomer/pull/100)). +- New field `_weAppStartTs` in `WidgetEnv`, complementary to `_weTimestamp`, representing the time in milliseconds when the application started. Added utility function `currentTimeMs` that returns their sum with a polymorphic type ([PR #103](https://github.com/fjvallarino/monomer/pull/103)). +- Several sizeReq helpers ([PR #106](https://github.com/fjvallarino/monomer/pull/106)). +- `compositeMergeEvents`, for completeness ([PR #114](https://github.com/fjvallarino/monomer/pull/114)). +- Support for symbols and other keys in `keystroke` ([PR #117](https://github.com/fjvallarino/monomer/pull/117)). +- New constructor (`buttonD_`) and `ignoreParentEvts` configuration option to `button` ([PR #123](https://github.com/fjvallarino/monomer/pull/123)). +- Allow disabling auto scale detection with `appDisableAutoScale` ([PR #128](https://github.com/fjvallarino/monomer/pull/128)). + +### Changed + +- The `keystroke` widget now supports the `Backspace` key ([PR #74](https://github.com/fjvallarino/monomer/pull/74)). +- `style...` family of functions now combine new attributes with the existing ones ([PR #104](https://github.com/fjvallarino/monomer/pull/104)). +- `radio` and `optionButton` now only trigger `onChange` when their value changes. `onClick` was can be used to replicate the previous `onChange` behavior ([PR #134](https://github.com/fjvallarino/monomer/pull/134)). + +### Renamed + +- Utility functions for retrieving `WidgetNode` information ([PR #75](https://github.com/fjvallarino/monomer/pull/75)) + - `findWidgetByPath` -> `findChildNodeInfoByPath`. + - `findWidgetBranchByPath` -> `findChildBranchByPath`. + - `findWidgetIdFromPath` -> `widgetIdFromPath`. +- Composite merge related ([PR #114](https://github.com/fjvallarino/monomer/pull/114)) + - `customModelBuilder` -> `compositeMergeModel` + - `CompositeCustomModelBuilder` -> `MergeModelHandler`. + +### Removed + +- Dependencies on `OpenGL`, `Safe`, `scientific`, `unordered-containers`, `directory`, `HUnit` and `silently` ([PR #70](https://github.com/fjvallarino/monomer/pull/70)). + ## 1.3.0.0 ### Added diff --git a/cbits/fontmanager.c b/cbits/fontmanager.c --- a/cbits/fontmanager.c +++ b/cbits/fontmanager.c @@ -37,6 +37,7 @@ // Initialize font manager context ctx->fs = fonsCreateInternal(&fontParams); ctx->dpr = dpr; + ctx->scale = 1; ctx->fontSize = 16.0f; ctx->letterSpacing = 0.0f; ctx->lineHeight = 1.0f; @@ -52,6 +53,10 @@ return fonsAddFont(ctx->fs, name, filename, 0); } +void fmSetScale(FMcontext* ctx, float scale) { + ctx->scale = scale; +} + void fmFontFace(FMcontext* ctx, const char* font) { ctx->fontId = fonsGetFontByName(ctx->fs, font); @@ -79,7 +84,7 @@ void fmTextMetrics(FMcontext* ctx, float* ascender, float* descender, float* lineh) { - float scale = ctx->dpr; + float scale = ctx->dpr * ctx->scale; float invscale = 1.0f / scale; if (ctx->fontId == FONS_INVALID) return; @@ -101,7 +106,7 @@ float fmTextBounds(FMcontext* ctx, float x, float y, const char* string, const char* end, float* bounds) { - float scale = ctx->dpr; + float scale = ctx->dpr * ctx->scale; float invscale = 1.0f / scale; float width; @@ -127,7 +132,7 @@ int fmTextGlyphPositions(FMcontext* ctx, float x, float y, const char* string, const char* end, FMGglyphPosition* positions, int maxPositions) { - float scale = ctx->dpr; + float scale = ctx->dpr * ctx->scale; float invscale = 1.0f / scale; FONStextIter iter, prevIter; FONSquad q; diff --git a/cbits/fontmanager.h b/cbits/fontmanager.h --- a/cbits/fontmanager.h +++ b/cbits/fontmanager.h @@ -15,6 +15,7 @@ struct FMcontext { struct FONScontext* fs; float dpr; + float scale; float fontSize; float letterSpacing; float lineHeight; @@ -37,6 +38,8 @@ FMcontext* fmInit(float dpr); int fmCreateFont(FMcontext* ctx, const char* name, const char* filename); + +void fmSetScale(FMcontext* ctx, float scale); void fmFontFace(FMcontext* ctx, const char* font); diff --git a/examples/books/Main.hs b/examples/books/Main.hs --- a/examples/books/Main.hs +++ b/examples/books/Main.hs @@ -119,7 +119,7 @@ countLabel = label caption `styleBasic` [padding 10] where caption = "Books (" <> showt (length $ model ^. books) <> ")" - booksChanged old new = old ^. books /= new ^. books + booksChanged wenv old new = old ^. books /= new ^. books widgetTree = zstack [ vstack [ @@ -190,6 +190,7 @@ where config = [ appWindowTitle "Book search", + appWindowIcon "./assets/images/icon.bmp", appTheme customDarkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf", diff --git a/examples/generative/Main.hs b/examples/generative/Main.hs --- a/examples/generative/Main.hs +++ b/examples/generative/Main.hs @@ -112,6 +112,7 @@ model = GenerativeModel CirclesGrid False def def config = [ appWindowTitle "Generative", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Remix" "./assets/fonts/remixicon.ttf", appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", diff --git a/examples/opengl/Main.hs b/examples/opengl/Main.hs --- a/examples/opengl/Main.hs +++ b/examples/opengl/Main.hs @@ -94,6 +94,7 @@ where config = [ appWindowTitle "OpenGL", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appInitEvent AppInit diff --git a/examples/ticker/BinanceTypes.hs b/examples/ticker/BinanceTypes.hs --- a/examples/ticker/BinanceTypes.hs +++ b/examples/ticker/BinanceTypes.hs @@ -22,12 +22,14 @@ import Control.Lens.TH import Data.Aeson import Data.Default +import Data.Fixed import Data.Foldable (asum) import Data.Maybe import Data.Map (Map) -import Data.Scientific import Data.Text (Text, pack) +type FixedFloat = Pico + data ServerRequest = ServerRequest { _srqRequestId :: Int, _srqMethod :: Text, @@ -68,12 +70,12 @@ data Ticker = Ticker { _tckSymbolPair :: Text, _tckTs :: Int, - _tckOpen :: Scientific, - _tckClose :: Scientific, - _tckHigh :: Scientific, - _tckLow :: Scientific, - _tckVolume :: Scientific, - _tckTrades :: Scientific + _tckOpen :: FixedFloat, + _tckClose :: FixedFloat, + _tckHigh :: FixedFloat, + _tckLow :: FixedFloat, + _tckVolume :: FixedFloat, + _tckTrades :: FixedFloat } deriving (Eq, Show) instance FromJSON Ticker where diff --git a/examples/ticker/Main.hs b/examples/ticker/Main.hs --- a/examples/ticker/Main.hs +++ b/examples/ticker/Main.hs @@ -25,9 +25,9 @@ import Data.Default import Data.Foldable (foldl') import Data.Maybe -import Data.Scientific import Data.Text (Text) +import qualified Formatting as F import qualified Data.Map as M import qualified Data.Text as T import qualified Network.Wreq as W @@ -46,10 +46,10 @@ tickerPct :: Ticker -> TickerNode tickerPct t = pctLabel where - diff = toRealFloat $ 100 * (t ^. close - t ^. open) - pct = diff / toRealFloat (t ^. open) + diff = 100 * (t ^. close - t ^. open) + pct = diff / t ^. open - pctText = formatTickerPct (fromFloatDigits pct) <> "%" + pctText = formatTickerPct pct <> "%" pctColor | abs pct < 0.01 = rgbHex "#428FE0" | pct > 0 = rgbHex "#51A39A" @@ -170,7 +170,7 @@ handleSubscription :: AppEnv -> [Text] -> Text -> IO TickerEvt handleSubscription env pairs action = do - liftIO . atomically $ writeTChan (env^.channel) req + atomically $ writeTChan (env ^. channel) req return TickerIgnore where subscription pair = T.toLower pair <> "@miniTicker" @@ -213,8 +213,8 @@ groupTickers :: TChan Ticker -> (TickerEvt -> IO a) -> IO () groupTickers channel sendMsg = void . forkIO . forever $ do - ticker <- liftIO . atomically $ readTChan channel - tickers <- collectJustM . liftIO . atomically $ tryReadTChan channel + ticker <- atomically $ readTChan channel + tickers <- collectJustM . atomically $ tryReadTChan channel sendMsg $ TickerUpdate (ticker : tickers) threadDelay $ 500 * 1000 @@ -227,11 +227,11 @@ forM_ serverMsg $ \case MsgResponse resp -> sendMsg $ TickerResponse resp MsgError err -> sendMsg $ TickerError err - MsgTicker ticker -> liftIO . atomically $ writeTChan groupChannel ticker + MsgTicker ticker -> atomically $ writeTChan groupChannel ticker sendWs :: (Show a, ToJSON a) => TChan a -> WS.Connection -> IO () sendWs channel connection = forever $ do - msg <- liftIO . atomically $ readTChan channel + msg <- atomically $ readTChan channel WS.sendTextData connection (encode msg) main :: IO () @@ -243,6 +243,7 @@ where config = [ appWindowTitle "Ticker", + appWindowIcon "./assets/images/icon.bmp", appTheme customDarkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appFontDef "Remix" "./assets/fonts/remixicon.ttf", @@ -271,11 +272,11 @@ xs <- collectJustM action return (x : xs) -formatTickerValue :: Scientific -> Text -formatTickerValue = T.pack . formatScientific Fixed (Just 8) +formatTickerValue :: FixedFloat -> Text +formatTickerValue = F.sformat (F.fixed 8) -formatTickerPct :: Scientific -> Text -formatTickerPct = T.pack . formatScientific Fixed (Just 2) +formatTickerPct :: FixedFloat -> Text +formatTickerPct = F.sformat (F.fixed 2) initialList :: [Text] initialList = ["BTCUSDT", "ETHBTC", "BNBBTC", "ADABTC", "DOTBTC", "XRPBTC", diff --git a/examples/todo/Main.hs b/examples/todo/Main.hs --- a/examples/todo/Main.hs +++ b/examples/todo/Main.hs @@ -221,7 +221,7 @@ addNewTodo :: WidgetEnv s e -> TodoModel -> TodoModel addNewTodo wenv model = newModel where newTodo = model ^. activeTodo - & todoId .~ wenv ^. L.timestamp + & todoId .~ currentTimeMs wenv newModel = model & todos .~ (newTodo : model ^. todos) @@ -245,6 +245,7 @@ where config = [ appWindowTitle "Todo list", + appWindowIcon "./assets/images/icon.bmp", appTheme customDarkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf", diff --git a/examples/todo/TodoTypes.hs b/examples/todo/TodoTypes.hs --- a/examples/todo/TodoTypes.hs +++ b/examples/todo/TodoTypes.hs @@ -31,7 +31,7 @@ deriving (Eq, Show, Enum) data Todo = Todo { - _todoId :: Int, + _todoId :: Millisecond, _todoType :: TodoType, _status :: TodoStatus, _description :: Text diff --git a/examples/tutorial/Tutorial01_Basics.hs b/examples/tutorial/Tutorial01_Basics.hs --- a/examples/tutorial/Tutorial01_Basics.hs +++ b/examples/tutorial/Tutorial01_Basics.hs @@ -62,6 +62,7 @@ where config = [ appWindowTitle "Tutorial 01 - Basics", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appInitEvent AppInit diff --git a/examples/tutorial/Tutorial02_Styling.hs b/examples/tutorial/Tutorial02_Styling.hs --- a/examples/tutorial/Tutorial02_Styling.hs +++ b/examples/tutorial/Tutorial02_Styling.hs @@ -106,6 +106,7 @@ where config = [ appWindowTitle "Tutorial 02 - Styling", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf", diff --git a/examples/tutorial/Tutorial03_LifeCycle.hs b/examples/tutorial/Tutorial03_LifeCycle.hs --- a/examples/tutorial/Tutorial03_LifeCycle.hs +++ b/examples/tutorial/Tutorial03_LifeCycle.hs @@ -22,7 +22,7 @@ import qualified Monomer.Lens as L data ListItem = ListItem { - _ts :: Int, + _ts :: Millisecond, _text :: Text } deriving (Eq, Show) @@ -59,7 +59,8 @@ keystroke [("Enter", AddItem)] $ hstack [ label "Description:", spacer, - textField_ newItemText [placeholder "Write here!"], -- `nodeKey` "description", + textField_ newItemText [placeholder "Write here!"] + `nodeKey` "description", spacer, button "Add" AddItem `styleBasic` [paddingH 5] @@ -89,7 +90,7 @@ & items .~ removeIdx idx (model ^. items)] _ -> [] where - newItem = ListItem (wenv ^. L.timestamp) (model ^. newItemText) + newItem = ListItem (currentTimeMs wenv) (model ^. newItemText) removeIdx :: Int -> [a] -> [a] removeIdx idx lst = part1 ++ drop 1 part2 where @@ -101,6 +102,7 @@ where config = [ appWindowTitle "Tutorial 03 - Merging", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appInitEvent AppInit diff --git a/examples/tutorial/Tutorial04_Tasks.hs b/examples/tutorial/Tutorial04_Tasks.hs --- a/examples/tutorial/Tutorial04_Tasks.hs +++ b/examples/tutorial/Tutorial04_Tasks.hs @@ -52,7 +52,7 @@ `nodeVisible` (model ^. selected == idx) imageSet = hstack [ numberedImage "https://picsum.photos/id/1020/800/600" 1, - numberedImage "https://picsum.photos/id/1047/800/600" 2, + numberedImage "https://picsum.photos/id/1043/800/600" 2, numberedImage "https://picsum.photos/id/1047/800/600" 3, numberedImage "https://picsum.photos/id/1025/800/600" 4, numberedImage "https://picsum.photos/id/1080/800/600" 5, @@ -87,6 +87,7 @@ where config = [ appWindowTitle "Tutorial 04 - Tasks", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf" diff --git a/examples/tutorial/Tutorial05_Producers.hs b/examples/tutorial/Tutorial05_Producers.hs --- a/examples/tutorial/Tutorial05_Producers.hs +++ b/examples/tutorial/Tutorial05_Producers.hs @@ -80,6 +80,7 @@ where config = [ appWindowTitle "Tutorial 05 - Producers", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf", diff --git a/examples/tutorial/Tutorial06_Composite.hs b/examples/tutorial/Tutorial06_Composite.hs --- a/examples/tutorial/Tutorial06_Composite.hs +++ b/examples/tutorial/Tutorial06_Composite.hs @@ -150,6 +150,7 @@ where config = [ appWindowTitle "Tutorial 06 - Composite", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appInitEvent AppInit diff --git a/examples/tutorial/Tutorial07_CustomWidget.hs b/examples/tutorial/Tutorial07_CustomWidget.hs --- a/examples/tutorial/Tutorial07_CustomWidget.hs +++ b/examples/tutorial/Tutorial07_CustomWidget.hs @@ -168,6 +168,7 @@ where config = [ appWindowTitle "Tutorial 07 - Custom Widget", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf" ] diff --git a/examples/tutorial/Tutorial08_Themes.hs b/examples/tutorial/Tutorial08_Themes.hs --- a/examples/tutorial/Tutorial08_Themes.hs +++ b/examples/tutorial/Tutorial08_Themes.hs @@ -115,6 +115,7 @@ where config = [ appWindowTitle "Tutorial 08 - Themes", + appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appInitEvent AppInit diff --git a/monomer.cabal b/monomer.cabal --- a/monomer.cabal +++ b/monomer.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: monomer -version: 1.3.0.0 +version: 1.4.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. @@ -156,7 +156,7 @@ c2hs 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 @@ -172,14 +172,12 @@ , mtl >=2.1 && <2.3 , nanovg >=0.8 && <1.0 , process ==1.6.* - , safe ==0.3.* , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 - , unordered-containers >=0.2.8 && <0.3 , vector >=0.12 && <0.14 , wreq >=0.5.2 && <0.6 if os(windows) @@ -202,7 +200,7 @@ ghc-options: -threaded build-depends: JuicyPixels >=3.2.9 && <3.5 - , OpenGL ==3.0.* + , OpenGLRaw ==3.3.* , aeson >=1.4 && <2.3 , async >=2.1 && <2.3 , attoparsec >=0.12 && <0.15 @@ -220,14 +218,12 @@ , mtl >=2.1 && <2.3 , nanovg >=0.8 && <1.0 , process ==1.6.* - , safe ==0.3.* , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 , time >=1.8 && <1.16 , 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 @@ -246,7 +242,7 @@ 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 @@ -264,14 +260,12 @@ , nanovg >=0.8 && <1.0 , process ==1.6.* , random >=1.1 && <1.3 - , safe ==0.3.* , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 , time >=1.8 && <1.16 , 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 @@ -288,7 +282,6 @@ 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 @@ -307,14 +300,12 @@ , nanovg >=0.8 && <1.0 , process ==1.6.* , random >=1.1 && <1.3 - , safe ==0.3.* , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 , time >=1.8 && <1.16 , 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 @@ -332,7 +323,7 @@ ghc-options: -threaded build-depends: JuicyPixels >=3.2.9 && <3.5 - , OpenGL ==3.0.* + , OpenGLRaw ==3.3.* , aeson >=1.4 && <2.3 , async >=2.1 && <2.3 , attoparsec >=0.12 && <0.15 @@ -350,15 +341,12 @@ , mtl >=2.1 && <2.3 , nanovg >=0.8 && <1.0 , process ==1.6.* - , safe ==0.3.* - , scientific ==0.3.* , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 - , unordered-containers >=0.2.8 && <0.3 , vector >=0.12 && <0.14 , websockets ==0.12.* , wreq >=0.5.2 && <0.6 @@ -377,7 +365,7 @@ 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 @@ -394,14 +382,12 @@ , mtl >=2.1 && <2.3 , nanovg >=0.8 && <1.0 , process ==1.6.* - , safe ==0.3.* , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 , time >=1.8 && <1.16 , 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 @@ -425,7 +411,7 @@ 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 @@ -443,14 +429,12 @@ , nanovg >=0.8 && <1.0 , process ==1.6.* , random >=1.1 && <1.3 - , safe ==0.3.* , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 - , time >=1.8 && <1.13 + , time >=1.8 && <1.16 , 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 @@ -461,6 +445,7 @@ other-modules: Monomer.Common.CursorIconSpec Monomer.Core.SizeReqSpec + Monomer.Core.StyleUtilSpec Monomer.Graphics.UtilSpec Monomer.TestEventUtil Monomer.TestUtil @@ -512,9 +497,8 @@ OverloadedStrings ghc-options: -fwarn-incomplete-patterns build-depends: - HUnit ==1.6.* - , JuicyPixels >=3.2.9 && <3.5 - , OpenGL ==3.0.* + JuicyPixels >=3.2.9 && <3.5 + , OpenGLRaw ==3.3.* , async >=2.1 && <2.3 , attoparsec >=0.12 && <0.15 , base >=4.11 && <5 @@ -522,7 +506,6 @@ , bytestring-to-vector ==0.3.* , containers >=0.5.11 && <0.7 , data-default >=0.5 && <0.8 - , directory ==1.3.* , exceptions ==0.10.* , extra >=1.6 && <1.9 , formatting >=6.0 && <8.0 @@ -533,15 +516,12 @@ , mtl >=2.1 && <2.3 , nanovg >=0.8 && <1.0 , process ==1.6.* - , safe ==0.3.* , sdl2 >=2.5.0 && <2.6 - , silently ==1.2.* , stm ==2.5.* , text >=1.2 && <2.1 , text-show >=3.7 && <3.10 , time >=1.8 && <1.16 , 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 diff --git a/src/Monomer.hs b/src/Monomer.hs --- a/src/Monomer.hs +++ b/src/Monomer.hs @@ -10,7 +10,7 @@ that should be imported by applications. To start using the library, it is recommended to check the -: +. If you don't want to use all the helper modules, or you don't want to import them unqualified, the modules you will need to import to create an application diff --git a/src/Monomer/Common/BasicTypes.hs b/src/Monomer/Common/BasicTypes.hs --- a/src/Monomer/Common/BasicTypes.hs +++ b/src/Monomer/Common/BasicTypes.hs @@ -165,6 +165,14 @@ px2 = max rx . min (rx + rw) $ px py2 = max ry . min (ry + rh) $ py +-- | Returns a rect using the provided points as boundaries +rectFromPoints :: Point -> Point -> Rect +rectFromPoints (Point x1 y1) (Point x2 y2) = Rect x y w h where + x = min x1 x2 + y = min y1 y2 + w = abs (x2 - x1) + h = abs (y2 - y1) + -- | Adds individual x, y, w and h coordinates to a rect. addToRect :: Rect -> Double -> Double -> Double -> Double -> Maybe Rect addToRect (Rect x y w h) l r t b = newRect where diff --git a/src/Monomer/Core/Combinators.hs b/src/Monomer/Core/Combinators.hs --- a/src/Monomer/Core/Combinators.hs +++ b/src/Monomer/Core/Combinators.hs @@ -30,16 +30,40 @@ {-| Given two values, usually model, checks if merge is required for a given widget. -The first parameter corresponds to the old value, and the second to the new. + +The first parameter usually corresponds to the current 'WidgetEnv', the second +to the old value/model, and the third to the new/model. + +This is used, for example, by _composite_ and _box_. -} -class CmbMergeRequired t s | t -> s where - mergeRequired :: (s -> s -> Bool) -> t +class CmbMergeRequired t w s | t -> w s where + mergeRequired :: (w -> s -> s -> Bool) -> t --- | Listener for the validation status of a field using a lens. +{-| +Listener for the validation status of a user input field using a lens. + +Allows associating a flag to know if the input of a field with validation +settings is valid. This can be used with _textField_, _numericField_, +_dateField_ and _timeField_. + +The flag can be used for styling the component according to the current status. +Beyond styling, its usage is needed for validation purposes. Taking +_numericField_ as an example, one can bind a 'Double' record field to it and set +a valid range from 0 to 100. When the user inputs 100, the record field will +reflect the correct value. If the user adds a 0 (the numericField showing 1000), +the record field will still have 100 because it's the last valid value. Since +there is not a way of indicating errors when using primitive types (a 'Double' +is just a number), we can rely on the flag to check its validity. +-} class CmbValidInput t s | t -> s where validInput :: ALens' s Bool -> t --- | Listener for the validation status of a field using an event handler. +{-| +Listener for the validation status of a user input field using an event handler, +avoiding the need of a lens. + +Check 'CmbValidInput' for details. +-} class CmbValidInputV t e | t -> e where validInputV :: (Bool -> e) -> t @@ -49,6 +73,16 @@ selectOnFocus = selectOnFocus_ True selectOnFocus_ :: Bool -> t +{-| +Defines whether a widget prevents the user changing the value. Note that, in +contrast to a disabled widget, a read-only widget can still be focused and +still allows selecting and copying the value. +-} +class CmbReadOnly t where + readOnly :: t + readOnly = readOnly_ True + readOnly_ :: Bool -> t + -- | Defines whether a widget changes its size when the model changes. class CmbResizeOnChange t where resizeOnChange :: t @@ -249,6 +283,10 @@ textThroughline = textThroughline_ True textThroughline_ :: Bool -> t +-- | How to break texts into lines. +class CmbTextLineBreak t where + textLineBreak :: LineBreak -> t + -- | Does not apply any kind of resizing to fit to container. class CmbFitNone t where fitNone :: t @@ -302,8 +340,8 @@ thumbHoverColor :: Color -> t {-| -The thumb factor. For example, in slider this makes the thumb proportional -to the width of the slider. +The thumb factor. For example, in slider this makes the thumb proportional to +the width of the slider. -} class CmbThumbFactor t where thumbFactor :: Double -> t @@ -318,30 +356,71 @@ thumbVisible = thumbVisible_ True thumbVisible_ :: Bool -> t --- | The width color of a thumb, for example in a scroll. +-- | The width of a thumb, for example in a scroll. class CmbThumbWidth t where thumbWidth :: Double -> t +-- | The minimum size of a thumb, for example in a scroll. +class CmbThumbMinSize t where + thumbMinSize :: Double -> t + -- | Whether to show an alpha channel, for instance in color selector. class CmbShowAlpha t where showAlpha :: t showAlpha = showAlpha_ True showAlpha_ :: Bool -> t --- | Whether to ignore children events. +{-| +Whether to ignore children events. + +By default low-level events (keyboard, mouse, clipboard, etc) traverse the whole +branch where the target widget is located in the widget tree, giving the chance +to each widget along the line to respond to the event. + +In some cases it is desirable to restrict which widgets can handle an event. Two +different 'WidgetRequest's, which can be returned during event handling, exist +for this: + +- 'IgnoreChildrenEvents': parent widgets always have the priority. If a widget + returns this 'WidgetRequest' during event handling, its children widgets + response will be ignored. For example, the _keystroke_ widget can be + configured to return this when a keystroke combination matches. +- 'IgnoreParentEvents': if no parent widget requested 'IgnoreChildrenEvents', a + widget can respond with 'IgnoreParentEvents' to have its response being the + only one taking place. This is used, for example, by the _textArea_ widget to + handle the tab key; without this, the default handler would pass focus to the + next widget down the line. + +Some of the stock widgets allow configuring this behavior (e.g, keystroke and +button). +-} class CmbIgnoreChildrenEvts t where ignoreChildrenEvts :: t ignoreChildrenEvts = ignoreChildrenEvts_ True ignoreChildrenEvts_ :: Bool -> t +-- | Whether to ignore parent events. Check 'CmbIgnoreChildrenEvts'. +class CmbIgnoreParentEvts t where + ignoreParentEvts :: t + ignoreParentEvts = ignoreParentEvts_ True + ignoreParentEvts_ :: Bool -> t + -- | On init event. class CmbOnInit t e | t -> e where onInit :: e -> t +-- | On init WidgetRequest. +class CmbOnInitReq t s e | t -> s e where + onInitReq :: WidgetRequest s e -> t + -- | On dispose event. class CmbOnDispose t e | t -> e where onDispose :: e -> t +-- | On dispose WidgetRequest. +class CmbOnDisposeReq t s e | t -> s e where + onDisposeReq :: WidgetRequest s e -> t + -- | On resize event. class CmbOnResize t e a | t -> e a where onResize :: (a -> e) -> t @@ -515,35 +594,93 @@ -- Style infixl 5 `styleBasic` +infixl 5 `styleBasicSet` + infixl 5 `styleHover` +infixl 5 `styleHoverSet` + infixl 5 `styleFocus` +infixl 5 `styleFocusSet` + infixl 5 `styleFocusHover` +infixl 5 `styleFocusHoverSet` + infixl 5 `styleActive` +infixl 5 `styleActiveSet` + infixl 5 `styleDisabled` +infixl 5 `styleDisabledSet` --- | Basic style combinator, used mainly infix for widgets as a list. +{-| +Basic style combinator, mainly used infix with widgets. + +Represents the default style of a widget. It serves as the base for all the +other style states when an attribute is not overriden. +-} class CmbStyleBasic t where + -- | Merges the new basic style states with the existing ones. styleBasic :: t -> [StyleState] -> t + -- | Sets the new basic style states overriding the existing ones. + styleBasicSet :: t -> [StyleState] -> t --- | Hover style combinator, used mainly infix for widgets as a list. +{-| +Hover style combinator, mainly used infix with widgets. + +Used when the widget is hovered with a pointing device. +-} class CmbStyleHover t where + -- | Merges the new hover style states with the existing ones. styleHover :: t -> [StyleState] -> t + -- | Sets the new hover style states overriding the existing ones. + styleHoverSet :: t -> [StyleState] -> t --- | Focus style combinator, used mainly infix for widgets as a list. +{-| +Focus style combinator, mainly used infix with widgets. + +Used when the widget has keyboard focus. +-} class CmbStyleFocus t where + -- | Merges the new focus style states with the existing ones. styleFocus :: t -> [StyleState] -> t + -- | Sets the new focus style states overriding the existing ones. + styleFocusSet :: t -> [StyleState] -> t --- | Focus Hover style combinator, used mainly infix for widgets as a list. +{-| +Focus Hover style combinator, mainly used infix with widgets. + +Used when the widget is both focused and hovered. In this situation the +attributes defined in focus and hover will be combined, with focus attributes +taking precedence. This style state allows for better control in cases when the +combination of focus and hover styles do not match expectations. +-} class CmbStyleFocusHover t where + -- | Merges the new focus hover style states with the existing ones. styleFocusHover :: t -> [StyleState] -> t + -- | Sets the new focus hover style states overriding the existing ones. + styleFocusHoverSet :: t -> [StyleState] -> t --- | Active style combinator, used mainly infix for widgets as a list. +{-| +Active style combinator, mainly used infix with widgets. + +Used when a mouse press was started in the widget and the pointer is inside its +boundaries. +-} class CmbStyleActive t where + -- | Merges the new active style states with the existing ones. styleActive :: t -> [StyleState] -> t + -- | Sets the new active style states overriding the existing ones. + styleActiveSet :: t -> [StyleState] -> t --- | Disabled style combinator, used mainly infix for widgets as a list. +{-| +Disabled style combinator, mainly used infix with widgets. + +Used when the _nodeEnabled_ attribute has been set to False. +-} class CmbStyleDisabled t where + -- | Merges the new disabled style states with the existing ones. styleDisabled :: t -> [StyleState] -> t + -- | Sets the new disabled style states overriding the existing ones. + styleDisabledSet :: t -> [StyleState] -> t -- | Ignore theme settings and start with blank style. class CmbIgnoreTheme t where diff --git a/src/Monomer/Core/SizeReq.hs b/src/Monomer/Core/SizeReq.hs --- a/src/Monomer/Core/SizeReq.hs +++ b/src/Monomer/Core/SizeReq.hs @@ -13,6 +13,8 @@ module Monomer.Core.SizeReq ( SizeReqUpdater(..), clearExtra, + clearExtraW, + clearExtraH, fixedToMinW, fixedToMinH, fixedToMaxW, @@ -53,12 +55,29 @@ clearExtra :: SizeReqUpdater clearExtra (reqW, reqH) = (reqW & L.extra .~ 0, reqH & L.extra .~ 0) +-- | Clears the horizontal extra field of a pair of SizeReqs. +clearExtraW :: SizeReqUpdater +clearExtraW (reqW, reqH) = (reqW & L.extra .~ 0, reqH) + +-- | Clears the vertical extra field of a pair of SizeReqs. +clearExtraH :: SizeReqUpdater +clearExtraH (reqW, reqH) = (reqW, reqH & L.extra .~ 0) + +-- | Switches a SizeReq pair from fixed size to minimum size. +fixedToMin + :: Double -- ^ The resize factor. + -> SizeReqUpdater -- ^ The updated SizeReq. +fixedToMin fs (reqW, reqH) = (newReqW, newReqH) where + (fixedW, fixedH) = (reqW ^. L.fixed, reqH ^. L.fixed) + newReqW = SizeReq fixedW 0 fixedW fs + newReqH = SizeReq fixedH 0 fixedH fs + -- | 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 +fixedToMinW fw (SizeReq fixed _ _ _, reqH) = (newReqW, reqH) where + newReqW = SizeReq fixed 0 fixed fw -- | Switches a SizeReq pair from fixed height to minimum height. fixedToMinH @@ -67,12 +86,21 @@ fixedToMinH fh (reqW, SizeReq fixed _ _ _) = (reqW, newReqH) where newReqH = SizeReq fixed 0 fixed fh +-- | Switches a SizeReq pair from fixed size to maximum size. +fixedToMax + :: Double -- ^ The resize factor. + -> SizeReqUpdater -- ^ The updated SizeReq. +fixedToMax fs (reqW, reqH) = (newReqW, newReqH) where + (fixedW, fixedH) = (reqW ^. L.fixed, reqH ^. L.fixed) + newReqW = SizeReq 0 fixedW 0 fs + newReqH = SizeReq 0 fixedH 0 fs + -- | 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 +fixedToMaxW fw (SizeReq fixed _ _ _, reqH) = (newReqW, reqH) where + newReqW = SizeReq 0 fixed 0 fw -- | Switches a SizeReq pair from fixed height to maximum height. fixedToMaxH @@ -81,12 +109,21 @@ fixedToMaxH fh (reqW, SizeReq fixed _ _ _) = (reqW, newReqH) where newReqH = SizeReq 0 fixed 0 fh +-- | Switches a SizeReq pair from fixed size to expand size. +fixedToExpand + :: Double -- ^ The resize factor. + -> SizeReqUpdater -- ^ The updated SizeReq. +fixedToExpand fs (reqW, reqH) = (newReqW, newReqH) where + (fixedW, fixedH) = (reqW ^. L.fixed, reqH ^. L.fixed) + newReqW = SizeReq 0 fixedW fixedW fs + newReqH = SizeReq 0 fixedH fixedH fs + -- | 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 +fixedToExpandW fw (SizeReq fixed _ _ _, reqH) = (newReqW, reqH) where + newReqW = SizeReq 0 fixed fixed fw -- | Switches a SizeReq pair from fixed height to expand height. fixedToExpandH diff --git a/src/Monomer/Core/Style.hs b/src/Monomer/Core/Style.hs --- a/src/Monomer/Core/Style.hs +++ b/src/Monomer/Core/Style.hs @@ -177,6 +177,9 @@ instance CmbTextThroughline TextStyle where textThroughline_ through = def & L.throughline ?~ through +instance CmbTextLineBreak TextStyle where + textLineBreak break = def & L.lineBreak ?~ break + -- Padding instance CmbPadding Padding where @@ -360,6 +363,9 @@ instance CmbTextThroughline StyleState where textThroughline_ False = def textThroughline_ True = def & L.text ?~ textThroughline + +instance CmbTextLineBreak StyleState where + textLineBreak break = def & L.text ?~ textLineBreak break -- Padding instance CmbPadding StyleState where diff --git a/src/Monomer/Core/StyleTypes.hs b/src/Monomer/Core/StyleTypes.hs --- a/src/Monomer/Core/StyleTypes.hs +++ b/src/Monomer/Core/StyleTypes.hs @@ -306,6 +306,15 @@ instance Monoid Radius where mempty = def +-- | Defines how to break texts into lines. +data LineBreak + = OnSpaces + | OnCharacters + deriving (Eq, Ord, Enum, Show, Generic) + +instance Default LineBreak where + def = OnSpaces + -- | Text related definitions. data TextStyle = TextStyle { _txsFont :: Maybe Font, -- ^ The font type. @@ -317,7 +326,8 @@ _txsOverline :: Maybe Bool, -- ^ True if overline should be displayed. _txsThroughline :: Maybe Bool, -- ^ True if throughline should be displayed. _txsAlignH :: Maybe AlignTH, -- ^ Horizontal alignment. - _txsAlignV :: Maybe AlignTV -- ^ Vertical alignment. + _txsAlignV :: Maybe AlignTV, -- ^ Vertical alignment. + _txsLineBreak :: Maybe LineBreak -- ^ Line break option. } deriving (Eq, Show, Generic) instance Default TextStyle where @@ -331,7 +341,8 @@ _txsOverline = Nothing, _txsThroughline = Nothing, _txsAlignH = Nothing, - _txsAlignV = Nothing + _txsAlignV = Nothing, + _txsLineBreak = Nothing } instance Semigroup TextStyle where @@ -345,7 +356,8 @@ _txsOverline = _txsOverline ts2 <|> _txsOverline ts1, _txsThroughline = _txsThroughline ts2 <|> _txsThroughline ts1, _txsAlignH = _txsAlignH ts2 <|> _txsAlignH ts1, - _txsAlignV = _txsAlignV ts2 <|> _txsAlignV ts1 + _txsAlignV = _txsAlignV ts2 <|> _txsAlignV ts1, + _txsLineBreak = _txsLineBreak ts2 <|> _txsLineBreak ts1 } instance Monoid TextStyle where diff --git a/src/Monomer/Core/StyleUtil.hs b/src/Monomer/Core/StyleUtil.hs --- a/src/Monomer/Core/StyleUtil.hs +++ b/src/Monomer/Core/StyleUtil.hs @@ -8,8 +8,10 @@ Helper functions for style types. -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-} module Monomer.Core.StyleUtil ( @@ -25,6 +27,7 @@ styleFontColor, styleTextAlignH, styleTextAlignV, + styleTextLineBreak, styleBgColor, styleFgColor, styleSndColor, @@ -42,7 +45,7 @@ mapStyleStates ) where -import Control.Lens ((&), (^.), (^?), (.~), (+~), (%~), (?~), _Just, non) +import Control.Lens import Data.Default import Data.Maybe import Data.Text (Text) @@ -58,64 +61,88 @@ instance CmbStyleBasic Style where styleBasic oldStyle states = newStyle where + newStyle = oldStyle & L.basic <>~ maybeConcat states + + styleBasicSet oldStyle states = newStyle where newStyle = oldStyle & L.basic .~ maybeConcat states instance CmbStyleHover Style where styleHover oldStyle states = newStyle where + newStyle = oldStyle & L.hover <>~ maybeConcat states + + styleHoverSet oldStyle states = newStyle where newStyle = oldStyle & L.hover .~ maybeConcat states instance CmbStyleFocus Style where styleFocus oldStyle states = newStyle where + newStyle = oldStyle & L.focus <>~ maybeConcat states + + styleFocusSet oldStyle states = newStyle where newStyle = oldStyle & L.focus .~ maybeConcat states instance CmbStyleFocusHover Style where styleFocusHover oldStyle states = newStyle where + newStyle = oldStyle & L.focusHover <>~ maybeConcat states + + styleFocusHoverSet oldStyle states = newStyle where newStyle = oldStyle & L.focusHover .~ maybeConcat states instance CmbStyleActive Style where styleActive oldStyle states = newStyle where + newStyle = oldStyle & L.active <>~ maybeConcat states + + styleActiveSet oldStyle states = newStyle where newStyle = oldStyle & L.active .~ maybeConcat states instance CmbStyleDisabled Style where styleDisabled oldStyle states = newStyle where + newStyle = oldStyle & L.disabled <>~ maybeConcat states + + styleDisabledSet oldStyle states = newStyle where newStyle = oldStyle & L.disabled .~ maybeConcat states instance CmbStyleBasic (WidgetNode s e) where - styleBasic node states = node & L.info . L.style .~ newStyle where - state = mconcat states - oldStyle = node ^. L.info . L.style - newStyle = oldStyle & L.basic ?~ state + styleBasic node states = newNode where + newNode = mergeNodeStyleState L.basic node states + styleBasicSet node states = newNode where + newNode = setNodeStyleState L.basic node states + instance CmbStyleHover (WidgetNode s e) where - styleHover node states = node & L.info . L.style .~ newStyle where - state = mconcat states - oldStyle = node ^. L.info . L.style - newStyle = oldStyle & L.hover ?~ state + styleHover node states = newNode where + newNode = mergeNodeStyleState L.hover node states + styleHoverSet node states = newNode where + newNode = setNodeStyleState L.hover node states + instance CmbStyleFocus (WidgetNode s e) where - styleFocus node states = node & L.info . L.style .~ newStyle where - state = mconcat states - oldStyle = node ^. L.info . L.style - newStyle = oldStyle & L.focus ?~ state + styleFocus node states = newNode where + newNode = mergeNodeStyleState L.focus node states + styleFocusSet node states = newNode where + newNode = setNodeStyleState L.focus node states + instance CmbStyleFocusHover (WidgetNode s e) where - styleFocusHover node states = node & L.info . L.style .~ newStyle where - state = mconcat states - oldStyle = node ^. L.info . L.style - newStyle = oldStyle & L.focusHover ?~ state + styleFocusHover node states = newNode where + newNode = mergeNodeStyleState L.focusHover node states + styleFocusHoverSet node states = newNode where + newNode = setNodeStyleState L.focusHover node states + instance CmbStyleActive (WidgetNode s e) where - styleActive node states = node & L.info . L.style .~ newStyle where - state = mconcat states - oldStyle = node ^. L.info . L.style - newStyle = oldStyle & L.active ?~ state + styleActive node states = newNode where + newNode = mergeNodeStyleState L.active node states + styleActiveSet node states = newNode where + newNode = setNodeStyleState L.active node states + instance CmbStyleDisabled (WidgetNode s e) where - styleDisabled node states = node & L.info . L.style .~ newStyle where - state = mconcat states - oldStyle = node ^. L.info . L.style - newStyle = oldStyle & L.disabled ?~ state + styleDisabled node states = newNode where + newNode = mergeNodeStyleState L.disabled node states + styleDisabledSet node states = newNode where + newNode = setNodeStyleState L.disabled node states + infixl 5 `nodeKey` infixl 5 `nodeEnabled` infixl 5 `nodeVisible` @@ -177,6 +204,11 @@ styleTextAlignV style = fromMaybe def alignV where alignV = style ^? L.text . _Just . L.alignV . _Just +-- | Returns the line break option of the given style state, or the +styleTextLineBreak :: StyleState -> LineBreak +styleTextLineBreak style = fromMaybe def lineBreak where + lineBreak = style ^? L.text . _Just . L.lineBreak . _Just + -- | Returns the background color of the given style state, or the default. styleBgColor :: StyleState -> Color styleBgColor style = fromMaybe def bgColor where @@ -306,6 +338,34 @@ br = maybe 0 _bsWidth (_brdRight border) bt = maybe 0 _bsWidth (_brdTop border) bb = maybe 0 _bsWidth (_brdBottom border) + +mergeNodeStyleState + :: Lens' Style (Maybe StyleState) + -> WidgetNode s e + -> [StyleState] + -> WidgetNode s e +mergeNodeStyleState field node states = newNode where + oldStyle = node ^. L.info . L.style + oldState = oldStyle ^. field . non def + !mcatStates = mconcat states + !newStates = oldState <> mcatStates + !newStyle = oldStyle + & field ?~ newStates + !newNode = node + & L.info . L.style .~ newStyle + +setNodeStyleState + :: Lens' Style (Maybe StyleState) + -> WidgetNode s e + -> [StyleState] + -> WidgetNode s e +setNodeStyleState field node states = newNode where + oldStyle = node ^. L.info . L.style + !newStates = mconcat states + !newStyle = oldStyle + & field ?~ newStates + !newNode = node + & L.info . L.style .~ newStyle justDef :: (Default a) => Maybe a -> a justDef val = fromMaybe def val diff --git a/src/Monomer/Core/ThemeTypes.hs b/src/Monomer/Core/ThemeTypes.hs --- a/src/Monomer/Core/ThemeTypes.hs +++ b/src/Monomer/Core/ThemeTypes.hs @@ -84,6 +84,7 @@ _thsScrollThumbColor :: Color, _thsScrollBarWidth :: Double, _thsScrollThumbWidth :: Double, + _thsScrollThumbMinSize :: Double, _thsScrollThumbRadius :: Double, _thsScrollWheelRate :: Rational, _thsSeparatorLineWidth :: Double, @@ -140,6 +141,7 @@ _thsScrollThumbColor = darkGray, _thsScrollBarWidth = 10, _thsScrollThumbWidth = 8, + _thsScrollThumbMinSize = 25, _thsScrollThumbRadius = 0, _thsScrollWheelRate = 10, _thsSeparatorLineWidth = 1, @@ -192,10 +194,11 @@ _thsRadioWidth = _thsRadioWidth t2, _thsScrollOverlay = _thsScrollOverlay t2, _thsScrollFollowFocus = _thsScrollFollowFocus t2, - _thsScrollBarColor = _thsScrollBarColor t2, - _thsScrollThumbColor = _thsScrollThumbColor t2, - _thsScrollBarWidth = _thsScrollBarWidth t2, - _thsScrollThumbWidth = _thsScrollThumbWidth t2, + _thsScrollBarColor = _thsScrollBarColor t2, + _thsScrollThumbColor = _thsScrollThumbColor t2, + _thsScrollBarWidth = _thsScrollBarWidth t2, + _thsScrollThumbWidth = _thsScrollThumbWidth t2, + _thsScrollThumbMinSize = _thsScrollThumbMinSize t2, _thsScrollThumbRadius = _thsScrollThumbRadius t2, _thsScrollWheelRate = _thsScrollWheelRate t2, _thsSeparatorLineWidth = _thsSeparatorLineWidth t2, diff --git a/src/Monomer/Core/Themes/BaseTheme.hs b/src/Monomer/Core/Themes/BaseTheme.hs --- a/src/Monomer/Core/Themes/BaseTheme.hs +++ b/src/Monomer/Core/Themes/BaseTheme.hs @@ -131,13 +131,29 @@ normalFont = def & L.font ?~ Font "Regular" & L.fontSize ?~ FontSize 16 - & L.fontSpaceV ?~ FontSpace 4 + & L.fontSpaceV ?~ FontSpace 2 titleFont :: TextStyle titleFont = def & L.font ?~ Font "Bold" & L.fontSize ?~ FontSize 20 + & L.fontSpaceV ?~ FontSpace 2 +dialogMsgBodyFont :: BaseThemeColors -> TextStyle +dialogMsgBodyFont themeMod = fontStyle where + fontStyle = normalFont + & L.fontColor ?~ dialogText themeMod + +externalLinkFont :: BaseThemeColors -> TextStyle +externalLinkFont themeMod = fontStyle where + fontStyle = normalFont + & L.fontColor ?~ externalLinkBasic themeMod + +labelFont :: BaseThemeColors -> TextStyle +labelFont themeMod = fontStyle <> textLeft where + fontStyle = normalFont + & L.fontColor ?~ labelText themeMod + btnStyle :: BaseThemeColors -> StyleState btnStyle themeMod = def & L.text ?~ (normalFont & L.fontColor ?~ btnText themeMod) <> textCenter @@ -153,15 +169,18 @@ & L.border ?~ border 1 (btnMainBgBasic themeMod) textInputStyle :: BaseThemeColors -> StyleState -textInputStyle themeMod = def - & L.text ?~ (normalFont & L.fontColor ?~ inputText themeMod) - & L.bgColor ?~ inputBgBasic themeMod - & L.fgColor ?~ inputFgBasic themeMod - & L.sndColor ?~ (inputSndBasic themeMod & L.a .~ 0.6) - & L.hlColor ?~ inputSelBasic themeMod - & L.border ?~ border 1 (inputBorder themeMod) - & L.radius ?~ radius 4 - & L.padding ?~ padding 8 +textInputStyle themeMod = style where + textStyle = normalFont + & L.fontColor ?~ inputText themeMod + style = def + & L.text ?~ textStyle + & L.bgColor ?~ inputBgBasic themeMod + & L.fgColor ?~ inputFgBasic themeMod + & L.sndColor ?~ (inputSndBasic themeMod & L.a .~ 0.6) + & L.hlColor ?~ inputSelBasic themeMod + & L.border ?~ border 1 (inputBorder themeMod) + & L.radius ?~ radius 4 + & L.padding ?~ padding 8 numericInputStyle :: BaseThemeColors -> StyleState numericInputStyle themeMod = textInputStyle themeMod @@ -226,8 +245,7 @@ & L.dialogCloseIconStyle . L.sizeReqH ?~ width 16 & L.dialogButtonsStyle . L.padding ?~ padding 20 <> paddingT 10 & L.dialogMsgBodyStyle . L.padding ?~ padding 20 - & L.dialogMsgBodyStyle . L.text - ?~ (normalFont & L.fontColor ?~ dialogText themeMod) + & L.dialogMsgBodyStyle . L.text ?~ dialogMsgBodyFont themeMod & L.dialogMsgBodyStyle . L.sizeReqW ?~ maxWidth 600 & L.dropdownStyle .~ textInputStyle themeMod & L.dropdownStyle . L.fgColor ?~ inputIconFg themeMod @@ -236,9 +254,8 @@ & L.dropdownListStyle . L.bgColor ?~ slMainBg themeMod & L.dropdownItemStyle .~ selectListItemStyle themeMod & L.dropdownItemSelectedStyle .~ selectListItemSelectedStyle themeMod - & L.externalLinkStyle . L.text ?~ (normalFont & L.fontColor ?~ externalLinkBasic themeMod) - & L.labelStyle . L.text - ?~ (normalFont & L.fontColor ?~ labelText themeMod) <> textLeft + & L.externalLinkStyle . L.text ?~ externalLinkFont themeMod + & L.labelStyle . L.text ?~ labelFont themeMod & L.numericFieldStyle .~ numericInputStyle themeMod & L.optionBtnOnStyle .~ btnMainStyle themeMod & L.optionBtnOffStyle .~ btnStyle themeMod @@ -255,6 +272,7 @@ & L.scrollThumbColor .~ scrollThumbBasic themeMod & L.scrollBarWidth .~ 8 & L.scrollThumbWidth .~ 8 + & L.scrollThumbMinSize .~ 25 & L.scrollThumbRadius .~ 4 & L.scrollWheelRate .~ 10 & L.separatorLineWidth .~ 1 diff --git a/src/Monomer/Core/Util.hs b/src/Monomer/Core/Util.hs --- a/src/Monomer/Core/Util.hs +++ b/src/Monomer/Core/Util.hs @@ -8,11 +8,12 @@ Helper functions for Core types. -} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} module Monomer.Core.Util where -import Control.Lens ((&), (^.), (.~), (?~)) +import Control.Lens ((&), (^.), (^?), (.~), (?~), _Just) import Data.Maybe import Data.Text (Text) import Data.Typeable (cast) @@ -29,32 +30,78 @@ import qualified Monomer.Core.Lens as L --- | Returns the path associated to a given key, if any. +-- | Returns the 'Path' associated to a given 'WidgetKey', if any. The search is +-- restricted to the parent _Composite_. pathFromKey :: WidgetEnv s e -> WidgetKey -> Maybe Path pathFromKey wenv key = fmap (^. L.info . L.path) node where node = Map.lookup key (wenv ^. L.widgetKeyMap) --- | Returns the widgetId associated to a given key, if any. +-- | Returns the 'WidgetId' associated to a given 'WidgetKey', if any. The +-- search is restricted to the parent _Composite_. widgetIdFromKey :: WidgetEnv s e -> WidgetKey -> Maybe WidgetId widgetIdFromKey wenv key = fmap (^. L.info . L.widgetId) node where node = Map.lookup key (wenv ^. L.widgetKeyMap) --- | Returns the node info associated to a given path. -findWidgetByPath +-- | Returns the 'WidgetNodeInfo' associated to the given 'WidgetKey', if any. +-- The search is restricted to the parent _Composite_. +nodeInfoFromKey :: WidgetEnv s e -> WidgetKey -> Maybe WidgetNodeInfo +nodeInfoFromKey wenv key = path >>= nodeInfoFromPath wenv where + path = pathFromKey wenv key + +-- | Returns the 'WidgetId' associated to the given 'Path', if any. +widgetIdFromPath :: WidgetEnv s e -> Path -> Maybe WidgetId +widgetIdFromPath wenv path = mwni ^? _Just . L.widgetId where + branch = wenv ^. L.findBranchByPath $ path + mwni = Seq.lookup (length branch - 1) branch + +{-# DEPRECATED findWidgetIdFromPath "Use 'widgetIdFromPath' instead." #-} +findWidgetIdFromPath :: WidgetEnv s e -> Path -> Maybe WidgetId +findWidgetIdFromPath = widgetIdFromPath + +-- | Returns the 'WidgetNodeInfo' associated to the given 'Path', if any. +nodeInfoFromPath :: WidgetEnv s e -> Path -> Maybe WidgetNodeInfo +nodeInfoFromPath wenv path = mwni where + branch = wenv ^. L.findBranchByPath $ path + mwni = Seq.lookup (length branch - 1) branch + +-- | Returns the 'WidgetNodeInfo' associated to a given 'Path'. The path will be +-- searched for starting from the provided 'WidgetNode'. +findChildNodeInfoByPath :: WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo -findWidgetByPath wenv node target = mnode where +findChildNodeInfoByPath wenv node target = mnode where branch = widgetFindBranchByPath (node ^. L.widget) wenv node target mnode = case Seq.lookup (length branch - 1) branch of Just child | child ^. L.path == target -> Just child _ -> Nothing --- | Returns the complete node info branch associated to a given path. -findWidgetBranchByPath +{-# DEPRECATED findWidgetByPath "Use 'findChildNodeInfoByPath' instead." #-} +findWidgetByPath + :: WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo +findWidgetByPath = findChildNodeInfoByPath + +-- | Returns the 'WidgetNodeInfo' branch associated to a given 'Path'. The path +-- will be searched for starting from the provided 'WidgetNode'. +findChildBranchByPath :: WidgetEnv s e -> WidgetNode s e -> Path -> Seq WidgetNodeInfo -findWidgetBranchByPath wenv node target = branch where +findChildBranchByPath wenv node target = branch where branch = widgetFindBranchByPath (node ^. L.widget) wenv node target +{-# DEPRECATED findWidgetBranchByPath "Use 'findChildBranchByPath' instead." #-} +findWidgetBranchByPath + :: WidgetEnv s e -> WidgetNode s e -> Path -> Seq WidgetNodeInfo +findWidgetBranchByPath = findChildBranchByPath + +-- | Returns the first parent 'WidgetNodeInfo' of the 'Path' that matches the +-- given 'WidgetType'. +findParentNodeInfoByType + :: WidgetEnv s e -> Path -> WidgetType -> Maybe WidgetNodeInfo +findParentNodeInfoByType wenv path wtype = wniParent where + isMatch wni = wni ^. L.widgetType == wtype + branch = wenv ^. L.findBranchByPath $ path + matches = Seq.filter isMatch branch + wniParent = Seq.lookup (length matches - 1) matches + -- | Helper functions that associates False to Vertical and True to Horizontal. getLayoutDirection :: Bool -> LayoutDirection getLayoutDirection False = LayoutVertical @@ -285,6 +332,14 @@ -- | Checks if the platform is macOS isMacOS :: WidgetEnv s e -> Bool isMacOS wenv = _weOs wenv == "Mac OS X" + +{-| +Returns the current time in milliseconds. Adds appStartTs and timestamp fields +from 'WidgetEnv' and converts the result to the expected 'Integral' type. +-} +currentTimeMs :: Integral a => WidgetEnv s e -> a +currentTimeMs wenv = fromIntegral ts where + ts = wenv ^. L.appStartTs + wenv ^. L.timestamp -- | Returns a string description of a node and its children. widgetTreeDesc :: Int -> WidgetNode s e -> String diff --git a/src/Monomer/Core/WidgetTypes.hs b/src/Monomer/Core/WidgetTypes.hs --- a/src/Monomer/Core/WidgetTypes.hs +++ b/src/Monomer/Core/WidgetTypes.hs @@ -10,7 +10,9 @@ -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# Language GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-} @@ -24,7 +26,9 @@ import Data.String (IsString(..)) import Data.Text (Text) import Data.Typeable (Typeable, typeOf) +import Data.Word (Word64) import GHC.Generics +import TextShow import qualified Data.Text as T @@ -34,9 +38,18 @@ import Monomer.Event.Types import Monomer.Graphics.Types --- | Time ellapsed since startup -type Timestamp = Int +{-| +Time expressed in milliseconds. Useful for representing the time of events, +length of intervals, start time of the application and ellapsed time since its +start. +It can be converted from/to other numeric types using the standard functions. +-} +newtype Millisecond = Millisecond { + unMilliseconds :: Word64 +} deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Read, Show, Default, TextShow) + deriving (Generic) + -- | Type constraints for a valid model type WidgetModel s = Typeable s -- | Type constraints for a valid event @@ -94,8 +107,8 @@ requests (tasks, clipboard, etc). -} data WidgetId = WidgetId { - _widTs :: Int, -- ^ The timestamp when the instance was created. - _widPath :: Path -- ^ The path at creation time. + _widTs :: Millisecond, -- ^ The timestamp when the instance was created. + _widPath :: Path -- ^ The path at creation time. } deriving (Eq, Show, Ord, Generic) instance Default WidgetId where @@ -139,7 +152,7 @@ {-| WidgetRequests are the way a widget can perform side effects, such as changing cursor icons, get/set the clipboard and perform asynchronous tasks. These -requests are included as part of a WidgetResult in different points in the +requests are included as part of a 'WidgetResult' in different points in the lifecycle of a widget. -} data WidgetRequest s e @@ -160,7 +173,7 @@ | SetFocus WidgetId -- | Requests the clipboard contents. It will be received as a SystemEvent. | GetClipboard WidgetId - -- | Sets the clipboard to the given ClipboardData. + -- | Sets the clipboard to the given 'ClipboardData'. | SetClipboard ClipboardData -- | Sets the viewport that should be remain visible when an on-screen -- keyboard is displayed. Required for mobile. @@ -188,11 +201,11 @@ -- in order to reduce CPU usage. Widgets are responsible for requesting -- rendering at points of interest. Mouse (except mouse move) and keyboard -- events automatically generate render requests, but the result of a - -- WidgetTask or WidgetProducer does not. + -- 'RunTask' or 'RunProducer' does not. | RenderOnce -- | Useful if a widget requires periodic rendering. An optional maximum -- number of frames can be provided. - | RenderEvery WidgetId Int (Maybe Int) + | RenderEvery WidgetId Millisecond (Maybe Int) -- | Stops a previous periodic rendering request. | RenderStop WidgetId {-| @@ -293,6 +306,8 @@ _weOs :: Text, -- | Device pixel rate. _weDpr :: Double, + -- | The timestamp in milliseconds when the application started. + _weAppStartTs :: Millisecond, -- | Provides helper funtions for calculating text size. _weFontManager :: FontManager, -- | Returns the node info, and its parents', given a path from root. @@ -307,7 +322,11 @@ _weWindowSize :: Size, -- | The active map of shared data. _weWidgetShared :: MVar (Map Text WidgetShared), - -- | The active map of WidgetKey -> WidgetNode, if any. + {- + The active map of WidgetKey -> WidgetNode, if any. This map is restricted to + to the parent 'Composite'. Do not use this map directly, rely instead on the + 'widgetIdFromKey', 'nodeInfoFromKey' and 'nodeInfoFromPath' utility functions. + -} _weWidgetKeyMap :: WidgetKeyMap s e, -- | The currently hovered path, if any. _weHoveredPath :: Maybe Path, @@ -325,9 +344,12 @@ _weModel :: s, -- | The input status, mainly mouse and keyboard. _weInputStatus :: InputStatus, - -- | The timestamp when this cycle started. - _weTimestamp :: Timestamp, {-| + The timestamp in milliseconds when this event/message cycle started. This + value starts from zero each time the application is run. + -} + _weTimestamp :: Millisecond, + {-| Whether the theme changed in this cycle. Should be considered when a widget avoids merging as optimization, as the styles may have changed. -} @@ -404,8 +426,8 @@ {-| An instance of the widget in the widget tree, without specific type information. This allows querying for widgets that may be nested in Composites, which are not -visible as a regular "WidgetNode" because of possible type mismatches (see -"WidgetKeyMap"). +visible as a regular 'WidgetNode' because of possible type mismatches (see +'WidgetKeyMap'). -} data WidgetInstanceNode = WidgetInstanceNode { -- | Information about the instance. diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs --- a/src/Monomer/Event/Core.hs +++ b/src/Monomer/Event/Core.hs @@ -39,6 +39,7 @@ isActionEvent SDL.TextInputEvent{} = True isActionEvent _ = False +-- | Configuration options for converting from an SDL event to a 'SystemEvent'. data ConvertEventsCfg = ConvertEventsCfg { _cecOs :: Text, -- ^ The host operating system. _cecDpr :: Double, -- ^ Device pixel rate. diff --git a/src/Monomer/Event/Keyboard.hs b/src/Monomer/Event/Keyboard.hs --- a/src/Monomer/Event/Keyboard.hs +++ b/src/Monomer/Event/Keyboard.hs @@ -46,6 +46,9 @@ keyUnknown :: KeyCode keyUnknown = getKeyCode SDL.KeycodeUnknown +keyEnter :: KeyCode +keyEnter = getKeyCode SDL.KeycodeReturn + keyReturn :: KeyCode keyReturn = getKeyCode SDL.KeycodeReturn @@ -337,6 +340,56 @@ keyZ :: KeyCode keyZ = getKeyCode SDL.KeycodeZ +-- Key pad +keyPadDivide :: KeyCode +keyPadDivide = getKeyCode SDL.KeycodeKPDivide + +keyPadMultiply :: KeyCode +keyPadMultiply = getKeyCode SDL.KeycodeKPMultiply + +keyPadMinus :: KeyCode +keyPadMinus = getKeyCode SDL.KeycodeKPMinus + +keyPadPlus :: KeyCode +keyPadPlus = getKeyCode SDL.KeycodeKPPlus + +keyPadEnter :: KeyCode +keyPadEnter = getKeyCode SDL.KeycodeKPEnter + +keyPadPeriod :: KeyCode +keyPadPeriod = getKeyCode SDL.KeycodeKPPeriod + +-- Key pad numbers +keyPad0 :: KeyCode +keyPad0 = getKeyCode SDL.KeycodeKP0 + +keyPad1 :: KeyCode +keyPad1 = getKeyCode SDL.KeycodeKP1 + +keyPad2 :: KeyCode +keyPad2 = getKeyCode SDL.KeycodeKP2 + +keyPad3 :: KeyCode +keyPad3 = getKeyCode SDL.KeycodeKP3 + +keyPad4 :: KeyCode +keyPad4 = getKeyCode SDL.KeycodeKP4 + +keyPad5 :: KeyCode +keyPad5 = getKeyCode SDL.KeycodeKP5 + +keyPad6 :: KeyCode +keyPad6 = getKeyCode SDL.KeycodeKP6 + +keyPad7 :: KeyCode +keyPad7 = getKeyCode SDL.KeycodeKP7 + +keyPad8 :: KeyCode +keyPad8 = getKeyCode SDL.KeycodeKP8 + +keyPad9 :: KeyCode +keyPad9 = getKeyCode SDL.KeycodeKP9 + -- -- Mod keys @@ -657,3 +710,53 @@ isKeyZ :: KeyCode -> Bool isKeyZ = (== keyZ) + +-- Key pad +isKeyPadDivide :: KeyCode -> Bool +isKeyPadDivide = (== keyPadDivide) + +isKeyPadMultiply :: KeyCode -> Bool +isKeyPadMultiply = (== keyPadMultiply) + +isKeyPadMinus :: KeyCode -> Bool +isKeyPadMinus = (== keyPadMinus) + +isKeyPadPlus :: KeyCode -> Bool +isKeyPadPlus = (== keyPadPlus) + +isKeyPadEnter :: KeyCode -> Bool +isKeyPadEnter = (== keyPadEnter) + +isKeyPadPeriod :: KeyCode -> Bool +isKeyPadPeriod = (== keyPadPeriod) + +-- Key pad numbers +isKeyPad0 :: KeyCode -> Bool +isKeyPad0 = (== keyPad0) + +isKeyPad1 :: KeyCode -> Bool +isKeyPad1 = (== keyPad1) + +isKeyPad2 :: KeyCode -> Bool +isKeyPad2 = (== keyPad2) + +isKeyPad3 :: KeyCode -> Bool +isKeyPad3 = (== keyPad3) + +isKeyPad4 :: KeyCode -> Bool +isKeyPad4 = (== keyPad4) + +isKeyPad5 :: KeyCode -> Bool +isKeyPad5 = (== keyPad5) + +isKeyPad6 :: KeyCode -> Bool +isKeyPad6 = (== keyPad6) + +isKeyPad7 :: KeyCode -> Bool +isKeyPad7 = (== keyPad7) + +isKeyPad8 :: KeyCode -> Bool +isKeyPad8 = (== keyPad8) + +isKeyPad9 :: KeyCode -> Bool +isKeyPad9 = (== keyPad9) diff --git a/src/Monomer/Graphics/FFI.chs b/src/Monomer/Graphics/FFI.chs --- a/src/Monomer/Graphics/FFI.chs +++ b/src/Monomer/Graphics/FFI.chs @@ -37,10 +37,11 @@ #include "fontmanager.h" --- | Vector of 4 strict elements +-- | Vector of 4 strict elements. data V4 a = V4 !a !a !a !a deriving (Show, Read, Eq, Ord) +-- | Bounds of a block of text. newtype Bounds = Bounds (V4 CFloat) deriving (Show, Read, Eq, Ord) @@ -62,6 +63,7 @@ pokeElemOff p' 2 c pokeElemOff p' 3 d +-- | Position of a glyph in a text string. data GlyphPosition = GlyphPosition { -- | Pointer of the glyph in the input string. str :: !(Ptr CChar), @@ -98,9 +100,11 @@ {#pointer *FMGglyphPosition as GlyphPositionPtr -> GlyphPosition#} +-- | Reads Bounds from a pointer. peekBounds :: Ptr CFloat -> IO Bounds peekBounds = peek . castPtr +-- | Allocates space for Bounds. allocaBounds :: (Ptr CFloat -> IO b) -> IO b allocaBounds f = alloca (\(p :: Ptr Bounds) -> f (castPtr p)) @@ -121,6 +125,8 @@ {# fun unsafe fmInit {`Double'} -> `FMContext' #} {# fun unsafe fmCreateFont {`FMContext', withCString*`Text', withCString*`Text'} -> `Int' #} + +{# fun unsafe fmSetScale {`FMContext', `Double'} -> `()' #} {# fun unsafe fmFontFace {`FMContext', withCString*`Text'} -> `()' #} diff --git a/src/Monomer/Graphics/FontManager.hs b/src/Monomer/Graphics/FontManager.hs --- a/src/Monomer/Graphics/FontManager.hs +++ b/src/Monomer/Graphics/FontManager.hs @@ -31,23 +31,26 @@ -- | Creates a font manager instance. makeFontManager - :: [FontDef] -- ^ The font definitions. - -> Double -- ^ The device pixel rate. + :: [FontDef] -- ^ The font definitions. + -> Double -- ^ The device pixel rate. -> IO FontManager -- ^ The created renderer. makeFontManager fonts dpr = do - ctx <- fmInit 1 --dpr + ctx <- fmInit dpr validFonts <- foldM (loadFont ctx) [] fonts when (null validFonts) $ putStrLn "Could not find any valid fonts. Text size calculations will fail." - - return $ newManager ctx dpr -newManager :: FMContext -> Double -> FontManager -newManager ctx dpr = FontManager {..} where - computeTextMetrics font fontSize = unsafePerformIO $ do - setFont ctx dpr font fontSize def + return $ newManager ctx + +newManager :: FMContext -> FontManager +newManager ctx = FontManager {..} where + computeTextMetrics font fontSize = + computeTextMetrics_ 1 font fontSize + + computeTextMetrics_ scale font fontSize = unsafePerformIO $ do + setFont ctx scale font fontSize def (asc, desc, lineh) <- fmTextMetrics ctx lowerX <- Seq.lookup 0 <$> fmTextGlyphPositions ctx 0 0 "x" let heightLowerX = case lowerX of @@ -55,24 +58,30 @@ Nothing -> realToFrac asc return $ TextMetrics { - _txmAsc = asc / dpr, - _txmDesc = desc / dpr, - _txmLineH = lineh / dpr, - _txmLowerX = realToFrac heightLowerX / dpr + _txmAsc = asc, + _txmDesc = desc, + _txmLineH = lineh, + _txmLowerX = realToFrac heightLowerX } - computeTextSize font fontSize fontSpaceH text = unsafePerformIO $ do - setFont ctx dpr font fontSize fontSpaceH + computeTextSize font fontSize fontSpaceH text = + computeTextSize_ 1 font fontSize fontSpaceH text + + computeTextSize_ scale font fontSize fontSpaceH text = unsafePerformIO $ do + setFont ctx scale font fontSize fontSpaceH (x1, y1, x2, y2) <- if text /= "" then fmTextBounds ctx 0 0 text else do (asc, desc, lineh) <- fmTextMetrics ctx return (0, 0, 0, lineh) - return $ Size (realToFrac (x2 - x1) / dpr) (realToFrac (y2 - y1) / dpr) + return $ Size (realToFrac (x2 - x1)) (realToFrac (y2 - y1)) - computeGlyphsPos font fontSize fontSpaceH text = unsafePerformIO $ do - setFont ctx dpr font fontSize fontSpaceH + computeGlyphsPos font fontSize fontSpaceH text = + computeGlyphsPos_ 1 font fontSize fontSpaceH text + + computeGlyphsPos_ scale font fontSize fontSpaceH text = unsafePerformIO $ do + setFont ctx scale font fontSize fontSpaceH glyphs <- if text /= "" then fmTextGlyphPositions ctx 0 0 text else return Seq.empty @@ -81,12 +90,13 @@ where toGlyphPos chr glyph = GlyphPos { _glpGlyph = chr, - _glpXMin = realToFrac (glyphPosMinX glyph) / dpr, - _glpXMax = realToFrac (glyphPosMaxX glyph) / dpr, - _glpYMin = realToFrac (glyphPosMinY glyph) / dpr, - _glpYMax = realToFrac (glyphPosMaxY glyph) / dpr, - _glpW = realToFrac (glyphPosMaxX glyph - glyphPosMinX glyph) / dpr, - _glpH = realToFrac (glyphPosMaxY glyph - glyphPosMinY glyph) / dpr + _glpX = realToFrac (glyphX glyph), + _glpXMin = realToFrac (glyphPosMinX glyph), + _glpXMax = realToFrac (glyphPosMaxX glyph), + _glpYMin = realToFrac (glyphPosMinY glyph), + _glpYMax = realToFrac (glyphPosMaxY glyph), + _glpW = realToFrac (glyphPosMaxX glyph - glyphPosMinX glyph), + _glpH = realToFrac (glyphPosMaxY glyph - glyphPosMinY glyph) } loadFont :: FMContext -> [Text] -> FontDef -> IO [Text] @@ -97,7 +107,8 @@ else putStrLn ("Failed to load font: " ++ T.unpack name) >> return fonts setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO () -setFont ctx dpr (Font name) (FontSize size) (FontSpace spaceH) = do +setFont ctx scale (Font name) (FontSize size) (FontSpace spaceH) = do + fmSetScale ctx scale fmFontFace ctx name - fmFontSize ctx $ realToFrac $ size * dpr - fmTextLetterSpacing ctx $ realToFrac $ spaceH * dpr + fmFontSize ctx $ realToFrac size + fmTextLetterSpacing ctx $ realToFrac spaceH diff --git a/src/Monomer/Graphics/NanoVGRenderer.hs b/src/Monomer/Graphics/NanoVGRenderer.hs --- a/src/Monomer/Graphics/NanoVGRenderer.hs +++ b/src/Monomer/Graphics/NanoVGRenderer.hs @@ -113,6 +113,10 @@ newRenderer :: VG.Context -> Double -> IORef Env -> Renderer newRenderer c rdpr envRef = Renderer {..} where + {- + rdpr is used to let nanovg know the real device pixel rate. + dpr is set to 1 to disable all NanoVGRenderer internal calculations. + -} dpr = 1 beginFrame w h = do diff --git a/src/Monomer/Graphics/RemixIcon.hs b/src/Monomer/Graphics/RemixIcon.hs --- a/src/Monomer/Graphics/RemixIcon.hs +++ b/src/Monomer/Graphics/RemixIcon.hs @@ -10,7 +10,7 @@ representative name. These code points can be used in labels or buttons to show icons instead of regular text. -Make sure to load the remixicon.ttf font in your application and set 'textFont' +Make sure to load the remixicon.ttf font in your application and set _textFont_ in the corresponding widget. Existing icons can be browsed in https://remixicon.com. diff --git a/src/Monomer/Graphics/Text.hs b/src/Monomer/Graphics/Text.hs --- a/src/Monomer/Graphics/Text.hs +++ b/src/Monomer/Graphics/Text.hs @@ -135,10 +135,11 @@ fSize = styleFontSize style fSpcH = styleFontSpaceH style fSpcV = styleFontSpaceV style + break = styleTextLineBreak style lineH = _txmLineH metrics !metrics = computeTextMetrics fontMgr font fSize - fitToWidth = fitLineToW fontMgr font fSize fSpcH fSpcV metrics + fitToWidth = fitLineToW fontMgr font fSize fSpcH fSpcV metrics break helper acc line = (cLines <> newLines, newTop) where (cLines, cTop) = acc @@ -261,22 +262,25 @@ -> FontSpace -> FontSpace -> TextMetrics + -> LineBreak -> Double -> Double -> TextTrim -> Text -> Seq TextLine -fitLineToW fontMgr font fSize fSpcH fSpcV metrics top width trim text = res where +fitLineToW fontMgr font fSize fSpcH fSpcV metrics break top width trim text = res where spaces = T.replicate 4 " " newText = T.replace "\t" spaces text !glyphs = computeGlyphsPos fontMgr font fSize fSpcH newText -- Do not break line on trailing spaces, they are removed in the next step -- In the case of KeepSpaces, lines with only spaces (empty looking) are valid keepTailSpaces = trim == TrimSpaces - groups = fitGroups (splitGroups glyphs) width keepTailSpaces + groups + | break == OnCharacters = splitGroups break width glyphs + | otherwise = fitGroups (splitGroups break width glyphs) width keepTailSpaces resetGroups - | trim == TrimSpaces = fmap (resetGlyphs . trimGlyphs) groups - | otherwise = fmap resetGlyphs groups + | trim == TrimSpaces = fmap trimGlyphs groups + | otherwise = groups buildLine = buildTextLine font fSize fSpcH fSpcV metrics top res | text /= "" = Seq.mapWithIndex buildLine resetGroups @@ -413,26 +417,17 @@ isSpaceGroup Empty = False isSpaceGroup (g :<| gs) = isSpace (_glpGlyph g) -splitGroups :: Seq GlyphPos -> Seq GlyphGroup -splitGroups Empty = Empty -splitGroups glyphs = group <| splitGroups rest where +splitGroups :: LineBreak -> Double -> Seq GlyphPos -> Seq GlyphGroup +splitGroups _ _ Empty = Empty +splitGroups break width glyphs = group <| splitGroups break width rest where g :<| gs = glyphs groupWordFn = not . isWordDelimiter . _glpGlyph + groupWidthFn g2 = _glpXMax g2 - _glpXMin g <= width + atWord = break == OnSpaces (group, rest) - | isWordDelimiter (_glpGlyph g) = (Seq.singleton g, gs) - | otherwise = Seq.spanl groupWordFn glyphs - -resetGlyphs :: Seq GlyphPos -> Seq GlyphPos -resetGlyphs Empty = Empty -resetGlyphs gs@(g :<| _) = resetGlyphsPos gs (_glpXMin g) - -resetGlyphsPos :: Seq GlyphPos -> Double -> Seq GlyphPos -resetGlyphsPos Empty _ = Empty -resetGlyphsPos (g :<| gs) offset = newG <| resetGlyphsPos gs offset where - newG = g { - _glpXMin = _glpXMin g - offset, - _glpXMax = _glpXMax g - offset - } + | atWord && isWordDelimiter (_glpGlyph g) = (Seq.singleton g, gs) + | atWord = Seq.spanl groupWordFn glyphs + | otherwise = Seq.spanl groupWidthFn glyphs trimGlyphs :: Seq GlyphPos -> Seq GlyphPos trimGlyphs glyphs = newGlyphs where diff --git a/src/Monomer/Graphics/Types.hs b/src/Monomer/Graphics/Types.hs --- a/src/Monomer/Graphics/Types.hs +++ b/src/Monomer/Graphics/Types.hs @@ -140,6 +140,7 @@ -- | Information of a text glyph instance. data GlyphPos = GlyphPos { _glpGlyph :: {-# UNPACK #-} !Char, -- ^ The represented character. + _glpX :: {-# UNPACK #-} !Double, -- ^ The x coordinate used for rendering. _glpXMin :: {-# UNPACK #-} !Double, -- ^ The min x coordinate. _glpXMax :: {-# UNPACK #-} !Double, -- ^ The max x coordinate. _glpYMin :: {-# UNPACK #-} !Double, -- ^ The min x coordinate. @@ -151,6 +152,7 @@ instance Default GlyphPos where def = GlyphPos { _glpGlyph = ' ', + _glpX = 0, _glpXMin = 0, _glpXMax = 0, _glpYMin = 0, @@ -197,8 +199,8 @@ data TextLine = TextLine { _tlFont :: !Font, -- ^ The font name. _tlFontSize :: !FontSize, -- ^ The font size. - _tlFontSpaceH :: !FontSpace, -- ^ The font spacing. - _tlFontSpaceV :: !FontSpace, -- ^ The vertical line spacing. + _tlFontSpaceH :: !FontSpace, -- ^ The font spacing. + _tlFontSpaceV :: !FontSpace, -- ^ The vertical line spacing. _tlMetrics :: !TextMetrics, -- ^ The text metrics for the given font/size. _tlText :: !Text, -- ^ The represented text. _tlSize :: !Size, -- ^ The size the formatted text takes. @@ -228,20 +230,39 @@ -- | The definition of a loaded image. data ImageDef = ImageDef { - _idfName :: Text, -- ^ The logic name of the image. + _idfName :: Text, -- ^ The logic name of the image. _idfSize :: Size, -- ^ The dimensions of the image. _idfImgData :: BS.ByteString, -- ^ The image data as RGBA 4-bytes blocks. _idfFlags :: [ImageFlag] -- ^ The image flags. } deriving (Eq, Show, Generic) --- | Text metrics related functions. +{-| +Text metrics related functions. + +Two different versions of each function exist: + +- Default one, without underscore, does not apply scaling. +- Version with a trailing underscore, that receives an extra scale argument. + +In case the text is going to be rendered with a scale factor applied on +'Renderer' (by calling 'setScale'), it is recommended to apply the scale here +too (otherwise there will be differences in size and positioning). In most use +cases these functions will never be called, preferring the non underscore +versions. +-} data FontManager = FontManager { -- | Returns the text metrics of a given font and size. computeTextMetrics :: Font -> FontSize -> TextMetrics, + -- | Returns the text metrics of a given font and size, applying scale. + computeTextMetrics_ :: Double -> Font -> FontSize -> TextMetrics, -- | Returns the size of the line of text given font and size. computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size, + -- | Returns the size of the line of text given font and size, applying scale. + computeTextSize_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Size, -- | Returns the glyphs of the line of text given font and size. - computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos + computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos, + -- | Returns the glyphs of the line of text given font and size, applying scale. + computeGlyphsPos_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos } -- | Low level rendering definitions. diff --git a/src/Monomer/Helper.hs b/src/Monomer/Helper.hs --- a/src/Monomer/Helper.hs +++ b/src/Monomer/Helper.hs @@ -9,6 +9,8 @@ Helper functions used across the library. They do not belong to any specific module and are not directly exported. -} +{-# LANGUAGE BangPatterns #-} + module Monomer.Helper where import Control.Exception (SomeException, catch) @@ -20,7 +22,8 @@ -- | Concats a list of Monoids or returns Nothing if empty. maybeConcat :: Monoid a => [a] -> Maybe a maybeConcat [] = Nothing -maybeConcat lst = Just (mconcat lst) +maybeConcat lst = Just merged where + !merged = mconcat lst -- | Runs an action until Nothing is returned, collecting the results in a list. collectJustM :: MonadIO m => m (Maybe a) -> m [a] @@ -68,3 +71,8 @@ -- | Catches any exception thrown by the provided action catchAny :: IO a -> (SomeException -> IO a) -> IO a catchAny = catch + +-- | Returns Just the first item if the list is not empty, Nothing otherwise. +headMay :: [a] -> Maybe a +headMay [] = Nothing +headMay (x : _) = Just x diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs --- a/src/Monomer/Main/Core.hs +++ b/src/Monomer/Main/Core.hs @@ -19,11 +19,11 @@ startApp ) where -import Control.Concurrent (MVar, forkIO, forkOS, newMVar, threadDelay) +import Control.Concurrent import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan) +import Control.Exception import Control.Lens ((&), (^.), (.=), (.~), use) import Control.Monad (unless, void, when) -import Control.Monad.Catch import Control.Monad.Extra import Control.Monad.State import Control.Monad.STM (atomically) @@ -32,9 +32,12 @@ import Data.Map (Map) import Data.List (foldl') import Data.Text (Text) +import Data.Time +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Graphics.GL import qualified Data.Map as Map -import qualified Graphics.Rendering.OpenGL as GL +import qualified Data.Text as T import qualified SDL import qualified Data.Sequence as Seq @@ -71,18 +74,16 @@ data MainLoopArgs sp e ep = MainLoopArgs { _mlOS :: Text, - _mlRenderer :: Maybe Renderer, _mlTheme :: Theme, - _mlAppStartTs :: Int, + _mlAppStartTs :: Millisecond, _mlMaxFps :: Int, - _mlLatestRenderTs :: Int, - _mlFrameStartTs :: Int, - _mlFrameAccumTs :: Int, + _mlLatestRenderTs :: Millisecond, + _mlFrameStartTs :: Millisecond, + _mlFrameAccumTs :: Millisecond, _mlFrameCount :: Int, _mlExitEvents :: [e], _mlWidgetRoot :: WidgetNode sp ep, - _mlWidgetShared :: MVar (Map Text WidgetShared), - _mlChannel :: TChan (RenderMsg sp ep) + _mlWidgetShared :: MVar (Map Text WidgetShared) } data RenderState s e = RenderState { @@ -134,7 +135,8 @@ dpr <- use L.dpr winSize <- use L.windowSize - let useRenderThread = fromMaybe True (_apcUseRenderThread config) + let useRenderThreadFlag = fromMaybe True (_apcUseRenderThread config) + let useRenderThread = useRenderThreadFlag && rtsSupportsBoundThreads let maxFps = fromMaybe 60 (_apcMaxFps config) let fonts = _apcFonts config let theme = fromMaybe def (_apcTheme config) @@ -142,18 +144,16 @@ let mainBtn = fromMaybe BtnLeft (_apcMainButton config) let contextBtn = fromMaybe BtnRight (_apcContextButton config) - startTs <- fmap fromIntegral SDL.ticks + appStartTs <- getCurrentTimestamp model <- use L.mainModel os <- liftIO getPlatform widgetSharedMVar <- liftIO $ newMVar Map.empty - renderer <- if useRenderThread - then return Nothing - else liftIO $ Just <$> makeRenderer fonts dpr fontManager <- liftIO $ makeFontManager fonts dpr let wenv = WidgetEnv { _weOs = os, _weDpr = dpr, + _weAppStartTs = appStartTs, _weFontManager = fontManager, _weFindBranchByPath = const Seq.empty, _weMainButton = mainBtn, @@ -170,7 +170,7 @@ _weMainBtnPress = Nothing, _weModel = model, _weInputStatus = def, - _weTimestamp = startTs, + _weTimestamp = 0, _weThemeChanged = False, _weInTopLayer = const True, _weLayoutDirection = LayoutNone, @@ -180,33 +180,66 @@ let pathReadyRoot = widgetRoot & L.info . L.path .~ rootPath & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) rootPath + let makeMainThreadRenderer = do + renderer <- liftIO $ makeRenderer fonts dpr + L.renderMethod .= Left renderer + return RenderSetupSingle + setupRes <- if useRenderThread + then do + stpChan <- liftIO newTChanIO + + liftIO . void . forkOS $ + {- + The wenv and widgetRoot values are not used, since they are replaced + during MsgInit. Kept to avoid issues with the Strict pragma. + -} + startRenderThread stpChan channel window glCtx fonts dpr wenv widgetRoot + + setupRes <- liftIO . atomically $ readTChan stpChan + + case setupRes of + RenderSetupMakeCurrentFailed msg -> do + liftIO . putStrLn $ "Setup of the rendering thread failed: " ++ msg + liftIO . putStrLn $ "Falling back to rendering in the main thread. " + ++ "The content may not be updated while resizing the window." + + makeMainThreadRenderer + _ -> do + return RenderSetupMulti + else do + makeMainThreadRenderer + handleResourcesInit (newWenv, newRoot, _) <- handleWidgetInit wenv pathReadyRoot + {- + Deferred initialization step to account for Widgets that rely on OpenGL. They + need the Renderer to be setup before handleWidgetInit is called, and it is + safer to initialize the watcher after this happens. + -} + case setupRes of + RenderSetupMulti -> do + liftIO . atomically $ writeTChan channel (MsgInit newWenv newRoot) + liftIO $ watchWindowResize channel + _ -> return () + let loopArgs = MainLoopArgs { _mlOS = os, - _mlRenderer = renderer, _mlTheme = theme, _mlMaxFps = maxFps, - _mlAppStartTs = 0, + _mlAppStartTs = appStartTs, _mlLatestRenderTs = 0, - _mlFrameStartTs = startTs, + _mlFrameStartTs = 0, _mlFrameAccumTs = 0, _mlFrameCount = 0, _mlExitEvents = exitEvents, _mlWidgetRoot = newRoot, - _mlWidgetShared = widgetSharedMVar, - _mlChannel = channel + _mlWidgetShared = widgetSharedMVar } L.mainModel .= _weModel newWenv - when useRenderThread $ do - liftIO $ watchWindowResize channel - liftIO . void . forkOS $ - startRenderThread channel window glCtx fonts dpr newWenv newRoot - mainLoop window fontManager config loopArgs mainLoop @@ -219,7 +252,7 @@ mainLoop window fontManager config loopArgs = do let MainLoopArgs{..} = loopArgs - startTicks <- fmap fromIntegral SDL.ticks + startTs <- getEllapsedTimestampSince _mlAppStartTs events <- SDL.pumpEvents >> SDL.pollEvents windowSize <- use L.windowSize @@ -237,7 +270,7 @@ currWinSize <- liftIO $ getViewportSize window dpr let Size rw rh = windowSize - let ts = startTicks - _mlFrameStartTs + let ts = startTs - _mlFrameStartTs let eventsPayload = fmap SDL.eventPayload events let quit = SDL.QuitEvent `elem` eventsPayload @@ -264,8 +297,9 @@ let wenv = WidgetEnv { _weOs = _mlOS, _weDpr = dpr, + _weAppStartTs = _mlAppStartTs, _weFontManager = fontManager, - _weFindBranchByPath = findWidgetBranchByPath wenv _mlWidgetRoot, + _weFindBranchByPath = findChildBranchByPath wenv _mlWidgetRoot, _weMainButton = mainBtn, _weContextButton = contextBtn, _weTheme = _mlTheme, @@ -280,7 +314,7 @@ _weMainBtnPress = mainPress, _weModel = currentModel, _weInputStatus = inputStatus, - _weTimestamp = startTicks, + _weTimestamp = startTs, _weThemeChanged = False, _weInTopLayer = const True, _weLayoutDirection = LayoutNone, @@ -305,37 +339,38 @@ handleResizeWidgets (seWenv, seRoot, Seq.empty) else return (seWenv, seRoot, Seq.empty) - endTicks <- fmap fromIntegral SDL.ticks + endTs <- getEllapsedTimestampSince _mlAppStartTs -- Rendering - renderCurrentReq <- checkRenderCurrent startTicks _mlLatestRenderTs + renderCurrentReq <- checkRenderCurrent startTs _mlLatestRenderTs - let useRenderThread = fromMaybe True (_apcUseRenderThread config) let renderEvent = any isActionEvent eventsPayload let winRedrawEvt = windowResized || windowExposed let renderNeeded = winRedrawEvt || renderEvent || renderCurrentReq - when (renderNeeded && useRenderThread) $ - liftIO . atomically $ writeTChan _mlChannel (MsgRender newWenv newRoot) + when renderNeeded $ do + renderMethod <- use L.renderMethod - when (renderNeeded && not useRenderThread) $ do - let renderer = fromJust _mlRenderer - let bgColor = newWenv ^. L.theme . L.clearColor + case renderMethod of + Right renderChan -> do + liftIO . atomically $ writeTChan renderChan (MsgRender newWenv newRoot) + Left renderer -> do + let bgColor = newWenv ^. L.theme . L.clearColor - liftIO $ renderWidgets window dpr renderer bgColor newWenv newRoot + liftIO $ renderWidgets window dpr renderer bgColor newWenv newRoot + -- Used in the next rendering cycle L.renderRequested .= windowResized let fps = realToFrac _mlMaxFps let frameLength = round (1000000 / fps) - let remainingMs = endTicks - startTicks - let tempDelay = abs (frameLength - remainingMs * 1000) + let remainingMs = endTs - startTs + let tempDelay = abs (frameLength - fromIntegral remainingMs * 1000) let nextFrameDelay = min frameLength tempDelay - let latestRenderTs = if renderNeeded then startTicks else _mlLatestRenderTs + let latestRenderTs = if renderNeeded then startTs else _mlLatestRenderTs let newLoopArgs = loopArgs { - _mlAppStartTs = _mlAppStartTs + ts, _mlLatestRenderTs = latestRenderTs, - _mlFrameStartTs = startTicks, + _mlFrameStartTs = startTs, _mlFrameAccumTs = if newSecond then 0 else _mlFrameAccumTs + ts, _mlFrameCount = if newSecond then 0 else _mlFrameCount + 1, _mlWidgetRoot = newRoot @@ -350,9 +385,18 @@ unless shouldQuit (mainLoop window fontManager config newLoopArgs) +{- +Attempts to initialize a GL context in a separate OS thread to handle rendering +actions. This allows for continuous content updates when the user resizes the +window. + +In case the setup fails, it notifies the parent process so it can fall back to +rendering in the main thread. +-} startRenderThread :: (Eq s, WidgetEvent e) - => TChan (RenderMsg s e) + => TChan RenderSetupResult + -> TChan (RenderMsg s e) -> SDL.Window -> SDL.GLContext -> [FontDef] @@ -360,12 +404,23 @@ -> WidgetEnv s e -> WidgetNode s e -> IO () -startRenderThread channel window glCtx fonts dpr wenv root = do - SDL.glMakeCurrent window glCtx - renderer <- liftIO $ makeRenderer fonts dpr - fontMgr <- liftIO $ makeFontManager fonts dpr +startRenderThread setupChan msgChan window glCtx fonts dpr wenv root = do + resp <- try $ SDL.glMakeCurrent window glCtx - waitRenderMsg channel window renderer fontMgr state + case resp of + Right{} -> do + renderer <- liftIO $ makeRenderer fonts dpr + fontMgr <- liftIO $ makeFontManager fonts dpr + + atomically $ writeTChan setupChan RenderSetupMulti + + waitRenderMsg msgChan window renderer fontMgr state + Left (SDL.SDLCallFailed _ _ err) -> do + let msg = T.unpack err + atomically $ writeTChan setupChan (RenderSetupMakeCurrentFailed msg) + Left e -> do + let msg = displayException e + atomically $ writeTChan setupChan (RenderSetupMakeCurrentFailed msg) where state = RenderState dpr wenv root @@ -377,10 +432,10 @@ -> FontManager -> RenderState s e -> IO () -waitRenderMsg channel window renderer fontMgr state = do - msg <- liftIO . atomically $ readTChan channel +waitRenderMsg msgChan window renderer fontMgr state = do + msg <- atomically $ readTChan msgChan newState <- handleRenderMsg window renderer fontMgr state msg - waitRenderMsg channel window renderer fontMgr newState + waitRenderMsg msgChan window renderer fontMgr newState handleRenderMsg :: (Eq s, WidgetEvent e) @@ -390,6 +445,9 @@ -> RenderState s e -> RenderMsg s e -> IO (RenderState s e) +handleRenderMsg window renderer fontMgr state (MsgInit newWenv newRoot) = do + let RenderState dpr _ _ = state + return (RenderState dpr newWenv newRoot) handleRenderMsg window renderer fontMgr state (MsgRender tmpWenv newRoot) = do let RenderState dpr _ _ = state let newWenv = tmpWenv @@ -434,13 +492,10 @@ 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) - - GL.viewport GL.$= (position, size) + glViewport 0 0 (round dwW) (round dwH) - GL.clearColor GL.$= clearColor4 - GL.clear [GL.ColorBuffer] + glClearColor r g b a + glClear GL_COLOR_BUFFER_BIT beginFrame renderer vpW vpH widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer @@ -459,8 +514,7 @@ r = fromIntegral (clearColor ^. L.r) / 255 g = fromIntegral (clearColor ^. L.g) / 255 b = fromIntegral (clearColor ^. L.b) / 255 - a = clearColor ^. L.a - clearColor4 = GL.Color4 r g b (realToFrac a) + a = realToFrac (clearColor ^. L.a) watchWindowResize :: TChan (RenderMsg s e) -> IO () watchWindowResize channel = do @@ -473,7 +527,7 @@ atomically $ writeTChan channel (MsgResize newSize) _ -> return () -checkRenderCurrent :: (MonomerM s e m) => Int -> Int -> m Bool +checkRenderCurrent :: (MonomerM s e m) => Millisecond -> Millisecond -> m Bool checkRenderCurrent currTs renderTs = do renderCurrent <- use L.renderRequested schedule <- use L.renderSchedule @@ -483,14 +537,14 @@ requiresRender = renderScheduleReq currTs renderTs renderNext schedule = any requiresRender schedule -renderScheduleReq :: Int -> Int -> RenderSchedule -> Bool +renderScheduleReq :: Millisecond -> Millisecond -> RenderSchedule -> Bool renderScheduleReq currTs renderTs schedule = required where RenderSchedule _ start ms _ = schedule stepCount = floor (fromIntegral (currTs - start) / fromIntegral ms) stepTs = start + ms * stepCount required = renderTs < stepTs -renderScheduleActive :: Int -> RenderSchedule -> Bool +renderScheduleActive :: Millisecond -> RenderSchedule -> Bool renderScheduleActive currTs schedule = scheduleActive where RenderSchedule _ start ms count = schedule stepCount = floor (fromIntegral (currTs - start) / fromIntegral ms) @@ -507,3 +561,13 @@ isMouseEntered :: [SDL.EventPayload] -> Bool isMouseEntered eventsPayload = not status where status = null [ e | e@SDL.WindowGainedMouseFocusEvent {} <- eventsPayload ] + +getCurrentTimestamp :: MonadIO m => m Millisecond +getCurrentTimestamp = toMs <$> liftIO getCurrentTime + where + toMs = floor . (1e3 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds + +getEllapsedTimestampSince :: MonadIO m => Millisecond -> m Millisecond +getEllapsedTimestampSince start = do + ts <- getCurrentTimestamp + return (ts - start) diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs --- a/src/Monomer/Main/Handlers.hs +++ b/src/Monomer/Main/Handlers.hs @@ -39,7 +39,6 @@ import Data.Sequence (Seq(..), (|>)) import Data.Text (Text) import Data.Typeable (Typeable, typeOf) -import Safe (headMay) import SDL (($=)) import qualified Data.Map as Map @@ -52,7 +51,8 @@ import Monomer.Core import Monomer.Event -import Monomer.Helper (seqStartsWith) +import Monomer.Graphics +import Monomer.Helper (headMay, seqStartsWith) import Monomer.Main.Types import Monomer.Main.Util @@ -89,7 +89,7 @@ let (curWenv, curRoot, curReqs) = curStep let target = fromMaybe focused evtTarget let curWidget = curRoot ^. L.widget - let targetWni = evtTarget >>= findWidgetByPath curWenv curRoot + let targetWni = evtTarget >>= findChildNodeInfoByPath curWenv curRoot let targetWid = (^. L.widgetId) <$> targetWni when (isOnEnter evt) $ @@ -108,7 +108,7 @@ & L.hoveredPath .~ hoveredPath & L.mainBtnPress .~ mainBtnPress & L.inputStatus .~ inputStatus - let findBranchByPath path = findWidgetBranchByPath tmpWenv curRoot path + let findBranchByPath path = findChildBranchByPath tmpWenv curRoot path let newWenv = tmpWenv & L.findBranchByPath .~ findBranchByPath (wenv2, root2, reqs2) <- handleSystemEvent newWenv curRoot evt target @@ -260,7 +260,7 @@ -> m (HandlerStep s e) -- ^ Updated state/"HandlerStep". handleResizeWidgets previousStep = do windowSize <- use L.windowSize - resizeCheckFn <- makeResizeChechFn + resizeCheckFn <- makeResizeCheckFn let viewport = Rect 0 0 (windowSize ^. L.w) (windowSize ^. L.h) let (wenv, root, reqs) = previousStep @@ -277,7 +277,7 @@ return (wenv2, root2, reqs <> reqs2) where - makeResizeChechFn = do + makeResizeCheckFn = do resizeRequests <- use L.resizeRequests paths <- mapM getWidgetIdPath resizeRequests let parts = Set.fromDistinctAscList . drop 1 . toList . Seq.inits @@ -518,7 +518,7 @@ handleRenderEvery :: MonomerM s e m => WidgetId - -> Int + -> Millisecond -> Maybe Int -> HandlerStep s e -> m (HandlerStep s e) @@ -548,9 +548,12 @@ handleRemoveRendererImage :: MonomerM s e m => Text -> HandlerStep s e -> m (HandlerStep s e) handleRemoveRendererImage name previousStep = do - renderChannel <- use L.renderChannel + renderMethod <- use L.renderMethod - liftIO . atomically $ writeTChan renderChannel (MsgRemoveImage name) + case renderMethod of + Left renderer -> liftIO $ deleteImage renderer name + Right chan -> liftIO . atomically $ writeTChan chan (MsgRemoveImage name) + return previousStep handleExitApplication @@ -662,9 +665,17 @@ -> HandlerStep s e -> m (HandlerStep s e) handleRunInRenderThread widgetId path handler previousStep = do - renderChannel <- use L.renderChannel + renderMethod <- use L.renderMethod - handleRunTask widgetId path (taskWrapper renderChannel) previousStep + task <- case renderMethod of + Left renderer -> do + -- Force running in main thread to avoid issues with OpenGL + result <- liftIO handler + return (return result) + Right chan -> do + return $ liftIO (taskWrapper chan) + + handleRunTask widgetId path task previousStep where taskWrapper renderChannel = do msgChan <- newTChanIO @@ -829,7 +840,7 @@ restartPath = fromMaybe emptyPath overlay candidateWni = widgetFindNextFocus widget wenv widgetRoot dir start fromRootWni = widgetFindNextFocus widget wenv widgetRoot dir restartPath - focusWni = fromMaybe def (findWidgetByPath wenv widgetRoot start) + focusWni = fromMaybe def (findChildNodeInfoByPath wenv widgetRoot start) nextFocus = candidateWni <|> fromRootWni <|> Just focusWni dropNonParentWidgetId diff --git a/src/Monomer/Main/Platform.hs b/src/Monomer/Main/Platform.hs --- a/src/Monomer/Main/Platform.hs +++ b/src/Monomer/Main/Platform.hs @@ -22,6 +22,7 @@ getDisplayDPI ) where +import Control.Exception (finally) import Control.Monad (void) import Control.Monad.Extra (whenJust) import Control.Monad.State @@ -38,6 +39,8 @@ import qualified SDL.Input.Mouse as Mouse import qualified SDL.Raw as Raw import qualified SDL.Raw.Error as SRE +import qualified SDL.Internal.Types as SIT +import qualified SDL.Video.Renderer as SVR import Monomer.Common import Monomer.Core.StyleTypes @@ -65,10 +68,15 @@ platform <- getPlatform initDpiAwareness - factor <- case platform of + + baseFactor <- case platform of "Windows" -> getWindowsFactor "Linux" -> getLinuxFactor _ -> return 1 -- macOS + + let factor + | disableAutoScale = 1 + | otherwise = baseFactor let (winW, winH) = (factor * fromIntegral baseW, factor * fromIntegral baseH) window <- @@ -91,6 +99,8 @@ | platform `elem` ["Windows", "Linux"] = (scaleFactor, 1 / scaleFactor) | otherwise = (scaleFactor * contentRatio, 1 / scaleFactor) -- macOS + setWindowIcon window config + whenJust (_apcWindowTitle config) $ \title -> SDL.windowTitle window $= title @@ -123,6 +133,7 @@ } compositingFlag = fromMaybe False (_apcDisableCompositing config) userScaleFactor = fromMaybe 1 (_apcScaleFactor config) + disableAutoScale = _apcDisableAutoScale config == Just True (baseW, baseH) = case _apcWindowState config of Just (MainWindowNormal size) -> size _ -> defaultWindowSize @@ -135,6 +146,16 @@ Just MainWindowMaximized -> True _ -> False +setWindowIcon :: SDL.Window -> AppConfig e -> IO () +setWindowIcon (SIT.Window winPtr) config = + forM_ (_apcWindowIcon config) $ \iconPath -> do + iconSurface <- SVR.loadBMP (T.unpack iconPath) + let SVR.Surface iconSurfacePtr _ = iconSurface + finally + -- Note: this can use the high-level setWindowIcon once it is available (https://github.com/haskell-game/sdl2/pull/243) + (Raw.setWindowIcon winPtr iconSurfacePtr) + (SVR.freeSurface iconSurface) + -- | Destroys the provided window, shutdowns the video subsystem and SDL. detroySDLWindow :: SDL.Window -> IO () detroySDLWindow window = do @@ -194,28 +215,32 @@ vdpi <- peek pvdpi return (realToFrac ddpi, realToFrac hdpi, realToFrac vdpi) --- | Returns the default resize factor for Windows +-- | Returns the default resize factor for Windows. getWindowsFactor :: IO Double -getWindowsFactor = do - (ddpi, hdpi, vdpi) <- getDisplayDPI - return (hdpi / 96) +getWindowsFactor = max 1 <$> getDisplayDPIFactor -{-| -Returns a resizing factor to handle HiDPI on Linux. Currently only tested on -Wayland (Ubuntu 21.04). --} +-- | Returns the default resize factor for Linux. getLinuxFactor :: IO Double -getLinuxFactor = +getLinuxFactor = do + dpiFactor <- getDisplayDPIFactor + alloca $ \pmode -> do Raw.getCurrentDisplayMode 0 pmode mode <- peek pmode + let width = Raw.displayModeW mode - -- Applies scale in half steps (1, 1.5, 2, etc) - let baseFactor = 2 * fromIntegral width / 1920 + let detectedDPI + | dpiFactor > 0 = dpiFactor + | width <= 1920 = 1 + | otherwise = 2 - if width <= 1920 - then return 1 - else return (fromIntegral (ceiling baseFactor) / 2) + return detectedDPI + +-- | Returns DPI scaling factor using SDL_GetDisplayDPI. +getDisplayDPIFactor :: IO Double +getDisplayDPIFactor = do + (ddpi, hdpi, vdpi) <- getDisplayDPI + return (hdpi / 96) setDisableCompositorHint :: Bool -> IO () setDisableCompositorHint disable = void $ diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs --- a/src/Monomer/Main/Types.hs +++ b/src/Monomer/Main/Types.hs @@ -47,11 +47,19 @@ -- | Messages received by the rendering thread. data RenderMsg s e - = MsgRender (WidgetEnv s e) (WidgetNode s e) + = MsgInit (WidgetEnv s e) (WidgetNode s e) + | MsgRender (WidgetEnv s e) (WidgetNode s e) | MsgResize Size | MsgRemoveImage Text | forall i . MsgRunInRender (TChan i) (IO i) +-- | Result from attempting to set up the secondary rendering thread. +data RenderSetupResult + = RenderSetupSingle + | RenderSetupMulti + | RenderSetupMakeCurrentFailed String + deriving (Eq, Show) + {-| Requirements for periodic rendering by a widget. Start time is stored to calculate next frame based on the step ms. A maximum number of repetitions may @@ -59,8 +67,8 @@ -} data RenderSchedule = RenderSchedule { _rsWidgetId :: WidgetId, - _rsStart :: Int, - _rsMs :: Int, + _rsStart :: Millisecond, + _rsMs :: Millisecond, _rsRepeat :: Maybe Int } deriving (Eq, Show, Generic) @@ -93,8 +101,8 @@ _mcDpr :: Double, -- | Event pixel rate. _mcEpr :: Double, - -- | Event pixel rate. - _mcRenderChannel :: TChan (RenderMsg s e), + -- | Renderer instance or communication channel with the render thread. + _mcRenderMethod :: Either Renderer (TChan (RenderMsg s e)), -- | Input status (mouse and keyboard). _mcInputStatus :: InputStatus, -- | Cursor icons (a stack is used because of parent -> child relationship). @@ -153,6 +161,8 @@ _apcWindowResizable :: Maybe Bool, -- | Whether the main window has a border. _apcWindowBorder :: Maybe Bool, + -- | Path to an icon file in BMP format. + _apcWindowIcon :: Maybe Text, -- | Whether a separate render thread should be used. Defaults to True. _apcUseRenderThread :: Maybe Bool, {-| @@ -163,11 +173,15 @@ _apcMaxFps :: Maybe Int, {-| Scale factor to apply. This factor only affects the content, not the size of - the window. It is applied in addition to the OS zoom in plaforms where it is - reliably detected (i.e., system scaling may not be detected reliably on Linux) + the window. It is applied in addition to the detected display scaling. -} _apcScaleFactor :: Maybe Double, {-| + Whether display scaling detection should not be attempted. If set to True, the + display scale will be set to 1. This works together with 'appScaleFactor'. + -} + _apcDisableAutoScale :: Maybe Bool, + {-| Available fonts to the application. An empty list will make it impossible to render text. -} @@ -200,9 +214,11 @@ _apcWindowTitle = Nothing, _apcWindowResizable = Nothing, _apcWindowBorder = Nothing, + _apcWindowIcon = Nothing, _apcUseRenderThread = Nothing, _apcMaxFps = Nothing, _apcScaleFactor = Nothing, + _apcDisableAutoScale = Nothing, _apcFonts = [], _apcTheme = Nothing, _apcInitEvent = [], @@ -222,9 +238,11 @@ _apcWindowTitle = _apcWindowTitle a2 <|> _apcWindowTitle a1, _apcWindowResizable = _apcWindowResizable a2 <|> _apcWindowResizable a1, _apcWindowBorder = _apcWindowBorder a2 <|> _apcWindowBorder a1, + _apcWindowIcon = _apcWindowIcon a2 <|> _apcWindowIcon a1, _apcUseRenderThread = _apcUseRenderThread a2 <|> _apcUseRenderThread a1, _apcMaxFps = _apcMaxFps a2 <|> _apcMaxFps a1, _apcScaleFactor = _apcScaleFactor a2 <|> _apcScaleFactor a1, + _apcDisableAutoScale = _apcDisableAutoScale a2 <|> _apcDisableAutoScale a1, _apcFonts = _apcFonts a1 ++ _apcFonts a2, _apcTheme = _apcTheme a2 <|> _apcTheme a1, _apcInitEvent = _apcInitEvent a1 ++ _apcInitEvent a2, @@ -265,16 +283,32 @@ _apcWindowBorder = Just border } +-- | Path to an icon file in BMP format. +appWindowIcon :: Text -> AppConfig e +appWindowIcon path = def { + _apcWindowIcon = Just path +} + {-| Performs rendering on the main thread. On macOS and Windows this also disables continuous rendering on window resize, but in some Linux configurations it still works. -This option is useful when OpenGL driver issues prevent normal startup showing -the "Unable to make GL context current" error. +This configuration option was originally available to handle: -It can also be used for single threaded applications (without -threaded). + - OpenGL driver issues which prevented normal startup showing the "Unable to + make GL context current" error. + - Single threaded applications (without -threaded) which cannot use forkOS. + +This flag is no longer necessary for those cases, since the library will: + + - Attempt to fall back to rendering on the main thread if setting up a + secondary rendering thread fails. + - Will not attempt to set up a secondary rendering thread if the runtime does + not support bound threads (i.e. compiled without the -threaded flag). -} +{-# DEPRECATED appRenderOnMainThread + "Should no longer be needed. Check appRenderOnMainThread's Haddock page." #-} appRenderOnMainThread :: AppConfig e appRenderOnMainThread = def { _apcUseRenderThread = Just False @@ -291,13 +325,56 @@ } {-| -Scale factor to apply. This factor only affects the content, not the size of the -window. It is applied in addition to the OS zoom in plaforms where it is -reliably detected (i.e., system scaling may not be detected reliably on Linux). +Scale factor to apply to the viewport. This factor only affects the content, not +the size of the window. It is applied in addition to the detected display scale +factor, and can be useful if the detected value is not the desired. -} appScaleFactor :: Double -> AppConfig e appScaleFactor factor = def { _apcScaleFactor = Just factor +} + +{-| +Whether display scaling detection should not be attempted. If set to True, the +display scale will be set to 1. This flag does not cause an effect on macOS. + +Disabling auto scaling also affects window size on Linux and Windows in the +cases where the library would have applied scaling. This happens because window +and viewport size are the same in those operating systems. Window size can be +adjusted with 'appWindowState'. + +The logic for detecting display scaling varies depending on the platform: + +__macOS__ + +Scaling can be detected based on the window size and viewport size; the ratio +between these two give the scaling factor. + +Using window and viewport size for detecting DPI only works on macOS; both +Windows and Linux return the same value for window and viewport size. + +__Windows__ + +SDL_GetDisplayDPI returns the DPI of the screen, and dividing by 96 gives the +scaling factor. This factor is used to scale the window size and the content. + +__Linux__ + +The situation is more complex, since SDL_GetDisplayDPI does not always return +valid information. There is not a practical DPI/scale detection solution that +works for all combinations of Linux display servers and window managers. Even +when using the most popular window managers, the scaling factor may be handled +differently by the distribution (GNOME in Ubuntu). For a reference of some of +the existing options for DPI scaling detection, check here: +https://wiki.archlinux.org/title/HiDPI. + +Considering the above, when SDL_GetDisplayDPI fails, the library assumes that a +screen width larger than 1920 belongs to an HiDPI display and uses a scale +factor of 2. This factor is used to scale the window size and the content. +-} +appDisableAutoScale :: Bool -> AppConfig e +appDisableAutoScale disable = def { + _apcDisableAutoScale = Just disable } {-| diff --git a/src/Monomer/Main/Util.hs b/src/Monomer/Main/Util.hs --- a/src/Monomer/Main/Util.hs +++ b/src/Monomer/Main/Util.hs @@ -21,15 +21,14 @@ import Control.Monad.State import Data.Default import Data.Maybe -import Safe (headMay) import qualified Data.Sequence as Seq import qualified Data.Map as Map -import qualified Graphics.Rendering.OpenGL as GL import qualified SDL import Monomer.Core import Monomer.Event +import Monomer.Helper (headMay) import Monomer.Main.Platform import Monomer.Main.Types import Monomer.Widgets.Util.Widget @@ -52,7 +51,7 @@ _mcWindowSize = winSize, _mcDpr = dpr, _mcEpr = epr, - _mcRenderChannel = channel, + _mcRenderMethod = Right channel, _mcInputStatus = def, _mcCursorStack = [], _mcFocusedWidgetId = def, diff --git a/src/Monomer/Widgets.hs b/src/Monomer/Widgets.hs --- a/src/Monomer/Widgets.hs +++ b/src/Monomer/Widgets.hs @@ -9,12 +9,13 @@ Widgets module, grouping and re-exporting all the existing widgets. -} module Monomer.Widgets ( + -- * Composite widget module Monomer.Widgets.Composite, - + -- * Animation module Monomer.Widgets.Animation.Fade, module Monomer.Widgets.Animation.Slide, module Monomer.Widgets.Animation.Types, - + -- * Containers module Monomer.Widgets.Containers.Alert, module Monomer.Widgets.Containers.Box, module Monomer.Widgets.Containers.Confirm, @@ -30,7 +31,7 @@ module Monomer.Widgets.Containers.ThemeSwitch, module Monomer.Widgets.Containers.Tooltip, module Monomer.Widgets.Containers.ZStack, - + -- * Single widgets module Monomer.Widgets.Singles.Button, module Monomer.Widgets.Singles.Checkbox, module Monomer.Widgets.Singles.ColorPicker, diff --git a/src/Monomer/Widgets/Animation/Fade.hs b/src/Monomer/Widgets/Animation/Fade.hs --- a/src/Monomer/Widgets/Animation/Fade.hs +++ b/src/Monomer/Widgets/Animation/Fade.hs @@ -54,7 +54,7 @@ -} data FadeCfg e = FadeCfg { _fdcAutoStart :: Maybe Bool, - _fdcDuration :: Maybe Int, + _fdcDuration :: Maybe Millisecond, _fdcOnFinished :: [e] } deriving (Eq, Show) @@ -80,7 +80,7 @@ _fdcAutoStart = Just start } -instance CmbDuration (FadeCfg e) Int where +instance CmbDuration (FadeCfg e) Millisecond where duration dur = def { _fdcDuration = Just dur } @@ -92,7 +92,7 @@ data FadeState = FadeState { _fdsRunning :: Bool, - _fdsStartTs :: Int + _fdsStartTs :: Millisecond } deriving (Eq, Show, Generic) instance Default FadeState where @@ -141,7 +141,7 @@ autoStart = fromMaybe False (_fdcAutoStart config) duration = fromMaybe 500 (_fdcDuration config) period = 20 - steps = duration `div` period + steps = fromIntegral $ duration `div` period finishedReq node = delayedMessage node AnimationFinished duration renderReq wenv node = req where diff --git a/src/Monomer/Widgets/Animation/Slide.hs b/src/Monomer/Widgets/Animation/Slide.hs --- a/src/Monomer/Widgets/Animation/Slide.hs +++ b/src/Monomer/Widgets/Animation/Slide.hs @@ -66,7 +66,7 @@ data SlideCfg e = SlideCfg { _slcDirection :: Maybe SlideDirection, _slcAutoStart :: Maybe Bool, - _slcDuration :: Maybe Int, + _slcDuration :: Maybe Millisecond, _slcOnFinished :: [e] } deriving (Eq, Show) @@ -94,7 +94,7 @@ _slcAutoStart = Just start } -instance CmbDuration (SlideCfg e) Int where +instance CmbDuration (SlideCfg e) Millisecond where duration dur = def { _slcDuration = Just dur } @@ -122,7 +122,7 @@ data SlideState = SlideState { _slsRunning :: Bool, - _slsStartTs :: Int + _slsStartTs :: Millisecond } deriving (Eq, Show, Generic) instance Default SlideState where @@ -174,7 +174,7 @@ autoStart = fromMaybe False (_slcAutoStart config) duration = fromMaybe 500 (_slcDuration config) period = 20 - steps = duration `div` period + steps = fromIntegral $ duration `div` period finishedReq node = delayedMessage node AnimationFinished duration renderReq wenv node = req where diff --git a/src/Monomer/Widgets/Composite.hs b/src/Monomer/Widgets/Composite.hs --- a/src/Monomer/Widgets/Composite.hs +++ b/src/Monomer/Widgets/Composite.hs @@ -11,13 +11,15 @@ the need to implement a lower level widget. It can comunicate with its parent component by reporting events. -Requires two main functions: +Requires two functions: - UI Builder: creates the widget tree based on the provided Widget Environment and model. This widget tree is made of other widgets, in general combinations of containers and singles. - Event Handler: processes user defined events which are raised by the widgets created when building the UI. + +Composite is discussed in detail in the tutorials. -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} @@ -42,14 +44,16 @@ CompositeEvent, MergeRequired, MergeReqsHandler, - CompositeCustomModelBuilder, + MergeEventsHandler, + MergeModelHandler, EventHandler, UIBuilder, TaskHandler, ProducerHandler, CompMsgUpdate, compositeMergeReqs, - customModelBuilder, + compositeMergeEvents, + compositeMergeModel, -- * Constructors composite, @@ -93,26 +97,40 @@ type CompositeEvent e = WidgetEvent e -- | Checks if merging the composite is required. -type MergeRequired s - = s -- ^ Old composite model. - -> s -- ^ New composite model - -> Bool -- ^ True if merge is required. +type MergeRequired s e + = WidgetEnv s e -- ^ Widget environment. + -> s -- ^ Old composite model. + -> s -- ^ New composite model + -> Bool -- ^ True if merge is required. -- | Generates requests during the merge process. -type MergeReqsHandler s e +type MergeReqsHandler s e sp = WidgetEnv s e -- ^ Widget environment. -> WidgetNode s e -- ^ New widget node. -> WidgetNode s e -- ^ Old widget node. - -> s -- ^ The current model. + -> sp -- ^ Parent model. + -> s -- ^ Old composite model. + -> s -- ^ New composite model. -> [WidgetRequest s e] -- ^ The list of requests. --- | Creates a custom composite model from the parent model. -type CompositeCustomModelBuilder s sp - = sp -- ^ Parent model. - -> s -- ^ Old custom composite model. - -> s -- ^ New custom composite model. - -> s -- ^ Custom composite model. +-- | Generates events during the merge process. +type MergeEventsHandler s e sp + = WidgetEnv s e -- ^ Widget environment. + -> WidgetNode s e -- ^ New widget node. + -> WidgetNode s e -- ^ Old widget node. + -> sp -- ^ Parent model. + -> s -- ^ Old composite model. + -> s -- ^ New composite model. + -> [e] -- ^ The list of events. +-- | Allows updating the composite model with information from the parent model. +type MergeModelHandler s e sp + = WidgetEnv s e -- ^ Widget environment. + -> sp -- ^ Parent model. + -> s -- ^ Old composite model. + -> s -- ^ New composite model. + -> s -- ^ Updated composite model. + -- | Handles a composite event and returns a set of responses. type EventHandler s e sp ep = WidgetEnv s e @@ -193,51 +211,53 @@ {-| Configuration options for composite: +- 'onInit': event to raise when the widget is created. Useful for initializing + required resources. +- 'onDispose': event to raise when the widget is disposed. Useful for freeing + acquired resources. +- 'onResize': event to raise when the size of the widget changes. +- 'onChange': event to raise when the model changes. The value passed to the + provided event is the previous version of the model. The current version of + the model is always available as a parameter in the _handleEvent_ function. +- 'onChangeReq': 'WidgetRequest' to generate when the model changes. +- 'onEnabledChange': event to raise when the enabled status changes. +- 'onVisibleChange': event to raise when the visibility changes. - 'mergeRequired': indicates if merging is necessary for this widget. In case the UI build process references information outside the model, it can be used to signal that merging is required even if the model has not changed. It can also be used as a performance tweak if the changes do not require rebuilding the UI. -- 'onInit': event to raise when the widget is created. Useful for performing all - kinds of initialization. -- 'onDispose': event to raise when the widget is disposed. Used to free - resources. -- 'onResize': event to raise when the size of the widget changes. -- 'onChange': event to raise when the size of the model changes. -- 'onChangeReq': 'WidgetRequest' to generate when the size of the widget - changes. -- 'onEnabledChange': event to raise when the enabled status changes. -- 'onVisibleChange': event to raise when the visibility changes. - 'compositeMergeReqs': functions to generate WidgetRequests during the merge process. Since merge is already handled by Composite (by merging its tree), this is complementary for the cases when more control, and the previous version of the widget tree, is required. For example, it is used in 'Monomer.Widgets.Containers.Confirm' to set the focus on its Accept button - when visibility is restored (usually means it was brought to the front in a - zstack, and the visibility flag of the previous version needs to be checked). -- 'customModelBuilder': function for extracting a custom model from the current - parent model and the previous composite model. Useful when the composite needs - a more complex model than what the user is binding. + when visibility is restored (this usually means it was brought to the front in + a zstack, and the visibility flag of the previous version needs to be + checked). +- 'compositeMergeModel': Allows updating the composite model with information + from the parent model. Useful when the composite needs a more complex model + than what the user is binding. -} data CompositeCfg s e sp ep = CompositeCfg { - _cmcModelBuilder :: Maybe (CompositeCustomModelBuilder s sp), - _cmcMergeRequired :: Maybe (MergeRequired s), - _cmcMergeReqs :: [MergeReqsHandler s e], - _cmcOnInit :: [e], - _cmcOnDispose :: [e], + _cmcMergeRequired :: Maybe (MergeRequired s e), + _cmcMergeReqs :: [MergeReqsHandler s e sp], + _cmcMergeModel :: Maybe (MergeModelHandler s e sp), + _cmcOnInitReq :: [WidgetRequest s e], + _cmcOnDisposeReq :: [WidgetRequest s e], _cmcOnResize :: [Rect -> e], - _cmcOnChangeReq :: [s -> WidgetRequest sp ep], + _cmcOnChangeReq :: [s -> WidgetRequest s e], _cmcOnEnabledChange :: [e], _cmcOnVisibleChange :: [e] } instance Default (CompositeCfg s e sp ep) where def = CompositeCfg { - _cmcModelBuilder = Nothing, + _cmcMergeModel = Nothing, _cmcMergeRequired = Nothing, _cmcMergeReqs = [], - _cmcOnInit = [], - _cmcOnDispose = [], + _cmcOnInitReq = [], + _cmcOnDisposeReq = [], _cmcOnResize = [], _cmcOnChangeReq = [], _cmcOnEnabledChange = [], @@ -246,11 +266,11 @@ instance Semigroup (CompositeCfg s e sp ep) where (<>) c1 c2 = CompositeCfg { - _cmcModelBuilder = _cmcModelBuilder c2 <|> _cmcModelBuilder c1, + _cmcMergeModel = _cmcMergeModel c2 <|> _cmcMergeModel c1, _cmcMergeRequired = _cmcMergeRequired c2 <|> _cmcMergeRequired c1, _cmcMergeReqs = _cmcMergeReqs c1 <> _cmcMergeReqs c2, - _cmcOnInit = _cmcOnInit c1 <> _cmcOnInit c2, - _cmcOnDispose = _cmcOnDispose c1 <> _cmcOnDispose c2, + _cmcOnInitReq = _cmcOnInitReq c1 <> _cmcOnInitReq c2, + _cmcOnDisposeReq = _cmcOnDisposeReq c1 <> _cmcOnDisposeReq c2, _cmcOnResize = _cmcOnResize c1 <> _cmcOnResize c2, _cmcOnChangeReq = _cmcOnChangeReq c1 <> _cmcOnChangeReq c2, _cmcOnEnabledChange = _cmcOnEnabledChange c1 <> _cmcOnEnabledChange c2, @@ -260,32 +280,42 @@ instance Monoid (CompositeCfg s e sp ep) where mempty = def -instance CmbMergeRequired (CompositeCfg s e sp ep) s where +instance CmbMergeRequired (CompositeCfg s e sp ep) (WidgetEnv s e) s where mergeRequired fn = def { _cmcMergeRequired = Just fn } -instance CmbOnInit (CompositeCfg s e sp ep) e where +instance WidgetEvent e => CmbOnInit (CompositeCfg s e sp ep) e where onInit fn = def { - _cmcOnInit = [fn] + _cmcOnInitReq = [RaiseEvent fn] } -instance CmbOnDispose (CompositeCfg s e sp ep) e where +instance CmbOnInitReq (CompositeCfg s e sp ep) s e where + onInitReq req = def { + _cmcOnInitReq = [req] + } + +instance WidgetEvent e => CmbOnDispose (CompositeCfg s e sp ep) e where onDispose fn = def { - _cmcOnDispose = [fn] + _cmcOnDisposeReq = [RaiseEvent fn] } +instance CmbOnDisposeReq (CompositeCfg s e sp ep) s e where + onDisposeReq req = def { + _cmcOnDisposeReq = [req] + } + instance CmbOnResize (CompositeCfg s e sp ep) e Rect where onResize fn = def { _cmcOnResize = [fn] } -instance WidgetEvent ep => CmbOnChange (CompositeCfg s e sp ep) s ep where +instance WidgetEvent e => CmbOnChange (CompositeCfg s e sp ep) s e where onChange fn = def { _cmcOnChangeReq = [RaiseEvent . fn] } -instance CmbOnChangeReq (CompositeCfg s e sp ep) sp ep s where +instance CmbOnChangeReq (CompositeCfg s e sp ep) s e s where onChangeReq req = def { _cmcOnChangeReq = [req] } @@ -300,35 +330,58 @@ _cmcOnVisibleChange = [fn] } --- | Generate WidgetRequests during the merge process. -compositeMergeReqs :: MergeReqsHandler s e -> CompositeCfg s e sp ep +{-| +Generate WidgetRequests during the merge process. + +This function is not called during initialization; 'onInitReq' can be used. +-} +compositeMergeReqs :: MergeReqsHandler s e sp -> CompositeCfg s e sp ep compositeMergeReqs fn = def { _cmcMergeReqs = [fn] } {-| -Generates a custom model from the current parent model and the previous -composite model. Useful when the composite needs a more complex model than what -the user is binding. +Generate events during the merge process. + +This function is not called during initialization; 'onInit' can be used. -} -customModelBuilder - :: CompositeCustomModelBuilder s sp - -> CompositeCfg s e sp ep -customModelBuilder fn = def { - _cmcModelBuilder = Just fn +compositeMergeEvents + :: WidgetEvent e => MergeEventsHandler s e sp -> CompositeCfg s e sp ep +compositeMergeEvents fn = cfg where + cfg = def { + _cmcMergeReqs = [wrapper] + } + wrapper wenv node oldNode parentModel oldModel newModel + = RaiseEvent <$> fn wenv node oldNode parentModel oldModel newModel + +{-| +Allows updating the composite model with information from the parent model. +Useful when the composite needs a more complex model than what the user is +binding. + +For example, a database record may be binded as the model from the parent, but +the composite needs its own boolean flags to toggle visibility on different +sections. + +This function is called during both merge and init. On init, the oldModel will +be equal to the current model. +-} +compositeMergeModel :: MergeModelHandler s e sp -> CompositeCfg s e sp ep +compositeMergeModel fn = def { + _cmcMergeModel = Just fn } data Composite s e sp ep = Composite { _cmpWidgetData :: !(WidgetData sp s), _cmpEventHandler :: !(EventHandler s e sp ep), _cmpUiBuilder :: !(UIBuilder s e), - _cmpMergeRequired :: MergeRequired s, - _cmpMergeReqs :: [MergeReqsHandler s e], - _cmpModelBuilder :: Maybe (CompositeCustomModelBuilder s sp), - _cmpOnInit :: [e], - _cmpOnDispose :: [e], + _cmpMergeRequired :: MergeRequired s e, + _cmpMergeReqs :: [MergeReqsHandler s e sp], + _cmpMergeModel :: Maybe (MergeModelHandler s e sp), + _cmpOnInitReq :: [WidgetRequest s e], + _cmpOnDisposeReq :: [WidgetRequest s e], _cmpOnResize :: [Rect -> e], - _cmpOnChangeReq :: [s -> WidgetRequest sp ep], + _cmpOnChangeReq :: [s -> WidgetRequest s e], _cmpOnEnabledChange :: [e], _cmpOnVisibleChange :: [e] } @@ -383,7 +436,7 @@ :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp) => WidgetType -- ^ The name of the composite. -> s -- ^ The model. - -> (s -> ep) -- ^ The event to report when model changes. + -> (s -> e) -- ^ The event to report when model changes. -> UIBuilder s e -- ^ The UI builder function. -> EventHandler s e sp ep -- ^ The event handler. -> WidgetNode sp ep -- ^ The resulting widget. @@ -398,7 +451,7 @@ :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp) => WidgetType -- ^ The name of the composite. -> s -- ^ The model. - -> (s -> ep) -- ^ The event to report when model changes. + -> (s -> e) -- ^ The event to report when model changes. -> UIBuilder s e -- ^ The UI builder function. -> EventHandler s e sp ep -- ^ The event handler. -> [CompositeCfg s e sp ep] -- ^ The config options. @@ -419,7 +472,7 @@ -> WidgetNode sp ep -- ^ The resulting widget. compositeD_ wType wData uiBuilder evtHandler configs = newNode where config = mconcat configs - mergeReq = fromMaybe (/=) (_cmcMergeRequired config) + mergeReq = fromMaybe (const (/=)) (_cmcMergeRequired config) !widgetRoot = spacer composite = Composite { _cmpWidgetData = wData, @@ -427,9 +480,9 @@ _cmpUiBuilder = uiBuilder, _cmpMergeRequired = mergeReq, _cmpMergeReqs = _cmcMergeReqs config, - _cmpModelBuilder = _cmcModelBuilder config, - _cmpOnInit = _cmcOnInit config, - _cmpOnDispose = _cmcOnDispose config, + _cmpMergeModel = _cmcMergeModel config, + _cmpOnInitReq = _cmcOnInitReq config, + _cmpOnDisposeReq = _cmcOnDisposeReq config, _cmpOnResize = _cmcOnResize config, _cmpOnChangeReq = _cmcOnChangeReq config, _cmpOnEnabledChange = _cmcOnEnabledChange config, @@ -472,11 +525,12 @@ compositeInit comp state wenv widgetComp = newResult where CompositeState{..} = state - !customModelBuilder = _cmpModelBuilder comp + !mergeModel = _cmpMergeModel comp !parentModel = wenv ^. L.model !userModel = getUserModel comp wenv - !model = case customModelBuilder of - Just buildCustomModel -> buildCustomModel parentModel userModel userModel + !model = case mergeModel of + Just merge -> merge cwenv parentModel userModel userModel where + !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap userModel _ -> userModel -- Creates UI using provided function @@ -491,11 +545,11 @@ _cpsWidgetKeyMap = collectWidgetKeys M.empty root } - !newEvts = RaiseEvent <$> Seq.fromList (_cmpOnInit comp) - getBaseStyle wenv node = Nothing styledComp = initNodeStyle getBaseStyle wenv widgetComp - tempResult = WidgetResult root (RenderOnce <| reqs <> newEvts) + + initReqs = Seq.fromList (_cmpOnInitReq comp) + tempResult = WidgetResult root (RenderOnce <| reqs <> initReqs) !newResult = toParentResult comp newState wenv styledComp tempResult -- | Merge @@ -513,11 +567,12 @@ validState = fromMaybe state (useState oldState) CompositeState oldModel oldRoot oldWidgetKeys = validState - !customModelBuilder = _cmpModelBuilder comp + !mergeModel = _cmpMergeModel comp !parentModel = wenv ^. L.model !userModel = getUserModel comp wenv - !model = case customModelBuilder of - Just buildCustomModel -> buildCustomModel parentModel (fromJust oldModel) userModel + !model = case mergeModel of + Just merge -> merge cwenv parentModel (fromJust oldModel) userModel where + cwenv = convertWidgetEnv wenv oldWidgetKeys userModel _ -> userModel -- Creates new UI using provided function @@ -527,7 +582,7 @@ -- Needed in case the user references something outside model when building UI -- The same model is provided as old since nothing else is available, but -- mergeRequired may be using data from a closure - modelChanged = _cmpMergeRequired comp (fromJust oldModel) model + modelChanged = _cmpMergeRequired comp cwenv (fromJust oldModel) model visibleChg = nodeVisibleChanged oldComp newComp enabledChg = nodeEnabledChanged oldComp newComp flagsChanged = visibleChg || enabledChg @@ -563,7 +618,8 @@ evts = RaiseEvent <$> Seq.fromList (visibleEvts ++ enabledEvts) mergeReqsFns = _cmpMergeReqs comp - mergeReqs = concatMap (\fn -> fn cwenv newRoot oldRoot model) mergeReqsFns + mergeHelper f = f cwenv newRoot oldRoot parentModel (fromJust oldModel) model + mergeReqs = concatMap mergeHelper mergeReqsFns extraReqs = seqCatMaybes (toParentReq widgetId <$> Seq.fromList mergeReqs) tmpResult = WidgetResult newRoot (RenderOnce <| tmpReqs <> extraReqs <> evts) @@ -586,10 +642,11 @@ model = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model widget = _cpsRoot ^. L.widget - newEvts = RaiseEvent <$> Seq.fromList (_cmpOnDispose comp) WidgetResult _ reqs = widgetDispose widget cwenv _cpsRoot - tempResult = WidgetResult _cpsRoot (reqs <> newEvts) + + disposeReqs = Seq.fromList (_cmpOnDisposeReq comp) + tempResult = WidgetResult _cpsRoot (reqs <> disposeReqs) result = toParentResult comp state wenv widgetComp tempResult compositeGetInstanceTree @@ -911,8 +968,9 @@ -> WidgetNode s e -> WidgetNode sp ep -> WidgetResult sp ep -mergeChild comp state wenv newModel widgetRoot widgetComp = newResult where +mergeChild comp state wenv newModel widgetRoot widgetComp = parentResult where CompositeState{..} = state + oldModel = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap newModel widgetId = _cpsRoot ^. L.info . L.widgetId builtRoot = cascadeCtx wenv widgetComp (_cmpUiBuilder comp cwenv newModel) @@ -927,12 +985,14 @@ _cpsRoot = mergedResult ^. L.node, _cpsWidgetKeyMap = collectWidgetKeys M.empty (mergedResult ^. L.node) } - !result = toParentResult comp mergedState wenv widgetComp mergedResult - !newReqs = widgetDataSet (_cmpWidgetData comp) newModel - ++ fmap ($ newModel) (_cmpOnChangeReq comp) + childReqs = fmap ($ oldModel) (_cmpOnChangeReq comp) + parentReqs = widgetDataSet (_cmpWidgetData comp) newModel ++ [ResizeWidgets widgetId | initRequired] - !newResult = result - & L.requests <>~ Seq.fromList newReqs + childResult = mergedResult + & L.requests <>~ Seq.fromList childReqs + result = toParentResult comp mergedState wenv widgetComp childResult + parentResult = result + & L.requests .~ Seq.fromList parentReqs <> result ^. L.requests getUserModel :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp) @@ -1001,6 +1061,7 @@ convertWidgetEnv wenv widgetKeyMap model = WidgetEnv { _weOs = _weOs wenv, _weDpr = _weDpr wenv, + _weAppStartTs = _weAppStartTs wenv, _weFontManager = _weFontManager wenv, _weFindBranchByPath = _weFindBranchByPath wenv, _weMainButton = _weMainButton wenv, diff --git a/src/Monomer/Widgets/Container.hs b/src/Monomer/Widgets/Container.hs --- a/src/Monomer/Widgets/Container.hs +++ b/src/Monomer/Widgets/Container.hs @@ -25,6 +25,7 @@ -- * Configuration ContainerGetBaseStyle, ContainerGetCurrentStyle, + ContainerCreateContainerFromModel, ContainerUpdateCWenvHandler, ContainerInitHandler, ContainerInitPostHandler, @@ -680,13 +681,13 @@ -> WidgetNode s e -> WidgetResult s e -> WidgetResult s e -mergeChildren updateCWenv !wenv !newNode !oldNode !result = newResult where - WidgetResult uNode uReqs = result +mergeChildren updateCWenv !wenv !newNode !oldNode !pResult = newResult where + WidgetResult pNode pReqs = pResult oldChildren = oldNode ^. L.children oldIts = Seq.mapWithIndex (,) oldChildren - updatedChildren = uNode ^. L.children + updatedChildren = pNode ^. L.children - mergeChild idx child = (idx, cascadeCtx wenv uNode child idx) + mergeChild idx child = (idx, cascadeCtx wenv pNode child idx) newIts = Seq.mapWithIndex mergeChild updatedChildren oldKeys = buildLocalMap oldChildren newKeys = buildLocalMap (snd <$> newIts) @@ -696,8 +697,8 @@ mergedChildren = fmap _wrNode mergedResults mergedReqs = foldMap _wrRequests mergedResults removedReqs = foldMap _wrRequests removedResults - mergedNode = uNode & L.children .~ mergedChildren - newReqs = uReqs <> mergedReqs <> removedReqs + mergedNode = pNode & L.children .~ mergedChildren + newReqs = pReqs <> mergedReqs <> removedReqs !newResult = WidgetResult mergedNode newReqs mergeChildSeq diff --git a/src/Monomer/Widgets/Containers/Alert.hs b/src/Monomer/Widgets/Containers/Alert.hs --- a/src/Monomer/Widgets/Containers/Alert.hs +++ b/src/Monomer/Widgets/Containers/Alert.hs @@ -8,6 +8,24 @@ Simple alert dialog, displaying a close button and optional title. Usually embedded in a zstack component and displayed/hidden depending on context. + +A simple text message can be displayed with 'alertMsg', providing the message +text and the event to generate when the user closes the alert: + +@ +alertMsg "En error occurred" AlertClosedEvent +@ + +Alternatively, a custom widget can be provided to display as content: + +@ +customAlert = alert AlertClosedEvent content where + content = hstack [ + label "Error:", + filler, + label errorDescription + ] +@ -} {-# LANGUAGE Strict #-} diff --git a/src/Monomer/Widgets/Containers/Base/LabeledItem.hs b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs --- a/src/Monomer/Widgets/Containers/Base/LabeledItem.hs +++ b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs @@ -8,6 +8,11 @@ Container for items with an associated clickable label. Mainly used with radio and checkbox. + +For usage examples, see: + +- "Monomer.Widgets.Singles.LabeledCheckbox" +- "Monomer.Widgets.Singles.LabeledRadio" -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Monomer/Widgets/Containers/Box.hs b/src/Monomer/Widgets/Containers/Box.hs --- a/src/Monomer/Widgets/Containers/Box.hs +++ b/src/Monomer/Widgets/Containers/Box.hs @@ -6,19 +6,45 @@ Stability : experimental Portability : non-portable -Container for a single item. +Container for a single item, providing functionalities that may not be available +in other widgets. Useful in different layout situations, since it provides alignment options. This allows for the inner widget to keep its size while being positioned more explicitly, while the box takes up the complete space assigned by its parent (in -particular for containers which do not follow SizeReq restriccions, such as +particular for containers which do not follow SizeReq restrictions, such as Grid). +@ +box_ [alignRight, alignBottom] $ + image "assets/test-image.jpg" + \`styleBasic\` [width 100, height 100] +@ + Can be used to add padding to an inner widget with a border. This is equivalent to the margin property in CSS. +@ +-- Padding is inside the border +content = label \"Message\" + \`styleBasic\` [padding 5, border 1 black] +-- Padding in the wrapper box acts as margin +container = box content + \`styleBasic\` [padding 5] +@ + Also useful to handle click events in complex widget structures (for example, a label with an image at its side). + +@ +content = vstack [ + label "All the content widget is clickable", + spacer, + image "assets/test-image.jpg" + ] +clickableItem = box_ [onClick ItemClicked] content + \`styleBasic\' [cursorHand] +@ -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -80,7 +106,7 @@ _boxExpandContent :: Maybe Bool, _boxIgnoreEmptyArea :: Maybe Bool, _boxSizeReqUpdater :: [SizeReqUpdater], - _boxMergeRequired :: Maybe (s -> s -> Bool), + _boxMergeRequired :: Maybe (WidgetEnv s e -> s -> s -> Bool), _boxAlignH :: Maybe AlignH, _boxAlignV :: Maybe AlignV, _boxOnFocusReq :: [Path -> WidgetRequest s e], @@ -142,7 +168,7 @@ _boxSizeReqUpdater = [updater] } -instance CmbMergeRequired (BoxCfg s e) s where +instance CmbMergeRequired (BoxCfg s e) (WidgetEnv s e) s where mergeRequired fn = def { _boxMergeRequired = Just fn } @@ -320,7 +346,7 @@ mergeRequired wenv node oldNode oldState = required where newModel = wenv ^. L.model required = case (_boxMergeRequired config, _bxsModel oldState) of - (Just mergeReqFn, Just oldModel) -> mergeReqFn oldModel newModel + (Just mergeReqFn, Just oldModel) -> mergeReqFn wenv oldModel newModel _ -> True merge wenv node oldNode oldState = resultNode newNode where diff --git a/src/Monomer/Widgets/Containers/Confirm.hs b/src/Monomer/Widgets/Containers/Confirm.hs --- a/src/Monomer/Widgets/Containers/Confirm.hs +++ b/src/Monomer/Widgets/Containers/Confirm.hs @@ -6,9 +6,30 @@ Stability : experimental Portability : non-portable -Simple confirm dialog, displaying an accept and close buttons and optional -title. Usually embedded in a zstack component and displayed/hidden depending on +Simple confirm dialog, displaying accept and close buttons and optional title. +Usually embedded in a zstack component and displayed/hidden depending on context. + +Similar to "Monomer.Widgets.Containers.Alert", but takes two events to handle +the Accept and Cancel actions. + +A simple text message can be displayed with 'confirmMsg', providing the message +text and the events to generate when the user interacts with the dialog: + +@ +confirmMsg "Save changes?" ConfirmAcceptEvent ConfirmCancelEvent +@ + +Alternatively, a custom widget can be provided to display as content: + +@ +customConfirm = confirm ConfirmAcceptEvent ConfirmCancelEvent where + content = hstack [ + label "Save changes?", + filler, + label fileName + ] +@ -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -17,6 +38,7 @@ module Monomer.Widgets.Containers.Confirm ( -- * Configuration ConfirmCfg, + InnerConfirmEvt, -- * Constructors confirm, confirm_, @@ -89,28 +111,34 @@ _cfcCancel = Just t } -newtype ConfirmEvt e +{-| +Wraps the user event to be able to implement custom events and still be able to +report to its parent. + +Previously used, now kept for reference. +-} +newtype InnerConfirmEvt e = ConfirmParentEvt e deriving (Eq, Show) -- | Creates a confirm dialog with the provided content. confirm :: (WidgetModel s, WidgetEvent e) - => e -- ^ The accept button event. - -> e -- ^ The cancel button event. - -> WidgetNode () (ConfirmEvt e) -- ^ The content to display in the dialog. - -> WidgetNode s e -- ^ The created dialog. + => e -- ^ The accept button event. + -> e -- ^ The cancel button event. + -> WidgetNode () (InnerConfirmEvt e) -- ^ Content to display in the dialog. + -> WidgetNode s e -- ^ The created dialog. confirm acceptEvt cancelEvt dialogBody = newNode where newNode = confirm_ acceptEvt cancelEvt def dialogBody -- | Creates an alert dialog with the provided content. Accepts config. confirm_ :: (WidgetModel s, WidgetEvent e) - => e -- ^ The accept button event. - -> e -- ^ The cancel button event. - -> [ConfirmCfg] -- ^ The config options for the dialog. - -> WidgetNode () (ConfirmEvt e) -- ^ The content to display in the dialog. - -> WidgetNode s e -- ^ The created dialog. + => e -- ^ The accept button event. + -> e -- ^ The cancel button event. + -> [ConfirmCfg] -- ^ The config options for the dialog. + -> WidgetNode () (InnerConfirmEvt e) -- ^ Content to display in the dialog. + -> WidgetNode s e -- ^ The created dialog. confirm_ acceptEvt cancelEvt configs dialogBody = newNode where config = mconcat configs createUI = buildUI (const dialogBody) acceptEvt cancelEvt config @@ -120,19 +148,19 @@ -- | Creates an alert dialog with a text message as content. confirmMsg :: (WidgetModel s, WidgetEvent e) - => Text -- ^ The message to display in the dialog. - -> e -- ^ The accept button event. - -> e -- ^ The cancel button event. + => Text -- ^ The message to display in the dialog. + -> e -- ^ The accept button event. + -> e -- ^ The cancel button event. -> WidgetNode s e -- ^ The created dialog. confirmMsg msg acceptEvt cancelEvt = confirmMsg_ msg acceptEvt cancelEvt def -- | Creates an alert dialog with a text message as content. Accepts config. confirmMsg_ :: (WidgetModel s, WidgetEvent e) - => Text -- ^ The message to display in the dialog. - -> e -- ^ The accept button event. - -> e -- ^ The cancel button event. - -> [ConfirmCfg] -- ^ The config options for the dialog. + => Text -- ^ The message to display in the dialog. + -> e -- ^ The accept button event. + -> e -- ^ The cancel button event. + -> [ConfirmCfg] -- ^ The config options for the dialog. -> WidgetNode s e -- ^ The created dialog. confirmMsg_ message acceptEvt cancelEvt configs = newNode where config = mconcat configs @@ -142,8 +170,8 @@ compCfg = [compositeMergeReqs mergeReqs] newNode = compositeD_ "confirm" (WidgetValue ()) createUI handleEvent compCfg -mergeReqs :: MergeReqsHandler s e -mergeReqs wenv newNode oldNode model = reqs where +mergeReqs :: MergeReqsHandler s e sp +mergeReqs wenv newNode oldNode parentModel oldModel model = reqs where acceptPath = SetFocus <$> widgetIdFromKey wenv "acceptBtn" isVisible node = node ^. L.info . L.visible reqs @@ -152,13 +180,13 @@ buildUI :: (WidgetModel s, WidgetEvent ep) - => (WidgetEnv s (ConfirmEvt ep) -> WidgetNode s (ConfirmEvt ep)) + => (WidgetEnv s (InnerConfirmEvt ep) -> WidgetNode s (InnerConfirmEvt ep)) -> ep -> ep -> ConfirmCfg - -> WidgetEnv s (ConfirmEvt ep) + -> WidgetEnv s (InnerConfirmEvt ep) -> s - -> WidgetNode s (ConfirmEvt ep) + -> WidgetNode s (InnerConfirmEvt ep) buildUI dialogBody pAcceptEvt pCancelEvt config wenv model = mainTree where acceptEvt = ConfirmParentEvt pAcceptEvt cancelEvt = ConfirmParentEvt pCancelEvt @@ -190,10 +218,10 @@ mainTree = keystroke [("Esc", cancelEvt)] confirmBox handleEvent - :: WidgetEnv s (ConfirmEvt ep) - -> WidgetNode s (ConfirmEvt ep) + :: WidgetEnv s (InnerConfirmEvt ep) + -> WidgetNode s (InnerConfirmEvt ep) -> s - -> ConfirmEvt ep - -> [EventResponse s (ConfirmEvt ep) sp ep] + -> InnerConfirmEvt ep + -> [EventResponse s (InnerConfirmEvt ep) sp ep] handleEvent wenv node model evt = case evt of ConfirmParentEvt pevt -> [Report pevt] diff --git a/src/Monomer/Widgets/Containers/Draggable.hs b/src/Monomer/Widgets/Containers/Draggable.hs --- a/src/Monomer/Widgets/Containers/Draggable.hs +++ b/src/Monomer/Widgets/Containers/Draggable.hs @@ -8,7 +8,16 @@ Draggable container for a single item. Useful for adding drag support without having to implement a custom widget. Usually works in tandem with -'Monomer.Widgets.Containers.DropTarget'. +"Monomer.Widgets.Containers.DropTarget". + +Requires a value to identify the content (used when the item is dropped) and the +content to display. + +@ +dragItem = draggable "item" $ label "This label is draggable" +@ + +See Tutorial 6 (Composite) for a usage example. -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Monomer/Widgets/Containers/DropTarget.hs b/src/Monomer/Widgets/Containers/DropTarget.hs --- a/src/Monomer/Widgets/Containers/DropTarget.hs +++ b/src/Monomer/Widgets/Containers/DropTarget.hs @@ -8,10 +8,18 @@ Drop target container for a single element. Useful for adding drag support without having to implement a custom widget. Usually works in tandem with -'Monomer.Widgets.Containers.Draggable'. +"Monomer.Widgets.Containers.Draggable". Raises a user provided event when an item is dropped. The type must match with -the dragged message, otherwise it will not be raised. +the type of the dragged widget message, otherwise it will not be raised. + +@ +target = dropTarget ItemDropped $ + vstack itemsRows + \`styleBasic\` [width 200, height 400] +@ + +See Tutorial 6 (Composite) for a usage example. -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Monomer/Widgets/Containers/Dropdown.hs b/src/Monomer/Widgets/Containers/Dropdown.hs --- a/src/Monomer/Widgets/Containers/Dropdown.hs +++ b/src/Monomer/Widgets/Containers/Dropdown.hs @@ -7,9 +7,21 @@ Portability : non-portable Dropdown widget, allowing selection of a single item from a collapsable list. -Both header and list content is customizable, and so is its styling. In case -only 'Text' content is needed, 'Monomer.Widgets.Singles.TextDropdown' is easier -to use. +Both header and list content are customizable, and so is their styling. + +In case only 'Text' content is needed, "Monomer.Widgets.Singles.TextDropdown" is +easier to use. + +@ +makeSelected username = hstack [ + label "Selected: ", + spacer, + label username + ] +makeRow username = label username + +customDropdown = dropdown userLens usernames makeSelected makeRow +@ -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} diff --git a/src/Monomer/Widgets/Containers/Grid.hs b/src/Monomer/Widgets/Containers/Grid.hs --- a/src/Monomer/Widgets/Containers/Grid.hs +++ b/src/Monomer/Widgets/Containers/Grid.hs @@ -6,9 +6,23 @@ Stability : experimental Portability : non-portable -Layout container which distributes size equally along the main axis. For hgrid -it requests max width * elements as its width, and the max height as its height. -The reverse happens for vgrid. +Layout container which distributes space evenly along the main axis. For the +secondary axis children will receive as much space as available for the grid +widget itself. + +In the same way as with hstack and vstack, 'hgrid' and 'vgrid' can be combined +to create more complex layouts. + +The hgrid widget requests maxWidth * elements as its width, and the max height +as its height. The inverse happens for vgrid. + +@ +hgrid [ + label "Third 1", + label "Third 2", + label "Third 3" + ] +@ -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Strict #-} diff --git a/src/Monomer/Widgets/Containers/Keystroke.hs b/src/Monomer/Widgets/Containers/Keystroke.hs --- a/src/Monomer/Widgets/Containers/Keystroke.hs +++ b/src/Monomer/Widgets/Containers/Keystroke.hs @@ -11,28 +11,62 @@ implementing a widget from scratch, keyboard events are directly available. The shortcut definitions are provided as a list of tuples of 'Text', containing -the key combination and associated event. The widget handles unordered -combinations of multiple keys at the same time, but does not support ordered -sequences (pressing "a", releasing, then "b" and "c"). The available keys are: +the key combination and associated event, separated by "-". The widget handles +unordered combinations of multiple keys at the same time, but does not support +ordered sequences (pressing "a", releasing, then "b" and "c"). The available +keys are: - Mod keys: A, Alt, C, Ctrl, Cmd, O, Option, S, Shift - Action keys: Caps, Delete, Enter, Esc, Return, Space, Tab - Arrows: Up, Down, Left, Right - Function keys: F1-F12 +- Separator: Dash (since '-' is used for defining keystrokes) +- Symbols: brackets, ^, *, &, etc. - Lowercase letters (uppercase keys are reserved for mod and action keys) - Numbers -These can be combined, for example: +The keys can be combined, for example: - Copy: "Ctrl-c" or "C-c" - App config: "Ctrl-Shift-p" or "C-S-p" + +@ +keystroke [("Esc", CancelEditing)] $ hstack [ + label "Username:", + spacer, + textField userLens + ] +@ + +Note 1: Following the pattern explained in 'CmbIgnoreChildrenEvts', this widget +by default allows children widgets (i.e., focused widgets) that may receive the +events to respond to the pressed keys. If you want to avoid this, and only keep +the keystroke widgets's response when a combination matches, add the +'ignoreChildrenEvts' config option. To clarify: the only keypress event that +will be filtered is the one that causes a combination to match (the last one). + +Note 2: Except in the specific cases mentioned here (Ctrl, Cmd, etc), the keys +must be single characters. + +Note 3: Full words must be input exactly as indicated (Ctrl, Cmd, etc). Alias +only exist for the keys described here (A for Alt, C for Ctrl/Cmd, etc). + +Note 4: Symbols that require pressing the Shift key (^, &, etc) are virtual keys +and share the KeyCode with the symbol associated to the same physical key. This +causes issues when detecting their pressed status, and thus it's not possible to +combine these symbols with letters, numbers or other symbols in the same +keystroke. The same happens with characters that require pressing a combination +of keys (e.g. accented characters). It is still possible to combine them with +mod keys, so using "C-^" or "C-[" should work. If you find that binding a +symbol/complex character does not work, try using the names of the physical keys +instead (e.g. "Shift-e" instead of "E"). -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Strict #-} module Monomer.Widgets.Containers.Keystroke ( -- * Configuration @@ -42,6 +76,8 @@ keystroke_ ) where +import Debug.Trace (traceShow) + import Control.Applicative ((<|>)) import Control.Lens ((&), (^.), (^..), (.~), (%~), _1, at, folded) import Control.Lens.TH (abbreviatedFields, makeLensesWith) @@ -96,7 +132,9 @@ _kstKsCmd :: Bool, _kstKsAlt :: Bool, _kstKsShift :: Bool, - _kstKsKeys :: Set KeyCode + _kstKsKeys :: Set KeyCode, + _kstKsKeysText :: Set Text, + _kstKsErrors :: [Text] } deriving (Eq, Show) instance Default KeyStroke where @@ -107,13 +145,20 @@ _kstKsCmd = False, _kstKsAlt = False, _kstKsShift = False, - _kstKsKeys = Set.empty + _kstKsKeys = Set.empty, + _kstKsKeysText = Set.empty, + _kstKsErrors = [] } newtype KeyStrokeState e = KeyStrokeState { _kssLatest :: [(KeyStroke, e)] } deriving (Eq, Show) +data KeyEntry + = KeyEntryCode KeyCode + | KeyEntryText Text + deriving (Eq, Show) + makeLensesWith abbreviatedFields ''KeyStroke makeLensesWith abbreviatedFields ''KeyStrokeState @@ -156,37 +201,47 @@ & L.widget .~ makeKeystroke bindings config oldState handleEvent wenv node target evt = case evt of - KeyAction mod code KeyPressed -> Just result where - newWenv = wenv & L.inputStatus %~ removeMods - matches = filter (keyStrokeActive newWenv code . fst) bindings - newState = KeyStrokeState matches - newNode = node - & L.widget .~ makeKeystroke bindings config newState - evts = snd <$> matches - reqs - | ignoreChildren && not (null evts) = [IgnoreChildrenEvents] - | otherwise = [] - result = resultReqsEvts newNode reqs evts - TextInput t - | ignoreChildren && ignorePrevious t -> Just result where - previousMatch t = t `elem` _kssLatest state ^.. folded . _1 . ksText - ignorePrevious t = isTextValidCode t && previousMatch t + KeyAction mod code KeyPressed -> result where + result = handleKeystroke (KeyEntryCode code) + TextInput text + | ignoreChildren && ignorePrevious text -> Just result where newState = KeyStrokeState [] newNode = node & L.widget .~ makeKeystroke bindings config newState result = resultReqs newNode [IgnoreChildrenEvents] + TextInput text + | not (previousMatch text) -> result where + result = handleKeystroke (KeyEntryText text) _ -> Nothing where ignoreChildren = Just True == _kscIgnoreChildren config + previousMatch t = t `elem` _kssLatest state ^.. folded . _1 . ksText + ignorePrevious t = isTextValidCode t && previousMatch t -keyStrokeActive :: WidgetEnv s e -> KeyCode -> KeyStroke -> Bool -keyStrokeActive wenv code ks = currValid && allPressed && validMods where + handleKeystroke entry = Just result where + newWenv = wenv & L.inputStatus %~ removeMods + matches = filter (keyStrokeActive newWenv entry . fst) bindings + newState = KeyStrokeState matches + newNode = node + & L.widget .~ makeKeystroke bindings config newState + evts = snd <$> matches + reqs + | ignoreChildren && not (null evts) = [IgnoreChildrenEvents] + | otherwise = [] + result = resultReqsEvts newNode reqs evts + +keyStrokeActive :: WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool +keyStrokeActive wenv entry ks = currValid && allPressed && validMods where status = wenv ^. L.inputStatus keyMod = status ^. L.keyMod pressedKeys = M.filter (== KeyPressed) (status ^. L.keys) - currValid = code `elem` (ks ^. ksKeys) || code `elem` modKeys - allPressed = M.keysSet pressedKeys == ks ^. ksKeys + (currValid, allPressed, ignoreShift) = case entry of + KeyEntryCode code -> (valid, pressed, False) where + valid = code `elem` (ks ^. ksKeys) || code `elem` modKeys + pressed = M.keysSet pressedKeys == ks ^. ksKeys + KeyEntryText txt -> (valid, True, True) where + valid = txt `elem` (ks ^. ksKeysText) ctrlPressed = isCtrlPressed keyMod cmdPressed = isMacOS wenv && isGUIPressed keyMod @@ -194,17 +249,24 @@ validC = not (ks ^. ksC) || ks ^. ksC == (ctrlPressed || cmdPressed) validCtrl = ks ^. ksCtrl == ctrlPressed || ctrlPressed && validC validCmd = ks ^. ksCmd == cmdPressed || cmdPressed && validC - validShift = ks ^. ksShift == isShiftPressed keyMod + validShift = ks ^. ksShift == isShiftPressed keyMod || ignoreShift validAlt = ks ^. ksAlt == isAltPressed keyMod validMods = (validC && validCtrl && validCmd) && validShift && validAlt textToStroke :: Text -> KeyStroke -textToStroke text = ks where +textToStroke text = result where parts = T.split (=='-') text ks = foldl' partToStroke def parts & ksText .~ text + errors = ks ^. ksErrors + errorMsg = "'" <> text <> "' is not valid. Invalid parts: " + + result + | not (T.null text) && null errors = ks + | otherwise = traceShow (errorMsg, errors) ks + partToStroke :: KeyStroke -> Text -> KeyStroke partToStroke ks "A" = ks & ksAlt .~ True partToStroke ks "Alt" = ks & ksAlt .~ True @@ -216,9 +278,11 @@ partToStroke ks "S" = ks & ksShift .~ True partToStroke ks "Shift" = ks & ksShift .~ True -- Main keys +partToStroke ks "Backspace" = ks & ksKeys %~ Set.insert keyBackspace partToStroke ks "Caps" = ks & ksKeys %~ Set.insert keyCapsLock partToStroke ks "Delete" = ks & ksKeys %~ Set.insert keyDelete partToStroke ks "Enter" = ks & ksKeys %~ Set.insert keyReturn +partToStroke ks "KpEnter" = ks & ksKeys %~ Set.insert keyPadEnter partToStroke ks "Esc" = ks & ksKeys %~ Set.insert keyEscape partToStroke ks "Return" = ks & ksKeys %~ Set.insert keyReturn partToStroke ks "Space" = ks & ksKeys %~ Set.insert keySpace @@ -242,9 +306,13 @@ partToStroke ks "F11" = ks & ksKeys %~ Set.insert keyF11 partToStroke ks "F12" = ks & ksKeys %~ Set.insert keyF12 -- Other keys (numbers, letters, points, etc) +partToStroke ks "Dash" = partToStroke ks "-" partToStroke ks txt - | isTextValidCode txt = ks & ksKeys %~ Set.insert (KeyCode (ord txtHead)) + | isTextValidCode txt = ks + & ksKeys %~ Set.insert (KeyCode (ord txtHead)) + & ksKeysText %~ Set.insert txt | otherwise = ks + & ksErrors %~ (++ [txt]) where txtHead = T.index txt 0 diff --git a/src/Monomer/Widgets/Containers/Scroll.hs b/src/Monomer/Widgets/Containers/Scroll.hs --- a/src/Monomer/Widgets/Containers/Scroll.hs +++ b/src/Monomer/Widgets/Containers/Scroll.hs @@ -11,10 +11,14 @@ of the inner node with the scroll bars. It also supports automatic focus following. -Messages: +Accepts the following messages: - 'ScrollTo': Causes the scroll to update its handles to ensure rect is visible. - 'ScrollReset': Sets both handle positions to zero. + +@ +vscroll (vstack longItemsList) +@ -} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -68,12 +72,19 @@ | ScrollBoth deriving (Eq, Show) +{-| +Information provided in the 'onChange' event. + +The currently visible viewport is affected by the position of the scroll bars, +their size and any other parent widget that restricts the visible viewport +(e.g., another scroll). +-} data ScrollStatus = ScrollStatus { - scrollDeltaX :: Double, - scrollDeltaY :: Double, - scrollRect :: Rect, - scrollVpSize :: Size, - scrollChildSize :: Size + scrollDeltaX :: Double, -- ^ Displacement in the x axis. + scrollDeltaY :: Double, -- ^ Displacement in the y axis. + scrollRect :: Rect, -- ^ The viewport assigned to the scroll widget. + scrollVpSize :: Size, -- ^ The currently visible viewport. + scrollChildSize :: Size -- ^ The total size of the child widget. } deriving (Eq, Show) instance Default ScrollStatus where @@ -106,6 +117,7 @@ - 'thumbColor': the color of the thumb. - 'thumbHoverColor': the color of the thumb when mouse is on top. - 'thumbWidth': the width of the thumb. +- 'thumbMinSize': the minimum size of the thumb. - 'thumbRadius': the radius of the corners of the thumb. - 'onChange': event to raise when the viewport changes. - 'onChangeReq': 'WidgetRequest' to generate when the viewport changes. @@ -123,6 +135,7 @@ _scStyle :: Maybe (ALens' ThemeState StyleState), _scBarWidth :: Maybe Double, _scThumbWidth :: Maybe Double, + _scThumbMinSize :: Maybe Double, _scThumbRadius :: Maybe Double, _scOnChangeReq :: [ScrollStatus -> WidgetRequest s e] } @@ -141,6 +154,7 @@ _scStyle = Nothing, _scBarWidth = Nothing, _scThumbWidth = Nothing, + _scThumbMinSize = Nothing, _scThumbRadius = Nothing, _scOnChangeReq = [] } @@ -159,6 +173,7 @@ _scStyle = _scStyle t2 <|> _scStyle t1, _scBarWidth = _scBarWidth t2 <|> _scBarWidth t1, _scThumbWidth = _scThumbWidth t2 <|> _scThumbWidth t1, + _scThumbMinSize = _scThumbMinSize t2 <|> _scThumbMinSize t1, _scThumbRadius = _scThumbRadius t2 <|> _scThumbRadius t1, _scOnChangeReq = _scOnChangeReq t2 <|> _scOnChangeReq t1 } @@ -202,6 +217,11 @@ _scThumbWidth = Just w } +instance CmbThumbMinSize (ScrollCfg s e) where + thumbMinSize w = def { + _scThumbMinSize = Just w + } + instance CmbThumbRadius (ScrollCfg s e) where thumbRadius r = def { _scThumbRadius = Just r @@ -300,14 +320,16 @@ _sstDragging :: Maybe ActiveBar, _sstDeltaX :: !Double, _sstDeltaY :: !Double, + _sstThumbOffsetX :: !Double, + _sstThumbOffsetY :: !Double, _sstVpSize :: Size, _sstChildSize :: Size, _sstScissor :: Rect } deriving (Eq, Show, Generic) data ScrollContext = ScrollContext { - hScrollRatio :: Double, - vScrollRatio :: Double, + hThumbRatio :: Double, + vThumbRatio :: Double, hScrollRequired :: Bool, vScrollRequired :: Bool, hMouseInScroll :: Bool, @@ -325,6 +347,8 @@ _sstDragging = Nothing, _sstDeltaX = 0, _sstDeltaY = 0, + _sstThumbOffsetX = 0, + _sstThumbOffsetY = 0, _sstVpSize = def, _sstChildSize = def, _sstScissor = def @@ -395,7 +419,7 @@ } widget = createContainer state container - ScrollState dragging dx dy _ _ _ = state + (dragging, dx, dy) = (_sstDragging state, _sstDeltaX state, _sstDeltaY state) Size childWidth childHeight = _sstChildSize state Size maxVpW maxVpH = _sstVpSize state offset = Point dx dy @@ -484,7 +508,10 @@ follow = fromMaybe (theme ^. L.scrollFollowFocus) (_scFollowFocus config) overlayMatch = focusOverlay == inOverlay (node ^. L.info) + fwdFocus = Just (resultReqs node [MoveFocus Nothing FocusFwd]) + result + | target == node ^. L.info . L.path = fwdFocus | follow && overlayMatch = focusVp >>= scrollTo wenv node | otherwise = Nothing @@ -503,9 +530,20 @@ mouseInThumb = hMouseInThumb sctx || vMouseInThumb sctx mouseInScroll = hMouseInScroll sctx || vMouseInScroll sctx + thumbOffsetX = point ^. L.x - hThumbRect sctx ^. L.x + thumbOffsetY = point ^. L.y - vThumbRect sctx ^. L.y + newState - | startDragH = state { _sstDragging = Just HBar } - | startDragV = state { _sstDragging = Just VBar } + | startDragH = state { + _sstDragging = Just HBar, + _sstThumbOffsetX = thumbOffsetX, + _sstThumbOffsetY = 0 + } + | startDragV = state { + _sstDragging = Just VBar, + _sstThumbOffsetX = 0, + _sstThumbOffsetY = thumbOffsetY + } | jumpScrollH = updateScrollThumb state HBar point contentArea sctx | jumpScrollV = updateScrollThumb state VBar point contentArea sctx | mainReleased = state { _sstDragging = Nothing } @@ -627,11 +665,10 @@ ScrollContext{..} = sctx Rect cx cy _ _ = contentArea - hMid = _rW hThumbRect / 2 - vMid = _rH vThumbRect / 2 + (offsetH, offsetV) = (_sstThumbOffsetX state, _sstThumbOffsetY state) - hDelta = (cx - px + hMid) / hScrollRatio - vDelta = (cy - py + vMid) / vScrollRatio + hDelta = (cx - px + offsetH) / hThumbRatio + vDelta = (cy - py + offsetV) / vThumbRatio newDeltaX | activeBar == HBar = scrollAxisH hDelta @@ -814,16 +851,19 @@ -> ScrollState -> Point -> ScrollContext -scrollStatus config wenv node scrollState mousePos = ScrollContext{..} where - ScrollState _ dx dy _ _ _ = scrollState - Size childWidth childHeight = _sstChildSize scrollState - Size vpWidth vpHeight = _sstVpSize scrollState +scrollStatus config wenv node state mousePos = ScrollContext{..} where + (dragging, dx, dy) = (_sstDragging state, _sstDeltaX state, _sstDeltaY state) + + Size childWidth childHeight = _sstChildSize state + Size vpWidth vpHeight = _sstVpSize state + theme = currentTheme wenv node style = scrollCurrentStyle wenv node contentArea = getContentArea node style barW = fromMaybe (theme ^. L.scrollBarWidth) (_scBarWidth config) thumbW = fromMaybe (theme ^. L.scrollThumbWidth) (_scThumbWidth config) + minSize = fromMaybe (theme ^. L.scrollThumbMinSize) (_scThumbMinSize config) caLeft = _rX contentArea caTop = _rY contentArea @@ -835,15 +875,24 @@ hRatio = caWidth / childWidth vRatio = caHeight / childHeight - hRatioR = (caWidth - barW) / childWidth - vRatioR = (caHeight - barW) / childHeight - (hScrollRatio, vScrollRatio) - | hRatio < 1 && vRatio < 1 = (hRatioR, vRatioR) - | otherwise = (hRatio, vRatio) + ratioBarW + | hRatio < 1 && vRatio < 1 = barW + | otherwise = 0 + hScrollRatio = (caWidth - ratioBarW) / childWidth + vScrollRatio = (caHeight - ratioBarW) / childHeight + hScrollRequired = hScrollRatio < 1 vScrollRequired = vScrollRatio < 1 + hThumbSize = max minSize (hScrollRatio * vpWidth) + vThumbSize = max minSize (vScrollRatio * vpHeight) + + hThumbArea = caWidth - ratioBarW + vThumbArea = caHeight - ratioBarW + hThumbRatio = (hThumbArea - hThumbSize) / (childWidth - hThumbArea) + vThumbRatio = (vThumbArea - vThumbSize) / (childHeight - vThumbArea) + hScrollRect = Rect { _rX = caLeft, _rY = caTop + hScrollTop, @@ -857,16 +906,16 @@ _rH = vpHeight } hThumbRect = Rect { - _rX = caLeft - hScrollRatio * dx, + _rX = caLeft - hThumbRatio * dx, _rY = caTop + hScrollTop + (barW - thumbW) / 2, - _rW = hScrollRatio * vpWidth, + _rW = hThumbSize, _rH = thumbW } vThumbRect = Rect { _rX = caLeft + vScrollLeft + (barW - thumbW) / 2, - _rY = caTop - vScrollRatio * dy, + _rY = caTop - vThumbRatio * dy, _rW = thumbW, - _rH = vScrollRatio * vpHeight + _rH = vThumbSize } hMouseInScroll = pointInRect mousePos hScrollRect diff --git a/src/Monomer/Widgets/Containers/SelectList.hs b/src/Monomer/Widgets/Containers/SelectList.hs --- a/src/Monomer/Widgets/Containers/SelectList.hs +++ b/src/Monomer/Widgets/Containers/SelectList.hs @@ -7,13 +7,22 @@ Portability : non-portable Select list widget, allowing selection of a single item. List content (rows) is -customizable, plus its styling. +customizable, and so is its styling. This widget is used by +"Monomer.Widgets.Containers.Dropdown" when in its open state. + +@ +makeRow username = hstack [ + label "User: ", + label username + ] + +customSelect = selectList userLens usernames makeRow +@ -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -83,7 +92,7 @@ _slcSelectOnBlur :: Maybe Bool, _slcItemStyle :: Maybe Style, _slcItemSelectedStyle :: Maybe Style, - _slcMergeRequired :: Maybe (Seq a -> Seq a -> Bool), + _slcMergeRequired :: Maybe (WidgetEnv s e -> Seq a -> Seq a -> Bool), _slcOnFocusReq :: [Path -> WidgetRequest s e], _slcOnBlurReq :: [Path -> WidgetRequest s e], _slcOnChangeReq :: [a -> WidgetRequest s e], @@ -172,7 +181,7 @@ _slcItemSelectedStyle = Just style } -instance CmbMergeRequired (SelectListCfg s e a) (Seq a) where +instance CmbMergeRequired (SelectListCfg s e a) (WidgetEnv s e) (Seq a) where mergeRequired fn = def { _slcMergeRequired = Just fn } @@ -299,8 +308,8 @@ mergeChildrenReq wenv node oldNode oldState = result where oldItems = _prevItems oldState - mergeRequiredFn = fromMaybe (/=) (_slcMergeRequired config) - result = mergeRequiredFn oldItems items + mergeRequiredFn = fromMaybe (const (/=)) (_slcMergeRequired config) + result = mergeRequiredFn wenv oldItems items merge wenv node oldNode oldState = resultNode newNode where selected = currentValue wenv @@ -406,7 +415,7 @@ itemScrollTo wenv node idx = maybeToList (scrollToReq <$> mwid <*> vp) where vp = itemViewport node idx - mwid = findWidgetIdFromPath wenv (parentPath node) + mwid = widgetIdFromPath wenv (parentPath node) scrollToReq wid rect = SendMessage wid (ScrollTo rect) itemViewport node idx = viewport where diff --git a/src/Monomer/Widgets/Containers/Split.hs b/src/Monomer/Widgets/Containers/Split.hs --- a/src/Monomer/Widgets/Containers/Split.hs +++ b/src/Monomer/Widgets/Containers/Split.hs @@ -6,9 +6,20 @@ Stability : experimental Portability : non-portable -Splits the assigned space into two parts, vertically or horizontally, which are +Splits the assigned space into two areas, vertically or horizontally, which are assigned to its two child nodes. The space assigned depends on the style and size requirements of each child node. + +@ +actionPanel = vstack [ + button "Image 1" ShowImage1, + button "Image 2" ShowImage2, + button "Image 3" ShowImage3 + ] +contentPanel = scroll (image activeImage) + +mainPanel = hsplit (actionPanel, contentPanel) +@ -} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Monomer/Widgets/Containers/Stack.hs b/src/Monomer/Widgets/Containers/Stack.hs --- a/src/Monomer/Widgets/Containers/Stack.hs +++ b/src/Monomer/Widgets/Containers/Stack.hs @@ -6,10 +6,35 @@ Stability : experimental Portability : non-portable -Container which stacks its children along a main axis. The layout algorithm -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. +Container that stacks its children along a main axis. + +An hstack widget will assign horizontal space to its children according to their +size requests. The inverse happens with vstack and vertical space, which assigns +vertical space as requested and all the horizontal space available. + +For example, a label will get enough space to be displayed completely, and it +will also get all the vertical space the hstack has. This means that if the +hstack is the top level widget in the window, the label will also be as tall as +the window. + +Both can be combined to create complex layouts. Considering the situation of a +top-level hstack which created a large vertical label, we could wrap the hstack +with a vstack to only use as much horizontal and vertical space as needed. Both +stack widgets will request space from their parent, along their corresponding +axis, based on the requests of their children. + +The layout algorithm 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. + +@ +vstack_ [childSpacing] [ + label "Selected image", + image "assets/large-image.jpg" + \`styleBasic\` [maxHeight 400], + button \"Complete\" CompleteAction + ] +@ -} {-# LANGUAGE Strict #-} diff --git a/src/Monomer/Widgets/Containers/ThemeSwitch.hs b/src/Monomer/Widgets/Containers/ThemeSwitch.hs --- a/src/Monomer/Widgets/Containers/ThemeSwitch.hs +++ b/src/Monomer/Widgets/Containers/ThemeSwitch.hs @@ -8,9 +8,23 @@ Switches to the provided theme for its child nodes. -Note: this widget ignores style settings. If you need to display borders or any -other kind of style configuration, set it on the child node or wrap the -themeSwitch widget in a "Monomer.Widgets.Containers.Box". +@ +theme = case activeTheme of + DarkTheme -> darkTheme + LightTheme -> lightTheme + +widgetTree = themeSwitch theme $ vstack [ + hstack [ + label "Select theme:", + spacer, + textDropdownS activeTheme [DarkTheme, LightTheme] + ] + ] +@ + +Note: this widget ignores style settings applied to itself. If you need to +display borders or any 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 #-} diff --git a/src/Monomer/Widgets/Containers/Tooltip.hs b/src/Monomer/Widgets/Containers/Tooltip.hs --- a/src/Monomer/Widgets/Containers/Tooltip.hs +++ b/src/Monomer/Widgets/Containers/Tooltip.hs @@ -6,13 +6,18 @@ Stability : experimental Portability : non-portable -Displays a text message above its child node when the pointer is on top and -the delay, if any, has ellapsed. +Displays a text message above its child node when the pointer is on top and the +delay, if any, has ellapsed. -Tooltip styling is a bit unusual, since it only applies to the overlaid element. -This means, padding will not be shown for the contained child element, but only +Tooltip styling is a bit unusual, since it is applied to the overlaid element. +This means padding will not be shown for the contained child element, but only on the message when the tooltip is active. If you need padding around the child -element, you may want to use a box. +element, you can use a "Monomer.Widgets.Containers.Box" around it. + +@ +tooltip "Click the button" (buttom \"Accept\" AcceptAction) + \`styleBasic\` [textSize 16, bgColor steelBlue, paddingH 5, radius 5] +@ -} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -51,7 +56,7 @@ - 'tooltipFollow': if, after tooltip is displayed, it should follow the mouse. -} data TooltipCfg = TooltipCfg { - _ttcDelay :: Maybe Int, + _ttcDelay :: Maybe Millisecond, _ttcFollowCursor :: Maybe Bool, _ttcMaxWidth :: Maybe Double, _ttcMaxHeight :: Maybe Double @@ -87,7 +92,7 @@ } -- | Delay before the tooltip is displayed when child widget is hovered. -tooltipDelay :: Int -> TooltipCfg +tooltipDelay :: Millisecond -> TooltipCfg tooltipDelay ms = def { _ttcDelay = Just ms } @@ -100,7 +105,7 @@ data TooltipState = TooltipState { _ttsLastPos :: Point, - _ttsLastPosTs :: Int + _ttsLastPosTs :: Millisecond } deriving (Eq, Show, Generic) -- | Creates a tooltip for the child widget. diff --git a/src/Monomer/Widgets/Containers/ZStack.hs b/src/Monomer/Widgets/Containers/ZStack.hs --- a/src/Monomer/Widgets/Containers/ZStack.hs +++ b/src/Monomer/Widgets/Containers/ZStack.hs @@ -7,13 +7,21 @@ Portability : non-portable Layered container, stacking children one on top of the other. Useful for -handling widgets that need to be visible in certain contexts only (dialogs), or -to overlay unrelated widgets (text on top of an image). +handling widgets that need to be visible in certain contexts only, such as +dialogs, or to overlay unrelated widgets (text on top of an image). 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. + +@ +zstack [ + image_ "assets/test-image.png" [fitFill], + label "Image caption" + \`styleBasic\` [textFont \"Bold\", textSize 20, textCenter] + ] +@ -} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -127,7 +135,7 @@ ZStackState oldFocusMap oldTopIdx = oldState children = node ^. L.children focusedPath = wenv ^. L.focusedPath - focusedWid = findWidgetIdFromPath wenv focusedPath + focusedWid = widgetIdFromPath wenv focusedPath isFocusParent = isNodeParentOfPath node focusedPath topLevel = isNodeTopLevel wenv node diff --git a/src/Monomer/Widgets/Singles/Base/InputField.hs b/src/Monomer/Widgets/Singles/Base/InputField.hs --- a/src/Monomer/Widgets/Singles/Base/InputField.hs +++ b/src/Monomer/Widgets/Singles/Base/InputField.hs @@ -10,8 +10,8 @@ representations of other types, such as numbers and dates. It is not meant for direct use, but to create custom widgets using it. -See "Monomer.Widgets.Singles.NumericField", "Monomer.Widgets.Singles.DateField" -and "Monomer.Widgets.Singles.TimeField". +See "Monomer.Widgets.Singles.NumericField", "Monomer.Widgets.Singles.DateField", +"Monomer.Widgets.Singles.TimeField" and "Monomer.Widgets.Singles.TextField". -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} @@ -34,8 +34,7 @@ import Control.Applicative ((<|>)) import Control.Monad -import Control.Lens - (ALens', (&), (.~), (?~), (%~), (^.), (^?), _2, _Just, cloneLens, non) +import Control.Lens hiding ((|>)) import Data.Default import Data.Maybe import Data.Sequence (Seq(..), (|>)) @@ -97,13 +96,15 @@ -- | Caret width. _ifcCaretWidth :: Maybe Double, -- | Caret blink period. - _ifcCaretMs :: Maybe Int, + _ifcCaretMs :: Maybe Millisecond, -- | Character to display as text replacement. Useful for passwords. _ifcDisplayChar :: Maybe Char, -- | Whether input causes ResizeWidgets requests. Defaults to False. _ifcResizeOnChange :: Bool, -- | If all input should be selected when focus is received. _ifcSelectOnFocus :: Bool, + -- | Whether the input should be read-only (with editing not allowed, but allowing selection). + _ifcReadOnly :: Bool, -- | Conversion from text to the expected value. Failure returns Nothing. _ifcFromText :: Text -> Maybe a, -- | Conversion from a value to text. Cannot fail. @@ -184,7 +185,7 @@ -- | Current index into history. _ifsHistIdx :: Int, -- | The timestamp when focus was received (used for caret blink) - _ifsFocusStart :: Int + _ifsFocusStart :: Millisecond } deriving (Eq, Show, Typeable, Generic) initialState :: a -> InputFieldState a @@ -207,7 +208,7 @@ defCaretW :: Double defCaretW = 2 -defCaretMs :: Int +defCaretMs :: Millisecond defCaretMs = 500 -- | Creates an instance of an input field, with customizations in config. @@ -255,6 +256,7 @@ -- Text/value conversion functions !caretW = fromMaybe defCaretW (_ifcCaretWidth config) !caretMs = fromMaybe defCaretMs (_ifcCaretMs config) + !editable = not (_ifcReadOnly config) !fromText = _ifcFromText config !toText = _ifcToText config getModelValue !wenv = widgetDataGet (_weModel wenv) (_ifcValue config) @@ -318,10 +320,10 @@ reqs = [ RenderStop widgetId ] handleKeyPress wenv mod code - | isDelBackWordNoSel = Just $ moveCursor removeWord prevWordStartIdx Nothing - | isDelBackWord = Just $ moveCursor removeText minTpSel Nothing - | isBackspace && emptySel = Just $ moveCursor removeText (tp - 1) Nothing - | isBackspace = Just $ moveCursor removeText minTpSel Nothing + | isDelBackWordNoSel && editable = Just $ moveCursor removeWord prevWordStartIdx Nothing + | isDelBackWord && editable = Just $ moveCursor removeText minTpSel Nothing + | isBackspace && emptySel && editable = Just $ moveCursor removeText (tp - 1) Nothing + | isBackspace && editable = Just $ moveCursor removeText minTpSel Nothing | isMoveLeft = Just $ moveCursor txt (tp - 1) Nothing | isMoveRight = Just $ moveCursor txt (tp + 1) Nothing | isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing @@ -476,7 +478,8 @@ -- Handle custom drag Move point - | isNodePressed wenv node && shiftPressed -> Just result where + | isNodePressed wenv node && isShiftDrag -> Just result where + isShiftDrag = shiftPressed && isJust dragHandler (_, stPoint) = fromJust $ wenv ^. L.mainBtnPress handlerRes = fromJust dragHandler state stPoint point (newText, newPos, newSel) = handlerRes @@ -499,11 +502,11 @@ KeyAction mod code KeyPressed | isKeyboardCopy wenv evt -> Just $ resultReqs node [SetClipboard (ClipboardText selectedText)] - | isKeyboardPaste wenv evt + | isKeyboardPaste wenv evt && editable -> Just $ resultReqs node [GetClipboard widgetId] - | isKeyboardCut wenv evt -> cutTextRes wenv node - | isKeyboardUndo wenv evt -> moveHistory wenv node state config (-1) - | isKeyboardRedo wenv evt -> moveHistory wenv node state config 1 + | isKeyboardCut wenv evt && editable -> cutTextRes wenv node + | isKeyboardUndo wenv evt && editable -> moveHistory wenv node state config (-1) + | isKeyboardRedo wenv evt && editable -> moveHistory wenv node state config 1 | otherwise -> fmap handleKeyRes keyRes <|> cursorRes where !keyRes = handleKeyPress wenv mod code handleKeyRes (!newText, !newPos, !newSel) = result where @@ -522,8 +525,9 @@ result = Just (resultReqs node reqs) -- Text input has unicode already processed (it's not the same as KeyAction) - TextInput newText -> result where - result = insertTextRes wenv node newText + TextInput newText + | editable -> result where + result = insertTextRes wenv node newText -- Paste clipboard contents Clipboard (ClipboardText newText) -> result where @@ -568,7 +572,7 @@ && shiftPressed && isJust dragHandler validCursor - | not shiftPressed = CursorIBeam + | not shiftPressed || isNothing dragHandler = CursorIBeam | otherwise = fromMaybe CursorArrow dragCursor changeCursorReq newCursor = reqs where cursorMatch = wenv ^? L.cursor . _Just . _2 == Just newCursor @@ -706,9 +710,14 @@ tsFontColor = styleFontColor style getCaretH :: InputFieldState a -> Double -getCaretH state = ta - td * 2 where - TextMetrics ta td _ _ = _ifsTextMetrics state +getCaretH state = lineh where + TextMetrics asc desc lineh _ = _ifsTextMetrics state +getCaretOffset :: TextMetrics -> StyleState -> Double +getCaretOffset metrics style = textOffset - desc where + TextMetrics asc desc lineh _ = metrics + textOffset = textOffsetY metrics style + getCaretRect :: InputFieldCfg s e a -> InputFieldState a @@ -727,7 +736,7 @@ | pos >= length glyphs = _glpXMax (seqLast glyphs) | otherwise = _glpXMin (Seq.index glyphs pos) caretX tx = max 0 $ min (cx + cw - caretW) (tx + caretPos) - caretY = ty + textOffsetY textMetrics style + caretY = ty + getCaretOffset textMetrics style caretRect = Rect (caretX tx) caretY caretW (getCaretH state) getSelRect :: InputFieldState a -> StyleState -> Rect @@ -737,7 +746,7 @@ glyphs = _ifsGlyphs state pos = _ifsCursorPos state sel = _ifsSelStart state - caretY = ty + textOffsetY textMetrics style + caretY = ty + getCaretOffset textMetrics style caretH = getCaretH state glyph idx = Seq.index glyphs (min idx (length glyphs - 1)) gx idx = _glpXMin (glyph idx) @@ -755,7 +764,7 @@ textLen = getGlyphsMax (_ifsGlyphs state) glyphs | Seq.null (_ifsGlyphs state) = Seq.empty - | otherwise = _ifsGlyphs state |> GlyphPos ' ' textLen 0 0 0 0 0 + | otherwise = _ifsGlyphs state |> GlyphPos ' ' 0 textLen 0 0 0 0 0 glyphStart i g = (i, abs (_glpXMin g - localX)) pairs = Seq.mapWithIndex glyphStart glyphs cpm (_, g1) (_, g2) = compare g1 g2 diff --git a/src/Monomer/Widgets/Singles/Button.hs b/src/Monomer/Widgets/Singles/Button.hs --- a/src/Monomer/Widgets/Singles/Button.hs +++ b/src/Monomer/Widgets/Singles/Button.hs @@ -8,6 +8,10 @@ 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. + +@ +button "Increase count" AppIncrease +@ -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -19,10 +23,12 @@ -- * Configuration ButtonCfg, -- * Constructors + mainButton, + mainButton_, + mainButtonD_, button, button_, - mainButton, - mainButton_ + buttonD_ ) where import Control.Applicative ((<|>)) @@ -46,6 +52,9 @@ {-| Configuration options for button: +- 'ignoreParentEvts': whether to ignore all other responses to the click or + keypress that triggered the button, and only keep this button's response. + Useful when the button is child of a _keystroke_ widget. - 'trimSpaces': whether to remove leading/trailing spaces in the caption. - 'ellipsis': if ellipsis should be used for overflown text. - 'multiline': if text may be split in multiple lines. @@ -62,6 +71,7 @@ -} data ButtonCfg s e = ButtonCfg { _btnButtonType :: Maybe ButtonType, + _btnIgnoreParent :: Maybe Bool, _btnIgnoreTheme :: Maybe Bool, _btnLabelCfg :: LabelCfg s e, _btnOnFocusReq :: [Path -> WidgetRequest s e], @@ -72,6 +82,7 @@ instance Default (ButtonCfg s e) where def = ButtonCfg { _btnButtonType = Nothing, + _btnIgnoreParent = Nothing, _btnIgnoreTheme = Nothing, _btnLabelCfg = def, _btnOnFocusReq = [], @@ -82,6 +93,7 @@ instance Semigroup (ButtonCfg s e) where (<>) t1 t2 = ButtonCfg { _btnButtonType = _btnButtonType t2 <|> _btnButtonType t1, + _btnIgnoreParent = _btnIgnoreParent t2 <|> _btnIgnoreParent t1, _btnIgnoreTheme = _btnIgnoreTheme t2 <|> _btnIgnoreTheme t1, _btnLabelCfg = _btnLabelCfg t1 <> _btnLabelCfg t2, _btnOnFocusReq = _btnOnFocusReq t1 <> _btnOnFocusReq t2, @@ -92,6 +104,11 @@ instance Monoid (ButtonCfg s e) where mempty = def +instance CmbIgnoreParentEvts (ButtonCfg s e) where + ignoreParentEvts_ ignore = def { + _btnIgnoreParent = Just ignore + } + instance CmbIgnoreTheme (ButtonCfg s e) where ignoreTheme_ ignore = def { _btnIgnoreTheme = Just ignore @@ -165,15 +182,30 @@ _btnButtonType = Just ButtonMain } --- | Creates a button with main styling. Useful for dialogs. +{-| +Creates a button with main styling. Useful to highlight an option, such as +"Accept", when multiple buttons are available. +-} mainButton :: WidgetEvent e => Text -> e -> WidgetNode s e mainButton caption handler = button_ caption handler [mainConfig] --- | Creates a button with main styling. Useful for dialogs. Accepts config. +{-| +Creates a button with main styling. Useful to highlight an option, such as +"Accept", when multiple buttons are available. Accepts config. +-} mainButton_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e mainButton_ caption handler configs = button_ caption handler newConfigs where newConfigs = mainConfig : configs +{-| +Creates a button with main styling. Useful to highlight an option, such as +"Accept", when multiple buttons are available. Accepts config but does not +require an event. See 'buttonD_'. +-} +mainButtonD_ :: WidgetEvent e => Text -> [ButtonCfg s e] -> WidgetNode s e +mainButtonD_ caption configs = buttonD_ caption newConfigs where + newConfigs = mainConfig : configs + -- | Creates a button with normal styling. button :: WidgetEvent e => Text -> e -> WidgetNode s e button caption handler = button_ caption handler def @@ -181,7 +213,20 @@ -- | Creates a button with normal styling. Accepts config. button_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e button_ caption handler configs = buttonNode where - config = onClick handler <> mconcat configs + buttonNode = buttonD_ caption (onClick handler : configs) + +{-| +Creates a button without forcing an event to be provided. The other constructors +use this version, adding an 'onClick' handler in configs. + +Using this constructor directly can be helpful in cases where the event to be +raised belongs in a _Composite_ above in the widget tree, outside the scope of +the Composite that contains the button. This parent Composite can be reached by +sending a message ('SendMessage') to its 'WidgetId' using 'onClickReq'. +-} +buttonD_ :: WidgetEvent e => Text -> [ButtonCfg s e] -> WidgetNode s e +buttonD_ caption configs = buttonNode where + config = mconcat configs widget = makeButton caption config !buttonNode = defaultWidgetNode "button" widget & L.info . L.focusable .~ True @@ -242,9 +287,12 @@ _ -> Nothing where mainBtn btn = btn == wenv ^. L.mainButton + focused = isNodeFocused wenv node pointInVp p = isPointInNodeVp node p - reqs = _btnOnClickReq config + ignoreParent = _btnIgnoreParent config == Just True + + reqs = _btnOnClickReq config ++ [IgnoreParentEvents | ignoreParent] result = resultReqs node reqs resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)] diff --git a/src/Monomer/Widgets/Singles/Checkbox.hs b/src/Monomer/Widgets/Singles/Checkbox.hs --- a/src/Monomer/Widgets/Singles/Checkbox.hs +++ b/src/Monomer/Widgets/Singles/Checkbox.hs @@ -8,10 +8,15 @@ Checkbox widget, used for interacting with boolean values. It does not include 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. +[hstack/vstack]("Monomer.Widgets.Containers.Stack")). Alternatively, +"Monomer.Widgets.Singles.LabeledCheckbox" provides this functionality out of the +box. -'Monomer.Widgets.Singles.ToggleButton' provides similar functionality but with +@ +checkbox booleanLens +@ + +"Monomer.Widgets.Singles.ToggleButton" provides similar functionality but with the look of a regular button. -} {-# LANGUAGE BangPatterns #-} diff --git a/src/Monomer/Widgets/Singles/ColorPicker.hs b/src/Monomer/Widgets/Singles/ColorPicker.hs --- a/src/Monomer/Widgets/Singles/ColorPicker.hs +++ b/src/Monomer/Widgets/Singles/ColorPicker.hs @@ -6,16 +6,21 @@ Stability : experimental Portability : non-portable -Color picker using sliders and numeric fields. +Color picker, displayed inside its parent container as a regular widget. + +@ +colorPicker colorLens +@ -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Strict #-} module Monomer.Widgets.Singles.ColorPicker ( -- * Configuration ColorPickerCfg, + ColorPickerEvt, -- * Constructors colorPicker, colorPicker_, @@ -122,11 +127,12 @@ _cpcOnChangeReq = [req] } +-- | Internal events for the 'colorPicker' widget. data ColorPickerEvt = PickerFocus Path | PickerBlur Path - | ColorChanged Int - | AlphaChanged Double + | PickerColorChanged Int + | PickerAlphaChanged Double deriving (Eq, Show) -- | Creates a color picker using the given lens. @@ -188,8 +194,10 @@ buildUI config wenv model = mainTree where showAlpha = fromMaybe False (_cpcShowAlpha config) colorSample = zstack [ - patternImage 2 10 (rgb 255 255 255) (rgb 150 150 150), - filler `styleBasic` [bgColor model] + patternImage 2 10 (rgb 255 255 255) (rgb 150 150 150) + `styleBasic` [radius 4], + filler + `styleBasic` [bgColor model, radius 4] ] `styleBasic` [width 32] compRow lensCol evt lbl minV maxV = hstack [ @@ -201,11 +209,11 @@ spacer_ [width 5], numericField_ lensCol [minValue minV, maxValue maxV, onChange evt, onFocus PickerFocus, onBlur PickerBlur] - `styleBasic` [width 40, padding 0, textRight] + `styleBasic` [width 40, padding 0, textAscender, textRight] ] - colorRow lens lbl = compRow lens ColorChanged lbl 0 255 - alphaRow lens lbl = compRow lens AlphaChanged lbl 0 1 + colorRow lens lbl = compRow lens PickerColorChanged lbl 0 255 + alphaRow lens lbl = compRow lens PickerAlphaChanged lbl 0 1 mainTree = hstack_ [sizeReqUpdater clearExtra] [ vstack [ @@ -234,8 +242,8 @@ | not (isNodeParentOfPath node prev) -> reportFocus prev PickerBlur next | not (isNodeParentOfPath node next) -> reportBlur next - ColorChanged _ -> reportChange - AlphaChanged _ -> reportChange + PickerColorChanged _ -> reportChange + PickerAlphaChanged _ -> reportChange _ -> [] where report reqs = RequestParent <$> reqs diff --git a/src/Monomer/Widgets/Singles/DateField.hs b/src/Monomer/Widgets/Singles/DateField.hs --- a/src/Monomer/Widgets/Singles/DateField.hs +++ b/src/Monomer/Widgets/Singles/DateField.hs @@ -6,14 +6,23 @@ Stability : experimental Portability : non-portable -Input field for dates types. +Input field for dates types with support for valid ranges, different formats and +separators. -Supports the Day type of the -library, but other types can be supported by implementing 'DayConverter'. Maybe -is also supported. +@ +dateField dateLens +@ -Supports different date formats and separators. +With configuration options: +@ +dateField_ dateLens [dateFormatMMDDYYYY, dateFormatDelimiter \'-\'] +@ + +Supports the 'Day' type of the +library, but other types can be supported by implementing 'DayConverter'. +'Maybe' is also supported. + Handles mouse wheel and shift + vertical drag to increase/decrease days. -} {-# LANGUAGE ConstraintKinds #-} @@ -25,14 +34,16 @@ module Monomer.Widgets.Singles.DateField ( -- * Configuration DateFieldCfg, + DateFieldFormat, FormattableDate, DayConverter(..), - DateTextConverter, + DateTextConverter(..), -- * Constructors dateField, dateField_, dateFieldV, dateFieldV_, + dateFieldD_, dateFormatDelimiter, dateFormatDDMMYYYY, dateFormatMMDDYYYY, @@ -61,13 +72,14 @@ import qualified Monomer.Lens as L import qualified Monomer.Widgets.Util.Parser as P -data DateFormat +-- | Available formats for 'dateField'. +data DateFieldFormat = FormatDDMMYYYY | FormatYYYYMMDD | FormatMMDDYYYY deriving (Eq, Show) -defaultDateFormat :: DateFormat +defaultDateFormat :: DateFieldFormat defaultDateFormat = FormatDDMMYYYY defaultDateDelim :: Char @@ -85,11 +97,14 @@ convertFromDay = id convertToDay = Just --- | Converts a 'Day' instance to and from 'Text'. +{-| +Converts a 'Day' instance to and from 'Text'. Implementing this typeclass +is not necessary for instances of 'DayConverter'. +-} class DateTextConverter a where - dateAcceptText :: DateFormat -> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a) - dateFromText :: DateFormat -> Char -> Text -> Maybe a - dateToText :: DateFormat -> Char -> a -> Text + dateAcceptText :: DateFieldFormat -> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a) + dateFromText :: DateFieldFormat -> Char -> Text -> Maybe a + dateToText :: DateFieldFormat -> Char -> a -> Text dateFromDay :: Day -> a dateToDay :: a -> Maybe Day @@ -134,6 +149,7 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes 'ResizeWidgets' requests. - 'selectOnFocus': Whether all input should be selected when focus is received. +- 'readOnly': Whether to prevent the user changing the input text. - 'minValue': Minimum valid date. - 'maxValue': Maximum valid date. - 'wheelRate': The rate at which wheel movement affects the date. @@ -151,17 +167,18 @@ -} data DateFieldCfg s e a = DateFieldCfg { _dfcCaretWidth :: Maybe Double, - _dfcCaretMs :: Maybe Int, + _dfcCaretMs :: Maybe Millisecond, _dfcValid :: Maybe (WidgetData s Bool), _dfcValidV :: [Bool -> e], _dfcDateDelim :: Maybe Char, - _dfcDateFormat :: Maybe DateFormat, + _dfcDateFormat :: Maybe DateFieldFormat, _dfcMinValue :: Maybe a, _dfcMaxValue :: Maybe a, _dfcWheelRate :: Maybe Double, _dfcDragRate :: Maybe Double, _dfcResizeOnChange :: Maybe Bool, _dfcSelectOnFocus :: Maybe Bool, + _dfcReadOnly :: Maybe Bool, _dfcOnFocusReq :: [Path -> WidgetRequest s e], _dfcOnBlurReq :: [Path -> WidgetRequest s e], _dfcOnChangeReq :: [a -> WidgetRequest s e] @@ -181,6 +198,7 @@ _dfcDragRate = Nothing, _dfcResizeOnChange = Nothing, _dfcSelectOnFocus = Nothing, + _dfcReadOnly = Nothing, _dfcOnFocusReq = [], _dfcOnBlurReq = [], _dfcOnChangeReq = [] @@ -200,6 +218,7 @@ _dfcDragRate = _dfcDragRate t2 <|> _dfcDragRate t1, _dfcResizeOnChange = _dfcResizeOnChange t2 <|> _dfcResizeOnChange t1, _dfcSelectOnFocus = _dfcSelectOnFocus t2 <|> _dfcSelectOnFocus t1, + _dfcReadOnly = _dfcReadOnly t2 <|> _dfcReadOnly t1, _dfcOnFocusReq = _dfcOnFocusReq t1 <> _dfcOnFocusReq t2, _dfcOnBlurReq = _dfcOnBlurReq t1 <> _dfcOnBlurReq t2, _dfcOnChangeReq = _dfcOnChangeReq t1 <> _dfcOnChangeReq t2 @@ -213,7 +232,7 @@ _dfcCaretWidth = Just w } -instance CmbCaretMs (DateFieldCfg s e a) Int where +instance CmbCaretMs (DateFieldCfg s e a) Millisecond where caretMs ms = def { _dfcCaretMs = Just ms } @@ -238,14 +257,19 @@ _dfcSelectOnFocus = Just sel } +instance CmbReadOnly (DateFieldCfg s e a) where + readOnly_ ro = def { + _dfcReadOnly = Just ro + } + instance FormattableDate a => CmbMinValue (DateFieldCfg s e a) a where - minValue len = def { - _dfcMinValue = Just len + minValue value = def { + _dfcMinValue = Just value } instance FormattableDate a => CmbMaxValue (DateFieldCfg s e a) a where - maxValue len = def { - _dfcMaxValue = Just len + maxValue value = def { + _dfcMaxValue = Just value } instance CmbWheelRate (DateFieldCfg s e a) Double where @@ -358,6 +382,7 @@ delim = fromMaybe defaultDateDelim (_dfcDateDelim config) minVal = _dfcMinValue config maxVal = _dfcMaxValue config + readOnly = fromMaybe False (_dfcReadOnly config) initialValue | isJust minVal = fromJust minVal @@ -387,9 +412,10 @@ _ifcDisplayChar = Nothing, _ifcResizeOnChange = fromMaybe False (_dfcResizeOnChange config), _ifcSelectOnFocus = fromMaybe True (_dfcSelectOnFocus config), + _ifcReadOnly = readOnly, _ifcStyle = Just L.dateFieldStyle, - _ifcWheelHandler = Just (handleWheel config), - _ifcDragHandler = Just (handleDrag config), + _ifcWheelHandler = if readOnly then Nothing else Just (handleWheel config), + _ifcDragHandler = if readOnly then Nothing else Just (handleDrag config), _ifcDragCursor = Just CursorSizeV, _ifcOnFocusReq = _dfcOnFocusReq config, _ifcOnBlurReq = _dfcOnBlurReq config, @@ -463,7 +489,7 @@ dateFromTextSimple :: (DayConverter a, FormattableDate a) - => DateFormat + => DateFieldFormat -> Char -> Text -> Maybe a @@ -478,7 +504,7 @@ | otherwise -> fromGregorianValid (fromIntegral n1) n2 n3 newDate = tmpDate >>= dateFromDay -dateToTextSimple :: FormattableDate a => DateFormat -> Char -> a -> Text +dateToTextSimple :: FormattableDate a => DateFieldFormat -> Char -> a -> Text dateToTextSimple format delim val = result where converted = dateToDay val (year, month, day) = toGregorian (fromJust converted) @@ -495,7 +521,7 @@ | format == FormatMMDDYYYY = tmonth <> sep <> tday <> sep <> tyear | otherwise = tyear <> sep <> tmonth <> sep <> tday -acceptTextInput :: DateFormat -> Char -> Text -> Bool +acceptTextInput :: DateFieldFormat -> Char -> Text -> Bool acceptTextInput format delim text = isRight (A.parseOnly parser text) where numP = A.digit *> "" delimP = A.char delim *> "" diff --git a/src/Monomer/Widgets/Singles/Dial.hs b/src/Monomer/Widgets/Singles/Dial.hs --- a/src/Monomer/Widgets/Singles/Dial.hs +++ b/src/Monomer/Widgets/Singles/Dial.hs @@ -7,9 +7,14 @@ Portability : non-portable Dial widget, used for interacting with numeric values. It allows changing the -value by keyboard arrows, dragging the mouse or using the wheel. +value using the keyboard arrows, dragging the mouse or using the wheel. -Similar in objective to "Monomer.Widgets.Singles.Slider", but uses less space. +@ +dial numericLens 0 100 +@ + +Similar in objective to "Monomer.Widgets.Singles.Slider", but uses less visual +space in its parent container. -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} diff --git a/src/Monomer/Widgets/Singles/ExternalLink.hs b/src/Monomer/Widgets/Singles/ExternalLink.hs --- a/src/Monomer/Widgets/Singles/ExternalLink.hs +++ b/src/Monomer/Widgets/Singles/ExternalLink.hs @@ -6,8 +6,12 @@ Stability : experimental 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. +Provides a clickable link that is opened by the host OS. Since it relies on the +OS to open the content, it is possible to open URIs other than urls. + +@ +externalLink "Open Wikipedia" "https://en.wikipedia.org" +@ -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Monomer/Widgets/Singles/Icon.hs b/src/Monomer/Widgets/Singles/Icon.hs --- a/src/Monomer/Widgets/Singles/Icon.hs +++ b/src/Monomer/Widgets/Singles/Icon.hs @@ -7,6 +7,10 @@ Portability : non-portable Icon widget. Used for showing basic icons without the need of an asset. + +@ +icon IconPlus +@ -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Monomer/Widgets/Singles/Image.hs b/src/Monomer/Widgets/Singles/Image.hs --- a/src/Monomer/Widgets/Singles/Image.hs +++ b/src/Monomer/Widgets/Singles/Image.hs @@ -8,6 +8,12 @@ Displays an image from local storage or a url. +@ +image "https://picsum.photos/id/1059/800/600" +@ + +It is also possible to create images from a block of memory using 'imageMem'. + Notes: - Depending on the type of image fit chosen and the assigned viewport, some diff --git a/src/Monomer/Widgets/Singles/Label.hs b/src/Monomer/Widgets/Singles/Label.hs --- a/src/Monomer/Widgets/Singles/Label.hs +++ b/src/Monomer/Widgets/Singles/Label.hs @@ -7,6 +7,18 @@ Portability : non-portable Label widget, with support for multiline text. + +Single line label: + +@ +label "This is a label" +@ + +Multi-line label: + +@ +label_ "This is a\nmultiline label" [multiline] +@ -} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Strict #-} @@ -142,7 +154,7 @@ _lstTextStyle :: Maybe TextStyle, _lstTextRect :: Rect, _lstTextLines :: Seq TextLine, - _lstPrevResize :: (Int, Bool) + _lstPrevResize :: (Millisecond, Bool) } deriving (Eq, Show, Generic) -- | Creates a label using the provided 'Text'. diff --git a/src/Monomer/Widgets/Singles/LabeledCheckbox.hs b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs --- a/src/Monomer/Widgets/Singles/LabeledCheckbox.hs +++ b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs @@ -6,8 +6,18 @@ Stability : experimental Portability : non-portable -Labeled checkbox, used for interacting with boolean values with an associated -clickable label. +Labeled checkbox, used for interacting with boolean values. In contrast to +'checkbox', it includes a clickable label. + +@ +labeledCheckbox "Bool value" booleanLens +@ + +With text in a different location: + +@ +labeledCheckbox_ "Checkbox with text below" booleanLens [textBottom] +@ -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Monomer/Widgets/Singles/LabeledRadio.hs b/src/Monomer/Widgets/Singles/LabeledRadio.hs --- a/src/Monomer/Widgets/Singles/LabeledRadio.hs +++ b/src/Monomer/Widgets/Singles/LabeledRadio.hs @@ -6,9 +6,19 @@ Stability : experimental Portability : non-portable -Radio widget, used for interacting with a fixed set of values with an associated -clickable label. Each instance of the radio will be associated with a single -value. +Labeled radio widget, used for interacting with a fixed set of values. Each +instance of labeled radio is associated with a single value. In contrast to +'radio', it includes a clickable label. + +@ +labeledRadio "First option" Option1 optionLens +@ + +With text in a different location: + +@ +labeledRadio_ "Radio with text below" Option1 optionLens [textBottom] +@ -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Monomer/Widgets/Singles/NumericField.hs b/src/Monomer/Widgets/Singles/NumericField.hs --- a/src/Monomer/Widgets/Singles/NumericField.hs +++ b/src/Monomer/Widgets/Singles/NumericField.hs @@ -6,8 +6,18 @@ Stability : experimental Portability : non-portable -Input field for numeric types. +Input field for numeric types, with support for valid ranges and decimal places. +@ +numericField numericLens +@ + +With configuration options: + +@ +numericField_ numericLens [minValue 0, maxValue 100, decimals 2] +@ + Supports instances of the 'FromFractional' typeclass. Several basic types are implemented, both for integer and floating point types. @@ -23,12 +33,13 @@ -- * Configuration NumericFieldCfg, FormattableNumber, - NumericTextConverter, + NumericTextConverter(..), -- * Constructors numericField, numericField_, numericFieldV, - numericFieldV_ + numericFieldV_, + numericFieldD_ ) where import Control.Applicative ((<|>)) @@ -56,7 +67,10 @@ import qualified Monomer.Lens as L import qualified Monomer.Widgets.Util.Parser as P --- | Converts a numeric instance to and from 'Text'. +{-| +Converts a numeric instance to and from 'Text'. Implementing this typeclass +is not necessary for instances of 'FromFractional'. +-} class NumericTextConverter a where numericAcceptText :: Maybe a -> Maybe a -> Int -> Text -> (Bool, Bool, Maybe a) numericFromText :: Text -> Maybe a @@ -107,6 +121,7 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. - 'selectOnFocus': Whether all input should be selected when focus is received. +- 'readOnly': Whether to prevent the user changing the input text. - 'minValue': Minimum valid number. - 'maxValue': Maximum valid number. - 'wheelRate': The rate at which wheel movement affects the number. @@ -122,7 +137,7 @@ -} data NumericFieldCfg s e a = NumericFieldCfg { _nfcCaretWidth :: Maybe Double, - _nfcCaretMs :: Maybe Int, + _nfcCaretMs :: Maybe Millisecond, _nfcValid :: Maybe (WidgetData s Bool), _nfcValidV :: [Bool -> e], _nfcDecimals :: Maybe Int, @@ -132,6 +147,7 @@ _nfcDragRate :: Maybe Double, _nfcResizeOnChange :: Maybe Bool, _nfcSelectOnFocus :: Maybe Bool, + _nfcReadOnly :: Maybe Bool, _nfcOnFocusReq :: [Path -> WidgetRequest s e], _nfcOnBlurReq :: [Path -> WidgetRequest s e], _nfcOnChangeReq :: [a -> WidgetRequest s e] @@ -150,6 +166,7 @@ _nfcDragRate = Nothing, _nfcResizeOnChange = Nothing, _nfcSelectOnFocus = Nothing, + _nfcReadOnly = Nothing, _nfcOnFocusReq = [], _nfcOnBlurReq = [], _nfcOnChangeReq = [] @@ -167,6 +184,7 @@ _nfcWheelRate = _nfcWheelRate t2 <|> _nfcWheelRate t1, _nfcDragRate = _nfcDragRate t2 <|> _nfcDragRate t1, _nfcResizeOnChange = _nfcResizeOnChange t2 <|> _nfcResizeOnChange t1, + _nfcReadOnly = _nfcReadOnly t2 <|> _nfcReadOnly t1, _nfcSelectOnFocus = _nfcSelectOnFocus t2 <|> _nfcSelectOnFocus t1, _nfcOnFocusReq = _nfcOnFocusReq t1 <> _nfcOnFocusReq t2, _nfcOnBlurReq = _nfcOnBlurReq t1 <> _nfcOnBlurReq t2, @@ -181,7 +199,7 @@ _nfcCaretWidth = Just w } -instance CmbCaretMs (NumericFieldCfg s e a) Int where +instance CmbCaretMs (NumericFieldCfg s e a) Millisecond where caretMs ms = def { _nfcCaretMs = Just ms } @@ -206,14 +224,19 @@ _nfcSelectOnFocus = Just sel } +instance CmbReadOnly (NumericFieldCfg s e a) where + readOnly_ ro = def { + _nfcReadOnly = Just ro + } + instance FormattableNumber a => CmbMinValue (NumericFieldCfg s e a) a where - minValue len = def { - _nfcMinValue = Just len + minValue value = def { + _nfcMinValue = Just value } instance FormattableNumber a => CmbMaxValue (NumericFieldCfg s e a) a where - maxValue len = def { - _nfcMaxValue = Just len + maxValue value = def { + _nfcMaxValue = Just value } instance CmbWheelRate (NumericFieldCfg s e a) Double where @@ -305,14 +328,17 @@ config = mconcat configs minVal = _nfcMinValue config maxVal = _nfcMaxValue config + readOnly = fromMaybe False (_nfcReadOnly config) initialValue | isJust minVal = fromJust minVal | isJust maxVal = fromJust maxVal | otherwise = numericFromFractional 0 - decimals - | isIntegral initialValue = 0 - | otherwise = max 0 $ fromMaybe 2 (_nfcDecimals config) + decimals = case _nfcDecimals config of + Just count -> max 0 count + Nothing + | isIntegral initialValue -> 0 + | otherwise -> 2 defWidth | isIntegral initialValue = 50 | otherwise = 70 @@ -340,9 +366,10 @@ _ifcDisplayChar = Nothing, _ifcResizeOnChange = fromMaybe False (_nfcResizeOnChange config), _ifcSelectOnFocus = fromMaybe True (_nfcSelectOnFocus config), + _ifcReadOnly = readOnly, _ifcStyle = Just L.numericFieldStyle, - _ifcWheelHandler = Just (handleWheel config), - _ifcDragHandler = Just (handleDrag config), + _ifcWheelHandler = if readOnly then Nothing else Just (handleWheel config), + _ifcDragHandler = if readOnly then Nothing else Just (handleDrag config), _ifcDragCursor = Just CursorSizeV, _ifcOnFocusReq = _nfcOnFocusReq config, _ifcOnBlurReq = _nfcOnBlurReq config, @@ -438,7 +465,6 @@ isIntegral :: Typeable a => a -> Bool isIntegral val | "Int" `isPrefixOf` name = True - | "Fixed" `isPrefixOf` name = True | "Word" `isPrefixOf` name = True | otherwise = False where diff --git a/src/Monomer/Widgets/Singles/OptionButton.hs b/src/Monomer/Widgets/Singles/OptionButton.hs --- a/src/Monomer/Widgets/Singles/OptionButton.hs +++ b/src/Monomer/Widgets/Singles/OptionButton.hs @@ -7,27 +7,32 @@ Portability : non-portable Option button widget, used for choosing one value from a fixed set. Each -instance of optionButton will be associated with a single value. +instance of optionButton is associated with a single value. -Its behavior is equivalent to 'Monomer.Widgets.Singles.Radio' and -'Monomer.Widgets.Singles.LabeledRadio', with a different visual representation. +@ +optionButton "First option" Option1 optionLens +@ -This widget, and the associated 'ToggleButton', uses two separate styles for the -On and Off states which can be modified individually for the theme. If you use -any of the the standard style functions (styleBasic, styleHover, etc) in an -optionButton/toggleButton these changes will apply to both On and Off states, -except for the color related styles. The reason for this is that, in general, -you will want to use the same font and padding for both states, but colors will -usually differ. For changing the colors of the Off state you can use -'optionButtonOffStyle', that receives a 'Style' instance. The values set here -are higher priority than any inherited style from the theme or node text style. +Its behavior is equivalent to "Monomer.Widgets.Singles.Radio" and +"Monomer.Widgets.Singles.LabeledRadio", with a different visual representation. +This widget, and the associated "Monomer.Widgets.Singles.ToggleButton", uses two +separate styles for the On and Off states which can be modified individually for +the theme. If you use any of the the standard style functions (styleBasic, +styleHover, etc) in an optionButton/toggleButton these changes will apply to +both On and Off states, except for the color related styles. The reason is that, +in general, the font and padding will be the same for both states, but the +colors will differ. The 'optionButtonOffStyle' option, which receives a 'Style' +instance, can be used to change the colors of the Off state. The values set with +this option are higher priority than any inherited style from the theme or node +text style. + 'Style' instances can be created this way: @ newStyle :: Style = def - `styleBasic` [textSize 20] - `styleHover` [textColor white] + \`styleBasic\` [textSize 20] + \`styleHover\` [textColor white] @ -} {-# LANGUAGE BangPatterns #-} @@ -88,8 +93,10 @@ - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. - 'onBlurReq': 'WidgetRequest' to generate when focus is lost. -- 'onChange': event to raise when the value changes/is clicked. -- 'onChangeReq': 'WidgetRequest' to generate when the value changes/is clicked. +- 'onClick': event to raise when the value is clicked. +- 'onClickReq': 'WidgetRequest' to generate when the value is clicked. +- 'onChange': event to raise when the value changes. +- 'onChangeReq': 'WidgetRequest' to generate when the value changes. -} data OptionButtonCfg s e a = OptionButtonCfg { _obcIgnoreTheme :: Maybe Bool, @@ -97,6 +104,7 @@ _obcLabelCfg :: LabelCfg s e, _obcOnFocusReq :: [Path -> WidgetRequest s e], _obcOnBlurReq :: [Path -> WidgetRequest s e], + _obcOnClickReq :: [WidgetRequest s e], _obcOnChangeReq :: [a -> WidgetRequest s e] } @@ -107,6 +115,7 @@ _obcLabelCfg = def, _obcOnFocusReq = [], _obcOnBlurReq = [], + _obcOnClickReq = [], _obcOnChangeReq = [] } @@ -117,6 +126,7 @@ _obcLabelCfg = _obcLabelCfg t1 <> _obcLabelCfg t2, _obcOnFocusReq = _obcOnFocusReq t1 <> _obcOnFocusReq t2, _obcOnBlurReq = _obcOnBlurReq t1 <> _obcOnBlurReq t2, + _obcOnClickReq = _obcOnClickReq t1 <> _obcOnClickReq t2, _obcOnChangeReq = _obcOnChangeReq t1 <> _obcOnChangeReq t2 } @@ -181,6 +191,16 @@ _obcOnBlurReq = [req] } +instance WidgetEvent e => CmbOnClick (OptionButtonCfg s e a) e where + onClick req = def { + _obcOnClickReq = [RaiseEvent req] + } + +instance CmbOnClickReq (OptionButtonCfg s e a) s e where + onClickReq req = def { + _obcOnClickReq = [req] + } + instance WidgetEvent e => CmbOnChange (OptionButtonCfg s e a) a e where onChange fn = def { _obcOnChangeReq = [RaiseEvent . fn] @@ -259,6 +279,10 @@ optionButtonNode = defaultWidgetNode wtype widget & L.info . L.focusable .~ True +{-| +Helper function for creating a button associated to a value. Used by +_optionButton_ and _toggleButton_. +-} makeOptionButton :: OptionButtonValue a => Lens' ThemeState StyleState @@ -339,7 +363,11 @@ currValue = widgetDataGet (wenv ^. L.model) field nextValue = getNextVal currValue setValueReq = widgetDataSet field nextValue - reqs = setValueReq ++ fmap ($ nextValue) (_obcOnChangeReq config) + clickReqs = _obcOnClickReq config + changeReqs + | currValue /= nextValue = fmap ($ nextValue) (_obcOnChangeReq config) + | otherwise = [] + reqs = setValueReq ++ clickReqs ++ changeReqs result = resultReqs node reqs resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)] diff --git a/src/Monomer/Widgets/Singles/Radio.hs b/src/Monomer/Widgets/Singles/Radio.hs --- a/src/Monomer/Widgets/Singles/Radio.hs +++ b/src/Monomer/Widgets/Singles/Radio.hs @@ -7,12 +7,17 @@ Portability : non-portable Radio widget, used for interacting with a fixed set of values. Each instance of -the radio will be associated with a single value. It does not include text, -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. +the radio is associated with a single value. It does not include text, which can +be added with a label in the desired position (usually with +[hstack/vstack]("Monomer.Widgets.Containers.Stack")). Alternatively, +"Monomer.Widgets.Singles.LabeledRadio" provides this functionality out of the +box. -'Monomer.Widgets.Singles.OptionButton' provides similar functionality but with +@ +radio Option1 optionLens +@ + +"Monomer.Widgets.Singles.OptionButton" provides similar functionality but with the look of a regular button. -} {-# LANGUAGE BangPatterns #-} @@ -57,13 +62,16 @@ - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. - 'onBlurReq': 'WidgetRequest' to generate when focus is lost. -- 'onChange': event to raise when the value changes/is clicked. -- 'onChangeReq': 'WidgetRequest' to generate when the value changes/is clicked. +- 'onClick': event to raise when the value is clicked. +- 'onClickReq': 'WidgetRequest' to generate when the value is clicked. +- 'onChange': event to raise when the value changes. +- 'onChangeReq': 'WidgetRequest' to generate when the value changes. -} data RadioCfg s e a = RadioCfg { _rdcWidth :: Maybe Double, _rdcOnFocusReq :: [Path -> WidgetRequest s e], _rdcOnBlurReq :: [Path -> WidgetRequest s e], + _rdcOnClickReq :: [WidgetRequest s e], _rdcOnChangeReq :: [a -> WidgetRequest s e] } @@ -72,6 +80,7 @@ _rdcWidth = Nothing, _rdcOnFocusReq = [], _rdcOnBlurReq = [], + _rdcOnClickReq = [], _rdcOnChangeReq = [] } @@ -80,6 +89,7 @@ _rdcWidth = _rdcWidth t2 <|> _rdcWidth t1, _rdcOnFocusReq = _rdcOnFocusReq t1 <> _rdcOnFocusReq t2, _rdcOnBlurReq = _rdcOnBlurReq t1 <> _rdcOnBlurReq t2, + _rdcOnClickReq = _rdcOnClickReq t1 <> _rdcOnClickReq t2, _rdcOnChangeReq = _rdcOnChangeReq t1 <> _rdcOnChangeReq t2 } @@ -111,6 +121,16 @@ _rdcOnBlurReq = [req] } +instance WidgetEvent e => CmbOnClick (RadioCfg s e a) e where + onClick fn = def { + _rdcOnClickReq = [RaiseEvent fn] + } + +instance CmbOnClickReq (RadioCfg s e a) s e where + onClickReq req = def { + _rdcOnClickReq = [req] + } + instance WidgetEvent e => CmbOnChange (RadioCfg s e a) a e where onChange fn = def { _rdcOnChangeReq = [RaiseEvent . fn] @@ -208,8 +228,14 @@ rdArea = getRadioArea wenv node config path = node ^. L.info . L.path isSelectKey code = isKeyReturn code || isKeySpace code + + currValue = widgetDataGet (wenv ^. L.model) field setValueReq = widgetDataSet field option - reqs = setValueReq ++ fmap ($ option) (_rdcOnChangeReq config) + clickReqs = _rdcOnClickReq config + changeReqs + | currValue /= option = fmap ($ option) (_rdcOnChangeReq config) + | otherwise = [] + reqs = setValueReq ++ clickReqs ++ changeReqs getSizeReq wenv node = req where theme = currentTheme wenv node diff --git a/src/Monomer/Widgets/Singles/SeparatorLine.hs b/src/Monomer/Widgets/Singles/SeparatorLine.hs --- a/src/Monomer/Widgets/Singles/SeparatorLine.hs +++ b/src/Monomer/Widgets/Singles/SeparatorLine.hs @@ -10,8 +10,16 @@ to the active layout direction, creating a vertical line on a horizontal layout and viceversa. -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 +@ +hstack [ + label "Left half", + separatorLine, + label "Right half" +] +@ + +The separator line has the provided width in the direction orthogonal to the +parent layout, and takes all the available space in the other axis. In case of wanting a shorter line, padding should be used. -} {-# LANGUAGE BangPatterns #-} diff --git a/src/Monomer/Widgets/Singles/Slider.hs b/src/Monomer/Widgets/Singles/Slider.hs --- a/src/Monomer/Widgets/Singles/Slider.hs +++ b/src/Monomer/Widgets/Singles/Slider.hs @@ -7,9 +7,13 @@ Portability : non-portable Slider widget, used for interacting with numeric values. It allows changing the -value by keyboard arrows, dragging the mouse or using the wheel. +value using the keyboard arrows, dragging the mouse or using the wheel. -Similar in objective to 'Monomer.Widgets.Singles.Dial', but more convenient in +@ +hslider numericLens 0 100 +@ + +Similar in objective to "Monomer.Widgets.Singles.Dial", but more convenient in some layouts. -} {-# LANGUAGE BangPatterns #-} diff --git a/src/Monomer/Widgets/Singles/Spacer.hs b/src/Monomer/Widgets/Singles/Spacer.hs --- a/src/Monomer/Widgets/Singles/Spacer.hs +++ b/src/Monomer/Widgets/Singles/Spacer.hs @@ -7,10 +7,27 @@ Portability : non-portable Spacer is used for adding a fixed space between two widgets. + +@ +hstack [ + label \"Username\", + spacer, + label username +] +@ + Filler is used for taking all the unused space between two widgets. Useful for alignment purposes. -Both adapt to the current layout direction, if any. +@ +hstack [ + label "Section title", + filler, + button \"Close\" CloseSection +] +@ + +Both adapt to the active layout direction. -} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Monomer/Widgets/Singles/TextArea.hs b/src/Monomer/Widgets/Singles/TextArea.hs --- a/src/Monomer/Widgets/Singles/TextArea.hs +++ b/src/Monomer/Widgets/Singles/TextArea.hs @@ -6,7 +6,18 @@ Stability : experimental Portability : non-portable -Input field for multiline 'Text'. +Input field for multiline 'Text'. Allows setting the maximum number of +characters, lines and whether the tab key should trigger focus change. + +@ +textArea longTextLens +@ + +With configuration options: + +@ +textArea_ longTextLens [maxLength 1000, selectOnFocus] +@ -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} @@ -23,11 +34,12 @@ textArea, textArea_, textAreaV, - textAreaV_ + textAreaV_, + textAreaD_ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (^?), (.~), (%~), (<>~), ALens', ix, view) +import Control.Lens hiding ((|>)) import Control.Monad (forM_, when) import Data.Default import Data.Foldable (toList) @@ -49,7 +61,7 @@ defCaretW :: Double defCaretW = 2 -defCaretMs :: Int +defCaretMs :: Millisecond defCaretMs = 500 {-| @@ -60,6 +72,7 @@ - 'acceptTab': whether to handle tab and convert it to spaces (cancelling change of focus), or keep default behaviour and lose focus. - 'selectOnFocus': Whether all input should be selected when focus is received. +- 'readOnly': Whether to prevent the user changing the input text. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. @@ -69,11 +82,12 @@ -} data TextAreaCfg s e = TextAreaCfg { _tacCaretWidth :: Maybe Double, - _tacCaretMs :: Maybe Int, + _tacCaretMs :: Maybe Millisecond, _tacMaxLength :: Maybe Int, _tacMaxLines :: Maybe Int, _tacAcceptTab :: Maybe Bool, _tacSelectOnFocus :: Maybe Bool, + _tacReadOnly :: Maybe Bool, _tacOnFocusReq :: [Path -> WidgetRequest s e], _tacOnBlurReq :: [Path -> WidgetRequest s e], _tacOnChangeReq :: [Text -> WidgetRequest s e] @@ -87,6 +101,7 @@ _tacMaxLines = Nothing, _tacAcceptTab = Nothing, _tacSelectOnFocus = Nothing, + _tacReadOnly = Nothing, _tacOnFocusReq = [], _tacOnBlurReq = [], _tacOnChangeReq = [] @@ -100,6 +115,7 @@ _tacMaxLines = _tacMaxLines t2 <|> _tacMaxLines t1, _tacAcceptTab = _tacAcceptTab t2 <|> _tacAcceptTab t1, _tacSelectOnFocus = _tacSelectOnFocus t2 <|> _tacSelectOnFocus t1, + _tacReadOnly = _tacReadOnly t2 <|> _tacReadOnly t1, _tacOnFocusReq = _tacOnFocusReq t1 <> _tacOnFocusReq t2, _tacOnBlurReq = _tacOnBlurReq t1 <> _tacOnBlurReq t2, _tacOnChangeReq = _tacOnChangeReq t1 <> _tacOnChangeReq t2 @@ -113,7 +129,7 @@ _tacCaretWidth = Just w } -instance CmbCaretMs (TextAreaCfg s e) Int where +instance CmbCaretMs (TextAreaCfg s e) Millisecond where caretMs ms = def { _tacCaretMs = Just ms } @@ -138,6 +154,11 @@ _tacSelectOnFocus = Just sel } +instance CmbReadOnly (TextAreaCfg s e) where + readOnly_ ro = def { + _tacReadOnly = Just ro + } + instance WidgetEvent e => CmbOnFocus (TextAreaCfg s e) e Path where onFocus fn = def { _tacOnFocusReq = [RaiseEvent . fn] @@ -183,7 +204,7 @@ _tasTextLines :: Seq TextLine, _tasHistory :: Seq HistoryStep, _tasHistoryIdx :: Int, - _tasFocusStart :: Int + _tasFocusStart :: Millisecond } deriving (Eq, Show, Generic) instance Default TextAreaState where @@ -254,6 +275,7 @@ !caretMs = fromMaybe defCaretMs (_tacCaretMs config) !maxLength = _tacMaxLength config !maxLines = _tacMaxLines config + !editable = _tacReadOnly config /= Just True getModelValue !wenv = widgetDataGet (_weModel wenv) wdata -- State !currText = _tasText state @@ -291,10 +313,10 @@ reqs = [RenderStop widgetId] handleKeyPress wenv mod code - | isDelBackWordNoSel = Just removeWordL - | isDelBackWord = Just (replaceText state selStart "") - | isBackspace && emptySel = Just removeCharL - | isBackspace = Just (replaceText state selStart "") + | isDelBackWordNoSel && editable = Just removeWordL + | isDelBackWord && editable = Just (replaceText state selStart "") + | isBackspace && emptySel && editable = Just removeCharL + | isBackspace && editable = Just (replaceText state selStart "") | isMoveLeft = Just $ moveCursor txt (tpX - 1, tpY) Nothing | isMoveRight = Just $ moveCursor txt (tpX + 1, tpY) Nothing | isMoveUp = Just $ moveCursor txt (tpX, tpY - 1) Nothing @@ -534,12 +556,12 @@ KeyAction mod code KeyPressed | isKeyboardCopy wenv evt -> Just resultCopy - | isKeyboardPaste wenv evt -> Just resultPaste - | isKeyboardCut wenv evt -> Just resultCut - | isKeyboardUndo wenv evt -> Just $ moveHistory bwdState (-1) - | isKeyboardRedo wenv evt -> Just $ moveHistory state 1 - | isKeyReturn code -> Just resultReturn - | isKeyTab code && acceptTab -> Just resultTab + | isKeyboardPaste wenv evt && editable -> Just resultPaste + | isKeyboardCut wenv evt && editable -> Just resultCut + | isKeyboardUndo wenv evt && editable -> Just $ moveHistory bwdState (-1) + | isKeyboardRedo wenv evt && editable -> Just $ moveHistory state 1 + | isKeyReturn code && editable -> Just resultReturn + | isKeyTab code && acceptTab && editable -> Just resultTab | otherwise -> fmap handleKeyRes (handleKeyPress wenv mod code) where acceptTab = fromMaybe False (_tacAcceptTab config) @@ -576,8 +598,9 @@ & L.widget .~ makeTextArea wdata config newState result = resultReqs newNode (generateReqs wenv node newState) - TextInput newText -> Just result where - result = insertText wenv node newText + TextInput newText + | editable -> Just result where + result = insertText wenv node newText Clipboard (ClipboardText newText) -> Just result where result = insertText wenv node newText @@ -644,10 +667,10 @@ generateScrollReq wenv node newState = scrollReq where style = currentStyle wenv node scPath = parentPath node - scWid = findWidgetIdFromPath wenv scPath + scWid = widgetIdFromPath wenv scPath contentArea = getContentArea node style offset = Point (contentArea ^. L.x) (contentArea ^. L.y) - caretRect = getCaretRect config newState True + caretRect = getCaretRect config newState -- Padding/border added to show left/top borders when moving near them scrollRect = fromMaybe caretRect (addOuterBounds style caretRect) scrollMsg = ScrollTo $ moveRect offset scrollRect @@ -683,43 +706,41 @@ caretTs = ts - _tasFocusStart state caretRequired = focused && even (caretTs `div` caretMs) caretColor = styleFontColor style - caretRect = getCaretRect config state False + caretRect = getCaretRect config state selRequired = isJust (_tasSelStart state) selColor = styleHlColor style selRects = getSelectionRects state contentArea -getCaretRect :: TextAreaCfg s e -> TextAreaState -> Bool -> Rect -getCaretRect config state addSpcV = caretRect where - caretW = fromMaybe defCaretW (_tacCaretWidth config) +getCaretRect :: TextAreaCfg s e -> TextAreaState -> Rect +getCaretRect config state = caretRect where (cursorX, cursorY) = _tasCursorPos state - TextMetrics _ _ lineh _ = _tasTextMetrics state + Rect tx ty _ _ = lineRect + TextMetrics asc desc lineh _ = _tasTextMetrics state textLines = _tasTextLines state - (lineRect, glyphs, spaceV) = case Seq.lookup cursorY textLines of + (lineRect, glyphs, fspaceV) = case Seq.lookup cursorY textLines of Just tl -> (tl ^. L.rect, tl ^. L.glyphs, tl ^. L.fontSpaceV) Nothing -> (def, Seq.empty, def) - - Rect tx ty _ _ = lineRect - totalH - | addSpcV = lineh + unFontSpace spaceV - | otherwise = lineh + spaceV = unFontSpace fspaceV caretPos | cursorX == 0 || cursorX > length glyphs = 0 | cursorX == length glyphs = _glpXMax (Seq.index glyphs (cursorX - 1)) | otherwise = _glpXMin (Seq.index glyphs cursorX) + caretX = max 0 (tx + caretPos) - caretY - | cursorY == length textLines = fromIntegral cursorY * totalH - | otherwise = ty - caretRect = Rect caretX caretY caretW totalH + caretY = ty - spaceV + caretW = fromMaybe defCaretW (_tacCaretWidth config) + caretH = lineh + spaceV + caretRect = Rect caretX caretY caretW caretH + getSelectionRects :: TextAreaState -> Rect -> [Rect] getSelectionRects state contentArea = rects where currPos = _tasCursorPos state currSel = fromMaybe def (_tasSelStart state) - TextMetrics _ _ lineh _ = _tasTextMetrics state + TextMetrics asc desc lineh _ = _tasTextMetrics state textLines = _tasTextLines state spaceV = getSpaceV textLines @@ -740,14 +761,16 @@ | swap currPos <= swap currSel = (currPos, currSel) | otherwise = (currSel, currPos) + totalH = lineh + spaceV updateRect rect = rect - & L.h .~ lineh + spaceV + & L.y -~ spaceV + & L.h .~ totalH & L.w %~ max 5 -- Empty lines show a small rect to indicate they are there. makeRect cx1 cx2 cy = Rect rx ry rw rh where rx = glyphPos cx1 cy rw = glyphPos cx2 cy - rx - ry = fromIntegral cy * (lineh + spaceV) - rh = lineh + spaceV + ry = fromIntegral cy * totalH - spaceV + rh = totalH rects | selY1 == selY2 = [makeRect selX1 selX2 selY1] | otherwise = begin : middle ++ end where @@ -907,7 +930,7 @@ glyphs | Seq.null lineGlyphs = Seq.empty - | otherwise = lineGlyphs |> GlyphPos ' ' textLen 0 0 0 0 0 + | otherwise = lineGlyphs |> GlyphPos ' ' 0 textLen 0 0 0 0 0 glyphStart i g = (i, abs (_glpXMin g - x)) pairs = Seq.mapWithIndex glyphStart glyphs diff --git a/src/Monomer/Widgets/Singles/TextDropdown.hs b/src/Monomer/Widgets/Singles/TextDropdown.hs --- a/src/Monomer/Widgets/Singles/TextDropdown.hs +++ b/src/Monomer/Widgets/Singles/TextDropdown.hs @@ -7,8 +7,14 @@ Portability : non-portable Dropdown widget, allowing selection of a single item from a collapsable list. -Both header and list content is text based. In case a customizable version is -is needed, 'Monomer.Widgets.Containers.Dropdown' can be used. +Both header and list content are text based. + +@ +textDropdown textLens ["Option 1", "Option 2", "Option 3"] +@ + +In case a customizable version is needed, to display rich content in the header +or list items, "Monomer.Widgets.Containers.Dropdown" can be used. -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Strict #-} diff --git a/src/Monomer/Widgets/Singles/TextField.hs b/src/Monomer/Widgets/Singles/TextField.hs --- a/src/Monomer/Widgets/Singles/TextField.hs +++ b/src/Monomer/Widgets/Singles/TextField.hs @@ -6,7 +6,19 @@ Stability : experimental Portability : non-portable -Input field for single line 'Text'. +Input field for single line 'Text'. Allows setting the maximum number of +characters and a replacement character for password. + +@ +textField shortTextLens +@ + +With configuration options: + +@ +textField_ shortTextLens [maxLength 100, selectOnFocus_ False] +@ + -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -47,6 +59,7 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. - 'selectOnFocus': Whether all input should be selected when focus is received. +- 'readOnly': Whether to prevent the user changing the input text. - 'maxLength': the maximum length of input text. - 'textFieldDisplayChar': the character that will be displayed as replacement of the real text. Useful for password fields. @@ -59,7 +72,7 @@ -} data TextFieldCfg s e = TextFieldCfg { _tfcCaretWidth :: Maybe Double, - _tfcCaretMs :: Maybe Int, + _tfcCaretMs :: Maybe Millisecond, _tfcDisplayChar :: Maybe Char, _tfcPlaceholder :: Maybe Text, _tfcValid :: Maybe (WidgetData s Bool), @@ -67,6 +80,7 @@ _tfcMaxLength :: Maybe Int, _tfcResizeOnChange :: Maybe Bool, _tfcSelectOnFocus :: Maybe Bool, + _tfcReadOnly :: Maybe Bool, _tfcOnFocusReq :: [Path -> WidgetRequest s e], _tfcOnBlurReq :: [Path -> WidgetRequest s e], _tfcOnChangeReq :: [Text -> WidgetRequest s e] @@ -83,6 +97,7 @@ _tfcMaxLength = Nothing, _tfcResizeOnChange = Nothing, _tfcSelectOnFocus = Nothing, + _tfcReadOnly = Nothing, _tfcOnFocusReq = [], _tfcOnBlurReq = [], _tfcOnChangeReq = [] @@ -99,6 +114,7 @@ _tfcMaxLength = _tfcMaxLength t2 <|> _tfcMaxLength t1, _tfcResizeOnChange = _tfcResizeOnChange t2 <|> _tfcResizeOnChange t1, _tfcSelectOnFocus = _tfcSelectOnFocus t2 <|> _tfcSelectOnFocus t1, + _tfcReadOnly = _tfcReadOnly t2 <|> _tfcReadOnly t1, _tfcOnFocusReq = _tfcOnFocusReq t1 <> _tfcOnFocusReq t2, _tfcOnBlurReq = _tfcOnBlurReq t1 <> _tfcOnBlurReq t2, _tfcOnChangeReq = _tfcOnChangeReq t1 <> _tfcOnChangeReq t2 @@ -112,7 +128,7 @@ _tfcCaretWidth = Just w } -instance CmbCaretMs (TextFieldCfg s e) Int where +instance CmbCaretMs (TextFieldCfg s e) Millisecond where caretMs ms = def { _tfcCaretMs = Just ms } @@ -142,6 +158,11 @@ _tfcSelectOnFocus = Just sel } +instance CmbReadOnly (TextFieldCfg s e) where + readOnly_ ro = def { + _tfcReadOnly = Just ro + } + instance CmbMaxLength (TextFieldCfg s e) where maxLength len = def { _tfcMaxLength = Just len @@ -227,6 +248,7 @@ _ifcDisplayChar = _tfcDisplayChar config, _ifcResizeOnChange = fromMaybe False (_tfcResizeOnChange config), _ifcSelectOnFocus = fromMaybe False (_tfcSelectOnFocus config), + _ifcReadOnly = fromMaybe False (_tfcReadOnly config), _ifcStyle = Just L.textFieldStyle, _ifcWheelHandler = Nothing, _ifcDragHandler = Nothing, diff --git a/src/Monomer/Widgets/Singles/TimeField.hs b/src/Monomer/Widgets/Singles/TimeField.hs --- a/src/Monomer/Widgets/Singles/TimeField.hs +++ b/src/Monomer/Widgets/Singles/TimeField.hs @@ -6,14 +6,22 @@ Stability : experimental Portability : non-portable -Input field for time types. +Input field for time types with support for different formats. -Supports TimeOfDay type of the -library, but other types can be supported by implementing 'TimeOfDayConverter'. -Maybe is also supported. +@ +timeField timeLens +@ -Supports different time formats. +With configuration options: +@ +timeField_ timeLens [timeFormatHHMMSS] +@ + +Supports 'TimeOfDay' type of the +library, but other types can be supported by implementing 'TimeOfDayConverter'. +'Maybe' is also supported. + Handles mouse wheel and shift + vertical drag to increase/decrease minutes. -} {-# LANGUAGE ConstraintKinds #-} @@ -26,12 +34,15 @@ -- * Configuration TimeFieldCfg, FormattableTime, + TimeFieldFormat, TimeOfDayConverter(..), + TimeTextConverter(..), -- * Constructors timeField, timeField_, timeFieldV, timeFieldV_, + timeFieldD_, timeFormatHHMM, timeFormatHHMMSS ) where @@ -58,12 +69,13 @@ import qualified Monomer.Lens as L import qualified Monomer.Widgets.Util.Parser as P -data TimeFormat +-- | Available formats for 'timeField'. +data TimeFieldFormat = FormatHHMM | FormatHHMMSS deriving (Eq, Show) -defaultTimeFormat :: TimeFormat +defaultTimeFormat :: TimeFieldFormat defaultTimeFormat = FormatHHMM defaultTimeDelim :: Char @@ -81,11 +93,14 @@ convertFromTimeOfDay = id convertToTimeOfDay = Just --- | Converts a 'TimeOfDay' instance to and from 'Text'. +{-| +Converts a 'TimeOfDay' instance to and from 'Text'. Implementing this typeclass +is not necessary for instances of 'TimeOfDayConverter'. +-} class TimeTextConverter a where - timeAcceptText :: TimeFormat -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a) - timeFromText :: TimeFormat -> Text -> Maybe a - timeToText :: TimeFormat -> a -> Text + timeAcceptText :: TimeFieldFormat -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a) + timeFromText :: TimeFieldFormat -> Text -> Maybe a + timeToText :: TimeFieldFormat -> a -> Text timeFromTimeOfDay' :: TimeOfDay -> a timeToTimeOfDay' :: a -> Maybe TimeOfDay @@ -130,10 +145,11 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. - 'selectOnFocus': Whether all input should be selected when focus is received. -- 'minValue': Minimum valid date. -- 'maxValue': Maximum valid date. -- 'wheelRate': The rate at which wheel movement affects the date. -- 'dragRate': The rate at which drag movement affects the date. +- 'readOnly': Whether to prevent the user changing the input text. +- 'minValue': Minimum valid time. +- 'maxValue': Maximum valid time. +- 'wheelRate': The rate at which wheel movement affects the time. +- 'dragRate': The rate at which drag movement affects the time. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. @@ -145,16 +161,17 @@ -} data TimeFieldCfg s e a = TimeFieldCfg { _tfcCaretWidth :: Maybe Double, - _tfcCaretMs :: Maybe Int, + _tfcCaretMs :: Maybe Millisecond, _tfcValid :: Maybe (WidgetData s Bool), _tfcValidV :: [Bool -> e], - _tfcTimeFormat :: Maybe TimeFormat, + _tfcTimeFormat :: Maybe TimeFieldFormat, _tfcMinValue :: Maybe a, _tfcMaxValue :: Maybe a, _tfcWheelRate :: Maybe Double, _tfcDragRate :: Maybe Double, _tfcResizeOnChange :: Maybe Bool, _tfcSelectOnFocus :: Maybe Bool, + _tfcReadOnly :: Maybe Bool, _tfcOnFocusReq :: [Path -> WidgetRequest s e], _tfcOnBlurReq :: [Path -> WidgetRequest s e], _tfcOnChangeReq :: [a -> WidgetRequest s e] @@ -173,6 +190,7 @@ _tfcDragRate = Nothing, _tfcResizeOnChange = Nothing, _tfcSelectOnFocus = Nothing, + _tfcReadOnly = Nothing, _tfcOnFocusReq = [], _tfcOnBlurReq = [], _tfcOnChangeReq = [] @@ -191,6 +209,7 @@ _tfcDragRate = _tfcDragRate t2 <|> _tfcDragRate t1, _tfcResizeOnChange = _tfcResizeOnChange t2 <|> _tfcResizeOnChange t1, _tfcSelectOnFocus = _tfcSelectOnFocus t2 <|> _tfcSelectOnFocus t1, + _tfcReadOnly = _tfcReadOnly t2 <|> _tfcReadOnly t1, _tfcOnFocusReq = _tfcOnFocusReq t1 <> _tfcOnFocusReq t2, _tfcOnBlurReq = _tfcOnBlurReq t1 <> _tfcOnBlurReq t2, _tfcOnChangeReq = _tfcOnChangeReq t1 <> _tfcOnChangeReq t2 @@ -204,7 +223,7 @@ _tfcCaretWidth = Just w } -instance CmbCaretMs (TimeFieldCfg s e a) Int where +instance CmbCaretMs (TimeFieldCfg s e a) Millisecond where caretMs ms = def { _tfcCaretMs = Just ms } @@ -229,6 +248,11 @@ _tfcSelectOnFocus = Just sel } +instance CmbReadOnly (TimeFieldCfg s e a) where + readOnly_ ro = def { + _tfcReadOnly = Just ro + } + instance FormattableTime a => CmbMinValue (TimeFieldCfg s e a) a where minValue len = def { _tfcMinValue = Just len @@ -336,6 +360,7 @@ format = fromMaybe defaultTimeFormat (_tfcTimeFormat config) minVal = _tfcMinValue config maxVal = _tfcMaxValue config + readOnly = fromMaybe False (_tfcReadOnly config) initialValue | isJust minVal = fromJust minVal | isJust maxVal = fromJust maxVal @@ -364,9 +389,10 @@ _ifcDisplayChar = Nothing, _ifcResizeOnChange = fromMaybe False (_tfcResizeOnChange config), _ifcSelectOnFocus = fromMaybe True (_tfcSelectOnFocus config), + _ifcReadOnly = readOnly, _ifcStyle = Just L.timeFieldStyle, - _ifcWheelHandler = Just (handleWheel config), - _ifcDragHandler = Just (handleDrag config), + _ifcWheelHandler = if readOnly then Nothing else Just (handleWheel config), + _ifcDragHandler = if readOnly then Nothing else Just (handleDrag config), _ifcDragCursor = Just CursorSizeV, _ifcOnFocusReq = _tfcOnFocusReq config, _ifcOnBlurReq = _tfcOnBlurReq config, @@ -439,7 +465,7 @@ timeFromTextSimple :: (TimeOfDayConverter a, FormattableTime a) - => TimeFormat + => TimeFieldFormat -> Text -> Maybe a timeFromTextSimple format text = newTime where @@ -454,7 +480,7 @@ | otherwise -> makeTimeOfDayValid n1 n2 (fromIntegral n3) newTime = tmpTime >>= timeFromTimeOfDay' -timeToTextSimple :: FormattableTime a => TimeFormat -> a -> Text +timeToTextSimple :: FormattableTime a => TimeFieldFormat -> a -> Text timeToTextSimple format val = result where sep = T.singleton defaultTimeDelim converted = timeToTimeOfDay' val @@ -470,7 +496,7 @@ | format == FormatHHMM = thh <> sep <> tmm | otherwise = thh <> sep <> tmm <> sep <> tss -acceptTextInput :: TimeFormat -> Text -> Bool +acceptTextInput :: TimeFieldFormat -> Text -> Bool acceptTextInput format text = isRight (A.parseOnly parser text) where numP = A.digit *> "" delimP = A.char defaultTimeDelim *> "" diff --git a/src/Monomer/Widgets/Singles/ToggleButton.hs b/src/Monomer/Widgets/Singles/ToggleButton.hs --- a/src/Monomer/Widgets/Singles/ToggleButton.hs +++ b/src/Monomer/Widgets/Singles/ToggleButton.hs @@ -6,15 +6,18 @@ Stability : experimental Portability : non-portable -Toggle button widget, used for boolean properties. +Toggle button widget, used for boolean values. -Its behavior is equivalent to 'Monomer.Widgets.Singles.Checkbox' and -'Monomer.Widgets.Singles.LabeledCheckbox', with a different visual +@ +toggleButton \"Toggle\" booleanLens +@ + +Its behavior is equivalent to "Monomer.Widgets.Singles.Checkbox" and +"Monomer.Widgets.Singles.LabeledCheckbox", with a different visual representation. -See 'Monomer.Widgets.Singles.OptionButton' for detailed notes. +See "Monomer.Widgets.Singles.OptionButton" for detailed notes. -} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StrictData #-} @@ -59,8 +62,10 @@ - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. - 'onBlurReq': 'WidgetRequest' to generate when focus is lost. -- 'onChange': event to raise when the value changes/is clicked. -- 'onChangeReq': 'WidgetRequest' to generate when the value changes/is clicked. +- 'onClick': event to raise when the value is clicked. +- 'onClickReq': 'WidgetRequest' to generate when the value is clicked. +- 'onChange': event to raise when the value changes. +- 'onChangeReq': 'WidgetRequest' to generate when the value changes. -} type ToggleButtonCfg = OptionButtonCfg diff --git a/src/Monomer/Widgets/Util/Widget.hs b/src/Monomer/Widgets/Util/Widget.hs --- a/src/Monomer/Widgets/Util/Widget.hs +++ b/src/Monomer/Widgets/Util/Widget.hs @@ -33,7 +33,6 @@ infoMatches, nodeMatches, handleWidgetIdChange, - findWidgetIdFromPath, delayedMessage, delayedMessage_ ) where @@ -202,21 +201,15 @@ & L.requests %~ (SetWidgetPath widgetId newPath <|) | otherwise = result --- | Returns the WidgetId associated to the given path, if any. -findWidgetIdFromPath :: WidgetEnv s e -> Path -> Maybe WidgetId -findWidgetIdFromPath wenv path = mwni ^? _Just . L.widgetId where - branch = wenv ^. L.findBranchByPath $ path - mwni = Seq.lookup (length branch - 1) branch - -- | Sends a message to the given node with a delay of n ms. -delayedMessage :: Typeable i => WidgetNode s e -> i -> Int -> WidgetRequest s e +delayedMessage :: Typeable i => WidgetNode s e -> i -> Millisecond -> WidgetRequest s e delayedMessage node msg delay = delayedMessage_ widgetId path msg delay where widgetId = node ^. L.info . L.widgetId path = node ^. L.info . L.path -- | Sends a message to the given WidgetId with a delay of n ms. delayedMessage_ - :: Typeable i => WidgetId -> Path -> i -> Int -> WidgetRequest s e + :: Typeable i => WidgetId -> Path -> i -> Millisecond -> WidgetRequest s e delayedMessage_ widgetId path msg delay = RunTask widgetId path $ do - threadDelay (delay * 1000) + threadDelay (fromIntegral delay * 1000) return msg diff --git a/test/unit/Monomer/Common/CursorIconSpec.hs b/test/unit/Monomer/Common/CursorIconSpec.hs --- a/test/unit/Monomer/Common/CursorIconSpec.hs +++ b/test/unit/Monomer/Common/CursorIconSpec.hs @@ -21,7 +21,6 @@ import Data.Maybe import Data.Sequence (Seq(..)) import Data.Text (Text) -import Safe import Test.Hspec import qualified Data.Map.Strict as M @@ -31,6 +30,7 @@ import Monomer.Core.Combinators import Monomer.Core.Themes.SampleThemes import Monomer.Event +import Monomer.Helper (headMay) import Monomer.Main import Monomer.TestUtil import Monomer.TestEventUtil diff --git a/test/unit/Monomer/Core/StyleUtilSpec.hs b/test/unit/Monomer/Core/StyleUtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Core/StyleUtilSpec.hs @@ -0,0 +1,78 @@ +{-| +Module : Monomer.Core.StyleUtilSpec +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 StyleUtil functions. +-} +module Monomer.Core.StyleUtilSpec (spec) where + +import Control.Lens +import Test.Hspec + +import Monomer.Core.Combinators +import Monomer.Graphics (Color, rgb) +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +red :: Color +red = rgb 255 0 0 + +spec :: Spec +spec = describe "StyleUtil" $ do + styleStateSpec + +styleStateSpec :: Spec +styleStateSpec = describe "StyleState actions" $ do + describe "StyleState merge" $ do + it "should merge basic styles" $ do + checkStyleAction styleBasic L.basic mergedStyles + + it "should merge hover styles" $ do + checkStyleAction styleHover L.hover mergedStyles + + it "should merge focus styles" $ do + checkStyleAction styleFocus L.focus mergedStyles + + it "should merge hover focus styles" $ do + checkStyleAction styleFocusHover L.focusHover mergedStyles + + it "should merge active styles" $ do + checkStyleAction styleActive L.active mergedStyles + + it "should merge disabled styles" $ do + checkStyleAction styleDisabled L.disabled mergedStyles + + describe "StyleState merge" $ do + it "should set basic styles" $ do + checkStyleAction styleBasicSet L.basic newStyles + + it "should set hover styles" $ do + checkStyleAction styleHoverSet L.hover newStyles + + it "should set focus styles" $ do + checkStyleAction styleFocusSet L.focus newStyles + + it "should set focus hover styles" $ do + checkStyleAction styleFocusHoverSet L.focusHover newStyles + + it "should set active styles" $ do + checkStyleAction styleActiveSet L.active newStyles + + it "should set disabled styles" $ do + checkStyleAction styleDisabledSet L.disabled newStyles + + where + baseStyles = [width 200, padding 10] + newStyles = [padding 5, bgColor red] + mergedStyles = [width 200, padding 5, bgColor red] + + checkStyleAction styleFn field targetStyles = do + let node = styleFn spacer baseStyles + let newNode = styleFn node newStyles + + newNode ^. L.info . L.style . field `shouldBe` Just (mconcat targetStyles) diff --git a/test/unit/Monomer/TestUtil.hs b/test/unit/Monomer/TestUtil.hs --- a/test/unit/Monomer/TestUtil.hs +++ b/test/unit/Monomer/TestUtil.hs @@ -56,27 +56,35 @@ testWindowRect :: Rect testWindowRect = Rect 0 0 testW testH -mockTextMetrics :: Font -> FontSize -> TextMetrics -mockTextMetrics font fontSize = TextMetrics { +mockTextMetrics :: Double -> Font -> FontSize -> TextMetrics +mockTextMetrics scale font fontSize = TextMetrics { _txmAsc = 15, _txmDesc = 5, _txmLineH = 20, _txmLowerX = 10 } -mockTextSize :: Maybe Double -> Font -> FontSize -> FontSpace -> Text -> Size -mockTextSize mw font (FontSize fs) spaceH text = Size width height where +mockTextSize + :: Maybe Double -> Double -> Font -> FontSize -> FontSpace -> Text -> Size +mockTextSize mw scale font (FontSize fs) spaceH text = Size width height where w = fromMaybe fs mw + unFontSpace spaceH width = fromIntegral (T.length text) * w height = 20 mockGlyphsPos - :: Maybe Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos -mockGlyphsPos mw font (FontSize fs) spaceH text = glyphs where + :: Maybe Double + -> Double + -> Font + -> FontSize + -> FontSpace + -> Text + -> Seq GlyphPos +mockGlyphsPos mw scale font (FontSize fs) spaceH text = glyphs where w = fromMaybe fs mw + unFontSpace spaceH chars = Seq.fromList $ T.unpack text mkGlyph idx chr = GlyphPos { _glpGlyph = chr, + _glpX = fromIntegral idx * w, _glpXMin = fromIntegral idx * w, _glpXMax = (fromIntegral idx + 1) * w, _glpYMin = 0, @@ -154,15 +162,19 @@ mockFontManager :: FontManager mockFontManager = FontManager { - computeTextMetrics = mockTextMetrics, - computeTextSize = mockTextSize (Just 10), - computeGlyphsPos = mockGlyphsPos (Just 10) + computeTextMetrics = mockTextMetrics 1, + computeTextMetrics_ = mockTextMetrics, + computeTextSize = mockTextSize (Just 10) 1, + computeTextSize_ = mockTextSize (Just 10), + computeGlyphsPos = mockGlyphsPos (Just 10) 1, + computeGlyphsPos_ = mockGlyphsPos (Just 10) } mockWenv :: s -> WidgetEnv s e mockWenv model = WidgetEnv { _weOs = "Mac OS X", _weDpr = 2, + _weAppStartTs = 0, _weFontManager = mockFontManager, _weFindBranchByPath = const Seq.empty, _weMainButton = BtnLeft, diff --git a/test/unit/Monomer/Widgets/CompositeSpec.hs b/test/unit/Monomer/Widgets/CompositeSpec.hs --- a/test/unit/Monomer/Widgets/CompositeSpec.hs +++ b/test/unit/Monomer/Widgets/CompositeSpec.hs @@ -17,9 +17,10 @@ module Monomer.Widgets.CompositeSpec (spec) where import Control.Lens ( - (&), (^.), (^?), (^..), (.~), (%~), _Just, ix, folded, traverse, dropping) + (&), (^.), (^?), (^?!), (^..), (.~), (%~), _Just, ix, folded, traverse, dropping) import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Data.Default +import Data.Foldable (toList) import Data.Maybe import Data.Text (Text) import Data.Typeable (Typeable, cast) @@ -52,6 +53,10 @@ = MainBtnClicked | ChildClicked | MainResize Rect + | OnInit + | OnDispose + | OnChange MainModel + | ReportOnChange MainModel MainModel deriving (Eq, Show) data ChildEvt @@ -140,6 +145,9 @@ handleEvent :: Spec handleEvent = describe "handleEvent" $ do handleEventBasic + handleEventOnInit + handleEventOnDispose + handleEventOnChange handleEventNewRoot handleEventChild handleEventResize @@ -171,6 +179,82 @@ model es = nodeHandleEventModel wenv es cmpNode reqs es = nodeHandleEventReqs wenv es cmpNode +handleEventOnInit :: Spec +handleEventOnInit = describe "handleEventOnInit" $ do + it "should generate an init event" $ do + evts [] `shouldBe` Seq.singleton OnInit + + where + wenv = mockWenv def + handleEvent + :: WidgetEnv MainModel MainEvt + -> WidgetNode MainModel MainEvt + -> MainModel + -> MainEvt + -> [EventResponse MainModel MainEvt MainModel MainEvt] + handleEvent wenv node model evt = case evt of + OnInit{} -> [Report evt] + _ -> [] + buildUI wenv model = vstack [] + cmpNode = composite_ "main" id buildUI handleEvent [onInit OnInit] + evts es = nodeHandleEventEvts_ wenv WInitKeepFirst es cmpNode + +handleEventOnDispose :: Spec +handleEventOnDispose = describe "handleEventOnDispose" $ do + it "should generate an init event" $ do + let val = case evts [] ^?! L.requests . ix 1 of + SendMessage wid msg -> cast msg + _ -> Nothing + + val `shouldBe` Just OnDispose + + where + wenv = mockWenv def + handleEvent + :: WidgetEnv MainModel MainEvt + -> WidgetNode MainModel MainEvt + -> MainModel + -> MainEvt + -> [EventResponse MainModel MainEvt MainModel MainEvt] + handleEvent wenv node model evt = case evt of + OnInit{} -> [Report evt] + _ -> [] + buildUI wenv model = vstack [] + cmpNode = nodeInit wenv + $ composite_ "main" id buildUI handleEvent [onDispose OnDispose] + evts es = widgetDispose (cmpNode ^. L.widget) wenv cmpNode + +handleEventOnChange :: Spec +handleEventOnChange = describe "handleEventOnChange" $ do + it "should not generate an event if model did not change" $ do + evts [evtClick (Point 10 30)] `shouldBe` Seq.empty + + it "should generate an event if model changed" $ do + let items = toList $ evts [evtClick (Point 10 10)] + let ReportOnChange oldModel newModel = head items + + oldModel `shouldNotBe` newModel + + where + wenv = mockWenv def + handleEvent + :: WidgetEnv MainModel MainEvt + -> WidgetNode MainModel MainEvt + -> MainModel + -> MainEvt + -> [EventResponse MainModel MainEvt MainModel MainEvt] + handleEvent wenv node model evt = case evt of + MainBtnClicked -> [Model (model & clicks %~ (+1))] + ChildClicked -> [Model model] + OnChange oldModel -> [Report $ ReportOnChange oldModel model] + _ -> [] + buildUI wenv model = vstack [ + button "Click main" MainBtnClicked, + button "Click secondary" ChildClicked + ] + cmpNode = composite_ "main" id buildUI handleEvent [onChange OnChange] + evts es = nodeHandleEventEvts wenv es cmpNode + handleEventNewRoot :: Spec handleEventNewRoot = describe "handleEventNewRoot" $ do it "should generate a resize request when the widgetType of the root widget changes" $ do @@ -340,7 +424,7 @@ ] `nodeKey` "localTxt1" ] cmpNode1 = composite "main" id buildUI1 handleEvent - cmpNode2 = composite_ "main" id buildUI2 handleEvent [mergeRequired (\_ _ -> True)] + cmpNode2 = composite_ "main" id buildUI2 handleEvent [mergeRequired (\_ _ _ -> True)] evts1 = [evtK keyTab, evtT "aacc", moveCharL, moveCharL] (wenv1, root1, _) = fst $ nodeHandleEvents wenv WInit evts1 cmpNode1 cntNodeM = nodeMerge wenv1 cmpNode2 root1 @@ -473,7 +557,7 @@ cmpNode = findByHelperUI wni path = res where inode = nodeInit wenv cmpNode - res = findWidgetByPath wenv inode path + res = findChildNodeInfoByPath wenv inode path findNextFocus :: Spec findNextFocus = describe "findNextFocus" $ do diff --git a/test/unit/Monomer/Widgets/Containers/BoxSpec.hs b/test/unit/Monomer/Widgets/Containers/BoxSpec.hs --- a/test/unit/Monomer/Widgets/Containers/BoxSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/BoxSpec.hs @@ -68,8 +68,8 @@ btnNew = button "Click" (BtnClick 0) `nodeKey` "btnNew" btnOld = button "Click" (BtnClick 0) `nodeKey` "btnOld" box1 = box btnNew - box2 = box_ [mergeRequired (\_ _ -> True)] btnNew - box3 = box_ [mergeRequired (\_ _ -> False)] btnNew + box2 = box_ [mergeRequired (\_ _ _ -> True)] btnNew + box3 = box_ [mergeRequired (\_ _ _ -> False)] btnNew boxM = box btnOld mergeWith newNode oldNode = result ^?! L.node . L.children . ix 0 where oldNode2 = nodeInit wenv oldNode diff --git a/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs b/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs --- a/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs @@ -23,25 +23,30 @@ import qualified Data.Sequence as Seq -import Monomer.Core +import Monomer.Common import Monomer.Core.Combinators import Monomer.Event import Monomer.TestUtil import Monomer.TestEventUtil import Monomer.Widgets.Containers.Keystroke +import Monomer.Widgets.Singles.Button import Monomer.Widgets.Singles.Label import Monomer.Widgets.Singles.TextField import qualified Monomer.Lens as L data TestEvt - = SingleO + = ButtonEvent + | EnterPressed + | SingleO | TextFieldChanged Text | CtrlA | CtrlSpace + | CtrlDash | CtrlShiftSpace | MultiKey Int | FunctionKey Int + | SymbolKey Text deriving (Eq, Show) newtype TestModel = TestModel { @@ -53,6 +58,7 @@ spec :: Spec spec = describe "Keystroke" $ do handleEvent + handleNestedEvent getSizeReq handleEvent :: Spec @@ -63,6 +69,13 @@ it "should generate an event when Ctrl-Space is pressed" $ do events [evtKC keySpace] `shouldBe` Seq.fromList [CtrlSpace] + it "should generate an event when Ctrl-Dash is pressed" $ do + let wenv = mockWenv (TestModel "") + & L.inputStatus . L.keyMod . L.leftCtrl .~ True + let events es = nodeHandleEventEvts wenv es kstNode + + events [evtT "-"] `shouldBe` Seq.fromList [CtrlDash] + it "should generate an event when Ctrl-Shift-Space is pressed" $ do events [evtKCS keySpace] `shouldBe` Seq.fromList [CtrlShiftSpace] @@ -72,6 +85,14 @@ events [evtKG keyF7] `shouldBe` Seq.fromList [FunctionKey 7] events [evtKS keyF12] `shouldBe` Seq.fromList [FunctionKey 12] + it "should generate events when symbol keys are pressed" $ do + let wenv = mockWenv (TestModel "") + & L.inputStatus . L.keyMod . L.leftCtrl .~ True + let events es = nodeHandleEventEvts wenv es kstNode + + events [evtT "["] `shouldBe` Seq.fromList [SymbolKey "["] + events [evtT "^"] `shouldBe` Seq.fromList [SymbolKey "^"] + it "should only generate events when the exact keys are pressed" $ do events [evtKC keyA, evtKC keyB] `shouldBe` Seq.fromList [] events [evtKC keyA, evtKC keyB, evtKC keyD, evtKC keyC] `shouldBe` Seq.fromList [] @@ -104,13 +125,16 @@ wenv = mockWenv (TestModel "") bindings = [ ("C-Space", CtrlSpace), + ("C-Dash", CtrlDash), ("C-S-Space", CtrlShiftSpace), ("C-a-b-c", MultiKey 1), ("C-d-e", MultiKey 2), ("F1", FunctionKey 1), ("Ctrl-F3", FunctionKey 3), ("Cmd-F7", FunctionKey 7), - ("S-F12", FunctionKey 12) + ("S-F12", FunctionKey 12), + ("C-[", SymbolKey "["), + ("Shift-^", SymbolKey "^") ] kstNode = keystroke bindings (textField textValue) events es = nodeHandleEventEvts wenv es kstNode @@ -121,6 +145,35 @@ model2 es = nodeHandleEventModel wenv2 es kstModel2 events1 es = nodeHandleEventEvts wenv2 es kstModel1 events2 es = nodeHandleEventEvts wenv2 es kstModel2 + +handleNestedEvent :: Spec +handleNestedEvent = describe "handleNestedEvent" $ do + it "should not generate events" $ do + events False False [] `shouldBe` Seq.empty + + it "should generate an event when clicking the button" $ do + events False False [evtClick (Point 100 100)] `shouldBe` Seq.fromList [ButtonEvent] + events True False [evtClick (Point 100 100)] `shouldBe` Seq.fromList [ButtonEvent] + events False True [evtClick (Point 100 100)] `shouldBe` Seq.fromList [ButtonEvent] + events True True [evtClick (Point 100 100)] `shouldBe` Seq.fromList [ButtonEvent] + + it "should generate the expected events when pressing the enter key" $ do + events False False [evtK keyEnter] `shouldBe` Seq.fromList [EnterPressed, ButtonEvent] + events True False [evtK keyEnter] `shouldBe` Seq.fromList [EnterPressed] + events False True [evtK keyEnter] `shouldBe` Seq.fromList [ButtonEvent] + events True True [evtK keyEnter] `shouldBe` Seq.fromList [EnterPressed] + + where + wenv = mockWenv (TestModel "") + bindings = [ + ("Enter", EnterPressed) + ] + kstNode ignoreChild ignoreParent = + keystroke_ bindings [ignoreChildrenEvts_ ignoreChild] $ + button_ "Test" ButtonEvent [ignoreParentEvts_ ignoreParent] + events ignoreChild ignoreParent es = + nodeHandleEventEvts wenv es $ + kstNode ignoreChild ignoreParent getSizeReq :: Spec getSizeReq = describe "getSizeReq" $ do diff --git a/test/unit/Monomer/Widgets/Containers/ScrollSpec.hs b/test/unit/Monomer/Widgets/Containers/ScrollSpec.hs --- a/test/unit/Monomer/Widgets/Containers/ScrollSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/ScrollSpec.hs @@ -51,6 +51,7 @@ handleEvent :: Spec handleEvent = describe "handleEvent" $ do handleBarClick + handleThumbDrag handleChildrenFocus handleNestedWheel handleMessageReset @@ -61,15 +62,12 @@ it "should click the first button" $ do evts [evtClick point] `shouldBe` Seq.fromList [Button1] - it "should scroll right and click the third button" $ do + it "should scroll right and click the second 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] @@ -93,6 +91,53 @@ ] scrollNode = scroll stackNode evts es = nodeHandleEventEvts wenv es scrollNode + +handleThumbDrag :: Spec +handleThumbDrag = describe "handleThumbDrag" $ do + it "should click the first button" $ do + evts [evtClick pClick] `shouldBe` Seq.fromList [Button1] + + it "should drag the thumb right and click the second button" $ do + evts [evtPress pStartH, evtMove pEndH, evtClick pClick] `shouldBe` Seq.fromList [Button2] + + it "should drag the thumb down and click the third button" $ do + evts [evtPress pStartV, evtMove pEndV, evtClick pClick] `shouldBe` Seq.fromList [Button3] + + it "should drag the thumb down and right and click the fourth button" $ do + let steps = [ evtPress pStartH, evtMove pEndH, evtRelease pEndH, + evtPress pStartV, evtMove pEndV, evtRelease pEndV, + evtClick pClick ] + evts steps `shouldBe` Seq.fromList [Button4] + + it "should fail to drag the thumb right because of thumb size, causing it to click the first button" $ do + evtsSmall [evtPress pStartH, evtMove pEndH, evtClick pClick] `shouldBe` Seq.fromList [Button1] + + it "should fail to drag the thumb down because of thumb size, causing it to click the first button" $ do + evtsSmall [evtPress pStartV, evtMove pEndV, evtClick pClick] `shouldBe` Seq.fromList [Button1] + + where + wenv = mockWenv () + & L.theme .~ darkTheme + & L.windowSize .~ Size 640 480 + pClick = Point 320 200 + pStartH = Point 50 476 + pEndH = Point 400 476 + pStartV = Point 636 50 + pEndV = Point 636 300 + st = [width 6400, height 4800] + 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_ [thumbMinSize 100] stackNode + evts es = nodeHandleEventEvts wenv es scrollNode + evtsSmall es = nodeHandleEventEvts wenv es (scroll stackNode) handleChildrenFocus :: Spec handleChildrenFocus = describe "handleChildrenFocus" $ do diff --git a/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs @@ -72,6 +72,7 @@ handleEventDate handleEventValueDate handleEventMouseDragDate + handleEventReadOnly handleShiftFocus getSizeReqDate testWidgetType @@ -246,6 +247,30 @@ model es = nodeHandleEventModel wenv es dateNode lastIdx es = Seq.index es (Seq.length es - 1) lastEvt es = lastIdx (evts es) + +handleEventReadOnly :: Spec +handleEventReadOnly = describe "handleEventReadOnly" $ do + it "should ignore text input" $ do + let steps = [moveCharR, delCharL, evtT "5"] + model steps ^. dateValue `shouldBe` initDate + + it "should ignore drag" $ do + let selStart = Point 5 5 + let selEnd = Point 100 2000 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` initDate + + it "should ignore wheel" $ do + let steps = [WheelScroll (Point 100 10) (Point 0 (-2000)) WheelNormal] + model steps ^. dateValue `shouldBe` initDate + + where + initDate = fromGregorian 1999 11 21 + wenv = mockWenv (DateModel initDate True) + & L.inputStatus . L.keyMod . L.leftShift .~ True + dateCfg = [readOnly :: DateFieldCfg DateModel TestEvt Day] + dateNode = dateField_ dateValue dateCfg + model es = nodeHandleEventModel wenv es dateNode handleShiftFocus :: Spec handleShiftFocus = describe "handleShiftFocus" $ do diff --git a/test/unit/Monomer/Widgets/Singles/LabelSpec.hs b/test/unit/Monomer/Widgets/Singles/LabelSpec.hs --- a/test/unit/Monomer/Widgets/Singles/LabelSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/LabelSpec.hs @@ -121,7 +121,7 @@ where fontMgr = mockFontManager { - computeGlyphsPos = mockGlyphsPos Nothing + computeGlyphsPos = mockGlyphsPos Nothing 1 } wenv = mockWenvEvtUnit () & L.fontManager .~ fontMgr diff --git a/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs @@ -65,6 +65,7 @@ handleEventIntegral handleEventValueIntegral handleEventMouseDragIntegral + handleEventReadOnly getSizeReqIntegral testIntegralWidgetType @@ -475,6 +476,30 @@ numericField_ fractionalValue [wheelRate 1, onFocus GotFocus] ] evts es = nodeHandleEventEvts wenv es floatNode + +handleEventReadOnly :: Spec +handleEventReadOnly = describe "handleEventReadOnly" $ do + it "should ignore text input" $ do + let steps = [moveCharR, delCharL, evtT "5"] + model steps ^. fractionalValue `shouldBe` initValue + + it "should ignore drag" $ do + let selStart = Point 5 5 + let selEnd = Point 100 2000 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. fractionalValue `shouldBe` initValue + + it "should ignore wheel" $ do + let steps = [WheelScroll (Point 100 10) (Point 0 (-2000)) WheelNormal] + model steps ^. fractionalValue `shouldBe` initValue + + where + initValue = Just 42.4 + wenv = mockWenv (FractionalModel initValue False) + & L.inputStatus . L.keyMod . L.leftShift .~ True + fieldCfg = [readOnly :: NumericFieldCfg FractionalModel TestEvt (Maybe Double)] + fieldNode = numericField_ fractionalValue fieldCfg + model es = nodeHandleEventModel wenv es fieldNode getSizeReqFractional :: Spec getSizeReqFractional = describe "getSizeReqFractional" $ do diff --git a/test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs b/test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs --- a/test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs @@ -42,7 +42,8 @@ deriving (Eq, Show) data FruitEvt - = FruitSel Fruit + = FruitClicked + | FruitSel Fruit | GotFocus Path | LostFocus Path deriving (Eq, Show) @@ -77,11 +78,21 @@ it "should generate an event when focus is lost" $ events evtBlur orangeNode `shouldBe` Seq.singleton (LostFocus emptyPath) + it "should generate multiple click events when clicked, but a single onChange because the value did not change" $ do + let evt = evtClick (Point 320 240) + let events es = nodeHandleEventEvts wenv es bananaClickNode + + events [evt] `shouldBe` Seq.fromList [FruitClicked, FruitSel Banana] + events [evt, evt] `shouldBe` Seq.fromList [FruitClicked, FruitSel Banana, FruitClicked] + events [evt, evt, evt] `shouldBe` Seq.fromList [FruitClicked, FruitSel Banana, FruitClicked, FruitClicked] + where wenv = mockWenv (TestModel Apple) orangeNode = optionButton_ "Orange" Orange fruit [onFocus GotFocus, onBlur LostFocus] bananaNode :: WidgetNode TestModel FruitEvt bananaNode = optionButton "Banana" Banana fruit + bananaClickNode = optionButton_ "Banana" Banana fruit [onClick FruitClicked, onChange FruitSel] + clickModel p node = nodeHandleEventModel wenv [evtClick p] node keyModel key node = nodeHandleEventModel wenv [KeyAction def key KeyPressed] node events evt node = nodeHandleEventEvts wenv [evt] node diff --git a/test/unit/Monomer/Widgets/Singles/RadioSpec.hs b/test/unit/Monomer/Widgets/Singles/RadioSpec.hs --- a/test/unit/Monomer/Widgets/Singles/RadioSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/RadioSpec.hs @@ -40,7 +40,8 @@ deriving (Eq, Show) data FruitEvt - = FruitSel Fruit + = FruitClicked + | FruitSel Fruit | GotFocus Path | LostFocus Path deriving (Eq, Show) @@ -75,12 +76,22 @@ it "should generate an event when focus is lost" $ events evtBlur orangeNode `shouldBe` Seq.singleton (LostFocus emptyPath) + it "should generate multiple click events when clicked, but a single onChange because the value did not change" $ do + let evt = evtClick (Point 320 240) + let events es = nodeHandleEventEvts wenv es bananaClickNode + + events [evt] `shouldBe` Seq.fromList [FruitClicked, FruitSel Banana] + events [evt, evt] `shouldBe` Seq.fromList [FruitClicked, FruitSel Banana, FruitClicked] + events [evt, evt, evt] `shouldBe` Seq.fromList [FruitClicked, FruitSel Banana, FruitClicked, FruitClicked] + where wenv = mockWenv (TestModel Apple) & L.theme .~ darkTheme orangeNode = radio_ Orange fruit [onFocus GotFocus, onBlur LostFocus] bananaNode :: WidgetNode TestModel FruitEvt bananaNode = radio Banana fruit + bananaClickNode = radio_ Banana fruit [onClick FruitClicked, onChange FruitSel] + clickModel p node = nodeHandleEventModel wenv [evtClick p] node keyModel key node = nodeHandleEventModel wenv [KeyAction def key KeyPressed] node events evt node = nodeHandleEventEvts wenv [evt] node diff --git a/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs b/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs --- a/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs @@ -51,6 +51,7 @@ handleEventValue handleEventMouseSelect handleEventHistory + handleEventReadOnly getSizeReq handleEvent :: Spec @@ -322,6 +323,24 @@ evts es = nodeHandleEventEvts wenv es txtNode lastIdx es = Seq.index es (Seq.length es - 1) lastEvt es = lastIdx (evts es) + +handleEventReadOnly :: Spec +handleEventReadOnly = describe "handleEventReadOnly" $ do + it "should ignore text input" $ do + model [evtT "a"] ^. textValue `shouldBe` initText + + it "should ignore cut" $ do + model [selWordR, evtKG keyX] ^. textValue `shouldBe` initText + + it "should ignore paste" $ do + model [selWordR, evtKG keyV] ^. textValue `shouldBe` initText + + where + initText = "hello" + wenv = mockWenv (TestModel initText) + txtCfg = [readOnly :: TextAreaCfg TestModel TestEvt] + txtNode = textArea_ textValue txtCfg + model es = nodeHandleEventModel wenv es txtNode getSizeReq :: Spec getSizeReq = describe "getSizeReq" $ do diff --git a/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs @@ -51,6 +51,9 @@ handleEventValue handleEventMouseSelect handleEventHistory + handleEventMouseDrag + handleEventWheel + handleEventReadOnly getSizeReq handleEvent :: Spec @@ -267,6 +270,48 @@ evts es = nodeHandleEventEvts wenv es txtNode lastIdx es = Seq.index es (Seq.length es - 1) lastEvt es = lastIdx (evts es) + +handleEventMouseDrag :: Spec +handleEventMouseDrag = describe "handleEventMouseDrag" $ do + it "should ignore shift+drag events" $ do + let selStart = Point 50 10 + let selEnd = Point 50 (-70) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. textValue `shouldBe` "" + + where + wenv = mockWenvEvtUnit (TestModel "") + & L.inputStatus . L.keyMod . L.leftShift .~ True + model es = nodeHandleEventModel wenv es (textField textValue) + +handleEventWheel :: Spec +handleEventWheel = describe "handleEventWheel" $ do + it "should ignore wheel events" $ do + let p = Point 50 10 + let steps1 = [WheelScroll p (Point 0 (-8000)) WheelNormal] + model steps1 ^. textValue `shouldBe` "" + + where + wenv = mockWenvEvtUnit (TestModel "") + model es = nodeHandleEventModel wenv es (textField textValue) + +handleEventReadOnly :: Spec +handleEventReadOnly = describe "handleEventReadOnly" $ do + it "should ignore text input" $ do + model [evtT "a"] ^. textValue `shouldBe` initText + + it "should ignore cut" $ do + model [selWordR, evtKG keyX] ^. textValue `shouldBe` initText + + it "should ignore paste" $ do + model [selWordR, evtKG keyV] ^. textValue `shouldBe` initText + + where + initText = "hello" + wenv = mockWenv (TestModel initText) + txtCfg = [readOnly :: TextFieldCfg TestModel TestEvt] + txtNode = textField_ textValue txtCfg + model es = nodeHandleEventModel wenv es txtNode getSizeReq :: Spec getSizeReq = describe "getSizeReq" $ do diff --git a/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs @@ -72,6 +72,7 @@ handleEventTime handleEventValueTime handleEventMouseDragTime + handleEventReadOnly handleShiftFocus getSizeReqTime testWidgetType @@ -255,6 +256,30 @@ model es = nodeHandleEventModel wenv es timeNode lastIdx es = Seq.index es (Seq.length es - 1) lastEvt es = lastIdx (evts es) + +handleEventReadOnly :: Spec +handleEventReadOnly = describe "handleEventReadOnly" $ do + it "should ignore text input" $ do + let steps = [moveCharR, delCharL, evtT "5"] + model steps ^. timeValue `shouldBe` initTime + + it "should ignore drag" $ do + let selStart = Point 5 5 + let selEnd = Point 100 2000 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` initTime + + it "should ignore wheel" $ do + let steps = [WheelScroll (Point 100 10) (Point 0 (-2000)) WheelNormal] + model steps ^. timeValue `shouldBe` initTime + + where + initTime = TimeOfDay 20 37 00 + wenv = mockWenv (TimeModel initTime False) + & L.inputStatus . L.keyMod . L.leftShift .~ True + timeCfg = [readOnly :: TimeFieldCfg TimeModel TestEvt TimeOfDay] + timeNode = timeField_ timeValue timeCfg + model es = nodeHandleEventModel wenv es timeNode handleShiftFocus :: Spec handleShiftFocus = describe "handleShiftFocus" $ do diff --git a/test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs b/test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs --- a/test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs @@ -36,7 +36,8 @@ import qualified Monomer.Lens as L data TestEvt - = BoolSel Bool + = BoolClicked + | BoolSel Bool | GotFocus Path | LostFocus Path deriving (Eq, Show) @@ -70,9 +71,19 @@ it "should generate an event when focus is lost" $ events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + it "should generate multiple click and change events when clicked, since it toggles between True and False" $ do + let evt = evtClick (Point 320 240) + let events es = nodeHandleEventEvts wenv es chkClickNode + + events [evt] `shouldBe` Seq.fromList [BoolClicked, BoolSel True] + events [evt, evt] `shouldBe` Seq.fromList [BoolClicked, BoolSel True, BoolClicked, BoolSel False] + events [evt, evt, evt] `shouldBe` Seq.fromList [BoolClicked, BoolSel True, BoolClicked, BoolSel False, BoolClicked, BoolSel True] + where wenv = mockWenv (TestModel False) chkNode = toggleButton_ "Toggle" testBool [onFocus GotFocus, onBlur LostFocus] + chkClickNode = toggleButton_ "Toggle" testBool [onClick BoolClicked, onChange BoolSel] + clickModel p = nodeHandleEventModel wenv [evtClick p] chkNode keyModel key = nodeHandleEventModel wenv [KeyAction def key KeyPressed] chkNode events evt = nodeHandleEventEvts wenv [evt] chkNode diff --git a/test/unit/Monomer/Widgets/Util/TextSpec.hs b/test/unit/Monomer/Widgets/Util/TextSpec.hs --- a/test/unit/Monomer/Widgets/Util/TextSpec.hs +++ b/test/unit/Monomer/Widgets/Util/TextSpec.hs @@ -152,6 +152,16 @@ clipKeep "This is a tad bit longer\nMore" ^. ix 1 . L.text `shouldBe` " a tad" clipKeep "This is a tad bit longer\nMore" ^. ix 2 . L.text `shouldBe` " bit " + it "should return text broken even in the middle of words, clipped, trimmed, if it does not fit" $ do + breakOnChar "This is really-long\nMore" `shouldSatisfy` elementCount 3 + breakOnChar "This is really-long\nMore" ^. ix 0 . L.text `shouldBe` "This is" + breakOnChar "This is really-long\nMore" ^. ix 1 . L.text `shouldBe` "reall" + breakOnChar "This is really-long\nMore" ^. ix 2 . L.text `shouldBe` "y-long" + breakOnChar "This is a tad bit longer\nMore" `shouldSatisfy` elementCount 3 + breakOnChar "This is a tad bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is" + breakOnChar "This is a tad bit longer\nMore" ^. ix 1 . L.text `shouldBe` "a tad" + breakOnChar "This is a tad bit longer\nMore" ^. ix 2 . L.text `shouldBe` "bit lon" + where wenv = mockWenv () fontMgr = wenv ^. L.fontManager @@ -167,6 +177,7 @@ elpsKeep_ size text = fitTextToSize fontMgr style Ellipsis MultiLine KeepSpaces Nothing size text clipTrim_ size text = fitTextToSize fontMgr style ClipText MultiLine TrimSpaces Nothing size text clipKeep_ size text = fitTextToSize fontMgr style ClipText MultiLine KeepSpaces Nothing size text + breakOnChar text = fitTextToSize fontMgr (textLineBreak OnCharacters) ClipText MultiLine TrimSpaces Nothing sizeC text elementCount count sq = Seq.length sq == count fitTextSpace :: Spec diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs --- a/test/unit/Spec.hs +++ b/test/unit/Spec.hs @@ -8,7 +8,10 @@ import Monomer.TestUtil (useVideoSubSystem) import qualified Monomer.Common.CursorIconSpec as CursorIconSpec + import qualified Monomer.Core.SizeReqSpec as SizeReqSpec +import qualified Monomer.Core.StyleUtilSpec as StyleUtilSpec + import qualified Monomer.Graphics.UtilSpec as GraphicsUtilSpec import qualified Monomer.Widgets.CompositeSpec as CompositeSpec @@ -88,6 +91,7 @@ core :: Spec core = describe "Core" $ do SizeReqSpec.spec + StyleUtilSpec.spec graphics :: Spec graphics = describe "Graphics" $ do