diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +### 1.0.0.0 + +Initial public release + +- Supports Windows, Linux and macOS diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018-2021 Francisco Vallarino + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Francisco Vallarino nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,91 @@ +# Monomer + +An easy to use, cross platform, GUI library for writing native Haskell +applications. + +It provides a framework similar to the Elm Architecture, allowing the creation +of GUIs using an extensible set of widgets with pure Haskell. + +## Screenshot + +![Project's screenshot](assets/images/monomer-readme.png) + +## Objectives + +- Be easy to learn and use. +- Be extensible with custom widgets. +- Run on Windows, Linux and macOS. +- Have good documentation. +- Have good examples. + +### These are not objectives for this project + +- Have a native look and feel. + +### Why would you want to use this library? + +- You want to write your application in Haskell. +- You want to write a native, not web based, application. + +## Documentation + +### Setup + +You can read how to setup your environment [here](docs/tutorials/00-setup.md). + +### Tutorials + +Introductory tutorials are available: + +- [01 - Basics](docs/tutorials/01-basics.md) +- [02 - Styling](docs/tutorials/02-styling.md) +- [03 - Life cycle](docs/tutorials/03-life-cycle.md) +- [04 - Tasks](docs/tutorials/04-tasks.md) +- [05 - Producers](docs/tutorials/05-producers.md) +- [06 - Composite](docs/tutorials/06-composite.md) +- [07 - Custom widgets](docs/tutorials/07-custom-widgets.md) +- [08 - Themes](docs/tutorials/08-themes.md) + +### Examples + +Beyond the tutorials, a few _real world like_ examples are available: + +- [Todo](docs/examples/01-todo.md) +- [Books](docs/examples/02-books.md) +- [Ticker](docs/examples/03-ticker.md) +- [Generative](docs/examples/04-generative.md) + +### Haddock + +You can read the source code's documentation [here](https://hackage.haskell.org/package/monomer). + +### Design decisions + +In case you wonder why some choices were made, you can read +[here](docs/design-decisions.md). + +## Roadmap + +- Stability and performance. +- Mobile support. + +## Contributing + +PRs are welcome! + +If possible, keep them small and focused. If you are planning on making a large +change, please submit an issue first so we can agree on a solution. + +## License + +This library is licensed under the [BSD-3 license](LICENSE). + +Fonts used in examples: + +- [Roboto](https://fonts.google.com/specimen/Roboto), licensed under the [Apache license](http://www.apache.org/licenses/LICENSE-2.0) +- [Remix Icon](https://remixicon.com), licensed under the [Apache license](http://www.apache.org/licenses/LICENSE-2.0) + +## Acknowledgments + +- Thanks to [Ghislaine Guerin](https://github.com/ghislaineguerin) for UX advise. +- Thanks to [Mikko Mononen](https://github.com/memononen) for the amazing [nanovg](https://github.com/memononen/nanovg) library. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/dpi.c b/cbits/dpi.c new file mode 100644 --- /dev/null +++ b/cbits/dpi.c @@ -0,0 +1,53 @@ +/* +Based on code from notnullnotvoid's comment on: +https://seabird.handmade.network/blogs/p/2460-be_aware_of_high_dpi + +Author's page: https://handmade.network/m/notnullnotvoid +*/ + +#if !defined(_WIN32) + +void initDpiAwareness() { +} + +#else + +#include "windows.h" +#include "sdl.h" + +typedef enum PROCESS_DPI_AWARENESS { + PROCESS_DPI_UNAWARE = 0, + PROCESS_SYSTEM_DPI_AWARE = 1, + PROCESS_PER_MONITOR_DPI_AWARE = 2 +} PROCESS_DPI_AWARENESS; + +BOOL(WINAPI *SetProcessDPIAwareFn)(void); // Vista and later +HRESULT(WINAPI *SetProcessDpiAwarenessFn)(PROCESS_DPI_AWARENESS dpiAwareness); // Windows 8.1 and later + +void initDpiAwareness() { + void* userDLL = SDL_LoadObject("USER32.DLL"); + void* shcoreDLL = SDL_LoadObject("SHCORE.DLL"); + + if (userDLL) { + SetProcessDPIAwareFn = (BOOL(WINAPI *)(void)) SDL_LoadFunction(userDLL, "SetProcessDPIAware"); + } + + if (shcoreDLL) { + SetProcessDpiAwarenessFn = (HRESULT(WINAPI *)(PROCESS_DPI_AWARENESS)) SDL_LoadFunction(shcoreDLL, "SetProcessDpiAwareness"); + } + + if (SetProcessDpiAwarenessFn) { + // Try Windows 8.1+ version + //HRESULT result = SetProcessDpiAwarenessFn(PROCESS_PER_MONITOR_DPI_AWARE); + HRESULT result = SetProcessDpiAwarenessFn(PROCESS_SYSTEM_DPI_AWARE); + SDL_Log("called SetProcessDpiAwareness: %d", (result == S_OK) ? 1 : 0); + } + else if (SetProcessDPIAwareFn) { + // Try Vista - Windows 8 version. + // This has a constant scale factor for all monitors. + BOOL success = SetProcessDPIAwareFn(); + SDL_Log("Called SetProcessDPIAware: %d", (int) success); + } +} + +#endif diff --git a/cbits/fontmanager.c b/cbits/fontmanager.c new file mode 100644 --- /dev/null +++ b/cbits/fontmanager.c @@ -0,0 +1,171 @@ +// Based on code from memononen's https://github.com/memononen/nanovg + +#include +#include +#include + +#include "fontstash.h" +#include "fontmanager.h" + +static float fm__minf(float a, float b) { + return a < b ? a : b; +} + +static float fm__maxf(float a, float b) { + return a > b ? a : b; +} + +FMcontext* fmInit(float dpr) +{ + FMcontext *ctx; + FONSparams fontParams; + + ctx = (FMcontext*) malloc(sizeof(FMcontext)); + memset(ctx, 0, sizeof(FMcontext)); + + memset(&fontParams, 0, sizeof(fontParams)); + fontParams.width = INIT_FONTIMAGE_SIZE; + fontParams.height = INIT_FONTIMAGE_SIZE; + fontParams.flags = FONS_ZERO_TOPLEFT; + fontParams.renderCreate = NULL; + fontParams.renderUpdate = NULL; + fontParams.renderDraw = NULL; + fontParams.renderDelete = NULL; + fontParams.userPtr = NULL; + + // Initialize font manager context + ctx->fs = fonsCreateInternal(&fontParams); + ctx->dpr = dpr; + ctx->fontSize = 16.0f; + ctx->letterSpacing = 0.0f; + ctx->lineHeight = 1.0f; + ctx->fontBlur = 0.0f; + ctx->textAlign = ALIGN_LEFT | ALIGN_BASELINE; + ctx->fontId = 0; + + return ctx; +} + +int fmCreateFont(FMcontext* ctx, const char* name, const char* filename) +{ + return fonsAddFont(ctx->fs, name, filename, 0); +} + +void fmFontFace(FMcontext* ctx, const char* font) +{ + ctx->fontId = fonsGetFontByName(ctx->fs, font); +} + +void fmFontSize(FMcontext* ctx, float size) +{ + ctx->fontSize = size; +} + +void fmFontBlur(FMcontext* ctx, float blur) +{ + ctx->fontBlur = blur; +} + +void fmTextLetterSpacing(FMcontext* ctx, float spacing) +{ + ctx->letterSpacing = spacing; +} + +void fmTextLineHeight(FMcontext* ctx, float lineHeight) +{ + ctx->lineHeight = lineHeight; +} + +void fmTextMetrics(FMcontext* ctx, float* ascender, float* descender, float* lineh) +{ + float scale = ctx->dpr; + float invscale = 1.0f / scale; + + if (ctx->fontId == FONS_INVALID) return; + + fonsSetSize(ctx->fs, ctx->fontSize * scale); + fonsSetSpacing(ctx->fs, ctx->letterSpacing * scale); + fonsSetBlur(ctx->fs, ctx->fontBlur * scale); + fonsSetAlign(ctx->fs, ctx->textAlign); + fonsSetFont(ctx->fs, ctx->fontId); + + fonsVertMetrics(ctx->fs, ascender, descender, lineh); + if (ascender != NULL) + *ascender *= invscale; + if (descender != NULL) + *descender *= invscale; + if (lineh != NULL) + *lineh *= invscale; +} + +float fmTextBounds(FMcontext* ctx, float x, float y, const char* string, const char* end, float* bounds) +{ + float scale = ctx->dpr; + float invscale = 1.0f / scale; + float width; + + if (ctx->fontId == FONS_INVALID) return 0; + + fonsSetSize(ctx->fs, ctx->fontSize*scale); + fonsSetSpacing(ctx->fs, ctx->letterSpacing*scale); + fonsSetBlur(ctx->fs, ctx->fontBlur*scale); + fonsSetAlign(ctx->fs, ctx->textAlign); + fonsSetFont(ctx->fs, ctx->fontId); + + width = fonsTextBounds(ctx->fs, x*scale, y*scale, string, end, bounds); + if (bounds != NULL) { + // Use line bounds for height. + fonsLineBounds(ctx->fs, y*scale, &bounds[1], &bounds[3]); + bounds[0] *= invscale; + bounds[1] *= invscale; + bounds[2] *= invscale; + bounds[3] *= invscale; + } + return width * invscale; +} + +int fmTextGlyphPositions(FMcontext* ctx, float x, float y, const char* string, const char* end, FMGglyphPosition* positions, int maxPositions) +{ + float scale = ctx->dpr; + float invscale = 1.0f / scale; + FONStextIter iter, prevIter; + FONSquad q; + int npos = 0; + + if (ctx->fontId == FONS_INVALID) return 0; + + if (end == NULL) + end = string + strlen(string); + + if (string == end) + return 0; + + fonsSetSize(ctx->fs, ctx->fontSize*scale); + fonsSetSpacing(ctx->fs, ctx->letterSpacing*scale); + fonsSetBlur(ctx->fs, ctx->fontBlur*scale); + fonsSetAlign(ctx->fs, ctx->textAlign); + fonsSetFont(ctx->fs, ctx->fontId); + + fonsTextIterInit(ctx->fs, &iter, x*scale, y*scale, string, end, FONS_GLYPH_BITMAP_OPTIONAL); + prevIter = iter; + + while (fonsTextIterNext(ctx->fs, &iter, &q)) { + // can not retrieve glyph? + if (iter.prevGlyphIndex < 0 && fonsResetAtlas(ctx->fs, MAX_FONTIMAGE_SIZE, MAX_FONTIMAGE_SIZE)) { + iter = prevIter; + fonsTextIterNext(ctx->fs, &iter, &q); // try again + } + prevIter = iter; + positions[npos].str = iter.str; + positions[npos].x = iter.x * invscale; + positions[npos].minx = fm__minf(iter.x, q.x0) * invscale; + positions[npos].maxx = fm__maxf(iter.nextx, q.x1) * invscale; + positions[npos].miny = fm__minf(iter.y, q.y0) * invscale; + positions[npos].maxy = fm__maxf(iter.nexty, q.y1) * invscale; + npos++; + if (npos >= maxPositions) + break; + } + + return npos; +} diff --git a/cbits/fontmanager.h b/cbits/fontmanager.h new file mode 100644 --- /dev/null +++ b/cbits/fontmanager.h @@ -0,0 +1,57 @@ +// Based on code from memononen's https://github.com/memononen/nanovg + +#ifndef FONT_MANAGER_H +#define FONT_MANAGER_H + +#include +#include "fontstash.h" + +#define INIT_FONTIMAGE_SIZE 512 +#define MAX_FONTIMAGE_SIZE 2048 +#define MAX_FONTIMAGES 4 +#define ALIGN_LEFT 1 +#define ALIGN_BASELINE 64 + +struct FMcontext { + struct FONScontext* fs; + float dpr; + float fontSize; + float letterSpacing; + float lineHeight; + float fontBlur; + int textAlign; + int fontId; +}; + +typedef struct FMcontext FMcontext; + +struct FMGglyphPosition { + const char* str; // Position of the glyph in the input string. + float x; // The x-coordinate of the logical glyph position. + float minx, maxx; // The bounds of the glyph shape. + float miny, maxy; // The vertical bounds of the glyph shape. +}; + +typedef struct FMGglyphPosition FMGglyphPosition; + +FMcontext* fmInit(float dpr); + +int fmCreateFont(FMcontext* ctx, const char* name, const char* filename); + +void fmFontFace(FMcontext* ctx, const char* font); + +void fmFontSize(FMcontext* ctx, float size); + +void fmFontBlur(FMcontext* ctx, float blur); + +void fmTextLetterSpacing(FMcontext* ctx, float spacing); + +void fmTextLineHeight(FMcontext* ctx, float lineHeight); + +void fmTextMetrics(FMcontext* ctx, float* ascender, float* descender, float* lineh); + +float fmTextBounds(FMcontext* ctx, float x, float y, const char* string, const char* end, float* bounds); + +int fmTextGlyphPositions(FMcontext* ctx, float x, float y, const char* string, const char* end, FMGglyphPosition* positions, int maxPositions); + +#endif diff --git a/cbits/glew.c b/cbits/glew.c new file mode 100644 --- /dev/null +++ b/cbits/glew.c @@ -0,0 +1,21 @@ +// Based on code from cocreature's https://github.com/cocreature/nanovg-hs + +#include +#include + +void initGlew() { + glewExperimental = GL_TRUE; + GLenum err = glewInit(); + + const GLubyte* renderer = glGetString (GL_RENDERER); // get renderer string + const GLubyte* version = glGetString (GL_VERSION); // version as a string + fprintf(stderr, "Renderer: %s\nVersion: %s\n", renderer, version); + + if(err != GLEW_OK) { + fprintf(stderr, "Could not init GLEW: %s\n", glewGetErrorString(err)); + printf("\n"); + } + else { + glGetError(); + } +} diff --git a/examples/books/BookTypes.hs b/examples/books/BookTypes.hs new file mode 100644 --- /dev/null +++ b/examples/books/BookTypes.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module BookTypes where + +import Control.Lens.TH +import Data.Aeson +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import Monomer + +data Book = Book { + _bkTitle :: Text, + _bkAuthors :: [Text], + _bkYear :: Maybe Int, + _bkCover :: Maybe Int +} deriving (Eq, Show) + +instance FromJSON Book where + parseJSON = withObject "Book" $ \b -> Book + <$> b .: "title" + <*> fmap (fromMaybe []) (b .:? "author_name") + <*> b .:? "first_publish_year" + <*> b .:? "cover_i" + +data BookResp = BookResp { + _brDocs :: [Book], + _brFound :: Int +} deriving (Eq, Show) + +instance FromJSON BookResp where + parseJSON = withObject "BookResp" $ \b -> BookResp + <$> b .: "docs" + <*> b .: "numFound" + +data BooksModel = BooksModel { + _bkmQuery :: Text, + _bmkSearching :: Bool, + _bkmErrorMsg :: Maybe Text, + _bkmBooks :: [Book], + _bmkSelected :: Maybe Book +} deriving (Eq, Show) + +data BooksEvt + = BooksInit + | BooksSearch + | BooksSearchResult BookResp + | BooksSearchError Text + | BooksShowDetails Book + | BooksCloseDetails + | BooksCloseError + deriving (Eq, Show) + +makeLensesWith abbreviatedFields 'Book +makeLensesWith abbreviatedFields 'BookResp +makeLensesWith abbreviatedFields 'BooksModel diff --git a/examples/books/Main.hs b/examples/books/Main.hs new file mode 100644 --- /dev/null +++ b/examples/books/Main.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Exception +import Control.Lens +import Data.Default +import Data.Either.Extra +import Data.Maybe +import Data.Text (Text) +import TextShow + +import qualified Data.Text as T +import qualified Network.Wreq as W + +import BookTypes +import Monomer + +import qualified Monomer.Lens as L + +type BooksWenv = WidgetEnv BooksModel BooksEvt +type BooksNode = WidgetNode BooksModel BooksEvt + +bookImage :: Maybe Int -> Text -> WidgetNode s BooksEvt +bookImage imgId size = maybe filler coverImg imgId where + baseUrl = "http://covers.openlibrary.org/b/id/-.jpg" + imgUrl i = T.replace "" size $ T.replace "" (showt i) baseUrl + coverImg i = image_ (imgUrl i) [fitHeight, alignRight] + +bookRow :: BooksWenv -> Book -> BooksNode +bookRow wenv b = row where + rowBgColor = wenv ^. L.theme . L.userColorMap . at "rowBgColor" . non def + publishYear = maybe "" showt (b ^. year) + + rowContent b = hstack [ + vstack [ + label_ (b ^. title) [resizeFactor 1] + `styleBasic` [textFont "Medium", textSize 16], + spacer, + label_ (T.intercalate ", " (b ^. authors)) [resizeFactor 1] + `styleBasic` [textSize 14] + ], + filler, + vstack [ + label publishYear `styleBasic` [width 50, textSize 14], + spacer + ], + bookImage (b ^. cover) "S" `styleBasic` [width 35] + ] + + row = box_ cfg content `styleBasic` [padding 10, paddingT 0] where + cfg = [expandContent, onClick (BooksShowDetails b)] + content = rowContent b + `styleBasic` [height 80, padding 20, radius 5] + `styleHover` [bgColor rowBgColor, cursorIcon CursorHand] + +bookDetail :: Book -> WidgetNode s BooksEvt +bookDetail b = content `styleBasic` [minWidth 500, paddingH 20] where + hasCover = isJust (b ^. cover) + publishYear = maybe "" showt (b ^. year) + + shortLabel value = label value `styleBasic` [textFont "Medium", textTop] + longLabel value = label_ value [multiline, ellipsis, trimSpaces] + + content = hstack . concat $ [[ + vstack [ + longLabel (b ^. title) + `styleBasic` [textSize 20, textFont "Medium"], + spacer, + longLabel (T.intercalate ", " (b ^. authors)) + `styleBasic` [textSize 16], + spacer, + label publishYear + `styleBasic` [textSize 14] + ]], + [filler | hasCover], + [bookImage (b ^. cover) "M" `styleBasic` [width 200] | hasCover] + ] + +buildUI + :: WidgetEnv BooksModel BooksEvt + -> BooksModel + -> WidgetNode BooksModel BooksEvt +buildUI wenv model = widgetTree where + sectionBgColor = wenv ^. L.theme . L.sectionColor + + errorOverlay = alertMsg msg BooksCloseError where + msg = fromMaybe "" (model ^. errorMsg) + + bookOverlay = alert BooksCloseDetails content where + content = maybe spacer bookDetail (model ^. selected) + + searchOverlay = box content `styleBasic` [bgColor (darkGray & L.a .~ 0.8)] where + content = label "Searching" `styleBasic` [textSize 20, textColor black] + + searchForm = keystroke [("Enter", BooksSearch)] $ vstack [ + hstack [ + label "Query:", + spacer, + textField query `nodeKey` "query", + spacer, + mainButton "Search" BooksSearch + ] `styleBasic` [bgColor sectionBgColor, padding 25] + ] + + countLabel = label caption `styleBasic` [padding 10] where + caption = "Books (" <> showt (length $ model ^. books) <> ")" + + booksChanged old new = old ^. books /= new ^. books + + widgetTree = zstack [ + vstack [ + searchForm, + countLabel, + box_ [mergeRequired booksChanged] $ + vscroll (vstack (bookRow wenv <$> model ^. books)) `nodeKey` "mainScroll" + ], + errorOverlay `nodeVisible` isJust (model ^. errorMsg), + bookOverlay `nodeVisible` isJust (model ^. selected), + searchOverlay `nodeVisible` model ^. searching + ] + +handleEvent + :: WidgetEnv BooksModel BooksEvt + -> WidgetNode BooksModel BooksEvt + -> BooksModel + -> BooksEvt + -> [EventResponse BooksModel BooksEvt BooksModel ()] +handleEvent wenv node model evt = case evt of + BooksInit -> [setFocusOnKey wenv "query"] + BooksSearch -> [ + Model $ model & searching .~ True, + Task $ searchBooks (model ^. query) + ] + BooksSearchResult resp -> [ + Message "mainScroll" ScrollReset, + Model $ model + & searching .~ False + & errorMsg .~ Nothing + & books .~ resp ^. docs + ] + BooksSearchError msg -> [ + Model $ model + & searching .~ False + & errorMsg ?~ msg + & books .~ [] + ] + BooksShowDetails book -> [Model $ model & selected ?~ book] + BooksCloseDetails -> [Model $ model & selected .~ Nothing] + BooksCloseError -> [Model $ model & errorMsg .~ Nothing] + +searchBooks :: Text -> IO BooksEvt +searchBooks query = do + putStrLn . T.unpack $ "Searching: " <> query + result <- catchAny (fetch url) (return . Left . T.pack . show) + + case result of + Right resp -> return (BooksSearchResult resp) + Left err -> return (BooksSearchError err) + where + url = "https://openlibrary.org/search.json?q=" <> T.unpack query + checkEmpty resp + | null (resp ^. docs) = Nothing + | otherwise = Just resp + fetch url = do + resp <- W.get url + >>= W.asJSON + >>= return . preview (W.responseBody . _Just) + + return $ maybeToEither "Empty response" (resp >>= checkEmpty) + +main :: IO () +main = do + startApp initModel handleEvent buildUI config + where + config = [ + appWindowTitle "Book search", + appTheme customDarkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf", + appInitEvent BooksInit + ] + initModel = BooksModel "" False Nothing [] Nothing + +customLightTheme :: Theme +customLightTheme = lightTheme + & L.userColorMap . at "rowBgColor" ?~ rgbHex "#ECECEC" + +customDarkTheme :: Theme +customDarkTheme = darkTheme + & L.userColorMap . at "rowBgColor" ?~ rgbHex "#656565" + +-- Utility function to avoid the "Ambiguous type variable..." error +catchAny :: IO a -> (SomeException -> IO a) -> IO a +catchAny = catch diff --git a/examples/generative/GenerativeTypes.hs b/examples/generative/GenerativeTypes.hs new file mode 100644 --- /dev/null +++ b/examples/generative/GenerativeTypes.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module GenerativeTypes where + +import Control.Lens.TH +import Data.Default +import Data.Text (Text) + +import Monomer +import Widgets.CirclesGrid +import Widgets.BoxesPalette + +data GenerativeType + = CirclesGrid + | BoxesPalette + deriving (Eq, Show, Enum) + +data GenerativeModel = GenerativeModel { + _activeGen :: GenerativeType, + _showCfg :: Bool, + _circlesCfg :: CirclesGridCfg, + _boxesCfg :: BoxesPaletteCfg +} deriving (Eq, Show) + +data GenerativeEvt + = GenerativeInit + deriving (Eq, Show) + +makeLenses ''GenerativeType +makeLenses ''GenerativeModel + +genTypes :: [GenerativeType] +genTypes = enumFrom (toEnum 0) diff --git a/examples/generative/Main.hs b/examples/generative/Main.hs new file mode 100644 --- /dev/null +++ b/examples/generative/Main.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Lens +import Data.Default +import Data.List (intersperse) +import Data.Maybe +import Data.Text (Text) +import TextShow + +import Monomer +import Monomer.Widgets.Single + +import GenerativeTypes +import Widgets.BoxesPalette +import Widgets.CirclesGrid + +import qualified Monomer.Lens as L + +type GenerativeWenv = WidgetEnv GenerativeModel GenerativeEvt +type GenerativeNode = WidgetNode GenerativeModel GenerativeEvt + +buildUI :: GenerativeWenv -> GenerativeModel -> GenerativeNode +buildUI wenv model = widgetTree where + sectionBg = wenv ^. L.theme . L.sectionColor + + seedDropdown lens = textDropdown_ lens seedList seedDesc [] + + widgetCircleCfg = vstack $ intersperse spacer [ + label "Width", + vstack [ + dial_ (circlesCfg . itemWidth) 20 50 [dragRate 0.5], + labelS (model ^. circlesCfg . itemWidth) `styleBasic` [textSize 14, textCenter] + ], + + label "Seed", + seedDropdown (circlesCfg . seed) + ] + + widgetBoxCfg = vstack $ intersperse spacer [ + label "Width", + vstack [ + dial_ (boxesCfg . itemWidth) 20 50 [dragRate 0.5], + labelS (model ^. boxesCfg . itemWidth) `styleBasic` [textSize 14, textCenter] + ], + + label "Seed", + seedDropdown (boxesCfg . seed), + separatorLine, + + label "Palette type", + textDropdown (boxesCfg . paletteType) [1..4], + + label "Palette size", + vstack [ + dial_ (boxesCfg . paletteSize) 1 50 [dragRate 0.5], + labelS (model ^. boxesCfg . paletteSize) `styleBasic` [textSize 14, textCenter] + ] + ] + + widgetTree = vstack [ + hstack [ + label "Type:", + spacer, + textDropdown_ activeGen genTypes genTypeDesc [] `nodeKey` "activeType", + spacer, + + labeledCheckbox "Show config:" showCfg + ] `styleBasic` [padding 20, bgColor sectionBg], + zstack [ + hstack [ + circlesGrid (model ^. circlesCfg) `styleBasic` [padding 20], + widgetCircleCfg + `nodeVisible` model ^. showCfg + `styleBasic` [padding 20, width 200, bgColor sectionBg] + ] `nodeVisible` (model ^. activeGen == CirclesGrid), + + hstack [ + boxesPalette (model ^. boxesCfg) `styleBasic` [padding 20], + widgetBoxCfg + `nodeVisible` model ^. showCfg + `styleBasic` [padding 20, width 200, bgColor sectionBg] + ] `nodeVisible` (model ^. activeGen == BoxesPalette) + ] + ] + +handleEvent + :: GenerativeWenv + -> GenerativeNode + -> GenerativeModel + -> GenerativeEvt + -> [EventResponse GenerativeModel GenerativeEvt GenerativeModel ()] +handleEvent wenv node model evt = case evt of + GenerativeInit -> [setFocusOnKey wenv "activeType"] + +main :: IO () +main = do + startApp model handleEvent buildUI config + where + model = GenerativeModel CirclesGrid False def def + config = [ + appWindowTitle "Generative", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appInitEvent GenerativeInit + ] + +seedList :: [Maybe Int] +seedList = Nothing : (Just <$> [0..100]) + +seedDesc :: Maybe Int -> Text +seedDesc Nothing = "Random" +seedDesc (Just v) = showt v + +genTypeDesc :: GenerativeType -> Text +genTypeDesc CirclesGrid = "Randomness in size and location for circles" +genTypeDesc BoxesPalette = "Randomness in palette for boxes" diff --git a/examples/generative/Widgets/BoxesPalette.hs b/examples/generative/Widgets/BoxesPalette.hs new file mode 100644 --- /dev/null +++ b/examples/generative/Widgets/BoxesPalette.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Widgets.BoxesPalette ( + BoxesPaletteCfg(..), + HasItemWidth(..), + HasPaletteType(..), + HasPaletteSize(..), + HasSeed(..), + boxesPalette +) where + +import Control.Lens +import Control.Monad (forM, when) +import Data.Default +import Data.Maybe +import System.Random + +import Monomer.Graphics.ColorTable +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +data ColorHSV + = ColorHSV Double Double Double + deriving (Eq, Show) + +data BoxesPaletteCfg = BoxesPaletteCfg { + _bpcItemWidth :: Double, + _bpcPaletteType :: Int, + _bpcPaletteSize :: Int, + _bpcSeed :: Maybe Int +} deriving (Eq, Show) + +instance Default BoxesPaletteCfg where + def = BoxesPaletteCfg { + _bpcItemWidth = 25, + _bpcPaletteType = 0, + _bpcPaletteSize = 20, + _bpcSeed = Just 42 + } + +data BoxesPaletteState = BoxesPaletteState { + _cgcMouseX :: Double, + _cgcMouseY :: Double +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''BoxesPaletteCfg +makeLensesWith abbreviatedFields ''BoxesPaletteState + +boxesPalette :: BoxesPaletteCfg -> WidgetNode s e +boxesPalette cfg = defaultWidgetNode "boxesPalette" widget where + widget = makeBoxesPalette cfg (BoxesPaletteState 100 100) + +makeBoxesPalette :: BoxesPaletteCfg -> BoxesPaletteState -> Widget s e +makeBoxesPalette cfg state = widget where + widget = createSingle state def { + singleUseScissor = True, + singleMerge = merge, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + merge wenv node oldNode oldState = resultNode newNode where + newNode = node + & L.widget .~ makeBoxesPalette cfg oldState + + handleEvent wenv node target evt = case evt of + Move (Point x y) -> Just (resultReqs newNode [RenderOnce]) where + newState = BoxesPaletteState x y + newNode = node + & L.widget .~ makeBoxesPalette cfg newState + _ -> Nothing + + getSizeReq wenv node = (expandSize 100 1, expandSize 100 1) + + render wenv node renderer = do + when (isJust (cfg ^. seed)) $ + setStdGen $ mkStdGen (fromJust $ cfg ^. seed) + + colors <- makePalette (cfg ^. paletteType) (cfg ^. paletteSize) + mapM_ (drawRectangle renderer state colors vp cols rows) [0..cols * rows - 1] + where + style = currentStyle wenv node + vp = getContentArea node style + iw = cfg ^. itemWidth + fw = 0.5 + 5 * (state ^. mouseX - vp ^. L.x) / vp ^. L.w + fh = 0.5 + 5 * (state ^. mouseY - vp ^. L.y) / vp ^. L.h + cols = round $ vp ^. L.w / (fw * iw) + rows = round $ vp ^. L.h / (fh * iw) + +drawRectangle + :: Renderer + -> BoxesPaletteState + -> [Color] + -> Rect + -> Int + -> Int + -> Int + -> IO () +drawRectangle renderer state colors vp cols rows idx = do + colorIdx :: Double <- randomIO + let color = colors !! floor (fromIntegral (length colors) * colorIdx) + beginPath renderer + setFillColor renderer color + renderRect renderer rect + fill renderer + where + rw = fromIntegral . round $ vp ^. L.w / fromIntegral cols + rh = fromIntegral . round $ vp ^. L.h / fromIntegral rows + rx = vp ^. L.x + rw * fromIntegral (idx `rem` cols) + ry = vp ^. L.y + rh * fromIntegral (idx `div` cols) + rect = Rect rx ry rw rh + +makePalette :: Int -> Int -> IO [Color] +makePalette palette count = forM [0..count - 1] $ \idx -> do + h <- randomIO + s <- randomIO + v <- randomIO + return $ hsvToRGB (makeHSV idx h s v) + where + makeHSV idx h s v + | palette == 1 = ColorHSV h s 1 + | palette == 2 = ColorHSV h 1 v + | palette == 3 && even idx = ColorHSV h 1 v + | palette == 3 = ColorHSV (195 / 360) s 1 + | otherwise = ColorHSV h s v + +hsvToRGB :: ColorHSV -> Color +hsvToRGB (ColorHSV h s v) = Color r g b 1 where + i = floor (h * 6) + f = h * 6 - fromIntegral i + p = v * (1 - s) + q = v * (1 - f * s) + t = v * (1 - (1 - f) * s) + + (r1, g1, b1) = case i of + 0 -> (v, t, p) + 1 -> (q, v, p) + 2 -> (p, v, t) + 3 -> (p, q, v) + 4 -> (t, p, v) + _ -> (v, p, q) + to255 v = round (v * 255) + (r, g, b) = (to255 r1, to255 g1, to255 b1) diff --git a/examples/generative/Widgets/CirclesGrid.hs b/examples/generative/Widgets/CirclesGrid.hs new file mode 100644 --- /dev/null +++ b/examples/generative/Widgets/CirclesGrid.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Widgets.CirclesGrid ( + CirclesGridCfg(..), + HasItemWidth(..), + HasSeed(..), + circlesGrid +) where + +import Control.Lens +import Control.Monad (when) +import Data.Default +import Data.Maybe +import System.Random + +import Monomer.Graphics.ColorTable +import Monomer.Widgets.Single + +-- Imported to avoid issues with duplicate lens names +import Widgets.BoxesPalette + +import qualified Monomer.Lens as L + +data CirclesGridCfg = CirclesGridCfg { + _cgcItemWidth :: Double, + _cgcSeed :: Maybe Int +} deriving (Eq, Show) + +instance Default CirclesGridCfg where + def = CirclesGridCfg { + _cgcItemWidth = 25, + _cgcSeed = Just 42 + } + +data CirclesGridState = CirclesGridState { + _cgcMouseX :: Double, + _cgcMouseY :: Double +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''CirclesGridCfg +makeLensesWith abbreviatedFields ''CirclesGridState + +circlesGrid :: CirclesGridCfg -> WidgetNode s e +circlesGrid cfg = defaultWidgetNode "circlesGrid" widget where + widget = makeCirclesGrid cfg (CirclesGridState 0 0) + +makeCirclesGrid :: CirclesGridCfg -> CirclesGridState -> Widget s e +makeCirclesGrid cfg state = widget where + widget = createSingle state def { + singleUseScissor = True, + singleMerge = merge, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + merge wenv node oldNode oldState = resultNode newNode where + newNode = node + & L.widget .~ makeCirclesGrid cfg oldState + + handleEvent wenv node target evt = case evt of + Move (Point x y) -> Just (resultReqs newNode [RenderOnce]) where + newState = CirclesGridState x y + newNode = node + & L.widget .~ makeCirclesGrid cfg newState + _ -> Nothing + + getSizeReq wenv node = (expandSize 100 1, expandSize 100 1) + + render wenv node renderer = do + when (isJust (cfg ^. seed)) $ + setStdGen $ mkStdGen (fromJust $ cfg ^. seed) + + mapM_ (drawCircle renderer state vp iw cols) [0..cols * rows - 1] + where + style = currentStyle wenv node + vp = getContentArea node style + iw = cfg ^. itemWidth + cols = round (vp ^. L.w / iw) + rows = round (vp ^. L.h / iw) + +drawCircle + :: Renderer -> CirclesGridState -> Rect -> Double -> Int -> Int -> IO () +drawCircle renderer state vp iw cols idx = do + colorIdx :: Double <- randomIO + offsetX <- randomIO + offsetY <- randomIO + let color = colors !! floor (fromIntegral (length colors) * colorIdx) + let colorFill = color & L.a .~ 0.3 + beginPath renderer + setStrokeWidth renderer 2 + setStrokeColor renderer color + setFillColor renderer colorFill + renderEllipse renderer (rect offsetX offsetY) + fill renderer + stroke renderer + where + colors = [cyan, deepPink, orange, paleGreen] + sizeFactor = 0.3 + 1.1 * (state ^. mouseY - vp ^. L.y) / vp ^. L.h + randFactor = (state ^. mouseX - vp ^. L.x) / vp ^. L.w + currw = sizeFactor * iw + szDiff = (1 - sizeFactor) * iw + x = vp ^. L.x + iw * fromIntegral (idx `rem` cols) + y = vp ^. L.y + iw * fromIntegral (idx `div` cols) + rect ox oy = Rect rx ry currw currw where + rx = x + randFactor * (ox - 0.5) * iw + ry = y + randFactor * (oy - 0.5) * iw diff --git a/examples/ticker/BinanceTypes.hs b/examples/ticker/BinanceTypes.hs new file mode 100644 --- /dev/null +++ b/examples/ticker/BinanceTypes.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module BinanceTypes where + +import Control.Applicative ((<|>)) +import Control.Concurrent.STM.TChan +import Control.Lens.TH +import Data.Aeson +import Data.Default +import Data.Foldable (asum) +import Data.Maybe +import Data.Map (Map) +import Data.Scientific +import Data.Text (Text, pack) + +data ServerRequest = ServerRequest { + _srqRequestId :: Int, + _srqMethod :: Text, + _srqParams :: [Text] +} deriving (Eq, Show) + +instance ToJSON ServerRequest where + toJSON (ServerRequest reqId method params) = object [ + "id" .= reqId, + "method" .= method, + "params" .= params + ] + +data ServerResponse = ServerResponse { + _srpRequestId :: Int, + _srpResult :: [Text] +} deriving (Eq, Show) + +instance FromJSON ServerResponse where + parseJSON = withObject "response" $ \o -> do + _srpRequestId <- o .: "id" + _srpResult <- o .: "result" <|> pure [] + + return ServerResponse{..} + +data ServerError = ServerError { + _sveCode :: Int, + _sveMessage :: Text +} deriving (Eq, Show) + +instance FromJSON ServerError where + parseJSON = withObject "error" $ \o -> do + _sveCode <- o .: "code" + _sveMessage <- o .: "msg" + + return ServerError{..} + +data Ticker = Ticker { + _tckSymbolPair :: Text, + _tckTs :: Int, + _tckOpen :: Scientific, + _tckClose :: Scientific, + _tckHigh :: Scientific, + _tckLow :: Scientific, + _tckVolume :: Scientific, + _tckTrades :: Scientific +} deriving (Eq, Show) + +instance FromJSON Ticker where + parseJSON = withObject "ticker" $ \o -> do + _tckSymbolPair <- o .: "s" + _tckTs <- o .: "E" + _tckOpen <- read <$> o .: "o" + _tckClose <- read <$> o .: "c" + _tckHigh <- read <$> o .: "h" + _tckLow <- read <$> o .: "l" + _tckVolume <- read <$> o .: "v" + _tckTrades <- read <$> o .: "q" + + return Ticker{..} + +data ServerMsg + = MsgResponse ServerResponse + | MsgError ServerError + | MsgTicker Ticker + deriving (Eq, Show) + +instance FromJSON ServerMsg where + parseJSON v = asum [ + MsgResponse <$> parseJSON v, + MsgError <$> parseJSON v, + MsgTicker <$> parseJSON v + ] + +makeLensesWith abbreviatedFields 'Ticker diff --git a/examples/ticker/Main.hs b/examples/ticker/Main.hs new file mode 100644 --- /dev/null +++ b/examples/ticker/Main.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Lens +import Control.Monad (forever, forM_, void, when) +import Control.Monad.IO.Class +import Control.Monad.STM +import Data.Aeson +import Data.Default +import Data.Maybe +import Data.Scientific +import Data.Text (Text) + +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Network.Wreq as W +import qualified Network.WebSockets as WS +import qualified Wuss + +import Monomer + +import BinanceTypes +import TickerTypes + +import qualified Monomer.Lens as L + +type TickerWenv = WidgetEnv TickerModel TickerEvt +type TickerNode = WidgetNode TickerModel TickerEvt + +tickerPct :: Ticker -> TickerNode +tickerPct t = pctLabel where + diff = toRealFloat $ 100 * (t ^. close - t ^. open) + pct = diff / toRealFloat (t ^. open) + + pctText = formatTickerPct (fromFloatDigits pct) <> "%" + pctColor + | abs pct < 0.01 = rgbHex "#428FE0" + | pct > 0 = rgbHex "#51A39A" + | otherwise = rgbHex "#E25141" + + pctLabel = label pctText `styleBasic` [width 100, textRight, textColor pctColor] + +tickerRow :: TickerWenv -> Int -> Ticker -> TickerNode +tickerRow wenv idx t = row where + dragColor = rgbaHex "#D3D3D3" 0.5 + rowSep = rgbaHex "#A9A9A9" 0.5 + rowBg = wenv ^. L.theme . L.userColorMap . at "rowBg" . non def + + trashBg = wenv ^. L.theme . L.userColorMap . at "trashBg" . non def + trashFg = wenv ^. L.theme . L.userColorMap . at "trashFg" . non def + trashIcon action = button remixDeleteBinLine action + `styleBasic` [textFont "Remix", textMiddle, textColor trashFg, bgColor transparent, border 0 transparent] + `styleHover` [bgColor trashBg] + + dropTicker pair + = dropTarget_ (TickerMovePair pair) [dropTargetStyle [bgColor darkGray]] + + tickerInfo = hstack [ + label (t ^. symbolPair) `styleBasic` [width 100], + spacer, + label (formatTickerValue (t ^. close)) + `styleBasic` [textRight, minWidth 100], + spacer, + tickerPct t + ] `styleBasic` [cursorHand] + + row = hstack [ + dropTicker (t ^. symbolPair) $ + draggable_ (t ^. symbolPair) [draggableStyle [bgColor dragColor]] + tickerInfo, + spacer, + trashIcon (TickerRemovePairBegin (t ^. symbolPair)) + ] `styleBasic` [padding 10, borderB 1 rowSep] + `styleHover` [bgColor rowBg] + +buildUI :: TickerWenv -> TickerModel -> TickerNode +buildUI wenv model = widgetTree where + sectionBg = wenv ^. L.theme . L.sectionColor + + tickerList = vstack tickerRows where + orderedTickers = (\e -> model ^? tickers . ix e) <$> model ^. symbolPairs + tickerFade idx t = animRow where + action = TickerRemovePair (t ^. symbolPair) + item = tickerRow wenv idx t + animRow = animFadeOut_ [onFinished action] item `nodeKey` (t ^. symbolPair) + + tickerRows = zipWith tickerFade [0..] (catMaybes orderedTickers) + + widgetTree = vstack [ + hstack [ + label "New pair:", + spacer, + keystroke [("Enter", TickerAddClick)] $ textField newPair `nodeKey` "newPair", + spacer, + button "Add" TickerAddClick + ] `styleBasic` [padding 20, bgColor sectionBg], + scroll_ [scrollOverlay] $ tickerList `styleBasic` [padding 10] + ] + +handleEvent + :: AppEnv + -> TickerWenv + -> TickerNode + -> TickerModel + -> TickerEvt + -> [EventResponse TickerModel TickerEvt TickerModel ()] +handleEvent env wenv node model evt = case evt of + TickerInit -> [ + Model $ model + & symbolPairs .~ initialList, + Producer (startProducer env), + Task (subscribeInitial env initialList), + setFocusOnKey wenv "newPair" + ] + + TickerAddClick -> [ + Model $ model + & symbolPairs %~ (model ^. newPair <|) + & newPair .~ "", + Task $ subscribe env [model ^. newPair], + setFocusOnKey wenv "newPair" + ] + + TickerRemovePairBegin pair -> [ + Message (WidgetKey pair) AnimationStart] + + TickerRemovePair pair -> [ + Task $ unsubscribe env [pair], + Model $ model & tickers . at pair .~ Nothing + ] + + TickerMovePair target pair -> [ + Model $ model & symbolPairs .~ moveBefore (model^.symbolPairs) target pair + ] + + TickerUpdate ticker -> [ + Model $ model & tickers . at (ticker ^. symbolPair) ?~ ticker + ] + + TickerError err -> [Task $ print ("Error", err) >> return TickerIgnore] + + TickerResponse resp -> [Task $ print ("Response", resp) >> return TickerIgnore] + + TickerIgnore -> [] + +handleSubscription :: AppEnv -> [Text] -> Text -> IO TickerEvt +handleSubscription env pairs action = do + liftIO . atomically $ writeTChan (env^.channel) req + return TickerIgnore + where + subscription pair = T.toLower pair <> "@miniTicker" + req = ServerRequest 1 action (subscription <$> pairs) + +subscribe :: AppEnv -> [Text] -> IO TickerEvt +subscribe env pairs = handleSubscription env pairs "SUBSCRIBE" + +unsubscribe :: AppEnv -> [Text] -> IO TickerEvt +unsubscribe env pairs = handleSubscription env pairs "UNSUBSCRIBE" + +moveBefore :: Eq a => [a] -> a -> a -> [a] +moveBefore list target item = result where + result + | target == item = list + | otherwise = moveBefore_ cleanList target item + cleanList = filter (/= item) list + moveBefore_ [] target item = [item] + moveBefore_ (x:xs) target item + | x == target = item : x : xs + | otherwise = x : moveBefore_ xs target item + +startProducer :: AppEnv -> (TickerEvt -> IO ()) -> IO () +startProducer env sendMsg = do + Wuss.runSecureClient url port path $ \connection -> do + receiveWs connection sendMsg + sendWs (env ^. channel) connection + where + url = "stream.binance.com" + port = 9443 + path = "/ws" + +subscribeInitial :: AppEnv -> [Text] -> IO TickerEvt +subscribeInitial env initialList = do + threadDelay 500000 + subscribe env initialList + +receiveWs :: WS.Connection -> (TickerEvt -> IO ()) -> IO () +receiveWs conn sendMsg = void . forkIO . forever $ do + msg <- WS.receiveData conn + let serverMsg = decode msg + + forM_ serverMsg $ \case + MsgResponse resp -> sendMsg $ TickerResponse resp + MsgError err -> sendMsg $ TickerError err + MsgTicker ticker -> sendMsg $ TickerUpdate ticker + +sendWs :: (Show a, ToJSON a) => TChan a -> WS.Connection -> IO () +sendWs channel connection = forever $ do + msg <- liftIO . atomically $ readTChan channel + WS.sendTextData connection (encode msg) + +main :: IO () +main = do + channel <- newTChanIO + let env = AppEnv channel + + startApp initModel (handleEvent env) buildUI config + where + config = [ + appWindowTitle "Ticker", + appTheme customDarkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appFontDef "Remix" "./assets/fonts/remixicon.ttf", + appInitEvent TickerInit + ] + initModel = def + +customLightTheme :: Theme +customLightTheme = lightTheme + & L.userColorMap . at "rowBg" ?~ rgbHex "#ECECEC" + & L.userColorMap . at "trashBg" ?~ rgbHex "#D3D3D3" + & L.userColorMap . at "trashFg" ?~ rgbHex "#808080" + +customDarkTheme :: Theme +customDarkTheme = darkTheme + & L.userColorMap . at "rowBg" ?~ rgbHex "#656565" + & L.userColorMap . at "trashBg" ?~ rgbHex "#555555" + & L.userColorMap . at "trashFg" ?~ rgbHex "#909090" + +formatTickerValue :: Scientific -> Text +formatTickerValue = T.pack . formatScientific Fixed (Just 8) + +formatTickerPct :: Scientific -> Text +formatTickerPct = T.pack . formatScientific Fixed (Just 2) + +initialList :: [Text] +initialList = ["BTCUSDT", "ETHBTC", "BNBBTC", "ADABTC", "DOTBTC", "XRPBTC", + "UNIBTC", "LTCBTC", "LINKBTC", "BCHBTC", "DOGEBTC", "THETABTC", "LUNABTC", + "AAVEBTC", "CROBTC", "VETBTC", "XMRBTC", "ATOMBTC", "FTTBTC", "SOLBTC", + "SXPBTC", "BATBTC", "VETBTC", "REEFBTC"] diff --git a/examples/ticker/TickerTypes.hs b/examples/ticker/TickerTypes.hs new file mode 100644 --- /dev/null +++ b/examples/ticker/TickerTypes.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module TickerTypes where + +import Control.Concurrent.STM.TChan +import Control.Lens.TH +import Data.Default +import Data.Foldable (asum) +import Data.Map (Map) +import Data.Text (Text, pack) + +import qualified Data.Map as M + +import BinanceTypes + +newtype AppEnv = AppEnv { + _envChannel :: TChan ServerRequest +} + +data TickerModel = TickerModel { + _prcNewPair :: Text, + _prcSymbolPairs :: [Text], + _prcTickers :: Map Text Ticker +} deriving (Eq, Show) + +instance Default TickerModel where + def = TickerModel { + _prcNewPair = "", + _prcSymbolPairs = [], + _prcTickers = M.empty + } + +data TickerEvt + = TickerInit + | TickerIgnore + | TickerAddClick + | TickerRemovePairBegin Text + | TickerRemovePair Text + | TickerMovePair Text Text + | TickerUpdate Ticker + | TickerError ServerError + | TickerResponse ServerResponse + deriving (Eq, Show) + +makeLensesWith abbreviatedFields 'AppEnv +makeLensesWith abbreviatedFields 'TickerModel diff --git a/examples/todo/Main.hs b/examples/todo/Main.hs new file mode 100644 --- /dev/null +++ b/examples/todo/Main.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Lens +import Data.Default +import Data.Maybe +import Data.Text (Text) +import TextShow + +import Monomer + +import TodoTypes + +import qualified Monomer.Lens as L +import qualified Data.Text as T + +type TodoWenv = WidgetEnv TodoModel TodoEvt +type TodoNode = WidgetNode TodoModel TodoEvt + +todoRowKey :: Todo -> Text +todoRowKey todo = "todoRow" <> showt (todo ^. todoId) + +todoRow :: TodoWenv -> TodoModel -> Int -> Todo -> TodoNode +todoRow wenv model idx t = animRow `nodeKey` todoKey where + sectionBg = wenv ^. L.theme . L.sectionColor + rowButtonColor = wenv ^. L.theme . L.userColorMap . at "rowButton" . non def + rowSepColor = gray & L.a .~ 0.5 + + todoKey = todoRowKey t + todoDone = t ^. status == Done + isLast = idx == length (model ^. todos) - 1 + + (todoBg, todoFg) + | todoDone = (doneBg, doneFg) + | otherwise = (pendingBg, pendingFg) + + todoStatus = labelS (t ^. status) + `styleBasic` [textFont "Medium", textSize 12, textAscender, textColor todoFg, padding 6, paddingH 8, radius 12, bgColor todoBg] + + rowButton caption action = button caption action + `styleBasic` [textFont "Remix", textMiddle, textColor rowButtonColor, bgColor transparent, border 0 transparent] + `styleHover` [bgColor sectionBg] + + todoInfo = hstack [ + vstack [ + labelS (t ^. todoType) `styleBasic` [textSize 12, textColor darkGray], + spacer_ [width 5], + label (t ^. description) `styleBasic` [textThroughline_ todoDone] + ], + filler, + box_ [alignRight] todoStatus `styleBasic` [width 80], + spacer, + rowButton remixEdit2Line (TodoEdit idx t), + spacer, + rowButton remixDeleteBinLine (TodoDeleteBegin idx t) + ] `styleBasic` (paddingV 15 : [borderB 1 rowSepColor | not isLast]) + + animRow = animFadeOut_ [onFinished (TodoDelete idx t)] todoInfo + +todoEdit :: TodoWenv -> TodoModel -> TodoNode +todoEdit wenv model = editNode where + sectionBg = wenv ^. L.theme . L.sectionColor + + saveTodoBtn = case model ^. action of + TodoAdding -> mainButton "Add" TodoAdd + TodoEditing idx -> mainButton "Save" (TodoSave idx) + _ -> spacer + + editNode = vstack [ + hstack [ + label "Task:", + spacer, + textField (activeTodo . description) `nodeKey` "todoDesc" + ], + spacer, + hgrid [ + hstack [ + label "Type:", + spacer, + textDropdownS (activeTodo . todoType) todoTypes `nodeKey` "todoType", + spacer -- Added here to avoid grid expanding it to 1/3 total width + ], + hstack [ + label "Status:", + spacer, + textDropdownS (activeTodo . status) todoStatuses + ] + ], + spacer, + hstack [ + filler, + saveTodoBtn `nodeEnabled` (model ^. activeTodo . description /= ""), + spacer, + button "Cancel" TodoCancel + ] + ] `styleBasic` [bgColor sectionBg, padding 20] + +buildUI :: TodoWenv -> TodoModel -> TodoNode +buildUI wenv model = widgetTree where + sectionBg = wenv ^. L.theme . L.sectionColor + isEditing = model ^. action /= TodoNone + + countLabel = label caption `styleBasic` styles where + caption = "Tasks (" <> showt (length $ model ^. todos) <> ")" + styles = [textFont "Regular", textSize 16, padding 20, bgColor sectionBg] + + todoList = vstack (zipWith (todoRow wenv model) [0..] (model ^. todos)) + + newButton = mainButton "New" TodoNew `nodeKey` "todoNew" + `nodeVisible` not isEditing + + editLayer = content where + saveAction = case model ^. action of + TodoEditing idx -> TodoSave idx + _ -> TodoAdd + + dualSlide content = outer where + inner = animSlideIn_ [slideTop, duration 200] content + `nodeKey` "animEditIn" + outer = animSlideOut_ [slideTop, duration 200, onFinished TodoHideEditDone] inner + `nodeKey` "animEditOut" + + content = vstack [ + dualSlide $ + keystroke [("Enter", saveAction), ("Esc", TodoCancel)] $ + todoEdit wenv model, + filler + ] `styleBasic` [bgColor (grayDark & L.a .~ 0.5)] + + mainLayer = vstack [ + countLabel, + scroll_ [] (todoList `styleBasic` [padding 20, paddingT 5]), + filler, + box_ [alignRight] newButton + `styleBasic` [bgColor sectionBg, padding 20] + ] + + widgetTree = zstack [ + mainLayer, + editLayer `nodeVisible` isEditing + ] + +handleEvent + :: TodoWenv + -> TodoNode + -> TodoModel + -> TodoEvt + -> [EventResponse TodoModel TodoEvt TodoModel ()] +handleEvent wenv node model evt = case evt of + TodoInit -> [setFocusOnKey wenv "todoNew"] + + TodoNew -> [ + Event TodoShowEdit, + Model $ model + & action .~ TodoAdding + & activeTodo .~ def, + setFocusOnKey wenv "todoDesc"] + + TodoEdit idx td -> [ + Event TodoShowEdit, + Model $ model + & action .~ TodoEditing idx + & activeTodo .~ td, + setFocusOnKey wenv "todoDesc"] + + TodoAdd -> [ + Event TodoHideEdit, + Model $ addNewTodo wenv model, + setFocusOnKey wenv "todoNew"] + + TodoSave idx -> [ + Event TodoHideEdit, + Model $ model + & todos . ix idx .~ (model ^. activeTodo), + setFocusOnKey wenv "todoNew"] + + TodoDeleteBegin idx todo -> [ + Message (WidgetKey (todoRowKey todo)) AnimationStart] + + TodoDelete idx todo -> [ + Model $ model + & action .~ TodoNone + & todos .~ remove idx (model ^. todos), + setFocusOnKey wenv "todoNew"] + + TodoCancel -> [ + Event TodoHideEdit, + Model $ model + & activeTodo .~ def, + setFocusOnKey wenv "todoNew"] + + TodoShowEdit -> [ + Message "animEditIn" AnimationStart, + Message "animEditOut" AnimationStop + ] + + TodoHideEdit -> [ + Message "animEditIn" AnimationStop, + Message "animEditOut" AnimationStart + ] + + TodoHideEditDone -> [ + Model $ model + & action .~ TodoNone] + +addNewTodo :: WidgetEnv s e -> TodoModel -> TodoModel +addNewTodo wenv model = newModel where + newTodo = model ^. activeTodo + & todoId .~ wenv ^. L.timestamp + newModel = model + & todos .~ (newTodo : model ^. todos) + +initialTodos :: [Todo] +initialTodos = todos where + items = mconcat $ replicate 1 [ + Todo 0 Home Done "Tidy up the room", + Todo 0 Home Pending "Buy groceries", + Todo 0 Home Pending "Pay the bills", + Todo 0 Home Pending "Repair kitchen sink", + Todo 0 Work Done "Check the status of project A", + Todo 0 Work Pending "Finish project B", + Todo 0 Work Pending "Send email to clients", + Todo 0 Work Pending "Contact cloud services provider" + ] + todos = zipWith (\t idx -> t & todoId .~ idx) items [0..] + +main :: IO () +main = do + startApp (TodoModel initialTodos def TodoNone) handleEvent buildUI config + where + config = [ + appWindowTitle "Todo list", + appTheme customDarkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf", + appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf", + appFontDef "Remix" "./assets/fonts/remixicon.ttf", + appInitEvent TodoInit + ] + +doneBg = rgbHex "#CFF6E2" +doneFg = rgbHex "#459562" +pendingBg = rgbHex "#F5F0CC" +pendingFg = rgbHex "#827330" +grayLight = rgbHex "#9E9E9E" +grayDark = rgbHex "#393939" +grayDarker = rgbHex "#2E2E2E" + +customLightTheme :: Theme +customLightTheme = lightTheme +-- & L.userColorMap . at "statusFont" ?~ grayDarker + & L.userColorMap . at "rowButton" ?~ grayLight + +customDarkTheme :: Theme +customDarkTheme = darkTheme +-- & L.userColorMap . at "statusFont" ?~ grayDarker + & L.userColorMap . at "rowButton" ?~ gray + +remove :: Int -> [a] -> [a] +remove idx ls = take idx ls ++ drop (idx + 1) ls diff --git a/examples/todo/TodoTypes.hs b/examples/todo/TodoTypes.hs new file mode 100644 --- /dev/null +++ b/examples/todo/TodoTypes.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module TodoTypes where + +import Control.Lens.TH +import Data.Default +import Data.Text (Text) + +import Monomer + +data TodoType + = Home + | Work + | Sports + deriving (Eq, Show, Enum) + +data TodoStatus + = Pending + | Done + deriving (Eq, Show, Enum) + +data Todo = Todo { + _todoId :: Int, + _todoType :: TodoType, + _status :: TodoStatus, + _description :: Text +} deriving (Eq, Show) + +instance Default Todo where + def = Todo { + _todoId = 0, + _todoType = Home, + _status = Pending, + _description = "" + } + +data TodoAction + = TodoNone + | TodoAdding + | TodoEditing Int + deriving (Eq, Show) + +data TodoModel = TodoModel { + _todos :: [Todo], + _activeTodo :: Todo, + _action :: TodoAction +} deriving (Eq, Show) + +data TodoEvt + = TodoInit + | TodoNew + | TodoAdd + | TodoEdit Int Todo + | TodoSave Int + | TodoDeleteBegin Int Todo + | TodoDelete Int Todo + | TodoShowEdit + | TodoHideEdit + | TodoHideEditDone + | TodoCancel + deriving (Eq, Show) + +makeLenses 'TodoModel +makeLenses 'Todo + +todoTypes :: [TodoType] +todoTypes = enumFrom (toEnum 0) + +todoStatuses :: [TodoStatus] +todoStatuses = enumFrom (toEnum 0) diff --git a/examples/tutorial/Main.hs b/examples/tutorial/Main.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Main.hs @@ -0,0 +1,21 @@ +module Main where + +import qualified Tutorial01_Basics +import qualified Tutorial02_Styling +import qualified Tutorial03_LifeCycle +import qualified Tutorial04_Tasks +import qualified Tutorial05_Producers +import qualified Tutorial06_Composite +import qualified Tutorial07_CustomWidget +import qualified Tutorial08_Themes + +main :: IO () +main = do +-- Tutorial01_Basics.main01 + Tutorial02_Styling.main02 +-- Tutorial03_LifeCycle.main03 +-- Tutorial04_Tasks.main04 +-- Tutorial05_Producers.main05 +-- Tutorial06_Composite.main06 +-- Tutorial07_CustomWidget.main07 +-- Tutorial08_Themes.main08 diff --git a/examples/tutorial/Tutorial01_Basics.hs b/examples/tutorial/Tutorial01_Basics.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial01_Basics.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial01_Basics where + +import Control.Lens +import Data.Text (Text) +import Monomer +import TextShow + +import qualified Monomer.Lens as L + +newtype AppModel = AppModel { + _clickCount :: Int +} deriving (Eq, Show) + +data AppEvent + = AppInit + | AppIncrease + deriving (Eq, Show) + +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + widgetTree = vstack [ + label "Hello world", + spacer, + hstack [ + label $ "Click count: " <> showt (model ^. clickCount), + spacer, + button "Increase count" AppIncrease + ] + ] `styleBasic` [padding 10] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppInit -> [] + AppIncrease -> [Model (model & clickCount +~ 1)] + +main01 :: IO () +main01 = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 01 - Basics", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appInitEvent AppInit + ] + model = AppModel 0 diff --git a/examples/tutorial/Tutorial02_Styling.hs b/examples/tutorial/Tutorial02_Styling.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial02_Styling.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial02_Styling where + +import Control.Lens +import Data.Text (Text) +import Monomer + +import qualified Monomer.Lens as L + +data AppModel = AppModel { + _sampleText :: Text, + _showPicker :: Bool, + _fontName :: Font, + _fontSize :: Double, + _fontColor :: Color +} deriving (Eq, Show) + +data AppEvent + = AppInit + deriving (Eq, Show) + +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + widgetTree = vstack [ + titleText "Text", + box (textField sampleText) `styleBasic` [paddingV 10], + + titleText "Font name", + hgrid [ + hstack [ + labeledRadio "Regular " "Regular" fontName, + filler + ], + hstack [ + labeledRadio "Medium " "Medium" fontName, + filler + ], + hstack [ + labeledRadio "Bold " "Bold" fontName, + filler + ], + hstack [ + labeledRadio "Italic " "Italic" fontName + ] + ] `styleBasic` [paddingV 10], + + titleText "Font size", + hslider fontSize 10 200 + `styleBasic` [paddingV 10, fgColor orange], + + titleText "Font color", + hstack [ + labeledCheckbox "Show color picker " showPicker, + filler + ] `styleBasic` [paddingT 10, paddingB 5], + colorPicker fontColor + `nodeVisible` (model ^. showPicker) + `styleBasic` [paddingB 10], + + sampleTextLabel + ] `styleBasic` [padding 10] + + titleText text = label text + `styleBasic` [textFont "Medium", textSize 20] + + sampleTextLabel = label_ (model ^. sampleText) [ellipsis] + `styleBasic` [ + bgColor dimGray, + border 4 lightGray, + radius 10, + textFont (model ^. fontName), + textSize (model ^. fontSize), + textColor (model ^. fontColor), + textCenter, + flexHeight 100] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppInit -> [] + +main02 :: IO () +main02 = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 02 - Styling", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf", + appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf", + appFontDef "Italic" "./assets/fonts/Roboto-Italic.ttf", + appInitEvent AppInit + ] + model = AppModel { + _sampleText = "Hello World!", + _showPicker = False, + _fontName = "Regular", + _fontSize = 24, + _fontColor = white + } diff --git a/examples/tutorial/Tutorial03_LifeCycle.hs b/examples/tutorial/Tutorial03_LifeCycle.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial03_LifeCycle.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial03_LifeCycle where + +import Control.Lens +import Data.Text (Text) +import Monomer +import TextShow + +import qualified Data.Text as T +import qualified Monomer.Lens as L + +data ListItem = ListItem { + _ts :: Int, + _text :: Text +} deriving (Eq, Show) + +data AppModel = AppModel { + _newItemText :: Text, + _items :: [ListItem] +} deriving (Eq, Show) + +data AppEvent + = AppInit + | AddItem + | RemoveItem Int + deriving (Eq, Show) + +makeLenses 'ListItem +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + listItem idx item = vstack [ + label_ (item ^. text) [ellipsis] `styleBasic` [textSize 12, paddingH 8], + spacer, + hstack [ + textField (items . singular (ix idx) . text), + spacer, + button "Delete" (RemoveItem idx) + ] + ] `nodeKey` showt (item ^. ts) `styleBasic` [paddingT 10] + + widgetTree = vstack [ + keystroke [("Enter", AddItem)] $ hstack [ + label "Description:", + spacer, + textField_ newItemText [placeholder "Write here!"], -- `nodeKey` "description", + spacer, + button "Add" AddItem + `styleBasic` [paddingH 5] + `nodeEnabled` (model ^. newItemText /= "") + ], + + separatorLine `styleBasic` [paddingT 20, paddingB 10], + + vstack (zipWith listItem [0..] (model ^. items)) + ] `styleBasic` [padding 20] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppInit -> [] + AddItem + | model ^. newItemText /= "" -> [ + Model $ model + & newItemText .~ "" + & items .~ newItem : model ^. items, + setFocusOnKey wenv "description"] + RemoveItem idx -> [Model $ model + & items .~ removeIdx idx (model ^. items)] + _ -> [] + where + newItem = ListItem (wenv ^. L.timestamp) (model ^. newItemText) + +removeIdx idx lst = part1 ++ drop 1 part2 where + (part1, part2) = splitAt idx lst + +main03 :: IO () +main03 = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 03 - Merging", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appInitEvent AppInit + ] + model = AppModel { + _newItemText = "", + _items = [] + } diff --git a/examples/tutorial/Tutorial04_Tasks.hs b/examples/tutorial/Tutorial04_Tasks.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial04_Tasks.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial04_Tasks where + +import Control.Lens +import Data.Text (Text) +import Monomer +import System.Random + +import qualified Monomer.Lens as L + +data AppModel = AppModel { + _selected :: Int, + _hoverButton :: Bool +} deriving (Eq, Show) + +data AppEvent + = AppGenRandom + | AppSaveRandom Int + | AppOnEnterBtn + | AppOnLeaveBtn + deriving (Eq, Show) + +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + pushLayers = zstack [ + image_ "./assets/images/red-button.png" [fitFill] `nodeVisible` not (model ^. hoverButton), + image_ "./assets/images/red-button-hover.png" [fitFill] `nodeVisible` model ^. hoverButton, + label "Push!" `styleBasic` [textFont "Bold", textSize 20, textCenter] + ] + pushButton = box_ [onClick AppGenRandom, onEnter AppOnEnterBtn, onLeave AppOnLeaveBtn] pushLayers + `styleBasic` [width 160, height 160, cursorHand] + numberLabel = labelS (model ^. selected) + `styleBasic` [textFont "Bold", textSize 100, textColor black, textCenter, width 160] + numberedImage url idx = scroll (image_ url [fitNone]) + `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/1047/800/600" 3, + numberedImage "https://picsum.photos/id/1025/800/600" 4, + numberedImage "https://picsum.photos/id/1080/800/600" 5, + numberedImage "https://picsum.photos/id/1059/800/600" 6 + ] `styleBasic` [padding 10] + widgetTree = vstack [ + hstack [ + tooltip "Click to pick a random number" pushButton + `styleBasic` [textSize 16, bgColor steelBlue, paddingH 5, radius 5], + numberLabel + ], + imageSet + ] `styleBasic` [bgColor moccasin] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppGenRandom -> [Task $ + AppSaveRandom <$> randomRIO (1, 6) + ] + AppSaveRandom value -> [Model $ model & selected .~ value] + AppOnEnterBtn -> [Model $ model & hoverButton .~ True] + AppOnLeaveBtn -> [Model $ model & hoverButton .~ False] + +main04 :: IO () +main04 = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 04 - Tasks", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf" + ] + model = AppModel { + _selected = 0, + _hoverButton = False + } diff --git a/examples/tutorial/Tutorial05_Producers.hs b/examples/tutorial/Tutorial05_Producers.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial05_Producers.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial05_Producers where + +import Control.Concurrent (threadDelay) +import Control.Lens +import Data.Text (Text) +import Data.Time +import Monomer + +import qualified Data.Text as T +import qualified Monomer.Lens as L + +newtype AppModel = AppModel { + _currentTime :: TimeOfDay +} deriving (Eq, Show) + +data AppEvent + = AppInit + | AppSetTime TimeOfDay + deriving (Eq, Show) + +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + timeString = T.pack . show $ model ^. currentTime + + timeLabel = label (T.takeWhile (/= '.') timeString) + `styleBasic` [textFont "Bold", textSize 80, textCenter, textMiddle, flexHeight 100] + + widgetTree = vstack [ + animFadeIn timeLabel `nodeKey` "fadeTimeLabel" + ] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppInit -> [Producer timeOfDayProducer] + AppSetTime time -> fadeInMsg time ++ [Model $ model & currentTime .~ time] + where + fadeInMsg time + | truncate (todSec time) `mod` 10 /= 0 = [] + | otherwise = [Message "fadeTimeLabel" AnimationStart] + +timeOfDayProducer :: (AppEvent -> IO ()) -> IO () +timeOfDayProducer sendMsg = do + time <- getLocalTimeOfDay + sendMsg (AppSetTime time) + threadDelay $ 1000 * 1000 + timeOfDayProducer sendMsg + +getLocalTimeOfDay :: IO TimeOfDay +getLocalTimeOfDay = do + time <- getZonedTime + return . localTimeOfDay . zonedTimeToLocalTime $ time + +main05 :: IO () +main05 = do + time <- getLocalTimeOfDay + startApp (model time) handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 05 - Producers", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf", + appInitEvent AppInit + ] + model time = AppModel { + _currentTime = time + } diff --git a/examples/tutorial/Tutorial06_Composite.hs b/examples/tutorial/Tutorial06_Composite.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial06_Composite.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial06_Composite where + +import Control.Concurrent (threadDelay) +import Control.Lens +import Data.List +import Data.Text (Text) +import Monomer +import TextShow + +import qualified Data.Text as T +import qualified Monomer.Lens as L + +data CompModel = CompModel { + _listA :: [Int], + _listB :: [Int] +} deriving (Eq, Show) + +data CompEvent + = DropToA Int + | DropToB Int + deriving (Eq, Show) + +data AppModel = AppModel { + _showDialog :: Bool, + _parentModel :: CompModel, + _dialogModel :: CompModel +} deriving (Eq, Show) + +data AppEvent + = AppInit + | ShowDialog + | CloseDialog + deriving (Eq, Show) + +makeLenses 'CompModel +makeLenses 'AppModel + +buildUIComp + :: WidgetEnv CompModel CompEvent + -> CompModel + -> WidgetNode CompModel CompEvent +buildUIComp wenv model = widgetTree where + sectionBg = rgbHex "#80B6FD" + sectionHover = rgbHex "#A0D8FD" + textDrag = rgbHex "#E0FFFF" + + itemA val = label ("Item: " <> showt val) + `styleBasic` [textColor black, padding 5] + + dragItem val = draggable_ val + [draggableStyle [bgColor textDrag, radius 5]] + (itemA val) + `styleBasic` [cursorHand] + + dragList items = vstack (dragItem <$> items) + + dropContainer target list = dropTarget_ target + [dropTargetStyle [radius 10, bgColor sectionHover]] + (dragList (model ^. list)) + `styleBasic` [minWidth 100, flexHeight 100, padding 5, radius 10, bgColor sectionBg] + + dropTargetA = dropContainer DropToA listA + dropTargetB = dropContainer DropToB listB + + widgetTree = hstack [ + box dropTargetA `styleBasic` [paddingR 5], + box dropTargetB `styleBasic` [paddingL 5] + ] + +handleEventComp + :: WidgetEnv CompModel CompEvent + -> WidgetNode CompModel CompEvent + -> CompModel + -> CompEvent + -> [EventResponse CompModel CompEvent sp ep] +handleEventComp wenv node model evt = case evt of + DropToA val -> [Model $ model + & listA .~ sort (val : model ^. listA) + & listB .~ delete val (model ^. listB)] + + DropToB val -> [Model $ model + & listA .~ delete val (model ^. listA) + & listB .~ sort (val : model ^. listB)] + +compWidget + :: (WidgetModel sp, WidgetEvent ep) + => ALens' sp CompModel + -> WidgetNode sp ep +compWidget field = composite "compWidget" field buildUIComp handleEventComp + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + baseLayer = vstack [ + compWidget parentModel, + spacer, + hstack [ + button "Show Dialog" ShowDialog + ] + ] `styleBasic` [padding 10] + + closeIcon = icon IconClose + `styleBasic` [width 16, height 16, fgColor black, cursorHand] + + dialogLayer = vstack [ + hstack [ + filler, + box_ [alignTop, onClick CloseDialog] closeIcon + ], + spacer, + compWidget dialogModel + ] `styleBasic` [width 500, height 400, padding 10, radius 10, bgColor darkGray] + + widgetTree = zstack [ + baseLayer, + box_ [alignCenter, alignMiddle] dialogLayer + `nodeVisible` model ^. showDialog + `styleBasic` [bgColor (gray & L.a .~ 0.8)] + ] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppInit -> [] + ShowDialog -> [Model $ model & showDialog .~ True] + CloseDialog -> [Model $ model & showDialog .~ False] + +main06 :: IO () +main06 = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 06 - Composite", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appInitEvent AppInit + ] + compModel = CompModel { + _listA = [1..10], + _listB = [] + } + model = AppModel { + _showDialog = False, + _parentModel = compModel, + _dialogModel = compModel + } diff --git a/examples/tutorial/Tutorial07_CustomWidget.hs b/examples/tutorial/Tutorial07_CustomWidget.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial07_CustomWidget.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial07_CustomWidget where + +import Control.Concurrent (threadDelay) +import Control.Lens +import Control.Monad (forM_) +import Data.Default +import Data.Text (Text) +import Data.Typeable (cast) +import Monomer +import Monomer.Widgets.Single + +import qualified Data.Text as T +import qualified Monomer.Lens as L + +newtype CanvasCfg = CanvasCfg { + _canvasColors :: [Color] +} deriving (Eq, Show) + +instance Default CanvasCfg where + def = CanvasCfg { + _canvasColors = [] + } + +instance Semigroup CanvasCfg where + (<>) c1 c2 = CanvasCfg { + _canvasColors = _canvasColors c1 <> _canvasColors c2 + } + +instance Monoid CanvasCfg where + mempty = def + +data CanvasMessage + = ResetCanvas + deriving (Eq, Show) + +newtype CanvasState = CanvasState { + _clickedPoints :: [Point] +} deriving (Eq, Show) + +makeLenses 'CanvasCfg +makeLenses 'CanvasState + +canvasColor :: Color -> CanvasCfg +canvasColor col = def & canvasColors .~ [col] + +canvas :: WidgetNode s e +canvas = canvas_ def + +canvas_ :: [CanvasCfg] -> WidgetNode s e +canvas_ configs = defaultWidgetNode "canvas" newWidget where + config = mconcat configs + state = CanvasState [] + newWidget = makeCanvas config state + +makeCanvas :: CanvasCfg -> CanvasState -> Widget s e +makeCanvas cfg state = widget where + widget = createSingle state def { + singleMerge = merge, + singleHandleEvent = handleEvent, + singleHandleMessage = handleMessage, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + colors + | null (cfg ^. canvasColors) = [orange, green, steelBlue, deepPink] + | otherwise = cfg ^. canvasColors + nextColor idx = colors !! (idx `mod` length colors) + + merge wenv node oldNode oldState = result where + newNode = node + & L.widget .~ makeCanvas cfg oldState + result = resultNode newNode + + handleEvent wenv node target evt = case evt of + Click point button clicks -> Just result where + newPoint = subPoint point origin + newPoints = newPoint : state ^. clickedPoints + newState = CanvasState newPoints + newNode = node + & L.widget .~ makeCanvas cfg newState + result = resultNode newNode + Move _ -> Just (resultReqs node [RenderOnce]) + _ -> Nothing + where + vp = node ^. L.info . L.viewport + origin = Point (vp ^. L.x) (vp ^. L.y) + + handleMessage wenv node target msg = case cast msg of + Just ResetCanvas -> Just result where + newState = CanvasState [] + newNode = node + & L.widget .~ makeCanvas cfg newState + result = resultNode newNode + _ -> Nothing + + getSizeReq wenv node = (sizeReqW, sizeReqH) where + sizeReqW = minWidth 100 + sizeReqH = minHeight 100 + + render wenv node renderer = do + drawInTranslation renderer origin $ + forM_ tuples $ \(idx, pointA, pointB) -> do + setStrokeColor renderer (nextColor idx) + setStrokeWidth renderer 2 + beginPath renderer + renderLine renderer pointA pointB + stroke renderer + where + vp = node ^. L.info . L.viewport + mousePos = wenv ^. L.inputStatus . L.mousePos + newPoint = subPoint mousePos origin + origin = Point (vp ^. L.x) (vp ^. L.y) + clicked = state ^. clickedPoints + points + | isPointInNodeVp node mousePos = reverse $ newPoint : clicked + | otherwise = reverse clicked + tuples = zip3 [0..] points (drop 1 points) + +data AppModel + = AppModel + deriving (Eq, Show) + +data AppEvent + = AppResetCanvas + deriving (Eq, Show) + +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + widgetTree = vstack [ + button "Reset canvas" AppResetCanvas, + spacer, + canvas `nodeKey` "mainCanvas" `styleBasic` [border 1 gray] +-- canvas_ [canvasColor pink] `nodeKey` "mainCanvas" `styleBasic` [border 1 gray] + ] `styleBasic` [padding 10] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppResetCanvas -> [Message "mainCanvas" ResetCanvas] + +main07 :: IO () +main07 = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 07 - Custom Widget", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf" + ] + model = AppModel diff --git a/examples/tutorial/Tutorial08_Themes.hs b/examples/tutorial/Tutorial08_Themes.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Tutorial08_Themes.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tutorial08_Themes where + +import Control.Lens +import Data.Text (Text) +import Monomer +import Monomer.Core.Themes.BaseTheme +import TextShow + +import qualified Monomer.Lens as L + +data ActiveTheme + = DarkTheme + | LightTheme + | CustomTheme + deriving (Eq, Enum, Show) + +data AppModel = AppModel { + _clickCount :: Int, + _checked :: Bool, + _activeTheme :: ActiveTheme +} deriving (Eq, Show) + +data AppEvent + = AppInit + | AppIncrease + | AppDecrease + deriving (Eq, Show) + +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + theme = case model ^. activeTheme of + DarkTheme -> darkTheme + LightTheme -> lightTheme + CustomTheme -> customTheme + widgetTree = themeSwitch_ theme [themeClearBg] $ vstack [ + hstack [ + label "Select theme:", + spacer, + textDropdownS activeTheme (enumFrom (toEnum 0)) + ], + + spacer, + separatorLine, + + spacer, + hstack [ + labeledCheckbox "Checkbox" checked, + spacer, + labeledRadio "Boolean radio (True)" True checked, + spacer, + labeledRadio "Boolean radio (False)" False checked + ], + + spacer, + hstack [ + box $ hslider clickCount 0 100, + spacer, + numericField_ clickCount [minValue 0, maxValue 100] + ], + + spacer, + hstack [ + label $ "Click count: " <> showt (model ^. clickCount), + spacer, + mainButton "Increase count" AppIncrease, + spacer, + button "Decrease count" AppDecrease + ] + ] `styleBasic` [padding 20] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppInit -> [] + AppIncrease -> [Model (model & clickCount .~ min 100 (count + 1))] + AppDecrease -> [Model (model & clickCount .~ max 0 (count - 1))] + where + count = model ^. clickCount + +customTheme :: Theme +customTheme = baseTheme darkThemeColors { + btnMainBgBasic = rgbHex "#EE9000", + btnMainBgHover = rgbHex "#FFB522", + btnMainBgFocus = rgbHex "#FFA500", + btnMainBgActive = rgbHex "#DD8000", + btnMainBgDisabled = rgbHex "#BB8800", + btnMainText = rgbHex "000000" +} + +main08 :: IO () +main08 = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Tutorial 08 - Themes", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appInitEvent AppInit + ] + model = AppModel 0 False LightTheme diff --git a/monomer.cabal b/monomer.cabal new file mode 100644 --- /dev/null +++ b/monomer.cabal @@ -0,0 +1,499 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: monomer +version: 1.0.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. + . + It provides a framework similar to the Elm Architecture, allowing the creation + of GUIs using an extensible set of widgets with pure Haskell. + . + Please see the README on Github at +category: GUI +homepage: https://github.com/fjvallarino/monomer#readme +bug-reports: https://github.com/fjvallarino/monomer/issues +author: Francisco Vallarino +maintainer: fjvallarino@gmail.com +copyright: 2018 Francisco Vallarino +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/fjvallarino/monomer + +library + exposed-modules: + Monomer + Monomer.Common + Monomer.Common.BasicTypes + Monomer.Common.Lens + Monomer.Core + Monomer.Core.Combinators + Monomer.Core.FromFractional + Monomer.Core.Lens + Monomer.Core.SizeReq + Monomer.Core.Style + Monomer.Core.StyleTypes + Monomer.Core.StyleUtil + Monomer.Core.Themes.BaseTheme + Monomer.Core.Themes.SampleThemes + Monomer.Core.ThemeTypes + Monomer.Core.Util + Monomer.Core.WidgetTypes + Monomer.Event + Monomer.Event.Core + Monomer.Event.Keyboard + Monomer.Event.Lens + Monomer.Event.Types + Monomer.Event.Util + Monomer.Graphics + Monomer.Graphics.ColorTable + Monomer.Graphics.FFI + Monomer.Graphics.FontManager + Monomer.Graphics.Lens + Monomer.Graphics.NanoVGRenderer + Monomer.Graphics.RemixIcon + Monomer.Graphics.Text + Monomer.Graphics.Types + Monomer.Graphics.Util + Monomer.Helper + Monomer.Lens + Monomer.Main + Monomer.Main.Core + Monomer.Main.Handlers + Monomer.Main.Lens + Monomer.Main.Platform + Monomer.Main.Types + Monomer.Main.UserUtil + Monomer.Main.Util + Monomer.Main.WidgetTask + Monomer.Widgets + Monomer.Widgets.Animation + Monomer.Widgets.Animation.Fade + Monomer.Widgets.Animation.Slide + Monomer.Widgets.Animation.Types + Monomer.Widgets.Composite + Monomer.Widgets.Container + Monomer.Widgets.Containers.Alert + Monomer.Widgets.Containers.Base.LabeledItem + Monomer.Widgets.Containers.Box + Monomer.Widgets.Containers.Confirm + Monomer.Widgets.Containers.Draggable + Monomer.Widgets.Containers.Dropdown + Monomer.Widgets.Containers.DropTarget + Monomer.Widgets.Containers.Grid + Monomer.Widgets.Containers.Keystroke + Monomer.Widgets.Containers.Scroll + Monomer.Widgets.Containers.SelectList + Monomer.Widgets.Containers.Split + Monomer.Widgets.Containers.Stack + Monomer.Widgets.Containers.ThemeSwitch + Monomer.Widgets.Containers.Tooltip + Monomer.Widgets.Containers.ZStack + Monomer.Widgets.Single + Monomer.Widgets.Singles.Base.InputField + Monomer.Widgets.Singles.Button + Monomer.Widgets.Singles.Checkbox + Monomer.Widgets.Singles.ColorPicker + Monomer.Widgets.Singles.DateField + Monomer.Widgets.Singles.Dial + Monomer.Widgets.Singles.ExternalLink + Monomer.Widgets.Singles.Icon + Monomer.Widgets.Singles.Image + Monomer.Widgets.Singles.Label + Monomer.Widgets.Singles.LabeledCheckbox + Monomer.Widgets.Singles.LabeledRadio + Monomer.Widgets.Singles.NumericField + Monomer.Widgets.Singles.Radio + Monomer.Widgets.Singles.SeparatorLine + Monomer.Widgets.Singles.Slider + Monomer.Widgets.Singles.Spacer + Monomer.Widgets.Singles.TextArea + Monomer.Widgets.Singles.TextDropdown + Monomer.Widgets.Singles.TextField + Monomer.Widgets.Singles.TimeField + Monomer.Widgets.Util + Monomer.Widgets.Util.Drawing + Monomer.Widgets.Util.Focus + Monomer.Widgets.Util.Hover + Monomer.Widgets.Util.Keyboard + Monomer.Widgets.Util.Lens + Monomer.Widgets.Util.Parser + Monomer.Widgets.Util.Style + Monomer.Widgets.Util.Text + Monomer.Widgets.Util.Theme + Monomer.Widgets.Util.Types + Monomer.Widgets.Util.Widget + other-modules: + Paths_monomer + hs-source-dirs: + src + default-extensions: + OverloadedStrings + ghc-options: -fwarn-incomplete-patterns + cc-options: -fPIC + include-dirs: + cbits + install-includes: + fontmanager.h + c-sources: + cbits/dpi.c + cbits/fontmanager.c + cbits/glew.c + build-tools: + c2hs + build-depends: + JuicyPixels >=3.2.9 && <3.5 + , OpenGL ==3.0.* + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <5.1 + , mtl >=2.1 && <2.3 + , nanovg >=0.8 && <1.0 + , process ==1.6.* + , safe ==0.3.* + , sdl2 >=2.4.0 && <2.6 + , stm ==2.5.* + , text ==1.2.* + , text-show >=3.7 && <3.10 + , time >=1.8 && <1.13 + , transformers >=0.5 && <0.7 + , unordered-containers >=0.2.8 && <0.3 + , vector >=0.12 && <0.14 + , wreq >=0.5.2 && <0.6 + if os(windows) + extra-libraries: + glew32 + else + extra-libraries: + GLEW + default-language: Haskell2010 + +executable books + main-is: Main.hs + other-modules: + BookTypes + Paths_monomer + hs-source-dirs: + examples/books + default-extensions: + OverloadedStrings + ghc-options: -threaded + build-depends: + JuicyPixels >=3.2.9 && <3.5 + , OpenGL ==3.0.* + , aeson >=1.4 && <1.6 + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <5.1 + , monomer + , mtl >=2.1 && <2.3 + , nanovg >=0.8 && <1.0 + , process ==1.6.* + , safe ==0.3.* + , sdl2 >=2.4.0 && <2.6 + , stm ==2.5.* + , text ==1.2.* + , text-show >=3.7 && <3.10 + , time >=1.8 && <1.13 + , transformers >=0.5 && <0.7 + , unordered-containers >=0.2.8 && <0.3 + , vector >=0.12 && <0.14 + , wreq >=0.5.2 && <0.6 + default-language: Haskell2010 + +executable generative + main-is: Main.hs + other-modules: + GenerativeTypes + Widgets.BoxesPalette + Widgets.CirclesGrid + Paths_monomer + hs-source-dirs: + examples/generative + default-extensions: + OverloadedStrings + ghc-options: -threaded + build-depends: + JuicyPixels >=3.2.9 && <3.5 + , OpenGL ==3.0.* + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <5.1 + , monomer + , mtl >=2.1 && <2.3 + , nanovg >=0.8 && <1.0 + , process ==1.6.* + , random >=1.1 && <1.3 + , safe ==0.3.* + , sdl2 >=2.4.0 && <2.6 + , stm ==2.5.* + , text ==1.2.* + , text-show >=3.7 && <3.10 + , time >=1.8 && <1.13 + , transformers >=0.5 && <0.7 + , unordered-containers >=0.2.8 && <0.3 + , vector >=0.12 && <0.14 + , wreq >=0.5.2 && <0.6 + default-language: Haskell2010 + +executable ticker + main-is: Main.hs + other-modules: + BinanceTypes + TickerTypes + Paths_monomer + hs-source-dirs: + examples/ticker + default-extensions: + OverloadedStrings + ghc-options: -threaded + build-depends: + JuicyPixels >=3.2.9 && <3.5 + , OpenGL ==3.0.* + , aeson >=1.4 && <1.6 + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <5.1 + , monomer + , mtl >=2.1 && <2.3 + , nanovg >=0.8 && <1.0 + , process ==1.6.* + , safe ==0.3.* + , scientific ==0.3.* + , sdl2 >=2.4.0 && <2.6 + , stm ==2.5.* + , text ==1.2.* + , text-show >=3.7 && <3.10 + , time >=1.8 && <1.13 + , transformers >=0.5 && <0.7 + , unordered-containers >=0.2.8 && <0.3 + , vector >=0.12 && <0.14 + , websockets ==0.12.* + , wreq >=0.5.2 && <0.6 + , wuss ==1.1.* + default-language: Haskell2010 + +executable todo + main-is: Main.hs + other-modules: + TodoTypes + Paths_monomer + hs-source-dirs: + examples/todo + default-extensions: + OverloadedStrings + ghc-options: -threaded + build-depends: + JuicyPixels >=3.2.9 && <3.5 + , OpenGL ==3.0.* + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <5.1 + , monomer + , mtl >=2.1 && <2.3 + , nanovg >=0.8 && <1.0 + , process ==1.6.* + , safe ==0.3.* + , sdl2 >=2.4.0 && <2.6 + , stm ==2.5.* + , text ==1.2.* + , text-show >=3.7 && <3.10 + , time >=1.8 && <1.13 + , transformers >=0.5 && <0.7 + , unordered-containers >=0.2.8 && <0.3 + , vector >=0.12 && <0.14 + , wreq >=0.5.2 && <0.6 + default-language: Haskell2010 + +executable tutorial + main-is: Main.hs + other-modules: + Tutorial01_Basics + Tutorial02_Styling + Tutorial03_LifeCycle + Tutorial04_Tasks + Tutorial05_Producers + Tutorial06_Composite + Tutorial07_CustomWidget + Tutorial08_Themes + Paths_monomer + hs-source-dirs: + examples/tutorial + default-extensions: + OverloadedStrings + ghc-options: -threaded + build-depends: + JuicyPixels >=3.2.9 && <3.5 + , OpenGL ==3.0.* + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <5.1 + , monomer + , mtl >=2.1 && <2.3 + , nanovg >=0.8 && <1.0 + , process ==1.6.* + , random >=1.1 && <1.3 + , safe ==0.3.* + , sdl2 >=2.4.0 && <2.6 + , stm ==2.5.* + , text ==1.2.* + , text-show >=3.7 && <3.10 + , time >=1.8 && <1.13 + , transformers >=0.5 && <0.7 + , unordered-containers >=0.2.8 && <0.3 + , vector >=0.12 && <0.14 + , wreq >=0.5.2 && <0.6 + default-language: Haskell2010 + +test-suite monomer-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Monomer.Common.CursorIconSpec + Monomer.Graphics.UtilSpec + Monomer.TestEventUtil + Monomer.TestUtil + Monomer.Widgets.Animation.FadeSpec + Monomer.Widgets.Animation.SlideSpec + Monomer.Widgets.CompositeSpec + Monomer.Widgets.Containers.AlertSpec + Monomer.Widgets.Containers.BoxSpec + Monomer.Widgets.Containers.ConfirmSpec + Monomer.Widgets.Containers.DragDropSpec + Monomer.Widgets.Containers.DropdownSpec + Monomer.Widgets.Containers.GridSpec + Monomer.Widgets.Containers.KeystrokeSpec + Monomer.Widgets.Containers.ScrollSpec + Monomer.Widgets.Containers.SelectListSpec + Monomer.Widgets.Containers.SplitSpec + Monomer.Widgets.Containers.StackSpec + Monomer.Widgets.Containers.ThemeSwitchSpec + Monomer.Widgets.Containers.TooltipSpec + Monomer.Widgets.Containers.ZStackSpec + Monomer.Widgets.ContainerSpec + Monomer.Widgets.Singles.ButtonSpec + Monomer.Widgets.Singles.CheckboxSpec + Monomer.Widgets.Singles.ColorPickerSpec + Monomer.Widgets.Singles.DateFieldSpec + Monomer.Widgets.Singles.DialSpec + Monomer.Widgets.Singles.ExternalLinkSpec + Monomer.Widgets.Singles.ImageSpec + Monomer.Widgets.Singles.LabeledCheckboxSpec + Monomer.Widgets.Singles.LabeledRadioSpec + Monomer.Widgets.Singles.LabelSpec + Monomer.Widgets.Singles.NumericFieldSpec + Monomer.Widgets.Singles.RadioSpec + Monomer.Widgets.Singles.SeparatorLineSpec + Monomer.Widgets.Singles.SliderSpec + Monomer.Widgets.Singles.SpacerSpec + Monomer.Widgets.Singles.TextAreaSpec + Monomer.Widgets.Singles.TextFieldSpec + Monomer.Widgets.Singles.TimeFieldSpec + Monomer.Widgets.Util.FocusSpec + Monomer.Widgets.Util.StyleSpec + Monomer.Widgets.Util.TextSpec + Paths_monomer + hs-source-dirs: + test/unit + default-extensions: + OverloadedStrings + ghc-options: -threaded -fwarn-incomplete-patterns -rtsopts -with-rtsopts=-N -with-rtsopts=-T + build-depends: + HUnit ==1.6.* + , JuicyPixels >=3.2.9 && <3.5 + , OpenGL ==3.0.* + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , directory ==1.3.* + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , hspec >=2.4 && <3.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <5.1 + , monomer + , mtl >=2.1 && <2.3 + , nanovg >=0.8 && <1.0 + , process ==1.6.* + , safe ==0.3.* + , sdl2 >=2.4.0 && <2.6 + , silently ==1.2.* + , stm ==2.5.* + , text ==1.2.* + , text-show >=3.7 && <3.10 + , time >=1.8 && <1.13 + , transformers >=0.5 && <0.7 + , unordered-containers >=0.2.8 && <0.3 + , vector >=0.12 && <0.14 + , wreq >=0.5.2 && <0.6 + default-language: Haskell2010 diff --git a/src/Monomer.hs b/src/Monomer.hs new file mode 100644 --- /dev/null +++ b/src/Monomer.hs @@ -0,0 +1,63 @@ +{-| +Module : Monomer +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Main module, re-exporting all the modules in the library. This is the module +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 +are: + +- "Monomer.Common" +- "Monomer.Core" +- "Monomer.Event" +- "Monomer.Graphics" +- "Monomer.Main" +- "Monomer.Widgets" + +If you want to create custom Widgets, check: + +- "Monomer.Widgets.Single" for self contained widgets +- "Monomer.Widgets.Container" for widgets with children +-} +module Monomer ( + -- * Basic types common to all modules. + module Monomer.Common, + -- * Core types and utilities. + module Monomer.Core, + -- * User friendly names for configuration options. + module Monomer.Core.Combinators, + -- * Default theme, with light and dark versions. + module Monomer.Core.Themes.SampleThemes, + -- * High level and low level events and utilities. + module Monomer.Event, + -- * Graphics types, utilities and renderer implementation. + module Monomer.Graphics, + -- * Names for common colors. + module Monomer.Graphics.ColorTable, + -- * Icons from the Remix library. + module Monomer.Graphics.RemixIcon, + -- * Application launcher. + module Monomer.Main, + -- * Widgets included in the library. + module Monomer.Widgets +) where + +import Monomer.Common +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.Graphics +import Monomer.Graphics.ColorTable +import Monomer.Graphics.RemixIcon +import Monomer.Main +import Monomer.Widgets diff --git a/src/Monomer/Common.hs b/src/Monomer/Common.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Common.hs @@ -0,0 +1,15 @@ +{-| +Module : Monomer.Common +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Common module, including basic types definitions. +-} +module Monomer.Common ( + module Monomer.Common.BasicTypes +) where + +import Monomer.Common.BasicTypes diff --git a/src/Monomer/Common/BasicTypes.hs b/src/Monomer/Common/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Common/BasicTypes.hs @@ -0,0 +1,197 @@ +{-| +Module : Monomer.Common.BasicTypes +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Basic types used across the library. +-} +{-# LANGUAGE DeriveGeneric #-} + +module Monomer.Common.BasicTypes where + +import Data.Default +import Data.Sequence (Seq) +import GHC.Generics + +import qualified Data.Sequence as Seq + +-- | An index in the list of children of a widget. +type PathStep = Int +-- | A sequence of steps, usually from the root. +type Path = Seq PathStep +-- | Resize factor. +type Factor = Double + +-- | Point in the 2D space. +data Point = Point { + _pX :: {-# UNPACK #-} !Double, + _pY :: {-# UNPACK #-} !Double +} deriving (Eq, Show, Generic) + +instance Default Point where + def = Point 0 0 + +-- | Width and height, used for size requirements. +data Size = Size { + _sW :: {-# UNPACK #-} !Double, + _sH :: {-# UNPACK #-} !Double +} deriving (Eq, Show, Generic) + +instance Default Size where + def = Size 0 0 + +-- | Rectangle, usually representing an area of the screen. +data Rect = Rect { + _rX :: {-# UNPACK #-} !Double, + _rY :: {-# UNPACK #-} !Double, + _rW :: {-# UNPACK #-} !Double, + _rH :: {-# UNPACK #-} !Double +} deriving (Eq, Show, Generic) + +instance Default Rect where + def = Rect 0 0 0 0 + +-- | An empty path. +emptyPath :: Path +emptyPath = Seq.empty + +-- | The path of the root element. +rootPath :: Path +rootPath = Seq.singleton 0 + +-- | Checks if a point is inside the given rect. +pointInRect :: Point -> Rect -> Bool +pointInRect (Point px py) rect = coordInRectH px rect && coordInRectY py rect + +-- | Checks if a point is inside the given ellipse. +pointInEllipse :: Point -> Rect -> Bool +pointInEllipse (Point px py) rect = ellipseTest <= 1 where + Rect rx ry rw rh = rect + ew = rw / 2 + eh = rh / 2 + cx = rx + ew + cy = ry + eh + ellipseTest = ((px - cx) ^ 2) / ew ^ 2 + ((py - cy) ^ 2) / eh ^ 2 + +-- | Adds two points. +addPoint :: Point -> Point -> Point +addPoint (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2) + +-- | Subtracts one point from another. +subPoint :: Point -> Point -> Point +subPoint (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2) + +-- | Multiplies the coordinates of a point by the given factor. +mulPoint :: Double -> Point -> Point +mulPoint factor (Point x y) = Point (factor * x) (factor * y) + +-- | Returns the middle between two points. +midPoint :: Point -> Point -> Point +midPoint p1 p2 = interpolatePoints p1 p2 0.5 + +-- | Returns the point between a and b, f units away from a. +interpolatePoints :: Point -> Point -> Double -> Point +interpolatePoints (Point x1 y1) (Point x2 y2) f = newPoint where + newPoint = Point (f * x1 + (1 - f) * x2) (f * y1 + (1 - f) * y2) + +-- | Negates the coordinates of a point. +negPoint :: Point -> Point +negPoint (Point x y) = Point (-x) (-y) + +-- | Checks if a coordinate is inside the horizontal range of a rect. +coordInRectH :: Double -> Rect -> Bool +coordInRectH px (Rect x y w h) = px >= x && px < x + w + +-- | Checks if a coordinate is inside the vertical range of a rect. +coordInRectY :: Double -> Rect -> Bool +coordInRectY py (Rect x y w h) = py >= y && py < y + h + +-- | Adds width and height to a Size. +addToSize :: Size -> Double -> Double -> Maybe Size +addToSize (Size w h) w2 h2 = newSize where + nw = w + w2 + nh = h + h2 + newSize + | nw >= 0 && nh >= 0 = Just $ Size nw nh + | otherwise = Nothing + +-- | Subtracts width and height from a Size. +subtractFromSize :: Size -> Double -> Double -> Maybe Size +subtractFromSize (Size w h) w2 h2 = newSize where + nw = w - w2 + nh = h - h2 + newSize + | nw >= 0 && nh >= 0 = Just $ Size nw nh + | otherwise = Nothing + +-- | Moves a rect by the provided offset. +moveRect :: Point -> Rect -> Rect +moveRect (Point x y) (Rect rx ry rw rh) = Rect (rx + x) (ry + y) rw rh + +-- | Returns the middle point of a rect. +rectCenter :: Rect -> Point +rectCenter (Rect rx ry rw rh) = Point (rx + rw / 2) (ry + rh / 2) + +-- | Checks if a rectangle is completely inside a rect. +rectInRect :: Rect -> Rect -> Bool +rectInRect inner outer = rectInRectH inner outer && rectInRectV inner outer + +-- | Checks if a rectangle is completely inside a rectangle horizontal area. +rectInRectH :: Rect -> Rect -> Bool +rectInRectH (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = + x1 >= x2 && x1 + w1 <= x2 + w2 + +-- | Checks if a rectangle is completely inside a rectangle vertical area. +rectInRectV :: Rect -> Rect -> Bool +rectInRectV (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = + y1 >= y2 && y1 + h1 <= y2 + h2 + +-- | Checks if a rectangle overlaps another rectangle. +rectsOverlap :: Rect -> Rect -> Bool +rectsOverlap (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = overlapX && overlapY where + overlapX = x1 < x2 + w2 && x1 + w1 > x2 + overlapY = y1 < y2 + h2 && y1 + h1 > y2 + +-- | Returns a point bounded to the horizontal and vertical limits of a rect. +rectBoundedPoint :: Rect -> Point -> Point +rectBoundedPoint (Rect rx ry rw rh) (Point px py) = Point px2 py2 where + px2 = max rx . min (rx + rw) $ px + py2 = max ry . min (ry + rh) $ py + +-- | 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 + nx = x - l + ny = y - t + nw = w + l + r + nh = h + t + b + newRect + | nw >= 0 && nh >= 0 = Just $ Rect nx ny nw nh + | otherwise = Nothing + +-- | Subtracts individual x, y, w and h coordinates from a rect. +subtractFromRect :: Rect -> Double -> Double -> Double -> Double -> Maybe Rect +subtractFromRect (Rect x y w h) l r t b = newRect where + nx = x + l + ny = y + t + nw = w - l - r + nh = h - t - b + newRect + | nw >= 0 && nh >= 0 = Just $ Rect nx ny nw nh + | otherwise = Nothing + +-- | Returns the intersection of two rects, if any. +intersectRects :: Rect -> Rect -> Maybe Rect +intersectRects (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = newRect where + nx1 = max x1 x2 + nx2 = min (x1 + w1) (x2 + w2) + ny1 = max y1 y2 + ny2 = min (y1 + h1) (y2 + h2) + nw = nx2 - nx1 + nh = ny2 - ny1 + newRect + | nw >= 0 && nh >= 0 = Just $ Rect nx1 ny1 nw nh + | otherwise = Nothing diff --git a/src/Monomer/Common/Lens.hs b/src/Monomer/Common/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Common/Lens.hs @@ -0,0 +1,24 @@ +{-| +Module : Monomer.Common.Lens +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Lenses for the Common types. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Common.Lens where + +import Control.Lens.TH (abbreviatedFields, makeLensesWith, makePrisms) + +import Monomer.Common.BasicTypes + +-- Basic +makeLensesWith abbreviatedFields ''Point +makeLensesWith abbreviatedFields ''Size +makeLensesWith abbreviatedFields ''Rect diff --git a/src/Monomer/Core.hs b/src/Monomer/Core.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core.hs @@ -0,0 +1,27 @@ +{-| +Module : Monomer.Core +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Core module, including basic types, styling, sizing and widget definitions. +-} +module Monomer.Core ( + module Monomer.Common, + module Monomer.Core.FromFractional, + module Monomer.Core.SizeReq, + module Monomer.Core.Style, + module Monomer.Core.StyleUtil, + module Monomer.Core.Util, + module Monomer.Core.WidgetTypes +) where + +import Monomer.Common +import Monomer.Core.FromFractional +import Monomer.Core.SizeReq +import Monomer.Core.Style +import Monomer.Core.StyleUtil +import Monomer.Core.Util +import Monomer.Core.WidgetTypes diff --git a/src/Monomer/Core/Combinators.hs b/src/Monomer/Core/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/Combinators.hs @@ -0,0 +1,696 @@ +{-| +Module : Monomer.Core.Combinators +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Combinator typeclasses used for style and widget configutation. The reason for +using typeclasses is for the ability to reuse names such as onClick. + +Boolean combinators in general have two versions: + +- combinatorName: uses the default value, normally True, and is derived from the +combinator with _ suffix. +- combinatorName_: receives a boolean parameter. This is the function that needs +to be overriden in widgets. +-} +{-# LANGUAGE FunctionalDependencies #-} + +module Monomer.Core.Combinators where + +import Control.Lens (ALens') +import Data.Text (Text) + +import Monomer.Common +import Monomer.Core.StyleTypes +import Monomer.Core.WidgetTypes +import Monomer.Event.Types +import Monomer.Graphics.Types + +{-| +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. +-} +class CmbMergeRequired t s | t -> s where + mergeRequired :: (s -> s -> Bool) -> t + +-- | Listener for the validation status of a field using a lens. +class CmbValidInput t s | t -> s where + validInput :: ALens' s Bool -> t + +-- | Listener for the validation status of a field using an event handler. +class CmbValidInputV t e | t -> e where + validInputV :: (Bool -> e) -> t + +-- | Defines whether a widget selects all its content when receiving focus. +class CmbSelectOnFocus t where + selectOnFocus :: t + selectOnFocus = selectOnFocus_ True + selectOnFocus_ :: Bool -> t + +-- | Defines whether a widget changes its size when the model changes. +class CmbResizeOnChange t where + resizeOnChange :: t + resizeOnChange = resizeOnChange_ True + resizeOnChange_ :: Bool -> t + +-- | Defines whether animation should start automatically. +class CmbAutoStart t where + autoStart :: t + autoStart = autoStart_ True + autoStart_ :: Bool -> t + +-- | Defines the animation length. +class CmbDuration t a | t -> a where + duration :: a -> t + +-- | Title caption of a widget, usually a dialog. +class CmbTitleCaption t where + titleCaption :: Text -> t + +-- | Accept caption of a widget, usually a button. +class CmbAcceptCaption t where + acceptCaption :: Text -> t + +-- | Cancel caption of a widget, usually a button. +class CmbCancelCaption t where + cancelCaption :: Text -> t + +-- | Close caption of a widget, usually a button. +class CmbCloseCaption t where + closeCaption :: Text -> t + +-- | Minimum value of a widget, usually numeric. +class CmbMinValue t a | t -> a where + minValue :: a -> t + +-- | Maximum value of a widget, usually numeric. +class CmbMaxValue t a | t -> a where + maxValue :: a -> t + +-- | Drag rate of a widget, usually numeric. +class CmbDragRate t a | t -> a where + dragRate :: a -> t + +-- | Wheel rate of a widget, usually numeric or scrollable. +class CmbWheelRate t a | t -> a where + wheelRate :: a -> t + +-- | Whether to ignore pointer events where no widget exists. +class CmbIgnoreEmptyArea t where + ignoreEmptyArea :: t + ignoreEmptyArea = ignoreEmptyArea_ True + ignoreEmptyArea_ :: Bool -> t + +-- | How many decimals a numeric widget accepts. +class CmbDecimals t where + decimals :: Int -> t + +-- | Max length a widget accepts. +class CmbMaxLength t where + maxLength :: Int -> t + +-- | Max lines a widget accepts. +class CmbMaxLines t where + maxLines :: Int -> t + +-- | Whether a widget accepts tab key. +class CmbAcceptTab t where + acceptTab :: t + acceptTab = acceptTab_ True + acceptTab_ :: Bool -> t + +-- | Whether a text based widget is multiline. +class CmbMultiline t where + multiline :: t + multiline = multiline_ True + multiline_ :: Bool -> t + +-- | Whether to use ellipsis or not. +class CmbEllipsis t where + ellipsis :: t + ellipsis = ellipsis_ True + ellipsis_ :: Bool -> t + +-- | Whether to trim spaces or not. +class CmbTrimSpaces t where + trimSpaces :: t + trimSpaces = trimSpaces_ True + trimSpaces_ :: Bool -> t + +-- | Whether to automatically select a value on blur (for example, dropdown). +class CmbSelectOnBlur t where + selectOnBlur :: t + selectOnBlur = selectOnBlur_ True + selectOnBlur_ :: Bool -> t + +-- | Placeholder to use when main value is empty. +class CmbPlaceholder t a | t -> a where + placeholder :: a -> t + +-- | Width of the caret in a text widget. +class CmbCaretWidth t a | t -> a where + caretWidth :: a -> t + +-- | Blink period of the caret in a text widget. +class CmbCaretMs t a | t -> a where + caretMs :: a -> t + +-- | Text font. +class CmbTextFont t where + textFont :: Font -> t + +-- | Text size. +class CmbTextSize t where + textSize :: Double -> t + +-- | Horizontal text spacing. +class CmbTextSpaceH t where + textSpaceH :: Double -> t + +-- | Vertical text spacing. +class CmbTextSpaceV t where + textSpaceV :: Double -> t + +-- | Text color. +class CmbTextColor t where + textColor :: Color -> t + +-- | Align text to the left. +class CmbTextLeft t where + textLeft :: t + textLeft = textLeft_ True + textLeft_ :: Bool -> t + +-- | Align text to the center. +class CmbTextCenter t where + textCenter :: t + textCenter = textCenter_ True + textCenter_ :: Bool -> t + +-- | Align text to the right. +class CmbTextRight t where + textRight :: t + textRight = textRight_ True + textRight_ :: Bool -> t + +-- | Align text to the top. +class CmbTextTop t where + textTop :: t + textTop = textTop_ True + textTop_ :: Bool -> t + +-- | Align text to the vertical middle based on the line height. +class CmbTextMiddle t where + textMiddle :: t + textMiddle = textMiddle_ True + textMiddle_ :: Bool -> t + +-- | Align text to the vertical middle based on the ascender. +class CmbTextAscender t where + textAscender :: t + textAscender = textAscender_ True + textAscender_ :: Bool -> t + +-- | Align text to the vertical middle based on the x height. +class CmbTextLowerX t where + textLowerX :: t + textLowerX = textLowerX_ True + textLowerX_ :: Bool -> t + +-- | Align text to the bottom. +class CmbTextBottom t where + textBottom :: t + textBottom = textBottom_ True + textBottom_ :: Bool -> t + +-- | Align text to the baseline. +class CmbTextBaseline t where + textBaseline :: t + textBaseline = textBaseline_ True + textBaseline_ :: Bool -> t + +-- | Display a line under the text. +class CmbTextUnderline t where + textUnderline :: t + textUnderline = textUnderline_ True + textUnderline_ :: Bool -> t + +-- | Display a line above the text. +class CmbTextOverline t where + textOverline :: t + textOverline = textOverline_ True + textOverline_ :: Bool -> t + +-- | Display a line over the text. +class CmbTextThroughline t where + textThroughline :: t + textThroughline = textThroughline_ True + textThroughline_ :: Bool -> t + +-- | Does not apply any kind of resizing to fit to container. +class CmbFitNone t where + fitNone :: t + +-- | Fits to use all the container's space. +class CmbFitFill t where + fitFill :: t + +-- | Fits to use all the container's width. +class CmbFitWidth t where + fitWidth :: t + +-- | Fits to use all the container's height. +class CmbFitHeight t where + fitHeight :: t + +-- | Applies nearest filtering when stretching an image. +class CmbImageNearest t where + imageNearest :: t + +-- | Applies horizontal repetition when stretching an image. +class CmbImageRepeatX t where + imageRepeatX :: t + +-- | Applies vertical repetition when stretching an image. +class CmbImageRepeatY t where + imageRepeatY :: t + +-- | The color of a bar, for example in a scroll. +class CmbBarColor t where + barColor :: Color -> t + +-- | The hover color of a bar, for example in a scroll. +class CmbBarHoverColor t where + barHoverColor :: Color -> t + +-- | The width of a bar, for example in a scroll. +class CmbBarWidth t where + barWidth :: Double -> t + +-- | The color of a thumb, for example in a scroll. +class CmbThumbColor t where + thumbColor :: Color -> t + +-- | The hover color of a thumb, for example in a scroll. +class CmbThumbHoverColor t where + thumbHoverColor :: Color -> t + +{-| +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 + +-- | The radius of a thumb's rect, for example in a scroll. +class CmbThumbRadius t where + thumbRadius :: Double -> t + +-- | Whether the thumb is visible, for example in a scroll. +class CmbThumbVisible t where + thumbVisible :: t + thumbVisible = thumbVisible_ True + thumbVisible_ :: Bool -> t + +-- | The width color of a thumb, for example in a scroll. +class CmbThumbWidth t where + thumbWidth :: 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. +class CmbIgnoreChildrenEvts t where + ignoreChildrenEvts :: t + ignoreChildrenEvts = ignoreChildrenEvts_ True + ignoreChildrenEvts_ :: Bool -> t + +-- | On init event. +class CmbOnInit t e | t -> e where + onInit :: e -> t + +-- | On dispose event. +class CmbOnDispose t e | t -> e where + onDispose :: e -> t + +-- | On resize event. +class CmbOnResize t e a | t -> e a where + onResize :: (a -> e) -> t + +-- | On focus event. +class CmbOnFocus t e a | t -> e a where + onFocus :: (a -> e) -> t + +-- | On focus WidgetRequest. +class CmbOnFocusReq t s e a | t -> s e a where + onFocusReq :: (a -> WidgetRequest s e) -> t + +-- | On blur event. +class CmbOnBlur t e a | t -> e a where + onBlur :: (a -> e) -> t + +-- | On blur WidgetRequest. +class CmbOnBlurReq t s e a | t -> s e a where + onBlurReq :: (a -> WidgetRequest s e) -> t + +-- | On enter event. +class CmbOnEnter t e | t -> e where + onEnter :: e -> t + +-- | On enter WidgetRequest. +class CmbOnEnterReq t s e | t -> s e where + onEnterReq :: WidgetRequest s e -> t + +-- | On leave event. +class CmbOnLeave t e | t -> e where + onLeave :: e -> t + +-- | On leave WidgetRequest. +class CmbOnLeaveReq t s e | t -> s e where + onLeaveReq :: WidgetRequest s e -> t + +-- | On click event. +class CmbOnClick t e | t -> e where + onClick :: e -> t + +-- | On click WidgetRequest. +class CmbOnClickReq t s e | t -> s e where + onClickReq :: WidgetRequest s e -> t + +-- | On click empty event, where supported (box, for example). +class CmbOnClickEmpty t e | t -> e where + onClickEmpty :: e -> t + +-- | On click empty WidgetRequest, where supported (box, for example). +class CmbOnClickEmptyReq t s e | t -> s e where + onClickEmptyReq :: WidgetRequest s e -> t + +-- | On button pressed event. +class CmbOnBtnPressed t e | t -> e where + onBtnPressed :: (Button -> Int -> e) -> t + +-- | On button pressed WidgetRequest. +class CmbOnBtnPressedReq t s e | t -> s e where + onBtnPressedReq :: (Button -> Int -> WidgetRequest s e) -> t + +-- | On button released event. +class CmbOnBtnReleased t e | t -> e where + onBtnReleased :: (Button -> Int -> e) -> t + +-- | On button released WidgetRequest. +class CmbOnBtnReleasedReq t s e | t -> s e where + onBtnReleasedReq :: (Button -> Int -> WidgetRequest s e) -> t + +-- | On enabled change event. +class CmbOnEnabledChange t e | t -> e where + onEnabledChange :: e -> t + +-- | On visible change event. +class CmbOnVisibleChange t e | t -> e where + onVisibleChange :: e -> t + +-- | On change event. +class CmbOnChange t a e | t -> e where + onChange :: (a -> e) -> t + +-- | On change event, including index. +class CmbOnChangeIdx t e a | t -> e a where + onChangeIdx :: (Int -> a -> e) -> t + +-- | On change WidgetRequest. +class CmbOnChangeReq t s e a | t -> s e a where + onChangeReq :: (a -> WidgetRequest s e) -> t + +-- | On change WidgetRequest, including index. +class CmbOnChangeIdxReq t s e a | t -> s e a where + onChangeIdxReq :: (Int -> a -> WidgetRequest s e) -> t + +-- | On load error event. +class CmbOnLoadError t e a | t -> e a where + onLoadError :: (a -> e) -> t + +-- | On finished event. +class CmbOnFinished t e | t -> e where + onFinished :: e -> t + +-- | Width combinator. +class CmbWidth t where + width :: Double -> t + +-- | Height combinator. +class CmbHeight t where + height :: Double -> t + +-- | Flex width combinator. +class CmbFlexWidth t where + flexWidth :: Double -> t + +-- | Flex height combinator. +class CmbFlexHeight t where + flexHeight :: Double -> t + +-- | Min width combinator. +class CmbMinWidth t where + minWidth :: Double -> t + +-- | Min height combinator. +class CmbMinHeight t where + minHeight :: Double -> t + +-- | Max width combinator. +class CmbMaxWidth t where + maxWidth :: Double -> t + +-- | Max height combinator. +class CmbMaxHeight t where + maxHeight :: Double -> t + +-- | Expand width combinator. +class CmbExpandWidth t where + expandWidth :: Double -> t + +-- | Expand height combinator. +class CmbExpandHeight t where + expandHeight :: Double -> t + +-- | Range width combinator. +class CmbRangeWidth t where + rangeWidth :: Double -> Double -> t + +-- | Range height combinator. +class CmbRangeHeight t where + rangeHeight :: Double -> Double -> t + +-- | Custom SizeReq width combinator. +class CmbSizeReqW t where + sizeReqW :: SizeReq -> t + +-- | Custom SizeReq height combinator. +class CmbSizeReqH t where + sizeReqH :: SizeReq -> t + +-- | SizeReq updater. Useful to make modifications to widget SizeReqs without +-- | completely overriding them. +class CmbSizeReqUpdater t where + sizeReqUpdater :: ((SizeReq, SizeReq) -> (SizeReq, SizeReq)) -> t + +-- | Resize factor combinator. +class CmbResizeFactor t where + resizeFactor :: Double -> t + +-- | Resize factor combinator for individual w and h components. +class CmbResizeFactorDim t where + resizeFactorW :: Double -> t + resizeFactorH :: Double -> t + +-- Style +infixl 5 `styleBasic` +infixl 5 `styleHover` +infixl 5 `styleFocus` +infixl 5 `styleFocusHover` +infixl 5 `styleActive` +infixl 5 `styleDisabled` + +-- | Basic style combinator, used mainly infix for widgets as a list. +class CmbStyleBasic t where + styleBasic :: t -> [StyleState] -> t + +-- | Hover style combinator, used mainly infix for widgets as a list. +class CmbStyleHover t where + styleHover :: t -> [StyleState] -> t + +-- | Focus style combinator, used mainly infix for widgets as a list. +class CmbStyleFocus t where + styleFocus :: t -> [StyleState] -> t + +-- | Focus Hover style combinator, used mainly infix for widgets as a list. +class CmbStyleFocusHover t where + styleFocusHover :: t -> [StyleState] -> t + +-- | Active style combinator, used mainly infix for widgets as a list. +class CmbStyleActive t where + styleActive :: t -> [StyleState] -> t + +-- | Disabled style combinator, used mainly infix for widgets as a list. +class CmbStyleDisabled t where + styleDisabled :: t -> [StyleState] -> t + +-- | Ignore theme settings and start with blank style. +class CmbIgnoreTheme t where + ignoreTheme :: t + ignoreTheme = ignoreTheme_ True + ignoreTheme_ :: Bool -> t + +-- | Background color. +class CmbBgColor t where + bgColor :: Color -> t + +-- | Foreground color. +class CmbFgColor t where + fgColor :: Color -> t + +-- | Secondary color. +class CmbSndColor t where + sndColor :: Color -> t + +-- | Highlight color. +class CmbHlColor t where + hlColor :: Color -> t + +-- | Transparency level. +class CmbTransparency t where + transparency :: Double -> t + +-- | Cursor icons. +class CmbCursorIcon t where + cursorArrow :: t + cursorArrow = cursorIcon CursorArrow + cursorHand :: t + cursorHand = cursorIcon CursorHand + cursorIBeam :: t + cursorIBeam = cursorIcon CursorIBeam + cursorInvalid :: t + cursorInvalid = cursorIcon CursorInvalid + cursorSizeH :: t + cursorSizeH = cursorIcon CursorSizeH + cursorSizeV :: t + cursorSizeV = cursorIcon CursorSizeV + cursorDiagTL :: t + cursorDiagTL = cursorIcon CursorDiagTL + cursorDiagTR :: t + cursorDiagTR = cursorIcon CursorDiagTR + cursorIcon :: CursorIcon -> t + +-- | Basic style for each item of a list. +class CmbItemBasicStyle t s | t -> s where + itemBasicStyle :: s -> t + +-- | Hover style for an item of a list. +class CmbItemHoverStyle t s | t -> s where + itemHoverStyle :: s -> t + +-- | Selected style for an item of a list. +class CmbItemSelectedStyle t s | t -> s where + itemSelectedStyle :: s -> t + +-- | Align object to the left (not text). +class CmbAlignLeft t where + alignLeft :: t + alignLeft = alignLeft_ True + alignLeft_ :: Bool -> t + +-- | Align object to the center (not text). +class CmbAlignCenter t where + alignCenter :: t + alignCenter = alignCenter_ True + alignCenter_ :: Bool -> t + +-- | Align object to the right (not text). +class CmbAlignRight t where + alignRight :: t + alignRight = alignRight_ True + alignRight_ :: Bool -> t + +-- | Align object to the top (not text). +class CmbAlignTop t where + alignTop :: t + alignTop = alignTop_ True + alignTop_ :: Bool -> t + +-- | Align object to the middle (not text). +class CmbAlignMiddle t where + alignMiddle :: t + alignMiddle = alignMiddle_ True + alignMiddle_ :: Bool -> t + +-- | Align object to the bottom (not text). +class CmbAlignBottom t where + alignBottom :: t + alignBottom = alignBottom_ True + alignBottom_ :: Bool -> t + +-- | Set padding to the same size on all sides. +class CmbPadding t where + padding :: Double -> t + +-- | Set padding for the left side. +class CmbPaddingL t where + paddingL :: Double -> t + +-- | Set padding for the right side. +class CmbPaddingR t where + paddingR :: Double -> t + +-- | Set padding for the top side. +class CmbPaddingT t where + paddingT :: Double -> t + +-- | Set padding for the bottom side. +class CmbPaddingB t where + paddingB :: Double -> t + +-- | Set border to the same style on all sides. +class CmbBorder t where + border :: Double -> Color -> t + +-- | Set border for the left side. +class CmbBorderL t where + borderL :: Double -> Color -> t + +-- | Set border for the right side. +class CmbBorderR t where + borderR :: Double -> Color -> t + +-- | Set border for the top side. +class CmbBorderT t where + borderT :: Double -> Color -> t + +-- | Set border for the bottom side. +class CmbBorderB t where + borderB :: Double -> Color -> t + +-- | Set radius to the same size on all corners. +class CmbRadius t where + radius :: Double -> t + +-- | Set radius for the top left corner. +class CmbRadiusTL t where + radiusTL :: Double -> t + +-- | Set radius for the top right corner. +class CmbRadiusTR t where + radiusTR :: Double -> t + +-- | Set radius for the bottom left corner. +class CmbRadiusBL t where + radiusBL :: Double -> t + +-- | Set radius for the bottom right corner. +class CmbRadiusBR t where + radiusBR :: Double -> t diff --git a/src/Monomer/Core/FromFractional.hs b/src/Monomer/Core/FromFractional.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/FromFractional.hs @@ -0,0 +1,82 @@ +{-| +Module : Monomer.Core.FromFractional +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Conversions from Fractional to several types. Used by dial, numericField, +slider and other numeric related widgets. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Core.FromFractional ( + FromFractional(..) +) where + +import Data.Int +import Data.Fixed +import Data.Word +import Foreign.C.Types + +fractionalToIntegral :: (Integral a, Real b, Fractional b) => b -> a +fractionalToIntegral num = round newNum where + newNum :: Rational + newNum = realToFrac num + +-- | Converts a Fractional number to the target type. +class Real a => FromFractional a where + fromFractional :: (Real b, Fractional b) => b -> a + +instance FromFractional Integer where + fromFractional = fractionalToIntegral + +instance FromFractional Int where + fromFractional = fractionalToIntegral + +instance FromFractional Int8 where + fromFractional = fractionalToIntegral + +instance FromFractional Int16 where + fromFractional = fractionalToIntegral + +instance FromFractional Int32 where + fromFractional = fractionalToIntegral + +instance FromFractional Int64 where + fromFractional = fractionalToIntegral + +instance FromFractional Word where + fromFractional = fractionalToIntegral + +instance FromFractional Word8 where + fromFractional = fractionalToIntegral + +instance FromFractional Word16 where + fromFractional = fractionalToIntegral + +instance FromFractional Word32 where + fromFractional = fractionalToIntegral + +instance FromFractional Word64 where + fromFractional = fractionalToIntegral + +instance FromFractional Float where + fromFractional = realToFrac + +instance FromFractional Double where + fromFractional = realToFrac + +instance FromFractional CFloat where + fromFractional = realToFrac + +instance FromFractional CDouble where + fromFractional = realToFrac + +instance FromFractional Rational where + fromFractional = realToFrac + +instance HasResolution a => FromFractional (Fixed a) where + fromFractional = realToFrac diff --git a/src/Monomer/Core/Lens.hs b/src/Monomer/Core/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/Lens.hs @@ -0,0 +1,48 @@ +{-| +Module : Monomer.Core.Lens +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Lenses for the Core types. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Core.Lens where + +import Control.Lens.TH (abbreviatedFields, makeLensesWith, makePrisms) + +import Monomer.Common.Lens +import Monomer.Core.StyleTypes +import Monomer.Core.ThemeTypes +import Monomer.Core.WidgetTypes + +-- Style +makeLensesWith abbreviatedFields ''SizeReq +makeLensesWith abbreviatedFields ''Padding +makeLensesWith abbreviatedFields ''BorderSide +makeLensesWith abbreviatedFields ''Border +makeLensesWith abbreviatedFields ''Radius +makeLensesWith abbreviatedFields ''RadiusCorner +makeLensesWith abbreviatedFields ''TextStyle +makeLensesWith abbreviatedFields ''StyleState +makeLensesWith abbreviatedFields ''Style +makeLensesWith abbreviatedFields ''ThemeState +makeLensesWith abbreviatedFields ''Theme + +-- Widget +makePrisms ''WidgetKey +makePrisms ''WidgetData +makePrisms ''WidgetType +makeLensesWith abbreviatedFields ''WidgetEnv +makeLensesWith abbreviatedFields ''WidgetRequest +makeLensesWith abbreviatedFields ''WidgetResult +makeLensesWith abbreviatedFields ''WidgetData +makeLensesWith abbreviatedFields ''WidgetId +makeLensesWith abbreviatedFields ''WidgetNode +makeLensesWith abbreviatedFields ''WidgetNodeInfo +makeLensesWith abbreviatedFields ''WidgetInstanceNode diff --git a/src/Monomer/Core/SizeReq.hs b/src/Monomer/Core/SizeReq.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/SizeReq.hs @@ -0,0 +1,157 @@ +{-| +Module : Monomer.Core.SizeReq +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions creating, validating and merging size requirements. +-} +module Monomer.Core.SizeReq ( + SizeReqUpdater(..), + clearExtra, + sizeReqBounded, + sizeReqValid, + sizeReqAddStyle, + sizeReqMin, + sizeReqMax, + sizeReqMaxBounded, + sizeReqFixed, + sizeReqFlex, + sizeReqExtra, + sizeReqFactor, + sizeReqMergeSum, + sizeReqMergeMax +) where + +import Control.Lens ((&), (^.), (.~)) +import Data.Bits +import Data.Default +import Data.Maybe + +import Monomer.Common +import Monomer.Core.StyleTypes +import Monomer.Core.StyleUtil +import Monomer.Core.Util +import Monomer.Helper + +import qualified Monomer.Core.Lens as L + +-- | Transforms a SizeReq pair by applying an arbitrary operation. +type SizeReqUpdater = (SizeReq, SizeReq) -> (SizeReq, SizeReq) + +-- | Clears the extra field of a SizeReq. +clearExtra :: SizeReqUpdater +clearExtra (req1, req2) = (req1 & L.extra .~ 0, req2 & L.extra .~ 0) + +-- | Returns a bounded value by the SizeReq, starting from value and offset. +sizeReqBounded :: SizeReq -> Double -> Double -> Double +sizeReqBounded sizeReq offset value = max minSize (min maxSize value) where + minSize = offset + sizeReqMin sizeReq + maxSize = offset + sizeReqMax sizeReq + +-- | Checks that value, given an offset, matches a SizeReq. +sizeReqValid :: SizeReq -> Double -> Double -> Bool +sizeReqValid sizeReq offset value = doubleInRange minSize maxSize value where + minSize = offset + sizeReqMin sizeReq + maxSize = offset + sizeReqMax sizeReq + +-- | Adds border/padding size to a SizeReq pair. +sizeReqAddStyle :: StyleState -> (SizeReq, SizeReq) -> (SizeReq, SizeReq) +sizeReqAddStyle style (reqW, reqH) = (newReqW, newReqH) where + Size w h = fromMaybe def (addOuterSize style def) + realReqW = fromMaybe reqW (_sstSizeReqW style) + realReqH = fromMaybe reqH (_sstSizeReqH style) + newReqW = modifySizeReq realReqW (+w) + newReqH = modifySizeReq realReqH (+h) + +-- | Returns the minimum valid value for a SizeReq. +sizeReqMin :: SizeReq -> Double +sizeReqMin req = req ^. L.fixed + +-- | Returns the maximum valid value for a SizeReq. This can be unbounded if +-- | extra field is not zero. +sizeReqMax :: SizeReq -> Double +sizeReqMax req + | req ^. L.extra > 0 = maxNumericValue + | otherwise = req ^. L.fixed + req ^. L.flex + +-- | Returns the maximum, bounded, valid value for a SizeReq. Extra is ignored. +sizeReqMaxBounded :: SizeReq -> Double +sizeReqMaxBounded req = req ^. L.fixed + req ^. L.flex + +-- | Returns the fixed size of a SizeReq. +sizeReqFixed :: SizeReq -> Double +sizeReqFixed req = req ^. L.fixed + +-- | Returns the flex size of a SizeReq. +sizeReqFlex :: SizeReq -> Double +sizeReqFlex req = req ^. L.flex + +-- | Returns the extra size of a SizeReq. +sizeReqExtra :: SizeReq -> Double +sizeReqExtra req = req ^. L.extra + +-- | Returns the resize factor of a SizeReq. +sizeReqFactor :: SizeReq -> Double +sizeReqFactor req = req ^. L.factor + +{-| +Sums two SizeReqs. This is used for combining two widgets one after the other, +/summing/ their sizes. + +The fixed, flex and extra fields are summed individually, while the max factor +is kept. +-} +sizeReqMergeSum :: SizeReq -> SizeReq -> SizeReq +sizeReqMergeSum req1 req2 = newReq where + newReq = SizeReq { + _szrFixed = _szrFixed req1 + _szrFixed req2, + _szrFlex = _szrFlex req1 + _szrFlex req2, + _szrExtra = _szrExtra req1 + _szrExtra req2, + _szrFactor = max (_szrFactor req1) (_szrFactor req2) + } + +{-| +Merges two SizeReqs. This is used for combining two widgets by keeping the +largest size requirement. + +Fields are combined in order to first satisfy fixed requirements, adapting flex +if one of the fixed provided more space than required. For both extra and factor +the largest value is kept. +-} +sizeReqMergeMax :: SizeReq -> SizeReq -> SizeReq +sizeReqMergeMax req1 req2 = newReq where + isFixedReq1 = round (req1 ^. L.fixed) > 0 + isFixedReq2 = round (req2 ^. L.fixed) > 0 + flexReq1 = req1 ^. L.flex + flexReq2 = req2 ^. L.flex + newFixed = max (req1 ^. L.fixed) (req2 ^. L.fixed) + newFlex + | not (isFixedReq1 `xor` isFixedReq2) = max flexReq1 flexReq2 + | isFixedReq1 && flexReq1 > flexReq2 = flexReq1 + | isFixedReq2 && flexReq2 > flexReq1 = flexReq2 + | otherwise = max 0 $ max flexReq1 flexReq2 - newFixed + newReq = SizeReq { + _szrFixed = newFixed, + _szrFlex = newFlex, + _szrExtra = max (req1 ^. L.extra) (req2 ^. L.extra), + _szrFactor = max (req1 ^. L.factor) (req2 ^. L.factor) + } + +modifySizeReq :: SizeReq -> (Double -> Double) -> SizeReq +modifySizeReq (SizeReq fixed flex extra factor) fn = SizeReq { + _szrFixed = if fixed > 0 then fn fixed else 0, + _szrFlex = if flex > 0 then fn flex else 0, + _szrExtra = if extra > 0 then fn extra else 0, + _szrFactor = factor + } + +doubleInRange :: Double -> Double -> Double -> Bool +doubleInRange minValue maxValue curValue = validMin && validMax where + minDiff = curValue - minValue + maxDiff = maxValue - curValue + -- Some calculations may leave small differences in otherwise valid results + validMin = minDiff >= 0 || abs minDiff < 0.0001 + validMax = maxDiff >= 0 || abs maxDiff < 0.0001 diff --git a/src/Monomer/Core/Style.hs b/src/Monomer/Core/Style.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/Style.hs @@ -0,0 +1,425 @@ +{-| +Module : Monomer.Core.Style +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for creating style configurations, and corresponding instances. +-} +module Monomer.Core.Style ( + module Monomer.Core.StyleTypes, + module Monomer.Core.ThemeTypes, + paddingH, + paddingV, + fixedSize, + flexSize, + expandSize, + minSize, + maxSize, + rangeSize +) where + +import Control.Lens ((&), (.~), (?~), non) +import Data.Default + +import Monomer.Core.Combinators +import Monomer.Core.StyleTypes +import Monomer.Core.ThemeTypes +import Monomer.Graphics.Types + +import qualified Monomer.Core.Lens as L + +-- | Creates an equally sized padding left and right. +paddingH :: (Semigroup a, CmbPaddingL a, CmbPaddingR a) => Double -> a +paddingH p = paddingL p <> paddingR p + +-- | Creates an equally sized padding top and bottom. +paddingV :: (Semigroup a, CmbPaddingT a, CmbPaddingB a) => Double -> a +paddingV p = paddingT p <> paddingB p + +-- | Creates a SizeReq with fixed size. +fixedSize :: Double -> SizeReq +fixedSize s = def + & L.fixed .~ s + +-- | Creates a SizeReq with flex size. +flexSize :: Double -> Double -> SizeReq +flexSize s f = def + & L.flex .~ s + & L.factor .~ f + +-- | Creates a SizeReq with expand size. +expandSize :: Double -> Double -> SizeReq +expandSize s f = def + & L.flex .~ s + & L.extra .~ s + & L.factor .~ f + +-- | Creates a SizeReq with equal fixed and extra size, using the given factor. +minSize :: Double -> Double -> SizeReq +minSize s f = def + & L.fixed .~ s + & L.extra .~ s + & L.factor .~ f + +-- | Creates a SizeReq with flex size, using the given factor. +maxSize :: Double -> Double -> SizeReq +maxSize s f = def + & L.flex .~ s + & L.factor .~ f + +-- | Creates a SizeReq with fixed and flex size, using the given factor. +rangeSize :: Double -> Double -> Double -> SizeReq +rangeSize s1 s2 f = def + & L.fixed .~ s1 + & L.flex .~ s2 - s1 + & L.factor .~ f + +-- Size +instance CmbWidth SizeReq where + width w = fixedSize w + +instance CmbHeight SizeReq where + height h = fixedSize h + +instance CmbFlexWidth SizeReq where + flexWidth w = expandSize w 1 + +instance CmbFlexHeight SizeReq where + flexHeight h = expandSize h 1 + +instance CmbMinWidth SizeReq where + minWidth w = minSize w 1 + +instance CmbMinHeight SizeReq where + minHeight h = minSize h 1 + +instance CmbMaxWidth SizeReq where + maxWidth w = maxSize w 1 + +instance CmbMaxHeight SizeReq where + maxHeight h = maxSize h 1 + +instance CmbExpandWidth SizeReq where + expandWidth w = expandSize w 1 + +instance CmbExpandHeight SizeReq where + expandHeight h = expandSize h 1 + +instance CmbRangeWidth SizeReq where + rangeWidth w1 w2 = rangeSize w1 w2 1 + +instance CmbRangeHeight SizeReq where + rangeHeight h1 h2 = rangeSize h1 h2 1 + +-- Text +instance CmbTextFont TextStyle where + textFont font = def & L.font ?~ font + +instance CmbTextSize TextStyle where + textSize size = def & L.fontSize ?~ FontSize size + +instance CmbTextSpaceH TextStyle where + textSpaceH space = def & L.fontSpaceH ?~ FontSpace space + +instance CmbTextSpaceV TextStyle where + textSpaceV space = def & L.fontSpaceV ?~ FontSpace space + +instance CmbTextColor TextStyle where + textColor col = def & L.fontColor ?~ col + +instance CmbTextLeft TextStyle where + textLeft_ False = def + textLeft_ True = textAlignH ATLeft + +instance CmbTextCenter TextStyle where + textCenter_ False = def + textCenter_ True = textAlignH ATCenter + +instance CmbTextRight TextStyle where + textRight_ False = def + textRight_ True = textAlignH ATRight + +instance CmbTextTop TextStyle where + textTop_ False = def + textTop_ True = textAlignV ATTop + +instance CmbTextMiddle TextStyle where + textMiddle_ False = def + textMiddle_ True = textAlignV ATMiddle + +instance CmbTextAscender TextStyle where + textAscender_ False = def + textAscender_ True = textAlignV ATAscender + +instance CmbTextLowerX TextStyle where + textLowerX_ False = def + textLowerX_ True = textAlignV ATLowerX + +instance CmbTextBottom TextStyle where + textBottom_ False = def + textBottom_ True = textAlignV ATBottom + +instance CmbTextBaseline TextStyle where + textBaseline_ False = def + textBaseline_ True = textAlignV ATBaseline + +instance CmbTextUnderline TextStyle where + textUnderline_ under = def & L.underline ?~ under + +instance CmbTextOverline TextStyle where + textOverline_ over = def & L.overline ?~ over + +instance CmbTextThroughline TextStyle where + textThroughline_ through = def & L.throughline ?~ through + +-- Padding + +instance CmbPadding Padding where + padding padd = Padding jp jp jp jp where + jp = Just padd + +instance CmbPaddingL Padding where + paddingL padd = def & L.left ?~ padd + +instance CmbPaddingR Padding where + paddingR padd = def & L.right ?~ padd + +instance CmbPaddingT Padding where + paddingT padd = def & L.top ?~ padd + +instance CmbPaddingB Padding where + paddingB padd = def & L.bottom ?~ padd + +-- Border + +instance CmbBorder Border where + border w col = Border bs bs bs bs where + bs = Just (BorderSide w col) + +instance CmbBorderL Border where + borderL w col = def & L.left ?~ BorderSide w col + +instance CmbBorderR Border where + borderR w col = def & L.right ?~ BorderSide w col + +instance CmbBorderT Border where + borderT w col = def & L.top ?~ BorderSide w col + +instance CmbBorderB Border where + borderB w col = def & L.bottom ?~ BorderSide w col + +-- Radius + +instance CmbRadius Radius where + radius rad = Radius jrad jrad jrad jrad where + jrad = Just $ radiusCorner rad + +instance CmbRadiusTL Radius where + radiusTL rad = def & L.topLeft ?~ radiusCorner rad + +instance CmbRadiusTR Radius where + radiusTR rad = def & L.topRight ?~ radiusCorner rad + +instance CmbRadiusBL Radius where + radiusBL rad = def & L.bottomLeft ?~ radiusCorner rad + +instance CmbRadiusBR Radius where + radiusBR rad = def & L.bottomRight ?~ radiusCorner rad + +-- +-- StyleState instances +-- + +-- Size +instance CmbWidth StyleState where + width w = def & L.sizeReqW ?~ width w + +instance CmbHeight StyleState where + height h = def & L.sizeReqH ?~ height h + +instance CmbFlexWidth StyleState where + flexWidth w = def & L.sizeReqW ?~ flexWidth w + +instance CmbFlexHeight StyleState where + flexHeight h = def & L.sizeReqH ?~ flexHeight h + +instance CmbMinWidth StyleState where + minWidth w = def & L.sizeReqW ?~ minWidth w + +instance CmbMinHeight StyleState where + minHeight h = def & L.sizeReqH ?~ minHeight h + +instance CmbMaxWidth StyleState where + maxWidth w = def & L.sizeReqW ?~ maxWidth w + +instance CmbMaxHeight StyleState where + maxHeight h = def & L.sizeReqH ?~ maxHeight h + +instance CmbExpandWidth StyleState where + expandWidth w = def & L.sizeReqW ?~ expandWidth w + +instance CmbExpandHeight StyleState where + expandHeight h = def & L.sizeReqH ?~ expandHeight h + +instance CmbRangeWidth StyleState where + rangeWidth w1 w2 = def & L.sizeReqW ?~ rangeWidth w1 w2 + +instance CmbRangeHeight StyleState where + rangeHeight h1 h2 = def & L.sizeReqH ?~ rangeHeight h1 h2 + +instance CmbSizeReqW StyleState where + sizeReqW srW = def & L.sizeReqW ?~ srW + +instance CmbSizeReqH StyleState where + sizeReqH srH = def & L.sizeReqH ?~ srH + +-- Color + +instance CmbBgColor StyleState where + bgColor col = def & L.bgColor ?~ col + +instance CmbFgColor StyleState where + fgColor col = def & L.fgColor ?~ col + +instance CmbSndColor StyleState where + sndColor col = def & L.sndColor ?~ col + +instance CmbHlColor StyleState where + hlColor col = def & L.hlColor ?~ col + +-- Cursor + +instance CmbCursorIcon StyleState where + cursorIcon icon = def & L.cursorIcon ?~ icon + +-- Text +instance CmbTextFont StyleState where + textFont font = def & L.text ?~ textFont font + +instance CmbTextSize StyleState where + textSize size = def & L.text ?~ textSize size + +instance CmbTextSpaceH StyleState where + textSpaceH space = def & L.text ?~ textSpaceH space + +instance CmbTextSpaceV StyleState where + textSpaceV space = def & L.text ?~ textSpaceV space + +instance CmbTextColor StyleState where + textColor col = def & L.text ?~ textColor col + +instance CmbTextLeft StyleState where + textLeft_ False = def + textLeft_ True = styleTextAlignH ATLeft + +instance CmbTextCenter StyleState where + textCenter_ False = def + textCenter_ True = styleTextAlignH ATCenter + +instance CmbTextRight StyleState where + textRight_ False = def + textRight_ True = styleTextAlignH ATRight + +instance CmbTextTop StyleState where + textTop_ False = def + textTop_ True = styleTextAlignV ATTop + +instance CmbTextMiddle StyleState where + textMiddle_ False = def + textMiddle_ True = styleTextAlignV ATMiddle + +instance CmbTextAscender StyleState where + textAscender_ False = def + textAscender_ True = styleTextAlignV ATAscender + +instance CmbTextLowerX StyleState where + textLowerX_ False = def + textLowerX_ True = styleTextAlignV ATLowerX + +instance CmbTextBottom StyleState where + textBottom_ False = def + textBottom_ True = styleTextAlignV ATBottom + +instance CmbTextBaseline StyleState where + textBaseline_ False = def + textBaseline_ True = styleTextAlignV ATBaseline + +instance CmbTextUnderline StyleState where + textUnderline_ False = def + textUnderline_ True = def & L.text ?~ textUnderline + +instance CmbTextOverline StyleState where + textOverline_ False = def + textOverline_ True = def & L.text ?~ textOverline + +instance CmbTextThroughline StyleState where + textThroughline_ False = def + textThroughline_ True = def & L.text ?~ textThroughline + +-- Padding +instance CmbPadding StyleState where + padding padd = def & L.padding ?~ padding padd + +instance CmbPaddingL StyleState where + paddingL padd = def & L.padding . non def . L.left ?~ padd + +instance CmbPaddingR StyleState where + paddingR padd = def & L.padding . non def . L.right ?~ padd + +instance CmbPaddingT StyleState where + paddingT padd = def & L.padding . non def . L.top ?~ padd + +instance CmbPaddingB StyleState where + paddingB padd = def & L.padding . non def . L.bottom ?~ padd + +-- Border +instance CmbBorder StyleState where + border w col = def & L.border ?~ border w col + +instance CmbBorderL StyleState where + borderL w col = def & L.border . non def . L.left ?~ BorderSide w col + +instance CmbBorderR StyleState where + borderR w col = def & L.border . non def . L.right ?~ BorderSide w col + +instance CmbBorderT StyleState where + borderT w col = def & L.border . non def . L.top ?~ BorderSide w col + +instance CmbBorderB StyleState where + borderB w col = def & L.border . non def . L.bottom ?~ BorderSide w col + +-- Radius +instance CmbRadius StyleState where + radius rad = def & L.radius ?~ radius rad + +instance CmbRadiusTL StyleState where + radiusTL rad = def & L.radius . non def . L.topLeft ?~ radiusCorner rad + +instance CmbRadiusTR StyleState where + radiusTR rad = def & L.radius . non def . L.topRight ?~ radiusCorner rad + +instance CmbRadiusBL StyleState where + radiusBL rad = def & L.radius . non def . L.bottomLeft ?~ radiusCorner rad + +instance CmbRadiusBR StyleState where + radiusBR rad = def & L.radius . non def . L.bottomRight ?~ radiusCorner rad + +-- Internal + +radiusCorner :: Double -> RadiusCorner +radiusCorner rad = RadiusCorner rad + +textAlignH :: AlignTH -> TextStyle +textAlignH align = def & L.alignH ?~ align + +textAlignV :: AlignTV -> TextStyle +textAlignV align = def & L.alignV ?~ align + +styleTextAlignH :: AlignTH -> StyleState +styleTextAlignH align = def & L.text . non def . L.alignH ?~ align + +styleTextAlignV :: AlignTV -> StyleState +styleTextAlignV align = def & L.text . non def . L.alignV ?~ align diff --git a/src/Monomer/Core/StyleTypes.hs b/src/Monomer/Core/StyleTypes.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/StyleTypes.hs @@ -0,0 +1,351 @@ +{-| +Module : Monomer.Core.StyleTypes +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Basic types for styling widgets. +-} +{-# LANGUAGE DeriveGeneric #-} + +module Monomer.Core.StyleTypes where + +import Control.Applicative ((<|>)) +import Data.Default +import GHC.Generics + +import Monomer.Common +import Monomer.Graphics.Types +import Monomer.Graphics.Util + +{-| +Represents a size requirement for a specific axis. Mainly used by stack and box, +with grid using it as the base for its calculations. Each field represents: + +- Fixed: A minimum size required by the widget. This type of space is the first +that gets assigned. +- Flex: Additional space the widget accepts, up to the provided value. After +fixed requirements are satisfied, flex sizes are assigned proportionally +considering factor. +- Extra: After flex is satisfied, the remaining space is distributed +proportionally, considering factor, to all non zero extra requirements. There is +no limit to how much extra space can be assigned. +- Factor: How much flex/extra space a widget will get proportionally. This also +affects how much a requirement is willing to lose: a value less than 1 can +receive less space, but gives up less too. +-} +data SizeReq = SizeReq { + _szrFixed :: Double, + _szrFlex :: Double, + _szrExtra :: Double, + _szrFactor :: Factor +} deriving (Eq, Show, Generic) + +instance Default SizeReq where + def = SizeReq { + _szrFixed = 0, + _szrFlex = 0, + _szrExtra = 0, + _szrFactor = 1 + } + +-- | Different mouse pointer types. +data CursorIcon + = CursorArrow + | CursorHand + | CursorIBeam + | CursorInvalid + | CursorSizeH + | CursorSizeV + | CursorDiagTL + | CursorDiagTR + deriving (Eq, Ord, Enum, Show, Generic) + +instance Default CursorIcon where + def = CursorArrow + +{-| +Main style type, comprised of configurations for the different states: + +- Basic: Starting state for a widget, without any kind of interaction. This +is used as the base for all other states, which override values as needed. +- Hover: The mouse pointer is on top of the current widget. +- Focus: The widget has keyboard focus. +- Focus-Hover: The widget has keyboard focus and mouse is on top. Without this +state one of Hover or Focus would take precedence and it would not be possible +to specify the desired behavior. +- Active: The mouse button is currently presed and the pointer is within the +boundaries of the widget. +- Disabled: The widget is disabled. +-} +data Style = Style { + _styleBasic :: Maybe StyleState, + _styleHover :: Maybe StyleState, + _styleFocus :: Maybe StyleState, + _styleFocusHover :: Maybe StyleState, + _styleActive :: Maybe StyleState, + _styleDisabled :: Maybe StyleState +} deriving (Eq, Show, Generic) + +instance Default Style where + def = Style { + _styleBasic = Nothing, + _styleHover = Nothing, + _styleFocus = Nothing, + _styleFocusHover = Nothing, + _styleActive = Nothing, + _styleDisabled = Nothing + } + +instance Semigroup Style where + (<>) style1 style2 = Style { + _styleBasic = _styleBasic style1 <> _styleBasic style2, + _styleHover = _styleHover style1 <> _styleHover style2, + _styleFocus = _styleFocus style1 <> _styleFocus style2, + _styleFocusHover = _styleFocusHover style1 <> _styleFocusHover style2, + _styleActive = _styleActive style1 <> _styleActive style2, + _styleDisabled = _styleDisabled style1 <> _styleDisabled style2 + } + +instance Monoid Style where + mempty = def + +{-| +Customizable style items for a specific state. All values are optional, and can +be combined with the latest values taking precedence when the previous value is +not empty. +-} +data StyleState = StyleState { + -- | User defined width req. Takes precedence over widget req. + _sstSizeReqW :: Maybe SizeReq, + -- | User defined height req. Takes precedence over widget req. + _sstSizeReqH :: Maybe SizeReq, + -- | Space between the border and the content of the widget + _sstPadding :: Maybe Padding, + -- | Border definition. + _sstBorder :: Maybe Border, + -- | Radius. Affects both border and background. + _sstRadius :: Maybe Radius, + -- | Background color. + _sstBgColor :: Maybe Color, + -- | Main foreground color. Each widget decides how it uses it. + _sstFgColor :: Maybe Color, + -- | Secondary foreground color. Each widget decides how it uses it. + _sstSndColor :: Maybe Color, + -- | Highlight color. Each widget decides how it uses it. + _sstHlColor :: Maybe Color, + -- | Text style, including font, size and color. + _sstText :: Maybe TextStyle, + -- | The assigned cursor icon to this specific state. + _sstCursorIcon :: Maybe CursorIcon +} deriving (Eq, Show, Generic) + +instance Default StyleState where + def = StyleState { + _sstSizeReqW = Nothing, + _sstSizeReqH = Nothing, + _sstPadding = Nothing, + _sstBorder = Nothing, + _sstRadius = Nothing, + _sstBgColor = Nothing, + _sstFgColor = Nothing, + _sstSndColor = Nothing, + _sstHlColor = Nothing, + _sstText = Nothing, + _sstCursorIcon = Nothing + } + +instance Semigroup StyleState where + (<>) s1 s2 = StyleState { + _sstSizeReqW = _sstSizeReqW s2 <|> _sstSizeReqW s1, + _sstSizeReqH = _sstSizeReqH s2 <|> _sstSizeReqH s1, + _sstPadding = _sstPadding s1 <> _sstPadding s2, + _sstBorder = _sstBorder s1 <> _sstBorder s2, + _sstRadius = _sstRadius s1 <> _sstRadius s2, + _sstBgColor = _sstBgColor s2 <|> _sstBgColor s1, + _sstFgColor = _sstFgColor s2 <|> _sstFgColor s1, + _sstSndColor = _sstSndColor s2 <|> _sstSndColor s1, + _sstHlColor = _sstHlColor s2 <|> _sstHlColor s1, + _sstText = _sstText s1 <> _sstText s2, + _sstCursorIcon = _sstCursorIcon s2 <|> _sstCursorIcon s1 + } + +instance Monoid StyleState where + mempty = def + +-- | Padding definitions (space between border and content) for each side. +data Padding = Padding { + _padLeft :: Maybe Double, + _padRight :: Maybe Double, + _padTop :: Maybe Double, + _padBottom :: Maybe Double +} deriving (Eq, Show, Generic) + +instance Default Padding where + def = Padding { + _padLeft = Nothing, + _padRight = Nothing, + _padTop = Nothing, + _padBottom = Nothing + } + +instance Semigroup Padding where + (<>) p1 p2 = Padding { + _padLeft = _padLeft p2 <|> _padLeft p1, + _padRight = _padRight p2 <|> _padRight p1, + _padTop = _padTop p2 <|> _padTop p1, + _padBottom = _padBottom p2 <|> _padBottom p1 + } + +instance Monoid Padding where + mempty = def + +-- | Defines width and color for a given border side. +data BorderSide = BorderSide { + _bsWidth :: Double, + _bsColor :: Color +} deriving (Eq, Show, Generic) + +instance Default BorderSide where + def = BorderSide { + _bsWidth = 0, + _bsColor = def + } + +instance Semigroup BorderSide where + (<>) b1 b2 = b2 + +instance Monoid BorderSide where + mempty = def + +-- | Border definitions for each side. +data Border = Border { + _brdLeft :: Maybe BorderSide, + _brdRight :: Maybe BorderSide, + _brdTop :: Maybe BorderSide, + _brdBottom :: Maybe BorderSide +} deriving (Eq, Show, Generic) + +instance Default Border where + def = Border { + _brdLeft = Nothing, + _brdRight = Nothing, + _brdTop = Nothing, + _brdBottom = Nothing + } + +instance Semigroup Border where + (<>) b1 b2 = Border { + _brdLeft = _brdLeft b1 <> _brdLeft b2, + _brdRight = _brdRight b1 <> _brdRight b2, + _brdTop = _brdTop b1 <> _brdTop b2, + _brdBottom = _brdBottom b1 <> _brdBottom b2 + } + +instance Monoid Border where + mempty = def + +-- | Type of corner radius. +data RadiusType + = RadiusInner + | RadiusBoth + deriving (Eq, Show, Generic) + +instance Default RadiusType where + def = RadiusBoth + +instance Semigroup RadiusType where + (<>) rc1 rc2 = rc2 + +instance Monoid RadiusType where + mempty = def + +-- | Defines radius type and width/radius for a given corner. +newtype RadiusCorner = RadiusCorner { + _rcrWidth :: Double +} deriving (Eq, Show, Generic) + +instance Default RadiusCorner where + def = RadiusCorner { + _rcrWidth = def + } + +instance Semigroup RadiusCorner where + (<>) rc1 rc2 = rc2 + +instance Monoid RadiusCorner where + mempty = def + +-- | Provides radius definitions for each corner. +data Radius = Radius { + _radTopLeft :: Maybe RadiusCorner, + _radTopRight :: Maybe RadiusCorner, + _radBottomLeft :: Maybe RadiusCorner, + _radBottomRight :: Maybe RadiusCorner +} deriving (Eq, Show, Generic) + +instance Default Radius where + def = Radius { + _radTopLeft = Nothing, + _radTopRight = Nothing, + _radBottomLeft = Nothing, + _radBottomRight = Nothing + } + +instance Semigroup Radius where + (<>) r1 r2 = Radius { + _radTopLeft = _radTopLeft r2 <|> _radTopLeft r1, + _radTopRight = _radTopRight r2 <|> _radTopRight r1, + _radBottomLeft = _radBottomLeft r2 <|> _radBottomLeft r1, + _radBottomRight = _radBottomRight r2 <|> _radBottomRight r1 + } + +instance Monoid Radius where + mempty = def + +-- | Text related definitions. +data TextStyle = TextStyle { + _txsFont :: Maybe Font, -- ^ The font type. + _txsFontSize :: Maybe FontSize, -- ^ Text size in pixels. + _txsFontSpaceH :: Maybe FontSpace, -- ^ Horizontal text spacing in pixels. + _txsFontSpaceV :: Maybe FontSpace, -- ^ Vertical text spacing in pixels. + _txsFontColor :: Maybe Color, -- ^ Text color. + _txsUnderline :: Maybe Bool, -- ^ True if underline should be displayed. + _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. +} deriving (Eq, Show, Generic) + +instance Default TextStyle where + def = TextStyle { + _txsFont = Nothing, + _txsFontSize = Nothing, + _txsFontSpaceH = Nothing, + _txsFontSpaceV = Nothing, + _txsFontColor = Nothing, + _txsUnderline = Nothing, + _txsOverline = Nothing, + _txsThroughline = Nothing, + _txsAlignH = Nothing, + _txsAlignV = Nothing + } + +instance Semigroup TextStyle where + (<>) ts1 ts2 = TextStyle { + _txsFont = _txsFont ts2 <|> _txsFont ts1, + _txsFontSize = _txsFontSize ts2 <|> _txsFontSize ts1, + _txsFontSpaceH = _txsFontSpaceH ts2 <|> _txsFontSpaceH ts1, + _txsFontSpaceV = _txsFontSpaceV ts2 <|> _txsFontSpaceV ts1, + _txsFontColor = _txsFontColor ts2 <|> _txsFontColor ts1, + _txsUnderline = _txsUnderline ts2 <|> _txsUnderline ts1, + _txsOverline = _txsOverline ts2 <|> _txsOverline ts1, + _txsThroughline = _txsThroughline ts2 <|> _txsThroughline ts1, + _txsAlignH = _txsAlignH ts2 <|> _txsAlignH ts1, + _txsAlignV = _txsAlignV ts2 <|> _txsAlignV ts1 + } + +instance Monoid TextStyle where + mempty = def diff --git a/src/Monomer/Core/StyleUtil.hs b/src/Monomer/Core/StyleUtil.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/StyleUtil.hs @@ -0,0 +1,294 @@ +{-| +Module : Monomer.Core.StyleUtil +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for style types. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Core.StyleUtil ( + getContentArea, + nodeKey, + nodeEnabled, + nodeVisible, + nodeFocusable, + styleFont, + styleFontSize, + styleFontSpaceH, + styleFontSpaceV, + styleFontColor, + styleTextAlignH, + styleTextAlignV, + styleBgColor, + styleFgColor, + styleSndColor, + styleHlColor, + getOuterSize, + addOuterSize, + addOuterBounds, + removeOuterSize, + removeOuterBounds, + addBorder, + addPadding, + subtractBorder, + subtractPadding, + subtractBorderFromRadius +) where + +import Control.Lens ((&), (^.), (^?), (.~), (+~), (%~), (?~), _Just, non) +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import Monomer.Common +import Monomer.Core.Combinators +import Monomer.Core.StyleTypes +import Monomer.Core.WidgetTypes +import Monomer.Graphics.Types +import Monomer.Helper + +import qualified Monomer.Core.Lens as L + +instance CmbStyleBasic Style where + styleBasic 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 + +instance CmbStyleFocus Style where + styleFocus 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 + +instance CmbStyleActive Style where + styleActive 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 + +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 + +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 + +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 + +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 + +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 + +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 + +infixl 5 `nodeKey` +infixl 5 `nodeEnabled` +infixl 5 `nodeVisible` +infixl 5 `nodeFocusable` + +-- | Sets the key of the given node. +nodeKey :: WidgetNode s e -> Text -> WidgetNode s e +nodeKey node key = node & L.info . L.key ?~ WidgetKey key + +-- | Sets whether the given node is enabled. +nodeEnabled :: WidgetNode s e -> Bool -> WidgetNode s e +nodeEnabled node state = node & L.info . L.enabled .~ state + +-- | Sets whether the given node is visible. +nodeVisible :: WidgetNode s e -> Bool -> WidgetNode s e +nodeVisible node visibility = node & L.info . L.visible .~ visibility + +-- | Sets whether the given node is focusable. +nodeFocusable :: WidgetNode s e -> Bool -> WidgetNode s e +nodeFocusable node isFocusable = node & L.info . L.focusable .~ isFocusable + +-- | Returns the content area (i.e., ignoring border and padding) of the node. +getContentArea :: WidgetNode s e -> StyleState -> Rect +getContentArea node style = fromMaybe def area where + area = removeOuterBounds style (node ^. L.info . L.viewport) + +-- | Returns the font of the given style state, or the default. +styleFont :: StyleState -> Font +styleFont style = fromMaybe def font where + font = style ^? L.text . _Just . L.font . _Just + +-- | Returns the font size of the given style state, or the default. +styleFontSize :: StyleState -> FontSize +styleFontSize style = fromMaybe def fontSize where + fontSize = style ^? L.text . _Just . L.fontSize . _Just + +-- | Returns the horizontal spacing of the given style state, or the default. +styleFontSpaceH :: StyleState -> FontSpace +styleFontSpaceH style = fromMaybe def fontSpaceH where + fontSpaceH = style ^? L.text . _Just . L.fontSpaceH . _Just + +-- | Returns the vertical spacing of the given style state, or the default. +styleFontSpaceV :: StyleState -> FontSpace +styleFontSpaceV style = fromMaybe def fontSpaceV where + fontSpaceV = style ^? L.text . _Just . L.fontSpaceV . _Just + +-- | Returns the font color of the given style state, or the default. +styleFontColor :: StyleState -> Color +styleFontColor style = fromMaybe def fontColor where + fontColor = style ^? L.text . _Just . L.fontColor . _Just + +-- | Returns the horizontal alignment of the given style state, or the default. +styleTextAlignH :: StyleState -> AlignTH +styleTextAlignH style = fromMaybe def alignH where + alignH = style ^? L.text . _Just . L.alignH . _Just + +-- | Returns the vertical alignment of the given style state, or the default. +styleTextAlignV :: StyleState -> AlignTV +styleTextAlignV style = fromMaybe def alignV where + alignV = style ^? L.text . _Just . L.alignV . _Just + +-- | Returns the background color of the given style state, or the default. +styleBgColor :: StyleState -> Color +styleBgColor style = fromMaybe def bgColor where + bgColor = style ^? L.bgColor . _Just + +-- | Returns the foreground color of the given style state, or the default. +styleFgColor :: StyleState -> Color +styleFgColor style = fromMaybe def fgColor where + fgColor = style ^? L.fgColor . _Just + +-- | Returns the secondary color of the given style state, or the default. +styleSndColor :: StyleState -> Color +styleSndColor style = fromMaybe def sndColor where + sndColor = style ^? L.sndColor . _Just + +-- | Returns the highlight color of the given style state, or the default. +styleHlColor :: StyleState -> Color +styleHlColor style = fromMaybe def hlColor where + hlColor = style ^? L.hlColor . _Just + +-- | Returns the size used by border and padding. +getOuterSize :: StyleState -> Size +getOuterSize style = fromMaybe def size where + size = addOuterSize style def + +-- | Adds border and padding to the given size. +addOuterSize :: StyleState -> Size -> Maybe Size +addOuterSize style sz = + addBorderSize sz (_sstBorder style) + >>= (`addPaddingSize` _sstPadding style) + +-- | Removes border and padding from the given size. +removeOuterSize :: StyleState -> Size -> Maybe Size +removeOuterSize style sz = + subtractBorderSize sz (_sstBorder style) + >>= (`subtractPaddingSize` _sstPadding style) + +-- | Adds border and padding to the given rect. +addOuterBounds :: StyleState -> Rect -> Maybe Rect +addOuterBounds style rect = + addBorder rect (_sstBorder style) + >>= (`addPadding` _sstPadding style) + +-- | Removes border and padding from the given rect. +removeOuterBounds :: StyleState -> Rect -> Maybe Rect +removeOuterBounds style rect = + subtractBorder rect (_sstBorder style) + >>= (`subtractPadding` _sstPadding style) + +-- | Adds border widths to the given rect. +addBorder :: Rect -> Maybe Border -> Maybe Rect +addBorder rect border = nRect where + (bl, br, bt, bb) = borderWidths border + nRect = addToRect rect bl br bt bb + +-- | Adds padding the given rect. +addPadding :: Rect -> Maybe Padding -> Maybe Rect +addPadding rect Nothing = Just rect +addPadding rect (Just (Padding l r t b)) = nRect where + nRect = addToRect rect (justDef l) (justDef r) (justDef t) (justDef b) + +-- | Subtracts border widths from the given rect. +subtractBorder :: Rect -> Maybe Border -> Maybe Rect +subtractBorder rect border = nRect where + (bl, br, bt, bb) = borderWidths border + nRect = subtractFromRect rect bl br bt bb + +-- | Subbtracts padding from the given rect. +subtractPadding :: Rect -> Maybe Padding -> Maybe Rect +subtractPadding rect Nothing = Just rect +subtractPadding rect (Just (Padding l r t b)) = nRect where + nRect = subtractFromRect rect (justDef l) (justDef r) (justDef t) (justDef b) + +{-| +Subtracts border width from radius. This is useful when rendering nested shapes +with rounded corners, which would otherwise have gaps in the corners. +-} +subtractBorderFromRadius :: Maybe Border -> Radius -> Radius +subtractBorderFromRadius border (Radius rtl rtr rbl rbr) = newRadius where + (bl, br, bt, bb) = borderWidths border + ntl = rtl & _Just . L.width %~ \w -> max 0 (w - max bl bt) + ntr = rtr & _Just . L.width %~ \w -> max 0 (w - max br bt) + nbl = rbl & _Just . L.width %~ \w -> max 0 (w - max bl bb) + nbr = rbr & _Just . L.width %~ \w -> max 0 (w - max br bb) + newRadius = Radius ntl ntr nbl nbr + +-- Internal +addBorderSize :: Size -> Maybe Border -> Maybe Size +addBorderSize sz border = nSize where + (bl, br, bt, bb) = borderWidths border + nSize = addToSize sz (bl + br) (bt + bb) + +addPaddingSize :: Size -> Maybe Padding -> Maybe Size +addPaddingSize sz Nothing = Just sz +addPaddingSize sz (Just (Padding l r t b)) = nSize where + nSize = addToSize sz (justDef l + justDef r) (justDef t + justDef b) + +subtractBorderSize :: Size -> Maybe Border -> Maybe Size +subtractBorderSize sz border = nSize where + (bl, br, bt, bb) = borderWidths border + nSize = subtractFromSize sz (bl + br) (bt + bb) + +subtractPaddingSize :: Size -> Maybe Padding -> Maybe Size +subtractPaddingSize sz Nothing = Just sz +subtractPaddingSize sz (Just (Padding l r t b)) = nSize where + nSize = subtractFromSize sz (justDef l + justDef r) (justDef t + justDef b) + +borderWidths :: Maybe Border -> (Double, Double, Double, Double) +borderWidths Nothing = (0, 0, 0, 0) +borderWidths (Just border) = (bl, br, bt, bb) where + bl = maybe 0 _bsWidth (_brdLeft border) + br = maybe 0 _bsWidth (_brdRight border) + bt = maybe 0 _bsWidth (_brdTop border) + bb = maybe 0 _bsWidth (_brdBottom border) + +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 new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/ThemeTypes.hs @@ -0,0 +1,206 @@ +{-| +Module : Monomer.Core.ThemeTypes +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Theme configuration types. +-} +{-# LANGUAGE DeriveGeneric #-} + +module Monomer.Core.ThemeTypes where + +import Control.Applicative ((<|>)) +import Data.Default +import GHC.Generics + +import qualified Data.Map.Strict as M + +import Monomer.Common +import Monomer.Core.StyleTypes +import Monomer.Graphics.ColorTable +import Monomer.Graphics.Types + +-- | Theme configuration for each state, plus clear/base color. +data Theme = Theme { + _themeClearColor :: Color, + _themeSectionColor :: Color, + _themeUserColorMap :: M.Map String Color, + _themeBasic :: ThemeState, + _themeHover :: ThemeState, + _themeFocus :: ThemeState, + _themeFocusHover :: ThemeState, + _themeActive :: ThemeState, + _themeDisabled :: ThemeState +} deriving (Eq, Show, Generic) + +instance Default Theme where + def = Theme { + _themeClearColor = def, + _themeSectionColor = def, + _themeUserColorMap = def, + _themeBasic = def, + _themeHover = def, + _themeFocus = def, + _themeFocusHover = def, + _themeActive = def, + _themeDisabled = def + } + +-- | Default theme settings for each widget. +data ThemeState = ThemeState { + _thsEmptyOverlayStyle :: StyleState, + _thsBtnStyle :: StyleState, + _thsBtnMainStyle :: StyleState, + _thsCheckboxStyle :: StyleState, + _thsCheckboxWidth :: Double, + _thsDateFieldStyle :: StyleState, + _thsDialStyle :: StyleState, + _thsDialWheelRate :: Rational, + _thsDialWidth :: Double, + _thsDialogFrameStyle :: StyleState, + _thsDialogTitleStyle :: StyleState, + _thsDialogCloseIconStyle :: StyleState, + _thsDialogButtonsStyle :: StyleState, + _thsDialogMsgBodyStyle :: StyleState, + _thsDropdownMaxHeight :: Double, + _thsDropdownStyle :: StyleState, + _thsDropdownListStyle :: StyleState, + _thsDropdownItemStyle :: StyleState, + _thsDropdownItemSelectedStyle :: StyleState, + _thsExternalLinkStyle :: StyleState, + _thsLabelStyle :: StyleState, + _thsNumericFieldStyle :: StyleState, + _thsRadioStyle :: StyleState, + _thsRadioWidth :: Double, + _thsScrollOverlay :: Bool, + _thsScrollFollowFocus :: Bool, + _thsScrollBarColor :: Color, + _thsScrollThumbColor :: Color, + _thsScrollBarWidth :: Double, + _thsScrollThumbWidth :: Double, + _thsScrollThumbRadius :: Double, + _thsScrollWheelRate :: Rational, + _thsSeparatorLineWidth :: Double, + _thsSeparatorLineStyle :: StyleState, + _thsSelectListStyle :: StyleState, + _thsSelectListItemStyle :: StyleState, + _thsSelectListItemSelectedStyle :: StyleState, + _thsSliderStyle :: StyleState, + _thsSliderRadius :: Maybe Double, + _thsSliderThumbFactor :: Double, + _thsSliderWheelRate :: Rational, + _thsSliderWidth :: Double, + _thsTextAreaStyle :: StyleState, + _thsTextFieldStyle :: StyleState, + _thsTimeFieldStyle :: StyleState, + _thsTooltipStyle :: StyleState, + _thsUserStyleMap :: M.Map String StyleState, + _thsUserColorMap :: M.Map String Color +} deriving (Eq, Show, Generic) + +instance Default ThemeState where + def = ThemeState { + _thsEmptyOverlayStyle = def, + _thsBtnStyle = def, + _thsBtnMainStyle = def, + _thsCheckboxStyle = def, + _thsCheckboxWidth = 20, + _thsDateFieldStyle = def, + _thsDialStyle = def, + _thsDialWheelRate = 10, + _thsDialWidth = 50, + _thsDialogFrameStyle = def, + _thsDialogTitleStyle = def, + _thsDialogCloseIconStyle = def, + _thsDialogButtonsStyle = def, + _thsDialogMsgBodyStyle = def, + _thsDropdownMaxHeight = 150, + _thsDropdownStyle = def, + _thsDropdownListStyle = def, + _thsDropdownItemStyle = def, + _thsDropdownItemSelectedStyle = def, + _thsExternalLinkStyle = def, + _thsLabelStyle = def, + _thsNumericFieldStyle = def, + _thsRadioStyle = def, + _thsRadioWidth = 20, + _thsScrollOverlay = False, + _thsScrollFollowFocus = True, + _thsScrollBarColor = def, + _thsScrollThumbColor = darkGray, + _thsScrollBarWidth = 10, + _thsScrollThumbWidth = 8, + _thsScrollThumbRadius = 0, + _thsScrollWheelRate = 10, + _thsSeparatorLineWidth = 1, + _thsSeparatorLineStyle = def, + _thsSelectListStyle = def, + _thsSelectListItemStyle = def, + _thsSelectListItemSelectedStyle = def, + _thsSliderStyle = def, + _thsSliderRadius = Nothing, + _thsSliderThumbFactor = 1.25, + _thsSliderWheelRate = 10, + _thsSliderWidth = 10, + _thsTextAreaStyle = def, + _thsTextFieldStyle = def, + _thsTimeFieldStyle = def, + _thsTooltipStyle = def, + _thsUserStyleMap = M.empty, + _thsUserColorMap = M.empty + } + +instance Semigroup ThemeState where + (<>) t1 t2 = ThemeState { + _thsEmptyOverlayStyle = _thsEmptyOverlayStyle t1 <> _thsEmptyOverlayStyle t2, + _thsBtnStyle = _thsBtnStyle t1 <> _thsBtnStyle t2, + _thsBtnMainStyle = _thsBtnMainStyle t1 <> _thsBtnMainStyle t2, + _thsCheckboxStyle = _thsCheckboxStyle t1 <> _thsCheckboxStyle t2, + _thsCheckboxWidth = _thsCheckboxWidth t2, + _thsDateFieldStyle = _thsDateFieldStyle t1 <> _thsDateFieldStyle t2, + _thsDialStyle = _thsDialStyle t1 <> _thsDialStyle t2, + _thsDialWheelRate = _thsDialWheelRate t2, + _thsDialWidth = _thsDialWidth t2, + _thsDialogFrameStyle = _thsDialogFrameStyle t1 <> _thsDialogFrameStyle t2, + _thsDialogTitleStyle = _thsDialogTitleStyle t1 <> _thsDialogTitleStyle t2, + _thsDialogCloseIconStyle = _thsDialogCloseIconStyle t1 <> _thsDialogCloseIconStyle t2, + _thsDialogMsgBodyStyle = _thsDialogMsgBodyStyle t1 <> _thsDialogMsgBodyStyle t2, + _thsDialogButtonsStyle = _thsDialogButtonsStyle t1 <> _thsDialogButtonsStyle t2, + _thsDropdownMaxHeight = _thsDropdownMaxHeight t2, + _thsDropdownStyle = _thsDropdownStyle t1 <> _thsDropdownStyle t2, + _thsDropdownListStyle = _thsDropdownListStyle t1 <> _thsDropdownListStyle t2, + _thsDropdownItemStyle = _thsDropdownItemStyle t1 <> _thsDropdownItemStyle t2, + _thsDropdownItemSelectedStyle = _thsDropdownItemSelectedStyle t1 <> _thsDropdownItemSelectedStyle t2, + _thsExternalLinkStyle = _thsExternalLinkStyle t1 <> _thsExternalLinkStyle t2, + _thsLabelStyle = _thsLabelStyle t1 <> _thsLabelStyle t2, + _thsNumericFieldStyle = _thsNumericFieldStyle t1 <> _thsNumericFieldStyle t2, + _thsRadioStyle = _thsRadioStyle t1 <> _thsRadioStyle t2, + _thsRadioWidth = _thsRadioWidth t2, + _thsScrollOverlay = _thsScrollOverlay t2, + _thsScrollFollowFocus = _thsScrollFollowFocus t2, + _thsScrollBarColor = _thsScrollBarColor t2, + _thsScrollThumbColor = _thsScrollThumbColor t2, + _thsScrollBarWidth = _thsScrollBarWidth t2, + _thsScrollThumbWidth = _thsScrollThumbWidth t2, + _thsScrollThumbRadius = _thsScrollThumbRadius t2, + _thsScrollWheelRate = _thsScrollWheelRate t2, + _thsSeparatorLineWidth = _thsSeparatorLineWidth t2, + _thsSeparatorLineStyle = _thsSeparatorLineStyle t1 <> _thsSeparatorLineStyle t2, + _thsSelectListStyle = _thsSelectListStyle t1 <> _thsSelectListStyle t2, + _thsSelectListItemStyle = _thsSelectListItemStyle t1 <> _thsSelectListItemStyle t2, + _thsSelectListItemSelectedStyle = _thsSelectListItemSelectedStyle t1 <> _thsSelectListItemSelectedStyle t2, + _thsSliderStyle = _thsSliderStyle t1 <> _thsSliderStyle t2, + _thsSliderThumbFactor = _thsSliderThumbFactor t2, + _thsSliderWheelRate = _thsSliderWheelRate t2, + _thsSliderWidth = _thsSliderWidth t2, + _thsSliderRadius = _thsSliderRadius t2 <|> _thsSliderRadius t1, + _thsTextAreaStyle = _thsTextAreaStyle t1 <> _thsTextAreaStyle t2, + _thsTextFieldStyle = _thsTextFieldStyle t1 <> _thsTextFieldStyle t2, + _thsTimeFieldStyle = _thsTimeFieldStyle t1 <> _thsTimeFieldStyle t2, + _thsTooltipStyle = _thsTooltipStyle t1 <> _thsTooltipStyle t2, + _thsUserStyleMap = _thsUserStyleMap t1 <> _thsUserStyleMap t2, + _thsUserColorMap = _thsUserColorMap t1 <> _thsUserColorMap t2 + } diff --git a/src/Monomer/Core/Themes/BaseTheme.hs b/src/Monomer/Core/Themes/BaseTheme.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/Themes/BaseTheme.hs @@ -0,0 +1,420 @@ +{-| +Module : Monomer.Core.Themes.BaseTheme +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Provides a base theme, with fixed sizes and padding but configurable colors. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Core.Themes.BaseTheme ( + BaseThemeColors(..), + baseTheme +) where + +import Control.Lens ((&), (^.), (.~), (?~), non) +import Data.Default + +import Monomer.Core.Combinators +import Monomer.Core.Style +import Monomer.Graphics.Types + +import qualified Monomer.Core.Lens as L +import qualified Monomer.Graphics.Lens as L + +-- | Creates a theme using the provided colors. +baseTheme :: BaseThemeColors -> Theme +baseTheme themeMod = Theme { + _themeClearColor = clearColor themeMod, + _themeSectionColor = sectionColor themeMod, + _themeUserColorMap = def, + _themeBasic = baseBasic themeMod, + _themeHover = baseHover themeMod, + _themeFocus = baseFocus themeMod, + _themeFocusHover = baseFocusHover themeMod, + _themeActive = baseActive themeMod, + _themeDisabled = baseDisabled themeMod +} + +-- | Customizable colors for the theme. +data BaseThemeColors = BaseThemeColors { + clearColor :: Color, + sectionColor :: Color, + btnFocusBorder :: Color, + btnBgBasic :: Color, + btnBgHover :: Color, + btnBgFocus :: Color, + btnBgActive :: Color, + btnBgDisabled :: Color, + btnText :: Color, + btnTextDisabled :: Color, + btnMainFocusBorder :: Color, + btnMainBgBasic :: Color, + btnMainBgHover :: Color, + btnMainBgFocus :: Color, + btnMainBgActive :: Color, + btnMainBgDisabled :: Color, + btnMainText :: Color, + btnMainTextDisabled :: Color, + dialogBg :: Color, + dialogBorder :: Color, + dialogText :: Color, + dialogTitleText :: Color, + emptyOverlay :: Color, + externalLinkBasic :: Color, + externalLinkHover :: Color, + externalLinkFocus :: Color, + externalLinkActive :: Color, + externalLinkDisabled :: Color, + iconFg :: Color, + iconBg :: Color, + inputIconFg :: Color, + inputBorder :: Color, + inputFocusBorder :: Color, + inputBgBasic :: Color, + inputBgHover :: Color, + inputBgFocus :: Color, + inputBgActive :: Color, + inputBgDisabled :: Color, + inputFgBasic :: Color, + inputFgHover :: Color, + inputFgFocus :: Color, + inputFgActive :: Color, + inputFgDisabled :: Color, + inputSndBasic :: Color, + inputSndHover :: Color, + inputSndFocus :: Color, + inputSndActive :: Color, + inputSndDisabled :: Color, + inputHlBasic :: Color, + inputHlHover :: Color, + inputHlFocus :: Color, + inputHlActive :: Color, + inputHlDisabled :: Color, + inputSelBasic :: Color, + inputSelFocus :: Color, + inputText :: Color, + inputTextDisabled :: Color, + labelText :: Color, + scrollBarBasic :: Color, + scrollThumbBasic :: Color, + scrollBarHover :: Color, + scrollThumbHover :: Color, + slMainBg :: Color, + slNormalBgBasic :: Color, + slNormalBgHover :: Color, + slNormalText :: Color, + slNormalFocusBorder :: Color, + slSelectedBgBasic :: Color, + slSelectedBgHover :: Color, + slSelectedText :: Color, + slSelectedFocusBorder :: Color, + tooltipBorder :: Color, + tooltipBg :: Color, + tooltipText :: Color +} deriving (Eq, Show) + +btnBorderFocus :: BaseThemeColors -> Border +btnBorderFocus themeMod = border 1 (btnFocusBorder themeMod) + +btnMainBorderFocus :: BaseThemeColors -> Border +btnMainBorderFocus themeMod = border 1 (btnMainFocusBorder themeMod) + +inputBorderFocus :: BaseThemeColors -> Border +inputBorderFocus themeMod = border 1 (inputFocusBorder themeMod) + +normalFont :: TextStyle +normalFont = def + & L.font ?~ Font "Regular" + & L.fontSize ?~ FontSize 16 + & L.fontSpaceV ?~ FontSpace 4 + +titleFont :: TextStyle +titleFont = def + & L.font ?~ Font "Bold" + & L.fontSize ?~ FontSize 20 + +btnStyle :: BaseThemeColors -> StyleState +btnStyle themeMod = def + & L.text ?~ (normalFont & L.fontColor ?~ btnText themeMod) <> textCenter + & L.bgColor ?~ btnBgBasic themeMod + & L.border ?~ border 1 (btnBgBasic themeMod) + & L.padding ?~ padding 8 + & L.radius ?~ radius 4 + +btnMainStyle :: BaseThemeColors -> StyleState +btnMainStyle themeMod = btnStyle themeMod + & L.text . non def . L.fontColor ?~ btnMainText themeMod + & L.bgColor ?~ btnMainBgBasic themeMod + & 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 + +numericInputStyle :: BaseThemeColors -> StyleState +numericInputStyle themeMod = textInputStyle themeMod + & L.text . non def . L.alignH ?~ ATRight + +dateInputStyle :: BaseThemeColors -> StyleState +dateInputStyle themeMod = textInputStyle themeMod + & L.text . non def . L.alignH ?~ ATRight + +timeInputStyle :: BaseThemeColors -> StyleState +timeInputStyle themeMod = textInputStyle themeMod + & L.text . non def . L.alignH ?~ ATRight + +selectListItemStyle :: BaseThemeColors -> StyleState +selectListItemStyle themeMod = def + & L.text ?~ (normalFont & L.fontColor ?~ slNormalText themeMod) + & L.text . non def . L.alignH ?~ ATLeft + & L.bgColor ?~ slNormalBgBasic themeMod + & L.border ?~ border 1 (slNormalBgBasic themeMod) + & L.padding ?~ padding 8 + +selectListItemSelectedStyle :: BaseThemeColors -> StyleState +selectListItemSelectedStyle themeMod = selectListItemStyle themeMod + & L.text . non def . L.fontColor ?~ slSelectedText themeMod + & L.bgColor ?~ slSelectedBgBasic themeMod + & L.border ?~ border 1 (slSelectedBgBasic themeMod) + +tooltipStyle :: BaseThemeColors -> StyleState +tooltipStyle themeMod = def + & L.text . non def . L.font ?~ Font "Regular" + & L.text . non def . L.fontSize ?~ FontSize 14 + & L.text . non def . L.fontColor ?~ tooltipText themeMod + & L.bgColor ?~ tooltipBg themeMod + & L.border ?~ border 1 (tooltipBorder themeMod) + & L.padding ?~ padding 4 + +baseBasic :: BaseThemeColors -> ThemeState +baseBasic themeMod = def + & L.emptyOverlayStyle .~ bgColor (emptyOverlay themeMod) + & L.emptyOverlayStyle . L.padding ?~ padding 8 + & L.btnStyle .~ btnStyle themeMod + & L.btnMainStyle .~ btnMainStyle themeMod + & L.checkboxWidth .~ 20 + & L.checkboxStyle . L.fgColor ?~ inputFgBasic themeMod + & L.checkboxStyle . L.hlColor ?~ inputHlBasic themeMod + & L.checkboxStyle . L.radius ?~ radius 4 + & L.dateFieldStyle .~ dateInputStyle themeMod + & L.dialWidth .~ 50 + & L.dialStyle . L.fgColor ?~ inputFgBasic themeMod + & L.dialStyle . L.sndColor ?~ inputSndBasic themeMod + & L.dialogTitleStyle . L.text ?~ (titleFont & L.fontColor ?~ dialogTitleText themeMod) + & L.dialogTitleStyle . L.padding ?~ padding 10 + & L.dialogFrameStyle . L.padding ?~ padding 5 + & L.dialogFrameStyle . L.radius ?~ radius 10 + & L.dialogFrameStyle . L.bgColor ?~ dialogBg themeMod + & L.dialogFrameStyle . L.border ?~ border 1 (dialogBorder themeMod) + & L.dialogCloseIconStyle . L.bgColor ?~ iconBg themeMod + & L.dialogCloseIconStyle . L.fgColor ?~ iconFg themeMod + & L.dialogCloseIconStyle . L.padding ?~ padding 4 + & L.dialogCloseIconStyle . L.radius ?~ radius 8 + & L.dialogCloseIconStyle . L.sizeReqW ?~ width 16 + & 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.sizeReqW ?~ maxWidth 600 + & L.dropdownStyle .~ textInputStyle themeMod + & L.dropdownStyle . L.fgColor ?~ inputIconFg themeMod + & L.dropdownStyle . L.text . non def . L.alignH ?~ ATLeft + & L.dropdownMaxHeight .~ 200 + & 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.numericFieldStyle .~ numericInputStyle themeMod + & L.selectListStyle . L.bgColor ?~ slMainBg themeMod + & L.selectListStyle . L.border ?~ border 1 (slMainBg themeMod) + & L.selectListItemStyle .~ selectListItemStyle themeMod + & L.selectListItemSelectedStyle .~ selectListItemSelectedStyle themeMod + & L.radioWidth .~ 20 + & L.radioStyle . L.fgColor ?~ inputFgBasic themeMod + & L.radioStyle . L.hlColor ?~ inputHlBasic themeMod + & L.scrollOverlay .~ False + & L.scrollFollowFocus .~ True + & L.scrollBarColor .~ scrollBarBasic themeMod + & L.scrollThumbColor .~ scrollThumbBasic themeMod + & L.scrollBarWidth .~ 8 + & L.scrollThumbWidth .~ 8 + & L.scrollThumbRadius .~ 4 + & L.scrollWheelRate .~ 10 + & L.separatorLineWidth .~ 1 + & L.separatorLineStyle . L.fgColor ?~ inputSndBasic themeMod + & L.sliderRadius ?~ 2 + & L.sliderThumbFactor .~ 1.25 + & L.sliderWidth .~ 10 + & L.sliderStyle . L.fgColor ?~ inputFgBasic themeMod + & L.sliderStyle . L.hlColor ?~ inputHlBasic themeMod + & L.sliderStyle . L.sndColor ?~ inputSndBasic themeMod + & L.textAreaStyle .~ textInputStyle themeMod + & L.textFieldStyle .~ textInputStyle themeMod + & L.timeFieldStyle .~ timeInputStyle themeMod + & L.tooltipStyle .~ tooltipStyle themeMod + +baseHover :: BaseThemeColors -> ThemeState +baseHover themeMod = baseBasic themeMod + & L.btnStyle . L.bgColor ?~ btnBgHover themeMod + & L.btnStyle . L.border ?~ border 1 (btnBgHover themeMod) + & L.btnStyle . L.cursorIcon ?~ CursorHand + & L.btnMainStyle . L.bgColor ?~ btnMainBgHover themeMod + & L.btnMainStyle . L.border ?~ border 1 (btnMainBgHover themeMod) + & L.btnMainStyle . L.cursorIcon ?~ CursorHand + & L.checkboxStyle . L.fgColor ?~ inputFgHover themeMod + & L.checkboxStyle . L.hlColor ?~ inputHlHover themeMod + & L.checkboxStyle . L.cursorIcon ?~ CursorHand + & L.dateFieldStyle . L.cursorIcon ?~ CursorIBeam + & L.dialStyle . L.fgColor ?~ inputFgHover themeMod + & L.dialStyle . L.sndColor ?~ inputSndHover themeMod + & L.dialStyle . L.cursorIcon ?~ CursorSizeV + & L.dialogCloseIconStyle . L.cursorIcon ?~ CursorHand + & L.dropdownStyle . L.bgColor ?~ inputBgHover themeMod + & L.dropdownStyle . L.cursorIcon ?~ CursorHand + & L.dropdownListStyle . L.border ?~ border 1 (slMainBg themeMod) + & L.dropdownItemStyle . L.bgColor ?~ slNormalBgHover themeMod + & L.dropdownItemStyle . L.border ?~ border 1 (slNormalBgHover themeMod) + & L.dropdownItemStyle . L.cursorIcon ?~ CursorHand + & L.dropdownItemSelectedStyle . L.bgColor ?~ slSelectedBgHover themeMod + & L.dropdownItemSelectedStyle . L.border ?~ border 1 (slSelectedBgHover themeMod) + & L.dropdownItemSelectedStyle . L.cursorIcon ?~ CursorHand + & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkHover themeMod + & L.externalLinkStyle . L.text . non def . L.underline ?~ True + & L.externalLinkStyle . L.cursorIcon ?~ CursorHand + & L.numericFieldStyle . L.cursorIcon ?~ CursorIBeam + & L.selectListItemStyle . L.bgColor ?~ slNormalBgHover themeMod + & L.selectListItemStyle . L.border ?~ border 1 (slNormalBgHover themeMod) + & L.selectListItemStyle . L.cursorIcon ?~ CursorHand + & L.selectListItemSelectedStyle . L.bgColor ?~ slSelectedBgHover themeMod + & L.selectListItemSelectedStyle . L.border ?~ border 1 (slSelectedBgHover themeMod) + & L.selectListItemSelectedStyle . L.cursorIcon ?~ CursorHand + & L.radioStyle . L.fgColor ?~ inputFgHover themeMod + & L.radioStyle . L.hlColor ?~ inputHlHover themeMod + & L.radioStyle . L.cursorIcon ?~ CursorHand + & L.scrollBarColor .~ scrollBarHover themeMod + & L.scrollThumbColor .~ scrollThumbHover themeMod + & L.sliderStyle . L.fgColor ?~ inputFgHover themeMod + & L.sliderStyle . L.hlColor ?~ inputHlHover themeMod + & L.sliderStyle . L.sndColor ?~ inputSndHover themeMod + & L.sliderStyle . L.cursorIcon ?~ CursorHand + & L.textAreaStyle . L.cursorIcon ?~ CursorIBeam + & L.textFieldStyle . L.cursorIcon ?~ CursorIBeam + & L.timeFieldStyle . L.cursorIcon ?~ CursorIBeam + +baseFocus :: BaseThemeColors -> ThemeState +baseFocus themeMod = baseBasic themeMod + & L.btnStyle . L.bgColor ?~ btnBgFocus themeMod + & L.btnStyle . L.border ?~ btnBorderFocus themeMod + & L.btnMainStyle . L.bgColor ?~ btnMainBgFocus themeMod + & L.btnMainStyle . L.border ?~ btnMainBorderFocus themeMod + & L.checkboxStyle . L.fgColor ?~ inputFgFocus themeMod + & L.checkboxStyle . L.hlColor ?~ inputHlFocus themeMod + & L.dateFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.dateFieldStyle . L.hlColor ?~ inputSelFocus themeMod + & L.dialStyle . L.fgColor ?~ inputFgFocus themeMod + & L.dialStyle . L.sndColor ?~ inputSndFocus themeMod + & L.dropdownStyle . L.border ?~ inputBorderFocus themeMod + & L.dropdownListStyle . L.border ?~ border 1 (slMainBg themeMod) + & L.dropdownItemStyle . L.border ?~ border 1 (slNormalFocusBorder themeMod) + & L.dropdownItemSelectedStyle . L.border ?~ border 1 (slSelectedFocusBorder themeMod) + & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkFocus themeMod + & L.numericFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.numericFieldStyle . L.hlColor ?~ inputSelFocus themeMod + & L.selectListStyle . L.border ?~ inputBorderFocus themeMod + & L.selectListItemStyle . L.border ?~ border 1 (slNormalFocusBorder themeMod) + & L.selectListItemSelectedStyle . L.border ?~ border 1 (slSelectedFocusBorder themeMod) + & L.radioStyle . L.fgColor ?~ inputFgFocus themeMod + & L.radioStyle . L.hlColor ?~ inputHlFocus themeMod + & L.sliderStyle . L.fgColor ?~ inputFgFocus themeMod + & L.sliderStyle . L.hlColor ?~ inputHlFocus themeMod + & L.sliderStyle . L.sndColor ?~ inputSndFocus themeMod + & L.textAreaStyle . L.border ?~ inputBorderFocus themeMod + & L.textAreaStyle . L.hlColor ?~ inputSelFocus themeMod + & L.textFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.textFieldStyle . L.hlColor ?~ inputSelFocus themeMod + & L.timeFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.timeFieldStyle . L.hlColor ?~ inputSelFocus themeMod + +baseFocusHover :: BaseThemeColors -> ThemeState +baseFocusHover themeMod = (baseHover themeMod <> baseFocus themeMod) + & L.btnStyle . L.bgColor ?~ btnBgHover themeMod + & L.btnMainStyle . L.bgColor ?~ btnMainBgHover themeMod + & L.dropdownItemStyle . L.bgColor ?~ slNormalBgHover themeMod + & L.dropdownItemSelectedStyle . L.bgColor ?~ slSelectedBgHover themeMod + & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkHover themeMod + +baseActive :: BaseThemeColors -> ThemeState +baseActive themeMod = baseFocusHover themeMod + & L.btnStyle . L.bgColor ?~ btnBgActive themeMod + & L.btnStyle . L.border ?~ btnBorderFocus themeMod + & L.btnMainStyle . L.bgColor ?~ btnMainBgActive themeMod + & L.btnMainStyle . L.border ?~ btnMainBorderFocus themeMod + & L.checkboxStyle . L.fgColor ?~ inputFgActive themeMod + & L.checkboxStyle . L.hlColor ?~ inputHlActive themeMod + & L.dateFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.dateFieldStyle . L.hlColor ?~ inputSelFocus themeMod + & L.dialStyle . L.fgColor ?~ inputFgActive themeMod + & L.dialStyle . L.sndColor ?~ inputSndActive themeMod + & L.dropdownStyle . L.bgColor ?~ inputBgActive themeMod + & L.dropdownStyle . L.border ?~ inputBorderFocus themeMod + & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkActive themeMod + & L.numericFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.numericFieldStyle . L.hlColor ?~ inputSelFocus themeMod + & L.radioStyle . L.fgColor ?~ inputFgActive themeMod + & L.radioStyle . L.hlColor ?~ inputHlActive themeMod + & L.sliderStyle . L.fgColor ?~ inputFgActive themeMod + & L.sliderStyle . L.hlColor ?~ inputHlActive themeMod + & L.sliderStyle . L.sndColor ?~ inputSndActive themeMod + & L.textAreaStyle . L.border ?~ inputBorderFocus themeMod + & L.textAreaStyle . L.hlColor ?~ inputSelFocus themeMod + & L.textFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.textFieldStyle . L.hlColor ?~ inputSelFocus themeMod + & L.timeFieldStyle . L.border ?~ inputBorderFocus themeMod + & L.timeFieldStyle . L.hlColor ?~ inputSelFocus themeMod + +baseDisabled :: BaseThemeColors -> ThemeState +baseDisabled themeMod = baseBasic themeMod + & L.btnStyle . L.text . non def . L.fontColor ?~ btnTextDisabled themeMod + & L.btnStyle . L.bgColor ?~ btnBgDisabled themeMod + & L.btnStyle . L.border ?~ border 1 (btnBgDisabled themeMod) + & L.btnMainStyle . L.text . non def . L.fontColor ?~ btnMainTextDisabled themeMod + & L.btnMainStyle . L.bgColor ?~ btnMainBgDisabled themeMod + & L.btnMainStyle . L.border ?~ border 1 (btnMainBgDisabled themeMod) + & L.checkboxStyle . L.fgColor ?~ inputFgDisabled themeMod + & L.checkboxStyle . L.hlColor ?~ inputHlDisabled themeMod + & L.dateFieldStyle . L.bgColor ?~ inputBgDisabled themeMod + & L.dateFieldStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod + & L.dialStyle . L.fgColor ?~ inputFgDisabled themeMod + & L.dialStyle . L.sndColor ?~ inputSndDisabled themeMod + & L.dropdownStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod + & L.dropdownStyle . L.bgColor ?~ inputBgDisabled themeMod + & L.dropdownStyle . L.border ?~ border 1 (inputBgDisabled themeMod) + & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkDisabled themeMod + & L.numericFieldStyle . L.bgColor ?~ inputBgDisabled themeMod + & L.numericFieldStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod + & L.radioStyle . L.fgColor ?~ inputFgDisabled themeMod + & L.radioStyle . L.hlColor ?~ inputHlDisabled themeMod + & L.sliderStyle . L.fgColor ?~ inputFgDisabled themeMod + & L.sliderStyle . L.hlColor ?~ inputHlDisabled themeMod + & L.sliderStyle . L.sndColor ?~ inputSndDisabled themeMod + & L.textAreaStyle . L.bgColor ?~ inputBgDisabled themeMod + & L.textAreaStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod + & L.textFieldStyle . L.bgColor ?~ inputBgDisabled themeMod + & L.textFieldStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod + & L.timeFieldStyle . L.bgColor ?~ inputBgDisabled themeMod + & L.timeFieldStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod diff --git a/src/Monomer/Core/Themes/SampleThemes.hs b/src/Monomer/Core/Themes/SampleThemes.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/Themes/SampleThemes.hs @@ -0,0 +1,277 @@ +{-| +Module : Monomer.Core.Themes.SampleThemes +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Provides sample color schemes for the base theme. +-} +module Monomer.Core.Themes.SampleThemes ( + lightTheme, + lightThemeColors, + darkTheme, + darkThemeColors +) where + +import Control.Lens ((&), (^.), (.~), (?~), non) + +import Monomer.Core.ThemeTypes +import Monomer.Core.Themes.BaseTheme +import Monomer.Graphics + +import qualified Monomer.Lens as L + +-- | Light theme provided by the library. +lightTheme :: Theme +lightTheme = baseTheme lightThemeColors + +-- | Colors for the light theme. +lightThemeColors :: BaseThemeColors +lightThemeColors = BaseThemeColors { + clearColor = gray10, -- gray12, + sectionColor = gray09, -- gray11, + + btnFocusBorder = blue08, + btnBgBasic = gray07, + btnBgHover = gray08, + btnBgFocus = gray08, + btnBgActive = gray06, + btnBgDisabled = gray05, + btnText = gray02, + btnTextDisabled = gray02, + + btnMainFocusBorder = blue09, + btnMainBgBasic = blue05, + btnMainBgHover = blue06, + btnMainBgFocus = blue06, + btnMainBgActive = blue05, + btnMainBgDisabled = blue04, + btnMainText = white, + btnMainTextDisabled = white, + + dialogBg = white, + dialogBorder = white, + dialogText = black, + dialogTitleText = black, + emptyOverlay = gray07 & L.a .~ 0.8, + + externalLinkBasic = blue07, + externalLinkHover = blue08, + externalLinkFocus = blue07, + externalLinkActive = blue06, + externalLinkDisabled = gray06, + + iconBg = gray07, + iconFg = gray01, + + inputIconFg = black, + inputBorder = gray06, + inputFocusBorder = blue07, + + inputBgBasic = gray10, + inputBgHover = white, + inputBgFocus = white, + inputBgActive = gray09, + inputBgDisabled = gray05, + + inputFgBasic = gray05, + inputFgHover = blue07, + inputFgFocus = blue07, + inputFgActive = blue06, + inputFgDisabled = gray04, + + inputSndBasic = gray04, + inputSndHover = gray05, + inputSndFocus = gray05, + inputSndActive = gray04, + inputSndDisabled = gray03, + + inputHlBasic = gray06, + inputHlHover = blue07, + inputHlFocus = blue07, + inputHlActive = blue06, + inputHlDisabled = gray05, + + inputSelBasic = gray07, + inputSelFocus = blue08, + + inputText = black, + inputTextDisabled = gray02, + labelText = black, + + scrollBarBasic = gray03 & L.a .~ 0.2, + scrollThumbBasic = gray01 & L.a .~ 0.2, + scrollBarHover = gray07 & L.a .~ 0.8, + scrollThumbHover = gray05 & L.a .~ 0.8, + + slMainBg = white, + slNormalBgBasic = transparent, + slNormalBgHover = gray09, + slNormalText = black, + slNormalFocusBorder = blue07, + + slSelectedBgBasic = gray08, + slSelectedBgHover = gray09, + slSelectedText = black, + slSelectedFocusBorder = blue07, + + tooltipBorder = gray09, + tooltipBg = gray10, + tooltipText = black +} + +-- | Dark theme provided by the library. +darkTheme :: Theme +darkTheme = baseTheme darkThemeColors + +-- | Colors for the dark theme. +darkThemeColors :: BaseThemeColors +darkThemeColors = BaseThemeColors { + clearColor = gray03, + sectionColor = gray02, + + btnFocusBorder = blue09, + btnBgBasic = gray07, + btnBgHover = gray09, + btnBgFocus = gray08, + btnBgActive = gray06, + btnBgDisabled = gray05, + + btnText = gray02, + btnTextDisabled = gray01, + btnMainFocusBorder = blue08, + btnMainBgBasic = blue05, + btnMainBgHover = blue06, + btnMainBgFocus = blue06, + btnMainBgActive = blue05, + btnMainBgDisabled = blue04, + btnMainText = white, + btnMainTextDisabled = gray08, + + dialogBg = gray01, + dialogBorder = gray01, + dialogText = white, + dialogTitleText = white, + emptyOverlay = gray05 & L.a .~ 0.8, + + externalLinkBasic = blue07, + externalLinkHover = blue08, + externalLinkFocus = blue07, + externalLinkActive = blue06, + externalLinkDisabled = gray06, + + iconBg = gray08, + iconFg = gray01, + + inputIconFg = black, + inputBorder = gray02, + inputFocusBorder = blue08, + + inputBgBasic = gray04, + inputBgHover = gray06, + inputBgFocus = gray05, + inputBgActive = gray03, + inputBgDisabled = gray07, + + inputFgBasic = gray06, + inputFgHover = blue08, + inputFgFocus = blue08, + inputFgActive = blue07, + inputFgDisabled = gray07, + + inputSndBasic = gray05, + inputSndHover = gray06, + inputSndFocus = gray05, + inputSndActive = gray05, + inputSndDisabled = gray03, + + inputHlBasic = gray07, + inputHlHover = blue08, + inputHlFocus = blue08, + inputHlActive = blue08, + inputHlDisabled = gray08, + + inputSelBasic = gray06, + inputSelFocus = blue06, + + inputText = white, + inputTextDisabled = gray02, + labelText = white, + + scrollBarBasic = gray01 & L.a .~ 0.2, + scrollThumbBasic = gray07 & L.a .~ 0.6, + scrollBarHover = gray01 & L.a .~ 0.4, + scrollThumbHover = gray07 & L.a .~ 0.8, + + slMainBg = gray00, + slNormalBgBasic = transparent, + slNormalBgHover = gray05, + slNormalText = white, + slNormalFocusBorder = blue08, + + slSelectedBgBasic = gray04, + slSelectedBgHover = gray05, + slSelectedText = white, + slSelectedFocusBorder = blue08, + + tooltipBorder = gray09, + tooltipBg = gray04, + tooltipText = white +} + +black = rgbHex "#000000" +white = rgbHex "#FFFFFF" + +blue01 = rgbHex "#002159" +blue02 = rgbHex "#01337D" +blue03 = rgbHex "#03449E" +blue04 = rgbHex "#0552B5" +blue05 = rgbHex "#0967D2" +blue06 = rgbHex "#2186EB" +blue07 = rgbHex "#47A3F3" +blue08 = rgbHex "#7CC4FA" +blue09 = rgbHex "#BAE3FF" +blue10 = rgbHex "#E6F6FF" + +{- +gray01 = rgbHex "#242424" +gray02 = rgbHex "#2E2E2E" +gray03 = rgbHex "#393939" +gray04 = rgbHex "#404040" +gray05 = rgbHex "#575757" +gray06 = rgbHex "#606060" +gray07 = rgbHex "#6E6E6E" +gray08 = rgbHex "#8C8C8C" +gray09 = rgbHex "#A4A4A4" +gray10 = rgbHex "#C4C4C4" +gray11 = rgbHex "#DADADA" +gray12 = rgbHex "#EAEAEA" +-} + +gray00 = rgbHex "#222222" +gray01 = rgbHex "#2E2E2E" +gray02 = rgbHex "#393939" +gray03 = rgbHex "#515151" +gray04 = rgbHex "#626262" +gray05 = rgbHex "#7E7E7E" +gray06 = rgbHex "#9E9E9E" +gray07 = rgbHex "#B1B1B1" +gray08 = rgbHex "#CFCFCF" +gray09 = rgbHex "#E1E1E1" +gray10 = rgbHex "#F7F7F7" + +{- +gray00 = rgbHex "#0F1923" +gray01 = rgbHex "#1F2933" +gray02 = rgbHex "#323F4B" +gray03 = rgbHex "#3E4C59" +gray04 = rgbHex "#52606D" +gray05 = rgbHex "#616E7C" +gray06 = rgbHex "#7B8794" +gray07 = rgbHex "#9AA5B1" +gray08 = rgbHex "#CBD2D9" +gray09 = rgbHex "#E4E7EB" +gray10 = rgbHex "#F5F7FA" +-} diff --git a/src/Monomer/Core/Util.hs b/src/Monomer/Core/Util.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/Util.hs @@ -0,0 +1,320 @@ +{-| +Module : Monomer.Core.Util +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for Core types. +-} +{-# LANGUAGE LambdaCase #-} + +module Monomer.Core.Util where + +import Control.Lens ((&), (^.), (.~), (?~)) +import Data.Maybe +import Data.Text (Text) +import Data.Typeable (cast) +import Data.Sequence (Seq(..)) + +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Common +import Monomer.Core.Style +import Monomer.Core.WidgetTypes +import Monomer.Helper + +import qualified Monomer.Core.Lens as L + +-- | Returns the path associated to a given key, if any. +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. +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 + :: WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo +findWidgetByPath 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 + +-- | Helper functions that associates False to Vertical and True to Horizontal. +getLayoutDirection :: Bool -> LayoutDirection +getLayoutDirection False = LayoutVertical +getLayoutDirection True = LayoutHorizontal + +-- | Filters user events from a list of WidgetRequests. +eventsFromReqs :: Seq (WidgetRequest s e) -> Seq e +eventsFromReqs reqs = seqCatMaybes mevents where + mevents = flip fmap reqs $ \case + RaiseEvent ev -> cast ev + _ -> Nothing + +{-| +Ignore events generated by the parent. Could be used to consume the tab key and +avoid having the focus move to the next widget. +-} +isIgnoreParentEvents :: WidgetRequest s e -> Bool +isIgnoreParentEvents IgnoreParentEvents = True +isIgnoreParentEvents _ = False + +-- | Ignore children events. Scroll relies on this to handle click/wheel. +isIgnoreChildrenEvents :: WidgetRequest s e -> Bool +isIgnoreChildrenEvents IgnoreChildrenEvents = True +isIgnoreChildrenEvents _ = False + +{-| +The widget content changed and requires a different size. Processed at the end +of the cycle, since several widgets may request it. +-} +isResizeWidgets :: WidgetRequest s e -> Bool +isResizeWidgets ResizeWidgets{} = True +isResizeWidgets _ = False + +{-| +The widget content changed and requires a different size. Processed immediately. +Avoid if possible, since it can affect performance. +-} +isResizeWidgetsImmediate :: WidgetRequest s e -> Bool +isResizeWidgetsImmediate ResizeWidgetsImmediate{} = True +isResizeWidgetsImmediate _ = False + +-- | Moves the focus, optionally indicating a starting widgetId. +isMoveFocus :: WidgetRequest s e -> Bool +isMoveFocus MoveFocus{} = True +isMoveFocus _ = False + +-- | Sets the focus to the given widgetId. +isSetFocus :: WidgetRequest s e -> Bool +isSetFocus SetFocus{} = True +isSetFocus _ = False + +-- | Requests the clipboard contents. It will be received as a SystemEvent. +isGetClipboard :: WidgetRequest s e -> Bool +isGetClipboard GetClipboard{} = True +isGetClipboard _ = False + +-- | Sets the clipboard to the given ClipboardData. +isSetClipboard :: WidgetRequest s e -> Bool +isSetClipboard SetClipboard{} = True +isSetClipboard _ = False + +{-| +Sets the viewport which should be remain visible when an on-screen keyboard is +displayed. Required for mobile. +-} +isStartTextInput :: WidgetRequest s e -> Bool +isStartTextInput StartTextInput{} = True +isStartTextInput _ = False + +-- | Resets the keyboard viewport, +isStopTextInput :: WidgetRequest s e -> Bool +isStopTextInput StopTextInput{} = True +isStopTextInput _ = False + +{-| +Sets a widget as the base target of future events. This is used by the dropdown +component to handle list events (which is on top of everything). +-} +isSetOverlay :: WidgetRequest s e -> Bool +isSetOverlay SetOverlay{} = True +isSetOverlay _ = False + +-- | Removes the existing overlay. +isResetOverlay :: WidgetRequest s e -> Bool +isResetOverlay ResetOverlay{} = True +isResetOverlay _ = False + +{-| +Sets the current active cursor icon. This acts as a stack, so removing means +going back a step to the cursor set by a parent widget. +-} +isSetCursorIcon :: WidgetRequest s e -> Bool +isSetCursorIcon SetCursorIcon{} = True +isSetCursorIcon _ = False + +-- | Removes a cursor icon setting from the stack. +isResetCursorIcon :: WidgetRequest s e -> Bool +isResetCursorIcon ResetCursorIcon{} = True +isResetCursorIcon _ = False + +{-| +Sets the current item being dragged and the message it carries. This message is +used by targets to check if they accept it or not. +-} +isStartDrag :: WidgetRequest s e -> Bool +isStartDrag StartDrag{} = True +isStartDrag _ = False + +-- | Cancels the current dragging process. +isStopDrag :: WidgetRequest s e -> Bool +isStopDrag StopDrag{} = True +isStopDrag _ = False + +{-| +Requests rendering a single frame. Rendering is not done at a fixed rate, in +order to reduce CPU usage. Widgets are responsible of requesting rendering at +points of interest. Mouse and keyboard events automatically generate render +requests, but the result of a WidgetTask does not. +-} +isRenderOnce :: WidgetRequest s e -> Bool +isRenderOnce RenderOnce{} = True +isRenderOnce _ = False + +{-| +Useful if a widget requires periodic rendering. An optional maximum number of +frames can be provided. +-} +isRenderEvery :: WidgetRequest s e -> Bool +isRenderEvery RenderEvery{} = True +isRenderEvery _ = False + +-- | Stops a previous periodic rendering request. +isRenderStop :: WidgetRequest s e -> Bool +isRenderStop RenderStop{} = True +isRenderStop _ = False + +-- | Requests to have an image removed from the renderer. +isRemoveRendererImage :: WidgetRequest s e -> Bool +isRemoveRendererImage RemoveRendererImage{} = True +isRemoveRendererImage _ = False + +{-| +Requests to exit the application. Can also be used to cancel a previous request +(or a window close). +-} +isExitApplication :: WidgetRequest s e -> Bool +isExitApplication ExitApplication{} = True +isExitApplication _ = False + +-- | Performs a "WindowRequest". +isUpdateWindow :: WidgetRequest s e -> Bool +isUpdateWindow UpdateWindow{} = True +isUpdateWindow _ = False + +-- | Request a model update. This usually involves lenses and "widgetDataSet". +isUpdateModel :: WidgetRequest s e -> Bool +isUpdateModel UpdateModel{} = True +isUpdateModel _ = False + +{-| +Updates the path of a given widget. Both "Monomer.Widgets.Single" and +"Monomer.Widgets.Container" handle this automatically. +-} +isSetWidgetPath :: WidgetRequest s e -> Bool +isSetWidgetPath SetWidgetPath{} = True +isSetWidgetPath _ = False + +-- | Clears an association between widgetId and path. +isResetWidgetPath :: WidgetRequest s e -> Bool +isResetWidgetPath ResetWidgetPath{} = True +isResetWidgetPath _ = False + +{-| +Raises a user event, which usually will be processed in handleEvent in a +"Monomer.Widgets.Composite" instance. +-} +isRaiseEvent :: WidgetRequest s e -> Bool +isRaiseEvent RaiseEvent{} = True +isRaiseEvent _ = False + +{-| +Sends a message to the given widgetId. If the target does not expect the +message's type, it will be ignored. +-} +isSendMessage :: WidgetRequest s e -> Bool +isSendMessage SendMessage{} = True +isSendMessage _ = False + +{-| +Runs an asynchronous tasks. It is mandatory to return a message that will be +sent to the task owner (this is the only way to feed data back). +-} +isRunTask :: WidgetRequest s e -> Bool +isRunTask RunTask{} = True +isRunTask _ = False + +{-| +Similar to RunTask, but can generate unlimited messages. This is useful for +WebSockets and similar data sources. It receives a function that with which to +send messagess to the producer owner. +-} +isRunProducer :: WidgetRequest s e -> Bool +isRunProducer RunProducer{} = True +isRunProducer _ = False + +-- | Checks if the request is either MoveFocus or SetFocus. +isFocusRequest :: WidgetRequest s e -> Bool +isFocusRequest MoveFocus{} = True +isFocusRequest SetFocus{} = True +isFocusRequest _ = False + +-- | Checks if the result contains a Resize request. +isResizeResult :: Maybe (WidgetResult s e) -> Bool +isResizeResult result = isJust resizeReq where + requests = maybe Empty (^. L.requests) result + resizeReq = Seq.findIndexL isResizeWidgets requests + +-- | Checks if the result contains a ResizeImmediate request. +isResizeImmediateResult :: Maybe (WidgetResult s e) -> Bool +isResizeImmediateResult result = isJust resizeReq where + requests = maybe Empty (^. L.requests) result + resizeReq = Seq.findIndexL isResizeWidgetsImmediate requests + +-- | Checks if the result contains any kind of resize request. +isResizeAnyResult :: Maybe (WidgetResult s e) -> Bool +isResizeAnyResult res = isResizeResult res || isResizeImmediateResult res + +-- | Checks if the platform is macOS +isMacOS :: WidgetEnv s e -> Bool +isMacOS wenv = _weOs wenv == "Mac OS X" + +-- | Returns a string description of a node and its children. +widgetTreeDesc :: Int -> WidgetNode s e -> String +widgetTreeDesc level node = desc where + desc = nodeDesc level node ++ "\n" ++ childDesc + childDesc = foldMap (widgetTreeDesc (level + 1)) (_wnChildren node) + +-- | Returns a string description of a node. +nodeDesc :: Int -> WidgetNode s e -> String +nodeDesc level node = infoDesc (_wnInfo node) where + spaces = replicate (level * 2) ' ' + infoDesc info = + spaces ++ "type: " ++ show (_wniWidgetType info) ++ "\n" ++ + spaces ++ "path: " ++ show (_wniPath info) ++ "\n" ++ + spaces ++ "vp: " ++ rectDesc (_wniViewport info) ++ "\n" ++ + spaces ++ "req: " ++ show (_wniSizeReqW info, _wniSizeReqH info) ++ "\n" + rectDesc r = show (_rX r, _rY r, _rW r, _rH r) + +-- | Returns a string description of a node info and its children. +widgetInstTreeDesc :: Int -> WidgetInstanceNode -> String +widgetInstTreeDesc level node = desc where + desc = nodeInstDesc level node ++ "\n" ++ childDesc + childDesc = foldMap (widgetInstTreeDesc (level + 1)) (_winChildren node) + +-- | Returns a string description of a node info. +nodeInstDesc :: Int -> WidgetInstanceNode -> String +nodeInstDesc level node = infoDesc (_winInfo node) where + spaces = replicate (level * 2) ' ' + infoDesc info = + spaces ++ "type: " ++ show (_wniWidgetType info) ++ "\n" ++ + spaces ++ "path: " ++ show (_wniPath info) ++ "\n" ++ + spaces ++ "vp: " ++ rectDesc (_wniViewport info) ++ "\n" ++ + spaces ++ "req: " ++ show (_wniSizeReqW info, _wniSizeReqH info) ++ "\n" + rectDesc r = show (_rX r, _rY r, _rW r, _rH r) + +-- | Returns a string description of a node info and its children, from a node. +treeInstDescFromNode :: WidgetEnv s e -> Int -> WidgetNode s e -> String +treeInstDescFromNode wenv level node = widgetInstTreeDesc level nodeInst where + nodeInst = widgetGetInstanceTree (node ^. L.widget) wenv node diff --git a/src/Monomer/Core/WidgetTypes.hs b/src/Monomer/Core/WidgetTypes.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Core/WidgetTypes.hs @@ -0,0 +1,719 @@ +{-| +Module : Monomer.Core.WidgetTypes +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Basic types and definitions for Widgets. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} + +module Monomer.Core.WidgetTypes where + +import Control.Concurrent (MVar) +import Control.Lens (ALens') +import Data.ByteString.Lazy (ByteString) +import Data.Default +import Data.Map.Strict (Map) +import Data.Sequence (Seq) +import Data.String (IsString(..)) +import Data.Text (Text) +import Data.Typeable (Typeable, typeOf) +import GHC.Generics + +import qualified Data.Text as T + +import Monomer.Common +import Monomer.Core.StyleTypes +import Monomer.Core.ThemeTypes +import Monomer.Event.Types +import Monomer.Graphics.Types + +-- | Time ellapsed since startup +type Timestamp = Int + +-- | Type constraints for a valid model +type WidgetModel s = Typeable s +-- | Type constraints for a valid event +type WidgetEvent e = Typeable e + +{-| +Map of WidgetKeys to WidgetNodes. This association is valid only in the context +of a Composite, with visibility of keys restricted to its scope. WidgetKeys +inside nested Composites are /not/ visible. +-} +type WidgetKeyMap s e = Map WidgetKey (WidgetNode s e) + +-- | Direction of focus movement. +data FocusDirection + = FocusFwd -- ^ Focus moving forward (usually left -> bottom). + | FocusBwd -- ^ Focus moving backward (usually right -> top). + deriving (Eq, Show) + +-- | "WidgetRequest" specfici for window related operations. +data WindowRequest + = WindowSetTitle Text -- ^ Sets the title of the window to the given text. + | WindowSetFullScreen -- ^ Switches to fullscreen mode. + | WindowMaximize -- ^ Maximizes the window. + | WindowMinimize -- ^ Minimizes the window. + | WindowRestore -- ^ Restores the window to its previous normal size. + | WindowBringToFront -- ^ Brings the window to the foreground. + deriving (Eq, Show) + +-- | Type of a widget. Used during the merge process. +newtype WidgetType + = WidgetType Text + deriving (Eq, Show, Generic) + +instance IsString WidgetType where + fromString = WidgetType . T.pack + +{-| +Widgets can receive/report data using lenses or direct values. Reporting +WidgetValue requires user events (in general, an onChange event). +-} +data WidgetData s a + = WidgetValue a -- ^ A direct value. + | WidgetLens (ALens' s a) -- ^ A lens into the parent model. + +{-| +Widgets instances have an associated path from the root, which is unique at a +specific moment. This path may change, since widgets could be added before or +after it (for example, an ordered list of items). WidgetId provides an +association from a unique identifier to the current valid path of an instanes, +made up of the timestamp when the instance was created and the path at that +time. + +Several WidgetRequests rely on this to find the destination of asynchronous +requests (tasks, clipboard, etc). +-} +data WidgetId = WidgetId { + _widTs :: Int, -- ^ The timestamp when the instance was created. + _widPath :: Path -- ^ The path at creation time. +} deriving (Eq, Show, Ord, Generic) + +instance Default WidgetId where + def = WidgetId 0 emptyPath + +{-| +During the merge process, widgets are matched based on WidgetType and WidgetKey. +By default and instance's key is null, which means any matching type will be +valid for merging. If you have items that can be reordered, using a key makes +sure merge picks the correct instances for merging. Keys should be unique within +the context of a Composite. Duplicate key behavior is undefined. +-} +newtype WidgetKey + = WidgetKey Text + deriving (Eq, Show, Ord, Generic) + +instance IsString WidgetKey where + fromString = WidgetKey . T.pack + +{-| +Wrapper of a Typeable instance representing the state of a widget. The widget is +in charge of casting to the correct type. +-} +data WidgetState + = forall i . WidgetModel i => WidgetState i + +instance Show WidgetState where + show (WidgetState state) = "WidgetState: " ++ show (typeOf state) + +{-| +Wrapper of a Typeable instance representing shared data between widgets. Used, +for example, by image widget to avoid loading the same image multiple times. The +widget is in charge of casting to the correct type. +-} +data WidgetShared + = forall i . Typeable i => WidgetShared i + +instance Show WidgetShared where + show (WidgetShared shared) = "WidgetShared: " ++ show (typeOf shared) + +{-| +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 incldued as part of WidgetResult in different points in the +lifecycle of a widget. +-} +data WidgetRequest s e + -- | Ignore events generated by the parent. Could be used to consume the tab + -- | key and avoid having the focus move to the next widget. + = IgnoreParentEvents + -- | Ignore children events. Scroll relies on this to handle click/wheel. + | IgnoreChildrenEvents + -- | The widget content changed and requires a different size. Processed at + -- | the end of the cycle, since several widgets may request it. + | ResizeWidgets WidgetId + -- | The widget content changed and requires a different size. Processed + -- | immediately. Avoid if possible, since it can affect performance. + | ResizeWidgetsImmediate WidgetId + -- | Moves the focus, optionally indicating a starting widgetId. + | MoveFocus (Maybe WidgetId) FocusDirection + -- | Sets the focus to the given widgetId. + | SetFocus WidgetId + -- | Requests the clipboard contents. It will be received as a SystemEvent. + | GetClipboard WidgetId + -- | Sets the clipboard to the given ClipboardData. + | SetClipboard ClipboardData + -- | Sets the viewport which should be remain visible when an on-screen + -- | keyboard is displayed. Required for mobile. + | StartTextInput Rect + -- | Resets the keyboard viewport, + | StopTextInput + -- | Sets a widget as the base target of future events. This is used by the + -- | dropdown component to handle list events (which is on top of everything). + | SetOverlay WidgetId Path + -- | Removes the existing overlay. + | ResetOverlay WidgetId + -- | Sets the current active cursor icon. This acts as a stack, so removing + -- | means going back a step. + | SetCursorIcon WidgetId CursorIcon + -- | Removes a cursor icon setting from the stack. + | ResetCursorIcon WidgetId + -- | Sets the current item being dragged and the message it carries. This + -- | message is used by targets to check if they accept it or not. + | StartDrag WidgetId Path WidgetDragMsg + -- | Cancels the current dragging process. + | StopDrag WidgetId + -- | Requests rendering a single frame. Rendering is not done at a fixed rate, + -- | in order to reduce CPU usage. Widgets are responsible of requesting + -- | rendering at points of interest. Mouse and keyboard events automatically + -- | generate render requests, but the result of a WidgetTask does not. + | RenderOnce + -- | Useful if a widget requires periodic rendering. An optional maximum + -- | number of frames can be provided. + | RenderEvery WidgetId Int (Maybe Int) + -- | Stops a previous periodic rendering request. + | RenderStop WidgetId + {-| + Requests an image to be removed from the Renderer. In general, used in the + dispose function. + -} + | RemoveRendererImage Text + -- | Requests to exit the application. Can also be used to cancel a previous + -- | request (or a window close). + | ExitApplication Bool + -- | Performs a "WindowRequest". + | UpdateWindow WindowRequest + -- | Request a model update. This usually involves lenses and "widgetDataSet". + | UpdateModel (s -> s) + -- | Updates the path of a given widget. Both "Monomer.Widgets.Single" and + -- | "Monomer.Widgets.Container" handle this automatically. + | SetWidgetPath WidgetId Path + -- | Clears an association between widgetId and path. + | ResetWidgetPath WidgetId + -- | Raises a user event, which usually will be processed in handleEvent in a + -- | "Monomer.Widgets.Composite" instance. + | WidgetEvent e => RaiseEvent e + -- | Sends a message to the given widgetId. If the target does not expect the + -- | message's type, it will be ignored. + | forall i . Typeable i => SendMessage WidgetId i + -- | Runs an asynchronous tasks. It is mandatory to return a message that will + -- | be sent to the task owner (this is the only way to feed data back). + | forall i . Typeable i => RunTask WidgetId Path (IO i) + -- | Similar to RunTask, but can generate unlimited messages. This is useful + -- | for WebSockets and similar data sources. It receives a function that + -- | with which to send messagess to the producer owner. + | forall i . Typeable i => RunProducer WidgetId Path ((i -> IO ()) -> IO ()) + +instance Eq e => Eq (WidgetRequest s e) where + IgnoreParentEvents == IgnoreParentEvents = True + IgnoreChildrenEvents == IgnoreChildrenEvents = True + ResizeWidgets w1 == ResizeWidgets w2 = w1 == w2 + ResizeWidgetsImmediate w1 == ResizeWidgetsImmediate w2 = w1 == w2 + MoveFocus w1 fd1 == MoveFocus w2 fd2 = (w1, fd1) == (w2, fd2) + SetFocus w1 == SetFocus w2 = w1 == w2 + GetClipboard w1 == GetClipboard w2 = w1 == w2 + SetClipboard c1 == SetClipboard c2 = c1 == c2 + StartTextInput r1 == StartTextInput r2 = r1 == r2 + StopTextInput == StopTextInput = True + SetOverlay w1 p1 == SetOverlay w2 p2 = (w1, p1) == (w2, p2) + ResetOverlay w1 == ResetOverlay w2 = w1 == w2 + SetCursorIcon w1 c1 == SetCursorIcon w2 c2 = (w1, c1) == (w2, c2) + ResetCursorIcon w1 == ResetCursorIcon w2 = w1 == w2 + StartDrag w1 p1 m1 == StartDrag w2 p2 m2 = (w1, p1, m1) == (w2, p2, m2) + StopDrag w1 == StopDrag w2 = w1 == w2 + RenderOnce == RenderOnce = True + RenderEvery p1 c1 r1 == RenderEvery p2 c2 r2 = (p1, c1, r1) == (p2, c2, r2) + RenderStop p1 == RenderStop p2 = p1 == p2 + ExitApplication e1 == ExitApplication e2 = e1 == e2 + UpdateWindow w1 == UpdateWindow w2 = w1 == w2 + SetWidgetPath w1 p1 == SetWidgetPath w2 p2 = (w1, p1) == (w2, p2) + ResetWidgetPath w1 == ResetWidgetPath w2 = w1 == w2 + RaiseEvent e1 == RaiseEvent e2 = e1 == e2 + _ == _ = False + +{-| +Result of widget operations (init, merge, handleEvent, etc). The node is +mandatory. The "resultNode", "resultEvts", "resultReqs" and "resultReqsEvts" +helper functions can also be used. + +In general a result starts in a child widget, but parent widgets can append +requets or new versions of themselves. +-} +data WidgetResult s e = WidgetResult { + _wrNode :: WidgetNode s e, -- ^ The updated widget node. + _wrRequests :: Seq (WidgetRequest s e) -- ^ The widget requests. +} + +-- This instance is lawless (there is not an empty widget): use with caution +instance Semigroup (WidgetResult s e) where + er1 <> er2 = WidgetResult { + _wrNode = _wrNode er2, + _wrRequests = _wrRequests er1 <> _wrRequests er2 + } + +-- | Used to indicate active layout direction. Some widgets, such as spacer, +-- | can use it to adapt themselves. +data LayoutDirection + = LayoutNone + | LayoutHorizontal + | LayoutVertical + deriving (Eq, Show, Generic) + +-- | The widget environment. This includes system information, active viewport, +-- | and input status among other things. +data WidgetEnv s e = WidgetEnv { + -- | The OS of the host. + _weOs :: Text, + -- | Provides helper funtions for calculating text size. + _weFontManager :: FontManager, + -- | Returns the information of a node given a path from root, if any. + _weFindByPath :: Path -> Maybe WidgetNodeInfo, + -- | The mouse button that is considered main. + _weMainButton :: Button, + -- | The mouse button that is considered as secondary or context button. + _weContextButton :: Button, + -- | The active theme. Some widgets derive their base style from this. + _weTheme :: Theme, + -- | The main window size. + _weWindowSize :: Size, + -- | The active map of shared data. + _weWidgetShared :: MVar (Map Text WidgetShared), + -- | The active map of WidgetKey -> WidgetNode, if any. + _weWidgetKeyMap :: WidgetKeyMap s e, + -- | The currently hovered path, if any. + _weHoveredPath :: Maybe Path, + -- | The currently focused path. There's always one, even if it's root. + _weFocusedPath :: Path, + -- | The current overlay path, if any. + _weOverlayPath :: Maybe Path, + -- | The current drag message and source path, if any is active. + _weDragStatus :: Maybe (Path, WidgetDragMsg), + -- | Indicates the path and position where the main button was pressed. + _weMainBtnPress :: Maybe (Path, Point), + -- | The current active cursor, and the path that set it. + _weCursor :: Maybe (Path, CursorIcon), + -- | The current user model. + _weModel :: s, + -- | The input status, mainly mouse and keyboard. + _weInputStatus :: InputStatus, + -- | The timestamp when this cycle started. + _weTimestamp :: Timestamp, + {-| + Whether the theme changed in this cycle. Should be considered when a widget + avoids merging as optimization, as the styles may have changed. + -} + _weThemeChanged :: Bool, + -- | Indicates whether the current widget is in a top layer (zstack). + _weInTopLayer :: Point -> Bool, + -- | The current layout direction. + _weLayoutDirection :: LayoutDirection, + {-| + The active viewport. This may be smaller than the widget's viewport, if it's + currently inside a scroll or similar. + -} + _weViewport :: Rect, + -- | The current accumulated offset. This can be affected by scroll. + _weOffset :: Point +} + +-- | Complementary information to a Widget, forming a node in the view tree. +data WidgetNodeInfo = + WidgetNodeInfo { + -- | Type of the widget. + _wniWidgetType :: !WidgetType, + -- | The identifier at creation time of the widget (runtime generated). + _wniWidgetId :: !WidgetId, + -- | Key/Identifier of the widget (user provided). Used for merging. + _wniKey :: Maybe WidgetKey, + -- | The path of the instance in the widget tree, as a set of indexes. + _wniPath :: !Path, + -- | The requested width for the widget. The one in style takes precedence. + _wniSizeReqW :: !SizeReq, + -- | The requested height for the widget. The one in style takes precedence. + _wniSizeReqH :: !SizeReq, + -- | Indicates if the widget is enabled for user interaction. + _wniEnabled :: !Bool, + -- | Indicates if the widget is visible. + _wniVisible :: !Bool, + -- | Indicates whether the widget can receive focus. + _wniFocusable :: !Bool, + {-| + The area of the screen where the widget can draw. Could be out of bounds or + partially invisible if inside a scroll. The viewport on 'WidgetEnv' defines + what is currently visible. + -} + _wniViewport :: !Rect, + -- | Style attributes of the widget instance. + _wniStyle :: Style + } deriving (Eq, Show, Generic) + +instance Default WidgetNodeInfo where + def = WidgetNodeInfo { + _wniWidgetType = WidgetType (T.pack ""), + _wniWidgetId = def, + _wniKey = Nothing, + _wniPath = emptyPath, + _wniSizeReqW = def, + _wniSizeReqH = def, + _wniEnabled = True, + _wniVisible = True, + _wniFocusable = False, + _wniViewport = def, + _wniStyle = def + } + +-- | An instance of the widget in the widget tree. +data WidgetNode s e = WidgetNode { + -- | The actual widget. + _wnWidget :: Widget s e, + -- | Information about the instance. + _wnInfo :: WidgetNodeInfo, + -- | The children widgets, if any. + _wnChildren :: Seq (WidgetNode s e) +} + +{-| +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". +-} +data WidgetInstanceNode = WidgetInstanceNode { + -- | Information about the instance. + _winInfo :: WidgetNodeInfo, + -- | The widget state, if any. + _winState :: Maybe WidgetState, + -- | The children widget, if any. + _winChildren :: Seq WidgetInstanceNode +} deriving (Show, Generic) + +{-| +Main widget type. This is the type all widgets implement. In general it's not +needed to implement this type directly, and it's easier to use +"Monomer.Widgets.Container" for widgets with children elements and +"Monomer.Widgets.Single" for widgets without children. +-} +data Widget s e = + Widget { + {-| + Initializes the given node. This could include rebuilding the widget in + case internal state needs to use model/environment information, generate + user events or make requests to the runtime. + + Arguments: + + - The widget environment. + - The widget node. + + Returns: + + - The result of the init operation. + -} + widgetInit + :: WidgetEnv s e + -> WidgetNode s e + -> WidgetResult s e, + {-| + Merges the current node with the node it matched with during the merge + process. Receives the newly created node (whose *init* function is not + called), the previous node and the state extracted from that node. This + process is widget dependent, and may use or ignore the previous state + depending on newly available information. + + In general, you want to at least keep the previous state unless the widget + is stateless or only consumes model/environment information. + + Arguments: + + - The widget environment. + - The widget node. + - The previous widget node. + + Returns: + + - The result of the merge operation. + -} + widgetMerge + :: WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e + -> WidgetResult s e, + {-| + Disposes the current node. Only used by widgets which allocate resources + during /init/ or /merge/, and will usually involve requests to the runtime. + + Arguments: + + - The widget environment. + - The widget node. + + Returns: + + - The result of the dispose operation. + -} + widgetDispose + :: WidgetEnv s e + -> WidgetNode s e + -> WidgetResult s e, + {-| + Returns the current internal state, which can later be used when during the + merge process. + + Arguments: + + - The widget environment. + - The widget node. + + Returns: + + - The internal state, if any. + -} + widgetGetState + :: WidgetEnv s e + -> WidgetNode s e + -> Maybe WidgetState, + {-| + Returns information about the instance and its children. + + Arguments: + + - The widget environment. + - The widget node. + + Returns: + + - The untyped node information. + -} + widgetGetInstanceTree + :: WidgetEnv s e + -> WidgetNode s e + -> WidgetInstanceNode, + {-| + Returns the next focusable node. What next/previous is, depends on how the + widget works. Moving right -> bottom is usually considered forward. + + Arguments: + + - The widget environment. + - The widget node. + - The direction in which focus is moving. + - The path to start the search from. + + Returns: + + - The next focusable node info. + -} + widgetFindNextFocus + :: WidgetEnv s e + -> WidgetNode s e + -> FocusDirection + -> Path + -> Maybe WidgetNodeInfo, + {-| + Returns the currently hovered widget, if any. + + Arguments: + + - The widget environment. + - The widget node. + - The path to start the search from. + - The point to test for. + + Returns: + + - The hovered child index, if any. + -} + widgetFindByPoint + :: WidgetEnv s e + -> WidgetNode s e + -> Path + -> Point + -> Maybe WidgetNodeInfo, + {-| + Returns the widget matching the given path, plus all its parents. + + Arguments: + + - The widget environment. + - The widget node. + - The path to search for. + + Returns: + + - The sequence of widgets up to path, ordered from root to target. + -} + widgetFindBranchByPath + :: WidgetEnv s e + -> WidgetNode s e + -> Path + -> Seq WidgetNodeInfo, + {-| + Receives a System event and, optionally, returns a result. This can include + an updated version of the widget (in case it has internal state), user + events or requests to the runtime. + + Arguments: + + - The widget environment. + - The widget node. + - The target path of the event. + - The SystemEvent to handle. + + Returns: + + - The result of handling the event, if any. + -} + widgetHandleEvent + :: WidgetEnv s e + -> WidgetNode s e + -> Path + -> SystemEvent + -> Maybe (WidgetResult s e), + {-| + Receives a message and, optionally, returns a result. This can include an + updated version of the widget (in case it has internal state), user events + or requests to the runtime. There is no validation regarding the message + type, and the widget should take care of _casting_ to the correct type using + "Data.Typeable.cast" + + Arguments: + + - The widget environment. + - The widget node. + - The target path of the message. + - The message to handle. + + Returns: + + - The result of handling the message, if any. + -} + widgetHandleMessage + :: forall i . Typeable i + => WidgetEnv s e + -> WidgetNode s e + -> Path + -> i + -> Maybe (WidgetResult s e), + {-| + Returns the preferred size for the widget. + + Arguments: + + - The widget environment. + - The widget node. + + Returns: + + - The horizontal and vertical requirements. + -} + widgetGetSizeReq + :: WidgetEnv s e + -> WidgetNode s e + -> (SizeReq, SizeReq), + {-| + Resizes the widget to the provided size. + + Arguments: + + - The widget environment. + - The widget node. + - The new viewport. + - Checks if a given path, or its children, requested resize. + + Returns: + + - The result of resizing the widget. + -} + widgetResize + :: WidgetEnv s e + -> WidgetNode s e + -> Rect + -> (Path -> Bool) + -> WidgetResult s e, + {-| + Renders the widget's content using the given Renderer. + + Arguments: + + - The widget environment. + - The widget node. + - The renderer, providing low level drawing functions. + + Returns: + + - The IO action with rendering instructions. + -} + widgetRender + :: WidgetEnv s e + -> WidgetNode s e + -> Renderer + -> IO () + } + +instance Show (WidgetRequest s e) where + show IgnoreParentEvents = "IgnoreParentEvents" + show IgnoreChildrenEvents = "IgnoreChildrenEvents" + show (ResizeWidgets wid) = "ResizeWidgets: " ++ show wid + show (ResizeWidgetsImmediate wid) = "ResizeWidgetsImmediate: " ++ show wid + show (MoveFocus start dir) = "MoveFocus: " ++ show (start, dir) + show (SetFocus path) = "SetFocus: " ++ show path + show (GetClipboard wid) = "GetClipboard: " ++ show wid + show (SetClipboard _) = "SetClipboard" + show (StartTextInput rect) = "StartTextInput: " ++ show rect + show StopTextInput = "StopTextInput" + show (SetOverlay wid path) = "SetOverlay: " ++ show (wid, path) + show (ResetOverlay wid) = "ResetOverlay: " ++ show wid + show (SetCursorIcon wid icon) = "SetCursorIcon: " ++ show (wid, icon) + show (ResetCursorIcon wid) = "ResetCursorIcon: " ++ show wid + show (StartDrag wid path info) = "StartDrag: " ++ show (wid, path, info) + show (StopDrag wid) = "StopDrag: " ++ show wid + show RenderOnce = "RenderOnce" + show (RenderEvery wid ms repeat) = "RenderEvery: " ++ show (wid, ms, repeat) + show (RenderStop wid) = "RenderStop: " ++ show wid + show (RemoveRendererImage name) = "RemoveRendererImage: " ++ show name + show ExitApplication{} = "ExitApplication" + show (UpdateWindow req) = "UpdateWindow: " ++ show req + show UpdateModel{} = "UpdateModel" + show (SetWidgetPath wid path) = "SetWidgetPath: " ++ show (wid, path) + show (ResetWidgetPath wid) = "ResetWidgetPath: " ++ show wid + show RaiseEvent{} = "RaiseEvent" + show SendMessage{} = "SendMessage" + show RunTask{} = "RunTask" + show RunProducer{} = "RunProducer" + +instance Show (WidgetResult s e) where + show result = "WidgetResult " + ++ "{ _wrRequests: " ++ show (_wrRequests result) + ++ ", _wrNode: " ++ show (_wrNode result) + ++ " }" + +instance Show (WidgetEnv s e) where + show wenv = "WidgetEnv " + ++ "{ _weOs: " ++ show (_weOs wenv) + ++ ", _weWindowSize: " ++ show (_weWindowSize wenv) + ++ ", _weFocusedPath: " ++ show (_weFocusedPath wenv) + ++ ", _weTimestamp: " ++ show (_weTimestamp wenv) + ++ " }" + +instance Show (WidgetNode s e) where + show node = "WidgetNode " + ++ "{ _wnInfo: " ++ show (_wnInfo node) + ++ ", _wnChildren: " ++ show (_wnChildren node) + ++ " }" diff --git a/src/Monomer/Event.hs b/src/Monomer/Event.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Event.hs @@ -0,0 +1,21 @@ +{-| +Module : Monomer.Event +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Event module, including all related types and utility functions. Based on SDL. +-} +module Monomer.Event ( + module Monomer.Event.Core, + module Monomer.Event.Keyboard, + module Monomer.Event.Types, + module Monomer.Event.Util +) where + +import Monomer.Event.Core +import Monomer.Event.Keyboard +import Monomer.Event.Types +import Monomer.Event.Util diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Event/Core.hs @@ -0,0 +1,139 @@ +{-| +Module : Monomer.Event.Core +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Core functions for SDL event processing and conversion. +-} +module Monomer.Event.Core ( + isActionEvent, + convertEvents, + translateEvent +) where + +import Control.Applicative ((<|>)) +import Data.Maybe (catMaybes, fromMaybe) + +import qualified Data.Map.Strict as M +import qualified SDL + +import Monomer.Common +import Monomer.Event.Keyboard +import Monomer.Event.Types + +{-| +Checks if an SDL event is an action event. Currently only mouse and keyboard +events are considered as such (touch events should be added in the future). This +is used for triggering automatic rendering of a frame. For other events, widgets +must request rendering explicitly. +-} +isActionEvent :: SDL.EventPayload -> Bool +isActionEvent SDL.MouseButtonEvent{} = True +isActionEvent SDL.MouseWheelEvent{} = True +isActionEvent SDL.KeyboardEvent{} = True +isActionEvent SDL.TextInputEvent{} = True +isActionEvent _ = False + +-- | Converts SDL events to Monomer's SystemEvent +convertEvents + :: Double -- ^ Device pixel rate. + -> Double -- ^ Event pixel rate. + -> Point -- ^ Mouse position. + -> [SDL.EventPayload] -- ^ List of SDL events. + -> [SystemEvent] -- ^ List of Monomer events. +convertEvents dpr epr mousePos events = catMaybes convertedEvents where + convertedEvents = fmap convertEvent events + convertEvent evt = + mouseMoveEvent mousePos evt + <|> mouseClick mousePos evt + <|> mouseWheelEvent epr mousePos evt + <|> mouseMoveLeave mousePos evt + <|> keyboardEvent evt + <|> textEvent evt + +-- | Adds a given offset to mouse related SystemEvents. +translateEvent + :: Point -- ^ Offset to apply + -> SystemEvent -- ^ Source SystemEvent + -> SystemEvent -- ^ Updated SystemEvent +translateEvent offset evt = case evt of + Click p btn cl -> Click (addPoint p offset) btn cl + ButtonAction p btn st cl -> ButtonAction (addPoint p offset) btn st cl + WheelScroll p wxy dir -> WheelScroll (addPoint p offset) wxy dir + Enter p -> Enter (addPoint p offset) + Move p -> Move (addPoint p offset) + Leave p -> Leave (addPoint p offset) + Drag p path msg -> Drag (addPoint p offset) path msg + Drop p path msg -> Drop (addPoint p offset) path msg + _ -> evt + +mouseClick :: Point -> SDL.EventPayload -> Maybe SystemEvent +mouseClick mousePos (SDL.MouseButtonEvent eventData) = systemEvent where + button = case SDL.mouseButtonEventButton eventData of + SDL.ButtonLeft -> Just BtnLeft + SDL.ButtonRight -> Just BtnRight + _ -> Nothing + + action = case SDL.mouseButtonEventMotion eventData of + SDL.Pressed -> BtnPressed + SDL.Released -> BtnReleased + + clicks = fromIntegral $ SDL.mouseButtonEventClicks eventData + systemEvent = fmap (\btn -> ButtonAction mousePos btn action clicks) button +mouseClick _ _ = Nothing + +mouseMoveEvent :: Point -> SDL.EventPayload -> Maybe SystemEvent +mouseMoveEvent mousePos (SDL.MouseMotionEvent _) = Just $ Move mousePos +mouseMoveEvent mousePos _ = Nothing + +mouseMoveLeave :: Point -> SDL.EventPayload -> Maybe SystemEvent +mouseMoveLeave mousePos SDL.WindowLostMouseFocusEvent{} = evt where + evt = Just $ Move (Point (-1) (-1)) +mouseMoveLeave mousePos _ = Nothing + +mouseWheelEvent :: Double -> Point -> SDL.EventPayload -> Maybe SystemEvent +mouseWheelEvent epr mousePos (SDL.MouseWheelEvent eventData) = systemEvent where + wheelDirection = case SDL.mouseWheelEventDirection eventData of + SDL.ScrollNormal -> WheelNormal + SDL.ScrollFlipped -> WheelFlipped + SDL.V2 x y = SDL.mouseWheelEventPos eventData + wheelDelta = Point (fromIntegral x * epr) (fromIntegral y * epr) + + systemEvent = case SDL.mouseWheelEventWhich eventData of + SDL.Mouse _ -> Just $ WheelScroll mousePos wheelDelta wheelDirection + SDL.Touch -> Nothing +mouseWheelEvent epr mousePos _ = Nothing + +keyboardEvent :: SDL.EventPayload -> Maybe SystemEvent +keyboardEvent (SDL.KeyboardEvent eventData) = Just keyAction where + keySym = SDL.keyboardEventKeysym eventData + keyMod = convertKeyModifier $ SDL.keysymModifier keySym + keyCode = SDL.unwrapKeycode $ SDL.keysymKeycode keySym + keyStatus = case SDL.keyboardEventKeyMotion eventData of + SDL.Pressed -> KeyPressed + SDL.Released -> KeyReleased + keyAction = KeyAction keyMod (KeyCode $ fromIntegral keyCode) keyStatus +keyboardEvent _ = Nothing + +textEvent :: SDL.EventPayload -> Maybe SystemEvent +textEvent (SDL.TextInputEvent input) = Just textInput where + textInput = TextInput (SDL.textInputEventText input) +textEvent _ = Nothing + +convertKeyModifier :: SDL.KeyModifier -> KeyMod +convertKeyModifier keyMod = KeyMod { + _kmLeftShift = SDL.keyModifierLeftShift keyMod, + _kmRightShift = SDL.keyModifierRightShift keyMod, + _kmLeftCtrl = SDL.keyModifierLeftCtrl keyMod, + _kmRightCtrl = SDL.keyModifierRightCtrl keyMod, + _kmLeftAlt = SDL.keyModifierLeftAlt keyMod, + _kmRightAlt = SDL.keyModifierRightAlt keyMod, + _kmLeftGUI = SDL.keyModifierLeftGUI keyMod, + _kmRightGUI = SDL.keyModifierRightGUI keyMod, + _kmNumLock = SDL.keyModifierNumLock keyMod, + _kmCapsLock = SDL.keyModifierCapsLock keyMod, + _kmAltGr = SDL.keyModifierAltGr keyMod +} diff --git a/src/Monomer/Event/Keyboard.hs b/src/Monomer/Event/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Event/Keyboard.hs @@ -0,0 +1,659 @@ +{-| +Module : Monomer.Event.Keyboard +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Keycodes for all keyboard keys. +-} +module Monomer.Event.Keyboard where + +import qualified SDL + +import Monomer.Event.Types + +getKeyCode :: SDL.Keycode -> KeyCode +getKeyCode keyCode = KeyCode $ fromIntegral (SDL.unwrapKeycode keyCode) + +-- Mod Keys +keyLAlt :: KeyCode +keyLAlt = getKeyCode SDL.KeycodeLAlt + +keyRAlt :: KeyCode +keyRAlt = getKeyCode SDL.KeycodeLAlt + +keyLCtrl :: KeyCode +keyLCtrl = getKeyCode SDL.KeycodeLCtrl + +keyRCtrl :: KeyCode +keyRCtrl = getKeyCode SDL.KeycodeLCtrl + +keyLGUI :: KeyCode +keyLGUI = getKeyCode SDL.KeycodeLGUI + +keyRGUI :: KeyCode +keyRGUI = getKeyCode SDL.KeycodeLGUI + +keyLShift :: KeyCode +keyLShift = getKeyCode SDL.KeycodeLShift + +keyRShift :: KeyCode +keyRShift = getKeyCode SDL.KeycodeLShift + +-- General keys +keyUnknown :: KeyCode +keyUnknown = getKeyCode SDL.KeycodeUnknown + +keyReturn :: KeyCode +keyReturn = getKeyCode SDL.KeycodeReturn + +keyEscape :: KeyCode +keyEscape = getKeyCode SDL.KeycodeEscape + +keyBackspace :: KeyCode +keyBackspace = getKeyCode SDL.KeycodeBackspace + +keyTab :: KeyCode +keyTab = getKeyCode SDL.KeycodeTab + +keySpace :: KeyCode +keySpace = getKeyCode SDL.KeycodeSpace + +keyExclaim :: KeyCode +keyExclaim = getKeyCode SDL.KeycodeExclaim + +keyQuoteDbl :: KeyCode +keyQuoteDbl = getKeyCode SDL.KeycodeQuoteDbl + +keyHash :: KeyCode +keyHash = getKeyCode SDL.KeycodeHash + +keyPercent :: KeyCode +keyPercent = getKeyCode SDL.KeycodePercent + +keyDollar :: KeyCode +keyDollar = getKeyCode SDL.KeycodeDollar + +keyAmpersand :: KeyCode +keyAmpersand = getKeyCode SDL.KeycodeAmpersand + +keyQuote :: KeyCode +keyQuote = getKeyCode SDL.KeycodeQuote + +keyLeftParen :: KeyCode +keyLeftParen = getKeyCode SDL.KeycodeLeftParen + +keyRightParen :: KeyCode +keyRightParen = getKeyCode SDL.KeycodeRightParen + +keyAsterisk :: KeyCode +keyAsterisk = getKeyCode SDL.KeycodeAsterisk + +keyPlus :: KeyCode +keyPlus = getKeyCode SDL.KeycodePlus + +keyComma :: KeyCode +keyComma = getKeyCode SDL.KeycodeComma + +keyMinus :: KeyCode +keyMinus = getKeyCode SDL.KeycodeMinus + +keyPeriod :: KeyCode +keyPeriod = getKeyCode SDL.KeycodePeriod + +keySlash :: KeyCode +keySlash = getKeyCode SDL.KeycodeSlash + +keyColon :: KeyCode +keyColon = getKeyCode SDL.KeycodeColon + +keySemicolon :: KeyCode +keySemicolon = getKeyCode SDL.KeycodeSemicolon + +keyLess :: KeyCode +keyLess = getKeyCode SDL.KeycodeLess + +keyEquals :: KeyCode +keyEquals = getKeyCode SDL.KeycodeEquals + +keyGreater :: KeyCode +keyGreater = getKeyCode SDL.KeycodeGreater + +keyQuestion :: KeyCode +keyQuestion = getKeyCode SDL.KeycodeQuestion + +keyAt :: KeyCode +keyAt = getKeyCode SDL.KeycodeAt + +keyLeftBracket :: KeyCode +keyLeftBracket = getKeyCode SDL.KeycodeLeftBracket + +keyBackslash :: KeyCode +keyBackslash = getKeyCode SDL.KeycodeBackslash + +keyRightBracket :: KeyCode +keyRightBracket = getKeyCode SDL.KeycodeRightBracket + +keyCaret :: KeyCode +keyCaret = getKeyCode SDL.KeycodeCaret + +keyUnderscore :: KeyCode +keyUnderscore = getKeyCode SDL.KeycodeUnderscore + +keyBackquote :: KeyCode +keyBackquote = getKeyCode SDL.KeycodeBackquote + +keyCapsLock :: KeyCode +keyCapsLock = getKeyCode SDL.KeycodeCapsLock + +keyPrintScreen :: KeyCode +keyPrintScreen = getKeyCode SDL.KeycodePrintScreen + +keyScrollLock :: KeyCode +keyScrollLock = getKeyCode SDL.KeycodeScrollLock + +keyPause :: KeyCode +keyPause = getKeyCode SDL.KeycodePause + +keyInsert :: KeyCode +keyInsert = getKeyCode SDL.KeycodeInsert + +keyHome :: KeyCode +keyHome = getKeyCode SDL.KeycodeHome + +keyPageUp :: KeyCode +keyPageUp = getKeyCode SDL.KeycodePageUp + +keyDelete :: KeyCode +keyDelete = getKeyCode SDL.KeycodeDelete + +keyEnd :: KeyCode +keyEnd = getKeyCode SDL.KeycodeEnd + +keyPageDown :: KeyCode +keyPageDown = getKeyCode SDL.KeycodePageDown + +keyRight :: KeyCode +keyRight = getKeyCode SDL.KeycodeRight + +keyLeft :: KeyCode +keyLeft = getKeyCode SDL.KeycodeLeft + +keyDown :: KeyCode +keyDown = getKeyCode SDL.KeycodeDown + +keyUp :: KeyCode +keyUp = getKeyCode SDL.KeycodeUp + +keyNumLockClear :: KeyCode +keyNumLockClear = getKeyCode SDL.KeycodeNumLockClear + +-- Numbers +key0 :: KeyCode +key0 = getKeyCode SDL.Keycode0 + +key1 :: KeyCode +key1 = getKeyCode SDL.Keycode1 + +key2 :: KeyCode +key2 = getKeyCode SDL.Keycode2 + +key3 :: KeyCode +key3 = getKeyCode SDL.Keycode3 + +key4 :: KeyCode +key4 = getKeyCode SDL.Keycode4 + +key5 :: KeyCode +key5 = getKeyCode SDL.Keycode5 + +key6 :: KeyCode +key6 = getKeyCode SDL.Keycode6 + +key7 :: KeyCode +key7 = getKeyCode SDL.Keycode7 + +key8 :: KeyCode +key8 = getKeyCode SDL.Keycode8 + +key9 :: KeyCode +key9 = getKeyCode SDL.Keycode9 + +-- Function keys +keyF1 :: KeyCode +keyF1 = getKeyCode SDL.KeycodeF1 + +keyF2 :: KeyCode +keyF2 = getKeyCode SDL.KeycodeF2 + +keyF3 :: KeyCode +keyF3 = getKeyCode SDL.KeycodeF3 + +keyF4 :: KeyCode +keyF4 = getKeyCode SDL.KeycodeF4 + +keyF5 :: KeyCode +keyF5 = getKeyCode SDL.KeycodeF5 + +keyF6 :: KeyCode +keyF6 = getKeyCode SDL.KeycodeF6 + +keyF7 :: KeyCode +keyF7 = getKeyCode SDL.KeycodeF7 + +keyF8 :: KeyCode +keyF8 = getKeyCode SDL.KeycodeF8 + +keyF9 :: KeyCode +keyF9 = getKeyCode SDL.KeycodeF9 + +keyF10 :: KeyCode +keyF10 = getKeyCode SDL.KeycodeF10 + +keyF11 :: KeyCode +keyF11 = getKeyCode SDL.KeycodeF11 + +keyF12 :: KeyCode +keyF12 = getKeyCode SDL.KeycodeF12 + +-- Letters +keyA :: KeyCode +keyA = getKeyCode SDL.KeycodeA + +keyB :: KeyCode +keyB = getKeyCode SDL.KeycodeB + +keyC :: KeyCode +keyC = getKeyCode SDL.KeycodeC + +keyD :: KeyCode +keyD = getKeyCode SDL.KeycodeD + +keyE :: KeyCode +keyE = getKeyCode SDL.KeycodeE + +keyF :: KeyCode +keyF = getKeyCode SDL.KeycodeF + +keyG :: KeyCode +keyG = getKeyCode SDL.KeycodeG + +keyH :: KeyCode +keyH = getKeyCode SDL.KeycodeH + +keyI :: KeyCode +keyI = getKeyCode SDL.KeycodeI + +keyJ :: KeyCode +keyJ = getKeyCode SDL.KeycodeJ + +keyK :: KeyCode +keyK = getKeyCode SDL.KeycodeK + +keyL :: KeyCode +keyL = getKeyCode SDL.KeycodeL + +keyM :: KeyCode +keyM = getKeyCode SDL.KeycodeM + +keyN :: KeyCode +keyN = getKeyCode SDL.KeycodeN + +keyO :: KeyCode +keyO = getKeyCode SDL.KeycodeO + +keyP :: KeyCode +keyP = getKeyCode SDL.KeycodeP + +keyQ :: KeyCode +keyQ = getKeyCode SDL.KeycodeQ + +keyR :: KeyCode +keyR = getKeyCode SDL.KeycodeR + +keyS :: KeyCode +keyS = getKeyCode SDL.KeycodeS + +keyT :: KeyCode +keyT = getKeyCode SDL.KeycodeT + +keyU :: KeyCode +keyU = getKeyCode SDL.KeycodeU + +keyV :: KeyCode +keyV = getKeyCode SDL.KeycodeV + +keyW :: KeyCode +keyW = getKeyCode SDL.KeycodeW + +keyX :: KeyCode +keyX = getKeyCode SDL.KeycodeX + +keyY :: KeyCode +keyY = getKeyCode SDL.KeycodeY + +keyZ :: KeyCode +keyZ = getKeyCode SDL.KeycodeZ + +-- + +-- Mod keys +isKeyLAlt :: KeyCode -> Bool +isKeyLAlt = (== keyLAlt) + +isKeyRAlt :: KeyCode -> Bool +isKeyRAlt = (== keyRAlt) + +isKeyLCtrl :: KeyCode -> Bool +isKeyLCtrl = (== keyLCtrl) + +isKeyRCtrl :: KeyCode -> Bool +isKeyRCtrl = (== keyRCtrl) + +isKeyLGUI :: KeyCode -> Bool +isKeyLGUI = (== keyLGUI) + +isKeyRGUI :: KeyCode -> Bool +isKeyRGUI = (== keyRGUI) + +isKeyLShift :: KeyCode -> Bool +isKeyLShift = (== keyLShift) + +isKeyRShift :: KeyCode -> Bool +isKeyRShift = (== keyRShift) + +-- General keys +isKeyUnknown :: KeyCode -> Bool +isKeyUnknown = (== keyUnknown) + +isKeyReturn :: KeyCode -> Bool +isKeyReturn = (== keyReturn) + +isKeyEscape :: KeyCode -> Bool +isKeyEscape = (== keyEscape) + +isKeyBackspace :: KeyCode -> Bool +isKeyBackspace = (== keyBackspace) + +isKeyTab :: KeyCode -> Bool +isKeyTab = (== keyTab) + +isKeySpace :: KeyCode -> Bool +isKeySpace = (== keySpace) + +isKeyExclaim :: KeyCode -> Bool +isKeyExclaim = (== keyExclaim) + +isKeyQuoteDbl :: KeyCode -> Bool +isKeyQuoteDbl = (== keyQuoteDbl) + +isKeyHash :: KeyCode -> Bool +isKeyHash = (== keyHash) + +isKeyPercent :: KeyCode -> Bool +isKeyPercent = (== keyPercent) + +isKeyDollar :: KeyCode -> Bool +isKeyDollar = (== keyDollar) + +isKeyAmpersand :: KeyCode -> Bool +isKeyAmpersand = (== keyAmpersand) + +isKeyQuote :: KeyCode -> Bool +isKeyQuote = (== keyQuote) + +isKeyLeftParen :: KeyCode -> Bool +isKeyLeftParen = (== keyLeftParen) + +isKeyRightParen :: KeyCode -> Bool +isKeyRightParen = (== keyRightParen) + +isKeyAsterisk :: KeyCode -> Bool +isKeyAsterisk = (== keyAsterisk) + +isKeyPlus :: KeyCode -> Bool +isKeyPlus = (== keyPlus) + +isKeyComma :: KeyCode -> Bool +isKeyComma = (== keyComma) + +isKeyMinus :: KeyCode -> Bool +isKeyMinus = (== keyMinus) + +isKeyPeriod :: KeyCode -> Bool +isKeyPeriod = (== keyPeriod) + +isKeySlash :: KeyCode -> Bool +isKeySlash = (== keySlash) + +isKeyColon :: KeyCode -> Bool +isKeyColon = (== keyColon) + +isKeySemicolon :: KeyCode -> Bool +isKeySemicolon = (== keySemicolon) + +isKeyLess :: KeyCode -> Bool +isKeyLess = (== keyLess) + +isKeyEquals :: KeyCode -> Bool +isKeyEquals = (== keyEquals) + +isKeyGreater :: KeyCode -> Bool +isKeyGreater = (== keyGreater) + +isKeyQuestion :: KeyCode -> Bool +isKeyQuestion = (== keyQuestion) + +isKeyAt :: KeyCode -> Bool +isKeyAt = (== keyAt) + +isKeyLeftBracket :: KeyCode -> Bool +isKeyLeftBracket = (== keyLeftBracket) + +isKeyBackslash :: KeyCode -> Bool +isKeyBackslash = (== keyBackslash) + +isKeyRightBracket :: KeyCode -> Bool +isKeyRightBracket = (== keyRightBracket) + +isKeyCaret :: KeyCode -> Bool +isKeyCaret = (== keyCaret) + +isKeyUnderscore :: KeyCode -> Bool +isKeyUnderscore = (== keyUnderscore) + +isKeyBackquote :: KeyCode -> Bool +isKeyBackquote = (== keyBackquote) + +isKeyCapsLock :: KeyCode -> Bool +isKeyCapsLock = (== keyCapsLock) + +isKeyPrintScreen :: KeyCode -> Bool +isKeyPrintScreen = (== keyPrintScreen) + +isKeyScrollLock :: KeyCode -> Bool +isKeyScrollLock = (== keyScrollLock) + +isKeyPause :: KeyCode -> Bool +isKeyPause = (== keyPause) + +isKeyInsert :: KeyCode -> Bool +isKeyInsert = (== keyInsert) + +isKeyHome :: KeyCode -> Bool +isKeyHome = (== keyHome) + +isKeyPageUp :: KeyCode -> Bool +isKeyPageUp = (== keyPageUp) + +isKeyDelete :: KeyCode -> Bool +isKeyDelete = (== keyDelete) + +isKeyEnd :: KeyCode -> Bool +isKeyEnd = (== keyEnd) + +isKeyPageDown :: KeyCode -> Bool +isKeyPageDown = (== keyPageDown) + +isKeyRight :: KeyCode -> Bool +isKeyRight = (== keyRight) + +isKeyLeft :: KeyCode -> Bool +isKeyLeft = (== keyLeft) + +isKeyDown :: KeyCode -> Bool +isKeyDown = (== keyDown) + +isKeyUp :: KeyCode -> Bool +isKeyUp = (== keyUp) + +isKeyNumLockClear :: KeyCode -> Bool +isKeyNumLockClear = (== keyNumLockClear) + +-- Numbers +isKey0 :: KeyCode -> Bool +isKey0 = (== key0) + +isKey1 :: KeyCode -> Bool +isKey1 = (== key1) + +isKey2 :: KeyCode -> Bool +isKey2 = (== key2) + +isKey3 :: KeyCode -> Bool +isKey3 = (== key3) + +isKey4 :: KeyCode -> Bool +isKey4 = (== key4) + +isKey5 :: KeyCode -> Bool +isKey5 = (== key5) + +isKey6 :: KeyCode -> Bool +isKey6 = (== key6) + +isKey7 :: KeyCode -> Bool +isKey7 = (== key7) + +isKey8 :: KeyCode -> Bool +isKey8 = (== key8) + +isKey9 :: KeyCode -> Bool +isKey9 = (== key9) + +isKeyF1 :: KeyCode -> Bool +isKeyF1 = (== keyF1) + +isKeyF2 :: KeyCode -> Bool +isKeyF2 = (== keyF2) + +isKeyF3 :: KeyCode -> Bool +isKeyF3 = (== keyF3) + +isKeyF4 :: KeyCode -> Bool +isKeyF4 = (== keyF4) + +isKeyF5 :: KeyCode -> Bool +isKeyF5 = (== keyF5) + +isKeyF6 :: KeyCode -> Bool +isKeyF6 = (== keyF6) + +isKeyF7 :: KeyCode -> Bool +isKeyF7 = (== keyF7) + +isKeyF8 :: KeyCode -> Bool +isKeyF8 = (== keyF8) + +isKeyF9 :: KeyCode -> Bool +isKeyF9 = (== keyF9) + +isKeyF10 :: KeyCode -> Bool +isKeyF10 = (== keyF10) + +isKeyF11 :: KeyCode -> Bool +isKeyF11 = (== keyF11) + +isKeyF12 :: KeyCode -> Bool +isKeyF12 = (== keyF12) + +-- Letters +isKeyA :: KeyCode -> Bool +isKeyA = (== keyA) + +isKeyB :: KeyCode -> Bool +isKeyB = (== keyB) + +isKeyC :: KeyCode -> Bool +isKeyC = (== keyC) + +isKeyD :: KeyCode -> Bool +isKeyD = (== keyD) + +isKeyE :: KeyCode -> Bool +isKeyE = (== keyE) + +isKeyF :: KeyCode -> Bool +isKeyF = (== keyF) + +isKeyG :: KeyCode -> Bool +isKeyG = (== keyG) + +isKeyH :: KeyCode -> Bool +isKeyH = (== keyH) + +isKeyI :: KeyCode -> Bool +isKeyI = (== keyI) + +isKeyJ :: KeyCode -> Bool +isKeyJ = (== keyJ) + +isKeyK :: KeyCode -> Bool +isKeyK = (== keyK) + +isKeyL :: KeyCode -> Bool +isKeyL = (== keyL) + +isKeyM :: KeyCode -> Bool +isKeyM = (== keyM) + +isKeyN :: KeyCode -> Bool +isKeyN = (== keyN) + +isKeyO :: KeyCode -> Bool +isKeyO = (== keyO) + +isKeyP :: KeyCode -> Bool +isKeyP = (== keyP) + +isKeyQ :: KeyCode -> Bool +isKeyQ = (== keyQ) + +isKeyR :: KeyCode -> Bool +isKeyR = (== keyR) + +isKeyS :: KeyCode -> Bool +isKeyS = (== keyS) + +isKeyT :: KeyCode -> Bool +isKeyT = (== keyT) + +isKeyU :: KeyCode -> Bool +isKeyU = (== keyU) + +isKeyV :: KeyCode -> Bool +isKeyV = (== keyV) + +isKeyW :: KeyCode -> Bool +isKeyW = (== keyW) + +isKeyX :: KeyCode -> Bool +isKeyX = (== keyX) + +isKeyY :: KeyCode -> Bool +isKeyY = (== keyY) + +isKeyZ :: KeyCode -> Bool +isKeyZ = (== keyZ) diff --git a/src/Monomer/Event/Lens.hs b/src/Monomer/Event/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Event/Lens.hs @@ -0,0 +1,23 @@ +{-| +Module : Monomer.Event.Lens +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Lenses for the Event types. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Event.Lens where + +import Control.Lens.TH (abbreviatedFields, makeLensesWith) + +import Monomer.Common.Lens +import Monomer.Event.Types + +makeLensesWith abbreviatedFields ''InputStatus +makeLensesWith abbreviatedFields ''KeyMod diff --git a/src/Monomer/Event/Types.hs b/src/Monomer/Event/Types.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Event/Types.hs @@ -0,0 +1,175 @@ +{-| +Module : Monomer.Event.Types +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Basic types for Monomer events. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Monomer.Event.Types where + +import Data.Default +import Data.Text (Text) +import Data.Typeable (Typeable, cast, typeOf) +import Data.Map.Strict (Map) + +import qualified Data.Map.Strict as M + +import Monomer.Common + +-- | Keycode for keyboard events. Used instead of Scancodes to avoid mappings. +newtype KeyCode + = KeyCode { unKeyCode :: Int } + deriving (Eq, Ord, Show) + +-- | Status of a keyboard key. +data KeyStatus + = KeyPressed + | KeyReleased + deriving (Eq, Show) + +-- | Button of a pointer device (mouse). +data Button + = BtnLeft + | BtnMiddle + | BtnRight + deriving (Eq, Show, Ord) + +-- | Status of a mouse button. +data ButtonState + = BtnPressed + | BtnReleased + deriving (Eq, Show) + +-- | Movement direction in which wheel values are positive. +data WheelDirection + = WheelNormal + | WheelFlipped + deriving (Eq, Show) + +-- | Types of clipboard content. +data ClipboardData + = ClipboardEmpty + | ClipboardText Text + deriving (Eq, Show) + +-- | Constraints for drag event messages. +type DragMsg i = (Eq i, Typeable i) + +-- | Drag message container. +data WidgetDragMsg + = forall i . DragMsg i => WidgetDragMsg i + +instance Eq WidgetDragMsg where + WidgetDragMsg d1 == WidgetDragMsg d2 = case cast d1 of + Just d -> d == d2 + _ -> False + +instance Show WidgetDragMsg where + show (WidgetDragMsg info) = "WidgetDragMsg: " ++ show (typeOf info) + +-- | Supported Monomer SystemEvents +data SystemEvent + {-| + Click (press and release) of a mouse button. Includes mouse position and click + count. + -} + = Click Point Button Int + {-| + Click or release of a mouse button. Includes times pressed/released and mouse + position. + -} + | ButtonAction Point Button ButtonState Int + -- | Mouse wheel movement. Includes mouse position, move size in both axes and + -- | wheel direction. + | WheelScroll Point Point WheelDirection + -- | Keyboard key action. Includes modifiers, keyCode and pressed/released. + -- | This event should not be used for text input. + | KeyAction KeyMod KeyCode KeyStatus + -- | Processed keyboard events. Some Unicode characters require several key + -- | presses to produce the result. This event provides the final result. + | TextInput Text + -- | Provides current clipboard contents to a requesting widget. + | Clipboard ClipboardData + -- | Target now has focus. Includes path of the previously focused widget. + | Focus Path + -- | Target has lost focus. Includes path of the next focused widget. + | Blur Path + -- | Mouse has entered the assigned viewport. + | Enter Point + -- | Mouse has moved inside the assigned viewport. This event keeps being + -- | received if the main mouse button is pressed, even if the mouse is + -- | outside the assigned bounds or even the screen. + | Move Point + -- | Mouse has left the assigned viewport. This event is not received until + -- | the main mouse button has been pressed. + | Leave Point + -- | A drag action is active and the mouse is inside the current viewport. The + -- | messsage can be used to decide if it applies to the current widget. This + -- | event is not received by the widget which initiated the drag action. + | Drag Point Path WidgetDragMsg + -- | A drag action was active and the main button was released inside the + -- | current viewport. + | Drop Point Path WidgetDragMsg + deriving (Eq, Show) + +-- | Status of input devices. +data InputStatus = InputStatus { + -- | Mouse position. + _ipsMousePos :: Point, + -- | Previous mouse position. + _ipsMousePosPrev :: Point, + -- | Current key modifiers (shift, ctrl, alt, etc). + _ipsKeyMod :: KeyMod, + -- | Current status of keyCodes. If not in the map, status is KeyReleased. + _ipsKeys :: Map KeyCode KeyStatus, + -- | Status of mouse buttons. If not in the map, status is BtnReleased. + _ipsButtons :: Map Button ButtonState +} deriving (Eq, Show) + +instance Default InputStatus where + def = InputStatus { + _ipsMousePos = Point (-1) (-1), + _ipsMousePosPrev = Point (-1) (-1), + _ipsKeyMod = def, + _ipsKeys = M.empty, + _ipsButtons = M.empty + } + +{-| +Keyboard modifiers. True indicates the key is pressed. +Note: The __fn__ function in Macs cannot be detected individually. +-} +data KeyMod = KeyMod { + _kmLeftShift :: Bool, + _kmRightShift :: Bool, + _kmLeftCtrl :: Bool, + _kmRightCtrl :: Bool, + _kmLeftAlt :: Bool, + _kmRightAlt :: Bool, + _kmLeftGUI :: Bool, + _kmRightGUI :: Bool, + _kmNumLock :: Bool, + _kmCapsLock :: Bool, + _kmAltGr :: Bool +} deriving (Eq, Show) + +instance Default KeyMod where + def = KeyMod { + _kmLeftShift = False, + _kmRightShift = False, + _kmLeftCtrl = False, + _kmRightCtrl = False, + _kmLeftAlt = False, + _kmRightAlt = False, + _kmLeftGUI = False, + _kmRightGUI = False, + _kmNumLock = False, + _kmCapsLock = False, + _kmAltGr = False + } diff --git a/src/Monomer/Event/Util.hs b/src/Monomer/Event/Util.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Event/Util.hs @@ -0,0 +1,124 @@ +{-| +Module : Monomer.Event.Util +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Utility functions for event handling. +-} +module Monomer.Event.Util ( + isShiftPressed, + isCtrlPressed, + isAltPressed, + isGUIPressed, + isOnClick, + isOnButtonAction, + isOnWheelScroll, + isOnKeyAction, + isOnTextInput, + isOnClipboard, + isOnFocus, + isOnBlur, + isOnEnter, + isOnMove, + isOnLeave, + isOnDrag, + isOnDrop, + checkKeyboard +) where + +import Data.Maybe (fromMaybe) + +import qualified Data.Map as M + +import Monomer.Event.Core +import Monomer.Event.Keyboard +import Monomer.Event.Types + +-- | Checks if Winddows/Cmd key is pressed. +isGUIPressed :: KeyMod -> Bool +isGUIPressed mod = _kmLeftGUI mod || _kmRightGUI mod + +-- | Checks if Ctrl key is pressed. +isCtrlPressed :: KeyMod -> Bool +isCtrlPressed keyMod = _kmLeftCtrl keyMod || _kmRightCtrl keyMod + +-- | Checks if Shift key is pressed. +isShiftPressed :: KeyMod -> Bool +isShiftPressed keyMod = _kmLeftShift keyMod || _kmRightShift keyMod + +-- | Checks if Alt key is pressed. +isAltPressed :: KeyMod -> Bool +isAltPressed keyMod = _kmLeftAlt keyMod || _kmRightAlt keyMod + +-- | Checks if it's a Click event. +isOnClick :: SystemEvent -> Bool +isOnClick Click{} = True +isOnClick _ = False + +-- | Checks if it's a ButtonAction event. +isOnButtonAction :: SystemEvent -> Bool +isOnButtonAction ButtonAction{} = True +isOnButtonAction _ = False + +-- | Checks if it's a WheelScroll event. +isOnWheelScroll :: SystemEvent -> Bool +isOnWheelScroll WheelScroll{} = True +isOnWheelScroll _ = False + +-- | Checks if it's a KeyAction event. +isOnKeyAction :: SystemEvent -> Bool +isOnKeyAction KeyAction{} = True +isOnKeyAction _ = False + +-- | Checks if it's a TextInput event. +isOnTextInput :: SystemEvent -> Bool +isOnTextInput TextInput{} = True +isOnTextInput _ = False + +-- | Checks if it's a Clipboard event. +isOnClipboard :: SystemEvent -> Bool +isOnClipboard Clipboard{} = True +isOnClipboard _ = False + +-- | Checks if it's a Focus event. +isOnFocus :: SystemEvent -> Bool +isOnFocus Focus{} = True +isOnFocus _ = False + +-- | Checks if it's a Blur event. +isOnBlur :: SystemEvent -> Bool +isOnBlur Blur{} = True +isOnBlur _ = False + +-- | Checks if it's an Enter event. +isOnEnter :: SystemEvent -> Bool +isOnEnter Enter{} = True +isOnEnter _ = False + +-- | Checks if it's a Move event. +isOnMove :: SystemEvent -> Bool +isOnMove Move{} = True +isOnMove _ = False + +-- | Checks if it's a Leave event. +isOnLeave :: SystemEvent -> Bool +isOnLeave Leave{} = True +isOnLeave _ = False + +-- | Checks if it's a Drag event. +isOnDrag :: SystemEvent -> Bool +isOnDrag Drag{} = True +isOnDrag _ = False + +-- | Checks if it's a Drop event. +isOnDrop :: SystemEvent -> Bool +isOnDrop Drop{} = True +isOnDrop _ = False + +-- | Appplies a provided function to test a KeyAction event +checkKeyboard :: SystemEvent -> (KeyMod -> KeyCode -> KeyStatus -> Bool) -> Bool +checkKeyboard (KeyAction mod code motion) testFn = testFn mod code motion +checkKeyboard _ _ = False diff --git a/src/Monomer/Graphics.hs b/src/Monomer/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics.hs @@ -0,0 +1,24 @@ +{-| +Module : Monomer.Graphics +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Graphics module, including all related types, low level renderer interface, +nanovg implementation and higher level drawing helpers. +-} +module Monomer.Graphics ( + module Monomer.Graphics.FontManager, + module Monomer.Graphics.NanoVGRenderer, + module Monomer.Graphics.Text, + module Monomer.Graphics.Types, + module Monomer.Graphics.Util +) where + +import Monomer.Graphics.FontManager +import Monomer.Graphics.NanoVGRenderer +import Monomer.Graphics.Text +import Monomer.Graphics.Types +import Monomer.Graphics.Util diff --git a/src/Monomer/Graphics/ColorTable.hs b/src/Monomer/Graphics/ColorTable.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/ColorTable.hs @@ -0,0 +1,154 @@ +{-| +Module : Monomer.Graphics.ColorTable +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Color table imported from https://www.rapidtables.com/web/color/RGB_Color.html. +-} +module Monomer.Graphics.ColorTable where + +import Monomer.Graphics.Util (rgbHex) + +maroon = rgbHex "#800000" +darkRed = rgbHex "#8B0000" +brown = rgbHex "#A52A2A" +firebrick = rgbHex "#B22222" +crimson = rgbHex "#DC143C" +red = rgbHex "#FF0000" +tomato = rgbHex "#FF6347" +coral = rgbHex "#FF7F50" +indianRed = rgbHex "#CD5C5C" +lightCoral = rgbHex "#F08080" +darkSalmon = rgbHex "#E9967A" +salmon = rgbHex "#FA8072" +lightSalmon = rgbHex "#FFA07A" +orangeRed = rgbHex "#FF4500" +darkOrange = rgbHex "#FF8C00" +orange = rgbHex "#FFA500" +gold = rgbHex "#FFD700" +darkGoldenRod = rgbHex "#B8860B" +goldenRod = rgbHex "#DAA520" +paleGoldenRod = rgbHex "#EEE8AA" +darkKhaki = rgbHex "#BDB76B" +khaki = rgbHex "#F0E68C" +olive = rgbHex "#808000" +yellow = rgbHex "#FFFF00" +yellowGreen = rgbHex "#9ACD32" +darkOliveGreen = rgbHex "#556B2F" +oliveDrab = rgbHex "#6B8E23" +lawnGreen = rgbHex "#7CFC00" +chartReuse = rgbHex "#7FFF00" +greenYellow = rgbHex "#ADFF2F" +darkGreen = rgbHex "#006400" +green = rgbHex "#008000" +forestGreen = rgbHex "#228B22" +lime = rgbHex "#00FF00" +limeGreen = rgbHex "#32CD32" +lightGreen = rgbHex "#90EE90" +paleGreen = rgbHex "#98FB98" +darkSeaGreen = rgbHex "#8FBC8F" +mediumSpringGreen = rgbHex "#00FA9A" +springGreen = rgbHex "#00FF7F" +seaGreen = rgbHex "#2E8B57" +mediumAquaMarine = rgbHex "#66CDAA" +mediumSeaGreen = rgbHex "#3CB371" +lightSeaGreen = rgbHex "#20B2AA" +darkSlateGray = rgbHex "#2F4F4F" +teal = rgbHex "#008080" +darkCyan = rgbHex "#008B8B" +aqua = rgbHex "#00FFFF" +cyan = rgbHex "#00FFFF" +lightCyan = rgbHex "#E0FFFF" +darkTurquoise = rgbHex "#00CED1" +turquoise = rgbHex "#40E0D0" +mediumTurquoise = rgbHex "#48D1CC" +paleTurquoise = rgbHex "#AFEEEE" +aquaMarine = rgbHex "#7FFFD4" +powderBlue = rgbHex "#B0E0E6" +cadetBlue = rgbHex "#5F9EA0" +steelBlue = rgbHex "#4682B4" +cornFlowerBlue = rgbHex "#6495ED" +deepSkyBlue = rgbHex "#00BFFF" +dodgerBlue = rgbHex "#1E90FF" +lightBlue = rgbHex "#ADD8E6" +skyBlue = rgbHex "#87CEEB" +lightSkyBlue = rgbHex "#87CEFA" +midnightBlue = rgbHex "#191970" +navy = rgbHex "#000080" +darkBlue = rgbHex "#00008B" +mediumBlue = rgbHex "#0000CD" +blue = rgbHex "#0000FF" +royalBlue = rgbHex "#4169E1" +blueViolet = rgbHex "#8A2BE2" +indigo = rgbHex "#4B0082" +darkSlateBlue = rgbHex "#483D8B" +slateBlue = rgbHex "#6A5ACD" +mediumSlateBlue = rgbHex "#7B68EE" +mediumPurple = rgbHex "#9370DB" +darkMagenta = rgbHex "#8B008B" +darkViolet = rgbHex "#9400D3" +darkOrchid = rgbHex "#9932CC" +mediumOrchid = rgbHex "#BA55D3" +purple = rgbHex "#800080" +thistle = rgbHex "#D8BFD8" +plum = rgbHex "#DDA0DD" +violet = rgbHex "#EE82EE" +magenta = rgbHex "#FF00FF" +fuchsia = rgbHex "#FF00FF" +orchid = rgbHex "#DA70D6" +mediumVioletRed = rgbHex "#C71585" +paleVioletRed = rgbHex "#DB7093" +deepPink = rgbHex "#FF1493" +hotPink = rgbHex "#FF69B4" +lightPink = rgbHex "#FFB6C1" +pink = rgbHex "#FFC0CB" +antiqueWhite = rgbHex "#FAEBD7" +beige = rgbHex "#F5F5DC" +bisque = rgbHex "#FFE4C4" +blanchedAlmond = rgbHex "#FFEBCD" +wheat = rgbHex "#F5DEB3" +cornSilk = rgbHex "#FFF8DC" +lemonChiffon = rgbHex "#FFFACD" +lightGoldenRodYellow = rgbHex "#FAFAD2" +lightYellow = rgbHex "#FFFFE0" +saddleBrown = rgbHex "#8B4513" +sienna = rgbHex "#A0522D" +chocolate = rgbHex "#D2691E" +peru = rgbHex "#CD853F" +sandyBrown = rgbHex "#F4A460" +burlyWood = rgbHex "#DEB887" +tan = rgbHex "#D2B48C" +rosyBrown = rgbHex "#BC8F8F" +moccasin = rgbHex "#FFE4B5" +navajoWhite = rgbHex "#FFDEAD" +peachPuff = rgbHex "#FFDAB9" +mistyRose = rgbHex "#FFE4E1" +lavenderBlush = rgbHex "#FFF0F5" +linen = rgbHex "#FAF0E6" +oldLace = rgbHex "#FDF5E6" +papayaWhip = rgbHex "#FFEFD5" +seaShell = rgbHex "#FFF5EE" +mintCream = rgbHex "#F5FFFA" +slateGray = rgbHex "#708090" +lightSlateGray = rgbHex "#778899" +lightSteelBlue = rgbHex "#B0C4DE" +lavender = rgbHex "#E6E6FA" +floralWhite = rgbHex "#FFFAF0" +aliceBlue = rgbHex "#F0F8FF" +ghostWhite = rgbHex "#F8F8FF" +honeydew = rgbHex "#F0FFF0" +ivory = rgbHex "#FFFFF0" +azure = rgbHex "#F0FFFF" +snow = rgbHex "#FFFAFA" +black = rgbHex "#000000" +dimGray = rgbHex "#696969" +darkGray = rgbHex "#808080" +gray = rgbHex "#A9A9A9" +silver = rgbHex "#C0C0C0" +lightGray = rgbHex "#D3D3D3" +gainsboro = rgbHex "#DCDCDC" +whiteSmoke = rgbHex "#F5F5F5" +white = rgbHex "#FFFFFF" diff --git a/src/Monomer/Graphics/FFI.chs b/src/Monomer/Graphics/FFI.chs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/FFI.chs @@ -0,0 +1,167 @@ +{-| +Module : Monomer.Graphics.FFI +Copyright : (c) 2018 Francisco Vallarino, + (c) 2016 Moritz Kiefer +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Provides functions for getting text dimensions and metrics. + +Based on code from cocreature's https://github.com/cocreature/nanovg-hs +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Monomer.Graphics.FFI where + +import Control.Monad (forM) +import Data.ByteString (useAsCString) +import Data.Text (Text) +import Data.Text.Foreign (withCStringLen) +import Data.Sequence (Seq) +import Foreign +import Foreign.C (CString) +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable + +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Monomer.Graphics.Types (GlyphPos(..)) + +#include "fontmanager.h" + +-- | Vector of 4 strict elements +data V4 a = V4 !a !a !a !a + deriving (Show, Read, Eq, Ord) + +newtype Bounds + = Bounds (V4 CFloat) + deriving (Show, Read, Eq, Ord) + +instance Storable Bounds where + sizeOf _ = sizeOf (0 :: CFloat) * 4 + alignment _ = alignment (0 :: CFloat) + peek p = + do let p' = castPtr p :: Ptr CFloat + a <- peekElemOff p' 0 + b <- peekElemOff p' 1 + c <- peekElemOff p' 2 + d <- peekElemOff p' 3 + pure (Bounds (V4 a b c d)) + poke p (Bounds (V4 a b c d)) = + do let p' = castPtr p :: Ptr CFloat + pokeElemOff p' 0 a + pokeElemOff p' 1 b + pokeElemOff p' 2 c + pokeElemOff p' 3 d + +data GlyphPosition = GlyphPosition { + -- | Pointer of the glyph in the input string. + str :: !(Ptr CChar), + -- | The x-coordinate of the logical glyph position. + glyphX :: !CFloat, + -- | The left bound of the glyph shape. + glyphPosMinX :: !CFloat, + -- | The right bound of the glyph shape. + glyphPosMaxX :: !CFloat, + -- | The lower bound of the glyph shape. + glyphPosMinY :: !CFloat, + -- | The upper bound of the glyph shape. + glyphPosMaxY :: !CFloat +} deriving (Show, Eq, Ord) + +instance Storable GlyphPosition where + sizeOf _ = {# sizeof FMGglyphPosition #} + alignment _ = {#alignof FMGglyphPosition#} + peek p = + do str <- {#get FMGglyphPosition->str#} p + x <- {#get FMGglyphPosition->x#} p + minx <- {#get FMGglyphPosition->minx#} p + maxx <- {#get FMGglyphPosition->maxx#} p + miny <- {#get FMGglyphPosition->miny#} p + maxy <- {#get FMGglyphPosition->maxy#} p + pure (GlyphPosition str x minx maxx miny maxy) + poke p (GlyphPosition str x minx maxx miny maxy) = + do {#set FMGglyphPosition->str#} p str + {#set FMGglyphPosition->x#} p x + {#set FMGglyphPosition->minx#} p minx + {#set FMGglyphPosition->maxx#} p maxx + {#set FMGglyphPosition->miny#} p miny + {#set FMGglyphPosition->maxy#} p maxy + +{#pointer *FMGglyphPosition as GlyphPositionPtr -> GlyphPosition#} + +peekBounds :: Ptr CFloat -> IO Bounds +peekBounds = peek . castPtr + +allocaBounds :: (Ptr CFloat -> IO b) -> IO b +allocaBounds f = alloca (\(p :: Ptr Bounds) -> f (castPtr p)) + +withCString :: Text -> (CString -> IO b) -> IO b +withCString t = useAsCString (T.encodeUtf8 t) + +withText :: Text -> (CString -> IO b) -> IO b +withText t = useAsCString (T.encodeUtf8 t) + +-- | Marshalling helper for a constant 'nullPtr' +withNull :: (Ptr a -> b) -> b +withNull f = f nullPtr + +-- Common +{# pointer *FMcontext as FMContext newtype #} +deriving instance Storable FMContext + +{# fun unsafe fmInit {`Double'} -> `FMContext' #} + +{# fun unsafe fmCreateFont {`FMContext', withCString*`Text', withCString*`Text'} -> `Int' #} + +{# fun unsafe fmFontFace {`FMContext', withCString*`Text'} -> `()' #} + +{# fun unsafe fmFontSize {`FMContext', `Double'} -> `()' #} + +{# fun unsafe fmFontBlur {`FMContext', `Double'} -> `()' #} + +{# fun unsafe fmTextLetterSpacing {`FMContext', `Double'} -> `()' #} + +{# fun unsafe fmTextLineHeight {`FMContext', `Double'} -> `()' #} + +{# fun unsafe fmTextMetrics as fmTextMetrics_ {`FMContext', alloca- `CFloat' peek*, alloca- `CFloat' peek*, alloca- `CFloat' peek*} -> `()' #} + +fmTextMetrics :: FMContext -> IO (Double, Double, Double) +fmTextMetrics fm = do + (asc, desc, lineh) <- fmTextMetrics_ fm + return (realToFrac asc, realToFrac desc, realToFrac lineh) + +{# fun unsafe fmTextBounds as fmTextBounds_ + {`FMContext', `Double', `Double', withText*`Text', withNull-`Ptr CUChar', allocaBounds-`Bounds'peekBounds*} -> `Double' #} + +fmTextBounds :: FMContext -> Double -> Double -> Text -> IO (Double, Double, Double, Double) +fmTextBounds fm x y text = do + (_, Bounds (V4 x1 y1 x2 y2)) <- fmTextBounds_ fm x y text + return (realToFrac x1, realToFrac y1, realToFrac x2, realToFrac y2) + +{# fun unsafe fmTextGlyphPositions as fmTextGlyphPositions_ + {`FMContext', `Double', `Double', id`Ptr CChar', id`Ptr CChar', `GlyphPositionPtr', `CInt'} -> `CInt' #} + +fmTextGlyphPositions :: FMContext -> Double -> Double -> Text -> IO (Seq GlyphPosition) +fmTextGlyphPositions c x y text = + withCStringLen text $ \(ptr, len) -> do + let startPtr = ptr + let endPtr = ptr `plusPtr` len + allocaBytesAligned bufferSize align $ \arrayPtr -> do + count <- fmTextGlyphPositions_ c x y startPtr endPtr arrayPtr maxGlyphs + Seq.fromList <$> readChunk arrayPtr count + where + maxGlyphs = fromIntegral (T.length text) + bufferSize = sizeOf (undefined :: GlyphPosition) * fromIntegral maxGlyphs + align = alignment (undefined :: GlyphPosition) + readChunk :: GlyphPositionPtr -> CInt -> IO [GlyphPosition] + readChunk arrayPtr count = forM [0..count-1] $ \i -> + peekElemOff arrayPtr (fromIntegral i) diff --git a/src/Monomer/Graphics/FontManager.hs b/src/Monomer/Graphics/FontManager.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/FontManager.hs @@ -0,0 +1,102 @@ +{-| +Module : Monomer.Graphics.FontManager +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Provides functions for getting text dimensions and metrics. +-} +{-# LANGUAGE RecordWildCards #-} + +module Monomer.Graphics.FontManager ( + makeFontManager +) where + +import Control.Monad (foldM, when) + +import Data.Default +import Data.Sequence (Seq) +import Data.Text (Text) +import System.IO.Unsafe + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Common.BasicTypes +import Monomer.Graphics.FFI +import Monomer.Graphics.Types + +-- | Creates a font manager instance. +makeFontManager + :: [FontDef] -- ^ The font definitions. + -> Double -- ^ The device pixel rate. + -> IO FontManager -- ^ The created renderer. +makeFontManager fonts dpr = do + ctx <- fmInit 1 --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 + (asc, desc, lineh) <- fmTextMetrics ctx + lowerX <- Seq.lookup 0 <$> fmTextGlyphPositions ctx 0 0 "x" + let heightLowerX = case lowerX of + Just lx -> glyphPosMaxY lx - glyphPosMinY lx + Nothing -> realToFrac asc + + return $ TextMetrics { + _txmAsc = asc / dpr, + _txmDesc = desc / dpr, + _txmLineH = lineh / dpr, + _txmLowerX = realToFrac heightLowerX / dpr + } + + computeTextSize font fontSize fontSpaceH text = unsafePerformIO $ do + setFont ctx dpr 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) + + computeGlyphsPos font fontSize fontSpaceH text = unsafePerformIO $ do + setFont ctx dpr font fontSize fontSpaceH + glyphs <- if text /= "" + then fmTextGlyphPositions ctx 0 0 text + else return Seq.empty + + return $ Seq.zipWith toGlyphPos (Seq.fromList (T.unpack text)) glyphs + 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 + } + +loadFont :: FMContext -> [Text] -> FontDef -> IO [Text] +loadFont ctx fonts (FontDef name path) = do + res <- fmCreateFont ctx name path + if res >= 0 + then return $ path : fonts + 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 + fmFontFace ctx name + fmFontSize ctx $ realToFrac $ size * dpr + fmTextLetterSpacing ctx $ realToFrac $ spaceH * dpr diff --git a/src/Monomer/Graphics/Lens.hs b/src/Monomer/Graphics/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/Lens.hs @@ -0,0 +1,28 @@ +{-| +Module : Monomer.Graphics.Lens +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Lenses for the Graphics types. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Graphics.Lens where + +import Control.Lens.TH (abbreviatedFields, makeLensesWith) + +import Monomer.Common.Lens +import Monomer.Core.Lens +import Monomer.Graphics.Types + +makeLensesWith abbreviatedFields ''Color +makeLensesWith abbreviatedFields ''FontDef +makeLensesWith abbreviatedFields ''GlyphPos +makeLensesWith abbreviatedFields ''ImageDef +makeLensesWith abbreviatedFields ''TextMetrics +makeLensesWith abbreviatedFields ''TextLine diff --git a/src/Monomer/Graphics/NanoVGRenderer.hs b/src/Monomer/Graphics/NanoVGRenderer.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/NanoVGRenderer.hs @@ -0,0 +1,514 @@ +{-| +Module : Monomer.Graphics.NanoVGRenderer +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Renderer based on the nanovg library. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Monomer.Graphics.NanoVGRenderer (makeRenderer) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Monad (foldM, forM_, unless, when) +import Data.Default +import Data.Functor ((<&>)) +import Data.IORef +import Data.List (foldl') +import Data.Maybe +import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Set (Set(..)) +import Data.Text (Text) +import Data.Text.Foreign (withCStringLen) +import Foreign.C.Types (CFloat) +import Foreign.Ptr +import System.IO.Unsafe + +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified NanoVG as VG +import qualified NanoVG.Internal.Image as VGI + +import Monomer.Common +import Monomer.Graphics.Types + +import qualified Monomer.Common.Lens as L +import qualified Monomer.Graphics.Lens as L + +type ImagesMap = M.Map Text Image + +data ImageAction + = ImageAdd + | ImageUpdate + | ImageDelete + deriving (Eq, Show) + +data Image = Image { + _imImageDef :: ImageDef, + _imNvImage :: VG.Image, + _imCount :: Int +} + +data ImageReq = ImageReq { + _irName :: Text, + _irSize :: Size, + _irImgData :: Maybe BS.ByteString, + _irAction :: ImageAction, + _irFlags :: [ImageFlag] +} + +data Env = Env { + overlays :: Seq (IO ()), + tasksRaw :: Seq (IO ()), + overlaysRaw :: Seq (IO ()), + validFonts :: Set Text, + imagesMap :: ImagesMap +} + +data CSize + = CSize CFloat CFloat + deriving (Eq, Show) + +data CPoint + = CPoint CFloat CFloat + deriving (Eq, Show) + +data CRect + = CRect CFloat CFloat CFloat CFloat + deriving (Eq, Show) + +-- | Creates a nanovg based renderer. +makeRenderer + :: [FontDef] -- ^ The font definitions. + -> Double -- ^ The device pixel rate. + -> IO Renderer -- ^ The created renderer. +makeRenderer fonts dpr = do + c <- VG.createGL3 (Set.fromList [VG.Antialias, VG.StencilStrokes]) + + validFonts <- foldM (loadFont c) Set.empty fonts + + when (null validFonts) $ + putStrLn "Could not find any valid fonts. Text will fail to be displayed." + + envRef <- newIORef $ Env { + overlays = Seq.empty, + tasksRaw = Seq.empty, + overlaysRaw = Seq.empty, + validFonts = validFonts, + imagesMap = M.empty + } + + return $ newRenderer c dpr envRef + +newRenderer :: VG.Context -> Double -> IORef Env -> Renderer +newRenderer c rdpr envRef = Renderer {..} where + dpr = 1 + + beginFrame w h = do + VG.beginFrame c cw ch cdpr + where + cw = realToFrac (w / dpr) + ch = realToFrac (h / dpr) + cdpr = realToFrac rdpr + + endFrame = + VG.endFrame c + + beginPath = + VG.beginPath c + + closePath = + VG.closePath c + + -- Context management + saveContext = + VG.save c + + restoreContext = + VG.restore c + + -- Overlays + createOverlay overlay = + modifyIORef envRef $ \env -> env { + overlays = overlays env |> overlay + } + + renderOverlays = do + env <- readIORef envRef + sequence_ $ overlays env + writeIORef envRef env { + overlays = Seq.empty + } + + -- Raw tasks + createRawTask task = + modifyIORef envRef $ \env -> env { + tasksRaw = tasksRaw env |> task + } + + renderRawTasks = do + env <- readIORef envRef + sequence_ $ tasksRaw env + writeIORef envRef env { + tasksRaw = Seq.empty + } + + -- Raw overlays + createRawOverlay overlay = + modifyIORef envRef $ \env -> env { + overlaysRaw = overlaysRaw env |> overlay + } + + renderRawOverlays = do + env <- readIORef envRef + sequence_ $ overlaysRaw env + writeIORef envRef env { + overlaysRaw = Seq.empty + } + + -- Scissor + intersectScissor rect = do + VG.intersectScissor c cx cy cw ch + where + CRect cx cy cw ch = rectToCRect rect dpr + + -- Translation + setTranslation offset = do + VG.translate c tx ty + where + CPoint tx ty = pointToCPoint offset dpr + + -- Scale + setScale point = do + VG.scale c sx sy + where + sx = realToFrac (point ^. L.x) + sy = realToFrac (point ^. L.y) + + -- Rotation + setRotation angle = do + VG.rotate c cangle + where + cangle = VG.degToRad $ realToFrac angle + + -- Alpha + setGlobalAlpha alpha = do + VG.globalAlpha c calpha + where + calpha = max 0 . min 1 $ realToFrac alpha + + -- Winding + setPathWinding winding = do + VG.pathWinding c cwinding + where + cwinding = if winding == CW then 0 else 1 + + -- Strokes + stroke = + VG.stroke c + + setStrokeWidth width = + VG.strokeWidth c (realToFrac $ width * dpr) + + setStrokeColor color = + VG.strokeColor c (colorToPaint color) + + setStrokeLinearGradient p1 p2 color1 color2 = do + gradient <- makeLinearGradient c dpr p1 p2 color1 color2 + VG.strokePaint c gradient + + setStrokeRadialGradient p1 rad1 rad2 color1 color2 = do + gradient <- makeRadialGradient c dpr p1 rad1 rad2 color1 color2 + VG.strokePaint c gradient + + setStrokeImagePattern name topLeft size angle alpha = do + env <- readIORef envRef + + forM_ (M.lookup name (imagesMap env)) $ \image -> do + imgPattern <- makeImagePattern c dpr image topLeft size angle alpha + VG.strokePaint c imgPattern + + -- Fill + fill = + VG.fill c + + setFillColor color = + VG.fillColor c (colorToPaint color) + + setFillLinearGradient p1 p2 color1 color2 = do + gradient <- makeLinearGradient c dpr p1 p2 color1 color2 + VG.fillPaint c gradient + + setFillRadialGradient p1 rad1 rad2 color1 color2 = do + gradient <- makeRadialGradient c dpr p1 rad1 rad2 color1 color2 + VG.fillPaint c gradient + + setFillImagePattern name topLeft size angle alpha = do + env <- readIORef envRef + + forM_ (M.lookup name (imagesMap env)) $ \image -> do + imgPattern <- makeImagePattern c dpr image topLeft size angle alpha + VG.fillPaint c imgPattern + + -- Drawing + moveTo !point = + VG.moveTo c x y + where + CPoint x y = pointToCPoint point dpr + + renderLine p1 p2 = do + VG.moveTo c x1 y1 + VG.lineTo c x2 y2 + where + CPoint x1 y1 = pointToCPoint p1 dpr + CPoint x2 y2 = pointToCPoint p2 dpr + + renderLineTo !point = do + VG.lineJoin c VG.Bevel + VG.lineTo c x y + where + CPoint x y = pointToCPoint point dpr + + renderRect !rect = + VG.rect c x y w h + where + CRect x y w h = rectToCRect rect dpr + + renderRoundedRect !rect tl tr br bl = + VG.roundedRectVarying c x y w h ctl ctr cbr cbl + where + CRect x y w h = rectToCRect rect dpr + ctl = realToFrac tl + ctr = realToFrac tr + cbr = realToFrac br + cbl = realToFrac bl + + renderArc !point rad angleStart angleEnd winding = + VG.arc c x y radius start end wind + where + CPoint x y = pointToCPoint point dpr + radius = realToFrac $ rad * dpr + start = VG.degToRad $ realToFrac angleStart + end = VG.degToRad $ realToFrac angleEnd + wind = convertWinding winding + + renderQuadTo p1 p2 = + VG.quadTo c x1 y1 x2 y2 + where + CPoint x1 y1 = pointToCPoint p1 dpr + CPoint x2 y2 = pointToCPoint p2 dpr + + renderEllipse !rect = + VG.ellipse c cx cy rx ry + where + CRect x y w h = rectToCRect rect dpr + cx = x + rx + cy = y + ry + rx = w / 2 + ry = h / 2 + + -- Text + renderText !point font fontSize fontSpaceH message = do + setFont c envRef dpr font fontSize fontSpaceH + + when (message /= "") $ + VG.text c tx ty message + where + CPoint tx ty = pointToCPoint point dpr + + getImage name = do + env <- readIORef envRef + let image = M.lookup name (imagesMap env) + return $ fmap _imImageDef image + + addImage name size imgData flags = do + processImgReq c envRef req + where + req = ImageReq name size (Just imgData) ImageAdd flags + + updateImage name size imgData = do + processImgReq c envRef req + where + req = ImageReq name size (Just imgData) ImageUpdate [] + + deleteImage name = do + processImgReq c envRef req + where + req = ImageReq name def Nothing ImageDelete [] + +loadFont :: VG.Context -> Set Text -> FontDef -> IO (Set Text) +loadFont c fonts (FontDef name path) = do + res <- VG.createFont c name (VG.FileName path) + case res of + Just{} -> return $ Set.insert name fonts + _ -> putStrLn ("Failed to load font: " ++ T.unpack name) >> return fonts + +setFont + :: VG.Context + -> IORef Env + -> Double + -> Font + -> FontSize + -> FontSpace + -> IO () +setFont c envRef dpr (Font name) (FontSize size) (FontSpace spaceH) = do + env <- readIORef envRef + handleSetFont (validFonts env) + where + handleSetFont validFonts + | Set.member name validFonts = do + VG.fontFace c name + VG.fontSize c $ realToFrac $ size * dpr + VG.textLetterSpacing c $ realToFrac $ spaceH * dpr + | otherwise = return () + +makeLinearGradient + :: VG.Context -> Double -> Point -> Point -> Color -> Color -> IO VG.Paint +makeLinearGradient c dpr p1 p2 color1 color2 = do + VG.linearGradient c x1 y1 x2 y2 col1 col2 + where + CPoint x1 y1 = pointToCPoint p1 dpr + CPoint x2 y2 = pointToCPoint p2 dpr + col1 = colorToPaint color1 + col2 = colorToPaint color2 + +makeRadialGradient + :: VG.Context -> Double -> Point -> Double -> Double -> Color -> Color -> IO VG.Paint +makeRadialGradient c dpr center rad1 rad2 color1 color2 = do + VG.radialGradient c cx cy crad1 crad2 col1 col2 + where + CPoint cx cy = pointToCPoint center dpr + crad1 = realToFrac rad1 + crad2 = realToFrac rad2 + col1 = colorToPaint color1 + col2 = colorToPaint color2 + +makeImagePattern + :: VG.Context -> Double -> Image -> Point -> Size -> Double -> Double -> IO VG.Paint +makeImagePattern c dpr image topLeft size angle alpha = do + VG.imagePattern c x y w h cangle nvImg calpha + where + CPoint x y = pointToCPoint topLeft dpr + CSize w h = sizeToCSize size dpr + cangle = realToFrac angle + calpha = realToFrac alpha + nvImg = _imNvImage image + +processImgReq :: VG.Context -> IORef Env -> ImageReq -> IO () +processImgReq c envRef imageReq = do + env <- readIORef envRef + newImgMap <- handlePendingImage c (imagesMap env) imageReq + + writeIORef envRef $ env { + imagesMap = newImgMap + } + +handlePendingImage :: VG.Context -> ImagesMap -> ImageReq -> IO ImagesMap +handlePendingImage c imagesMap imageReq + | action == ImageAdd && imageExists = + return $ imgIncreaseCount name imagesMap + | action `elem` [ImageAdd, ImageUpdate] && not imageExists = do + -- Attempt to create image. If it fails, remove existing images and retry. + -- Ideally only LRU should be removed. + tmpImg <- createImage + (newImgMap, nvImg) <- if isNothing tmpImg + then clearImagesMap c imagesMap >> createImage <&> (M.empty, ) + else return (imagesMap, tmpImg) + return $ maybe newImgMap (imgInsertNew name imgDef newImgMap) nvImg + | action == ImageUpdate && imageExists && sizeMatches = do + VG.updateImage c (_imNvImage image) imgData + return imagesMap + | action == ImageDelete && imageExists = do + when (_imCount image == 1) $ + VG.deleteImage c (_imNvImage image) + return $ imgDelete name imagesMap + | otherwise = + return imagesMap + where + name = _irName imageReq + action = _irAction imageReq + size = _irSize imageReq + + cw = round (size ^. L.w) + ch = round (size ^. L.h) + + imgData = fromJust $ _irImgData imageReq + imgFlags = _irFlags imageReq + flags = Set.fromList (toVGImgFlag <$> imgFlags) + + imgDef = ImageDef name size imgData imgFlags + createImage = VG.createImageRGBA c cw ch flags imgData + + mimage = M.lookup name imagesMap + imageExists = isJust mimage + image = fromJust mimage + sizeMatches = size == _imImageDef image ^. L.size + +toVGImgFlag :: ImageFlag -> VGI.ImageFlags +toVGImgFlag ImageNearest = VGI.ImageNearest +toVGImgFlag ImageRepeatX = VGI.ImageRepeatx +toVGImgFlag ImageRepeatY = VGI.ImageRepeaty + +imgIncreaseCount :: Text -> ImagesMap -> ImagesMap +imgIncreaseCount name imagesMap = newImageMap where + incCount img = img { _imCount = _imCount img + 1 } + newImageMap = M.adjust incCount name imagesMap + +imgInsertNew :: Text -> ImageDef -> ImagesMap -> VG.Image -> ImagesMap +imgInsertNew name imageDef imagesMap nvImg = newImagesMap where + image = Image imageDef nvImg 0 + newImagesMap = M.insert name image imagesMap + +imgDelete :: Text -> ImagesMap -> ImagesMap +imgDelete name imagesMap = newImageMap where + deleteInstance img + | _imCount img > 1 = Just $ img { _imCount = _imCount img - 1 } + | otherwise = Nothing + newImageMap = M.update deleteInstance name imagesMap + +clearImagesMap :: VG.Context -> ImagesMap -> IO () +clearImagesMap c imagesMap = do + putStrLn "Clearing images map" + forM_ (M.elems imagesMap) $ \image -> + VG.deleteImage c (_imNvImage image) + +colorToPaint :: Color -> VG.Color +colorToPaint (Color r g b a) + | a >= 1.0 = VG.rgb red green blue + | otherwise = VG.rgba red green blue alpha + where + red = fromIntegral r + green = fromIntegral g + blue = fromIntegral b + alpha = round $ a * 255 + +convertWinding :: Winding -> VG.Winding +convertWinding CW = VG.CW +convertWinding CCW = VG.CCW + +sizeToCSize :: Size -> Double -> CSize +sizeToCSize (Size w h) dpr = CSize cw ch where + cw = realToFrac $ w * dpr + ch = realToFrac $ h * dpr + +pointToCPoint :: Point -> Double -> CPoint +pointToCPoint (Point x y) dpr = CPoint cx cy where + cx = realToFrac $ x * dpr + cy = realToFrac $ y * dpr + +rectToCRect :: Rect -> Double -> CRect +rectToCRect (Rect x y w h) dpr = CRect cx cy cw ch where + cx = realToFrac $ x * dpr + cy = realToFrac $ y * dpr + ch = realToFrac $ h * dpr + cw = realToFrac $ w * dpr diff --git a/src/Monomer/Graphics/RemixIcon.hs b/src/Monomer/Graphics/RemixIcon.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/RemixIcon.hs @@ -0,0 +1,2305 @@ +{-| +Module : Monomer.Graphics.RemixIcon +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Utility functions to retrieve the Unicode code point of a Remix Font using its +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` +in the corresponding widget. + +Existing icons can be browsed in https://remixicon.com. + +The name has to be updated by adding a _remix_ prefix, applying capital case and +removing dashes. For example, _"delete-bin"_ should be transformed to +_"remixDeleteBin"_. Also note that most icons have line and fill versions, so +you will also need to include that (for example, _"remixDeleteBinLine"_ or +_"remixDeleteBinFill"_). +-} +{-# LANGUAGE BinaryLiterals #-} + +module Monomer.Graphics.RemixIcon where + +import Data.Text (Text) + +import qualified Data.Text as T + +toGlyph :: Int -> Text +toGlyph = T.singleton . toEnum + +remix24HoursFill = toGlyph 0XEA01 +remix24HoursLine = toGlyph 0XEA02 +remix4kFill = toGlyph 0XEA03 +remix4kLine = toGlyph 0XEA04 +remixAB = toGlyph 0XEA05 +remixAccountBoxFill = toGlyph 0XEA06 +remixAccountBoxLine = toGlyph 0XEA07 +remixAccountCircleFill = toGlyph 0XEA08 +remixAccountCircleLine = toGlyph 0XEA09 +remixAccountPinBoxFill = toGlyph 0XEA0A +remixAccountPinBoxLine = toGlyph 0XEA0B +remixAccountPinCircleFill = toGlyph 0XEA0C +remixAccountPinCircleLine = toGlyph 0XEA0D +remixAddBoxFill = toGlyph 0XEA0E +remixAddBoxLine = toGlyph 0XEA0F +remixAddCircleFill = toGlyph 0XEA10 +remixAddCircleLine = toGlyph 0XEA11 +remixAddFill = toGlyph 0XEA12 +remixAddLine = toGlyph 0XEA13 +remixAdminFill = toGlyph 0XEA14 +remixAdminLine = toGlyph 0XEA15 +remixAdvertisementFill = toGlyph 0XEA16 +remixAdvertisementLine = toGlyph 0XEA17 +remixAirplayFill = toGlyph 0XEA18 +remixAirplayLine = toGlyph 0XEA19 +remixAlarmFill = toGlyph 0XEA1A +remixAlarmLine = toGlyph 0XEA1B +remixAlarmWarningFill = toGlyph 0XEA1C +remixAlarmWarningLine = toGlyph 0XEA1D +remixAlbumFill = toGlyph 0XEA1E +remixAlbumLine = toGlyph 0XEA1F +remixAlertFill = toGlyph 0XEA20 +remixAlertLine = toGlyph 0XEA21 +remixAliensFill = toGlyph 0XEA22 +remixAliensLine = toGlyph 0XEA23 +remixAlignBottom = toGlyph 0XEA24 +remixAlignCenter = toGlyph 0XEA25 +remixAlignJustify = toGlyph 0XEA26 +remixAlignLeft = toGlyph 0XEA27 +remixAlignRight = toGlyph 0XEA28 +remixAlignTop = toGlyph 0XEA29 +remixAlignVertically = toGlyph 0XEA2A +remixAlipayFill = toGlyph 0XEA2B +remixAlipayLine = toGlyph 0XEA2C +remixAmazonFill = toGlyph 0XEA2D +remixAmazonLine = toGlyph 0XEA2E +remixAnchorFill = toGlyph 0XEA2F +remixAnchorLine = toGlyph 0XEA30 +remixAncientGateFill = toGlyph 0XEA31 +remixAncientGateLine = toGlyph 0XEA32 +remixAncientPavilionFill = toGlyph 0XEA33 +remixAncientPavilionLine = toGlyph 0XEA34 +remixAndroidFill = toGlyph 0XEA35 +remixAndroidLine = toGlyph 0XEA36 +remixAngularjsFill = toGlyph 0XEA37 +remixAngularjsLine = toGlyph 0XEA38 +remixAnticlockwise2Fill = toGlyph 0XEA39 +remixAnticlockwise2Line = toGlyph 0XEA3A +remixAnticlockwiseFill = toGlyph 0XEA3B +remixAnticlockwiseLine = toGlyph 0XEA3C +remixAppStoreFill = toGlyph 0XEA3D +remixAppStoreLine = toGlyph 0XEA3E +remixAppleFill = toGlyph 0XEA3F +remixAppleLine = toGlyph 0XEA40 +remixApps2Fill = toGlyph 0XEA41 +remixApps2Line = toGlyph 0XEA42 +remixAppsFill = toGlyph 0XEA43 +remixAppsLine = toGlyph 0XEA44 +remixArchiveDrawerFill = toGlyph 0XEA45 +remixArchiveDrawerLine = toGlyph 0XEA46 +remixArchiveFill = toGlyph 0XEA47 +remixArchiveLine = toGlyph 0XEA48 +remixArrowDownCircleFill = toGlyph 0XEA49 +remixArrowDownCircleLine = toGlyph 0XEA4A +remixArrowDownFill = toGlyph 0XEA4B +remixArrowDownLine = toGlyph 0XEA4C +remixArrowDownSFill = toGlyph 0XEA4D +remixArrowDownSLine = toGlyph 0XEA4E +remixArrowDropDownFill = toGlyph 0XEA4F +remixArrowDropDownLine = toGlyph 0XEA50 +remixArrowDropLeftFill = toGlyph 0XEA51 +remixArrowDropLeftLine = toGlyph 0XEA52 +remixArrowDropRightFill = toGlyph 0XEA53 +remixArrowDropRightLine = toGlyph 0XEA54 +remixArrowDropUpFill = toGlyph 0XEA55 +remixArrowDropUpLine = toGlyph 0XEA56 +remixArrowGoBackFill = toGlyph 0XEA57 +remixArrowGoBackLine = toGlyph 0XEA58 +remixArrowGoForwardFill = toGlyph 0XEA59 +remixArrowGoForwardLine = toGlyph 0XEA5A +remixArrowLeftCircleFill = toGlyph 0XEA5B +remixArrowLeftCircleLine = toGlyph 0XEA5C +remixArrowLeftDownFill = toGlyph 0XEA5D +remixArrowLeftDownLine = toGlyph 0XEA5E +remixArrowLeftFill = toGlyph 0XEA5F +remixArrowLeftLine = toGlyph 0XEA60 +remixArrowLeftRightFill = toGlyph 0XEA61 +remixArrowLeftRightLine = toGlyph 0XEA62 +remixArrowLeftSFill = toGlyph 0XEA63 +remixArrowLeftSLine = toGlyph 0XEA64 +remixArrowLeftUpFill = toGlyph 0XEA65 +remixArrowLeftUpLine = toGlyph 0XEA66 +remixArrowRightCircleFill = toGlyph 0XEA67 +remixArrowRightCircleLine = toGlyph 0XEA68 +remixArrowRightDownFill = toGlyph 0XEA69 +remixArrowRightDownLine = toGlyph 0XEA6A +remixArrowRightFill = toGlyph 0XEA6B +remixArrowRightLine = toGlyph 0XEA6C +remixArrowRightSFill = toGlyph 0XEA6D +remixArrowRightSLine = toGlyph 0XEA6E +remixArrowRightUpFill = toGlyph 0XEA6F +remixArrowRightUpLine = toGlyph 0XEA70 +remixArrowUpCircleFill = toGlyph 0XEA71 +remixArrowUpCircleLine = toGlyph 0XEA72 +remixArrowUpDownFill = toGlyph 0XEA73 +remixArrowUpDownLine = toGlyph 0XEA74 +remixArrowUpFill = toGlyph 0XEA75 +remixArrowUpLine = toGlyph 0XEA76 +remixArrowUpSFill = toGlyph 0XEA77 +remixArrowUpSLine = toGlyph 0XEA78 +remixArtboard2Fill = toGlyph 0XEA79 +remixArtboard2Line = toGlyph 0XEA7A +remixArtboardFill = toGlyph 0XEA7B +remixArtboardLine = toGlyph 0XEA7C +remixArticleFill = toGlyph 0XEA7D +remixArticleLine = toGlyph 0XEA7E +remixAspectRatioFill = toGlyph 0XEA7F +remixAspectRatioLine = toGlyph 0XEA80 +remixAsterisk = toGlyph 0XEA81 +remixAtFill = toGlyph 0XEA82 +remixAtLine = toGlyph 0XEA83 +remixAttachment2 = toGlyph 0XEA84 +remixAttachmentFill = toGlyph 0XEA85 +remixAttachmentLine = toGlyph 0XEA86 +remixAuctionFill = toGlyph 0XEA87 +remixAuctionLine = toGlyph 0XEA88 +remixAwardFill = toGlyph 0XEA89 +remixAwardLine = toGlyph 0XEA8A +remixBaiduFill = toGlyph 0XEA8B +remixBaiduLine = toGlyph 0XEA8C +remixBallPenFill = toGlyph 0XEA8D +remixBallPenLine = toGlyph 0XEA8E +remixBankCard2Fill = toGlyph 0XEA8F +remixBankCard2Line = toGlyph 0XEA90 +remixBankCardFill = toGlyph 0XEA91 +remixBankCardLine = toGlyph 0XEA92 +remixBankFill = toGlyph 0XEA93 +remixBankLine = toGlyph 0XEA94 +remixBarChart2Fill = toGlyph 0XEA95 +remixBarChart2Line = toGlyph 0XEA96 +remixBarChartBoxFill = toGlyph 0XEA97 +remixBarChartBoxLine = toGlyph 0XEA98 +remixBarChartFill = toGlyph 0XEA99 +remixBarChartGroupedFill = toGlyph 0XEA9A +remixBarChartGroupedLine = toGlyph 0XEA9B +remixBarChartHorizontalFill = toGlyph 0XEA9C +remixBarChartHorizontalLine = toGlyph 0XEA9D +remixBarChartLine = toGlyph 0XEA9E +remixBarcodeBoxFill = toGlyph 0XEA9F +remixBarcodeBoxLine = toGlyph 0XEAA0 +remixBarcodeFill = toGlyph 0XEAA1 +remixBarcodeLine = toGlyph 0XEAA2 +remixBarricadeFill = toGlyph 0XEAA3 +remixBarricadeLine = toGlyph 0XEAA4 +remixBaseStationFill = toGlyph 0XEAA5 +remixBaseStationLine = toGlyph 0XEAA6 +remixBasketballFill = toGlyph 0XEAA7 +remixBasketballLine = toGlyph 0XEAA8 +remixBattery2ChargeFill = toGlyph 0XEAA9 +remixBattery2ChargeLine = toGlyph 0XEAAA +remixBattery2Fill = toGlyph 0XEAAB +remixBattery2Line = toGlyph 0XEAAC +remixBatteryChargeFill = toGlyph 0XEAAD +remixBatteryChargeLine = toGlyph 0XEAAE +remixBatteryFill = toGlyph 0XEAAF +remixBatteryLine = toGlyph 0XEAB0 +remixBatteryLowFill = toGlyph 0XEAB1 +remixBatteryLowLine = toGlyph 0XEAB2 +remixBatterySaverFill = toGlyph 0XEAB3 +remixBatterySaverLine = toGlyph 0XEAB4 +remixBatteryShareFill = toGlyph 0XEAB5 +remixBatteryShareLine = toGlyph 0XEAB6 +remixBearSmileFill = toGlyph 0XEAB7 +remixBearSmileLine = toGlyph 0XEAB8 +remixBehanceFill = toGlyph 0XEAB9 +remixBehanceLine = toGlyph 0XEABA +remixBellFill = toGlyph 0XEABB +remixBellLine = toGlyph 0XEABC +remixBikeFill = toGlyph 0XEABD +remixBikeLine = toGlyph 0XEABE +remixBilibiliFill = toGlyph 0XEABF +remixBilibiliLine = toGlyph 0XEAC0 +remixBillFill = toGlyph 0XEAC1 +remixBillLine = toGlyph 0XEAC2 +remixBilliardsFill = toGlyph 0XEAC3 +remixBilliardsLine = toGlyph 0XEAC4 +remixBitCoinFill = toGlyph 0XEAC5 +remixBitCoinLine = toGlyph 0XEAC6 +remixBlazeFill = toGlyph 0XEAC7 +remixBlazeLine = toGlyph 0XEAC8 +remixBluetoothConnectFill = toGlyph 0XEAC9 +remixBluetoothConnectLine = toGlyph 0XEACA +remixBluetoothFill = toGlyph 0XEACB +remixBluetoothLine = toGlyph 0XEACC +remixBlurOffFill = toGlyph 0XEACD +remixBlurOffLine = toGlyph 0XEACE +remixBodyScanFill = toGlyph 0XEACF +remixBodyScanLine = toGlyph 0XEAD0 +remixBold = toGlyph 0XEAD1 +remixBook2Fill = toGlyph 0XEAD2 +remixBook2Line = toGlyph 0XEAD3 +remixBook3Fill = toGlyph 0XEAD4 +remixBook3Line = toGlyph 0XEAD5 +remixBookFill = toGlyph 0XEAD6 +remixBookLine = toGlyph 0XEAD7 +remixBookMarkFill = toGlyph 0XEAD8 +remixBookMarkLine = toGlyph 0XEAD9 +remixBookOpenFill = toGlyph 0XEADA +remixBookOpenLine = toGlyph 0XEADB +remixBookReadFill = toGlyph 0XEADC +remixBookReadLine = toGlyph 0XEADD +remixBookletFill = toGlyph 0XEADE +remixBookletLine = toGlyph 0XEADF +remixBookmark2Fill = toGlyph 0XEAE0 +remixBookmark2Line = toGlyph 0XEAE1 +remixBookmark3Fill = toGlyph 0XEAE2 +remixBookmark3Line = toGlyph 0XEAE3 +remixBookmarkFill = toGlyph 0XEAE4 +remixBookmarkLine = toGlyph 0XEAE5 +remixBoxingFill = toGlyph 0XEAE6 +remixBoxingLine = toGlyph 0XEAE7 +remixBracesFill = toGlyph 0XEAE8 +remixBracesLine = toGlyph 0XEAE9 +remixBracketsFill = toGlyph 0XEAEA +remixBracketsLine = toGlyph 0XEAEB +remixBriefcase2Fill = toGlyph 0XEAEC +remixBriefcase2Line = toGlyph 0XEAED +remixBriefcase3Fill = toGlyph 0XEAEE +remixBriefcase3Line = toGlyph 0XEAEF +remixBriefcase4Fill = toGlyph 0XEAF0 +remixBriefcase4Line = toGlyph 0XEAF1 +remixBriefcase5Fill = toGlyph 0XEAF2 +remixBriefcase5Line = toGlyph 0XEAF3 +remixBriefcaseFill = toGlyph 0XEAF4 +remixBriefcaseLine = toGlyph 0XEAF5 +remixBringForward = toGlyph 0XEAF6 +remixBringToFront = toGlyph 0XEAF7 +remixBroadcastFill = toGlyph 0XEAF8 +remixBroadcastLine = toGlyph 0XEAF9 +remixBrush2Fill = toGlyph 0XEAFA +remixBrush2Line = toGlyph 0XEAFB +remixBrush3Fill = toGlyph 0XEAFC +remixBrush3Line = toGlyph 0XEAFD +remixBrush4Fill = toGlyph 0XEAFE +remixBrush4Line = toGlyph 0XEAFF +remixBrushFill = toGlyph 0XEB00 +remixBrushLine = toGlyph 0XEB01 +remixBubbleChartFill = toGlyph 0XEB02 +remixBubbleChartLine = toGlyph 0XEB03 +remixBug2Fill = toGlyph 0XEB04 +remixBug2Line = toGlyph 0XEB05 +remixBugFill = toGlyph 0XEB06 +remixBugLine = toGlyph 0XEB07 +remixBuilding2Fill = toGlyph 0XEB08 +remixBuilding2Line = toGlyph 0XEB09 +remixBuilding3Fill = toGlyph 0XEB0A +remixBuilding3Line = toGlyph 0XEB0B +remixBuilding4Fill = toGlyph 0XEB0C +remixBuilding4Line = toGlyph 0XEB0D +remixBuildingFill = toGlyph 0XEB0E +remixBuildingLine = toGlyph 0XEB0F +remixBus2Fill = toGlyph 0XEB10 +remixBus2Line = toGlyph 0XEB11 +remixBusFill = toGlyph 0XEB12 +remixBusLine = toGlyph 0XEB13 +remixBusWifiFill = toGlyph 0XEB14 +remixBusWifiLine = toGlyph 0XEB15 +remixCactusFill = toGlyph 0XEB16 +remixCactusLine = toGlyph 0XEB17 +remixCake2Fill = toGlyph 0XEB18 +remixCake2Line = toGlyph 0XEB19 +remixCake3Fill = toGlyph 0XEB1A +remixCake3Line = toGlyph 0XEB1B +remixCakeFill = toGlyph 0XEB1C +remixCakeLine = toGlyph 0XEB1D +remixCalculatorFill = toGlyph 0XEB1E +remixCalculatorLine = toGlyph 0XEB1F +remixCalendar2Fill = toGlyph 0XEB20 +remixCalendar2Line = toGlyph 0XEB21 +remixCalendarCheckFill = toGlyph 0XEB22 +remixCalendarCheckLine = toGlyph 0XEB23 +remixCalendarEventFill = toGlyph 0XEB24 +remixCalendarEventLine = toGlyph 0XEB25 +remixCalendarFill = toGlyph 0XEB26 +remixCalendarLine = toGlyph 0XEB27 +remixCalendarTodoFill = toGlyph 0XEB28 +remixCalendarTodoLine = toGlyph 0XEB29 +remixCamera2Fill = toGlyph 0XEB2A +remixCamera2Line = toGlyph 0XEB2B +remixCamera3Fill = toGlyph 0XEB2C +remixCamera3Line = toGlyph 0XEB2D +remixCameraFill = toGlyph 0XEB2E +remixCameraLensFill = toGlyph 0XEB2F +remixCameraLensLine = toGlyph 0XEB30 +remixCameraLine = toGlyph 0XEB31 +remixCameraOffFill = toGlyph 0XEB32 +remixCameraOffLine = toGlyph 0XEB33 +remixCameraSwitchFill = toGlyph 0XEB34 +remixCameraSwitchLine = toGlyph 0XEB35 +remixCapsuleFill = toGlyph 0XEB36 +remixCapsuleLine = toGlyph 0XEB37 +remixCarFill = toGlyph 0XEB38 +remixCarLine = toGlyph 0XEB39 +remixCarWashingFill = toGlyph 0XEB3A +remixCarWashingLine = toGlyph 0XEB3B +remixCaravanFill = toGlyph 0XEB3C +remixCaravanLine = toGlyph 0XEB3D +remixCastFill = toGlyph 0XEB3E +remixCastLine = toGlyph 0XEB3F +remixCellphoneFill = toGlyph 0XEB40 +remixCellphoneLine = toGlyph 0XEB41 +remixCelsiusFill = toGlyph 0XEB42 +remixCelsiusLine = toGlyph 0XEB43 +remixCentosFill = toGlyph 0XEB44 +remixCentosLine = toGlyph 0XEB45 +remixCharacterRecognitionFill = toGlyph 0XEB46 +remixCharacterRecognitionLine = toGlyph 0XEB47 +remixChargingPile2Fill = toGlyph 0XEB48 +remixChargingPile2Line = toGlyph 0XEB49 +remixChargingPileFill = toGlyph 0XEB4A +remixChargingPileLine = toGlyph 0XEB4B +remixChat1Fill = toGlyph 0XEB4C +remixChat1Line = toGlyph 0XEB4D +remixChat2Fill = toGlyph 0XEB4E +remixChat2Line = toGlyph 0XEB4F +remixChat3Fill = toGlyph 0XEB50 +remixChat3Line = toGlyph 0XEB51 +remixChat4Fill = toGlyph 0XEB52 +remixChat4Line = toGlyph 0XEB53 +remixChatCheckFill = toGlyph 0XEB54 +remixChatCheckLine = toGlyph 0XEB55 +remixChatDeleteFill = toGlyph 0XEB56 +remixChatDeleteLine = toGlyph 0XEB57 +remixChatDownloadFill = toGlyph 0XEB58 +remixChatDownloadLine = toGlyph 0XEB59 +remixChatFollowUpFill = toGlyph 0XEB5A +remixChatFollowUpLine = toGlyph 0XEB5B +remixChatForwardFill = toGlyph 0XEB5C +remixChatForwardLine = toGlyph 0XEB5D +remixChatHeartFill = toGlyph 0XEB5E +remixChatHeartLine = toGlyph 0XEB5F +remixChatHistoryFill = toGlyph 0XEB60 +remixChatHistoryLine = toGlyph 0XEB61 +remixChatNewFill = toGlyph 0XEB62 +remixChatNewLine = toGlyph 0XEB63 +remixChatOffFill = toGlyph 0XEB64 +remixChatOffLine = toGlyph 0XEB65 +remixChatPollFill = toGlyph 0XEB66 +remixChatPollLine = toGlyph 0XEB67 +remixChatPrivateFill = toGlyph 0XEB68 +remixChatPrivateLine = toGlyph 0XEB69 +remixChatQuoteFill = toGlyph 0XEB6A +remixChatQuoteLine = toGlyph 0XEB6B +remixChatSettingsFill = toGlyph 0XEB6C +remixChatSettingsLine = toGlyph 0XEB6D +remixChatSmile2Fill = toGlyph 0XEB6E +remixChatSmile2Line = toGlyph 0XEB6F +remixChatSmile3Fill = toGlyph 0XEB70 +remixChatSmile3Line = toGlyph 0XEB71 +remixChatSmileFill = toGlyph 0XEB72 +remixChatSmileLine = toGlyph 0XEB73 +remixChatUploadFill = toGlyph 0XEB74 +remixChatUploadLine = toGlyph 0XEB75 +remixChatVoiceFill = toGlyph 0XEB76 +remixChatVoiceLine = toGlyph 0XEB77 +remixCheckDoubleFill = toGlyph 0XEB78 +remixCheckDoubleLine = toGlyph 0XEB79 +remixCheckFill = toGlyph 0XEB7A +remixCheckLine = toGlyph 0XEB7B +remixCheckboxBlankCircleFill = toGlyph 0XEB7C +remixCheckboxBlankCircleLine = toGlyph 0XEB7D +remixCheckboxBlankFill = toGlyph 0XEB7E +remixCheckboxBlankLine = toGlyph 0XEB7F +remixCheckboxCircleFill = toGlyph 0XEB80 +remixCheckboxCircleLine = toGlyph 0XEB81 +remixCheckboxFill = toGlyph 0XEB82 +remixCheckboxIndeterminateFill = toGlyph 0XEB83 +remixCheckboxIndeterminateLine = toGlyph 0XEB84 +remixCheckboxLine = toGlyph 0XEB85 +remixCheckboxMultipleBlankFill = toGlyph 0XEB86 +remixCheckboxMultipleBlankLine = toGlyph 0XEB87 +remixCheckboxMultipleFill = toGlyph 0XEB88 +remixCheckboxMultipleLine = toGlyph 0XEB89 +remixChinaRailwayFill = toGlyph 0XEB8A +remixChinaRailwayLine = toGlyph 0XEB8B +remixChromeFill = toGlyph 0XEB8C +remixChromeLine = toGlyph 0XEB8D +remixClapperboardFill = toGlyph 0XEB8E +remixClapperboardLine = toGlyph 0XEB8F +remixClipboardFill = toGlyph 0XEB90 +remixClipboardLine = toGlyph 0XEB91 +remixClockwise2Fill = toGlyph 0XEB92 +remixClockwise2Line = toGlyph 0XEB93 +remixClockwiseFill = toGlyph 0XEB94 +remixClockwiseLine = toGlyph 0XEB95 +remixCloseCircleFill = toGlyph 0XEB96 +remixCloseCircleLine = toGlyph 0XEB97 +remixCloseFill = toGlyph 0XEB98 +remixCloseLine = toGlyph 0XEB99 +remixClosedCaptioningFill = toGlyph 0XEB9A +remixClosedCaptioningLine = toGlyph 0XEB9B +remixCloudFill = toGlyph 0XEB9C +remixCloudLine = toGlyph 0XEB9D +remixCloudOffFill = toGlyph 0XEB9E +remixCloudOffLine = toGlyph 0XEB9F +remixCloudWindyFill = toGlyph 0XEBA0 +remixCloudWindyLine = toGlyph 0XEBA1 +remixCloudy2Fill = toGlyph 0XEBA2 +remixCloudy2Line = toGlyph 0XEBA3 +remixCloudyFill = toGlyph 0XEBA4 +remixCloudyLine = toGlyph 0XEBA5 +remixCodeBoxFill = toGlyph 0XEBA6 +remixCodeBoxLine = toGlyph 0XEBA7 +remixCodeFill = toGlyph 0XEBA8 +remixCodeLine = toGlyph 0XEBA9 +remixCodeSFill = toGlyph 0XEBAA +remixCodeSLine = toGlyph 0XEBAB +remixCodeSSlashFill = toGlyph 0XEBAC +remixCodeSSlashLine = toGlyph 0XEBAD +remixCodeView = toGlyph 0XEBAE +remixCodepenFill = toGlyph 0XEBAF +remixCodepenLine = toGlyph 0XEBB0 +remixCoinFill = toGlyph 0XEBB1 +remixCoinLine = toGlyph 0XEBB2 +remixCoinsFill = toGlyph 0XEBB3 +remixCoinsLine = toGlyph 0XEBB4 +remixCollageFill = toGlyph 0XEBB5 +remixCollageLine = toGlyph 0XEBB6 +remixCommandFill = toGlyph 0XEBB7 +remixCommandLine = toGlyph 0XEBB8 +remixCommunityFill = toGlyph 0XEBB9 +remixCommunityLine = toGlyph 0XEBBA +remixCompass2Fill = toGlyph 0XEBBB +remixCompass2Line = toGlyph 0XEBBC +remixCompass3Fill = toGlyph 0XEBBD +remixCompass3Line = toGlyph 0XEBBE +remixCompass4Fill = toGlyph 0XEBBF +remixCompass4Line = toGlyph 0XEBC0 +remixCompassDiscoverFill = toGlyph 0XEBC1 +remixCompassDiscoverLine = toGlyph 0XEBC2 +remixCompassFill = toGlyph 0XEBC3 +remixCompassLine = toGlyph 0XEBC4 +remixCompasses2Fill = toGlyph 0XEBC5 +remixCompasses2Line = toGlyph 0XEBC6 +remixCompassesFill = toGlyph 0XEBC7 +remixCompassesLine = toGlyph 0XEBC8 +remixComputerFill = toGlyph 0XEBC9 +remixComputerLine = toGlyph 0XEBCA +remixContactsBook2Fill = toGlyph 0XEBCB +remixContactsBook2Line = toGlyph 0XEBCC +remixContactsBookFill = toGlyph 0XEBCD +remixContactsBookLine = toGlyph 0XEBCE +remixContactsBookUploadFill = toGlyph 0XEBCF +remixContactsBookUploadLine = toGlyph 0XEBD0 +remixContactsFill = toGlyph 0XEBD1 +remixContactsLine = toGlyph 0XEBD2 +remixContrast2Fill = toGlyph 0XEBD3 +remixContrast2Line = toGlyph 0XEBD4 +remixContrastDrop2Fill = toGlyph 0XEBD5 +remixContrastDrop2Line = toGlyph 0XEBD6 +remixContrastDropFill = toGlyph 0XEBD7 +remixContrastDropLine = toGlyph 0XEBD8 +remixContrastFill = toGlyph 0XEBD9 +remixContrastLine = toGlyph 0XEBDA +remixCopperCoinFill = toGlyph 0XEBDB +remixCopperCoinLine = toGlyph 0XEBDC +remixCopperDiamondFill = toGlyph 0XEBDD +remixCopperDiamondLine = toGlyph 0XEBDE +remixCopyleftFill = toGlyph 0XEBDF +remixCopyleftLine = toGlyph 0XEBE0 +remixCopyrightFill = toGlyph 0XEBE1 +remixCopyrightLine = toGlyph 0XEBE2 +remixCoreosFill = toGlyph 0XEBE3 +remixCoreosLine = toGlyph 0XEBE4 +remixCoupon2Fill = toGlyph 0XEBE5 +remixCoupon2Line = toGlyph 0XEBE6 +remixCoupon3Fill = toGlyph 0XEBE7 +remixCoupon3Line = toGlyph 0XEBE8 +remixCoupon4Fill = toGlyph 0XEBE9 +remixCoupon4Line = toGlyph 0XEBEA +remixCoupon5Fill = toGlyph 0XEBEB +remixCoupon5Line = toGlyph 0XEBEC +remixCouponFill = toGlyph 0XEBED +remixCouponLine = toGlyph 0XEBEE +remixCpuFill = toGlyph 0XEBEF +remixCpuLine = toGlyph 0XEBF0 +remixCreativeCommonsByFill = toGlyph 0XEBF1 +remixCreativeCommonsByLine = toGlyph 0XEBF2 +remixCreativeCommonsFill = toGlyph 0XEBF3 +remixCreativeCommonsLine = toGlyph 0XEBF4 +remixCreativeCommonsNcFill = toGlyph 0XEBF5 +remixCreativeCommonsNcLine = toGlyph 0XEBF6 +remixCreativeCommonsNdFill = toGlyph 0XEBF7 +remixCreativeCommonsNdLine = toGlyph 0XEBF8 +remixCreativeCommonsSaFill = toGlyph 0XEBF9 +remixCreativeCommonsSaLine = toGlyph 0XEBFA +remixCreativeCommonsZeroFill = toGlyph 0XEBFB +remixCreativeCommonsZeroLine = toGlyph 0XEBFC +remixCriminalFill = toGlyph 0XEBFD +remixCriminalLine = toGlyph 0XEBFE +remixCrop2Fill = toGlyph 0XEBFF +remixCrop2Line = toGlyph 0XEC00 +remixCropFill = toGlyph 0XEC01 +remixCropLine = toGlyph 0XEC02 +remixCss3Fill = toGlyph 0XEC03 +remixCss3Line = toGlyph 0XEC04 +remixCupFill = toGlyph 0XEC05 +remixCupLine = toGlyph 0XEC06 +remixCurrencyFill = toGlyph 0XEC07 +remixCurrencyLine = toGlyph 0XEC08 +remixCursorFill = toGlyph 0XEC09 +remixCursorLine = toGlyph 0XEC0A +remixCustomerService2Fill = toGlyph 0XEC0B +remixCustomerService2Line = toGlyph 0XEC0C +remixCustomerServiceFill = toGlyph 0XEC0D +remixCustomerServiceLine = toGlyph 0XEC0E +remixDashboard2Fill = toGlyph 0XEC0F +remixDashboard2Line = toGlyph 0XEC10 +remixDashboard3Fill = toGlyph 0XEC11 +remixDashboard3Line = toGlyph 0XEC12 +remixDashboardFill = toGlyph 0XEC13 +remixDashboardLine = toGlyph 0XEC14 +remixDatabase2Fill = toGlyph 0XEC15 +remixDatabase2Line = toGlyph 0XEC16 +remixDatabaseFill = toGlyph 0XEC17 +remixDatabaseLine = toGlyph 0XEC18 +remixDeleteBack2Fill = toGlyph 0XEC19 +remixDeleteBack2Line = toGlyph 0XEC1A +remixDeleteBackFill = toGlyph 0XEC1B +remixDeleteBackLine = toGlyph 0XEC1C +remixDeleteBin2Fill = toGlyph 0XEC1D +remixDeleteBin2Line = toGlyph 0XEC1E +remixDeleteBin3Fill = toGlyph 0XEC1F +remixDeleteBin3Line = toGlyph 0XEC20 +remixDeleteBin4Fill = toGlyph 0XEC21 +remixDeleteBin4Line = toGlyph 0XEC22 +remixDeleteBin5Fill = toGlyph 0XEC23 +remixDeleteBin5Line = toGlyph 0XEC24 +remixDeleteBin6Fill = toGlyph 0XEC25 +remixDeleteBin6Line = toGlyph 0XEC26 +remixDeleteBin7Fill = toGlyph 0XEC27 +remixDeleteBin7Line = toGlyph 0XEC28 +remixDeleteBinFill = toGlyph 0XEC29 +remixDeleteBinLine = toGlyph 0XEC2A +remixDeleteColumn = toGlyph 0XEC2B +remixDeleteRow = toGlyph 0XEC2C +remixDeviceFill = toGlyph 0XEC2D +remixDeviceLine = toGlyph 0XEC2E +remixDeviceRecoverFill = toGlyph 0XEC2F +remixDeviceRecoverLine = toGlyph 0XEC30 +remixDingdingFill = toGlyph 0XEC31 +remixDingdingLine = toGlyph 0XEC32 +remixDirectionFill = toGlyph 0XEC33 +remixDirectionLine = toGlyph 0XEC34 +remixDiscFill = toGlyph 0XEC35 +remixDiscLine = toGlyph 0XEC36 +remixDiscordFill = toGlyph 0XEC37 +remixDiscordLine = toGlyph 0XEC38 +remixDiscussFill = toGlyph 0XEC39 +remixDiscussLine = toGlyph 0XEC3A +remixDislikeFill = toGlyph 0XEC3B +remixDislikeLine = toGlyph 0XEC3C +remixDisqusFill = toGlyph 0XEC3D +remixDisqusLine = toGlyph 0XEC3E +remixDivideFill = toGlyph 0XEC3F +remixDivideLine = toGlyph 0XEC40 +remixDonutChartFill = toGlyph 0XEC41 +remixDonutChartLine = toGlyph 0XEC42 +remixDoorClosedFill = toGlyph 0XEC43 +remixDoorClosedLine = toGlyph 0XEC44 +remixDoorFill = toGlyph 0XEC45 +remixDoorLine = toGlyph 0XEC46 +remixDoorLockBoxFill = toGlyph 0XEC47 +remixDoorLockBoxLine = toGlyph 0XEC48 +remixDoorLockFill = toGlyph 0XEC49 +remixDoorLockLine = toGlyph 0XEC4A +remixDoorOpenFill = toGlyph 0XEC4B +remixDoorOpenLine = toGlyph 0XEC4C +remixDossierFill = toGlyph 0XEC4D +remixDossierLine = toGlyph 0XEC4E +remixDoubanFill = toGlyph 0XEC4F +remixDoubanLine = toGlyph 0XEC50 +remixDoubleQuotesL = toGlyph 0XEC51 +remixDoubleQuotesR = toGlyph 0XEC52 +remixDownload2Fill = toGlyph 0XEC53 +remixDownload2Line = toGlyph 0XEC54 +remixDownloadCloud2Fill = toGlyph 0XEC55 +remixDownloadCloud2Line = toGlyph 0XEC56 +remixDownloadCloudFill = toGlyph 0XEC57 +remixDownloadCloudLine = toGlyph 0XEC58 +remixDownloadFill = toGlyph 0XEC59 +remixDownloadLine = toGlyph 0XEC5A +remixDraftFill = toGlyph 0XEC5B +remixDraftLine = toGlyph 0XEC5C +remixDragDropFill = toGlyph 0XEC5D +remixDragDropLine = toGlyph 0XEC5E +remixDragMove2Fill = toGlyph 0XEC5F +remixDragMove2Line = toGlyph 0XEC60 +remixDragMoveFill = toGlyph 0XEC61 +remixDragMoveLine = toGlyph 0XEC62 +remixDribbbleFill = toGlyph 0XEC63 +remixDribbbleLine = toGlyph 0XEC64 +remixDriveFill = toGlyph 0XEC65 +remixDriveLine = toGlyph 0XEC66 +remixDrizzleFill = toGlyph 0XEC67 +remixDrizzleLine = toGlyph 0XEC68 +remixDropFill = toGlyph 0XEC69 +remixDropLine = toGlyph 0XEC6A +remixDropboxFill = toGlyph 0XEC6B +remixDropboxLine = toGlyph 0XEC6C +remixDualSim1Fill = toGlyph 0XEC6D +remixDualSim1Line = toGlyph 0XEC6E +remixDualSim2Fill = toGlyph 0XEC6F +remixDualSim2Line = toGlyph 0XEC70 +remixDvFill = toGlyph 0XEC71 +remixDvLine = toGlyph 0XEC72 +remixDvdFill = toGlyph 0XEC73 +remixDvdLine = toGlyph 0XEC74 +remixEBike2Fill = toGlyph 0XEC75 +remixEBike2Line = toGlyph 0XEC76 +remixEBikeFill = toGlyph 0XEC77 +remixEBikeLine = toGlyph 0XEC78 +remixEarthFill = toGlyph 0XEC79 +remixEarthLine = toGlyph 0XEC7A +remixEarthquakeFill = toGlyph 0XEC7B +remixEarthquakeLine = toGlyph 0XEC7C +remixEdgeFill = toGlyph 0XEC7D +remixEdgeLine = toGlyph 0XEC7E +remixEdit2Fill = toGlyph 0XEC7F +remixEdit2Line = toGlyph 0XEC80 +remixEditBoxFill = toGlyph 0XEC81 +remixEditBoxLine = toGlyph 0XEC82 +remixEditCircleFill = toGlyph 0XEC83 +remixEditCircleLine = toGlyph 0XEC84 +remixEditFill = toGlyph 0XEC85 +remixEditLine = toGlyph 0XEC86 +remixEjectFill = toGlyph 0XEC87 +remixEjectLine = toGlyph 0XEC88 +remixEmotion2Fill = toGlyph 0XEC89 +remixEmotion2Line = toGlyph 0XEC8A +remixEmotionFill = toGlyph 0XEC8B +remixEmotionHappyFill = toGlyph 0XEC8C +remixEmotionHappyLine = toGlyph 0XEC8D +remixEmotionLaughFill = toGlyph 0XEC8E +remixEmotionLaughLine = toGlyph 0XEC8F +remixEmotionLine = toGlyph 0XEC90 +remixEmotionNormalFill = toGlyph 0XEC91 +remixEmotionNormalLine = toGlyph 0XEC92 +remixEmotionSadFill = toGlyph 0XEC93 +remixEmotionSadLine = toGlyph 0XEC94 +remixEmotionUnhappyFill = toGlyph 0XEC95 +remixEmotionUnhappyLine = toGlyph 0XEC96 +remixEmpathizeFill = toGlyph 0XEC97 +remixEmpathizeLine = toGlyph 0XEC98 +remixEmphasisCn = toGlyph 0XEC99 +remixEmphasis = toGlyph 0XEC9A +remixEnglishInput = toGlyph 0XEC9B +remixEqualizerFill = toGlyph 0XEC9C +remixEqualizerLine = toGlyph 0XEC9D +remixEraserFill = toGlyph 0XEC9E +remixEraserLine = toGlyph 0XEC9F +remixErrorWarningFill = toGlyph 0XECA0 +remixErrorWarningLine = toGlyph 0XECA1 +remixEvernoteFill = toGlyph 0XECA2 +remixEvernoteLine = toGlyph 0XECA3 +remixExchangeBoxFill = toGlyph 0XECA4 +remixExchangeBoxLine = toGlyph 0XECA5 +remixExchangeCnyFill = toGlyph 0XECA6 +remixExchangeCnyLine = toGlyph 0XECA7 +remixExchangeDollarFill = toGlyph 0XECA8 +remixExchangeDollarLine = toGlyph 0XECA9 +remixExchangeFill = toGlyph 0XECAA +remixExchangeFundsFill = toGlyph 0XECAB +remixExchangeFundsLine = toGlyph 0XECAC +remixExchangeLine = toGlyph 0XECAD +remixExternalLinkFill = toGlyph 0XECAE +remixExternalLinkLine = toGlyph 0XECAF +remixEye2Fill = toGlyph 0XECB0 +remixEye2Line = toGlyph 0XECB1 +remixEyeCloseFill = toGlyph 0XECB2 +remixEyeCloseLine = toGlyph 0XECB3 +remixEyeFill = toGlyph 0XECB4 +remixEyeLine = toGlyph 0XECB5 +remixEyeOffFill = toGlyph 0XECB6 +remixEyeOffLine = toGlyph 0XECB7 +remixFacebookBoxFill = toGlyph 0XECB8 +remixFacebookBoxLine = toGlyph 0XECB9 +remixFacebookCircleFill = toGlyph 0XECBA +remixFacebookCircleLine = toGlyph 0XECBB +remixFacebookFill = toGlyph 0XECBC +remixFacebookLine = toGlyph 0XECBD +remixFahrenheitFill = toGlyph 0XECBE +remixFahrenheitLine = toGlyph 0XECBF +remixFeedbackFill = toGlyph 0XECC0 +remixFeedbackLine = toGlyph 0XECC1 +remixFile2Fill = toGlyph 0XECC2 +remixFile2Line = toGlyph 0XECC3 +remixFile3Fill = toGlyph 0XECC4 +remixFile3Line = toGlyph 0XECC5 +remixFile4Fill = toGlyph 0XECC6 +remixFile4Line = toGlyph 0XECC7 +remixFileAddFill = toGlyph 0XECC8 +remixFileAddLine = toGlyph 0XECC9 +remixFileChart2Fill = toGlyph 0XECCA +remixFileChart2Line = toGlyph 0XECCB +remixFileChartFill = toGlyph 0XECCC +remixFileChartLine = toGlyph 0XECCD +remixFileCloudFill = toGlyph 0XECCE +remixFileCloudLine = toGlyph 0XECCF +remixFileCodeFill = toGlyph 0XECD0 +remixFileCodeLine = toGlyph 0XECD1 +remixFileCopy2Fill = toGlyph 0XECD2 +remixFileCopy2Line = toGlyph 0XECD3 +remixFileCopyFill = toGlyph 0XECD4 +remixFileCopyLine = toGlyph 0XECD5 +remixFileDamageFill = toGlyph 0XECD6 +remixFileDamageLine = toGlyph 0XECD7 +remixFileDownloadFill = toGlyph 0XECD8 +remixFileDownloadLine = toGlyph 0XECD9 +remixFileEditFill = toGlyph 0XECDA +remixFileEditLine = toGlyph 0XECDB +remixFileExcel2Fill = toGlyph 0XECDC +remixFileExcel2Line = toGlyph 0XECDD +remixFileExcelFill = toGlyph 0XECDE +remixFileExcelLine = toGlyph 0XECDF +remixFileFill = toGlyph 0XECE0 +remixFileForbidFill = toGlyph 0XECE1 +remixFileForbidLine = toGlyph 0XECE2 +remixFileGifFill = toGlyph 0XECE3 +remixFileGifLine = toGlyph 0XECE4 +remixFileHistoryFill = toGlyph 0XECE5 +remixFileHistoryLine = toGlyph 0XECE6 +remixFileHwpFill = toGlyph 0XECE7 +remixFileHwpLine = toGlyph 0XECE8 +remixFileInfoFill = toGlyph 0XECE9 +remixFileInfoLine = toGlyph 0XECEA +remixFileLine = toGlyph 0XECEB +remixFileList2Fill = toGlyph 0XECEC +remixFileList2Line = toGlyph 0XECED +remixFileList3Fill = toGlyph 0XECEE +remixFileList3Line = toGlyph 0XECEF +remixFileListFill = toGlyph 0XECF0 +remixFileListLine = toGlyph 0XECF1 +remixFileLockFill = toGlyph 0XECF2 +remixFileLockLine = toGlyph 0XECF3 +remixFileMarkFill = toGlyph 0XECF4 +remixFileMarkLine = toGlyph 0XECF5 +remixFileMusicFill = toGlyph 0XECF6 +remixFileMusicLine = toGlyph 0XECF7 +remixFilePaper2Fill = toGlyph 0XECF8 +remixFilePaper2Line = toGlyph 0XECF9 +remixFilePaperFill = toGlyph 0XECFA +remixFilePaperLine = toGlyph 0XECFB +remixFilePdfFill = toGlyph 0XECFC +remixFilePdfLine = toGlyph 0XECFD +remixFilePpt2Fill = toGlyph 0XECFE +remixFilePpt2Line = toGlyph 0XECFF +remixFilePptFill = toGlyph 0XED00 +remixFilePptLine = toGlyph 0XED01 +remixFileReduceFill = toGlyph 0XED02 +remixFileReduceLine = toGlyph 0XED03 +remixFileSearchFill = toGlyph 0XED04 +remixFileSearchLine = toGlyph 0XED05 +remixFileSettingsFill = toGlyph 0XED06 +remixFileSettingsLine = toGlyph 0XED07 +remixFileShield2Fill = toGlyph 0XED08 +remixFileShield2Line = toGlyph 0XED09 +remixFileShieldFill = toGlyph 0XED0A +remixFileShieldLine = toGlyph 0XED0B +remixFileShredFill = toGlyph 0XED0C +remixFileShredLine = toGlyph 0XED0D +remixFileTextFill = toGlyph 0XED0E +remixFileTextLine = toGlyph 0XED0F +remixFileTransferFill = toGlyph 0XED10 +remixFileTransferLine = toGlyph 0XED11 +remixFileUnknowFill = toGlyph 0XED12 +remixFileUnknowLine = toGlyph 0XED13 +remixFileUploadFill = toGlyph 0XED14 +remixFileUploadLine = toGlyph 0XED15 +remixFileUserFill = toGlyph 0XED16 +remixFileUserLine = toGlyph 0XED17 +remixFileWarningFill = toGlyph 0XED18 +remixFileWarningLine = toGlyph 0XED19 +remixFileWord2Fill = toGlyph 0XED1A +remixFileWord2Line = toGlyph 0XED1B +remixFileWordFill = toGlyph 0XED1C +remixFileWordLine = toGlyph 0XED1D +remixFileZipFill = toGlyph 0XED1E +remixFileZipLine = toGlyph 0XED1F +remixFilmFill = toGlyph 0XED20 +remixFilmLine = toGlyph 0XED21 +remixFilter2Fill = toGlyph 0XED22 +remixFilter2Line = toGlyph 0XED23 +remixFilter3Fill = toGlyph 0XED24 +remixFilter3Line = toGlyph 0XED25 +remixFilterFill = toGlyph 0XED26 +remixFilterLine = toGlyph 0XED27 +remixFilterOffFill = toGlyph 0XED28 +remixFilterOffLine = toGlyph 0XED29 +remixFindReplaceFill = toGlyph 0XED2A +remixFindReplaceLine = toGlyph 0XED2B +remixFinderFill = toGlyph 0XED2C +remixFinderLine = toGlyph 0XED2D +remixFingerprint2Fill = toGlyph 0XED2E +remixFingerprint2Line = toGlyph 0XED2F +remixFingerprintFill = toGlyph 0XED30 +remixFingerprintLine = toGlyph 0XED31 +remixFireFill = toGlyph 0XED32 +remixFireLine = toGlyph 0XED33 +remixFirefoxFill = toGlyph 0XED34 +remixFirefoxLine = toGlyph 0XED35 +remixFirstAidKitFill = toGlyph 0XED36 +remixFirstAidKitLine = toGlyph 0XED37 +remixFlag2Fill = toGlyph 0XED38 +remixFlag2Line = toGlyph 0XED39 +remixFlagFill = toGlyph 0XED3A +remixFlagLine = toGlyph 0XED3B +remixFlashlightFill = toGlyph 0XED3C +remixFlashlightLine = toGlyph 0XED3D +remixFlaskFill = toGlyph 0XED3E +remixFlaskLine = toGlyph 0XED3F +remixFlightLandFill = toGlyph 0XED40 +remixFlightLandLine = toGlyph 0XED41 +remixFlightTakeoffFill = toGlyph 0XED42 +remixFlightTakeoffLine = toGlyph 0XED43 +remixFloodFill = toGlyph 0XED44 +remixFloodLine = toGlyph 0XED45 +remixFlowChart = toGlyph 0XED46 +remixFlutterFill = toGlyph 0XED47 +remixFlutterLine = toGlyph 0XED48 +remixFocus2Fill = toGlyph 0XED49 +remixFocus2Line = toGlyph 0XED4A +remixFocus3Fill = toGlyph 0XED4B +remixFocus3Line = toGlyph 0XED4C +remixFocusFill = toGlyph 0XED4D +remixFocusLine = toGlyph 0XED4E +remixFoggyFill = toGlyph 0XED4F +remixFoggyLine = toGlyph 0XED50 +remixFolder2Fill = toGlyph 0XED51 +remixFolder2Line = toGlyph 0XED52 +remixFolder3Fill = toGlyph 0XED53 +remixFolder3Line = toGlyph 0XED54 +remixFolder4Fill = toGlyph 0XED55 +remixFolder4Line = toGlyph 0XED56 +remixFolder5Fill = toGlyph 0XED57 +remixFolder5Line = toGlyph 0XED58 +remixFolderAddFill = toGlyph 0XED59 +remixFolderAddLine = toGlyph 0XED5A +remixFolderChart2Fill = toGlyph 0XED5B +remixFolderChart2Line = toGlyph 0XED5C +remixFolderChartFill = toGlyph 0XED5D +remixFolderChartLine = toGlyph 0XED5E +remixFolderDownloadFill = toGlyph 0XED5F +remixFolderDownloadLine = toGlyph 0XED60 +remixFolderFill = toGlyph 0XED61 +remixFolderForbidFill = toGlyph 0XED62 +remixFolderForbidLine = toGlyph 0XED63 +remixFolderHistoryFill = toGlyph 0XED64 +remixFolderHistoryLine = toGlyph 0XED65 +remixFolderInfoFill = toGlyph 0XED66 +remixFolderInfoLine = toGlyph 0XED67 +remixFolderKeyholeFill = toGlyph 0XED68 +remixFolderKeyholeLine = toGlyph 0XED69 +remixFolderLine = toGlyph 0XED6A +remixFolderLockFill = toGlyph 0XED6B +remixFolderLockLine = toGlyph 0XED6C +remixFolderMusicFill = toGlyph 0XED6D +remixFolderMusicLine = toGlyph 0XED6E +remixFolderOpenFill = toGlyph 0XED6F +remixFolderOpenLine = toGlyph 0XED70 +remixFolderReceivedFill = toGlyph 0XED71 +remixFolderReceivedLine = toGlyph 0XED72 +remixFolderReduceFill = toGlyph 0XED73 +remixFolderReduceLine = toGlyph 0XED74 +remixFolderSettingsFill = toGlyph 0XED75 +remixFolderSettingsLine = toGlyph 0XED76 +remixFolderSharedFill = toGlyph 0XED77 +remixFolderSharedLine = toGlyph 0XED78 +remixFolderShield2Fill = toGlyph 0XED79 +remixFolderShield2Line = toGlyph 0XED7A +remixFolderShieldFill = toGlyph 0XED7B +remixFolderShieldLine = toGlyph 0XED7C +remixFolderTransferFill = toGlyph 0XED7D +remixFolderTransferLine = toGlyph 0XED7E +remixFolderUnknowFill = toGlyph 0XED7F +remixFolderUnknowLine = toGlyph 0XED80 +remixFolderUploadFill = toGlyph 0XED81 +remixFolderUploadLine = toGlyph 0XED82 +remixFolderUserFill = toGlyph 0XED83 +remixFolderUserLine = toGlyph 0XED84 +remixFolderWarningFill = toGlyph 0XED85 +remixFolderWarningLine = toGlyph 0XED86 +remixFolderZipFill = toGlyph 0XED87 +remixFolderZipLine = toGlyph 0XED88 +remixFoldersFill = toGlyph 0XED89 +remixFoldersLine = toGlyph 0XED8A +remixFontColor = toGlyph 0XED8B +remixFontSize2 = toGlyph 0XED8C +remixFontSize = toGlyph 0XED8D +remixFootballFill = toGlyph 0XED8E +remixFootballLine = toGlyph 0XED8F +remixFootprintFill = toGlyph 0XED90 +remixFootprintLine = toGlyph 0XED91 +remixForbid2Fill = toGlyph 0XED92 +remixForbid2Line = toGlyph 0XED93 +remixForbidFill = toGlyph 0XED94 +remixForbidLine = toGlyph 0XED95 +remixFormatClear = toGlyph 0XED96 +remixFridgeFill = toGlyph 0XED97 +remixFridgeLine = toGlyph 0XED98 +remixFullscreenExitFill = toGlyph 0XED99 +remixFullscreenExitLine = toGlyph 0XED9A +remixFullscreenFill = toGlyph 0XED9B +remixFullscreenLine = toGlyph 0XED9C +remixFunctionFill = toGlyph 0XED9D +remixFunctionLine = toGlyph 0XED9E +remixFunctions = toGlyph 0XED9F +remixFundsBoxFill = toGlyph 0XEDA0 +remixFundsBoxLine = toGlyph 0XEDA1 +remixFundsFill = toGlyph 0XEDA2 +remixFundsLine = toGlyph 0XEDA3 +remixGalleryFill = toGlyph 0XEDA4 +remixGalleryLine = toGlyph 0XEDA5 +remixGalleryUploadFill = toGlyph 0XEDA6 +remixGalleryUploadLine = toGlyph 0XEDA7 +remixGameFill = toGlyph 0XEDA8 +remixGameLine = toGlyph 0XEDA9 +remixGamepadFill = toGlyph 0XEDAA +remixGamepadLine = toGlyph 0XEDAB +remixGasStationFill = toGlyph 0XEDAC +remixGasStationLine = toGlyph 0XEDAD +remixGatsbyFill = toGlyph 0XEDAE +remixGatsbyLine = toGlyph 0XEDAF +remixGenderlessFill = toGlyph 0XEDB0 +remixGenderlessLine = toGlyph 0XEDB1 +remixGhost2Fill = toGlyph 0XEDB2 +remixGhost2Line = toGlyph 0XEDB3 +remixGhostFill = toGlyph 0XEDB4 +remixGhostLine = toGlyph 0XEDB5 +remixGhostSmileFill = toGlyph 0XEDB6 +remixGhostSmileLine = toGlyph 0XEDB7 +remixGift2Fill = toGlyph 0XEDB8 +remixGift2Line = toGlyph 0XEDB9 +remixGiftFill = toGlyph 0XEDBA +remixGiftLine = toGlyph 0XEDBB +remixGitBranchFill = toGlyph 0XEDBC +remixGitBranchLine = toGlyph 0XEDBD +remixGitCommitFill = toGlyph 0XEDBE +remixGitCommitLine = toGlyph 0XEDBF +remixGitMergeFill = toGlyph 0XEDC0 +remixGitMergeLine = toGlyph 0XEDC1 +remixGitPullRequestFill = toGlyph 0XEDC2 +remixGitPullRequestLine = toGlyph 0XEDC3 +remixGitRepositoryCommitsFill = toGlyph 0XEDC4 +remixGitRepositoryCommitsLine = toGlyph 0XEDC5 +remixGitRepositoryFill = toGlyph 0XEDC6 +remixGitRepositoryLine = toGlyph 0XEDC7 +remixGitRepositoryPrivateFill = toGlyph 0XEDC8 +remixGitRepositoryPrivateLine = toGlyph 0XEDC9 +remixGithubFill = toGlyph 0XEDCA +remixGithubLine = toGlyph 0XEDCB +remixGitlabFill = toGlyph 0XEDCC +remixGitlabLine = toGlyph 0XEDCD +remixGlobalFill = toGlyph 0XEDCE +remixGlobalLine = toGlyph 0XEDCF +remixGlobeFill = toGlyph 0XEDD0 +remixGlobeLine = toGlyph 0XEDD1 +remixGobletFill = toGlyph 0XEDD2 +remixGobletLine = toGlyph 0XEDD3 +remixGoogleFill = toGlyph 0XEDD4 +remixGoogleLine = toGlyph 0XEDD5 +remixGooglePlayFill = toGlyph 0XEDD6 +remixGooglePlayLine = toGlyph 0XEDD7 +remixGovernmentFill = toGlyph 0XEDD8 +remixGovernmentLine = toGlyph 0XEDD9 +remixGpsFill = toGlyph 0XEDDA +remixGpsLine = toGlyph 0XEDDB +remixGradienterFill = toGlyph 0XEDDC +remixGradienterLine = toGlyph 0XEDDD +remixGridFill = toGlyph 0XEDDE +remixGridLine = toGlyph 0XEDDF +remixGroup2Fill = toGlyph 0XEDE0 +remixGroup2Line = toGlyph 0XEDE1 +remixGroupFill = toGlyph 0XEDE2 +remixGroupLine = toGlyph 0XEDE3 +remixGuideFill = toGlyph 0XEDE4 +remixGuideLine = toGlyph 0XEDE5 +remixH1 = toGlyph 0XEDE6 +remixH2 = toGlyph 0XEDE7 +remixH3 = toGlyph 0XEDE8 +remixH4 = toGlyph 0XEDE9 +remixH5 = toGlyph 0XEDEA +remixH6 = toGlyph 0XEDEB +remixHailFill = toGlyph 0XEDEC +remixHailLine = toGlyph 0XEDED +remixHammerFill = toGlyph 0XEDEE +remixHammerLine = toGlyph 0XEDEF +remixHandCoinFill = toGlyph 0XEDF0 +remixHandCoinLine = toGlyph 0XEDF1 +remixHandHeartFill = toGlyph 0XEDF2 +remixHandHeartLine = toGlyph 0XEDF3 +remixHandSanitizerFill = toGlyph 0XEDF4 +remixHandSanitizerLine = toGlyph 0XEDF5 +remixHandbagFill = toGlyph 0XEDF6 +remixHandbagLine = toGlyph 0XEDF7 +remixHardDrive2Fill = toGlyph 0XEDF8 +remixHardDrive2Line = toGlyph 0XEDF9 +remixHardDriveFill = toGlyph 0XEDFA +remixHardDriveLine = toGlyph 0XEDFB +remixHashtag = toGlyph 0XEDFC +remixHaze2Fill = toGlyph 0XEDFD +remixHaze2Line = toGlyph 0XEDFE +remixHazeFill = toGlyph 0XEDFF +remixHazeLine = toGlyph 0XEE00 +remixHdFill = toGlyph 0XEE01 +remixHdLine = toGlyph 0XEE02 +remixHeading = toGlyph 0XEE03 +remixHeadphoneFill = toGlyph 0XEE04 +remixHeadphoneLine = toGlyph 0XEE05 +remixHealthBookFill = toGlyph 0XEE06 +remixHealthBookLine = toGlyph 0XEE07 +remixHeart2Fill = toGlyph 0XEE08 +remixHeart2Line = toGlyph 0XEE09 +remixHeart3Fill = toGlyph 0XEE0A +remixHeart3Line = toGlyph 0XEE0B +remixHeartAddFill = toGlyph 0XEE0C +remixHeartAddLine = toGlyph 0XEE0D +remixHeartFill = toGlyph 0XEE0E +remixHeartLine = toGlyph 0XEE0F +remixHeartPulseFill = toGlyph 0XEE10 +remixHeartPulseLine = toGlyph 0XEE11 +remixHeartsFill = toGlyph 0XEE12 +remixHeartsLine = toGlyph 0XEE13 +remixHeavyShowersFill = toGlyph 0XEE14 +remixHeavyShowersLine = toGlyph 0XEE15 +remixHistoryFill = toGlyph 0XEE16 +remixHistoryLine = toGlyph 0XEE17 +remixHome2Fill = toGlyph 0XEE18 +remixHome2Line = toGlyph 0XEE19 +remixHome3Fill = toGlyph 0XEE1A +remixHome3Line = toGlyph 0XEE1B +remixHome4Fill = toGlyph 0XEE1C +remixHome4Line = toGlyph 0XEE1D +remixHome5Fill = toGlyph 0XEE1E +remixHome5Line = toGlyph 0XEE1F +remixHome6Fill = toGlyph 0XEE20 +remixHome6Line = toGlyph 0XEE21 +remixHome7Fill = toGlyph 0XEE22 +remixHome7Line = toGlyph 0XEE23 +remixHome8Fill = toGlyph 0XEE24 +remixHome8Line = toGlyph 0XEE25 +remixHomeFill = toGlyph 0XEE26 +remixHomeGearFill = toGlyph 0XEE27 +remixHomeGearLine = toGlyph 0XEE28 +remixHomeHeartFill = toGlyph 0XEE29 +remixHomeHeartLine = toGlyph 0XEE2A +remixHomeLine = toGlyph 0XEE2B +remixHomeSmile2Fill = toGlyph 0XEE2C +remixHomeSmile2Line = toGlyph 0XEE2D +remixHomeSmileFill = toGlyph 0XEE2E +remixHomeSmileLine = toGlyph 0XEE2F +remixHomeWifiFill = toGlyph 0XEE30 +remixHomeWifiLine = toGlyph 0XEE31 +remixHonorOfKingsFill = toGlyph 0XEE32 +remixHonorOfKingsLine = toGlyph 0XEE33 +remixHonourFill = toGlyph 0XEE34 +remixHonourLine = toGlyph 0XEE35 +remixHospitalFill = toGlyph 0XEE36 +remixHospitalLine = toGlyph 0XEE37 +remixHotelBedFill = toGlyph 0XEE38 +remixHotelBedLine = toGlyph 0XEE39 +remixHotelFill = toGlyph 0XEE3A +remixHotelLine = toGlyph 0XEE3B +remixHotspotFill = toGlyph 0XEE3C +remixHotspotLine = toGlyph 0XEE3D +remixHqFill = toGlyph 0XEE3E +remixHqLine = toGlyph 0XEE3F +remixHtml5Fill = toGlyph 0XEE40 +remixHtml5Line = toGlyph 0XEE41 +remixIeFill = toGlyph 0XEE42 +remixIeLine = toGlyph 0XEE43 +remixImage2Fill = toGlyph 0XEE44 +remixImage2Line = toGlyph 0XEE45 +remixImageAddFill = toGlyph 0XEE46 +remixImageAddLine = toGlyph 0XEE47 +remixImageEditFill = toGlyph 0XEE48 +remixImageEditLine = toGlyph 0XEE49 +remixImageFill = toGlyph 0XEE4A +remixImageLine = toGlyph 0XEE4B +remixInboxArchiveFill = toGlyph 0XEE4C +remixInboxArchiveLine = toGlyph 0XEE4D +remixInboxFill = toGlyph 0XEE4E +remixInboxLine = toGlyph 0XEE4F +remixInboxUnarchiveFill = toGlyph 0XEE50 +remixInboxUnarchiveLine = toGlyph 0XEE51 +remixIncreaseDecreaseFill = toGlyph 0XEE52 +remixIncreaseDecreaseLine = toGlyph 0XEE53 +remixIndentDecrease = toGlyph 0XEE54 +remixIndentIncrease = toGlyph 0XEE55 +remixIndeterminateCircleFill = toGlyph 0XEE56 +remixIndeterminateCircleLine = toGlyph 0XEE57 +remixInformationFill = toGlyph 0XEE58 +remixInformationLine = toGlyph 0XEE59 +remixInfraredThermometerFill = toGlyph 0XEE5A +remixInfraredThermometerLine = toGlyph 0XEE5B +remixInkBottleFill = toGlyph 0XEE5C +remixInkBottleLine = toGlyph 0XEE5D +remixInputCursorMove = toGlyph 0XEE5E +remixInputMethodFill = toGlyph 0XEE5F +remixInputMethodLine = toGlyph 0XEE60 +remixInsertColumnLeft = toGlyph 0XEE61 +remixInsertColumnRight = toGlyph 0XEE62 +remixInsertRowBottom = toGlyph 0XEE63 +remixInsertRowTop = toGlyph 0XEE64 +remixInstagramFill = toGlyph 0XEE65 +remixInstagramLine = toGlyph 0XEE66 +remixInstallFill = toGlyph 0XEE67 +remixInstallLine = toGlyph 0XEE68 +remixInvisionFill = toGlyph 0XEE69 +remixInvisionLine = toGlyph 0XEE6A +remixItalic = toGlyph 0XEE6B +remixKakaoTalkFill = toGlyph 0XEE6C +remixKakaoTalkLine = toGlyph 0XEE6D +remixKey2Fill = toGlyph 0XEE6E +remixKey2Line = toGlyph 0XEE6F +remixKeyFill = toGlyph 0XEE70 +remixKeyLine = toGlyph 0XEE71 +remixKeyboardBoxFill = toGlyph 0XEE72 +remixKeyboardBoxLine = toGlyph 0XEE73 +remixKeyboardFill = toGlyph 0XEE74 +remixKeyboardLine = toGlyph 0XEE75 +remixKeynoteFill = toGlyph 0XEE76 +remixKeynoteLine = toGlyph 0XEE77 +remixKnifeBloodFill = toGlyph 0XEE78 +remixKnifeBloodLine = toGlyph 0XEE79 +remixKnifeFill = toGlyph 0XEE7A +remixKnifeLine = toGlyph 0XEE7B +remixLandscapeFill = toGlyph 0XEE7C +remixLandscapeLine = toGlyph 0XEE7D +remixLayout2Fill = toGlyph 0XEE7E +remixLayout2Line = toGlyph 0XEE7F +remixLayout3Fill = toGlyph 0XEE80 +remixLayout3Line = toGlyph 0XEE81 +remixLayout4Fill = toGlyph 0XEE82 +remixLayout4Line = toGlyph 0XEE83 +remixLayout5Fill = toGlyph 0XEE84 +remixLayout5Line = toGlyph 0XEE85 +remixLayout6Fill = toGlyph 0XEE86 +remixLayout6Line = toGlyph 0XEE87 +remixLayoutBottom2Fill = toGlyph 0XEE88 +remixLayoutBottom2Line = toGlyph 0XEE89 +remixLayoutBottomFill = toGlyph 0XEE8A +remixLayoutBottomLine = toGlyph 0XEE8B +remixLayoutColumnFill = toGlyph 0XEE8C +remixLayoutColumnLine = toGlyph 0XEE8D +remixLayoutFill = toGlyph 0XEE8E +remixLayoutGridFill = toGlyph 0XEE8F +remixLayoutGridLine = toGlyph 0XEE90 +remixLayoutLeft2Fill = toGlyph 0XEE91 +remixLayoutLeft2Line = toGlyph 0XEE92 +remixLayoutLeftFill = toGlyph 0XEE93 +remixLayoutLeftLine = toGlyph 0XEE94 +remixLayoutLine = toGlyph 0XEE95 +remixLayoutMasonryFill = toGlyph 0XEE96 +remixLayoutMasonryLine = toGlyph 0XEE97 +remixLayoutRight2Fill = toGlyph 0XEE98 +remixLayoutRight2Line = toGlyph 0XEE99 +remixLayoutRightFill = toGlyph 0XEE9A +remixLayoutRightLine = toGlyph 0XEE9B +remixLayoutRowFill = toGlyph 0XEE9C +remixLayoutRowLine = toGlyph 0XEE9D +remixLayoutTop2Fill = toGlyph 0XEE9E +remixLayoutTop2Line = toGlyph 0XEE9F +remixLayoutTopFill = toGlyph 0XEEA0 +remixLayoutTopLine = toGlyph 0XEEA1 +remixLeafFill = toGlyph 0XEEA2 +remixLeafLine = toGlyph 0XEEA3 +remixLifebuoyFill = toGlyph 0XEEA4 +remixLifebuoyLine = toGlyph 0XEEA5 +remixLightbulbFill = toGlyph 0XEEA6 +remixLightbulbFlashFill = toGlyph 0XEEA7 +remixLightbulbFlashLine = toGlyph 0XEEA8 +remixLightbulbLine = toGlyph 0XEEA9 +remixLineChartFill = toGlyph 0XEEAA +remixLineChartLine = toGlyph 0XEEAB +remixLineFill = toGlyph 0XEEAC +remixLineHeight = toGlyph 0XEEAD +remixLineLine = toGlyph 0XEEAE +remixLinkM = toGlyph 0XEEAF +remixLinkUnlinkM = toGlyph 0XEEB0 +remixLinkUnlink = toGlyph 0XEEB1 +remixLink = toGlyph 0XEEB2 +remixLinkedinBoxFill = toGlyph 0XEEB3 +remixLinkedinBoxLine = toGlyph 0XEEB4 +remixLinkedinFill = toGlyph 0XEEB5 +remixLinkedinLine = toGlyph 0XEEB6 +remixLinksFill = toGlyph 0XEEB7 +remixLinksLine = toGlyph 0XEEB8 +remixListCheck2 = toGlyph 0XEEB9 +remixListCheck = toGlyph 0XEEBA +remixListOrdered = toGlyph 0XEEBB +remixListSettingsFill = toGlyph 0XEEBC +remixListSettingsLine = toGlyph 0XEEBD +remixListUnordered = toGlyph 0XEEBE +remixLiveFill = toGlyph 0XEEBF +remixLiveLine = toGlyph 0XEEC0 +remixLoader2Fill = toGlyph 0XEEC1 +remixLoader2Line = toGlyph 0XEEC2 +remixLoader3Fill = toGlyph 0XEEC3 +remixLoader3Line = toGlyph 0XEEC4 +remixLoader4Fill = toGlyph 0XEEC5 +remixLoader4Line = toGlyph 0XEEC6 +remixLoader5Fill = toGlyph 0XEEC7 +remixLoader5Line = toGlyph 0XEEC8 +remixLoaderFill = toGlyph 0XEEC9 +remixLoaderLine = toGlyph 0XEECA +remixLock2Fill = toGlyph 0XEECB +remixLock2Line = toGlyph 0XEECC +remixLockFill = toGlyph 0XEECD +remixLockLine = toGlyph 0XEECE +remixLockPasswordFill = toGlyph 0XEECF +remixLockPasswordLine = toGlyph 0XEED0 +remixLockUnlockFill = toGlyph 0XEED1 +remixLockUnlockLine = toGlyph 0XEED2 +remixLoginBoxFill = toGlyph 0XEED3 +remixLoginBoxLine = toGlyph 0XEED4 +remixLoginCircleFill = toGlyph 0XEED5 +remixLoginCircleLine = toGlyph 0XEED6 +remixLogoutBoxFill = toGlyph 0XEED7 +remixLogoutBoxLine = toGlyph 0XEED8 +remixLogoutBoxRFill = toGlyph 0XEED9 +remixLogoutBoxRLine = toGlyph 0XEEDA +remixLogoutCircleFill = toGlyph 0XEEDB +remixLogoutCircleLine = toGlyph 0XEEDC +remixLogoutCircleRFill = toGlyph 0XEEDD +remixLogoutCircleRLine = toGlyph 0XEEDE +remixLuggageCartFill = toGlyph 0XEEDF +remixLuggageCartLine = toGlyph 0XEEE0 +remixLuggageDepositFill = toGlyph 0XEEE1 +remixLuggageDepositLine = toGlyph 0XEEE2 +remixLungsFill = toGlyph 0XEEE3 +remixLungsLine = toGlyph 0XEEE4 +remixMacFill = toGlyph 0XEEE5 +remixMacLine = toGlyph 0XEEE6 +remixMacbookFill = toGlyph 0XEEE7 +remixMacbookLine = toGlyph 0XEEE8 +remixMagicFill = toGlyph 0XEEE9 +remixMagicLine = toGlyph 0XEEEA +remixMailAddFill = toGlyph 0XEEEB +remixMailAddLine = toGlyph 0XEEEC +remixMailCheckFill = toGlyph 0XEEED +remixMailCheckLine = toGlyph 0XEEEE +remixMailCloseFill = toGlyph 0XEEEF +remixMailCloseLine = toGlyph 0XEEF0 +remixMailDownloadFill = toGlyph 0XEEF1 +remixMailDownloadLine = toGlyph 0XEEF2 +remixMailFill = toGlyph 0XEEF3 +remixMailForbidFill = toGlyph 0XEEF4 +remixMailForbidLine = toGlyph 0XEEF5 +remixMailLine = toGlyph 0XEEF6 +remixMailLockFill = toGlyph 0XEEF7 +remixMailLockLine = toGlyph 0XEEF8 +remixMailOpenFill = toGlyph 0XEEF9 +remixMailOpenLine = toGlyph 0XEEFA +remixMailSendFill = toGlyph 0XEEFB +remixMailSendLine = toGlyph 0XEEFC +remixMailSettingsFill = toGlyph 0XEEFD +remixMailSettingsLine = toGlyph 0XEEFE +remixMailStarFill = toGlyph 0XEEFF +remixMailStarLine = toGlyph 0XEF00 +remixMailUnreadFill = toGlyph 0XEF01 +remixMailUnreadLine = toGlyph 0XEF02 +remixMailVolumeFill = toGlyph 0XEF03 +remixMailVolumeLine = toGlyph 0XEF04 +remixMap2Fill = toGlyph 0XEF05 +remixMap2Line = toGlyph 0XEF06 +remixMapFill = toGlyph 0XEF07 +remixMapLine = toGlyph 0XEF08 +remixMapPin2Fill = toGlyph 0XEF09 +remixMapPin2Line = toGlyph 0XEF0A +remixMapPin3Fill = toGlyph 0XEF0B +remixMapPin3Line = toGlyph 0XEF0C +remixMapPin4Fill = toGlyph 0XEF0D +remixMapPin4Line = toGlyph 0XEF0E +remixMapPin5Fill = toGlyph 0XEF0F +remixMapPin5Line = toGlyph 0XEF10 +remixMapPinAddFill = toGlyph 0XEF11 +remixMapPinAddLine = toGlyph 0XEF12 +remixMapPinFill = toGlyph 0XEF13 +remixMapPinLine = toGlyph 0XEF14 +remixMapPinRangeFill = toGlyph 0XEF15 +remixMapPinRangeLine = toGlyph 0XEF16 +remixMapPinTimeFill = toGlyph 0XEF17 +remixMapPinTimeLine = toGlyph 0XEF18 +remixMapPinUserFill = toGlyph 0XEF19 +remixMapPinUserLine = toGlyph 0XEF1A +remixMarkPenFill = toGlyph 0XEF1B +remixMarkPenLine = toGlyph 0XEF1C +remixMarkdownFill = toGlyph 0XEF1D +remixMarkdownLine = toGlyph 0XEF1E +remixMarkupFill = toGlyph 0XEF1F +remixMarkupLine = toGlyph 0XEF20 +remixMastercardFill = toGlyph 0XEF21 +remixMastercardLine = toGlyph 0XEF22 +remixMastodonFill = toGlyph 0XEF23 +remixMastodonLine = toGlyph 0XEF24 +remixMedal2Fill = toGlyph 0XEF25 +remixMedal2Line = toGlyph 0XEF26 +remixMedalFill = toGlyph 0XEF27 +remixMedalLine = toGlyph 0XEF28 +remixMedicineBottleFill = toGlyph 0XEF29 +remixMedicineBottleLine = toGlyph 0XEF2A +remixMediumFill = toGlyph 0XEF2B +remixMediumLine = toGlyph 0XEF2C +remixMenFill = toGlyph 0XEF2D +remixMenLine = toGlyph 0XEF2E +remixMentalHealthFill = toGlyph 0XEF2F +remixMentalHealthLine = toGlyph 0XEF30 +remixMenu2Fill = toGlyph 0XEF31 +remixMenu2Line = toGlyph 0XEF32 +remixMenu3Fill = toGlyph 0XEF33 +remixMenu3Line = toGlyph 0XEF34 +remixMenu4Fill = toGlyph 0XEF35 +remixMenu4Line = toGlyph 0XEF36 +remixMenu5Fill = toGlyph 0XEF37 +remixMenu5Line = toGlyph 0XEF38 +remixMenuAddFill = toGlyph 0XEF39 +remixMenuAddLine = toGlyph 0XEF3A +remixMenuFill = toGlyph 0XEF3B +remixMenuFoldFill = toGlyph 0XEF3C +remixMenuFoldLine = toGlyph 0XEF3D +remixMenuLine = toGlyph 0XEF3E +remixMenuUnfoldFill = toGlyph 0XEF3F +remixMenuUnfoldLine = toGlyph 0XEF40 +remixMergeCellsHorizontal = toGlyph 0XEF41 +remixMergeCellsVertical = toGlyph 0XEF42 +remixMessage2Fill = toGlyph 0XEF43 +remixMessage2Line = toGlyph 0XEF44 +remixMessage3Fill = toGlyph 0XEF45 +remixMessage3Line = toGlyph 0XEF46 +remixMessageFill = toGlyph 0XEF47 +remixMessageLine = toGlyph 0XEF48 +remixMessengerFill = toGlyph 0XEF49 +remixMessengerLine = toGlyph 0XEF4A +remixMeteorFill = toGlyph 0XEF4B +remixMeteorLine = toGlyph 0XEF4C +remixMic2Fill = toGlyph 0XEF4D +remixMic2Line = toGlyph 0XEF4E +remixMicFill = toGlyph 0XEF4F +remixMicLine = toGlyph 0XEF50 +remixMicOffFill = toGlyph 0XEF51 +remixMicOffLine = toGlyph 0XEF52 +remixMickeyFill = toGlyph 0XEF53 +remixMickeyLine = toGlyph 0XEF54 +remixMicroscopeFill = toGlyph 0XEF55 +remixMicroscopeLine = toGlyph 0XEF56 +remixMicrosoftFill = toGlyph 0XEF57 +remixMicrosoftLine = toGlyph 0XEF58 +remixMindMap = toGlyph 0XEF59 +remixMiniProgramFill = toGlyph 0XEF5A +remixMiniProgramLine = toGlyph 0XEF5B +remixMistFill = toGlyph 0XEF5C +remixMistLine = toGlyph 0XEF5D +remixMoneyCnyBoxFill = toGlyph 0XEF5E +remixMoneyCnyBoxLine = toGlyph 0XEF5F +remixMoneyCnyCircleFill = toGlyph 0XEF60 +remixMoneyCnyCircleLine = toGlyph 0XEF61 +remixMoneyDollarBoxFill = toGlyph 0XEF62 +remixMoneyDollarBoxLine = toGlyph 0XEF63 +remixMoneyDollarCircleFill = toGlyph 0XEF64 +remixMoneyDollarCircleLine = toGlyph 0XEF65 +remixMoneyEuroBoxFill = toGlyph 0XEF66 +remixMoneyEuroBoxLine = toGlyph 0XEF67 +remixMoneyEuroCircleFill = toGlyph 0XEF68 +remixMoneyEuroCircleLine = toGlyph 0XEF69 +remixMoneyPoundBoxFill = toGlyph 0XEF6A +remixMoneyPoundBoxLine = toGlyph 0XEF6B +remixMoneyPoundCircleFill = toGlyph 0XEF6C +remixMoneyPoundCircleLine = toGlyph 0XEF6D +remixMoonClearFill = toGlyph 0XEF6E +remixMoonClearLine = toGlyph 0XEF6F +remixMoonCloudyFill = toGlyph 0XEF70 +remixMoonCloudyLine = toGlyph 0XEF71 +remixMoonFill = toGlyph 0XEF72 +remixMoonFoggyFill = toGlyph 0XEF73 +remixMoonFoggyLine = toGlyph 0XEF74 +remixMoonLine = toGlyph 0XEF75 +remixMore2Fill = toGlyph 0XEF76 +remixMore2Line = toGlyph 0XEF77 +remixMoreFill = toGlyph 0XEF78 +remixMoreLine = toGlyph 0XEF79 +remixMotorbikeFill = toGlyph 0XEF7A +remixMotorbikeLine = toGlyph 0XEF7B +remixMouseFill = toGlyph 0XEF7C +remixMouseLine = toGlyph 0XEF7D +remixMovie2Fill = toGlyph 0XEF7E +remixMovie2Line = toGlyph 0XEF7F +remixMovieFill = toGlyph 0XEF80 +remixMovieLine = toGlyph 0XEF81 +remixMusic2Fill = toGlyph 0XEF82 +remixMusic2Line = toGlyph 0XEF83 +remixMusicFill = toGlyph 0XEF84 +remixMusicLine = toGlyph 0XEF85 +remixMvFill = toGlyph 0XEF86 +remixMvLine = toGlyph 0XEF87 +remixNavigationFill = toGlyph 0XEF88 +remixNavigationLine = toGlyph 0XEF89 +remixNeteaseCloudMusicFill = toGlyph 0XEF8A +remixNeteaseCloudMusicLine = toGlyph 0XEF8B +remixNetflixFill = toGlyph 0XEF8C +remixNetflixLine = toGlyph 0XEF8D +remixNewspaperFill = toGlyph 0XEF8E +remixNewspaperLine = toGlyph 0XEF8F +remixNodeTree = toGlyph 0XEF90 +remixNotification2Fill = toGlyph 0XEF91 +remixNotification2Line = toGlyph 0XEF92 +remixNotification3Fill = toGlyph 0XEF93 +remixNotification3Line = toGlyph 0XEF94 +remixNotification4Fill = toGlyph 0XEF95 +remixNotification4Line = toGlyph 0XEF96 +remixNotificationBadgeFill = toGlyph 0XEF97 +remixNotificationBadgeLine = toGlyph 0XEF98 +remixNotificationFill = toGlyph 0XEF99 +remixNotificationLine = toGlyph 0XEF9A +remixNotificationOffFill = toGlyph 0XEF9B +remixNotificationOffLine = toGlyph 0XEF9C +remixNpmjsFill = toGlyph 0XEF9D +remixNpmjsLine = toGlyph 0XEF9E +remixNumber0 = toGlyph 0XEF9F +remixNumber1 = toGlyph 0XEFA0 +remixNumber2 = toGlyph 0XEFA1 +remixNumber3 = toGlyph 0XEFA2 +remixNumber4 = toGlyph 0XEFA3 +remixNumber5 = toGlyph 0XEFA4 +remixNumber6 = toGlyph 0XEFA5 +remixNumber7 = toGlyph 0XEFA6 +remixNumber8 = toGlyph 0XEFA7 +remixNumber9 = toGlyph 0XEFA8 +remixNumbersFill = toGlyph 0XEFA9 +remixNumbersLine = toGlyph 0XEFAA +remixNurseFill = toGlyph 0XEFAB +remixNurseLine = toGlyph 0XEFAC +remixOilFill = toGlyph 0XEFAD +remixOilLine = toGlyph 0XEFAE +remixOmega = toGlyph 0XEFAF +remixOpenArmFill = toGlyph 0XEFB0 +remixOpenArmLine = toGlyph 0XEFB1 +remixOpenSourceFill = toGlyph 0XEFB2 +remixOpenSourceLine = toGlyph 0XEFB3 +remixOperaFill = toGlyph 0XEFB4 +remixOperaLine = toGlyph 0XEFB5 +remixOrderPlayFill = toGlyph 0XEFB6 +remixOrderPlayLine = toGlyph 0XEFB7 +remixOrganizationChart = toGlyph 0XEFB8 +remixOutlet2Fill = toGlyph 0XEFB9 +remixOutlet2Line = toGlyph 0XEFBA +remixOutletFill = toGlyph 0XEFBB +remixOutletLine = toGlyph 0XEFBC +remixPageSeparator = toGlyph 0XEFBD +remixPagesFill = toGlyph 0XEFBE +remixPagesLine = toGlyph 0XEFBF +remixPaintBrushFill = toGlyph 0XEFC0 +remixPaintBrushLine = toGlyph 0XEFC1 +remixPaintFill = toGlyph 0XEFC2 +remixPaintLine = toGlyph 0XEFC3 +remixPaletteFill = toGlyph 0XEFC4 +remixPaletteLine = toGlyph 0XEFC5 +remixPantoneFill = toGlyph 0XEFC6 +remixPantoneLine = toGlyph 0XEFC7 +remixParagraph = toGlyph 0XEFC8 +remixParentFill = toGlyph 0XEFC9 +remixParentLine = toGlyph 0XEFCA +remixParenthesesFill = toGlyph 0XEFCB +remixParenthesesLine = toGlyph 0XEFCC +remixParkingBoxFill = toGlyph 0XEFCD +remixParkingBoxLine = toGlyph 0XEFCE +remixParkingFill = toGlyph 0XEFCF +remixParkingLine = toGlyph 0XEFD0 +remixPassportFill = toGlyph 0XEFD1 +remixPassportLine = toGlyph 0XEFD2 +remixPatreonFill = toGlyph 0XEFD3 +remixPatreonLine = toGlyph 0XEFD4 +remixPauseCircleFill = toGlyph 0XEFD5 +remixPauseCircleLine = toGlyph 0XEFD6 +remixPauseFill = toGlyph 0XEFD7 +remixPauseLine = toGlyph 0XEFD8 +remixPauseMiniFill = toGlyph 0XEFD9 +remixPauseMiniLine = toGlyph 0XEFDA +remixPaypalFill = toGlyph 0XEFDB +remixPaypalLine = toGlyph 0XEFDC +remixPenNibFill = toGlyph 0XEFDD +remixPenNibLine = toGlyph 0XEFDE +remixPencilFill = toGlyph 0XEFDF +remixPencilLine = toGlyph 0XEFE0 +remixPencilRuler2Fill = toGlyph 0XEFE1 +remixPencilRuler2Line = toGlyph 0XEFE2 +remixPencilRulerFill = toGlyph 0XEFE3 +remixPencilRulerLine = toGlyph 0XEFE4 +remixPercentFill = toGlyph 0XEFE5 +remixPercentLine = toGlyph 0XEFE6 +remixPhoneCameraFill = toGlyph 0XEFE7 +remixPhoneCameraLine = toGlyph 0XEFE8 +remixPhoneFill = toGlyph 0XEFE9 +remixPhoneFindFill = toGlyph 0XEFEA +remixPhoneFindLine = toGlyph 0XEFEB +remixPhoneLine = toGlyph 0XEFEC +remixPhoneLockFill = toGlyph 0XEFED +remixPhoneLockLine = toGlyph 0XEFEE +remixPictureInPicture2Fill = toGlyph 0XEFEF +remixPictureInPicture2Line = toGlyph 0XEFF0 +remixPictureInPictureExitFill = toGlyph 0XEFF1 +remixPictureInPictureExitLine = toGlyph 0XEFF2 +remixPictureInPictureFill = toGlyph 0XEFF3 +remixPictureInPictureLine = toGlyph 0XEFF4 +remixPieChart2Fill = toGlyph 0XEFF5 +remixPieChart2Line = toGlyph 0XEFF6 +remixPieChartBoxFill = toGlyph 0XEFF7 +remixPieChartBoxLine = toGlyph 0XEFF8 +remixPieChartFill = toGlyph 0XEFF9 +remixPieChartLine = toGlyph 0XEFFA +remixPinDistanceFill = toGlyph 0XEFFB +remixPinDistanceLine = toGlyph 0XEFFC +remixPingPongFill = toGlyph 0XEFFD +remixPingPongLine = toGlyph 0XEFFE +remixPinterestFill = toGlyph 0XEFFF +remixPinterestLine = toGlyph 0XF000 +remixPinyinInput = toGlyph 0XF001 +remixPixelfedFill = toGlyph 0XF002 +remixPixelfedLine = toGlyph 0XF003 +remixPlaneFill = toGlyph 0XF004 +remixPlaneLine = toGlyph 0XF005 +remixPlantFill = toGlyph 0XF006 +remixPlantLine = toGlyph 0XF007 +remixPlayCircleFill = toGlyph 0XF008 +remixPlayCircleLine = toGlyph 0XF009 +remixPlayFill = toGlyph 0XF00A +remixPlayLine = toGlyph 0XF00B +remixPlayList2Fill = toGlyph 0XF00C +remixPlayList2Line = toGlyph 0XF00D +remixPlayListAddFill = toGlyph 0XF00E +remixPlayListAddLine = toGlyph 0XF00F +remixPlayListFill = toGlyph 0XF010 +remixPlayListLine = toGlyph 0XF011 +remixPlayMiniFill = toGlyph 0XF012 +remixPlayMiniLine = toGlyph 0XF013 +remixPlaystationFill = toGlyph 0XF014 +remixPlaystationLine = toGlyph 0XF015 +remixPlug2Fill = toGlyph 0XF016 +remixPlug2Line = toGlyph 0XF017 +remixPlugFill = toGlyph 0XF018 +remixPlugLine = toGlyph 0XF019 +remixPolaroid2Fill = toGlyph 0XF01A +remixPolaroid2Line = toGlyph 0XF01B +remixPolaroidFill = toGlyph 0XF01C +remixPolaroidLine = toGlyph 0XF01D +remixPoliceCarFill = toGlyph 0XF01E +remixPoliceCarLine = toGlyph 0XF01F +remixPriceTag2Fill = toGlyph 0XF020 +remixPriceTag2Line = toGlyph 0XF021 +remixPriceTag3Fill = toGlyph 0XF022 +remixPriceTag3Line = toGlyph 0XF023 +remixPriceTagFill = toGlyph 0XF024 +remixPriceTagLine = toGlyph 0XF025 +remixPrinterCloudFill = toGlyph 0XF026 +remixPrinterCloudLine = toGlyph 0XF027 +remixPrinterFill = toGlyph 0XF028 +remixPrinterLine = toGlyph 0XF029 +remixProductHuntFill = toGlyph 0XF02A +remixProductHuntLine = toGlyph 0XF02B +remixProfileFill = toGlyph 0XF02C +remixProfileLine = toGlyph 0XF02D +remixProjector2Fill = toGlyph 0XF02E +remixProjector2Line = toGlyph 0XF02F +remixProjectorFill = toGlyph 0XF030 +remixProjectorLine = toGlyph 0XF031 +remixPsychotherapyFill = toGlyph 0XF032 +remixPsychotherapyLine = toGlyph 0XF033 +remixPulseFill = toGlyph 0XF034 +remixPulseLine = toGlyph 0XF035 +remixPushpin2Fill = toGlyph 0XF036 +remixPushpin2Line = toGlyph 0XF037 +remixPushpinFill = toGlyph 0XF038 +remixPushpinLine = toGlyph 0XF039 +remixQqFill = toGlyph 0XF03A +remixQqLine = toGlyph 0XF03B +remixQrCodeFill = toGlyph 0XF03C +remixQrCodeLine = toGlyph 0XF03D +remixQrScan2Fill = toGlyph 0XF03E +remixQrScan2Line = toGlyph 0XF03F +remixQrScanFill = toGlyph 0XF040 +remixQrScanLine = toGlyph 0XF041 +remixQuestionAnswerFill = toGlyph 0XF042 +remixQuestionAnswerLine = toGlyph 0XF043 +remixQuestionFill = toGlyph 0XF044 +remixQuestionLine = toGlyph 0XF045 +remixQuestionMark = toGlyph 0XF046 +remixQuestionnaireFill = toGlyph 0XF047 +remixQuestionnaireLine = toGlyph 0XF048 +remixQuillPenFill = toGlyph 0XF049 +remixQuillPenLine = toGlyph 0XF04A +remixRadarFill = toGlyph 0XF04B +remixRadarLine = toGlyph 0XF04C +remixRadio2Fill = toGlyph 0XF04D +remixRadio2Line = toGlyph 0XF04E +remixRadioButtonFill = toGlyph 0XF04F +remixRadioButtonLine = toGlyph 0XF050 +remixRadioFill = toGlyph 0XF051 +remixRadioLine = toGlyph 0XF052 +remixRainbowFill = toGlyph 0XF053 +remixRainbowLine = toGlyph 0XF054 +remixRainyFill = toGlyph 0XF055 +remixRainyLine = toGlyph 0XF056 +remixReactjsFill = toGlyph 0XF057 +remixReactjsLine = toGlyph 0XF058 +remixRecordCircleFill = toGlyph 0XF059 +remixRecordCircleLine = toGlyph 0XF05A +remixRecordMailFill = toGlyph 0XF05B +remixRecordMailLine = toGlyph 0XF05C +remixRecycleFill = toGlyph 0XF05D +remixRecycleLine = toGlyph 0XF05E +remixRedPacketFill = toGlyph 0XF05F +remixRedPacketLine = toGlyph 0XF060 +remixRedditFill = toGlyph 0XF061 +remixRedditLine = toGlyph 0XF062 +remixRefreshFill = toGlyph 0XF063 +remixRefreshLine = toGlyph 0XF064 +remixRefund2Fill = toGlyph 0XF065 +remixRefund2Line = toGlyph 0XF066 +remixRefundFill = toGlyph 0XF067 +remixRefundLine = toGlyph 0XF068 +remixRegisteredFill = toGlyph 0XF069 +remixRegisteredLine = toGlyph 0XF06A +remixRemixiconFill = toGlyph 0XF06B +remixRemixiconLine = toGlyph 0XF06C +remixRemoteControl2Fill = toGlyph 0XF06D +remixRemoteControl2Line = toGlyph 0XF06E +remixRemoteControlFill = toGlyph 0XF06F +remixRemoteControlLine = toGlyph 0XF070 +remixRepeat2Fill = toGlyph 0XF071 +remixRepeat2Line = toGlyph 0XF072 +remixRepeatFill = toGlyph 0XF073 +remixRepeatLine = toGlyph 0XF074 +remixRepeatOneFill = toGlyph 0XF075 +remixRepeatOneLine = toGlyph 0XF076 +remixReplyAllFill = toGlyph 0XF077 +remixReplyAllLine = toGlyph 0XF078 +remixReplyFill = toGlyph 0XF079 +remixReplyLine = toGlyph 0XF07A +remixReservedFill = toGlyph 0XF07B +remixReservedLine = toGlyph 0XF07C +remixRestTimeFill = toGlyph 0XF07D +remixRestTimeLine = toGlyph 0XF07E +remixRestartFill = toGlyph 0XF07F +remixRestartLine = toGlyph 0XF080 +remixRestaurant2Fill = toGlyph 0XF081 +remixRestaurant2Line = toGlyph 0XF082 +remixRestaurantFill = toGlyph 0XF083 +remixRestaurantLine = toGlyph 0XF084 +remixRewindFill = toGlyph 0XF085 +remixRewindLine = toGlyph 0XF086 +remixRewindMiniFill = toGlyph 0XF087 +remixRewindMiniLine = toGlyph 0XF088 +remixRhythmFill = toGlyph 0XF089 +remixRhythmLine = toGlyph 0XF08A +remixRidingFill = toGlyph 0XF08B +remixRidingLine = toGlyph 0XF08C +remixRoadMapFill = toGlyph 0XF08D +remixRoadMapLine = toGlyph 0XF08E +remixRoadsterFill = toGlyph 0XF08F +remixRoadsterLine = toGlyph 0XF090 +remixRobotFill = toGlyph 0XF091 +remixRobotLine = toGlyph 0XF092 +remixRocket2Fill = toGlyph 0XF093 +remixRocket2Line = toGlyph 0XF094 +remixRocketFill = toGlyph 0XF095 +remixRocketLine = toGlyph 0XF096 +remixRotateLockFill = toGlyph 0XF097 +remixRotateLockLine = toGlyph 0XF098 +remixRoundedCorner = toGlyph 0XF099 +remixRouteFill = toGlyph 0XF09A +remixRouteLine = toGlyph 0XF09B +remixRouterFill = toGlyph 0XF09C +remixRouterLine = toGlyph 0XF09D +remixRssFill = toGlyph 0XF09E +remixRssLine = toGlyph 0XF09F +remixRuler2Fill = toGlyph 0XF0A0 +remixRuler2Line = toGlyph 0XF0A1 +remixRulerFill = toGlyph 0XF0A2 +remixRulerLine = toGlyph 0XF0A3 +remixRunFill = toGlyph 0XF0A4 +remixRunLine = toGlyph 0XF0A5 +remixSafariFill = toGlyph 0XF0A6 +remixSafariLine = toGlyph 0XF0A7 +remixSafe2Fill = toGlyph 0XF0A8 +remixSafe2Line = toGlyph 0XF0A9 +remixSafeFill = toGlyph 0XF0AA +remixSafeLine = toGlyph 0XF0AB +remixSailboatFill = toGlyph 0XF0AC +remixSailboatLine = toGlyph 0XF0AD +remixSave2Fill = toGlyph 0XF0AE +remixSave2Line = toGlyph 0XF0AF +remixSave3Fill = toGlyph 0XF0B0 +remixSave3Line = toGlyph 0XF0B1 +remixSaveFill = toGlyph 0XF0B2 +remixSaveLine = toGlyph 0XF0B3 +remixScales2Fill = toGlyph 0XF0B4 +remixScales2Line = toGlyph 0XF0B5 +remixScales3Fill = toGlyph 0XF0B6 +remixScales3Line = toGlyph 0XF0B7 +remixScalesFill = toGlyph 0XF0B8 +remixScalesLine = toGlyph 0XF0B9 +remixScan2Fill = toGlyph 0XF0BA +remixScan2Line = toGlyph 0XF0BB +remixScanFill = toGlyph 0XF0BC +remixScanLine = toGlyph 0XF0BD +remixScissors2Fill = toGlyph 0XF0BE +remixScissors2Line = toGlyph 0XF0BF +remixScissorsCutFill = toGlyph 0XF0C0 +remixScissorsCutLine = toGlyph 0XF0C1 +remixScissorsFill = toGlyph 0XF0C2 +remixScissorsLine = toGlyph 0XF0C3 +remixScreenshot2Fill = toGlyph 0XF0C4 +remixScreenshot2Line = toGlyph 0XF0C5 +remixScreenshotFill = toGlyph 0XF0C6 +remixScreenshotLine = toGlyph 0XF0C7 +remixSdCardFill = toGlyph 0XF0C8 +remixSdCardLine = toGlyph 0XF0C9 +remixSdCardMiniFill = toGlyph 0XF0CA +remixSdCardMiniLine = toGlyph 0XF0CB +remixSearch2Fill = toGlyph 0XF0CC +remixSearch2Line = toGlyph 0XF0CD +remixSearchEyeFill = toGlyph 0XF0CE +remixSearchEyeLine = toGlyph 0XF0CF +remixSearchFill = toGlyph 0XF0D0 +remixSearchLine = toGlyph 0XF0D1 +remixSecurePaymentFill = toGlyph 0XF0D2 +remixSecurePaymentLine = toGlyph 0XF0D3 +remixSeedlingFill = toGlyph 0XF0D4 +remixSeedlingLine = toGlyph 0XF0D5 +remixSendBackward = toGlyph 0XF0D6 +remixSendPlane2Fill = toGlyph 0XF0D7 +remixSendPlane2Line = toGlyph 0XF0D8 +remixSendPlaneFill = toGlyph 0XF0D9 +remixSendPlaneLine = toGlyph 0XF0DA +remixSendToBack = toGlyph 0XF0DB +remixSensorFill = toGlyph 0XF0DC +remixSensorLine = toGlyph 0XF0DD +remixSeparator = toGlyph 0XF0DE +remixServerFill = toGlyph 0XF0DF +remixServerLine = toGlyph 0XF0E0 +remixServiceFill = toGlyph 0XF0E1 +remixServiceLine = toGlyph 0XF0E2 +remixSettings2Fill = toGlyph 0XF0E3 +remixSettings2Line = toGlyph 0XF0E4 +remixSettings3Fill = toGlyph 0XF0E5 +remixSettings3Line = toGlyph 0XF0E6 +remixSettings4Fill = toGlyph 0XF0E7 +remixSettings4Line = toGlyph 0XF0E8 +remixSettings5Fill = toGlyph 0XF0E9 +remixSettings5Line = toGlyph 0XF0EA +remixSettings6Fill = toGlyph 0XF0EB +remixSettings6Line = toGlyph 0XF0EC +remixSettingsFill = toGlyph 0XF0ED +remixSettingsLine = toGlyph 0XF0EE +remixShape2Fill = toGlyph 0XF0EF +remixShape2Line = toGlyph 0XF0F0 +remixShapeFill = toGlyph 0XF0F1 +remixShapeLine = toGlyph 0XF0F2 +remixShareBoxFill = toGlyph 0XF0F3 +remixShareBoxLine = toGlyph 0XF0F4 +remixShareCircleFill = toGlyph 0XF0F5 +remixShareCircleLine = toGlyph 0XF0F6 +remixShareFill = toGlyph 0XF0F7 +remixShareForward2Fill = toGlyph 0XF0F8 +remixShareForward2Line = toGlyph 0XF0F9 +remixShareForwardBoxFill = toGlyph 0XF0FA +remixShareForwardBoxLine = toGlyph 0XF0FB +remixShareForwardFill = toGlyph 0XF0FC +remixShareForwardLine = toGlyph 0XF0FD +remixShareLine = toGlyph 0XF0FE +remixShieldCheckFill = toGlyph 0XF0FF +remixShieldCheckLine = toGlyph 0XF100 +remixShieldCrossFill = toGlyph 0XF101 +remixShieldCrossLine = toGlyph 0XF102 +remixShieldFill = toGlyph 0XF103 +remixShieldFlashFill = toGlyph 0XF104 +remixShieldFlashLine = toGlyph 0XF105 +remixShieldKeyholeFill = toGlyph 0XF106 +remixShieldKeyholeLine = toGlyph 0XF107 +remixShieldLine = toGlyph 0XF108 +remixShieldStarFill = toGlyph 0XF109 +remixShieldStarLine = toGlyph 0XF10A +remixShieldUserFill = toGlyph 0XF10B +remixShieldUserLine = toGlyph 0XF10C +remixShip2Fill = toGlyph 0XF10D +remixShip2Line = toGlyph 0XF10E +remixShipFill = toGlyph 0XF10F +remixShipLine = toGlyph 0XF110 +remixShirtFill = toGlyph 0XF111 +remixShirtLine = toGlyph 0XF112 +remixShoppingBag2Fill = toGlyph 0XF113 +remixShoppingBag2Line = toGlyph 0XF114 +remixShoppingBag3Fill = toGlyph 0XF115 +remixShoppingBag3Line = toGlyph 0XF116 +remixShoppingBagFill = toGlyph 0XF117 +remixShoppingBagLine = toGlyph 0XF118 +remixShoppingBasket2Fill = toGlyph 0XF119 +remixShoppingBasket2Line = toGlyph 0XF11A +remixShoppingBasketFill = toGlyph 0XF11B +remixShoppingBasketLine = toGlyph 0XF11C +remixShoppingCart2Fill = toGlyph 0XF11D +remixShoppingCart2Line = toGlyph 0XF11E +remixShoppingCartFill = toGlyph 0XF11F +remixShoppingCartLine = toGlyph 0XF120 +remixShowersFill = toGlyph 0XF121 +remixShowersLine = toGlyph 0XF122 +remixShuffleFill = toGlyph 0XF123 +remixShuffleLine = toGlyph 0XF124 +remixShutDownFill = toGlyph 0XF125 +remixShutDownLine = toGlyph 0XF126 +remixSideBarFill = toGlyph 0XF127 +remixSideBarLine = toGlyph 0XF128 +remixSignalTowerFill = toGlyph 0XF129 +remixSignalTowerLine = toGlyph 0XF12A +remixSignalWifi1Fill = toGlyph 0XF12B +remixSignalWifi1Line = toGlyph 0XF12C +remixSignalWifi2Fill = toGlyph 0XF12D +remixSignalWifi2Line = toGlyph 0XF12E +remixSignalWifi3Fill = toGlyph 0XF12F +remixSignalWifi3Line = toGlyph 0XF130 +remixSignalWifiErrorFill = toGlyph 0XF131 +remixSignalWifiErrorLine = toGlyph 0XF132 +remixSignalWifiFill = toGlyph 0XF133 +remixSignalWifiLine = toGlyph 0XF134 +remixSignalWifiOffFill = toGlyph 0XF135 +remixSignalWifiOffLine = toGlyph 0XF136 +remixSimCard2Fill = toGlyph 0XF137 +remixSimCard2Line = toGlyph 0XF138 +remixSimCardFill = toGlyph 0XF139 +remixSimCardLine = toGlyph 0XF13A +remixSingleQuotesL = toGlyph 0XF13B +remixSingleQuotesR = toGlyph 0XF13C +remixSipFill = toGlyph 0XF13D +remixSipLine = toGlyph 0XF13E +remixSkipBackFill = toGlyph 0XF13F +remixSkipBackLine = toGlyph 0XF140 +remixSkipBackMiniFill = toGlyph 0XF141 +remixSkipBackMiniLine = toGlyph 0XF142 +remixSkipForwardFill = toGlyph 0XF143 +remixSkipForwardLine = toGlyph 0XF144 +remixSkipForwardMiniFill = toGlyph 0XF145 +remixSkipForwardMiniLine = toGlyph 0XF146 +remixSkull2Fill = toGlyph 0XF147 +remixSkull2Line = toGlyph 0XF148 +remixSkullFill = toGlyph 0XF149 +remixSkullLine = toGlyph 0XF14A +remixSkypeFill = toGlyph 0XF14B +remixSkypeLine = toGlyph 0XF14C +remixSlackFill = toGlyph 0XF14D +remixSlackLine = toGlyph 0XF14E +remixSliceFill = toGlyph 0XF14F +remixSliceLine = toGlyph 0XF150 +remixSlideshow2Fill = toGlyph 0XF151 +remixSlideshow2Line = toGlyph 0XF152 +remixSlideshow3Fill = toGlyph 0XF153 +remixSlideshow3Line = toGlyph 0XF154 +remixSlideshow4Fill = toGlyph 0XF155 +remixSlideshow4Line = toGlyph 0XF156 +remixSlideshowFill = toGlyph 0XF157 +remixSlideshowLine = toGlyph 0XF158 +remixSmartphoneFill = toGlyph 0XF159 +remixSmartphoneLine = toGlyph 0XF15A +remixSnapchatFill = toGlyph 0XF15B +remixSnapchatLine = toGlyph 0XF15C +remixSnowyFill = toGlyph 0XF15D +remixSnowyLine = toGlyph 0XF15E +remixSortAsc = toGlyph 0XF15F +remixSortDesc = toGlyph 0XF160 +remixSoundModuleFill = toGlyph 0XF161 +remixSoundModuleLine = toGlyph 0XF162 +remixSoundcloudFill = toGlyph 0XF163 +remixSoundcloudLine = toGlyph 0XF164 +remixSpaceShipFill = toGlyph 0XF165 +remixSpaceShipLine = toGlyph 0XF166 +remixSpace = toGlyph 0XF167 +remixSpam2Fill = toGlyph 0XF168 +remixSpam2Line = toGlyph 0XF169 +remixSpam3Fill = toGlyph 0XF16A +remixSpam3Line = toGlyph 0XF16B +remixSpamFill = toGlyph 0XF16C +remixSpamLine = toGlyph 0XF16D +remixSpeaker2Fill = toGlyph 0XF16E +remixSpeaker2Line = toGlyph 0XF16F +remixSpeaker3Fill = toGlyph 0XF170 +remixSpeaker3Line = toGlyph 0XF171 +remixSpeakerFill = toGlyph 0XF172 +remixSpeakerLine = toGlyph 0XF173 +remixSpectrumFill = toGlyph 0XF174 +remixSpectrumLine = toGlyph 0XF175 +remixSpeedFill = toGlyph 0XF176 +remixSpeedLine = toGlyph 0XF177 +remixSpeedMiniFill = toGlyph 0XF178 +remixSpeedMiniLine = toGlyph 0XF179 +remixSplitCellsHorizontal = toGlyph 0XF17A +remixSplitCellsVertical = toGlyph 0XF17B +remixSpotifyFill = toGlyph 0XF17C +remixSpotifyLine = toGlyph 0XF17D +remixSpyFill = toGlyph 0XF17E +remixSpyLine = toGlyph 0XF17F +remixStackFill = toGlyph 0XF180 +remixStackLine = toGlyph 0XF181 +remixStackOverflowFill = toGlyph 0XF182 +remixStackOverflowLine = toGlyph 0XF183 +remixStackshareFill = toGlyph 0XF184 +remixStackshareLine = toGlyph 0XF185 +remixStarFill = toGlyph 0XF186 +remixStarHalfFill = toGlyph 0XF187 +remixStarHalfLine = toGlyph 0XF188 +remixStarHalfSFill = toGlyph 0XF189 +remixStarHalfSLine = toGlyph 0XF18A +remixStarLine = toGlyph 0XF18B +remixStarSFill = toGlyph 0XF18C +remixStarSLine = toGlyph 0XF18D +remixStarSmileFill = toGlyph 0XF18E +remixStarSmileLine = toGlyph 0XF18F +remixSteamFill = toGlyph 0XF190 +remixSteamLine = toGlyph 0XF191 +remixSteering2Fill = toGlyph 0XF192 +remixSteering2Line = toGlyph 0XF193 +remixSteeringFill = toGlyph 0XF194 +remixSteeringLine = toGlyph 0XF195 +remixStethoscopeFill = toGlyph 0XF196 +remixStethoscopeLine = toGlyph 0XF197 +remixStickyNote2Fill = toGlyph 0XF198 +remixStickyNote2Line = toGlyph 0XF199 +remixStickyNoteFill = toGlyph 0XF19A +remixStickyNoteLine = toGlyph 0XF19B +remixStockFill = toGlyph 0XF19C +remixStockLine = toGlyph 0XF19D +remixStopCircleFill = toGlyph 0XF19E +remixStopCircleLine = toGlyph 0XF19F +remixStopFill = toGlyph 0XF1A0 +remixStopLine = toGlyph 0XF1A1 +remixStopMiniFill = toGlyph 0XF1A2 +remixStopMiniLine = toGlyph 0XF1A3 +remixStore2Fill = toGlyph 0XF1A4 +remixStore2Line = toGlyph 0XF1A5 +remixStore3Fill = toGlyph 0XF1A6 +remixStore3Line = toGlyph 0XF1A7 +remixStoreFill = toGlyph 0XF1A8 +remixStoreLine = toGlyph 0XF1A9 +remixStrikethrough2 = toGlyph 0XF1AA +remixStrikethrough = toGlyph 0XF1AB +remixSubscript2 = toGlyph 0XF1AC +remixSubscript = toGlyph 0XF1AD +remixSubtractFill = toGlyph 0XF1AE +remixSubtractLine = toGlyph 0XF1AF +remixSubwayFill = toGlyph 0XF1B0 +remixSubwayLine = toGlyph 0XF1B1 +remixSubwayWifiFill = toGlyph 0XF1B2 +remixSubwayWifiLine = toGlyph 0XF1B3 +remixSuitcase2Fill = toGlyph 0XF1B4 +remixSuitcase2Line = toGlyph 0XF1B5 +remixSuitcase3Fill = toGlyph 0XF1B6 +remixSuitcase3Line = toGlyph 0XF1B7 +remixSuitcaseFill = toGlyph 0XF1B8 +remixSuitcaseLine = toGlyph 0XF1B9 +remixSunCloudyFill = toGlyph 0XF1BA +remixSunCloudyLine = toGlyph 0XF1BB +remixSunFill = toGlyph 0XF1BC +remixSunFoggyFill = toGlyph 0XF1BD +remixSunFoggyLine = toGlyph 0XF1BE +remixSunLine = toGlyph 0XF1BF +remixSuperscript2 = toGlyph 0XF1C0 +remixSuperscript = toGlyph 0XF1C1 +remixSurgicalMaskFill = toGlyph 0XF1C2 +remixSurgicalMaskLine = toGlyph 0XF1C3 +remixSurroundSoundFill = toGlyph 0XF1C4 +remixSurroundSoundLine = toGlyph 0XF1C5 +remixSurveyFill = toGlyph 0XF1C6 +remixSurveyLine = toGlyph 0XF1C7 +remixSwapBoxFill = toGlyph 0XF1C8 +remixSwapBoxLine = toGlyph 0XF1C9 +remixSwapFill = toGlyph 0XF1CA +remixSwapLine = toGlyph 0XF1CB +remixSwitchFill = toGlyph 0XF1CC +remixSwitchLine = toGlyph 0XF1CD +remixSwordFill = toGlyph 0XF1CE +remixSwordLine = toGlyph 0XF1CF +remixSyringeFill = toGlyph 0XF1D0 +remixSyringeLine = toGlyph 0XF1D1 +remixTBoxFill = toGlyph 0XF1D2 +remixTBoxLine = toGlyph 0XF1D3 +remixTShirt2Fill = toGlyph 0XF1D4 +remixTShirt2Line = toGlyph 0XF1D5 +remixTShirtAirFill = toGlyph 0XF1D6 +remixTShirtAirLine = toGlyph 0XF1D7 +remixTShirtFill = toGlyph 0XF1D8 +remixTShirtLine = toGlyph 0XF1D9 +remixTable2 = toGlyph 0XF1DA +remixTableAltFill = toGlyph 0XF1DB +remixTableAltLine = toGlyph 0XF1DC +remixTableFill = toGlyph 0XF1DD +remixTableLine = toGlyph 0XF1DE +remixTabletFill = toGlyph 0XF1DF +remixTabletLine = toGlyph 0XF1E0 +remixTakeawayFill = toGlyph 0XF1E1 +remixTakeawayLine = toGlyph 0XF1E2 +remixTaobaoFill = toGlyph 0XF1E3 +remixTaobaoLine = toGlyph 0XF1E4 +remixTapeFill = toGlyph 0XF1E5 +remixTapeLine = toGlyph 0XF1E6 +remixTaskFill = toGlyph 0XF1E7 +remixTaskLine = toGlyph 0XF1E8 +remixTaxiFill = toGlyph 0XF1E9 +remixTaxiLine = toGlyph 0XF1EA +remixTaxiWifiFill = toGlyph 0XF1EB +remixTaxiWifiLine = toGlyph 0XF1EC +remixTeamFill = toGlyph 0XF1ED +remixTeamLine = toGlyph 0XF1EE +remixTelegramFill = toGlyph 0XF1EF +remixTelegramLine = toGlyph 0XF1F0 +remixTempColdFill = toGlyph 0XF1F1 +remixTempColdLine = toGlyph 0XF1F2 +remixTempHotFill = toGlyph 0XF1F3 +remixTempHotLine = toGlyph 0XF1F4 +remixTerminalBoxFill = toGlyph 0XF1F5 +remixTerminalBoxLine = toGlyph 0XF1F6 +remixTerminalFill = toGlyph 0XF1F7 +remixTerminalLine = toGlyph 0XF1F8 +remixTerminalWindowFill = toGlyph 0XF1F9 +remixTerminalWindowLine = toGlyph 0XF1FA +remixTestTubeFill = toGlyph 0XF1FB +remixTestTubeLine = toGlyph 0XF1FC +remixTextDirectionL = toGlyph 0XF1FD +remixTextDirectionR = toGlyph 0XF1FE +remixTextSpacing = toGlyph 0XF1FF +remixTextWrap = toGlyph 0XF200 +remixText = toGlyph 0XF201 +remixThermometerFill = toGlyph 0XF202 +remixThermometerLine = toGlyph 0XF203 +remixThumbDownFill = toGlyph 0XF204 +remixThumbDownLine = toGlyph 0XF205 +remixThumbUpFill = toGlyph 0XF206 +remixThumbUpLine = toGlyph 0XF207 +remixThunderstormsFill = toGlyph 0XF208 +remixThunderstormsLine = toGlyph 0XF209 +remixTicket2Fill = toGlyph 0XF20A +remixTicket2Line = toGlyph 0XF20B +remixTicketFill = toGlyph 0XF20C +remixTicketLine = toGlyph 0XF20D +remixTimeFill = toGlyph 0XF20E +remixTimeLine = toGlyph 0XF20F +remixTimer2Fill = toGlyph 0XF210 +remixTimer2Line = toGlyph 0XF211 +remixTimerFill = toGlyph 0XF212 +remixTimerFlashFill = toGlyph 0XF213 +remixTimerFlashLine = toGlyph 0XF214 +remixTimerLine = toGlyph 0XF215 +remixTodoFill = toGlyph 0XF216 +remixTodoLine = toGlyph 0XF217 +remixToggleFill = toGlyph 0XF218 +remixToggleLine = toGlyph 0XF219 +remixToolsFill = toGlyph 0XF21A +remixToolsLine = toGlyph 0XF21B +remixTornadoFill = toGlyph 0XF21C +remixTornadoLine = toGlyph 0XF21D +remixTrademarkFill = toGlyph 0XF21E +remixTrademarkLine = toGlyph 0XF21F +remixTrafficLightFill = toGlyph 0XF220 +remixTrafficLightLine = toGlyph 0XF221 +remixTrainFill = toGlyph 0XF222 +remixTrainLine = toGlyph 0XF223 +remixTrainWifiFill = toGlyph 0XF224 +remixTrainWifiLine = toGlyph 0XF225 +remixTranslate2 = toGlyph 0XF226 +remixTranslate = toGlyph 0XF227 +remixTravestiFill = toGlyph 0XF228 +remixTravestiLine = toGlyph 0XF229 +remixTreasureMapFill = toGlyph 0XF22A +remixTreasureMapLine = toGlyph 0XF22B +remixTrelloFill = toGlyph 0XF22C +remixTrelloLine = toGlyph 0XF22D +remixTrophyFill = toGlyph 0XF22E +remixTrophyLine = toGlyph 0XF22F +remixTruckFill = toGlyph 0XF230 +remixTruckLine = toGlyph 0XF231 +remixTumblrFill = toGlyph 0XF232 +remixTumblrLine = toGlyph 0XF233 +remixTv2Fill = toGlyph 0XF234 +remixTv2Line = toGlyph 0XF235 +remixTvFill = toGlyph 0XF236 +remixTvLine = toGlyph 0XF237 +remixTwitchFill = toGlyph 0XF238 +remixTwitchLine = toGlyph 0XF239 +remixTwitterFill = toGlyph 0XF23A +remixTwitterLine = toGlyph 0XF23B +remixTyphoonFill = toGlyph 0XF23C +remixTyphoonLine = toGlyph 0XF23D +remixUDiskFill = toGlyph 0XF23E +remixUDiskLine = toGlyph 0XF23F +remixUbuntuFill = toGlyph 0XF240 +remixUbuntuLine = toGlyph 0XF241 +remixUmbrellaFill = toGlyph 0XF242 +remixUmbrellaLine = toGlyph 0XF243 +remixUnderline = toGlyph 0XF244 +remixUninstallFill = toGlyph 0XF245 +remixUninstallLine = toGlyph 0XF246 +remixUnsplashFill = toGlyph 0XF247 +remixUnsplashLine = toGlyph 0XF248 +remixUpload2Fill = toGlyph 0XF249 +remixUpload2Line = toGlyph 0XF24A +remixUploadCloud2Fill = toGlyph 0XF24B +remixUploadCloud2Line = toGlyph 0XF24C +remixUploadCloudFill = toGlyph 0XF24D +remixUploadCloudLine = toGlyph 0XF24E +remixUploadFill = toGlyph 0XF24F +remixUploadLine = toGlyph 0XF250 +remixUsbFill = toGlyph 0XF251 +remixUsbLine = toGlyph 0XF252 +remixUser2Fill = toGlyph 0XF253 +remixUser2Line = toGlyph 0XF254 +remixUser3Fill = toGlyph 0XF255 +remixUser3Line = toGlyph 0XF256 +remixUser4Fill = toGlyph 0XF257 +remixUser4Line = toGlyph 0XF258 +remixUser5Fill = toGlyph 0XF259 +remixUser5Line = toGlyph 0XF25A +remixUser6Fill = toGlyph 0XF25B +remixUser6Line = toGlyph 0XF25C +remixUserAddFill = toGlyph 0XF25D +remixUserAddLine = toGlyph 0XF25E +remixUserFill = toGlyph 0XF25F +remixUserFollowFill = toGlyph 0XF260 +remixUserFollowLine = toGlyph 0XF261 +remixUserHeartFill = toGlyph 0XF262 +remixUserHeartLine = toGlyph 0XF263 +remixUserLine = toGlyph 0XF264 +remixUserLocationFill = toGlyph 0XF265 +remixUserLocationLine = toGlyph 0XF266 +remixUserReceived2Fill = toGlyph 0XF267 +remixUserReceived2Line = toGlyph 0XF268 +remixUserReceivedFill = toGlyph 0XF269 +remixUserReceivedLine = toGlyph 0XF26A +remixUserSearchFill = toGlyph 0XF26B +remixUserSearchLine = toGlyph 0XF26C +remixUserSettingsFill = toGlyph 0XF26D +remixUserSettingsLine = toGlyph 0XF26E +remixUserShared2Fill = toGlyph 0XF26F +remixUserShared2Line = toGlyph 0XF270 +remixUserSharedFill = toGlyph 0XF271 +remixUserSharedLine = toGlyph 0XF272 +remixUserSmileFill = toGlyph 0XF273 +remixUserSmileLine = toGlyph 0XF274 +remixUserStarFill = toGlyph 0XF275 +remixUserStarLine = toGlyph 0XF276 +remixUserUnfollowFill = toGlyph 0XF277 +remixUserUnfollowLine = toGlyph 0XF278 +remixUserVoiceFill = toGlyph 0XF279 +remixUserVoiceLine = toGlyph 0XF27A +remixVideoAddFill = toGlyph 0XF27B +remixVideoAddLine = toGlyph 0XF27C +remixVideoChatFill = toGlyph 0XF27D +remixVideoChatLine = toGlyph 0XF27E +remixVideoDownloadFill = toGlyph 0XF27F +remixVideoDownloadLine = toGlyph 0XF280 +remixVideoFill = toGlyph 0XF281 +remixVideoLine = toGlyph 0XF282 +remixVideoUploadFill = toGlyph 0XF283 +remixVideoUploadLine = toGlyph 0XF284 +remixVidicon2Fill = toGlyph 0XF285 +remixVidicon2Line = toGlyph 0XF286 +remixVidiconFill = toGlyph 0XF287 +remixVidiconLine = toGlyph 0XF288 +remixVimeoFill = toGlyph 0XF289 +remixVimeoLine = toGlyph 0XF28A +remixVipCrown2Fill = toGlyph 0XF28B +remixVipCrown2Line = toGlyph 0XF28C +remixVipCrownFill = toGlyph 0XF28D +remixVipCrownLine = toGlyph 0XF28E +remixVipDiamondFill = toGlyph 0XF28F +remixVipDiamondLine = toGlyph 0XF290 +remixVipFill = toGlyph 0XF291 +remixVipLine = toGlyph 0XF292 +remixVirusFill = toGlyph 0XF293 +remixVirusLine = toGlyph 0XF294 +remixVisaFill = toGlyph 0XF295 +remixVisaLine = toGlyph 0XF296 +remixVoiceRecognitionFill = toGlyph 0XF297 +remixVoiceRecognitionLine = toGlyph 0XF298 +remixVoiceprintFill = toGlyph 0XF299 +remixVoiceprintLine = toGlyph 0XF29A +remixVolumeDownFill = toGlyph 0XF29B +remixVolumeDownLine = toGlyph 0XF29C +remixVolumeMuteFill = toGlyph 0XF29D +remixVolumeMuteLine = toGlyph 0XF29E +remixVolumeOffVibrateFill = toGlyph 0XF29F +remixVolumeOffVibrateLine = toGlyph 0XF2A0 +remixVolumeUpFill = toGlyph 0XF2A1 +remixVolumeUpLine = toGlyph 0XF2A2 +remixVolumeVibrateFill = toGlyph 0XF2A3 +remixVolumeVibrateLine = toGlyph 0XF2A4 +remixVuejsFill = toGlyph 0XF2A5 +remixVuejsLine = toGlyph 0XF2A6 +remixWalkFill = toGlyph 0XF2A7 +remixWalkLine = toGlyph 0XF2A8 +remixWallet2Fill = toGlyph 0XF2A9 +remixWallet2Line = toGlyph 0XF2AA +remixWallet3Fill = toGlyph 0XF2AB +remixWallet3Line = toGlyph 0XF2AC +remixWalletFill = toGlyph 0XF2AD +remixWalletLine = toGlyph 0XF2AE +remixWaterFlashFill = toGlyph 0XF2AF +remixWaterFlashLine = toGlyph 0XF2B0 +remixWebcamFill = toGlyph 0XF2B1 +remixWebcamLine = toGlyph 0XF2B2 +remixWechat2Fill = toGlyph 0XF2B3 +remixWechat2Line = toGlyph 0XF2B4 +remixWechatFill = toGlyph 0XF2B5 +remixWechatLine = toGlyph 0XF2B6 +remixWechatPayFill = toGlyph 0XF2B7 +remixWechatPayLine = toGlyph 0XF2B8 +remixWeiboFill = toGlyph 0XF2B9 +remixWeiboLine = toGlyph 0XF2BA +remixWhatsappFill = toGlyph 0XF2BB +remixWhatsappLine = toGlyph 0XF2BC +remixWheelchairFill = toGlyph 0XF2BD +remixWheelchairLine = toGlyph 0XF2BE +remixWifiFill = toGlyph 0XF2BF +remixWifiLine = toGlyph 0XF2C0 +remixWifiOffFill = toGlyph 0XF2C1 +remixWifiOffLine = toGlyph 0XF2C2 +remixWindow2Fill = toGlyph 0XF2C3 +remixWindow2Line = toGlyph 0XF2C4 +remixWindowFill = toGlyph 0XF2C5 +remixWindowLine = toGlyph 0XF2C6 +remixWindowsFill = toGlyph 0XF2C7 +remixWindowsLine = toGlyph 0XF2C8 +remixWindyFill = toGlyph 0XF2C9 +remixWindyLine = toGlyph 0XF2CA +remixWirelessChargingFill = toGlyph 0XF2CB +remixWirelessChargingLine = toGlyph 0XF2CC +remixWomenFill = toGlyph 0XF2CD +remixWomenLine = toGlyph 0XF2CE +remixWubiInput = toGlyph 0XF2CF +remixXboxFill = toGlyph 0XF2D0 +remixXboxLine = toGlyph 0XF2D1 +remixXingFill = toGlyph 0XF2D2 +remixXingLine = toGlyph 0XF2D3 +remixYoutubeFill = toGlyph 0XF2D4 +remixYoutubeLine = toGlyph 0XF2D5 +remixZcoolFill = toGlyph 0XF2D6 +remixZcoolLine = toGlyph 0XF2D7 +remixZhihuFill = toGlyph 0XF2D8 +remixZhihuLine = toGlyph 0XF2D9 +remixZoomInFill = toGlyph 0XF2DA +remixZoomInLine = toGlyph 0XF2DB +remixZoomOutFill = toGlyph 0XF2DC +remixZoomOutLine = toGlyph 0XF2DD +remixZzzFill = toGlyph 0XF2DE +remixZzzLine = toGlyph 0XF2DF diff --git a/src/Monomer/Graphics/Text.hs b/src/Monomer/Graphics/Text.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/Text.hs @@ -0,0 +1,445 @@ +{-| +Module : Monomer.Graphics.Text +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for calculating text size. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +module Monomer.Graphics.Text ( + calcTextSize, + calcTextSize_, + fitTextToSize, + fitTextToWidth, + alignTextLines, + moveTextLines, + getTextLinesSize, + getGlyphsMin, + getGlyphsMax +) where + +import Control.Lens ((&), (^.), (^?), (+~), ix, non) +import Data.Default +import Data.List (foldl') +import Data.Maybe +import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Text (Text) + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Common +import Monomer.Core.StyleTypes +import Monomer.Core.StyleUtil +import Monomer.Graphics.Types +import Monomer.Helper + +import qualified Monomer.Common.Lens as L +import qualified Monomer.Graphics.Lens as L + +type GlyphGroup = Seq GlyphPos + +-- | Returns the size a given text an style will take. +calcTextSize + :: FontManager -- ^ The font manager. + -> StyleState -- ^ The style. + -> Text -- ^ The text to calculate. + -> Size -- ^ The calculated size. +calcTextSize fontMgr style !text = size where + size = calcTextSize_ fontMgr style SingleLine KeepSpaces Nothing Nothing text + +-- | Returns the size a given text an style will take. +calcTextSize_ + :: FontManager -- ^ The font manager. + -> StyleState -- ^ The style. + -> TextMode -- ^ Single or multiline. + -> TextTrim -- ^ Whether to trim or keep spaces. + -> Maybe Double -- ^ Optional max width (needed for multiline). + -> Maybe Int -- ^ Optional max lines. + -> Text -- ^ The text to calculate. + -> Size -- ^ The calculated size. +calcTextSize_ fontMgr style mode trim mwidth mlines text = newSize where + font = styleFont style + fontSize = styleFontSize style + !metrics = computeTextMetrics fontMgr font fontSize + width = fromMaybe maxNumericValue mwidth + + textLinesW = fitTextToWidth fontMgr style width trim text + textLines + | mode == SingleLine = Seq.take 1 textLinesW + | isJust mlines = Seq.take (fromJust mlines) textLinesW + | otherwise = textLinesW + + newSize + | not (Seq.null textLines) = getTextLinesSize textLines + | otherwise = Size 0 (_txmLineH metrics) + +{-| +Fits the given text to a determined size, splitting on multiple lines as needed. +Since the function returns glyphs that may be partially visible, the text can +overflow vertically or horizontally and a scissor is needed. The rectangles are +returned with zero offset (i.e., x = 0 and first line y = 0), and a translation +transform is needed when rendering. +-} +fitTextToSize + :: FontManager -- ^ The font manager. + -> StyleState -- ^ The style. + -> TextOverflow -- ^ Whether to clip or use ellipsis. + -> TextMode -- ^ Single or multiline. + -> TextTrim -- ^ Whether to trim or keep spaces. + -> Maybe Int -- ^ Optional max lines. + -> Size -- ^ The bounding size. + -> Text -- ^ The text to fit. + -> Seq TextLine -- ^ The fitted text lines. +fitTextToSize fontMgr style ovf mode trim mlines !size !text = newLines where + Size cw ch = size + font = styleFont style + fontSize = styleFontSize style + textMetrics = computeTextMetrics fontMgr font fontSize + + fitW + | mode == MultiLine = cw + | otherwise = maxNumericValue + maxH = case mlines of + Just maxLines -> min ch (fromIntegral maxLines * textMetrics ^. L.lineH) + _ -> ch + + textLinesW = fitTextToWidth fontMgr style fitW trim text + firstLine = Seq.take 1 textLinesW + isMultiline = mode == MultiLine + ellipsisReq = ovf == Ellipsis && getTextLinesSize firstLine ^. L.w > cw + + newLines + | isMultiline = fitLinesToH fontMgr style ovf cw maxH textLinesW + | ellipsisReq = addEllipsisToTextLine fontMgr style cw <$> firstLine + | otherwise = clipTextLine fontMgr style trim cw <$> firstLine + +-- | Fits a single line of text to the given width, potencially spliting into +-- | several lines. +fitTextToWidth + :: FontManager -- ^ The fontManager. + -> StyleState -- ^ The style. + -> Double -- ^ The maximum width. + -> TextTrim -- ^ Whether to trim or keep spaces. + -> Text -- ^ The text to calculate. + -> Seq TextLine -- ^ The fitted text lines. +fitTextToWidth fontMgr style width trim text = resultLines where + font = styleFont style + fSize = styleFontSize style + fSpcH = styleFontSpaceH style + fSpcV = styleFontSpaceV style + lineH = _txmLineH metrics + + !metrics = computeTextMetrics fontMgr font fSize + fitToWidth = fitLineToW fontMgr font fSize fSpcH fSpcV metrics + + helper acc line = (cLines <> newLines, newTop) where + (cLines, cTop) = acc + newLines = fitToWidth cTop width trim line + vspc = unFontSpace fSpcV + newTop = cTop + fromIntegral (Seq.length newLines) * (lineH + vspc) + + (resultLines, _) = foldl' helper (Empty, 0) (T.lines text) + +-- | Aligns a Seq of TextLines to the given rect. +alignTextLines + :: StyleState -- ^ The style. + -> Rect -- ^ The bounding rect. Text may overflow. + -> Seq TextLine -- ^ The TextLines to align. + -> Seq TextLine -- ^ The aligned TextLines. +alignTextLines style parentRect textLines = newTextLines where + Rect _ py _ ph = parentRect + Size _ th = getTextLinesSize textLines + TextMetrics asc _ lineH lowerX = (textLines ^? ix 0) ^. non def . L.metrics + + isSingle = length textLines == 1 + alignH = styleTextAlignH style + alignV = styleTextAlignV style + + alignOffsetY = case alignV of + ATTop -> 0 + ATAscender + | isSingle -> (ph - asc) / 2 + ATLowerX + | isSingle -> (ph - lowerX) / 2 - (asc - lowerX) + ATBottom -> ph - th + ATBaseline -> ph - th + _ -> (ph - th) / 2 -- ATMiddle + + offsetY = py + alignOffsetY + newTextLines = fmap (alignTextLine parentRect offsetY alignH) textLines + +-- | Moves a Seq of TextLines by the given offset. +moveTextLines + :: Point -- ^ The offset. + -> Seq TextLine -- ^ The TextLines. + -> Seq TextLine -- ^ The displaced TextLines. +moveTextLines (Point offsetX offsetY) textLines = newTextLines where + moveTextLine tl = tl + & L.rect . L.x +~ offsetX + & L.rect . L.y +~ offsetY + newTextLines = fmap moveTextLine textLines + +-- | Returns the combined size of a sequence of text lines. +getTextLinesSize :: Seq TextLine -> Size +getTextLinesSize textLines = size where + -- Excludes last line vertical spacing + spaceV = unFontSpace $ maybe def _tlFontSpaceV (textLines ^? ix 0) + lineW line = line ^. L.size . L.w + lineH line = line ^. L.size . L.h + unFontSpace (_tlFontSpaceV line) + width = maximum (fmap lineW textLines) + height = sum (fmap lineH textLines) - spaceV + size + | Seq.null textLines = def + | otherwise = Size width height + +-- | Gets the minimum x a Seq of Glyphs will use. +getGlyphsMin :: Seq GlyphPos -> Double +getGlyphsMin Empty = 0 +getGlyphsMin (g :<| gs) = _glpXMin g + +-- | Gets the maximum x a Seq of Glyphs will use. +getGlyphsMax :: Seq GlyphPos -> Double +getGlyphsMax Empty = 0 +getGlyphsMax (gs :|> g) = _glpXMax g + +-- Helpers +alignTextLine :: Rect -> Double -> AlignTH -> TextLine -> TextLine +alignTextLine parentRect offsetY alignH textLine = newTextLine where + Rect px _ pw _ = parentRect + Rect tx ty tw th = _tlRect textLine + + alignOffsetX = case alignH of + ATLeft -> 0 + ATCenter -> (pw - tw) / 2 + ATRight -> pw - tw + + offsetX = px + alignOffsetX + newTextLine = textLine { + _tlRect = Rect (tx + offsetX) (ty + offsetY) tw th + } + +fitLinesToH + :: FontManager + -> StyleState + -> TextOverflow + -> Double + -> Double + -> Seq TextLine + -> Seq TextLine +fitLinesToH fontMgr style overflow w h Empty = Empty +fitLinesToH fontMgr style overflow w h (g1 :<| g2 :<| gs) + | overflow == Ellipsis && h >= g1H + g2H = g1 :<| rest + | overflow == Ellipsis && h >= g1H = Seq.singleton ellipsisG1 + | overflow == ClipText && h >= g1H = g1 :<| rest + where + g1H = _sH (_tlSize g1) + g2H = _sH (_tlSize g2) + newH = h - g1H + rest = fitLinesToH fontMgr style overflow w newH (g2 :<| gs) + ellipsisG1 = addEllipsisToTextLine fontMgr style w g1 +fitLinesToH fontMgr style overflow w h (g :<| gs) + | h > 0 = Seq.singleton newG + | otherwise = Empty + where + gW = _sW (_tlSize g) + newG + | overflow == Ellipsis && w < gW = addEllipsisToTextLine fontMgr style w g + | otherwise = g + +fitLineToW + :: FontManager + -> Font + -> FontSize + -> FontSpace + -> FontSpace + -> TextMetrics + -> Double + -> Double + -> TextTrim + -> Text + -> Seq TextLine +fitLineToW fontMgr font fSize fSpcH fSpcV metrics 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 + resetGroups + | trim == TrimSpaces = fmap (resetGlyphs . trimGlyphs) groups + | otherwise = fmap resetGlyphs groups + buildLine = buildTextLine font fSize fSpcH fSpcV metrics top + res + | text /= "" = Seq.mapWithIndex buildLine resetGroups + | otherwise = Seq.singleton (buildLine 0 Empty) + +buildTextLine + :: Font + -> FontSize + -> FontSpace + -> FontSpace + -> TextMetrics + -> Double + -> Int + -> Seq GlyphPos + -> TextLine +buildTextLine font fSize fSpcH fSpcV metrics top idx glyphs = textLine where + lineH = _txmLineH metrics + x = 0 + y = top + fromIntegral idx * (lineH + unFontSpace fSpcV) + width = getGlyphsWidth glyphs + height = lineH + text = T.pack . reverse $ foldl' (\ac g -> _glpGlyph g : ac) [] glyphs + textLine = TextLine { + _tlFont = font, + _tlFontSize = fSize, + _tlFontSpaceH = fSpcH, + _tlFontSpaceV = fSpcV, + _tlMetrics = metrics, + _tlText = text, + _tlSize = Size width height, + _tlRect = Rect x y width height, + _tlGlyphs = glyphs + } + +addEllipsisToTextLine + :: FontManager + -> StyleState + -> Double + -> TextLine + -> TextLine +addEllipsisToTextLine fontMgr style width textLine = newTextLine where + TextLine{..} = textLine + Size tw th = _tlSize + Size dw dh = calcTextSize fontMgr style "..." + + font = styleFont style + fontSize = styleFontSize style + fontSpcH = styleFontSpaceH style + targetW = width - tw + + dropHelper (idx, w) g + | _glpW g + w <= dw = (idx + 1, _glpW g + w) + | otherwise = (idx, w) + (dropChars, _) = foldl' dropHelper (0, targetW) (Seq.reverse _tlGlyphs) + + newText = T.dropEnd dropChars _tlText <> "..." + !newGlyphs = computeGlyphsPos fontMgr font fontSize fontSpcH newText + + newW = getGlyphsWidth newGlyphs + newTextLine = textLine { + _tlText = newText, + _tlSize = _tlSize { _sW = newW }, + _tlRect = _tlRect { _rW = newW }, + _tlGlyphs = newGlyphs + } + +clipTextLine + :: FontManager + -> StyleState + -> TextTrim + -> Double + -> TextLine + -> TextLine +clipTextLine fontMgr style trim width textLine = newTextLine where + TextLine{..} = textLine + Size tw th = _tlSize + + font = styleFont style + fontSize = styleFontSize style + fontSpcH = styleFontSpaceH style + + takeHelper (idx, w) g + | _glpW g + w <= width = (idx + 1, _glpW g + w) + | otherwise = (idx, w) + + (takeChars, _) = foldl' takeHelper (0, 0) _tlGlyphs + validGlyphs = Seq.takeWhileL (\g -> _glpXMax g <= width) _tlGlyphs + newText + | trim == KeepSpaces = T.take (length validGlyphs) _tlText + | otherwise = T.dropWhileEnd (== ' ') $ T.take (length validGlyphs) _tlText + + !newGlyphs = computeGlyphsPos fontMgr font fontSize fontSpcH newText + newW = getGlyphsWidth newGlyphs + newTextLine = textLine { + _tlText = newText, + _tlSize = _tlSize { _sW = newW }, + _tlRect = _tlRect { _rW = newW }, + _tlGlyphs = newGlyphs + } + +fitGroups :: Seq GlyphGroup -> Double -> Bool -> Seq GlyphGroup +fitGroups Empty _ _ = Empty +fitGroups (g :<| gs) !width !keepTailSpaces = currentLine <| extraLines where + gW = getGlyphsWidth g + gMax = getGlyphsMax g + extraGroups = fitExtraGroups gs (width - gW) gMax keepTailSpaces + (lineGroups, remainingGroups) = extraGroups + currentLine = g <> lineGroups + extraLines = fitGroups remainingGroups width keepTailSpaces + +fitExtraGroups + :: Seq GlyphGroup + -> Double + -> Double + -> Bool + -> (Seq GlyphPos, Seq GlyphGroup) +fitExtraGroups Empty _ _ _ = (Empty, Empty) +fitExtraGroups (g :<| gs) !width !prevGMax !keepTailSpaces + | gW + wDiff <= width || keepSpace = (g <> newFit, newRest) + | otherwise = (Empty, g :<| gs) + where + gW = getGlyphsWidth g + gMin = getGlyphsMin g + gMax = getGlyphsMax g + wDiff = gMin - prevGMax + remWidth = width - (gW + wDiff) + keepSpace = keepTailSpaces && isSpaceGroup g + (newFit, newRest) = fitExtraGroups gs remWidth gMax keepTailSpaces + +getGlyphsWidth :: Seq GlyphPos -> Double +getGlyphsWidth glyphs = getGlyphsMax glyphs - getGlyphsMin glyphs + +isSpaceGroup :: Seq GlyphPos -> Bool +isSpaceGroup Empty = False +isSpaceGroup (g :<| gs) = isSpace (_glpGlyph g) + +splitGroups :: Seq GlyphPos -> Seq GlyphGroup +splitGroups Empty = Empty +splitGroups glyphs = group <| splitGroups rest where + g :<| gs = glyphs + groupWordFn = not . isWordDelimiter . _glpGlyph + (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 + } + +trimGlyphs :: Seq GlyphPos -> Seq GlyphPos +trimGlyphs glyphs = newGlyphs where + isSpaceGlyph g = _glpGlyph g == ' ' + newGlyphs = Seq.dropWhileL isSpaceGlyph $ Seq.dropWhileR isSpaceGlyph glyphs + +isWordDelimiter :: Char -> Bool +isWordDelimiter = (== ' ') + +isSpace :: Char -> Bool +isSpace = (== ' ') diff --git a/src/Monomer/Graphics/Types.hs b/src/Monomer/Graphics/Types.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/Types.hs @@ -0,0 +1,364 @@ +{-| +Module : Monomer.Graphics.Types +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Basic types for Graphics. + +Angles are always expressed in degrees, not radians. +-} +{-# LANGUAGE DeriveGeneric #-} + +module Monomer.Graphics.Types where + +import Data.ByteString (ByteString) +import Data.Default +import Data.String (IsString(..)) +import Data.Text (Text) +import Data.Sequence (Seq) +import GHC.Generics + +import qualified Data.ByteString as BS +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Common + +-- | Direction in which triangles and arcs are drawn. +data Winding + = CW + | CCW + deriving (Eq, Show, Generic) + +-- | An RGBA color. +data Color = Color { + _colorR :: {-# UNPACK #-} !Int, + _colorG :: {-# UNPACK #-} !Int, + _colorB :: {-# UNPACK #-} !Int, + _colorA :: {-# UNPACK #-} !Double +} deriving (Eq, Show, Generic) + +instance Default Color where + def = Color 255 255 255 1.0 + +-- | The definition of a font. +data FontDef = FontDef { + _fntName :: !Text, -- ^ The logic name. Will be used when defining styles. + _fntPath :: !Text -- ^ The path in the filesystem. +} deriving (Eq, Show, Generic) + +-- | The name of a loaded font. +newtype Font + = Font { unFont :: Text } + deriving (Eq, Show, Generic) + +instance IsString Font where + fromString s = Font (T.pack s) + +instance Default Font where + def = Font "Regular" + +-- | The size of a font. +newtype FontSize + = FontSize { unFontSize :: Double } + deriving (Eq, Show, Generic) + +instance Default FontSize where + def = FontSize 32 + +-- | The spacing of a font. Zero represents the default spacing of the font. +newtype FontSpace + = FontSpace { unFontSpace :: Double } + deriving (Eq, Show, Generic) + +instance Default FontSpace where + def = FontSpace 0 + +-- | Represents the sides of a rectangle. +data RectSide + = SideLeft + | SideRight + | SideTop + | SideBottom + deriving (Eq, Show) + +-- | Represents the corners of a rectangle. +data RectCorner + = CornerTL + | CornerTR + | CornerBR + | CornerBL + deriving (Eq, Show) + +-- | Horizontal alignment flags. +data AlignH + = ALeft + | ACenter + | ARight + deriving (Eq, Show, Generic) + +instance Default AlignH where + def = ACenter + +-- | Vertical alignment flags. +data AlignV + = ATop + | AMiddle + | ABottom + deriving (Eq, Show, Generic) + +instance Default AlignV where + def = AMiddle + +-- | Text horizontal alignment flags. +data AlignTH + = ATLeft + | ATCenter + | ATRight + deriving (Eq, Show, Generic) + +instance Default AlignTH where + def = ATCenter + +-- | Text vertical alignment flags. +data AlignTV + = ATTop + | ATMiddle + | ATAscender + | ATLowerX + | ATBottom + | ATBaseline + deriving (Eq, Show, Generic) + +instance Default AlignTV where + def = ATLowerX + +-- | Information of a text glyph instance. +data GlyphPos = GlyphPos { + _glpGlyph :: {-# UNPACK #-} !Char, -- ^ The represented character. + _glpXMin :: {-# UNPACK #-} !Double, -- ^ The min x coordinate. + _glpXMax :: {-# UNPACK #-} !Double, -- ^ The max x coordinate. + _glpYMin :: {-# UNPACK #-} !Double, -- ^ The min x coordinate. + _glpYMax :: {-# UNPACK #-} !Double, -- ^ The max x coordinate. + _glpW :: {-# UNPACK #-} !Double, -- ^ The glyph width. + _glpH :: {-# UNPACK #-} !Double -- ^ The glyph height. +} deriving (Eq, Show, Generic) + +instance Default GlyphPos where + def = GlyphPos { + _glpGlyph = ' ', + _glpXMin = 0, + _glpXMax = 0, + _glpYMin = 0, + _glpYMax = 0, + _glpW = 0, + _glpH = 0 + } + +-- | Text flags for single or multiline. +data TextMode + = SingleLine + | MultiLine + deriving (Eq, Show, Generic) + +-- | Text flags for trimming or keeping sapces. +data TextTrim + = TrimSpaces + | KeepSpaces + deriving (Eq, Show, Generic) + +-- | Text flags for clipping or using ellipsis. +data TextOverflow + = Ellipsis + | ClipText + deriving (Eq, Show) + +-- | Text metrics. +data TextMetrics = TextMetrics { + _txmAsc :: {-# UNPACK #-} !Double, -- ^ The height above the baseline. + _txmDesc :: {-# UNPACK #-} !Double, -- ^ The height below the baseline. + _txmLineH :: {-# UNPACK #-} !Double, -- ^ The total height. + _txmLowerX :: {-# UNPACK #-} !Double -- ^ The height of lowercase x. +} deriving (Eq, Show, Generic) + +instance Default TextMetrics where + def = TextMetrics { + _txmAsc = 0, + _txmDesc = 0, + _txmLineH = 0, + _txmLowerX = 0 + } + +-- | A text line with associated rendering information. +data TextLine = TextLine { + _tlFont :: !Font, -- ^ The font name. + _tlFontSize :: !FontSize, -- ^ The font size. + _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. + _tlRect :: !Rect, -- ^ The rect the formatted text occupies. + _tlGlyphs :: !(Seq GlyphPos) -- ^ The glyphs for each character. +} deriving (Eq, Show, Generic) + +instance Default TextLine where + def = TextLine { + _tlFont = def, + _tlFontSize = def, + _tlFontSpaceH = def, + _tlFontSpaceV = def, + _tlMetrics = def, + _tlText = "", + _tlSize = def, + _tlRect = def, + _tlGlyphs = Seq.empty + } + +-- | Flags for a newly created image. +data ImageFlag + = ImageNearest + | ImageRepeatX + | ImageRepeatY + deriving (Eq, Show, Generic) + +-- | The definition of a loaded image. +data ImageDef = ImageDef { + _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. +data FontManager = FontManager { + -- | Returns the text metrics of a given font and size. + computeTextMetrics :: Font -> FontSize -> TextMetrics, + -- | Returns the size of the line of text given font and size. + computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size, + -- | Returns the glyphs of the line of text given font and size. + computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos +} + +-- | Low level rendering definitions. +data Renderer = Renderer { + -- | Begins a new frame. + beginFrame :: Double -> Double -> IO (), + -- | Finishes a frame, consolidating the drawing operations since beginFrame. + endFrame :: IO (), + -- | Begins a new path + beginPath :: IO (), + -- | Finishes an active path by closing it with a line. + closePath :: IO (), + -- | Saves current context (scissor, offset, scale, rotation, etc). + saveContext :: IO (), + -- | Restores a previously saved context. + restoreContext :: IO (), + -- | Creates an overlay. These are rendered after the regular frame has been + -- | displayed. Useful, for instance, for a dropdown or context menu. + createOverlay :: IO () -> IO (), + -- | Renders the added overlays and clears them. + renderOverlays :: IO (), + {-| + Creates a render task which does not rely on the abstractions provided by the + Renderer. Well suited for pure OpenGL/Vulkan/Metal. + + This runs _before_ overlays of any type, and it's useful for the content of + widgets created with low level APIs. + -} + createRawTask :: IO () -> IO (), + -- | Renders the added raw tasks and clears its queue. + renderRawTasks :: IO (), + {-| + Creates an overlay which does not rely on the abstractions provided by the + Renderer. Well suited for pure OpenGL/Vulkan/Metal. + + This runs _after_ overlays based on Renderer. + -} + createRawOverlay :: IO () -> IO (), + -- | Renders the added raw overlays and clears its queue. + renderRawOverlays :: IO (), + -- | Sets, or intersects, a scissor which will limit the visible area. + intersectScissor :: Rect -> IO (), + -- | Translates all further drawing operations by the given offset. + setTranslation :: Point -> IO (), + -- | Scales all further drawing operations by the given size. + setScale :: Point -> IO (), + -- | Rotates all further drawing operations by the given angle. + setRotation :: Double -> IO (), + -- | Applies the given alpha to all further drawing operations. + setGlobalAlpha :: Double -> IO (), + {-| + Sets the winding of the shape to be drawn. Setting CCW (counter clockwise) + means the shape will be solid. Setting CW (clockwise) means the shape will be + a hole inside a larger solid path. + -} + setPathWinding :: Winding -> IO (), + -- | Draws an active path as a non filled stroke. + stroke :: IO (), + -- | Sets the width of the next stroke actions. + setStrokeWidth :: Double -> IO (), + -- | Sets the color of the next stroke actions. + setStrokeColor :: Color -> IO (), + -- | Sets a linear gradient stroke from Point to Point, Color to Color. + setStrokeLinearGradient :: Point -> Point -> Color -> Color -> IO (), + {-| + Sets a radial gradient stroke with center point Point, inner and outer radius, + inner and outer Color. + -} + setStrokeRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO (), + {-| + Sets an image pattern stroke, with top given by Point, size of a single image + given by size, rotation and alpha. + -} + setStrokeImagePattern :: Text -> Point -> Size -> Double -> Double -> IO (), + -- | Draws an active path as a filled object. + fill :: IO (), + -- | Sets the color of the next fill actions. + setFillColor :: Color -> IO (), + -- | Sets a linear gradient fill from Point to Point, Color to Color. + setFillLinearGradient :: Point -> Point -> Color -> Color -> IO (), + {-| + Sets a radial gradient fill with center point Point, inner and outer radius, + inner and outer Color. + -} + setFillRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO (), + {-| + Sets an image pattern fill, with top given by Point, size of a single image + given by size, rotation and alpha. + -} + setFillImagePattern :: Text -> Point -> Size -> Double -> Double -> IO (), + -- | Moves the head to the given point. Useful for starting a set of lines. + moveTo :: Point -> IO (), + -- | Renders a line between to points. + renderLine :: Point -> Point -> IO (), + -- | Renders a line from head to a given point. + renderLineTo :: Point -> IO (), + -- | Renders a rectangle. + renderRect :: Rect -> IO (), + -- | Renders a rectangle with rounded corners. + renderRoundedRect :: Rect -> Double -> Double -> Double -> Double -> IO (), + -- | Renders an arc (center, radius, angle start, angle, end, winding). + renderArc :: Point -> Double -> Double -> Double -> Winding -> IO (), + -- | Quadratic bezier segment from head via control point to target. + renderQuadTo :: Point -> Point -> IO (), + -- | Renders an ellipse. + renderEllipse :: Rect -> IO (), + {-| + Renders the given text line at a specific point, with the provided font, size + and horizontal spacing. + -} + renderText :: Point -> Font -> FontSize -> FontSpace -> Text -> IO (), + -- | Returns the image definition of a loaded image, if any. + getImage :: Text -> IO (Maybe ImageDef), + -- | Adds an image, providing name, size, image data and flags. + addImage :: Text -> Size -> ByteString -> [ImageFlag] -> IO (), + -- | Updates an image, providing name, size and image data (must match + -- | previous size). + updateImage :: Text -> Size -> ByteString -> IO (), + -- | Removes an existing image. + deleteImage :: Text -> IO () +} diff --git a/src/Monomer/Graphics/Util.hs b/src/Monomer/Graphics/Util.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Graphics/Util.hs @@ -0,0 +1,148 @@ +{-| +Module : Monomer.Graphics.Util +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for graphics related operations. +-} +module Monomer.Graphics.Util ( + clampChannel, + clampAlpha, + rgb, + rgba, + rgbHex, + rgbaHex, + hsl, + hsla, + transparent, + alignInRect, + alignHInRect, + alignVInRect +) where + +import Data.Char (digitToInt) + +import Monomer.Common.BasicTypes +import Monomer.Graphics.Types +import Monomer.Helper + +-- | Restricts a color channel to its valid range. +clampChannel :: Int -> Int +clampChannel channel = clamp 0 255 channel + +-- | Restricts an alpha channel to its valid range. +clampAlpha :: Double -> Double +clampAlpha alpha = clamp 0 1 alpha + +{-| +Creates a Color from red, green and blue components. Valid range for each +component is [0, 255]. +-} +rgb :: Int -> Int -> Int -> Color +rgb r g b = Color (clampChannel r) (clampChannel g) (clampChannel b) 1.0 + +{-| +Creates a Color from red, green and blue components plus alpha channel. Valid +range for each component is [0, 255], while alpha is [0, 1]. +-} +rgba :: Int -> Int -> Int -> Double -> Color +rgba r g b a = Color { + _colorR = clampChannel r, + _colorG = clampChannel g, + _colorB = clampChannel b, + _colorA = clampAlpha a +} + +-- | Creates a Color from a hex string. It may include a # prefix or not. +rgbHex :: String -> Color +rgbHex hex + | length hex == 7 = rgbHex (tail hex) + | length hex == 6 = rgb r g b + | otherwise = rgb 0 0 0 + where + [r1, r2, g1, g2, b1, b2] = hex + r = digitToInt r1 * 16 + digitToInt r2 + g = digitToInt g1 * 16 + digitToInt g2 + b = digitToInt b1 * 16 + digitToInt b2 + +{-| +Creates a Color from a hex string plus an alpha component. It may include a # +prefix or not. +-} +rgbaHex :: String -> Double -> Color +rgbaHex hex alpha = (rgbHex hex) { + _colorA = clampAlpha alpha + } + +{-| +Creates a Color instance from HSL components. The valid ranges are: + +- Hue: [0, 360] +- Saturation: [0, 100] +- Lightness: [0, 100] + +Alpha is set to 1.0. +-} +hsl :: Int -> Int -> Int -> Color +hsl h s l = Color r g b 1.0 where + vh = clamp 0 360 (fromIntegral h) + vs = clamp 0 100 (fromIntegral s / 100) + vl = clamp 0 100 (fromIntegral l / 100) + a = vs * min vl (1 - vl) + f n = vl - a * max mink (-1) where + k = fromIntegral $ round (n + vh / 30) `mod` 12 + mink = minimum [k - 3, 9 - k, 1] + i n = clampChannel . round $ 255 * f n + (r, g, b) = (i 0, i 8, i 4) + +{-| +Creates a Color instance from HSL components. The valid ranges are: + +- Hue: [0, 360] +- Saturation: [0, 100] +- Lightness: [0, 100] +- Alpha: [0, 1] +-} +hsla :: Int -> Int -> Int -> Double -> Color +hsla h s l a = (hsl h s l) { + _colorA = clampAlpha a + } + +-- | Creates a non visible color. +transparent :: Color +transparent = rgba 0 0 0 0 + +{-| +Aligns the child rect inside the parent given the alignment constraints. + +Note: The child rect can overflow the parent. +-} +alignInRect :: Rect -> Rect -> AlignH -> AlignV -> Rect +alignInRect parent child ah av = newRect where + tempRect = alignVInRect parent child av + newRect = alignHInRect parent tempRect ah + +-- | Aligns the child rect horizontally inside the parent. +alignHInRect :: Rect -> Rect -> AlignH -> Rect +alignHInRect parent child ah = newRect where + Rect px _ pw _ = parent + Rect _ cy cw ch = child + newX = case ah of + ALeft -> px + ACenter -> px + (pw - cw) / 2 + ARight -> px + pw - cw + newRect = Rect newX cy cw ch + +-- | Aligns the child rect vertically inside the parent. +alignVInRect :: Rect -> Rect -> AlignV -> Rect +alignVInRect parent child av = newRect where + Rect _ py _ ph = parent + Rect cx _ cw ch = child + newY = case av of + ATop -> py + AMiddle -> py + (ph - ch) / 2 + ABottom -> py + ph - ch + newRect = Rect cx newY cw ch diff --git a/src/Monomer/Helper.hs b/src/Monomer/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Helper.hs @@ -0,0 +1,50 @@ +{-| +Module : Monomer.Helper +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions used across the library. Do not belong to any specifig module +and are not directly exported. +-} +module Monomer.Helper where + +import Data.Sequence (Seq(..)) + +import qualified Data.Sequence as Seq + +-- | Concats a list of Monoids or returns Nothing if empty. +maybeConcat :: Monoid a => [a] -> Maybe a +maybeConcat [] = Nothing +maybeConcat lst = Just (mconcat lst) + +-- | Returns the last item in a sequence. Unsafe, fails if sequence is empty. +seqLast :: Seq a -> a +seqLast seq + | not (null seq) = Seq.index seq (length seq - 1) + | otherwise = error "Invalid sequence provided to seqLast" + +-- | Checks if the first sequence is a prefix of the second. +seqStartsWith :: Eq a => Seq a -> Seq a -> Bool +seqStartsWith prefix seq = Seq.take (length prefix) seq == prefix + +-- | Filters Nothing instances out of a Seq, and removes the Just wrapper. +seqCatMaybes :: Seq (Maybe a) -> Seq a +seqCatMaybes Empty = Empty +seqCatMaybes (x :<| xs) = case x of + Just val -> val :<| seqCatMaybes xs + _ -> seqCatMaybes xs + +-- | Returns the maximum value of a given floating type. +maxNumericValue :: (RealFloat a) => a +maxNumericValue = x where + n = floatDigits x + b = floatRadix x + (_, u) = floatRange x + x = encodeFloat (b^n - 1) (u - n) + +-- | Restricts a value to a given range. +clamp :: (Ord a) => a -> a -> a -> a +clamp mn mx = max mn . min mx diff --git a/src/Monomer/Lens.hs b/src/Monomer/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Lens.hs @@ -0,0 +1,26 @@ +{-| +Module : Monomer.Lens +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Module grouping all the diferent lens modules. Useful import to avoid duplicate +instance errors. +-} +module Monomer.Lens ( + module Monomer.Common.Lens, + module Monomer.Core.Lens, + module Monomer.Event.Lens, + module Monomer.Graphics.Lens, + module Monomer.Main.Lens, + module Monomer.Widgets.Util.Lens +) where + +import Monomer.Common.Lens +import Monomer.Core.Lens +import Monomer.Event.Lens +import Monomer.Graphics.Lens +import Monomer.Main.Lens +import Monomer.Widgets.Util.Lens diff --git a/src/Monomer/Main.hs b/src/Monomer/Main.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main.hs @@ -0,0 +1,19 @@ +{-| +Module : Monomer.Main +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Main module, including types and functions for application initialization. +-} +module Monomer.Main ( + module Monomer.Main.Core, + module Monomer.Main.UserUtil, + module Monomer.Main.Types +) where + +import Monomer.Main.Core +import Monomer.Main.UserUtil +import Monomer.Main.Types diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/Core.hs @@ -0,0 +1,484 @@ +{-| +Module : Monomer.Main.Core +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Core glue for running an application. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +module Monomer.Main.Core ( + AppEventResponse(..), + AppEventHandler(..), + AppUIBuilder(..), + startApp +) where + +import Control.Concurrent (MVar, forkIO, forkOS, newMVar, threadDelay) +import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan) +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) +import Data.Default +import Data.Maybe +import Data.Map (Map) +import Data.List (foldl') +import Data.Text (Text) + +import qualified Data.Map as Map +import qualified Graphics.Rendering.OpenGL as GL +import qualified SDL +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Main.Handlers +import Monomer.Main.Platform +import Monomer.Main.Types +import Monomer.Main.Util +import Monomer.Main.WidgetTask +import Monomer.Graphics +import Monomer.Widgets.Composite + +import qualified Monomer.Lens as L + +{-| +Type of response an App event handler can return, with __s__ being the model and +__e__ the user's event type. +-} +type AppEventResponse s e = EventResponse s e s () + +-- | Type of an App event handler. +type AppEventHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The root node of the application. + -> s -- ^ The application's model. + -> e -- ^ The event to handle. + -> [AppEventResponse s e] -- ^ The list of requested actions. + +-- | Type of the function responsible of creating the App UI. +type AppUIBuilder s e = UIBuilder s e + +data MainLoopArgs sp e ep = MainLoopArgs { + _mlOS :: Text, + _mlTheme :: Theme, + _mlAppStartTs :: Int, + _mlMaxFps :: Int, + _mlLatestRenderTs :: Int, + _mlFrameStartTs :: Int, + _mlFrameAccumTs :: Int, + _mlFrameCount :: Int, + _mlExitEvents :: [e], + _mlWidgetRoot :: WidgetNode sp ep, + _mlWidgetShared :: MVar (Map Text WidgetShared), + _mlChannel :: TChan (RenderMsg sp ep) +} + +data RenderState s e = RenderState { + _rstDpr :: Double, + _rstWidgetEnv :: WidgetEnv s e, + _rstRootNode :: WidgetNode s e +} + +{-| +Runs an application, creating the UI with the provided function and initial +model, handling future events with the event handler. + +Control will not be returned until the UI exits. This needs to be ran in the +main thread if using macOS. +-} +startApp + :: (Eq s, WidgetModel s, WidgetEvent e) + => s -- ^ The initial model. + -> AppEventHandler s e -- ^ The event handler. + -> AppUIBuilder s e -- ^ The UI builder. + -> [AppConfig e] -- ^ The application config. + -> IO () -- ^ The application action. +startApp model eventHandler uiBuilder configs = do + (window, dpr, epr, glCtx) <- initSDLWindow config + vpSize <- getViewportSize window dpr + channel <- newTChanIO + + let monomerCtx = initMonomerCtx window channel vpSize dpr epr model + + runStateT (runAppLoop window glCtx channel appWidget config) monomerCtx + detroySDLWindow window + where + config = mconcat configs + compCfgs + = (onInit <$> _apcInitEvent config) + ++ (onDispose <$> _apcDisposeEvent config) + ++ (onResize <$> _apcResizeEvent config) + appWidget = composite_ "app" id uiBuilder eventHandler compCfgs + +runAppLoop + :: (MonomerM sp ep m, Eq sp, WidgetEvent e, WidgetEvent ep) + => SDL.Window + -> SDL.GLContext + -> TChan (RenderMsg sp ep) + -> WidgetNode sp ep + -> AppConfig e + -> m () +runAppLoop window glCtx channel widgetRoot config = do + dpr <- use L.dpr + winSize <- use L.windowSize + + let maxFps = fromMaybe 60 (_apcMaxFps config) + let fonts = _apcFonts config + let theme = fromMaybe def (_apcTheme config) + let exitEvents = _apcExitEvent config + let mainBtn = fromMaybe BtnLeft (_apcMainButton config) + let contextBtn = fromMaybe BtnRight (_apcContextButton config) + + startTs <- fmap fromIntegral SDL.ticks + model <- use L.mainModel + os <- getPlatform + widgetSharedMVar <- liftIO $ newMVar Map.empty + fontManager <- liftIO $ makeFontManager fonts dpr + + let wenv = WidgetEnv { + _weOs = os, + _weFontManager = fontManager, + _weFindByPath = const Nothing, + _weMainButton = mainBtn, + _weContextButton = contextBtn, + _weTheme = theme, + _weWindowSize = winSize, + _weWidgetShared = widgetSharedMVar, + _weWidgetKeyMap = Map.empty, + _weCursor = Nothing, + _weHoveredPath = Nothing, + _weFocusedPath = emptyPath, + _weOverlayPath = Nothing, + _weDragStatus = Nothing, + _weMainBtnPress = Nothing, + _weModel = model, + _weInputStatus = def, + _weTimestamp = startTs, + _weThemeChanged = False, + _weInTopLayer = const True, + _weLayoutDirection = LayoutNone, + _weViewport = Rect 0 0 (winSize ^. L.w) (winSize ^. L.h), + _weOffset = def + } + let pathReadyRoot = widgetRoot + & L.info . L.path .~ rootPath + & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) rootPath + + handleResourcesInit + (newWenv, newRoot, _) <- handleWidgetInit wenv pathReadyRoot + + let loopArgs = MainLoopArgs { + _mlOS = os, + _mlTheme = theme, + _mlMaxFps = maxFps, + _mlAppStartTs = 0, + _mlLatestRenderTs = 0, + _mlFrameStartTs = startTs, + _mlFrameAccumTs = 0, + _mlFrameCount = 0, + _mlExitEvents = exitEvents, + _mlWidgetRoot = newRoot, + _mlWidgetShared = widgetSharedMVar, + _mlChannel = channel + } + + L.mainModel .= _weModel newWenv + + liftIO . forkOS . void $ + startRenderThread channel window glCtx fonts dpr newWenv newRoot + + liftIO $ watchWindowResize channel + mainLoop window fontManager config loopArgs + +mainLoop + :: (MonomerM sp ep m, WidgetEvent e) + => SDL.Window + -> FontManager + -> AppConfig e + -> MainLoopArgs sp e ep + -> m () +mainLoop window fontManager config loopArgs = do + let MainLoopArgs{..} = loopArgs + + startTicks <- fmap fromIntegral SDL.ticks + events <- SDL.pollEvents + + windowSize <- use L.windowSize + dpr <- use L.dpr + epr <- use L.epr + currentModel <- use L.mainModel + cursorIcon <- getCurrentCursorIcon + hovered <- getHoveredPath + focused <- getFocusedPath + overlay <- getOverlayPath + dragged <- getDraggedMsgInfo + mainPress <- use L.mainBtnPress + inputStatus <- use L.inputStatus + mousePos <- getCurrentMousePos epr + currWinSize <- getViewportSize window dpr + + let Size rw rh = windowSize + let ts = startTicks - _mlFrameStartTs + let eventsPayload = fmap SDL.eventPayload events + let quit = SDL.QuitEvent `elem` eventsPayload + + let windowResized = currWinSize /= windowSize && isWindowResized eventsPayload + let windowExposed = isWindowExposed eventsPayload + let mouseEntered = isMouseEntered eventsPayload + let baseSystemEvents = convertEvents dpr epr mousePos eventsPayload + +-- when newSecond $ +-- liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount + + when quit $ + L.exitApplication .= True + + when windowExposed $ + L.mainBtnPress .= Nothing + + let newSecond = _mlFrameAccumTs > 1000 + let mainBtn = fromMaybe BtnLeft (_apcMainButton config) + let contextBtn = fromMaybe BtnRight (_apcContextButton config) + let wenv = WidgetEnv { + _weOs = _mlOS, + _weFontManager = fontManager, + _weFindByPath = findWidgetByPath wenv _mlWidgetRoot, + _weMainButton = mainBtn, + _weContextButton = contextBtn, + _weTheme = _mlTheme, + _weWindowSize = windowSize, + _weWidgetShared = _mlWidgetShared, + _weWidgetKeyMap = Map.empty, + _weCursor = cursorIcon, + _weHoveredPath = hovered, + _weFocusedPath = focused, + _weOverlayPath = overlay, + _weDragStatus = dragged, + _weMainBtnPress = mainPress, + _weModel = currentModel, + _weInputStatus = inputStatus, + _weTimestamp = startTicks, + _weThemeChanged = False, + _weInTopLayer = const True, + _weLayoutDirection = LayoutNone, + _weViewport = Rect 0 0 rw rh, + _weOffset = def + } + -- Exit handler + let baseWidgetId = _mlWidgetRoot ^. L.info . L.widgetId + let exitMsgs = SendMessage baseWidgetId <$> _mlExitEvents + let baseReqs + | quit = Seq.fromList exitMsgs + | otherwise = Seq.Empty + let baseStep = (wenv, _mlWidgetRoot, Seq.empty) + + (rqWenv, rqRoot, _) <- handleRequests baseReqs baseStep + (wtWenv, wtRoot, _) <- handleWidgetTasks rqWenv rqRoot + (seWenv, seRoot, _) <- handleSystemEvents wtWenv wtRoot baseSystemEvents + + (newWenv, newRoot, _) <- if windowResized + then do + L.windowSize .= currWinSize + handleResizeWidgets (seWenv, seRoot, Seq.empty) + else return (seWenv, seRoot, Seq.empty) + + endTicks <- fmap fromIntegral SDL.ticks + + -- Rendering + renderCurrentReq <- checkRenderCurrent startTicks _mlLatestRenderTs + + let renderEvent = any isActionEvent eventsPayload + let winRedrawEvt = windowResized || windowExposed + let renderNeeded = winRedrawEvt || renderEvent || renderCurrentReq + + when renderNeeded $ + liftIO . atomically $ writeTChan _mlChannel (MsgRender newWenv newRoot) + + L.renderRequested .= windowResized + + let fps = realToFrac _mlMaxFps + let frameLength = round (1000000 / fps) + let remainingMs = endTicks - startTicks + let tempDelay = abs (frameLength - remainingMs * 1000) + let nextFrameDelay = min frameLength tempDelay + let latestRenderTs = if renderNeeded then startTicks else _mlLatestRenderTs + let newLoopArgs = loopArgs { + _mlAppStartTs = _mlAppStartTs + ts, + _mlLatestRenderTs = latestRenderTs, + _mlFrameStartTs = startTicks, + _mlFrameAccumTs = if newSecond then 0 else _mlFrameAccumTs + ts, + _mlFrameCount = if newSecond then 0 else _mlFrameCount + 1, + _mlWidgetRoot = newRoot + } + + liftIO $ threadDelay nextFrameDelay + + shouldQuit <- use L.exitApplication + + when shouldQuit $ + void $ handleWidgetDispose newWenv newRoot + + unless shouldQuit (mainLoop window fontManager config newLoopArgs) + +startRenderThread + :: (Eq s, WidgetEvent e) + => TChan (RenderMsg s e) + -> SDL.Window + -> SDL.GLContext + -> [FontDef] + -> Double + -> 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 + + waitRenderMsg channel window renderer fontMgr state + where + state = RenderState dpr wenv root + +waitRenderMsg + :: (Eq s, WidgetEvent e) + => TChan (RenderMsg s e) + -> SDL.Window + -> Renderer + -> FontManager + -> RenderState s e + -> IO () +waitRenderMsg channel window renderer fontMgr state = do + msg <- liftIO . atomically $ readTChan channel + newState <- handleRenderMsg window renderer fontMgr state msg + waitRenderMsg channel window renderer fontMgr newState + +handleRenderMsg + :: (Eq s, WidgetEvent e) + => SDL.Window + -> Renderer + -> FontManager + -> RenderState s e + -> RenderMsg s e + -> IO (RenderState s e) +handleRenderMsg window renderer fontMgr state (MsgRender tmpWenv newRoot) = do + let RenderState dpr _ _ = state + let newWenv = tmpWenv + & L.fontManager .~ fontMgr + let color = newWenv ^. L.theme . L.clearColor + renderWidgets window dpr renderer color newWenv newRoot + return (RenderState dpr newWenv newRoot) +handleRenderMsg window renderer fontMgr state (MsgResize _) = do + newSize <- getViewportSize window (_rstDpr state) + + let RenderState dpr wenv root = state + let viewport = Rect 0 0 (newSize ^. L.w) (newSize ^. L.h) + let newWenv = wenv + & L.fontManager .~ fontMgr + & L.windowSize .~ newSize + & L.viewport .~ viewport + let color = newWenv ^. L.theme . L.clearColor + let resizeCheck = const False + let result = widgetResize (root ^. L.widget) newWenv root viewport resizeCheck + let newRoot = result ^. L.node + + renderWidgets window dpr renderer color newWenv newRoot + return state +handleRenderMsg window renderer fontMgr state (MsgRemoveImage name) = do + deleteImage renderer name + return state + +renderWidgets + :: SDL.Window + -> Double + -> Renderer + -> Color + -> WidgetEnv s e + -> WidgetNode s e + -> IO () +renderWidgets !window dpr renderer clearColor wenv widgetRoot = do + Size dwW dwH <- getDrawableSize window + Size vpW vpH <- getViewportSize window dpr + + let position = GL.Position 0 0 + let size = GL.Size (round dwW) (round dwH) + + liftIO $ GL.viewport GL.$= (position, size) + + liftIO $ GL.clearColor GL.$= clearColor4 + liftIO $ GL.clear [GL.ColorBuffer] + + liftIO $ beginFrame renderer vpW vpH + liftIO $ widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer + liftIO $ endFrame renderer + + liftIO $ renderRawTasks renderer + + liftIO $ beginFrame renderer vpW vpH + liftIO $ renderOverlays renderer + liftIO $ endFrame renderer + + liftIO $ renderRawOverlays renderer + + SDL.glSwapWindow window + where + 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) + +watchWindowResize :: TChan (RenderMsg s e) -> IO () +watchWindowResize channel = do + void . SDL.addEventWatch $ \ev -> do + case SDL.eventPayload ev of + SDL.WindowSizeChangedEvent sizeChangeData -> do + let SDL.V2 nw nh = SDL.windowSizeChangedEventSize sizeChangeData + let newSize = Size (fromIntegral nw) (fromIntegral nh) + + atomically $ writeTChan channel (MsgResize newSize) + _ -> return () + +checkRenderCurrent :: (MonomerM s e m) => Int -> Int -> m Bool +checkRenderCurrent currTs renderTs = do + renderCurrent <- use L.renderRequested + schedule <- use L.renderSchedule + L.renderSchedule .= Map.filter (renderScheduleActive currTs) schedule + return (renderCurrent || renderNext schedule) + where + requiresRender = renderScheduleReq currTs renderTs + renderNext schedule = any requiresRender schedule + +renderScheduleReq :: Int -> Int -> 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 currTs schedule = scheduleActive where + RenderSchedule _ start ms count = schedule + stepCount = floor (fromIntegral (currTs - start) / fromIntegral ms) + scheduleActive = maybe True (> stepCount) count + +isWindowResized :: [SDL.EventPayload] -> Bool +isWindowResized eventsPayload = not status where + status = null [ e | e@SDL.WindowResizedEvent {} <- eventsPayload ] + +isWindowExposed :: [SDL.EventPayload] -> Bool +isWindowExposed eventsPayload = not status where + status = null [ e | e@SDL.WindowExposedEvent {} <- eventsPayload ] + +isMouseEntered :: [SDL.EventPayload] -> Bool +isMouseEntered eventsPayload = not status where + status = null [ e | e@SDL.WindowGainedMouseFocusEvent {} <- eventsPayload ] diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/Handlers.hs @@ -0,0 +1,906 @@ +{-| +Module : Monomer.Main.Handlers +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Handlers for WidgetRequests. Functions in this module handle focus, clipboard, +overlays and all SystemEvent related operations and updates. +-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +module Monomer.Main.Handlers ( + HandlerStep, + handleSystemEvents, + handleResourcesInit, + handleWidgetInit, + handleWidgetDispose, + handleWidgetResult, + handleRequests, + handleResizeWidgets +) where + +import Control.Concurrent.Async (async) +import Control.Lens + ((&), (^.), (^?), (.~), (?~), (%~), (.=), (?=), (%=), (%%~), _Just, _1, _2, ix, at, use) +import Control.Monad.STM (atomically) +import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan) +import Control.Applicative ((<|>)) +import Control.Monad +import Control.Monad.IO.Class +import Data.Default +import Data.Foldable (fold, toList) +import Data.Maybe +import Data.Sequence (Seq(..), (|>)) +import Data.Text (Text) +import Data.Typeable (Typeable, typeOf) +import Safe (headMay) +import SDL (($=)) + +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified SDL +import qualified SDL.Raw.Enum as SDLEnum +import qualified SDL.Raw.Event as SDLE +import qualified SDL.Raw.Types as SDLT + +import Monomer.Core +import Monomer.Event +import Monomer.Helper (seqStartsWith) +import Monomer.Main.Types +import Monomer.Main.Util + +import qualified Monomer.Lens as L + +{-| +Tuple representing the current widget environment, widget root and accumulated +WidgetRequests. These requests have already been processed, they are collected +for unit testing purposes. +-} +type HandlerStep s e = (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e)) + +{-| +Processes a list of SystemEvents dispatching each of the to the corresponding +widget based on the current root. At each step the root may change, new events +may be generated (which will be processed interleaved with the list of events) +and this is handled before returning the latest "HandlerStep". +-} +handleSystemEvents + :: MonomerM s e m + => WidgetEnv s e -- ^ The initial widget environment. + -> WidgetNode s e -- ^ The initial widget root. + -> [SystemEvent] -- ^ The starting list of events. + -> m (HandlerStep s e) -- ^ The resulting "HandlerStep." +handleSystemEvents wenv widgetRoot baseEvents = nextStep where + mainBtn = wenv ^. L.mainButton + reduceEvt curStep evt = do + let (curWenv, curRoot, curReqs) = curStep + systemEvents <- addRelatedEvents curWenv mainBtn curRoot evt + + foldM reduceSysEvt (curWenv, curRoot, curReqs) systemEvents + reduceSysEvt curStep (evt, evtTarget) = do + focused <- getFocusedPath + let (curWenv, curRoot, curReqs) = curStep + let target = fromMaybe focused evtTarget + let curWidget = curRoot ^. L.widget + let targetWni = evtTarget >>= findWidgetByPath curWenv curRoot + let targetWid = (^. L.widgetId) <$> targetWni + + when (isOnEnter evt) $ + L.hoveredWidgetId .= targetWid + + when (isOnMove evt) + restoreCursorOnWindowEnter + + cursorIcon <- getCurrentCursorIcon + hoveredPath <- getHoveredPath + mainBtnPress <- use L.mainBtnPress + inputStatus <- use L.inputStatus + + let tmpWenv = curWenv + & L.cursor .~ cursorIcon + & L.hoveredPath .~ hoveredPath + & L.mainBtnPress .~ mainBtnPress + & L.inputStatus .~ inputStatus + let findByPath path = findWidgetByPath tmpWenv curRoot path + let newWenv = tmpWenv + & L.findByPath .~ findByPath + (wenv2, root2, reqs2) <- handleSystemEvent newWenv curRoot evt target + + when (isOnLeave evt) $ do + resetCursorOnNodeLeave evt curStep + L.hoveredWidgetId .= Nothing + + return (wenv2, root2, curReqs <> reqs2) + newEvents = preProcessEvents baseEvents + nextStep = foldM reduceEvt (wenv, widgetRoot, Seq.empty) newEvents + +-- | Processes a single SystemEvent. +handleSystemEvent + :: MonomerM s e m + => WidgetEnv s e + -> WidgetNode s e + -> SystemEvent + -> Path + -> m (HandlerStep s e) +handleSystemEvent wenv widgetRoot event currentTarget = do + mainStart <- use L.mainBtnPress + overlay <- getOverlayPath + leaveEnterPair <- use L.leaveEnterPair + let pressed = fmap fst mainStart + + case getTargetPath wenv widgetRoot pressed overlay currentTarget event of + Nothing -> return (wenv, widgetRoot, Seq.empty) + Just target -> do + let widget = widgetRoot ^. L.widget + let emptyResult = WidgetResult widgetRoot Seq.empty + let evtResult = widgetHandleEvent widget wenv widgetRoot target event + let resizeWidgets = not (leaveEnterPair && isOnLeave event) + let widgetResult = fromMaybe emptyResult evtResult + & L.requests %~ addFocusReq event + + step <- handleWidgetResult wenv resizeWidgets widgetResult + + if isOnDrop event + then handleFinalizeDrop step + else return step + +-- | Initializes system resources (currently only icons). +handleResourcesInit :: MonomerM s e m => m () +handleResourcesInit = do + cursors <- foldM insert Map.empty [toEnum 0 ..] + L.cursorIcons .= cursors + where + insert map icon = do + cursor <- SDLE.createSystemCursor (cursorToSDL icon) + return $ Map.insert icon cursor map + +-- | Initializes a widget (in general, this is called for root). +handleWidgetInit + :: MonomerM s e m + => WidgetEnv s e + -> WidgetNode s e + -> m (HandlerStep s e) +handleWidgetInit wenv widgetRoot = do + let widget = widgetRoot ^. L.widget + let widgetResult = widgetInit widget wenv widgetRoot + let reqs = widgetResult ^. L.requests + let focusReqExists = isJust $ Seq.findIndexL isFocusRequest reqs + + L.resizeRequests .= Seq.singleton def + + step <- handleWidgetResult wenv True widgetResult + currFocus <- getFocusedPath + + if not focusReqExists && currFocus == emptyPath + then handleMoveFocus Nothing FocusFwd step + else return step + +-- | Disposes a widget (in general, this is called for root). +handleWidgetDispose + :: MonomerM s e m + => WidgetEnv s e + -> WidgetNode s e + -> m (HandlerStep s e) +handleWidgetDispose wenv widgetRoot = do + let widget = widgetRoot ^. L.widget + let widgetResult = widgetDispose widget wenv widgetRoot + + handleWidgetResult wenv False widgetResult + +{-| +Handles a WidgetResult instance, processing events and requests, and returning +an updated "HandlerStep". +-} +handleWidgetResult + :: MonomerM s e m + => WidgetEnv s e + -> Bool + -> WidgetResult s e + -> m (HandlerStep s e) +handleWidgetResult wenv resizeWidgets result = do + let WidgetResult evtRoot reqs = result + + step <- handleRequests reqs (wenv, evtRoot, reqs) + resizeRequests <- use L.resizeRequests + + if resizeWidgets && not (null resizeRequests) + then handleResizeWidgets step + else return step + +-- | Processes a Seq of WidgetRequest, returning the latest "HandlerStep". +handleRequests + :: MonomerM s e m + => Seq (WidgetRequest s e) -- ^ Requests to process. + -> HandlerStep s e -- ^ Initial state/"HandlerStep". + -> m (HandlerStep s e) -- ^ Updated "HandlerStep", +handleRequests reqs step = foldM handleRequest step reqs where + handleRequest step req = case req of + IgnoreParentEvents -> return step + IgnoreChildrenEvents -> return step + ResizeWidgets wid -> handleAddPendingResize wid step + ResizeWidgetsImmediate wid -> handleResizeImmediate wid step + MoveFocus start dir -> handleMoveFocus start dir step + SetFocus path -> handleSetFocus path step + GetClipboard wid -> handleGetClipboard wid step + SetClipboard cdata -> handleSetClipboard cdata step + StartTextInput rect -> handleStartTextInput rect step + StopTextInput -> handleStopTextInput step + SetOverlay wid path -> handleSetOverlay wid path step + ResetOverlay wid -> handleResetOverlay wid step + SetCursorIcon wid icon -> handleSetCursorIcon wid icon step + ResetCursorIcon wid -> handleResetCursorIcon wid step + StartDrag wid path info -> handleStartDrag wid path info step + StopDrag wid -> handleStopDrag wid step + RenderOnce -> handleRenderOnce step + RenderEvery wid ms repeat -> handleRenderEvery wid ms repeat step + RenderStop wid -> handleRenderStop wid step + RemoveRendererImage path -> handleRemoveRendererImage path step + ExitApplication exit -> handleExitApplication exit step + UpdateWindow req -> handleUpdateWindow req step + UpdateModel fn -> handleUpdateModel fn step + SetWidgetPath wid path -> handleSetWidgetPath wid path step + ResetWidgetPath wid -> handleResetWidgetPath wid step + RaiseEvent msg -> handleRaiseEvent msg step + SendMessage wid msg -> handleSendMessage wid msg step + RunTask wid path handler -> handleRunTask wid path handler step + RunProducer wid path handler -> handleRunProducer wid path handler step + +-- | Resizes the current root, and marks the render and resized flags. +handleResizeWidgets + :: MonomerM s e m + => HandlerStep s e -- ^ Current state/"HandlerStep". + -> m (HandlerStep s e) -- ^ Updated state/"HandlerStep". +handleResizeWidgets previousStep = do + windowSize <- use L.windowSize + resizeCheckFn <- makeResizeChechFn + + let viewport = Rect 0 0 (windowSize ^. L.w) (windowSize ^. L.h) + let (wenv, root, reqs) = previousStep + let newWenv = wenv + & L.windowSize .~ windowSize + & L.viewport .~ viewport + let rootWidget = root ^. L.widget + let newResult = widgetResize rootWidget newWenv root viewport resizeCheckFn + + L.renderRequested .= True + L.resizeRequests .= Seq.empty + + (wenv2, root2, reqs2) <- handleWidgetResult newWenv True newResult + + return (wenv2, root2, reqs <> reqs2) + where + makeResizeChechFn = do + resizeRequests <- use L.resizeRequests + paths <- mapM getWidgetIdPath resizeRequests + let parts = Set.fromDistinctAscList . drop 1 . toList . Seq.inits + let sets = fold (parts <$> paths) + + return (`Set.member` sets) + +handleAddPendingResize + :: MonomerM s e m + => WidgetId + -> HandlerStep s e + -> m (HandlerStep s e) +handleAddPendingResize wid step = do + L.resizeRequests %= (|> wid) + return step + +handleResizeImmediate + :: MonomerM s e m + => WidgetId + -> HandlerStep s e + -> m (HandlerStep s e) +handleResizeImmediate wid step = do + L.resizeRequests %= (|> wid) + handleResizeWidgets step + +handleMoveFocus + :: MonomerM s e m + => Maybe WidgetId + -> FocusDirection + -> HandlerStep s e + -> m (HandlerStep s e) +handleMoveFocus startFromWid dir (wenv, root, reqs) = do + oldFocus <- getFocusedPath + tmpOverlay <- getOverlayPath + let tmpFocusWni = findNextFocus wenv dir oldFocus tmpOverlay root + let tmpFocus = tmpFocusWni ^. L.path + let blurEvt = Blur tmpFocus + let wenv0 = wenv & L.focusedPath .~ tmpFocus + (wenv1, root1, reqs1) <- handleSystemEvent wenv0 root blurEvt oldFocus + currFocus <- getFocusedPath + currOverlay <- getOverlayPath + + if oldFocus == currFocus + then do + startFrom <- mapM getWidgetIdPath startFromWid + let searchFrom = fromMaybe currFocus startFrom + let newFocusWni = findNextFocus wenv1 dir searchFrom currOverlay root1 + let newFocus = newFocusWni ^. L.path + let wenvF = wenv1 & L.focusedPath .~ newFocus + let focusEvt = Focus oldFocus + + L.focusedWidgetId .= newFocusWni ^. L.widgetId + L.renderRequested .= True + (wenv2, root2, reqs2) <- handleSystemEvent wenvF root1 focusEvt newFocus + + return (wenv2, root2, reqs <> reqs1 <> reqs2) + else + return (wenv1, root1, reqs <> reqs1) + +handleSetFocus + :: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e) +handleSetFocus newFocusWid (wenv, root, reqs) = do + newFocus <- getWidgetIdPath newFocusWid + oldFocus <- getFocusedPath + + if oldFocus /= newFocus && newFocus /= emptyPath + then do + let wenv0 = wenv & L.focusedPath .~ newFocus + let blurEvt = Blur newFocus + (wenv1, root1, reqs1) <- handleSystemEvent wenv0 root blurEvt oldFocus + let wenvF = wenv1 & L.focusedPath .~ newFocus + let focusEvt = Focus oldFocus + + L.focusedWidgetId .= newFocusWid + L.renderRequested .= True + (wenv2, root2, reqs2) <- handleSystemEvent wenvF root1 focusEvt newFocus + + return (wenv2, root2, reqs <> reqs1 <> reqs2) + else + return (wenv, root, reqs) + +handleGetClipboard + :: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e) +handleGetClipboard widgetId (wenv, root, reqs) = do + path <- getWidgetIdPath widgetId + hasText <- SDL.hasClipboardText + contents <- fmap Clipboard $ if hasText + then fmap ClipboardText SDL.getClipboardText + else return ClipboardEmpty + + (wenv2, root2, reqs2) <- handleSystemEvent wenv root contents path + return (wenv2, root2, reqs <> reqs2) + +handleSetClipboard + :: MonomerM s e m => ClipboardData -> HandlerStep s e -> m (HandlerStep s e) +handleSetClipboard (ClipboardText text) previousStep = do + SDL.setClipboardText text + return previousStep +handleSetClipboard _ previousStep = return previousStep + +handleStartTextInput + :: MonomerM s e m => Rect -> HandlerStep s e -> m (HandlerStep s e) +handleStartTextInput (Rect x y w h) previousStep = do + SDL.startTextInput (SDLT.Rect (c x) (c y) (c w) (c h)) + return previousStep + where + c x = fromIntegral $ round x + +handleStopTextInput :: MonomerM s e m => HandlerStep s e -> m (HandlerStep s e) +handleStopTextInput previousStep = do + SDL.stopTextInput + return previousStep + +handleSetOverlay + :: MonomerM s e m + => WidgetId + -> Path + -> HandlerStep s e + -> m (HandlerStep s e) +handleSetOverlay widgetId path previousStep = do + overlay <- use L.overlayWidgetId + + L.overlayWidgetId .= Just widgetId + setWidgetIdPath widgetId path + return $ previousStep + & _1 . L.overlayPath ?~ path + +handleResetOverlay + :: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e) +handleResetOverlay widgetId step = do + let (wenv, root, reqs) = step + let mousePos = wenv ^. L.inputStatus . L.mousePos + + overlay <- use L.overlayWidgetId + + (wenv2, root2, reqs2) <- if overlay == Just widgetId + then do + let newWenv = wenv & L.overlayPath .~ Nothing + L.overlayWidgetId .= Nothing + void $ handleResetCursorIcon widgetId step + handleSystemEvents newWenv root [Move mousePos] + else + return (wenv, root, Empty) + + return (wenv2, root2, reqs <> reqs2) + +handleSetCursorIcon + :: MonomerM s e m + => WidgetId + -> CursorIcon + -> HandlerStep s e + -> m (HandlerStep s e) +handleSetCursorIcon wid icon previousStep = do + cursors <- use L.cursorStack >>= dropNonParentWidgetId wid + L.cursorStack .= (wid, icon) : cursors + cursor <- Map.lookup icon <$> use L.cursorIcons + + when (isNothing cursor) $ + liftIO . putStrLn $ "Invalid handleSetCursorIcon: " ++ show icon + + forM_ cursor SDLE.setCursor + + return previousStep + +handleResetCursorIcon + :: MonomerM s e m + => WidgetId + -> HandlerStep s e + -> m (HandlerStep s e) +handleResetCursorIcon wid previousStep = do + cursors <- use L.cursorStack >>= dropNonParentWidgetId wid + let newCursors = dropWhile ((==wid) . fst) cursors + let newCursorIcon + | null newCursors = CursorArrow + | otherwise = snd . head $ newCursors + L.cursorStack .= newCursors + cursor <- (Map.! newCursorIcon) <$> use L.cursorIcons + SDLE.setCursor cursor + + currentPair <- headMay newCursors & _Just . _1 %%~ getWidgetIdPath + return $ previousStep + & _1 . L.cursor .~ currentPair + +handleStartDrag + :: MonomerM s e m + => WidgetId + -> Path + -> WidgetDragMsg + -> HandlerStep s e + -> m (HandlerStep s e) +handleStartDrag widgetId path dragData previousStep = do + oldDragAction <- use L.dragAction + let prevWidgetId = fmap (^. L.widgetId) oldDragAction + + L.dragAction .= Just (DragAction widgetId dragData) + setWidgetIdPath widgetId path + return $ previousStep + & _1 . L.dragStatus ?~ (path, dragData) + +handleStopDrag + :: MonomerM s e m + => WidgetId + -> HandlerStep s e + -> m (HandlerStep s e) +handleStopDrag widgetId previousStep = do + oldDragAction <- use L.dragAction + let prevWidgetId = fmap (^. L.widgetId) oldDragAction + + if prevWidgetId == Just widgetId + then do + L.renderRequested .= True + L.dragAction .= Nothing + return $ previousStep + & _1 . L.dragStatus .~ Nothing + else return previousStep + +handleFinalizeDrop + :: MonomerM s e m + => HandlerStep s e + -> m (HandlerStep s e) +handleFinalizeDrop previousStep = do + dragAction <- use L.dragAction + let widgetId = fmap (^. L.widgetId) dragAction + + if isJust widgetId + then do + L.renderRequested .= True + L.dragAction .= Nothing + return $ previousStep + & _1 . L.dragStatus .~ Nothing + else return previousStep + +handleRenderOnce :: MonomerM s e m => HandlerStep s e -> m (HandlerStep s e) +handleRenderOnce previousStep = do + L.renderRequested .= True + return previousStep + +handleRenderEvery + :: MonomerM s e m + => WidgetId + -> Int + -> Maybe Int + -> HandlerStep s e + -> m (HandlerStep s e) +handleRenderEvery widgetId ms repeat previousStep = do + schedule <- use L.renderSchedule + L.renderSchedule .= addSchedule schedule + return previousStep + where + (wenv, _, _) = previousStep + newValue = RenderSchedule { + _rsWidgetId = widgetId, + _rsStart = _weTimestamp wenv, + _rsMs = ms, + _rsRepeat = repeat + } + addSchedule schedule + | ms > 0 = Map.insert widgetId newValue schedule + | otherwise = schedule + +handleRenderStop + :: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e) +handleRenderStop widgetId previousStep = do + schedule <- use L.renderSchedule + L.renderSchedule .= Map.delete widgetId schedule + return previousStep + +handleRemoveRendererImage + :: MonomerM s e m => Text -> HandlerStep s e -> m (HandlerStep s e) +handleRemoveRendererImage name previousStep = do + renderChannel <- use L.renderChannel + + liftIO . atomically $ writeTChan renderChannel (MsgRemoveImage name) + return previousStep + +handleExitApplication + :: MonomerM s e m => Bool -> HandlerStep s e -> m (HandlerStep s e) +handleExitApplication exit previousStep = do + L.exitApplication .= exit + return previousStep + +handleUpdateWindow + :: MonomerM s e m => WindowRequest -> HandlerStep s e -> m (HandlerStep s e) +handleUpdateWindow windowRequest previousStep = do + window <- use L.window + case windowRequest of + WindowSetTitle title -> SDL.windowTitle window $= title + WindowSetFullScreen -> SDL.setWindowMode window SDL.FullscreenDesktop + WindowMaximize -> SDL.setWindowMode window SDL.Maximized + WindowMinimize -> SDL.setWindowMode window SDL.Minimized + WindowRestore -> SDL.setWindowMode window SDL.Windowed + WindowBringToFront -> SDL.raiseWindow window + return previousStep + +handleUpdateModel + :: MonomerM s e m => (s -> s) -> HandlerStep s e -> m (HandlerStep s e) +handleUpdateModel fn (wenv, root, reqs) = do + L.mainModel .= _weModel wenv2 + return (wenv2, root, reqs) + where + wenv2 = wenv & L.model %~ fn + +handleSetWidgetPath + :: MonomerM s e m => WidgetId -> Path -> HandlerStep s e -> m (HandlerStep s e) +handleSetWidgetPath wid path step = do + setWidgetIdPath wid path + return step + +handleResetWidgetPath + :: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e) +handleResetWidgetPath wid step = do + delWidgetIdPath wid + return step + +handleRaiseEvent + :: forall s e m msg . (MonomerM s e m, Typeable msg) + => msg + -> HandlerStep s e + -> m (HandlerStep s e) +handleRaiseEvent message step = do + --liftIO . putStrLn $ message ++ show (typeOf message) + return step + where + message = "Invalid state. RaiseEvent reached main handler. Type: " + +handleSendMessage + :: forall s e m msg . (MonomerM s e m, Typeable msg) + => WidgetId + -> msg + -> HandlerStep s e + -> m (HandlerStep s e) +handleSendMessage widgetId message (wenv, root, reqs) = do + path <- getWidgetIdPath widgetId + + let emptyResult = WidgetResult root Seq.empty + let widget = root ^. L.widget + let msgResult = widgetHandleMessage widget wenv root path message + let result = fromMaybe emptyResult msgResult + + (newWenv, newRoot, newReqs) <- handleWidgetResult wenv True result + + return (newWenv, newRoot, reqs <> newReqs) + +handleRunTask + :: forall s e m i . (MonomerM s e m, Typeable i) + => WidgetId + -> Path + -> IO i + -> HandlerStep s e + -> m (HandlerStep s e) +handleRunTask widgetId path handler previousStep = do + asyncTask <- liftIO $ async (liftIO handler) + + previousTasks <- use L.widgetTasks + L.widgetTasks .= previousTasks |> WidgetTask widgetId asyncTask + setWidgetIdPath widgetId path + + return previousStep + +handleRunProducer + :: forall s e m i . (MonomerM s e m, Typeable i) + => WidgetId + -> Path + -> ((i -> IO ()) -> IO ()) + -> HandlerStep s e + -> m (HandlerStep s e) +handleRunProducer widgetId path handler previousStep = do + newChannel <- liftIO newTChanIO + asyncTask <- liftIO $ async (liftIO $ handler (sendMessage newChannel)) + + previousTasks <- use L.widgetTasks + L.widgetTasks .= previousTasks |> WidgetProducer widgetId newChannel asyncTask + setWidgetIdPath widgetId path + + return previousStep + +sendMessage :: TChan e -> e -> IO () +sendMessage channel message = atomically $ writeTChan channel message + +addFocusReq + :: SystemEvent + -> Seq (WidgetRequest s e) + -> Seq (WidgetRequest s e) +addFocusReq (KeyAction mod code KeyPressed) reqs = newReqs where + isTabPressed = isKeyTab code + stopProcessing = isJust $ Seq.findIndexL isIgnoreParentEvents reqs + focusReqExists = isJust $ Seq.findIndexL isFocusRequest reqs + focusReqNeeded = isTabPressed && not stopProcessing && not focusReqExists + direction + | mod ^. L.leftShift = FocusBwd + | otherwise = FocusFwd + newReqs + | focusReqNeeded = reqs |> MoveFocus Nothing direction + | otherwise = reqs +addFocusReq _ reqs = reqs + +preProcessEvents :: [SystemEvent] -> [SystemEvent] +preProcessEvents [] = [] +preProcessEvents (e:es) = case e of + WheelScroll p _ _ -> e : Move p : preProcessEvents es + _ -> e : preProcessEvents es + +addRelatedEvents + :: MonomerM s e m + => WidgetEnv s e + -> Button + -> WidgetNode s e + -> SystemEvent + -> m [(SystemEvent, Maybe Path)] +addRelatedEvents wenv mainBtn widgetRoot evt = case evt of + Move point -> do + (target, hoverEvts) <- addHoverEvents wenv widgetRoot point + -- Update input status + status <- use L.inputStatus + L.inputStatus . L.mousePosPrev .= status ^. L.mousePos + L.inputStatus . L.mousePos .= point + -- Drag event + mainPress <- use L.mainBtnPress + draggedMsg <- getDraggedMsgInfo + let pressed = fmap fst mainPress + let isPressed = target == pressed + let dragEvts = case draggedMsg of + Just (path, msg) -> [(Drag point path msg, target) | not isPressed] + _ -> [] + + when (isJust mainPress || isJust draggedMsg) $ + L.renderRequested .= True + + return $ hoverEvts ++ dragEvts ++ [(evt, Nothing)] + ButtonAction point btn BtnPressed _ -> do + overlay <- getOverlayPath + let start = fromMaybe emptyPath overlay + let widget = widgetRoot ^. L.widget + let wni = widgetFindByPoint widget wenv widgetRoot start point + let curr = fmap (^. L.path) wni + + when (btn == mainBtn) $ + L.mainBtnPress .= fmap (, point) curr + + L.inputStatus . L.buttons . at btn ?= BtnPressed + + SDLE.captureMouse True + + return [(evt, Nothing)] + ButtonAction point btn BtnReleased clicks -> do + -- Hover changes need to be handled here too + mainPress <- use L.mainBtnPress + draggedMsg <- getDraggedMsgInfo + + when (btn == mainBtn) $ + L.mainBtnPress .= Nothing + + (target, hoverEvts) <- addHoverEvents wenv widgetRoot point + + let pressed = fmap fst mainPress + let isPressed = btn == mainBtn && target == pressed + let clickEvt = [(Click point btn clicks, pressed) | isPressed || clicks > 1] + let releasedEvt = [(evt, pressed <|> target)] + let dropEvts = case draggedMsg of + Just (path, msg) -> [(Drop point path msg, target) | not isPressed] + _ -> [] + + L.inputStatus . L.buttons . at btn ?= BtnReleased + + SDLE.captureMouse False + + return $ releasedEvt ++ dropEvts ++ clickEvt ++ hoverEvts + KeyAction mod code status -> do + L.inputStatus . L.keyMod .= mod + L.inputStatus . L.keys . at code ?= status + + return [(evt, Nothing)] + -- These handlers are only here to help with testing functions + -- This will only be reached from `handleSystemEvents` + Click point btn clicks -> findEvtTargetByPoint wenv widgetRoot evt point + _ -> return [(evt, Nothing)] + +addHoverEvents + :: MonomerM s e m + => WidgetEnv s e + -> WidgetNode s e + -> Point + -> m (Maybe Path, [(SystemEvent, Maybe Path)]) +addHoverEvents wenv widgetRoot point = do + overlay <- getOverlayPath + hover <- getHoveredPath + mainBtnPress <- use L.mainBtnPress + + let start = fromMaybe emptyPath overlay + let widget = widgetRoot ^. L.widget + let wni = widgetFindByPoint widget wenv widgetRoot start point + let target = fmap (^. L.path) wni + let hoverChanged = target /= hover && isNothing mainBtnPress + let enter = [(Enter point, target) | isJust target && hoverChanged] + let leave = [(Leave point, hover) | isJust hover && hoverChanged] + + L.leaveEnterPair .= not (null leave || null enter) + + return (target, leave ++ enter) + +findEvtTargetByPoint + :: MonomerM s e m + => WidgetEnv s e + -> WidgetNode s e + -> SystemEvent + -> Point + -> m [(SystemEvent, Maybe Path)] +findEvtTargetByPoint wenv widgetRoot evt point = do + overlay <- getOverlayPath + let start = fromMaybe emptyPath overlay + let widget = widgetRoot ^. L.widget + let wni = widgetFindByPoint widget wenv widgetRoot start point + let curr = fmap (^. L.path) wni + return [(evt, curr)] + +findNextFocus + :: WidgetEnv s e + -> FocusDirection + -> Path + -> Maybe Path + -> WidgetNode s e + -> WidgetNodeInfo +findNextFocus wenv dir start overlay widgetRoot = fromJust nextFocus where + widget = widgetRoot ^. L.widget + 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) + nextFocus = candidateWni <|> fromRootWni <|> Just focusWni + +dropNonParentWidgetId + :: MonomerM s e m + => WidgetId + -> [(WidgetId, a)] + -> m [(WidgetId, a)] +dropNonParentWidgetId wid [] = return [] +dropNonParentWidgetId wid (x:xs) = do + path <- getWidgetIdPath wid + cpath <- getWidgetIdPath cwid + + if isParentPath cpath path + then return (x:xs) + else dropNonParentWidgetId wid xs + where + (cwid, _) = x + isParentPath parent child = seqStartsWith parent child && parent /= child + +resetCursorOnNodeLeave + :: MonomerM s e m + => SystemEvent + -> HandlerStep s e + -> m () +resetCursorOnNodeLeave (Leave point) step = do + void $ handleResetCursorIcon widgetId step + where + (wenv, root, _) = step + widget = root ^. L.widget + + childNode = widgetFindByPoint widget wenv root emptyPath point + widgetId = case childNode of + Just info -> info ^. L.widgetId + Nothing -> root ^. L.info . L.widgetId +resetCursorOnNodeLeave _ step = return () + +restoreCursorOnWindowEnter :: MonomerM s e m => m () +restoreCursorOnWindowEnter = do + -- Restore old icon if needed + Size ww wh <- use L.windowSize + status <- use L.inputStatus + cursorIcons <- use L.cursorIcons + cursorPair <- headMay <$> use L.cursorStack + + let windowRect = Rect 0 0 ww wh + let prevInside = pointInRect (status ^. L.mousePosPrev) windowRect + let currInside = pointInRect (status ^. L.mousePos) windowRect + let sdlCursor = cursorPair >>= (`Map.lookup` cursorIcons) . snd + + when (isNothing sdlCursor && isJust cursorPair) $ + liftIO. putStrLn $ "Invalid restoreCursorOnWindowEnter: " ++ show cursorPair + + when (not prevInside && currInside && isJust sdlCursor) $ do + SDLE.setCursor (fromJust sdlCursor) + +getTargetPath + :: WidgetEnv s e + -> WidgetNode s e + -> Maybe Path + -> Maybe Path + -> Path + -> SystemEvent + -> Maybe Path +getTargetPath wenv root pressed overlay target event = case event of + -- Keyboard + KeyAction{} -> pathEvent target + TextInput _ -> pathEvent target + -- Clipboard + Clipboard _ -> pathEvent target + -- Mouse/touch + ButtonAction point _ BtnPressed _ -> pointEvent point + ButtonAction _ _ BtnReleased _ -> pathEvent target + Click{} -> pathEvent target + WheelScroll point _ _ -> pointEvent point + Focus{} -> pathEvent target + Blur{} -> pathEvent target + Enter{} -> pathEvent target + Move point -> pointEvent point + Leave{} -> pathEvent target + -- Drag/drop + Drag point _ _ -> pointEvent point + Drop point _ _ -> pointEvent point + where + widget = root ^. L.widget + startPath = fromMaybe emptyPath overlay + pathEvent = Just + pathFromPoint p = fmap (^. L.path) wni where + wni = widgetFindByPoint widget wenv root startPath p + -- pressed is only really used for Move + pointEvent point = pressed <|> pathFromPoint point <|> overlay + +cursorToSDL :: CursorIcon -> SDLEnum.SystemCursor +cursorToSDL CursorArrow = SDLEnum.SDL_SYSTEM_CURSOR_ARROW +cursorToSDL CursorHand = SDLEnum.SDL_SYSTEM_CURSOR_HAND +cursorToSDL CursorIBeam = SDLEnum.SDL_SYSTEM_CURSOR_IBEAM +cursorToSDL CursorInvalid = SDLEnum.SDL_SYSTEM_CURSOR_NO +cursorToSDL CursorSizeH = SDLEnum.SDL_SYSTEM_CURSOR_SIZEWE +cursorToSDL CursorSizeV = SDLEnum.SDL_SYSTEM_CURSOR_SIZENS +cursorToSDL CursorDiagTL = SDLEnum.SDL_SYSTEM_CURSOR_SIZENWSE +cursorToSDL CursorDiagTR = SDLEnum.SDL_SYSTEM_CURSOR_SIZENESW diff --git a/src/Monomer/Main/Lens.hs b/src/Monomer/Main/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/Lens.hs @@ -0,0 +1,25 @@ +{-| +Module : Monomer.Main.Lens +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Lenses for the Main types. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Main.Lens where + +import Control.Lens.TH (abbreviatedFields, makeLensesWith) + +import Monomer.Core.Lens +import Monomer.Main.Types + +makeLensesWith abbreviatedFields ''AppConfig +makeLensesWith abbreviatedFields ''MonomerCtx +makeLensesWith abbreviatedFields ''DragAction +makeLensesWith abbreviatedFields ''RenderSchedule diff --git a/src/Monomer/Main/Platform.hs b/src/Monomer/Main/Platform.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/Platform.hs @@ -0,0 +1,212 @@ +{-| +Module : Monomer.Main.Platform +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for SDL platform related operations. +-} +module Monomer.Main.Platform ( + defaultWindowSize, + initSDLWindow, + detroySDLWindow, + getCurrentMousePos, + getDrawableSize, + getWindowSize, + getViewportSize, + getPlatform, + getDisplayDPI +) where + +import Control.Monad.State +import Data.Maybe +import Data.Text (Text) +import Foreign (alloca, peek) +import Foreign.C (peekCString, withCString) +import Foreign.C.Types +import SDL (($=)) + +import qualified Data.Text as T +import qualified Foreign.C.String as STR +import qualified SDL +import qualified SDL.Input.Mouse as Mouse +import qualified SDL.Raw as Raw +import qualified SDL.Raw.Error as SRE + +import Monomer.Common +import Monomer.Core.StyleTypes +import Monomer.Main.Types +import Monomer.Event.Types +import Monomer.Widgets.Composite + +foreign import ccall unsafe "initGlew" glewInit :: IO CInt +foreign import ccall unsafe "initDpiAwareness" initDpiAwareness :: IO CInt + +-- | Default window size if not is specified. +defaultWindowSize :: (Int, Int) +defaultWindowSize = (800, 600) + +-- | Creates and initializes a window using the provided configuration. +initSDLWindow :: AppConfig e -> IO (SDL.Window, Double, Double, SDL.GLContext) +initSDLWindow config = do + SDL.initialize [SDL.InitVideo] + SDL.HintRenderScaleQuality $= SDL.ScaleLinear + + do renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + putStrLn "Warning: Linear texture filtering not enabled!" + + platform <- getPlatform + initDpiAwareness + factor <- case platform of + "Windows" -> getWindowsFactor + "Linux" -> getLinuxFactor + _ -> return 1 -- macOS + let (winW, winH) = (factor * fromIntegral baseW, factor * fromIntegral baseH) + + window <- + SDL.createWindow + "Monomer application" + SDL.defaultWindow { + SDL.windowInitialSize = SDL.V2 (round winW) (round winH), + SDL.windowHighDPI = True, + SDL.windowResizable = windowResizable, + SDL.windowBorder = windowBorder, + SDL.windowGraphicsContext = SDL.OpenGLContext customOpenGL + } + + -- Get device pixel rate + Size dw _ <- getDrawableSize window + Size ww _ <- getWindowSize window + let scaleFactor = factor * userScaleFactor + let contentRatio = dw / ww + let (dpr, epr) + | platform `elem` ["Windows", "Linux"] = (scaleFactor, 1 / scaleFactor) + | otherwise = (scaleFactor * contentRatio, 1 / scaleFactor) -- macOS + + when (isJust (_apcWindowTitle config)) $ + SDL.windowTitle window $= fromJust (_apcWindowTitle config) + + when windowFullscreen $ + SDL.setWindowMode window SDL.FullscreenDesktop + + when windowMaximized $ + SDL.setWindowMode window SDL.Maximized + + err <- SRE.getError + err <- STR.peekCString err + putStrLn err + + ctxRender <- SDL.glCreateContext window + + when (platform == "Windows") $ + void $ SDL.glCreateContext window + + _ <- glewInit + + return (window, dpr, epr, ctxRender) + where + customOpenGL = SDL.OpenGLConfig { + SDL.glColorPrecision = SDL.V4 8 8 8 0, + SDL.glDepthPrecision = 24, + SDL.glStencilPrecision = 8, + --SDL.glProfile = SDL.Core SDL.Debug 3 2, + SDL.glProfile = SDL.Core SDL.Normal 3 2, + SDL.glMultisampleSamples = 1 + } + userScaleFactor = fromMaybe 1 (_apcScaleFactor config) + (baseW, baseH) = case _apcWindowState config of + Just (MainWindowNormal size) -> size + _ -> defaultWindowSize + windowResizable = fromMaybe True (_apcWindowResizable config) + windowBorder = fromMaybe True (_apcWindowBorder config) + windowFullscreen = case _apcWindowState config of + Just MainWindowFullScreen -> True + _ -> False + windowMaximized = case _apcWindowState config of + Just MainWindowMaximized -> True + _ -> False + +-- | Destroys the provided window, shutdowns the video subsystem and SDL. +detroySDLWindow :: SDL.Window -> IO () +detroySDLWindow window = do + putStrLn "About to destroyWindow" + SDL.destroyWindow window + Raw.quitSubSystem Raw.SDL_INIT_VIDEO + SDL.quit + +-- | Returns the current mouse position. +getCurrentMousePos :: (MonadIO m) => Double -> m Point +getCurrentMousePos epr = do + SDL.P (SDL.V2 x y) <- Mouse.getAbsoluteMouseLocation + return $ Point (epr * fromIntegral x) (epr * fromIntegral y) + +-- | Returns the drawable size of the provided window. May differ from window +-- | size if HDPI is enabled. +getDrawableSize :: (MonadIO m) => SDL.Window -> m Size +getDrawableSize window = do + SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window + return $ Size (fromIntegral fbWidth) (fromIntegral fbHeight) + +-- | Returns the size of the provided window. +getWindowSize :: (MonadIO m) => SDL.Window -> m Size +getWindowSize window = do + SDL.V2 rw rh <- SDL.get (SDL.windowSize window) + + return $ Size (fromIntegral rw) (fromIntegral rh) + +{-| +Returns the viewport size. This is the size of the viewport the application will +render to and, depending on the platform, may match window size or not. For +example, on Windows and Linux Wayland this size may be smaller than the window +size because of dpr scaling. +-} +getViewportSize :: (MonadIO m) => SDL.Window -> Double -> m Size +getViewportSize window dpr = do + SDL.V2 fw fh <- SDL.glGetDrawableSize window + + return $ Size (fromIntegral fw / dpr) (fromIntegral fh / dpr) + +-- | Returns the name of the host OS. +getPlatform :: (MonadIO m) => m Text +getPlatform = do + platform <- liftIO . peekCString =<< Raw.getPlatform + + return $ T.pack platform + +-- | Returns the diagonal, horizontal and vertical DPI of the main display. +getDisplayDPI :: IO (Double, Double, Double) +getDisplayDPI = + alloca $ \pddpi -> + alloca $ \phdpi -> + alloca $ \pvdpi -> do + Raw.getDisplayDPI 0 pddpi phdpi pvdpi + ddpi <- peek pddpi + hdpi <- peek phdpi + vdpi <- peek pvdpi + return (realToFrac ddpi, realToFrac hdpi, realToFrac vdpi) + +-- | Returns the default resize factor for Windows +getWindowsFactor :: IO Double +getWindowsFactor = do + (ddpi, hdpi, vdpi) <- getDisplayDPI + return (hdpi / 96) + +{-| +Returns a resizing factor to handle HiDPI on Linux. Currently only tested on +Wayland (Ubuntu 21.04). +-} +getLinuxFactor :: IO Double +getLinuxFactor = + 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 + + if width <= 1920 + then return 1 + else return (fromIntegral (ceiling baseFactor) / 2) diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/Types.hs @@ -0,0 +1,320 @@ +{-| +Module : Monomer.Main.Types +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Basic types for Main module. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Main.Types where + +import Control.Applicative ((<|>)) +import Control.Concurrent.Async +import Control.Concurrent.STM.TChan +import Control.Monad.Catch +import Control.Monad.State +import Data.Default +import Data.Map (Map) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Sequence (Seq) +import GHC.Generics + +import qualified Data.Map as M +import qualified SDL +import qualified SDL.Raw.Types as SDLR + +import Monomer.Common +import Monomer.Core.Combinators +import Monomer.Core.StyleTypes +import Monomer.Core.ThemeTypes +import Monomer.Core.WidgetTypes +import Monomer.Event.Types +import Monomer.Graphics.Types + +-- | Main Monomer monad. +type MonomerM s e m = (Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadIO m) + +-- | Messages received by the rendering thread. +data RenderMsg s e + = MsgRender (WidgetEnv s e) (WidgetNode s e) + | MsgResize Size + | MsgRemoveImage Text + deriving 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 +be provided. +-} +data RenderSchedule = RenderSchedule { + _rsWidgetId :: WidgetId, + _rsStart :: Int, + _rsMs :: Int, + _rsRepeat :: Maybe Int +} deriving (Eq, Show, Generic) + +-- | Drag action started by "WidgetId", with an associated message. +data DragAction = DragAction { + _dgaWidgetId :: WidgetId, + _dgaDragData :: WidgetDragMsg +} deriving (Eq, Show) + +{-| +Asychronous widget task. Results must be provided as user defined, Typeable, +types. Error handling should be done inside the task and reporting handled as +part of the user type. +-} +data WidgetTask + -- | Task generating a single result (for example, an HTTP request). + = forall i . Typeable i => WidgetTask WidgetId (Async i) + -- | Task generating a multiple result (for example, a Socket). + | forall i . Typeable i => WidgetProducer WidgetId (TChan i) (Async ()) + +-- | Current state of the Monomer runtime. +data MonomerCtx s e = MonomerCtx { + -- | Main application model. + _mcMainModel :: s, + -- | Active window. + _mcWindow :: SDL.Window, + -- | Main window size. + _mcWindowSize :: Size, + -- | Device pixel rate. + _mcDpr :: Double, + -- | Event pixel rate. + _mcEpr :: Double, + -- | Event pixel rate. + _mcRenderChannel :: TChan (RenderMsg s e), + -- | Input status (mouse and keyboard). + _mcInputStatus :: InputStatus, + -- | Cursor icons (a stack is used because of parent -> child relationship). + _mcCursorStack :: [(WidgetId, CursorIcon)], + -- | WidgetId of focused widget. + _mcFocusedWidgetId :: WidgetId, + -- | WidgetId of hovered widget, if any. + _mcHoveredWidgetId :: Maybe WidgetId, + -- | WidgetId of overlay widget, if any. + _mcOverlayWidgetId :: Maybe WidgetId, + -- | Active drag action, if any. + _mcDragAction :: Maybe DragAction, + -- | Start point and target of latest main button press, if any. + _mcMainBtnPress :: Maybe (Path, Point), + -- | Active widget tasks. + _mcWidgetTasks :: Seq WidgetTask, + {-| + Associations of WidgetId to updated paths. Only WidgetIds whose initial path + changed are included. + -} + _mcWidgetPaths :: Map WidgetId Path, + -- | Association of Monomer CursorIcon to SDL Cursors. + _mcCursorIcons :: Map CursorIcon SDLR.Cursor, + {-| + Hacky flag to avoid resizing when transitioning hover. Needed because sizes + may change and new target of hover should not change. + -} + _mcLeaveEnterPair :: Bool, + -- | Widgets with pending resize requests. + _mcResizeRequests :: Seq WidgetId, + -- | Flag indicating render was requested in this cycle. + _mcRenderRequested :: Bool, + -- | Active periodic rendering requests. + _mcRenderSchedule :: Map WidgetId RenderSchedule, + -- | Whether there was a request to exit the application. + _mcExitApplication :: Bool +} + +-- | Requests for main window size. +data MainWindowState + -- | Normal window with a given size. + = MainWindowNormal (Int, Int) + -- | Maximized window. + | MainWindowMaximized + -- | Full screen window. + | MainWindowFullScreen + deriving (Eq, Show) + +-- | Main application config. +data AppConfig e = AppConfig { + -- | Initial size of the main window. + _apcWindowState :: Maybe MainWindowState, + -- | Title of the main window. + _apcWindowTitle :: Maybe Text, + -- | Whether the main window is resizable. + _apcWindowResizable :: Maybe Bool, + -- | Whether the main window has a border. + _apcWindowBorder :: Maybe Bool, + {-| + Max number of FPS the application will run at. It does not necessarily mean + rendering will happen every frame, but events and schedules will be checked at + this rate. + -} + _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) + -} + _apcScaleFactor :: Maybe Double, + {-| + Available fonts to the application. An empty list will make it impossible to + render text. + -} + _apcFonts :: [FontDef], + -- | Initial theme. + _apcTheme :: Maybe Theme, + -- | Initial event, useful for loading resources. + _apcInitEvent :: [e], + -- | Dispose event, useful for closing resources. + _apcDisposeEvent :: [e], + -- | Exit event, useful for cancelling an application close event. + _apcExitEvent :: [e], + -- | Resize event handler. + _apcResizeEvent :: [Rect -> e], + -- | Defines which mouse button is considered main. + _apcMainButton :: Maybe Button, + -- | Defines which mouse button is considered secondary or context button. + _apcContextButton :: Maybe Button +} + +instance Default (AppConfig e) where + def = AppConfig { + _apcWindowState = Nothing, + _apcWindowTitle = Nothing, + _apcWindowResizable = Nothing, + _apcWindowBorder = Nothing, + _apcMaxFps = Nothing, + _apcScaleFactor = Nothing, + _apcFonts = [], + _apcTheme = Nothing, + _apcInitEvent = [], + _apcDisposeEvent = [], + _apcExitEvent = [], + _apcResizeEvent = [], + _apcMainButton = Nothing, + _apcContextButton = Nothing + } + +instance Semigroup (AppConfig e) where + (<>) a1 a2 = AppConfig { + _apcWindowState = _apcWindowState a2 <|> _apcWindowState a1, + _apcWindowTitle = _apcWindowTitle a2 <|> _apcWindowTitle a1, + _apcWindowResizable = _apcWindowResizable a2 <|> _apcWindowResizable a1, + _apcWindowBorder = _apcWindowBorder a2 <|> _apcWindowBorder a1, + _apcMaxFps = _apcMaxFps a2 <|> _apcMaxFps a1, + _apcScaleFactor = _apcScaleFactor a2 <|> _apcScaleFactor a1, + _apcFonts = _apcFonts a1 ++ _apcFonts a2, + _apcTheme = _apcTheme a2 <|> _apcTheme a1, + _apcInitEvent = _apcInitEvent a1 ++ _apcInitEvent a2, + _apcDisposeEvent = _apcDisposeEvent a1 ++ _apcDisposeEvent a2, + _apcExitEvent = _apcExitEvent a1 ++ _apcExitEvent a2, + _apcResizeEvent = _apcResizeEvent a1 ++ _apcResizeEvent a2, + _apcMainButton = _apcMainButton a2 <|> _apcMainButton a1, + _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1 + } + +instance Monoid (AppConfig e) where + mempty = def + +-- | Initial size of the main window. +appWindowState :: MainWindowState -> AppConfig e +appWindowState title = def { + _apcWindowState = Just title +} + +-- | Title of the main window. +appWindowTitle :: Text -> AppConfig e +appWindowTitle title = def { + _apcWindowTitle = Just title +} + +-- | Whether the main window is resizable. +appWindowResizable :: Bool -> AppConfig e +appWindowResizable resizable = def { + _apcWindowResizable = Just resizable +} + +-- | Whether the main window has a border. +appWindowBorder :: Bool -> AppConfig e +appWindowBorder border = def { + _apcWindowBorder = Just border +} + +{-| +Max number of FPS the application will run. It does not necessarily mean +rendering will happen every frame, but events and schedules will be checked at +this rate and may cause it. +-} +appMaxFps :: Int -> AppConfig e +appMaxFps fps = def { + _apcMaxFps = Just fps +} + +{-| +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). +-} +appScaleFactor :: Double -> AppConfig e +appScaleFactor factor = def { + _apcScaleFactor = Just factor +} + +{-| +Available fonts to the application. An empty list will make it impossible to +render text. +-} +appFontDef :: Text -> Text -> AppConfig e +appFontDef name path = def { + _apcFonts = [ FontDef name path ] +} + +-- | Initial theme. +appTheme :: Theme -> AppConfig e +appTheme t = def { + _apcTheme = Just t +} + +-- | Initial event, useful for loading resources. +appInitEvent :: e -> AppConfig e +appInitEvent evt = def { + _apcInitEvent = [evt] +} + +-- | Dispose event, useful for closing resources. +appDisposeEvent :: e -> AppConfig e +appDisposeEvent evt = def { + _apcDisposeEvent = [evt] +} + +-- | Exit event, useful for cancelling an application close event. +appExitEvent :: e -> AppConfig e +appExitEvent evt = def { + _apcExitEvent = [evt] +} + +-- | Resize event handler. +appResizeEvent :: (Rect -> e) -> AppConfig e +appResizeEvent evt = def { + _apcResizeEvent = [evt] +} + +-- | Defines which mouse button is considered main. +appMainButton :: Button -> AppConfig e +appMainButton btn = def { + _apcMainButton = Just btn +} + +-- | Defines which mouse button is considered secondary or context button. +appContextButton :: Button -> AppConfig e +appContextButton btn = def { + _apcContextButton = Just btn +} diff --git a/src/Monomer/Main/UserUtil.hs b/src/Monomer/Main/UserUtil.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/UserUtil.hs @@ -0,0 +1,53 @@ +{-| +Module : Monomer.Main.UserUtil +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for Monomer users, to simplify common operations such as focus +change and clipboard requests. +-} +module Monomer.Main.UserUtil where + +import Control.Applicative ((<|>)) +import Control.Lens +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import Monomer.Widgets.Composite + +import qualified Monomer.Core.Lens as L +import qualified Monomer.Main.Lens as L + +{-| +Generates a response to sets focus on the given key, provided as WidgetKey. If +the key does not exist, focus will remain on the currently focused widget. +-} +setFocusOnKey :: WidgetEnv s e -> WidgetKey -> EventResponse s e sp ep +setFocusOnKey wenv key = Request (SetFocus widgetId) where + widgetId = fromMaybe def (widgetIdFromKey wenv key) + +-- | Generates a response that sets the clipboard to the given data +setClipboardData :: ClipboardData -> EventResponse s e sp ep +setClipboardData cdata = Request (SetClipboard cdata) + +-- | Generates a response that sets the cursor to the given icon +setCursorIcon :: WidgetNode s e -> CursorIcon -> EventResponse s e sp ep +setCursorIcon node icon = Request (SetCursorIcon widgetId icon) where + widgetId = node ^. L.info . L.widgetId + +-- | Generates a response that resets the cursor icon +resetCursorIcon :: WidgetNode s e -> EventResponse s e sp ep +resetCursorIcon node = Request (ResetCursorIcon widgetId) where + widgetId = node ^. L.info . L.widgetId + +-- | Generates a response that exits the application +exitApplication :: EventResponse s e sp ep +exitApplication = Request (ExitApplication True) + +-- | Generates a response that cancels a request to exit the application +cancelExitApplication :: EventResponse s e sp ep +cancelExitApplication = Request (ExitApplication False) diff --git a/src/Monomer/Main/Util.hs b/src/Monomer/Main/Util.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/Util.hs @@ -0,0 +1,121 @@ +{-| +Module : Monomer.Main.Util +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for the Main module. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +module Monomer.Main.Util where + +import Control.Applicative ((<|>)) +import Control.Concurrent.STM.TChan +import Control.Lens ((&), (^.), (.=), (%=), ix, at, non, use, _1) +import Control.Monad.Extra +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.Main.Platform +import Monomer.Main.Types +import Monomer.Widgets.Util.Widget + +import qualified Monomer.Core.Lens as L +import qualified Monomer.Main.Lens as L + +-- | Initializes the Monomer context with the provided information. +initMonomerCtx + :: SDL.Window + -> TChan (RenderMsg s e) + -> Size + -> Double + -> Double + -> s + -> MonomerCtx s e +initMonomerCtx win channel winSize dpr epr model = MonomerCtx { + _mcMainModel = model, + _mcWindow = win, + _mcWindowSize = winSize, + _mcDpr = dpr, + _mcEpr = epr, + _mcRenderChannel = channel, + _mcInputStatus = def, + _mcCursorStack = [], + _mcFocusedWidgetId = def, + _mcHoveredWidgetId = Nothing, + _mcOverlayWidgetId = Nothing, + _mcDragAction = Nothing, + _mcMainBtnPress = Nothing, + _mcWidgetTasks = Seq.empty, + _mcWidgetPaths = Map.empty, + _mcCursorIcons = Map.empty, + _mcLeaveEnterPair = False, + _mcResizeRequests = Seq.empty, + _mcRenderRequested = False, + _mcRenderSchedule = Map.empty, + _mcExitApplication = False +} + +-- | Returns the path of the provided "WidgetId". +getWidgetIdPath :: (MonomerM s e m) => WidgetId -> m Path +getWidgetIdPath widgetId = + use $ L.widgetPaths . at widgetId . non (widgetId ^. L.path) + +-- | Updates the path associated to a "WidgetId". +setWidgetIdPath :: (MonomerM s e m) => WidgetId -> Path -> m () +setWidgetIdPath widgetId path = L.widgetPaths . at widgetId .= Just path + +-- | Removes the association of a path to a "WidgetId". +delWidgetIdPath :: (MonomerM s e m) => WidgetId -> m () +delWidgetIdPath widgetId = L.widgetPaths . at widgetId .= Nothing + +-- | Returns the path of the currently hovered node, if any. +getHoveredPath :: (MonomerM s e m) => m (Maybe Path) +getHoveredPath = do + hoveredWidgetId <- use L.hoveredWidgetId + case hoveredWidgetId of + Just wid -> Just <$> getWidgetIdPath wid + Nothing -> return Nothing + +-- | Returns the path of the currently focused node. +getFocusedPath :: (MonomerM s e m) => m Path +getFocusedPath = getWidgetIdPath =<< use L.focusedWidgetId + +-- | Returns the path of the current overlay node, if any. +getOverlayPath :: (MonomerM s e m) => m (Maybe Path) +getOverlayPath = do + overlayWidgetId <- use L.overlayWidgetId + case overlayWidgetId of + Just wid -> Just <$> getWidgetIdPath wid + Nothing -> return Nothing + +-- | Returns the current drag message and path, if any. +getDraggedMsgInfo :: (MonomerM s e m) => m (Maybe (Path, WidgetDragMsg)) +getDraggedMsgInfo = do + dragAction <- use L.dragAction + case dragAction of + Just (DragAction wid msg) -> Just . (, msg) <$> getWidgetIdPath wid + Nothing -> return Nothing + +-- | Returns the current cursor and path that set it, if any. +getCurrentCursorIcon :: (MonomerM s e m) => m (Maybe (Path, CursorIcon)) +getCurrentCursorIcon = do + cursorHead <- fmap headMay (use L.cursorStack) + case cursorHead of + Just (wid, icon) -> do + path <- getWidgetIdPath wid + return $ Just (path, icon) + otherwhise -> return Nothing diff --git a/src/Monomer/Main/WidgetTask.hs b/src/Monomer/Main/WidgetTask.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Main/WidgetTask.hs @@ -0,0 +1,117 @@ +{-| +Module : Monomer.Main.WidgetTask +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Handles the lifecycle and reporting of generated events of WidgetTasks (single +message) and Producers (multiple messages). +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Main.WidgetTask (handleWidgetTasks) where + +import Control.Concurrent.Async (poll) +import Control.Concurrent.STM.TChan (tryReadTChan) +import Control.Exception.Base +import Control.Lens ((&), (^.), (.=), use) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.STM (atomically) +import Data.Foldable (toList) +import Data.Maybe +import Data.Typeable + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Main.Handlers +import Monomer.Main.Lens +import Monomer.Main.Util +import Monomer.Main.Types + +import qualified Monomer.Core.Lens as L + +-- | Checks the status and collects results of active tasks. +handleWidgetTasks + :: MonomerM s e m + => WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget root. + -> m (HandlerStep s e) -- ^ The updated "Monomer.Main.Handlers.HandlerStep". +handleWidgetTasks wenv widgetRoot = do + tasks <- use widgetTasks + (active, finished) <- partitionM isThreadActive (toList tasks) + widgetTasks .= Seq.fromList active + + processTasks wenv widgetRoot tasks + +processTasks + :: (MonomerM s e m, Traversable t) + => WidgetEnv s e + -> WidgetNode s e + -> t WidgetTask + -> m (HandlerStep s e) +processTasks wenv widgetRoot tasks = nextStep where + reducer (wenv1, root1, reqs1) task = do + (wenv2, root2, reqs2) <- processTask wenv1 root1 task + return (wenv2, root2, reqs1 <> reqs2) + nextStep = foldM reducer (wenv, widgetRoot, Seq.empty) tasks + +processTask + :: MonomerM s e m + => WidgetEnv s e + -> WidgetNode s e + -> WidgetTask + -> m (HandlerStep s e) +processTask wenv widgetRoot (WidgetTask widgetId task) = do + taskStatus <- liftIO $ poll task + + case taskStatus of + Just taskRes -> processTaskResult wenv widgetRoot widgetId taskRes + Nothing -> return (wenv, widgetRoot, Seq.empty) +processTask wenv widgetRoot (WidgetProducer widgetId channel task) = do + channelStatus <- liftIO . atomically $ tryReadTChan channel + + case channelStatus of + Just taskMsg -> processTaskEvent wenv widgetRoot widgetId taskMsg + Nothing -> return (wenv, widgetRoot, Seq.empty) + +processTaskResult + :: (MonomerM s e m, Typeable i) + => WidgetEnv s e + -> WidgetNode s e + -> WidgetId + -> Either SomeException i + -> m (HandlerStep s e) +processTaskResult wenv widgetRoot _ (Left ex) = do + liftIO . putStrLn $ "Error processing Widget task result: " ++ show ex + return (wenv, widgetRoot, Seq.empty) +processTaskResult wenv widgetRoot widgetId (Right taskResult) + = processTaskEvent wenv widgetRoot widgetId taskResult + +processTaskEvent + :: (MonomerM s e m, Typeable i) + => WidgetEnv s e + -> WidgetNode s e + -> WidgetId + -> i + -> m (HandlerStep s e) +processTaskEvent wenv widgetRoot widgetId event = do + path <- getWidgetIdPath widgetId + + let emptyResult = WidgetResult widgetRoot Seq.empty + let widget = widgetRoot ^. L.widget + let msgResult = widgetHandleMessage widget wenv widgetRoot path event + let widgetResult = fromMaybe emptyResult msgResult + + handleWidgetResult wenv True widgetResult + +isThreadActive :: MonomerM s e m => WidgetTask -> m Bool +isThreadActive (WidgetTask _ task) = fmap isNothing (liftIO $ poll task) +isThreadActive (WidgetProducer _ _ task) = fmap isNothing (liftIO $ poll task) + +taskWidgetId :: WidgetTask -> WidgetId +taskWidgetId (WidgetTask widgetId _) = widgetId +taskWidgetId (WidgetProducer widgetId _ _) = widgetId diff --git a/src/Monomer/Widgets.hs b/src/Monomer/Widgets.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets.hs @@ -0,0 +1,97 @@ +{-| +Module : Monomer.Widgets +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Widgets module, grouping and re-exporting all the existing widgets. +-} +module Monomer.Widgets ( + module Monomer.Widgets.Composite, + + module Monomer.Widgets.Animation.Fade, + module Monomer.Widgets.Animation.Slide, + module Monomer.Widgets.Animation.Types, + + module Monomer.Widgets.Containers.Alert, + module Monomer.Widgets.Containers.Box, + module Monomer.Widgets.Containers.Confirm, + module Monomer.Widgets.Containers.Draggable, + module Monomer.Widgets.Containers.Dropdown, + module Monomer.Widgets.Containers.DropTarget, + module Monomer.Widgets.Containers.Grid, + module Monomer.Widgets.Containers.Keystroke, + module Monomer.Widgets.Containers.Scroll, + module Monomer.Widgets.Containers.SelectList, + module Monomer.Widgets.Containers.Split, + module Monomer.Widgets.Containers.Stack, + module Monomer.Widgets.Containers.ThemeSwitch, + module Monomer.Widgets.Containers.Tooltip, + module Monomer.Widgets.Containers.ZStack, + + module Monomer.Widgets.Singles.Button, + module Monomer.Widgets.Singles.Checkbox, + module Monomer.Widgets.Singles.ColorPicker, + module Monomer.Widgets.Singles.DateField, + module Monomer.Widgets.Singles.Dial, + module Monomer.Widgets.Singles.ExternalLink, + module Monomer.Widgets.Singles.Icon, + module Monomer.Widgets.Singles.Image, + module Monomer.Widgets.Singles.Label, + module Monomer.Widgets.Singles.LabeledCheckbox, + module Monomer.Widgets.Singles.LabeledRadio, + module Monomer.Widgets.Singles.NumericField, + module Monomer.Widgets.Singles.Radio, + module Monomer.Widgets.Singles.SeparatorLine, + module Monomer.Widgets.Singles.Slider, + module Monomer.Widgets.Singles.Spacer, + module Monomer.Widgets.Singles.TextArea, + module Monomer.Widgets.Singles.TextDropdown, + module Monomer.Widgets.Singles.TextField, + module Monomer.Widgets.Singles.TimeField +) where + +import Monomer.Widgets.Composite + +import Monomer.Widgets.Animation.Fade +import Monomer.Widgets.Animation.Slide +import Monomer.Widgets.Animation.Types + +import Monomer.Widgets.Containers.Alert +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Confirm +import Monomer.Widgets.Containers.Draggable +import Monomer.Widgets.Containers.Dropdown +import Monomer.Widgets.Containers.DropTarget +import Monomer.Widgets.Containers.Grid +import Monomer.Widgets.Containers.Keystroke +import Monomer.Widgets.Containers.Scroll +import Monomer.Widgets.Containers.SelectList +import Monomer.Widgets.Containers.Split +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Containers.ThemeSwitch +import Monomer.Widgets.Containers.Tooltip +import Monomer.Widgets.Containers.ZStack + +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Checkbox +import Monomer.Widgets.Singles.ColorPicker +import Monomer.Widgets.Singles.DateField +import Monomer.Widgets.Singles.Dial +import Monomer.Widgets.Singles.ExternalLink +import Monomer.Widgets.Singles.Icon +import Monomer.Widgets.Singles.Image +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.LabeledCheckbox +import Monomer.Widgets.Singles.LabeledRadio +import Monomer.Widgets.Singles.NumericField +import Monomer.Widgets.Singles.Radio +import Monomer.Widgets.Singles.SeparatorLine +import Monomer.Widgets.Singles.Slider +import Monomer.Widgets.Singles.Spacer +import Monomer.Widgets.Singles.TextArea +import Monomer.Widgets.Singles.TextDropdown +import Monomer.Widgets.Singles.TextField +import Monomer.Widgets.Singles.TimeField diff --git a/src/Monomer/Widgets/Animation.hs b/src/Monomer/Widgets/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation.hs @@ -0,0 +1,19 @@ +{-| +Module : Monomer.Widgets.Animation +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Widgets implementing different types of animations. +-} +module Monomer.Widgets.Animation ( + module Monomer.Widgets.Animation.Fade, + module Monomer.Widgets.Animation.Slide, + module Monomer.Widgets.Animation.Types +) where + +import Monomer.Widgets.Animation.Fade +import Monomer.Widgets.Animation.Slide +import Monomer.Widgets.Animation.Types diff --git a/src/Monomer/Widgets/Animation/Fade.hs b/src/Monomer/Widgets/Animation/Fade.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation/Fade.hs @@ -0,0 +1,188 @@ +{-| +Module : Monomer.Widgets.Animation.Fade +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Fade animation widget. Wraps a child widget whose content will be animated. + +Config: + +- autoStart: whether the first time the widget is added, animation should run. +- duration: how long the animation lasts in ms. +- onFinished: event to raise when animation is complete. + +Messages: + +- Receives a 'AnimationMsg', used to control the state of the animation. +-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Monomer.Widgets.Animation.Fade ( + animFadeIn, + animFadeIn_, + animFadeOut, + animFadeOut_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), (%~), at) +import Control.Monad (when) +import Data.Default +import Data.Maybe +import Data.Text (Text) +import Data.Typeable (cast) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container +import Monomer.Widgets.Animation.Types + +import qualified Monomer.Lens as L + +data FadeCfg e = FadeCfg { + _fdcAutoStart :: Maybe Bool, + _fdcDuration :: Maybe Int, + _fdcOnFinished :: [e] +} deriving (Eq, Show) + +instance Default (FadeCfg e) where + def = FadeCfg { + _fdcAutoStart = Nothing, + _fdcDuration = Nothing, + _fdcOnFinished = [] + } + +instance Semigroup (FadeCfg e) where + (<>) fc1 fc2 = FadeCfg { + _fdcAutoStart = _fdcAutoStart fc2 <|> _fdcAutoStart fc1, + _fdcDuration = _fdcDuration fc2 <|> _fdcDuration fc1, + _fdcOnFinished = _fdcOnFinished fc1 <> _fdcOnFinished fc2 + } + +instance Monoid (FadeCfg e) where + mempty = def + +instance CmbAutoStart (FadeCfg e) where + autoStart_ start = def { + _fdcAutoStart = Just start + } + +instance CmbDuration (FadeCfg e) Int where + duration dur = def { + _fdcDuration = Just dur + } + +instance CmbOnFinished (FadeCfg e) e where + onFinished fn = def { + _fdcOnFinished = [fn] + } + +data FadeState = FadeState { + _fdsRunning :: Bool, + _fdsStartTs :: Int +} deriving (Eq, Show, Generic) + +instance Default FadeState where + def = FadeState { + _fdsRunning = False, + _fdsStartTs = 0 + } + +-- | Animates a widget from not visible state to fully visible. +animFadeIn :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animFadeIn managed = animFadeIn_ def managed + +-- | Animates a widget from not visible state to fully visible. Accepts config. +animFadeIn_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e +animFadeIn_ configs managed = makeNode "animFadeIn" widget managed where + config = mconcat configs + widget = makeFade True config def + +-- | Animates a widget from visible state to not visible. +animFadeOut :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animFadeOut managed = animFadeOut_ def managed + +-- | Animates a widget from visible state to not visible. Accepts config. +animFadeOut_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e +animFadeOut_ configs managed = makeNode "animFadeOut" widget managed where + config = mconcat configs + widget = makeFade False config def + +makeNode + :: WidgetEvent e => WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode wType widget managedWidget = defaultWidgetNode wType widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeFade :: WidgetEvent e => Bool -> FadeCfg e -> FadeState -> Widget s e +makeFade isFadeIn config state = widget where + widget = createContainer state def { + containerInit = init, + containerMerge = merge, + containerHandleMessage = handleMessage, + containerRender = render, + containerRenderAfter = renderPost + } + + FadeState running start = state + autoStart = fromMaybe False (_fdcAutoStart config) + duration = fromMaybe 500 (_fdcDuration config) + period = 20 + steps = duration `div` period + + finishedReq node = delayedMessage node AnimationFinished duration + renderReq wenv node = req where + widgetId = node ^. L.info . L.widgetId + req = RenderEvery widgetId period (Just steps) + + init wenv node = result where + ts = wenv ^. L.timestamp + newNode = node + & L.widget .~ makeFade isFadeIn config (FadeState True ts) + result + | autoStart = resultReqs newNode [finishedReq node, renderReq wenv node] + | otherwise = resultNode node + + merge wenv node oldNode oldState = resultNode newNode where + newNode = node + & L.widget .~ makeFade isFadeIn config oldState + + handleMessage wenv node target message = result where + result = cast message >>= Just . handleAnimateMsg wenv node + + handleAnimateMsg wenv node msg = result where + widgetId = node ^. L.info . L.widgetId + ts = wenv ^. L.timestamp + startState = FadeState True ts + startReqs = [finishedReq node, renderReq wenv node] + + newNode newState = node + & L.widget .~ makeFade isFadeIn config newState + result = case msg of + AnimationStart -> resultReqs (newNode startState) startReqs + AnimationStop -> resultReqs (newNode def) [RenderStop widgetId] + AnimationFinished + | _fdsRunning state -> resultEvts node (_fdcOnFinished config) + | otherwise -> resultNode node + + render wenv node renderer = do + saveContext renderer + when running $ + setGlobalAlpha renderer alpha + where + ts = wenv ^. L.timestamp + currStep = clampAlpha $ fromIntegral (ts - start) / fromIntegral duration + alpha + | isFadeIn = currStep + | otherwise = 1 - currStep + + renderPost wenv node renderer = do + restoreContext renderer diff --git a/src/Monomer/Widgets/Animation/Slide.hs b/src/Monomer/Widgets/Animation/Slide.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation/Slide.hs @@ -0,0 +1,235 @@ +{-| +Module : Monomer.Widgets.Animation.Slide +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Slide animation widget. Wraps a child widget whose content will be animated. + +Config: + +- autoStart: whether the first time the widget is added, animation should run. +- duration: how long the animation lasts in ms. +- onFinished: event to raise when animation is complete. +- Individual combinators for direction. + +Messages: + +- Receives a 'AnimationMsg', used to control the state of the animation. +-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Animation.Slide ( + animSlideIn, + animSlideIn_, + animSlideOut, + animSlideOut_, + slideLeft, + slideRight, + slideTop, + slideBottom +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), (%~), at) +import Control.Monad (when) +import Data.Default +import Data.Maybe +import Data.Typeable (cast) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Helper +import Monomer.Widgets.Container +import Monomer.Widgets.Animation.Types + +import qualified Monomer.Lens as L + +data SlideDirection + = SlideLeft + | SlideRight + | SlideUp + | SlideDown + deriving (Eq, Show) + +data SlideCfg e = SlideCfg { + _slcDirection :: Maybe SlideDirection, + _slcAutoStart :: Maybe Bool, + _slcDuration :: Maybe Int, + _slcOnFinished :: [e] +} deriving (Eq, Show) + +instance Default (SlideCfg e) where + def = SlideCfg { + _slcDirection = Nothing, + _slcAutoStart = Nothing, + _slcDuration = Nothing, + _slcOnFinished = [] + } + +instance Semigroup (SlideCfg e) where + (<>) fc1 fc2 = SlideCfg { + _slcDirection = _slcDirection fc2 <|> _slcDirection fc1, + _slcAutoStart = _slcAutoStart fc2 <|> _slcAutoStart fc1, + _slcDuration = _slcDuration fc2 <|> _slcDuration fc1, + _slcOnFinished = _slcOnFinished fc1 <> _slcOnFinished fc2 + } + +instance Monoid (SlideCfg e) where + mempty = def + +instance CmbAutoStart (SlideCfg e) where + autoStart_ start = def { + _slcAutoStart = Just start + } + +instance CmbDuration (SlideCfg e) Int where + duration dur = def { + _slcDuration = Just dur + } + +instance CmbOnFinished (SlideCfg e) e where + onFinished fn = def { + _slcOnFinished = [fn] + } + +-- | Slide from/to left. +slideLeft :: SlideCfg e +slideLeft = def { _slcDirection = Just SlideLeft } + +-- | Slide from/to right. +slideRight :: SlideCfg e +slideRight = def { _slcDirection = Just SlideRight } + +-- | Slide from/to top. +slideTop :: SlideCfg e +slideTop = def { _slcDirection = Just SlideUp } + +-- | Slide from/to bottom. +slideBottom :: SlideCfg e +slideBottom = def { _slcDirection = Just SlideDown } + +data SlideState = SlideState { + _slsRunning :: Bool, + _slsStartTs :: Int +} deriving (Eq, Show, Generic) + +instance Default SlideState where + def = SlideState { + _slsRunning = False, + _slsStartTs = 0 + } + +-- | Animates a widget from the left to fully visible. +animSlideIn :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animSlideIn managed = animSlideIn_ def managed + +-- | Animates a widget from the provided direction to fully visible (defaults +-- | to left). Accepts config. +animSlideIn_ :: WidgetEvent e => [SlideCfg e] -> WidgetNode s e -> WidgetNode s e +animSlideIn_ configs managed = makeNode "animSlideIn" widget managed where + config = mconcat configs + widget = makeSlide True config def + +-- | Animates a widget to the left from visible to not visible. +animSlideOut :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animSlideOut managed = animSlideOut_ def managed + +-- | Animates a widget to the the provided direction from visible to not +-- | visible (defaults to left). Accepts config. +animSlideOut_ :: WidgetEvent e => [SlideCfg e] -> WidgetNode s e -> WidgetNode s e +animSlideOut_ configs managed = makeNode "animSlideOut" widget managed where + config = mconcat configs + widget = makeSlide False config def + +makeNode + :: WidgetEvent e => WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode wType widget managedWidget = defaultWidgetNode wType widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeSlide :: WidgetEvent e => Bool -> SlideCfg e -> SlideState -> Widget s e +makeSlide isSlideIn config state = widget where + widget = createContainer state def { + containerUseScissor = True, + containerInit = init, + containerMerge = merge, + containerHandleMessage = handleMessage, + containerRender = render, + containerRenderAfter = renderPost + } + + SlideState running start = state + autoStart = fromMaybe False (_slcAutoStart config) + duration = fromMaybe 500 (_slcDuration config) + period = 20 + steps = duration `div` period + + finishedReq node = delayedMessage node AnimationFinished duration + renderReq wenv node = req where + widgetId = node ^. L.info . L.widgetId + req = RenderEvery widgetId period (Just steps) + + init wenv node = result where + ts = wenv ^. L.timestamp + newNode = node + & L.widget .~ makeSlide isSlideIn config (SlideState True ts) + result + | autoStart = resultReqs newNode [finishedReq node, renderReq wenv node] + | otherwise = resultNode node + + merge wenv node oldNode oldState = resultNode newNode where + newNode = node + & L.widget .~ makeSlide isSlideIn config oldState + + handleMessage wenv node target message = result where + result = cast message >>= Just . handleAnimateMsg wenv node + + handleAnimateMsg wenv node msg = result where + widgetId = node ^. L.info . L.widgetId + ts = wenv ^. L.timestamp + startState = SlideState True ts + startReqs = [finishedReq node, renderReq wenv node] + + newNode newState = node + & L.widget .~ makeSlide isSlideIn config newState + result = case msg of + AnimationStart -> resultReqs (newNode startState) startReqs + AnimationStop -> resultReqs (newNode def) [RenderStop widgetId] + AnimationFinished + | _slsRunning state -> resultEvts node (_slcOnFinished config) + | otherwise -> resultNode node + + render wenv node renderer = do + saveContext renderer + when running $ + setTranslation renderer (Point offsetX offsetY) + where + viewport = node ^. L.info . L.viewport + ts = wenv ^. L.timestamp + dir = fromMaybe SlideLeft (_slcDirection config) + + bwdStep = clamp 0 1 $ fromIntegral (ts - start) / fromIntegral duration + fwdStep = 1 - bwdStep + + offsetX + | dir == SlideLeft && isSlideIn = -1 * fwdStep * viewport ^. L.w + | dir == SlideLeft = -1 * bwdStep * viewport ^. L.w + | dir == SlideRight && isSlideIn = fwdStep * viewport ^. L.w + | dir == SlideRight = bwdStep * viewport ^. L.w + | otherwise = 0 + offsetY + | dir == SlideUp && isSlideIn = -1 * fwdStep * viewport ^. L.h + | dir == SlideUp = -1 * bwdStep * viewport ^. L.h + | dir == SlideDown && isSlideIn = fwdStep * viewport ^. L.h + | dir == SlideDown = bwdStep * viewport ^. L.h + | otherwise = 0 + + renderPost wenv node renderer = do + restoreContext renderer diff --git a/src/Monomer/Widgets/Animation/Types.hs b/src/Monomer/Widgets/Animation/Types.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation/Types.hs @@ -0,0 +1,24 @@ +{-| +Module : Monomer.Widgets.Animation.Types +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Common types for animation widgets. +-} +module Monomer.Widgets.Animation.Types where + +-- | Message animation widgets usually support. Controls animation state. +data AnimationMsg + -- | Starts the animation from the beginning, even if it's running. + = AnimationStart + -- | Stops the animation if it's currently running. + | AnimationStop + {-| + Indicates the animation has finished. This is usually generated by the widget + itself for clean up. + -} + | AnimationFinished + deriving (Eq, Show) diff --git a/src/Monomer/Widgets/Composite.hs b/src/Monomer/Widgets/Composite.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Composite.hs @@ -0,0 +1,892 @@ +{-| +Module : Monomer.Widgets.Composite +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Composite widget. Main glue between all the other widgets, also acts as the main +app widget. Composite allows to split an application into reusable partss +without the need to implement a lower level widget. It can comunicate with its +parent component by reporting events. + +Requires two main 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. + +Configs: + +- 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 it's 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). +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Composite ( + module Monomer.Core, + module Monomer.Event, + module Monomer.Widgets.Util, + + CompositeCfg, + EventResponse(..), + MergeReqsHandler, + EventHandler, + UIBuilder, + compositeMergeReqs, + composite, + composite_, + compositeV, + compositeV_, + compositeD_ +) where + +import Debug.Trace + +import Control.Applicative ((<|>)) +import Control.Exception (AssertionFailed(..), throw) +import Control.Lens (ALens', (&), (^.), (^?), (.~), (%~), (<>~), at, ix, non) +import Data.Default +import Data.Either +import Data.List (foldl') +import Data.Map.Strict (Map) +import Data.Maybe +import Data.Sequence (Seq(..), (|>), (<|), fromList) +import Data.Typeable (Typeable, cast, typeOf) + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map.Strict as M +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics.Types +import Monomer.Helper +import Monomer.Widgets.Singles.Spacer +import Monomer.Widgets.Util + +import qualified Monomer.Core.Lens as L + +-- | Type of the parent's model +type ParentModel sp = Typeable sp +-- | Type of the composite's model +type CompositeModel s = (Eq s, WidgetModel s) +-- | Type of the composite's event +type CompositeEvent e = WidgetEvent e + +-- | Generates requests during the merge process. +type MergeReqsHandler s e + = WidgetEnv s e -> WidgetNode s e -> WidgetNode s e -> s -> [WidgetRequest s e] +-- | Handles a composite event and returns a set of responses. +type EventHandler s e sp ep + = WidgetEnv s e -> WidgetNode s e -> s -> e -> [EventResponse s e sp ep] +-- | Creates the widget tree based on the given model. +type UIBuilder s e = WidgetEnv s e -> s -> WidgetNode s e +-- | Checks if merging the composite is required. +type MergeRequired s = s -> s -> Bool +-- | Asynchronous task generating a single event. +type TaskHandler e = IO e +-- | Asynchronous task generating multiple events. +type ProducerHandler e = (e -> IO ()) -> IO () + +data CompMsgUpdate + = forall s . CompositeModel s => CompMsgUpdate (s -> s) + +-- | Response options for an event handler. +data EventResponse s e sp ep + -- | Modifies the current model, prompting a merge. + = Model s + -- | Raises a new event, which will be handled in the same cycle. + | Event e + -- | Raises an event that will be handled by the parent. + | Report ep + -- | Generates a WidgetRequest. + | Request (WidgetRequest s e) + {-| + Generates a WidgetRequest matching the parent's types. Useful when receiving + requests as configuration from the parent, since the types will not match + otherwise. + -} + | RequestParent (WidgetRequest sp ep) + {-| + Sends a message to the given key. If the key does not exist, the message will + not be delivered. + -} + | forall i . Typeable i => Message WidgetKey i + {-| + Runs an asynchronous task that will return a single result. The task is + responsible for reporting errors using the expected event type. If the task + crashes without returning a value, the composite will not know about it. + -} + | Task (TaskHandler e) + {-| + Runs an asynchronous task that will produce unlimited result. The producer is + responsible for reporting errors using the expected event type. If the + producer crashes without sending a value, composite will not know about it. + -} + | Producer (ProducerHandler e) + +-- | Configuration options for composite widget. +data CompositeCfg s e sp ep = CompositeCfg { + _cmcMergeRequired :: Maybe (MergeRequired s), + _cmcMergeReqs :: [MergeReqsHandler s e], + _cmcOnInit :: [e], + _cmcOnDispose :: [e], + _cmcOnResize :: [Rect -> e], + _cmcOnChangeReq :: [s -> WidgetRequest sp ep], + _cmcOnEnabledChange :: [e], + _cmcOnVisibleChange :: [e] +} + +instance Default (CompositeCfg s e sp ep) where + def = CompositeCfg { + _cmcMergeRequired = Nothing, + _cmcMergeReqs = [], + _cmcOnInit = [], + _cmcOnDispose = [], + _cmcOnResize = [], + _cmcOnChangeReq = [], + _cmcOnEnabledChange = [], + _cmcOnVisibleChange = [] + } + +instance Semigroup (CompositeCfg s e sp ep) where + (<>) c1 c2 = CompositeCfg { + _cmcMergeRequired = _cmcMergeRequired c2 <|> _cmcMergeRequired c1, + _cmcMergeReqs = _cmcMergeReqs c1 <> _cmcMergeReqs c2, + _cmcOnInit = _cmcOnInit c1 <> _cmcOnInit c2, + _cmcOnDispose = _cmcOnDispose c1 <> _cmcOnDispose c2, + _cmcOnResize = _cmcOnResize c1 <> _cmcOnResize c2, + _cmcOnChangeReq = _cmcOnChangeReq c1 <> _cmcOnChangeReq c2, + _cmcOnEnabledChange = _cmcOnEnabledChange c1 <> _cmcOnEnabledChange c2, + _cmcOnVisibleChange = _cmcOnVisibleChange c1 <> _cmcOnVisibleChange c2 + } + +instance Monoid (CompositeCfg s e sp ep) where + mempty = def + +instance CmbMergeRequired (CompositeCfg s e sp ep) s where + mergeRequired fn = def { + _cmcMergeRequired = Just fn + } + +instance CmbOnInit (CompositeCfg s e sp ep) e where + onInit fn = def { + _cmcOnInit = [fn] + } + +instance CmbOnDispose (CompositeCfg s e sp ep) e where + onDispose fn = def { + _cmcOnDispose = [fn] + } + +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 + onChange fn = def { + _cmcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (CompositeCfg s e sp ep) sp ep s where + onChangeReq req = def { + _cmcOnChangeReq = [req] + } + +instance CmbOnEnabledChange (CompositeCfg s e sp ep) e where + onEnabledChange fn = def { + _cmcOnEnabledChange = [fn] + } + +instance CmbOnVisibleChange (CompositeCfg s e sp ep) e where + onVisibleChange fn = def { + _cmcOnVisibleChange = [fn] + } + +-- | Generate WidgetRequests during the merge process. +compositeMergeReqs :: MergeReqsHandler s e -> CompositeCfg s e sp ep +compositeMergeReqs fn = def { + _cmcMergeReqs = [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], + _cmpOnInit :: [e], + _cmpOnDispose :: [e], + _cmpOnResize :: [Rect -> e], + _cmpOnChangeReq :: [s -> WidgetRequest sp ep], + _cmpOnEnabledChange :: [e], + _cmpOnVisibleChange :: [e] +} + +data CompositeState s e = CompositeState { + _cpsModel :: Maybe s, + _cpsRoot :: WidgetNode s e, + _cpsWidgetKeyMap :: WidgetKeyMap s e +} + +data ReducedEvents s e sp ep = ReducedEvents { + _reModel :: s, + _reEvents :: Seq e, + _reReports :: Seq ep, + _reRequests :: Seq (WidgetRequest s e), + _reMessages :: Seq (WidgetRequest sp ep), + _reTasks :: Seq (TaskHandler e), + _reProducers :: Seq (ProducerHandler e) +} + +{-| +Creates a composite taking its model from a lens into the parent model. +-} +composite + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => WidgetType -- ^ The name of the composite. + -> ALens' sp s -- ^ The lens into the parent's model. + -> UIBuilder s e -- ^ The UI builder function. + -> EventHandler s e sp ep -- ^ The event handler. + -> WidgetNode sp ep -- ^ The resulting widget. +composite widgetType field uiBuilder evtHandler = newNode where + newNode = composite_ widgetType field uiBuilder evtHandler def + +{-| +Creates a composite taking its model from a lens into the parent model. Accepts +config. +-} +composite_ + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => WidgetType -- ^ The name of the composite. + -> ALens' sp s -- ^ The lens into the parent's model. + -> UIBuilder s e -- ^ The UI builder function. + -> EventHandler s e sp ep -- ^ The event handler. + -> [CompositeCfg s e sp ep] -- ^ The config options. + -> WidgetNode sp ep -- ^ The resulting widget. +composite_ widgetType field uiBuilder evtHandler cfgs = newNode where + widgetData = WidgetLens field + newNode = compositeD_ widgetType widgetData uiBuilder evtHandler cfgs + +-- | Creates a composite using the given model and onChange event handler. +compositeV + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => WidgetType -- ^ The name of the composite. + -> s -- ^ The model. + -> (s -> ep) -- ^ 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. +compositeV wType val handler uiBuilder evtHandler = newNode where + newNode = compositeV_ wType val handler uiBuilder evtHandler def + +{-| +Creates a composite using the given model and onChange event handler. Accepts +config. +-} +compositeV_ + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => WidgetType -- ^ The name of the composite. + -> s -- ^ The model. + -> (s -> ep) -- ^ 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. + -> WidgetNode sp ep -- ^ The resulting widget. +compositeV_ wType val handler uiBuilder evtHandler cfgs = newNode where + widgetData = WidgetValue val + newCfgs = onChange handler : cfgs + newNode = compositeD_ wType widgetData uiBuilder evtHandler newCfgs + +-- | Creates a color picker providing a WidgetData instance and config. +compositeD_ + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => WidgetType -- ^ The name of the composite. + -> WidgetData sp s -- ^ The model. + -> UIBuilder s e -- ^ The UI builder function. + -> EventHandler s e sp ep -- ^ The event handler. + -> [CompositeCfg s e sp ep] -- ^ The config options. + -> WidgetNode sp ep -- ^ The resulting widget. +compositeD_ wType wData uiBuilder evtHandler configs = newNode where + config = mconcat configs + mergeReq = fromMaybe (/=) (_cmcMergeRequired config) + widgetRoot = spacer + composite = Composite { + _cmpWidgetData = wData, + _cmpEventHandler = evtHandler, + _cmpUiBuilder = uiBuilder, + _cmpMergeRequired = mergeReq, + _cmpMergeReqs = _cmcMergeReqs config, + _cmpOnInit = _cmcOnInit config, + _cmpOnDispose = _cmcOnDispose config, + _cmpOnResize = _cmcOnResize config, + _cmpOnChangeReq = _cmcOnChangeReq config, + _cmpOnEnabledChange = _cmcOnEnabledChange config, + _cmpOnVisibleChange = _cmcOnVisibleChange config + } + state = CompositeState Nothing widgetRoot M.empty + widget = createComposite composite state + newNode = defaultWidgetNode wType widget + +createComposite + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> Widget sp ep +createComposite comp state = widget where + widget = Widget { + widgetInit = compositeInit comp state, + widgetMerge = compositeMerge comp state, + widgetDispose = compositeDispose comp state, + widgetGetState = makeState state, + widgetGetInstanceTree = compositeGetInstanceTree comp state, + widgetFindNextFocus = compositeFindNextFocus comp state, + widgetFindByPoint = compositeFindByPoint comp state, + widgetFindBranchByPath = compositeFindBranchByPath comp state, + widgetHandleEvent = compositeHandleEvent comp state, + widgetHandleMessage = compositeHandleMessage comp state, + widgetGetSizeReq = compositeGetSizeReq comp state, + widgetResize = compositeResize comp state, + widgetRender = compositeRender comp state + } + +-- | Init +compositeInit + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> WidgetResult sp ep +compositeInit comp state wenv widgetComp = newResult where + CompositeState{..} = state + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + -- Creates UI using provided function + builtRoot = _cmpUiBuilder comp cwenv model + tempRoot = cascadeCtx wenv widgetComp builtRoot + + WidgetResult root reqs = widgetInit (tempRoot ^. L.widget) cwenv tempRoot + newEvts = RaiseEvent <$> Seq.fromList (_cmpOnInit comp) + newState = state { + _cpsModel = Just model, + _cpsRoot = root, + _cpsWidgetKeyMap = collectWidgetKeys M.empty root + } + + getBaseStyle wenv node = Nothing + styledComp = initNodeStyle getBaseStyle wenv widgetComp + tempResult = WidgetResult root (reqs <> newEvts) + newResult = toParentResult comp newState wenv styledComp tempResult + +-- | Merge +compositeMerge + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> WidgetNode sp ep + -> WidgetResult sp ep +compositeMerge comp state wenv newComp oldComp = newResult where + widgetId = oldComp ^. L.info . L.widgetId + oldState = widgetGetState (oldComp ^. L.widget) wenv oldComp + validState = fromMaybe state (useState oldState) + CompositeState oldModel oldRoot oldWidgetKeys = validState + model = getModel comp wenv + -- Creates new UI using provided function + cwenv = convertWidgetEnv wenv oldWidgetKeys model + tempRoot = cascadeCtx wenv newComp (_cmpUiBuilder comp cwenv model) + tempWidget = tempRoot ^. L.widget + -- 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 + visibleChg = oldComp ^. L.info . L.visible /= newComp ^. L.info . L.visible + enabledChg = oldComp ^. L.info . L.enabled /= newComp ^. L.info . L.enabled + flagsChanged = visibleChg || enabledChg + themeChanged = wenv ^. L.themeChanged + mergeRequired + | isJust oldModel = modelChanged || flagsChanged || themeChanged + | otherwise = True + initRequired = not (nodeMatches tempRoot oldRoot) + + WidgetResult newRoot tmpReqs + | initRequired = widgetInit tempWidget cwenv tempRoot + | mergeRequired = widgetMerge tempWidget cwenv tempRoot oldRoot + | otherwise = resultNode oldRoot + newState = validState { + _cpsModel = Just model, + _cpsRoot = newRoot, + _cpsWidgetKeyMap = collectWidgetKeys M.empty newRoot + } + getBaseStyle wenv node = Nothing + styledComp = initNodeStyle getBaseStyle wenv newComp + & L.info . L.widgetId .~ oldComp ^. L.info . L.widgetId + & L.info . L.viewport .~ oldComp ^. L.info . L.viewport + & L.info . L.sizeReqW .~ oldComp ^. L.info . L.sizeReqW + & L.info . L.sizeReqH .~ oldComp ^. L.info . L.sizeReqH + + visibleEvts = if visibleChg then _cmpOnVisibleChange comp else [] + enabledEvts = if enabledChg then _cmpOnEnabledChange comp else [] + mergeReqsFns = _cmpMergeReqs comp + mergeReqs = concatMap (\fn -> fn cwenv newRoot oldRoot model) mergeReqsFns + extraReqs = seqCatMaybes (toParentReq widgetId <$> Seq.fromList mergeReqs) + evts = RaiseEvent <$> Seq.fromList (visibleEvts ++ enabledEvts) + + tmpResult = WidgetResult newRoot (tmpReqs <> extraReqs <> evts) + reducedResult = toParentResult comp newState wenv styledComp tmpResult + newResult = handleWidgetIdChange oldComp reducedResult + +-- | Dispose +compositeDispose + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> WidgetResult sp ep +compositeDispose comp state wenv widgetComp = result where + CompositeState{..} = state + model = getModel comp wenv + 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) + result = toParentResult comp state wenv widgetComp tempResult + +compositeGetInstanceTree + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> WidgetInstanceNode +compositeGetInstanceTree comp state wenv node = instTree where + CompositeState{..} = state + widget = _cpsRoot ^. L.widget + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + cInstTree = widgetGetInstanceTree widget cwenv _cpsRoot + instTree = WidgetInstanceNode { + _winInfo = node ^. L.info, + _winState = Just (WidgetState state), + _winChildren = Seq.singleton cInstTree + } + +-- | Next focusable +compositeFindNextFocus + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> FocusDirection + -> Path + -> Maybe WidgetNodeInfo +compositeFindNextFocus comp state wenv widgetComp dir start = nextFocus where + CompositeState{..} = state + widget = _cpsRoot ^. L.widget + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + nextFocus = widgetFindNextFocus widget cwenv _cpsRoot dir start + +-- | Find +compositeFindByPoint + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> Path + -> Point + -> Maybe WidgetNodeInfo +compositeFindByPoint comp state wenv widgetComp start point + | widgetComp ^. L.info . L.visible && validStep = resultInfo + | otherwise = Nothing + where + CompositeState{..} = state + widget = _cpsRoot ^. L.widget + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + next = nextTargetStep widgetComp start + validStep = isNothing next || next == Just 0 + resultInfo = widgetFindByPoint widget cwenv _cpsRoot start point + +compositeFindBranchByPath + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> Path + -> Seq WidgetNodeInfo +compositeFindBranchByPath comp state wenv widgetComp path + | info ^. L.path == path = Seq.singleton info + | nextStep == Just 0 = info <| childrenInst + | otherwise = Seq.empty + where + CompositeState{..} = state + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + info = widgetComp ^. L.info + nextStep = nextTargetStep widgetComp path + child = _cpsRoot + childrenInst = widgetFindBranchByPath (child ^. L.widget) cwenv child path + +-- | Event handling +compositeHandleEvent + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> Path + -> SystemEvent + -> Maybe (WidgetResult sp ep) +compositeHandleEvent comp state wenv widgetComp target evt = result where + CompositeState{..} = state + widget = _cpsRoot ^. L.widget + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + rootEnabled = _cpsRoot ^. L.info . L.enabled + compVisible = widgetComp ^. L.info . L.visible + compEnabled = widgetComp ^. L.info . L.enabled + + processEvent = toParentResult comp state wenv widgetComp + evtResult + | not (compVisible && compEnabled) = Nothing + | rootEnabled = widgetHandleEvent widget cwenv _cpsRoot target evt + | otherwise = Nothing + result = fmap processEvent evtResult + +-- | Message handling +compositeHandleMessage + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp, Typeable i) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> Path + -> i + -> Maybe (WidgetResult sp ep) +compositeHandleMessage comp state@CompositeState{..} wenv widgetComp target arg + | isTargetReached widgetComp target = case cast arg of + Just evt -> Just $ handleMsgEvent comp state wenv widgetComp evt + Nothing -> case cast arg of + Just (CompMsgUpdate msg) -> handleMsgUpdate comp state wenv widgetComp <$> cast msg + _ -> traceShow ("Failed match on Composite handleEvent", typeOf arg) Nothing + | otherwise = fmap processEvent result where + processEvent = toParentResult comp state wenv widgetComp + cmpWidget = _cpsRoot ^. L.widget + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + result = widgetHandleMessage cmpWidget cwenv _cpsRoot target arg + +-- Preferred size +compositeGetSizeReq + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> (SizeReq, SizeReq) +compositeGetSizeReq comp state wenv widgetComp = (newReqW, newReqH) where + CompositeState{..} = state + style = currentStyle wenv widgetComp + widget = _cpsRoot ^. L.widget + currReqW = _cpsRoot ^. L.info . L.sizeReqW + currReqH = _cpsRoot ^. L.info . L.sizeReqH + (tmpReqW, tmpReqH) = sizeReqAddStyle style (currReqW, currReqH) + -- User settings take precedence + newReqW = fromMaybe tmpReqW (style ^. L.sizeReqW) + newReqH = fromMaybe tmpReqH (style ^. L.sizeReqH) + +-- Preferred size +updateSizeReq + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> WidgetNode sp ep +updateSizeReq comp state wenv widgetComp = newComp where + (newReqW, newReqH) = compositeGetSizeReq comp state wenv widgetComp + newComp = widgetComp + & L.info . L.sizeReqW .~ newReqW + & L.info . L.sizeReqH .~ newReqH + +-- Resize +compositeResize + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> Rect + -> (Path -> Bool) + -> WidgetResult sp ep +compositeResize comp state wenv widgetComp viewport rszReq = resizedRes where + CompositeState{..} = state + style = currentStyle wenv widgetComp + carea = fromMaybe def (removeOuterBounds style viewport) + widget = _cpsRoot ^. L.widget + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + + WidgetResult newRoot newReqs = widgetResize widget cwenv _cpsRoot carea rszReq + oldVp = widgetComp ^. L.info . L.viewport + sizeChanged = viewport /= oldVp + resizeEvts = fmap ($ viewport) (_cmpOnResize comp) + resizeReqs + | sizeChanged = RaiseEvent <$> Seq.fromList resizeEvts + | otherwise = Empty + + childRes = WidgetResult newRoot (newReqs <> resizeReqs) + & L.node . L.info . L.viewport .~ carea + resizedRes = toParentResult comp state wenv widgetComp childRes + & L.node . L.info . L.viewport .~ viewport + +-- Render +compositeRender + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> Renderer + -> IO () +compositeRender comp state wenv widgetComp renderer = action where + CompositeState{..} = state + widget = _cpsRoot ^. L.widget + model = getModel comp wenv + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + action = widgetRender widget cwenv _cpsRoot renderer + +handleMsgEvent + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> e + -> WidgetResult sp ep +handleMsgEvent comp state wenv widgetComp event = newResult where + CompositeState{..} = state + model + | isJust _cpsModel = fromJust _cpsModel + | otherwise = getModel comp wenv + evtHandler = _cmpEventHandler comp + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model + response = evtHandler cwenv _cpsRoot model event + newReqs = evtResponseToRequest widgetComp _cpsWidgetKeyMap <$> response + newResult = WidgetResult widgetComp (Seq.fromList (catMaybes newReqs)) + +handleMsgUpdate + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> (s -> s) + -> WidgetResult sp ep +handleMsgUpdate comp state wenv widgetComp fnUpdate = result where + CompositeState{..} = state + model + | isJust _cpsModel = fromJust _cpsModel + | otherwise = getModel comp wenv + newModel = fnUpdate model + result + | model == newModel = resultNode widgetComp + | otherwise = mergeChild comp state wenv newModel _cpsRoot widgetComp + +toParentResult + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> WidgetNode sp ep + -> WidgetResult s e + -> WidgetResult sp ep +toParentResult comp state wenv widgetComp result = newResult where + WidgetResult newRoot reqs = result + widgetId = widgetComp ^. L.info . L.widgetId + newState = state { + _cpsRoot = newRoot + } + newComp = widgetComp + & L.widget .~ createComposite comp newState + newNode = updateSizeReq comp newState wenv newComp + newReqs = seqCatMaybes (toParentReq widgetId <$> reqs) + newResult = WidgetResult newNode newReqs + +evtResponseToRequest + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => WidgetNode sp ep + -> WidgetKeyMap s e + -> EventResponse s e sp ep + -> Maybe (WidgetRequest sp ep) +evtResponseToRequest widgetComp widgetKeys response = case response of + Model newModel -> Just $ sendTo widgetComp (CompMsgUpdate $ const newModel) + Event event -> Just $ sendTo widgetComp event + Report report -> Just (RaiseEvent report) + Request req -> toParentReq widgetId req + RequestParent req -> Just req + Message key msg -> (`sendTo` msg) <$> M.lookup key widgetKeys + Task task -> Just $ RunTask widgetId path task + Producer producer -> Just $ RunProducer widgetId path producer + where + sendTo node msg = SendMessage (node ^. L.info . L.widgetId) msg + widgetId = widgetComp ^. L.info . L.widgetId + path = widgetComp ^. L.info . L.path + +mergeChild + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> CompositeState s e + -> WidgetEnv sp ep + -> s + -> WidgetNode s e + -> WidgetNode sp ep + -> WidgetResult sp ep +mergeChild comp state wenv newModel widgetRoot widgetComp = newResult where + CompositeState{..} = state + cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap newModel + builtRoot = cascadeCtx wenv widgetComp (_cmpUiBuilder comp cwenv newModel) + & L.info . L.widgetId .~ _cpsRoot ^. L.info . L.widgetId + builtWidget = builtRoot ^. L.widget + mergedResult = widgetMerge builtWidget cwenv builtRoot widgetRoot + mergedState = state { + _cpsModel = Just newModel, + _cpsRoot = mergedResult ^. L.node, + _cpsWidgetKeyMap = collectWidgetKeys M.empty (mergedResult ^. L.node) + } + result = toParentResult comp mergedState wenv widgetComp mergedResult + newReqs = widgetDataSet (_cmpWidgetData comp) newModel + ++ fmap ($ newModel) (_cmpOnChangeReq comp) + newResult = result + & L.requests <>~ Seq.fromList newReqs + +getModel + :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, ParentModel sp) + => Composite s e sp ep + -> WidgetEnv sp ep + -> s +getModel comp wenv = widgetDataGet (_weModel wenv) (_cmpWidgetData comp) + +toParentReq + :: (CompositeModel s, ParentModel sp) + => WidgetId + -> WidgetRequest s e + -> Maybe (WidgetRequest sp ep) +toParentReq _ IgnoreParentEvents = Just IgnoreParentEvents +toParentReq _ IgnoreChildrenEvents = Just IgnoreChildrenEvents +toParentReq _ (ResizeWidgets wid) = Just (ResizeWidgets wid) +toParentReq _ (ResizeWidgetsImmediate wid) = Just (ResizeWidgetsImmediate wid) +toParentReq _ (MoveFocus start dir) = Just (MoveFocus start dir) +toParentReq _ (SetFocus path) = Just (SetFocus path) +toParentReq _ (GetClipboard path) = Just (GetClipboard path) +toParentReq _ (SetClipboard clipboard) = Just (SetClipboard clipboard) +toParentReq _ (StartTextInput rect) = Just (StartTextInput rect) +toParentReq _ StopTextInput = Just StopTextInput +toParentReq _ (ResetOverlay wid) = Just (ResetOverlay wid) +toParentReq _ (SetOverlay wid path) = Just (SetOverlay wid path) +toParentReq _ (SetCursorIcon wid icon) = Just (SetCursorIcon wid icon) +toParentReq _ (ResetCursorIcon wid) = Just (ResetCursorIcon wid) +toParentReq _ (StartDrag wid path info) = Just (StartDrag wid path info) +toParentReq _ (StopDrag wid) = Just (StopDrag wid) +toParentReq _ RenderOnce = Just RenderOnce +toParentReq _ (RenderEvery path ms repeat) = Just (RenderEvery path ms repeat) +toParentReq _ (RenderStop path) = Just (RenderStop path) +toParentReq _ (RemoveRendererImage name) = Just (RemoveRendererImage name) +toParentReq _ (ExitApplication exit) = Just (ExitApplication exit) +toParentReq _ (UpdateWindow req) = Just (UpdateWindow req) +toParentReq _ (SetWidgetPath wid path) = Just (SetWidgetPath wid path) +toParentReq _ (ResetWidgetPath wid) = Just (ResetWidgetPath wid) +toParentReq wid (UpdateModel fn) = Just (SendMessage wid (CompMsgUpdate fn)) +toParentReq wid (RaiseEvent message) = Just (SendMessage wid message) +toParentReq _ (SendMessage wid message) = Just (SendMessage wid message) +toParentReq _ (RunTask wid path action) = Just (RunTask wid path action) +toParentReq _ (RunProducer wid path action) = Just (RunProducer wid path action) + +collectWidgetKeys + :: Map WidgetKey (WidgetNode s e) + -> WidgetNode s e + -> Map WidgetKey (WidgetNode s e) +collectWidgetKeys keys node = newMap where + children = node ^. L.children + collect currKeys child = collectWidgetKeys currKeys child + updatedMap = case node ^. L.info . L.key of + Just key -> M.insert key node keys + _ -> keys + newMap = foldl' collect updatedMap children + +convertWidgetEnv :: WidgetEnv sp ep -> WidgetKeyMap s e -> s -> WidgetEnv s e +convertWidgetEnv wenv widgetKeyMap model = WidgetEnv { + _weOs = _weOs wenv, + _weFontManager = _weFontManager wenv, + _weFindByPath = _weFindByPath wenv, + _weMainButton = _weMainButton wenv, + _weContextButton = _weContextButton wenv, + _weTheme = _weTheme wenv, + _weWindowSize = _weWindowSize wenv, + _weWidgetShared = _weWidgetShared wenv, + _weWidgetKeyMap = widgetKeyMap, + _weCursor = _weCursor wenv, + _weHoveredPath = _weHoveredPath wenv, + _weFocusedPath = _weFocusedPath wenv, + _weDragStatus = _weDragStatus wenv, + _weMainBtnPress = _weMainBtnPress wenv, + _weOverlayPath = _weOverlayPath wenv, + _weModel = model, + _weInputStatus = _weInputStatus wenv, + _weTimestamp = _weTimestamp wenv, + _weThemeChanged = _weThemeChanged wenv, + _weInTopLayer = _weInTopLayer wenv, + _weLayoutDirection = LayoutNone, + _weViewport = _weViewport wenv, + _weOffset = _weOffset wenv +} + +cascadeCtx + :: WidgetEnv sp ep -> WidgetNode sp ep -> WidgetNode s e -> WidgetNode s e +cascadeCtx wenv parent child = newChild where + pVisible = parent ^. L.info . L.visible + pEnabled = parent ^. L.info . L.enabled + cVisible = child ^. L.info . L.visible + cEnabled = child ^. L.info . L.enabled + newPath = parent ^. L.info . L.path |> 0 + newChild = child + & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) newPath + & L.info . L.path .~ newPath + & L.info . L.visible .~ (cVisible && pVisible) + & L.info . L.enabled .~ (cEnabled && pEnabled) diff --git a/src/Monomer/Widgets/Container.hs b/src/Monomer/Widgets/Container.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Container.hs @@ -0,0 +1,1152 @@ +{-| +Module : Monomer.Widgets.Container +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper for creating widgets with children elements. +-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Container ( + module Monomer.Core, + module Monomer.Core.Combinators, + module Monomer.Event, + module Monomer.Graphics, + module Monomer.Widgets.Util, + + ContainerGetBaseStyle, + ContainerGetCurrentStyle, + ContainerUpdateCWenvHandler, + ContainerInitHandler, + ContainerInitPostHandler, + ContainerMergeChildrenReqHandler, + ContainerMergeHandler, + ContainerMergePostHandler, + ContainerDisposeHandler, + ContainerFindNextFocusHandler, + ContainerFindByPointHandler, + ContainerFilterHandler, + ContainerEventHandler, + ContainerMessageHandler, + ContainerGetSizeReqHandler, + ContainerResizeHandler, + ContainerRenderHandler, + + Container(..), + createContainer, + updateWenvOffset +) where + +import Control.Applicative ((<|>)) +import Control.Exception (AssertionFailed(..), throw) +import Control.Lens ((&), (^.), (^?), (.~), (%~), (<>~), _Just) +import Control.Monad +import Data.Default +import Data.Foldable (fold, foldl') +import Data.Maybe +import Data.Map.Strict (Map) +import Data.Typeable (Typeable) +import Data.Sequence (Seq(..), (<|), (|>)) + +import qualified Data.Map.Strict as M +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics +import Monomer.Widgets.Util + +import qualified Monomer.Lens as L + +{-| +Returns the base style for this type of widget. + +Usually this style comes from the active theme. +-} +type ContainerGetBaseStyle s e + = GetBaseStyle s e -- ^ The base style for a new node. + +{-| +Returns the active style for this type of widget. It depends on the state of +the widget, which can be: + +- Basic +- Hovered +- Focused +- Hovered and Focused +- Active +- Disabled + +In general there's no needed to override it, except when the widget does not use +the full content rect. + +An example can be found in "Monomer.Widgets.Containers.Tooltip". +-} +type ContainerGetCurrentStyle s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> StyleState -- ^ The active style for the node. + +{-| +Updates the widget environment before passing it down to children. This function +is called during the execution of all the widget functions. Useful for +restricting viewport or modifying other kind of contextual information. + +An example can be found in "Monomer.Widgets.Containers.ThemeSwitch". +-} +type ContainerUpdateCWenvHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetNode s e -- ^ The child node. + -> Int -- ^ The index of the node. + -> WidgetEnv s e -- ^ The updated widget environment. + +{-| +Initializes the given node. This could include rebuilding the widget in case +internal state needs to use model/environment information, generate user +events or make requests to the runtime. + +An example can be found in "Monomer.Widgets.Containers.SelectList". + +Most of the current containers serve layout purposes and don't need a custom +/init/. +-} +type ContainerInitHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetResult s e -- ^ The result of the init operation. + +{-| +Allows making further operations after children have been initialized. + +Note: if state was modified on `init`, you should use the new state provided as +an argument, since the state referenced in the closure will be outdated. +-} +type ContainerInitPostHandler s e a + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> a -- ^ The current state of the widget node. + -> WidgetResult s e -- ^ The result after children have been initialized. + -> WidgetResult s e -- ^ The result of the init post operation. + +{-| +Returns whether merge is required for children. It's mostly used for performance +optimization. + +An example can be found in "Monomer.Widgets.Containers.SelectList". +-} +type ContainerMergeChildrenReqHandler s e a + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetNode s e -- ^ The previous widget node. + -> a -- ^ The state of the previous widget node. + -> Bool -- ^ True if widget is needed. + +{-| +Merges the current node with the node it matched with during the merge process. +Receives the newly created node (whose *init* function is not called), the +previous node and the state extracted from that node. This process is widget +dependent, and may use or ignore the previous state depending on newly available +information. + +In general, you want to at least keep the previous state unless the widget is +stateless or only consumes model/environment information. + +Examples can be found in "Monomer.Widgets.Containers.Fade" and +"Monomer.Widgets.Containers.Tooltip". On the other hand, +"Monomer.Widgets.Containers.Grid" does not need to override merge since it's +stateless. +-} +type ContainerMergeHandler s e a + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetNode s e -- ^ The previous widget node. + -> a -- ^ The state of the previous widget node. + -> WidgetResult s e -- ^ The result of the merge operation. + +{-| +Allows making further operations after children have been merged. + +Examples can be found in "Monomer.Widgets.Containers.SelectList" and +"Monomer.Widgets.Containers.ZStack". + +Note: if state was modified during merge, you should use the new state provided +as an argument, since the state referenced in the closure will be outdated. +-} +type ContainerMergePostHandler s e a + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetNode s e -- ^ The previous widget node. + -> a -- ^ The state of the previous widget node. + -> a -- ^ The current state of the widget node. + -> WidgetResult s e -- ^ The result after children have been merged. + -> WidgetResult s e -- ^ The result of the merge post operation. + +{-| +Disposes the current node. Only used by widgets which allocate resources during +/init/ or /merge/, and will usually involve requests to the runtime. + +An example can be found "Monomer.Widgets.Containers.Dropdown". +-} +type ContainerDisposeHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetResult s e -- ^ The result of the dispose operation. + +{-| +Returns the next focusable node. What next/previous is, depends on how the +container works. Moving right -> bottom is usually considered forward. +-} +type ContainerFindNextFocusHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> FocusDirection -- ^ The direction in which focus is moving. + -> Path -- ^ The start path from which to search. + -> Seq (WidgetNode s e) -- ^ The next focusable node info. + +{-| +Returns the currently hovered widget, if any. If the widget is rectangular and +uses the full content area, there is not need to override this function. + +An example can be found "Monomer.Widgets.Containers.Dropdown". +-} +type ContainerFindByPointHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Path -- ^ The start path from which to search. + -> Point -- ^ The point to test for. + -> Maybe Int -- ^ The hovered child index, if any. + +{-| +Receives a System event and, optionally, modifies the event, its target, or +cancels the event propagation by returning null. + +Examples can be found in "Monomer.Widgets.Containers.Base.LabeledItem". +-} +type ContainerFilterHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Path -- ^ The target path of the event. + -> SystemEvent -- ^ The SystemEvent to handle. + -> Maybe (Path, SystemEvent) -- ^ The optional modified event/target. + +{-| +Receives a System event and, optionally, returns a result. This can include an +updated version of the widget (in case it has internal state), user events or +requests to the runtime. + +Examples can be found in "Monomer.Widgets.Containers.Draggable" and +"Monomer.Widgets.Containers.Keystroke". +-} +type ContainerEventHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Path -- ^ The target path of the event. + -> SystemEvent -- ^ The SystemEvent to handle. + -> Maybe (WidgetResult s e) -- ^ The result of handling the event, if any. + +{-| +Receives a message and, optionally, returns a result. This can include an +updated version of the widget (in case it has internal state), user events or +requests to the runtime. There is no validation regarding the message type, and +the widget should take care of _casting_ to the correct type using +"Data.Typeable.cast" + +Examples can be found in "Monomer.Widgets.Containers.Fade" and +"Monomer.Widgets.Containers.Scroll". +-} +type ContainerMessageHandler s e + = forall i . Typeable i + => WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Path -- ^ The target path of the message. + -> i -- ^ The message to handle. + -> Maybe (WidgetResult s e) -- ^ The result of handling the message, if any. + +{-| +Returns the preferred size for the widget. This size should not include border +and padding; those are added automatically by Container. + +This is called to update WidgetNodeInfo only at specific times. + +Examples can be found in "Monomer.Widgets.Containers.Grid" and +"Monomer.Widgets.Containers.Stack". +-} +type ContainerGetSizeReqHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Seq (WidgetNode s e) -- ^ The children widgets + -> (SizeReq, SizeReq) -- ^ The horizontal and vertical requirements. + +{-| +Resizes the widget to the provided size. If the widget state does not depend +on the viewport size, this function does not need to be overriden. + +Examples can be found in "Monomer.Widgets.Containers.Grid" and +"Monomer.Widgets.Containers.Stack". +-} +type ContainerResizeHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Rect -- ^ The new viewport. + -> Seq (WidgetNode s e) -- ^ The children widgets + -> (WidgetResult s e, Seq Rect) -- ^ The result of resizing the widget. + +{-| +Renders the widget's content using the given Renderer. In general, this method +needs to be overriden. There are two render methods: one runs before children, +the other one after. + +Examples can be found in "Monomer.Widgets.Containers.Draggable" and +"Monomer.Widgets.Containers.Scroll". +-} +type ContainerRenderHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Renderer -- ^ The renderer, providing low level drawing functions. + -> IO () -- ^ The IO action with rendering instructions. + +-- | Interface for Container widgets. +data Container s e a = Container { + -- | True if border and padding should be added to size requirement. Defaults + -- to True. + containerAddStyleReq :: Bool, + -- | Offset to apply to children. This not only includes rendering, but also + -- updating SystemEvents and all coordinate related functions. + containerChildrenOffset :: Maybe Point, + -- | Scissor to apply to child widgets. This is not the same as the widget + -- enabled by containerUseScissor + containerChildrenScissor :: Maybe Rect, + -- | The layout direction generated by this widget. If one is indicated, it + -- can be used by widgets such as "Monomer.Widgets.Singles.Spacer" + containerLayoutDirection :: LayoutDirection, + -- | If True, when none of the children is found under the pointer, indicates + -- an event will not be handled. If False, the parent (i.e., current) widget + -- will be returned. This is useful when using zstack and wanting for events + -- to be handled in lower layers. + containerIgnoreEmptyArea :: Bool, + -- | True if style cursor should be ignored. If it's False, cursor changes need + -- to be handled in custom code. Defaults to False. + containerUseCustomCursor :: Bool, + -- | If true, it will ignore extra space assigned by the parent container, but + -- it will not use more space than assigned. Defaults to False. + containerUseCustomSize :: Bool, + -- | If true, it will accept the size requested by children, restricted to the + -- space already assigned. + containerUseChildrenSizes :: Bool, + -- | True if automatic scissoring needs to be applied. Defaults to False. + containerUseScissor :: Bool, + -- | Returns the base style for this type of widget. + containerGetBaseStyle :: ContainerGetBaseStyle s e, + -- | Returns the current style, depending on the status of the widget. + containerGetCurrentStyle :: ContainerGetCurrentStyle s e, + -- | Updates the widget environment before passing it down to children. + containerUpdateCWenv :: ContainerUpdateCWenvHandler s e, + -- | Initializes the given node. + containerInit :: ContainerInitHandler s e, + -- | Allow for extra steps after children are initialized. + containerInitPost :: ContainerInitPostHandler s e a, + -- | Returns whether merge is required for children. + containerMergeChildrenReq :: ContainerMergeChildrenReqHandler s e a, + -- | Merges the node with the node it matched with during the merge process. + containerMerge :: ContainerMergeHandler s e a, + -- | Allow for extra steps after children are merged. + containerMergePost :: ContainerMergePostHandler s e a, + -- | Disposes the current node. + containerDispose :: ContainerDisposeHandler s e, + -- | Returns the next focusable node. + containerFindNextFocus :: ContainerFindNextFocusHandler s e, + -- | Returns the currently hovered widget, if any. + containerFindByPoint :: ContainerFindByPointHandler s e, + -- | Receives a System event and, optionally, filters/modifies it. + containerFilterEvent :: ContainerFilterHandler s e, + -- | Receives a System event and, optionally, returns a result. + containerHandleEvent :: ContainerEventHandler s e, + -- | Receives a message and, optionally, returns a result. + containerHandleMessage :: ContainerMessageHandler s e, + -- | Returns the preferred size for the widget. + containerGetSizeReq :: ContainerGetSizeReqHandler s e, + -- | Resizes the widget to the provided size. + containerResize :: ContainerResizeHandler s e, + -- | Renders the widget's content. This runs before childrens' render. + containerRender :: ContainerRenderHandler s e, + -- | Renders the widget's content. This runs after childrens' render. + containerRenderAfter :: ContainerRenderHandler s e +} + +instance Default (Container s e a) where + def = Container { + containerAddStyleReq = True, + containerChildrenOffset = Nothing, + containerChildrenScissor = Nothing, + containerLayoutDirection = LayoutNone, + containerIgnoreEmptyArea = False, + containerUseCustomCursor = False, + containerUseCustomSize = False, + containerUseChildrenSizes = False, + containerUseScissor = False, + containerGetBaseStyle = defaultGetBaseStyle, + containerGetCurrentStyle = defaultGetCurrentStyle, + containerUpdateCWenv = defaultUpdateCWenv, + containerInit = defaultInit, + containerInitPost = defaultInitPost, + containerMergeChildrenReq = defaultMergeRequired, + containerMerge = defaultMerge, + containerMergePost = defaultMergePost, + containerDispose = defaultDispose, + containerFindNextFocus = defaultFindNextFocus, + containerFindByPoint = defaultFindByPoint, + containerFilterEvent = defaultFilterEvent, + containerHandleEvent = defaultHandleEvent, + containerHandleMessage = defaultHandleMessage, + containerGetSizeReq = defaultGetSizeReq, + containerResize = defaultResize, + containerRender = defaultRender, + containerRenderAfter = defaultRender + } + +{-| +Creates a widget based on the Container infrastructure. An initial state and the +Container definition need to be provided. In case internal state is not needed, +__()__ can be provided. Using the __def__ instance as a starting point is +recommended to focus on overriding only what is needed: + +@ +widget = createContainer () def { + containerRender = ... +} +@ +-} +createContainer + :: WidgetModel a + => a + -> Container s e a + -> Widget s e +createContainer state container = Widget { + widgetInit = initWrapper container, + widgetMerge = mergeWrapper container, + widgetDispose = disposeWrapper container, + widgetGetState = makeState state, + widgetGetInstanceTree = getInstanceTreeWrapper container, + widgetFindNextFocus = findNextFocusWrapper container, + widgetFindByPoint = findByPointWrapper container, + widgetFindBranchByPath = containerFindBranchByPath, + widgetHandleEvent = handleEventWrapper container, + widgetHandleMessage = handleMessageWrapper container, + widgetGetSizeReq = getSizeReqWrapper container, + widgetResize = resizeWrapper container, + widgetRender = renderWrapper container +} + +-- | Get base style for component +defaultGetBaseStyle :: ContainerGetBaseStyle s e +defaultGetBaseStyle wenv node = Nothing + +defaultGetCurrentStyle :: ContainerGetCurrentStyle s e +defaultGetCurrentStyle wenv node = currentStyle wenv node + +defaultUpdateCWenv :: ContainerUpdateCWenvHandler s e +defaultUpdateCWenv wenv node cnode cidx = wenv + +getUpdateCWenv + :: Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e + -> Int + -> WidgetEnv s e +getUpdateCWenv container wenv node cnode cidx = newWenv where + cOffset = containerChildrenOffset container + updateCWenv = containerUpdateCWenv container + layoutDirection = containerLayoutDirection container + offsetWenv wenv + | isJust cOffset = updateWenvOffset container wenv node + | otherwise = wenv + directionWenv = wenv + & L.layoutDirection .~ layoutDirection + newWenv = updateCWenv (offsetWenv directionWenv) node cnode cidx + +{-| +Helper function that updates widget environment based on current container +information. In case the created container needs to pass information down using +wenv, it should call this function first and update the resulting wenv. +-} +updateWenvOffset + :: Container s e a -- ^ The container config + -> WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetEnv s e -- ^ THe updated widget environment. +updateWenvOffset container wenv node = newWenv where + cOffset = containerChildrenOffset container + offset = fromMaybe def cOffset + accumOffset = addPoint offset (wenv ^. L.offset) + viewport = node ^. L.info . L.viewport + updateMain (path, point) + | isNodeParentOfPath node path = (path, addPoint (negPoint offset) point) + | otherwise = (path, point) + newWenv = wenv + & L.viewport .~ moveRect (negPoint offset) viewport + & L.inputStatus . L.mousePos %~ addPoint (negPoint offset) + & L.inputStatus . L.mousePosPrev %~ addPoint (negPoint offset) + & L.offset %~ addPoint offset + & L.mainBtnPress %~ fmap updateMain + +-- | Init handler +defaultInit :: ContainerInitHandler s e +defaultInit wenv node = resultNode node + +defaultInitPost :: ContainerInitPostHandler s e a +defaultInitPost wenv node state result = result + +initWrapper + :: WidgetModel a + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetResult s e +initWrapper container wenv node = result where + initHandler = containerInit container + initPostHandler = containerInitPost container + getBaseStyle = containerGetBaseStyle container + updateCWenv = getUpdateCWenv container + + styledNode = initNodeStyle getBaseStyle wenv node + WidgetResult tempNode reqs = initHandler wenv styledNode + children = tempNode ^. L.children + initChild idx child = widgetInit newWidget cwenv newChild where + newChild = cascadeCtx wenv tempNode child idx + cwenv = updateCWenv wenv node newChild idx + newWidget = newChild ^. L.widget + results = Seq.mapWithIndex initChild children + newReqs = foldMap _wrRequests results + newChildren = fmap _wrNode results + newNode = updateSizeReq wenv $ tempNode + & L.children .~ newChildren + + tmpResult = WidgetResult newNode (reqs <> newReqs) + newState = widgetGetState (newNode ^. L.widget) wenv newNode + result = case useState newState of + Just st -> initPostHandler wenv newNode st tmpResult + Nothing -> tmpResult + +-- | Merging +defaultMergeRequired :: ContainerMergeChildrenReqHandler s e a +defaultMergeRequired wenv newNode oldNode oldState = True + +defaultMerge :: ContainerMergeHandler s e a +defaultMerge wenv newNode oldNode oldState = resultNode newNode + +defaultMergePost :: ContainerMergePostHandler s e a +defaultMergePost wenv newNode oldNode oldState newState result = result + +mergeWrapper + :: WidgetModel a + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e + -> WidgetResult s e +mergeWrapper container wenv newNode oldNode = newResult where + getBaseStyle = containerGetBaseStyle container + updateCWenv = getUpdateCWenv container + mergeRequiredHandler = containerMergeChildrenReq container + mergeHandler = containerMerge container + mergePostHandler = containerMergePost container + + oldState = widgetGetState (oldNode ^. L.widget) wenv oldNode + mergeRequired = case useState oldState of + Just state -> mergeRequiredHandler wenv newNode oldNode state + Nothing -> True + + styledNode = initNodeStyle getBaseStyle wenv newNode + cWenvHelper idx child = cwenv where + cwenv = updateCWenv wenv (pResult ^. L.node) child idx + + pResult = mergeParent mergeHandler wenv styledNode oldNode oldState + cResult = mergeChildren cWenvHelper wenv newNode oldNode pResult + vResult = mergeChildrenCheckVisible oldNode cResult + + flagsChanged = nodeFlagsChanged oldNode newNode + themeChanged = wenv ^. L.themeChanged + mResult + | mergeRequired || flagsChanged || themeChanged = vResult + | otherwise = pResult & L.node . L.children .~ oldNode ^. L.children + + mNode = mResult ^. L.node + mState = widgetGetState (mNode ^. L.widget) wenv mNode + postRes = case (,) <$> useState oldState <*> useState mState of + Just (ost, st) -> mergePostHandler wenv mNode oldNode ost st mResult + Nothing -> resultNode (mResult ^. L.node) + + tmpResult + | isResizeAnyResult (Just postRes) = postRes + & L.node .~ updateSizeReq wenv (postRes ^. L.node) + | otherwise = postRes + newResult = handleWidgetIdChange oldNode tmpResult + +mergeParent + :: WidgetModel a + => ContainerMergeHandler s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e + -> Maybe WidgetState + -> WidgetResult s e +mergeParent mergeHandler wenv newNode oldNode oldState = result where + oldInfo = oldNode ^. L.info + tempNode = newNode + & L.info . L.widgetId .~ oldInfo ^. L.widgetId + & L.info . L.viewport .~ oldInfo ^. L.viewport + & L.info . L.sizeReqW .~ oldInfo ^. L.sizeReqW + & L.info . L.sizeReqH .~ oldInfo ^. L.sizeReqH + result = case useState oldState of + Just state -> mergeHandler wenv tempNode oldNode state + Nothing -> resultNode tempNode + +mergeChildren + :: (Int -> WidgetNode s e -> WidgetEnv s e) + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e + -> WidgetResult s e + -> WidgetResult s e +mergeChildren updateCWenv wenv newNode oldNode result = newResult where + WidgetResult uNode uReqs = result + oldChildren = oldNode ^. L.children + oldIts = Seq.mapWithIndex (,) oldChildren + updatedChildren = uNode ^. L.children + + mergeChild idx child = (idx, cascadeCtx wenv uNode child idx) + newIts = Seq.mapWithIndex mergeChild updatedChildren + oldKeys = buildLocalMap oldChildren + newKeys = buildLocalMap (snd <$> newIts) + + mpairs = mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts + (mergedResults, removedResults) = mpairs + mergedChildren = fmap _wrNode mergedResults + mergedReqs = foldMap _wrRequests mergedResults + removedReqs = foldMap _wrRequests removedResults + mergedNode = uNode & L.children .~ mergedChildren + newReqs = uReqs <> mergedReqs <> removedReqs + newResult = WidgetResult mergedNode newReqs + +mergeChildSeq + :: (Int -> WidgetNode s e -> WidgetEnv s e) + -> WidgetEnv s e + -> WidgetKeyMap s e + -> WidgetKeyMap s e + -> WidgetNode s e + -> Seq (Int, WidgetNode s e) + -> Seq (Int, WidgetNode s e) + -> (Seq (WidgetResult s e), Seq (WidgetResult s e)) +mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts Empty = res where + dispose (idx, child) = case flip M.member newKeys <$> child^. L.info. L.key of + Just True -> WidgetResult child Empty + _ -> widgetDispose (child ^. L.widget) wenv child + removed = fmap dispose oldIts + res = (Empty, removed) +mergeChildSeq updateCWenv wenv oldKeys newKeys newNode Empty newIts = res where + init (idx, child) = widgetInit (child ^. L.widget) wenv child + merged = fmap init newIts + res = (merged, Empty) +mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts = res where + (_, oldChild) :<| oldChildren = oldIts + (newIdx, newChild) :<| newChildren = newIts + newWidget = newChild ^. L.widget + newWidgetId = newChild ^. L.info . L.widgetId + newChildKey = newChild ^. L.info . L.key + cwenv = updateCWenv newIdx newChild + + oldKeyMatch = newChildKey >>= \key -> M.lookup key oldKeys + oldMatch = fromJust oldKeyMatch + isMergeKey = isJust oldKeyMatch && nodeMatches newChild oldMatch + + mergedOld = widgetMerge newWidget cwenv newChild oldChild + mergedKey = widgetMerge newWidget cwenv newChild oldMatch + initNew = widgetInit newWidget cwenv newChild + & L.requests %~ (|> ResizeWidgets newWidgetId) + + (child, oldRest) + | nodeMatches newChild oldChild = (mergedOld, oldChildren) + | isMergeKey = (mergedKey, oldIts) + | otherwise = (initNew, oldIts) + + (cmerged, cremoved) + = mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldRest newChildren + merged = child <| cmerged + res = (merged, cremoved) + +mergeChildrenCheckVisible + :: WidgetNode s e + -> WidgetResult s e + -> WidgetResult s e +mergeChildrenCheckVisible oldNode result = newResult where + newNode = result ^. L.node + widgetId = newNode ^. L.info . L.widgetId + resizeRequired = childrenVisibleChanged oldNode newNode + newResult + | resizeRequired = result & L.requests %~ (|> ResizeWidgets widgetId) + | otherwise = result + +getInstanceTreeWrapper + :: WidgetModel a + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetInstanceNode +getInstanceTreeWrapper container wenv node = instNode where + updateCWenv = getUpdateCWenv container + instNode = WidgetInstanceNode { + _winInfo = node ^. L.info, + _winState = widgetGetState (node ^. L.widget) wenv node, + _winChildren = Seq.mapWithIndex getChildTree (node ^. L.children) + } + getChildTree idx child = tree where + cwenv = updateCWenv wenv node child idx + tree = widgetGetInstanceTree (child ^. L.widget) cwenv child + +-- | Dispose handler +defaultDispose :: ContainerInitHandler s e +defaultDispose wenv node = resultNode node + +disposeWrapper + :: Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetResult s e +disposeWrapper container wenv node = result where + updateCWenv = getUpdateCWenv container + disposeHandler = containerDispose container + + WidgetResult tempNode reqs = disposeHandler wenv node + widgetId = node ^. L.info . L.widgetId + children = tempNode ^. L.children + + dispose idx child = widgetDispose (child ^. L.widget) cwenv child where + cwenv = updateCWenv wenv node child idx + results = Seq.mapWithIndex dispose children + newReqs = foldMap _wrRequests results |> ResetWidgetPath widgetId + result = WidgetResult node (reqs <> newReqs) + +-- | Find next focusable item +defaultFindNextFocus :: ContainerFindNextFocusHandler s e +defaultFindNextFocus wenv node direction start = vchildren where + vchildren = Seq.filter (^. L.info . L.visible) (node ^. L.children) + +findNextFocusWrapper + :: Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> FocusDirection + -> Path + -> Maybe WidgetNodeInfo +findNextFocusWrapper container wenv node dir start = nextFocus where + handler = containerFindNextFocus container + handlerResult = handler wenv node dir start + children + | dir == FocusBwd = Seq.reverse handlerResult + | otherwise = handlerResult + nextFocus + | isFocusCandidate node start dir = Just (node ^. L.info) + | otherwise = findFocusCandidate container wenv dir start node children + +findFocusCandidate + :: Container s e a + -> WidgetEnv s e + -> FocusDirection + -> Path + -> WidgetNode s e + -> Seq (WidgetNode s e) + -> Maybe WidgetNodeInfo +findFocusCandidate _ _ _ _ _ Empty = Nothing +findFocusCandidate container wenv dir start node (ch :<| chs) = result where + updateCWenv = getUpdateCWenv container + path = node ^. L.info . L.path + idx = fromMaybe 0 (Seq.lookup (length path - 1) path) + cwenv = updateCWenv wenv node ch idx + isWidgetAfterStart + | dir == FocusBwd = isNodeBeforePath ch start + | otherwise = isNodeParentOfPath ch start || isNodeAfterPath ch start + + candidate = widgetFindNextFocus (ch ^. L.widget) cwenv ch dir start + result + | isWidgetAfterStart && isJust candidate = candidate + | otherwise = findFocusCandidate container wenv dir start node chs + +-- | Find instance matching point +defaultFindByPoint :: ContainerFindByPointHandler s e +defaultFindByPoint wenv node start point = result where + children = node ^. L.children + pointInWidget wi = wi ^. L.visible && pointInRect point (wi ^. L.viewport) + result = Seq.findIndexL (pointInWidget . _wnInfo) children + +findByPointWrapper + :: Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Path + -> Point + -> Maybe WidgetNodeInfo +findByPointWrapper container wenv node start point = result where + offset = fromMaybe def (containerChildrenOffset container) + updateCWenv = getUpdateCWenv container + ignoreEmpty = containerIgnoreEmptyArea container + handler = containerFindByPoint container + + isVisible = node ^. L.info . L.visible + inVp = isPointInNodeVp node point + cpoint = addPoint (negPoint offset) point + path = node ^. L.info . L.path + children = node ^. L.children + childIdx = nextTargetStep node start <|> handler wenv node start cpoint + validateIdx p + | Seq.length children > p && p >= 0 = Just p + | otherwise = Nothing + + win = case childIdx >>= validateIdx of + Just idx -> childWni where + cwenv = updateCWenv wenv node child idx + child = Seq.index children idx + childWidget = child ^. L.widget + childWni = widgetFindByPoint childWidget cwenv child start cpoint + Nothing + | not ignoreEmpty -> Just $ node ^. L.info + | otherwise -> Nothing + result + | isVisible && (inVp || fmap (^. L.path) win /= Just path) = win + | otherwise = Nothing + +containerFindBranchByPath + :: WidgetEnv s e + -> WidgetNode s e + -> Path + -> Seq WidgetNodeInfo +containerFindBranchByPath wenv node path + | info ^. L.path == path = Seq.singleton info + | isJust nextChild = info <| nextInst (fromJust nextChild) + | otherwise = Seq.empty + where + children = node ^. L.children + info = node ^. L.info + nextStep = nextTargetStep node path + nextChild = nextStep >>= flip Seq.lookup children + nextInst child = widgetFindBranchByPath (child ^. L.widget) wenv child path + +-- | Event Handling +defaultFilterEvent :: ContainerFilterHandler s e +defaultFilterEvent wenv node target evt = Just (target, evt) + +defaultHandleEvent :: ContainerEventHandler s e +defaultHandleEvent wenv node target evt = Nothing + +handleEventWrapper + :: WidgetModel a + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Path + -> SystemEvent + -> Maybe (WidgetResult s e) +handleEventWrapper container wenv node baseTarget baseEvt + | not (node ^. L.info . L.visible) || isNothing filteredEvt = Nothing + | targetReached || not targetValid = pResultStyled + | otherwise = cResultStyled + where + -- Having targetValid = False means the next path step is not in + -- _wiChildren, but may still be valid in the receiving widget + -- For example, Composite has its own tree of child widgets with (possibly) + -- different types for Model and Events, and is candidate for the next step + offset = fromMaybe def (containerChildrenOffset container) + style = containerGetCurrentStyle container wenv node + doCursor = not (containerUseCustomCursor container) + updateCWenv = getUpdateCWenv container + filterHandler = containerFilterEvent container + eventHandler = containerHandleEvent container + + targetReached = isTargetReached node target + targetValid = isTargetValid node target + filteredEvt = filterHandler wenv node baseTarget baseEvt + (target, evt) = fromMaybe (baseTarget, baseEvt) filteredEvt + -- Event targeted at parent + pResult = eventHandler wenv node target evt + pResultStyled = handleStyleChange wenv target style doCursor node evt + $ handleSizeReqChange container wenv node (Just evt) pResult + -- Event targeted at children + pNode = maybe node (^. L.node) pResult + cwenv = updateCWenv wenv pNode child childIdx + childIdx = fromJust $ nextTargetStep pNode target + children = pNode ^. L.children + child = Seq.index children childIdx + childWidget = child ^. L.widget + cevt = translateEvent (negPoint offset) evt + + childrenIgnored = isJust pResult && ignoreChildren (fromJust pResult) + parentIgnored = isJust cResult && ignoreParent (fromJust cResult) + + cResult + | childrenIgnored || not (child ^. L.info . L.enabled) = Nothing + | otherwise = widgetHandleEvent childWidget cwenv child target cevt + cResultMerged + | parentIgnored = mergeParentChildEvts node Nothing cResult childIdx + | otherwise = mergeParentChildEvts pNode pResult cResult childIdx + + cpNode + | parentIgnored = node + | otherwise = pNode + cResultStyled = handleStyleChange cwenv target style doCursor cpNode cevt + $ handleSizeReqChange container cwenv cpNode (Just cevt) cResultMerged + +mergeParentChildEvts + :: WidgetNode s e + -> Maybe (WidgetResult s e) + -> Maybe (WidgetResult s e) + -> Int + -> Maybe (WidgetResult s e) +mergeParentChildEvts _ Nothing Nothing _ = Nothing +mergeParentChildEvts _ pResponse Nothing _ = pResponse +mergeParentChildEvts original Nothing (Just cResponse) idx = Just $ cResponse { + _wrNode = replaceChild original (_wrNode cResponse) idx + } +mergeParentChildEvts original (Just pResponse) (Just cResponse) idx + | ignoreChildren pResponse = Just pResponse + | ignoreParent cResponse = Just newChildResponse + | otherwise = Just $ WidgetResult newWidget requests + where + pWidget = _wrNode pResponse + cWidget = _wrNode cResponse + requests = _wrRequests pResponse <> _wrRequests cResponse + newWidget = replaceChild pWidget cWidget idx + newChildResponse = cResponse { + _wrNode = replaceChild original (_wrNode cResponse) idx + } + +-- | Message Handling +defaultHandleMessage :: ContainerMessageHandler s e +defaultHandleMessage wenv node target message = Nothing + +handleMessageWrapper + :: (WidgetModel a, Typeable i) + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Path + -> i + -> Maybe (WidgetResult s e) +handleMessageWrapper container wenv node target arg + | not targetReached && not targetValid = Nothing + | otherwise = handleSizeReqChange container wenv node Nothing result + where + updateCWenv = getUpdateCWenv container + handler = containerHandleMessage container + + targetReached = isTargetReached node target + targetValid = isTargetValid node target + childIdx = fromJust $ nextTargetStep node target + children = node ^. L.children + child = Seq.index children childIdx + cwenv = updateCWenv wenv node child childIdx + + message = widgetHandleMessage (child ^. L.widget) cwenv child target arg + messageResult = updateChild <$> message + updateChild cr = cr { + _wrNode = replaceChild node (_wrNode cr) childIdx + } + result + | targetReached = handler wenv node target arg + | otherwise = messageResult + +-- | Preferred size +defaultGetSizeReq :: ContainerGetSizeReqHandler s e +defaultGetSizeReq wenv node children = (newReqW, newReqH) where + (newReqW, newReqH) = case Seq.lookup 0 children of + Just child -> (child ^. L.info . L.sizeReqW, child ^. L.info . L.sizeReqH) + _ -> def + +getSizeReqWrapper + :: WidgetModel a + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> (SizeReq, SizeReq) +getSizeReqWrapper container wenv node = (newReqW, newReqH) where + addStyleReq = containerAddStyleReq container + handler = containerGetSizeReq container + style = containerGetCurrentStyle container wenv node + + children = node ^. L.children + reqs = handler wenv node children + (tmpReqW, tmpReqH) + | addStyleReq = sizeReqAddStyle style reqs + | otherwise = reqs + -- User settings take precedence + newReqW = fromMaybe tmpReqW (style ^. L.sizeReqW) + newReqH = fromMaybe tmpReqH (style ^. L.sizeReqH) + +updateSizeReq + :: WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e +updateSizeReq wenv node = newNode where + (newReqW, newReqH) = widgetGetSizeReq (node ^. L.widget) wenv node + newNode = node + & L.info . L.sizeReqW .~ newReqW + & L.info . L.sizeReqH .~ newReqH + +handleSizeReqChange + :: WidgetModel a + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Maybe SystemEvent + -> Maybe (WidgetResult s e) + -> Maybe (WidgetResult s e) +handleSizeReqChange container wenv node evt mResult = result where + baseResult = fromMaybe (resultNode node) mResult + baseNode = baseResult ^. L.node + resizeReq = isResizeAnyResult mResult + styleChanged = isJust evt && styleStateChanged wenv baseNode (fromJust evt) + result + | styleChanged || resizeReq = Just $ baseResult + & L.node .~ updateSizeReq wenv baseNode + | otherwise = mResult + +-- | Resize +defaultResize :: ContainerResizeHandler s e +defaultResize wenv node viewport children = resized where + style = currentStyle wenv node + contentArea = fromMaybe def (removeOuterBounds style viewport) + childrenSizes = Seq.replicate (Seq.length children) contentArea + resized = (resultNode node, childrenSizes) + +resizeWrapper + :: WidgetModel a + => Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Rect + -> (Path -> Bool) + -> WidgetResult s e +resizeWrapper container wenv node viewport resizeReq = result where + updateCWenv = getUpdateCWenv container + useCustomSize = containerUseCustomSize container + useChildSize = containerUseChildrenSizes container + handler = containerResize container + + lensVp = L.info . L.viewport + vpChanged = viewport /= node ^. lensVp + path = node ^. L.info . L.path + children = node ^. L.children + + (tempRes, assigned) = handler wenv node viewport children + resize idx (child, vp) = newChildRes where + cwenv = updateCWenv wenv node child idx + tempChildRes = widgetResize (child ^. L.widget) cwenv child vp resizeReq + cvp = tempChildRes ^. L.node . L.info . L.viewport + icvp = fromMaybe vp (intersectRects vp cvp) + newChildRes = tempChildRes + & L.node . L.info . L.viewport .~ (if useChildSize then icvp else vp) + + newChildrenRes = Seq.mapWithIndex resize (Seq.zip children assigned) + newChildren = fmap _wrNode newChildrenRes + newChildrenReqs = foldMap _wrRequests newChildrenRes + newVp + | useCustomSize = tempRes ^. L.node . lensVp + | otherwise = viewport + tmpResult + | vpChanged || resizeReq path = Just $ tempRes + & L.node . L.info . L.viewport .~ newVp + & L.node . L.children .~ newChildren + & L.requests <>~ newChildrenReqs + | otherwise = Just $ resultNode node + result = fromJust $ + handleSizeReqChange container wenv (tempRes ^. L.node) Nothing tmpResult + +-- | Rendering +defaultRender :: ContainerRenderHandler s e +defaultRender renderer wenv node = return () + +renderWrapper + :: Container s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Renderer + -> IO () +renderWrapper container wenv node renderer = + drawInScissor renderer useScissor viewport $ + drawStyledAction renderer viewport style $ \_ -> do + renderBefore wenv node renderer + + drawInScissor renderer useChildrenScissor childrenScissorRect $ do + when (isJust offset) $ do + saveContext renderer + setTranslation renderer (fromJust offset) + + forM_ pairs $ \(idx, child) -> + when (isWidgetVisible (cwenv child idx) child) $ + widgetRender (child ^. L.widget) (cwenv child idx) child renderer + + when (isJust offset) $ + restoreContext renderer + + -- Outside children scissor + renderAfter wenv node renderer + where + style = containerGetCurrentStyle container wenv node + updateCWenv = getUpdateCWenv container + useScissor = containerUseScissor container + childrenScissor = containerChildrenScissor container + offset = containerChildrenOffset container + renderBefore = containerRender container + renderAfter = containerRenderAfter container + + children = node ^. L.children + viewport = node ^. L.info . L.viewport + useChildrenScissor = isJust childrenScissor + childrenScissorRect = fromMaybe def childrenScissor + pairs = Seq.mapWithIndex (,) children + cwenv child idx = updateCWenv wenv node child idx + +-- | Event Handling Helpers +ignoreChildren :: WidgetResult s e -> Bool +ignoreChildren result = not (Seq.null ignoreReqs) where + ignoreReqs = Seq.filter isIgnoreChildrenEvents (_wrRequests result) + +ignoreParent :: WidgetResult s e -> Bool +ignoreParent result = not (Seq.null ignoreReqs) where + ignoreReqs = Seq.filter isIgnoreParentEvents (_wrRequests result) + +replaceChild + :: WidgetNode s e -> WidgetNode s e -> Int -> WidgetNode s e +replaceChild parent child idx = parent & L.children .~ newChildren where + newChildren = Seq.update idx child (parent ^. L.children) + +cascadeCtx + :: WidgetEnv s e -> WidgetNode s e -> WidgetNode s e -> Int -> WidgetNode s e +cascadeCtx wenv parent child idx = newChild where + pInfo = parent ^. L.info + cInfo = child ^. L.info + parentPath = pInfo ^. L.path + parentVisible = pInfo ^. L.visible + parentEnabled = pInfo ^. L.enabled + newPath = parentPath |> idx + newChild = child + & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) newPath + & L.info . L.path .~ newPath + & L.info . L.visible .~ (cInfo ^. L.visible && parentVisible) + & L.info . L.enabled .~ (cInfo ^. L.enabled && parentEnabled) + +buildLocalMap :: Seq (WidgetNode s e) -> Map WidgetKey (WidgetNode s e) +buildLocalMap widgets = newMap where + addWidget map widget + | isJust key = M.insert (fromJust key) widget map + | otherwise = map + where + key = widget ^. L.info . L.key + newMap = foldl' addWidget M.empty widgets diff --git a/src/Monomer/Widgets/Containers/Alert.hs b/src/Monomer/Widgets/Containers/Alert.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Alert.hs @@ -0,0 +1,154 @@ +{-| +Module : Monomer.Widgets.Containers.Alert +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Simple alert dialog, displaying a close button and optional title. Usually +embedded in a zstack component and displayed/hidden depending on context. + +Config: + +- titleCaption: the title of the alert dialog. +- closeCaption: the caption of the close button. +-} +module Monomer.Widgets.Containers.Alert ( + alert, + alert_, + alertMsg, + alertMsg_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (.~)) +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import Monomer.Core +import Monomer.Core.Combinators + +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Keystroke +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Icon +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +data AlertCfg = AlertCfg { + _alcTitle :: Maybe Text, + _alcClose :: Maybe Text +} + +instance Default AlertCfg where + def = AlertCfg { + _alcTitle = Nothing, + _alcClose = Nothing + } + +instance Semigroup AlertCfg where + (<>) a1 a2 = AlertCfg { + _alcTitle = _alcTitle a2 <|> _alcTitle a1, + _alcClose = _alcClose a2 <|> _alcClose a1 + } + +instance Monoid AlertCfg where + mempty = def + +instance CmbTitleCaption AlertCfg where + titleCaption t = def { + _alcTitle = Just t + } + +instance CmbCloseCaption AlertCfg where + closeCaption t = def { + _alcClose = Just t + } + +-- | Creates an alert dialog with the provided content. +alert + :: (WidgetModel sp, WidgetEvent ep) + => ep -- ^ The event to raise when the dialog is closed. + -> WidgetNode () ep -- ^ The content to display in the dialog. + -> WidgetNode sp ep -- ^ The created dialog. +alert evt dialogBody = alert_ evt def dialogBody + +-- | Creates an alert dialog with the provided content. Accepts config. +alert_ + :: (WidgetModel sp, WidgetEvent ep) + => ep -- ^ The event to raise when the dialog is closed. + -> [AlertCfg] -- ^ The config options for the dialog. + -> WidgetNode () ep -- ^ The content to display in the dialog. + -> WidgetNode sp ep -- ^ The created dialog. +alert_ evt configs dialogBody = newNode where + config = mconcat configs + createUI = buildUI (const dialogBody) evt config + newNode = compositeD_ "alert" (WidgetValue ()) createUI handleEvent [] + +-- | Creates an alert dialog with a text message as content. +alertMsg + :: (WidgetModel sp, WidgetEvent ep) + => Text -- ^ The message to display. + -> ep -- ^ The event to raise when the dialog is closed. + -> WidgetNode sp ep -- ^ The created dialog. +alertMsg message evt = alertMsg_ message evt def + +-- | Creates an alert dialog with a text message as content. Accepts config. +alertMsg_ + :: (WidgetModel sp, WidgetEvent ep) + => Text -- ^ The message to display. + -> ep -- ^ The event to raise when the dialog is closed. + -> [AlertCfg] -- ^ The config options for the dialog. + -> WidgetNode sp ep -- ^ The created dialog. +alertMsg_ message evt configs = newNode where + config = mconcat configs + dialogBody wenv = label_ message [multiline] + & L.info . L.style .~ collectTheme wenv L.dialogMsgBodyStyle + createUI = buildUI dialogBody evt config + newNode = compositeD_ "alert" (WidgetValue ()) createUI handleEvent [] + +buildUI + :: (WidgetModel s, WidgetEvent ep) + => (WidgetEnv s ep -> WidgetNode s ep) + -> ep + -> AlertCfg + -> WidgetEnv s ep + -> s + -> WidgetNode s ep +buildUI dialogBody cancelEvt config wenv model = mainTree where + title = fromMaybe "" (_alcTitle config) + close = fromMaybe "Close" (_alcClose config) + + emptyOverlay = collectTheme wenv L.emptyOverlayStyle + dismissButton = hstack [button close cancelEvt] + closeIcon = icon_ IconClose [width 2] + & L.info . L.style .~ collectTheme wenv L.dialogCloseIconStyle + + alertTree = vstack_ [sizeReqUpdater clearExtra] [ + hstack [ + label title & L.info . L.style .~ collectTheme wenv L.dialogTitleStyle, + filler, + box_ [alignTop, onClick cancelEvt] closeIcon + ], + dialogBody wenv, + filler, + box_ [alignRight] dismissButton + & L.info . L.style .~ collectTheme wenv L.dialogButtonsStyle + ] & L.info . L.style .~ collectTheme wenv L.dialogFrameStyle + alertBox = box_ [onClickEmpty cancelEvt] alertTree + & L.info . L.style .~ emptyOverlay + mainTree = keystroke [("Esc", cancelEvt)] alertBox + +handleEvent + :: WidgetEnv s ep + -> WidgetNode s ep + -> s + -> ep + -> [EventResponse s e sp ep] +handleEvent wenv node model evt = [Report evt] diff --git a/src/Monomer/Widgets/Containers/Base/LabeledItem.hs b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs @@ -0,0 +1,118 @@ +{-| +Module : Monomer.Widgets.Containers.Base.LabeledItem +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Container for items with an associated clickable label. Mainly used with radio +and checkbox. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Monomer.Widgets.Containers.Base.LabeledItem ( + labeledItem +) where + +import Control.Applicative ((<|>)) +import Data.Default +import Control.Lens ((&), (^.), (^?), (^?!), (.~), (<>~), ix) +import Data.Maybe +import Data.Sequence ((|>)) +import Data.Text (Text) + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators + +import Monomer.Widgets.Container +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +{-| +Creates a stack with a label and the provided widget, passing to this widget all +the click events received. Positioning is configurable. +-} +labeledItem + :: WidgetEvent e + => WidgetType + -> RectSide + -> Text + -> LabelCfg s e + -> WidgetNode s e + -> WidgetNode s e +labeledItem wtype textSide caption labelCfg itemNode = labeledNode where + widget = makeLabeledItem textSide caption labelCfg itemNode + labeledNode = defaultWidgetNode wtype widget + +makeLabeledItem + :: WidgetEvent e + => RectSide + -> Text + -> LabelCfg s e + -> WidgetNode s e + -> Widget s e +makeLabeledItem textSide caption labelCfg itemNode = widget where + widget = createContainer () def { + containerInit = init, + containerMerge = merge, + containerFilterEvent = filterEvent + } + + createChildNode wenv node = newNode where + nodeStyle = node ^. L.info . L.style + labelStyle = def + & collectStyleField_ L.text nodeStyle + & collectStyleField_ L.cursorIcon nodeStyle + itemStyle = def + & collectStyleField_ L.fgColor nodeStyle + & collectStyleField_ L.hlColor nodeStyle + & collectStyleField_ L.sndColor nodeStyle + & collectStyleField_ L.cursorIcon nodeStyle + + baseLabel = label_ caption [labelCfg] `styleBasic` [cursorHand] + labelNode = baseLabel + & L.info . L.style <>~ labelStyle + styledNode = itemNode + & L.info . L.style <>~ itemStyle + + childNode + | textSide == SideLeft = hstack [ labelNode, spacer, styledNode ] + | textSide == SideRight = hstack [ styledNode, spacer, labelNode ] + | textSide == SideTop = vstack [ labelNode, spacer, styledNode ] + | otherwise = vstack [ styledNode, spacer, labelNode ] + newNode = node + & L.children .~ Seq.singleton childNode + + init wenv node = result where + result = resultNode (createChildNode wenv node) + + merge wenv node oldNode oldState = result where + result = resultNode (createChildNode wenv node) + + filterEvent :: ContainerFilterHandler s e + filterEvent wenv node target evt = case evt of + Click p btn clicks + | isPointInNodeVp labelNode p -> Just (newPath, newEvt) where + newEvt = Click targetCenter btn clicks + + ButtonAction p btn BtnPressed clicks + | isPointInNodeVp labelNode p -> Just (newPath, newEvt) where + newEvt = ButtonAction targetCenter btn BtnPressed clicks + + _ -> Just (target, evt) + where + labelIdx + | textSide `elem` [SideLeft, SideTop] = 0 + | otherwise = 2 + targetIdx = 2 - labelIdx + newPath = Seq.take (length target - 1) target |> targetIdx + labelNode = node ^. L.children . ix 0 . L.children ^?! ix labelIdx + targetNode = node ^. L.children . ix 0 . L.children ^?! ix targetIdx + targetCenter = rectCenter (targetNode ^. L.info . L.viewport) diff --git a/src/Monomer/Widgets/Containers/Box.hs b/src/Monomer/Widgets/Containers/Box.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Box.hs @@ -0,0 +1,402 @@ +{-| +Module : Monomer.Widgets.Containers.Box +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Container for a single item. 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 the container (in particular for containers which do not +follow SizeReq restriccions, such as Grid). +Can be used to add padding to an inner widget with a border. This is equivalent +to the margin property in CSS. +Also useful to handle click events in complex widget structures (for example, a +label with an image at its side). + +Config: + +- mergeRequired: function called during merge that receives the old and new + model, returning True in case the child widget needs to be merged. Since by + default merge is required, this function can be used to restrict merging when + it would be expensive and it is not necessary. For example, a list of widgets + representing search result only needs to be updated when the list of results + changes, not while the user inputs new search criteria (which also triggers + a model change and, hence, the merge process). +- ignoreEmptyArea: when the inner widget does not use all the available space, + ignoring the unassigned space allows for mouse events to pass through. This is + useful in zstack layers. +- sizeReqUpdater: allows modifying the 'SizeReq' generated by the inner widget. +- alignLeft: aligns the inner widget to the left. +- alignCenter: aligns the inner widget to the horizontal center. +- alignRight: aligns the inner widget to the right. +- alignTop: aligns the inner widget to the top. +- alignMiddle: aligns the inner widget to the left. +- alignBottom: aligns the inner widget to the bottom. +- onClick: click event. +- onClickReq: generates a WidgetRequest on click. +- onClickEmpty: click event on empty area. +- onClickEmptyReq: generates a WidgetRequest on click in empty area. +- expandContent: if the inner widget should use all the available space. To be + able to use alignment options, this must be False (the default). +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Monomer.Widgets.Containers.Box ( + BoxCfg(..), + box, + box_, + expandContent +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.Maybe + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container +import Monomer.Widgets.Containers.Stack + +import qualified Monomer.Lens as L + +-- | Configuration options for box widget. +data BoxCfg s e = BoxCfg { + _boxExpandContent :: Maybe Bool, + _boxIgnoreEmptyArea :: Maybe Bool, + _boxSizeReqUpdater :: Maybe SizeReqUpdater, + _boxMergeRequired :: Maybe (s -> s -> Bool), + _boxAlignH :: Maybe AlignH, + _boxAlignV :: Maybe AlignV, + _boxOnFocusReq :: [Path -> WidgetRequest s e], + _boxOnBlurReq :: [Path -> WidgetRequest s e], + _boxOnEnterReq :: [WidgetRequest s e], + _boxOnLeaveReq :: [WidgetRequest s e], + _boxOnClickReq :: [WidgetRequest s e], + _boxOnClickEmptyReq :: [WidgetRequest s e], + _boxOnBtnPressedReq :: [Button -> Int -> WidgetRequest s e], + _boxOnBtnReleasedReq :: [Button -> Int -> WidgetRequest s e] +} + +instance Default (BoxCfg s e) where + def = BoxCfg { + _boxExpandContent = Nothing, + _boxIgnoreEmptyArea = Nothing, + _boxSizeReqUpdater = Nothing, + _boxMergeRequired = Nothing, + _boxAlignH = Nothing, + _boxAlignV = Nothing, + _boxOnFocusReq = [], + _boxOnBlurReq = [], + _boxOnEnterReq = [], + _boxOnLeaveReq = [], + _boxOnClickReq = [], + _boxOnClickEmptyReq = [], + _boxOnBtnPressedReq = [], + _boxOnBtnReleasedReq = [] + } + +instance Semigroup (BoxCfg s e) where + (<>) t1 t2 = BoxCfg { + _boxExpandContent = _boxExpandContent t2 <|> _boxExpandContent t1, + _boxIgnoreEmptyArea = _boxIgnoreEmptyArea t2 <|> _boxIgnoreEmptyArea t1, + _boxSizeReqUpdater = _boxSizeReqUpdater t2 <|> _boxSizeReqUpdater t1, + _boxMergeRequired = _boxMergeRequired t2 <|> _boxMergeRequired t1, + _boxAlignH = _boxAlignH t2 <|> _boxAlignH t1, + _boxAlignV = _boxAlignV t2 <|> _boxAlignV t1, + _boxOnFocusReq = _boxOnFocusReq t1 <> _boxOnFocusReq t2, + _boxOnBlurReq = _boxOnBlurReq t1 <> _boxOnBlurReq t2, + _boxOnEnterReq = _boxOnEnterReq t1 <> _boxOnEnterReq t2, + _boxOnLeaveReq = _boxOnLeaveReq t1 <> _boxOnLeaveReq t2, + _boxOnClickReq = _boxOnClickReq t1 <> _boxOnClickReq t2, + _boxOnClickEmptyReq = _boxOnClickEmptyReq t1 <> _boxOnClickEmptyReq t2, + _boxOnBtnPressedReq = _boxOnBtnPressedReq t1 <> _boxOnBtnPressedReq t2, + _boxOnBtnReleasedReq = _boxOnBtnReleasedReq t1 <> _boxOnBtnReleasedReq t2 + } + +instance Monoid (BoxCfg s e) where + mempty = def + +instance CmbIgnoreEmptyArea (BoxCfg s e) where + ignoreEmptyArea_ ignore = def { + _boxIgnoreEmptyArea = Just ignore + } + +instance CmbSizeReqUpdater (BoxCfg s e) where + sizeReqUpdater updater = def { + _boxSizeReqUpdater = Just updater + } + +instance CmbMergeRequired (BoxCfg s e) s where + mergeRequired fn = def { + _boxMergeRequired = Just fn + } + +instance CmbAlignLeft (BoxCfg s e) where + alignLeft_ False = def + alignLeft_ True = def { + _boxAlignH = Just ALeft + } + +instance CmbAlignCenter (BoxCfg s e) where + alignCenter_ False = def + alignCenter_ True = def { + _boxAlignH = Just ACenter + } + +instance CmbAlignRight (BoxCfg s e) where + alignRight_ False = def + alignRight_ True = def { + _boxAlignH = Just ARight + } + +instance CmbAlignTop (BoxCfg s e) where + alignTop_ False = def + alignTop_ True = def { + _boxAlignV = Just ATop + } + +instance CmbAlignMiddle (BoxCfg s e) where + alignMiddle_ False = def + alignMiddle_ True = def { + _boxAlignV = Just AMiddle + } + +instance CmbAlignBottom (BoxCfg s e) where + alignBottom_ False = def + alignBottom_ True = def { + _boxAlignV = Just ABottom + } + +instance WidgetEvent e => CmbOnFocus (BoxCfg s e) e Path where + onFocus handler = def { + _boxOnFocusReq = [RaiseEvent . handler] + } + +instance CmbOnFocusReq (BoxCfg s e) s e Path where + onFocusReq req = def { + _boxOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (BoxCfg s e) e Path where + onBlur handler = def { + _boxOnBlurReq = [RaiseEvent . handler] + } + +instance CmbOnBlurReq (BoxCfg s e) s e Path where + onBlurReq req = def { + _boxOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnBtnPressed (BoxCfg s e) e where + onBtnPressed handler = def { + _boxOnBtnPressedReq = [(RaiseEvent .) . handler] + } + +instance CmbOnBtnPressedReq (BoxCfg s e) s e where + onBtnPressedReq req = def { + _boxOnBtnPressedReq = [req] + } + +instance WidgetEvent e => CmbOnBtnReleased (BoxCfg s e) e where + onBtnReleased handler = def { + _boxOnBtnReleasedReq = [(RaiseEvent .) . handler] + } + +instance CmbOnBtnReleasedReq (BoxCfg s e) s e where + onBtnReleasedReq req = def { + _boxOnBtnReleasedReq = [req] + } + +instance WidgetEvent e => CmbOnClick (BoxCfg s e) e where + onClick handler = def { + _boxOnClickReq = [RaiseEvent handler] + } + +instance CmbOnClickReq (BoxCfg s e) s e where + onClickReq req = def { + _boxOnClickReq = [req] + } + +instance WidgetEvent e => CmbOnClickEmpty (BoxCfg s e) e where + onClickEmpty handler = def { + _boxOnClickEmptyReq = [RaiseEvent handler] + } + +instance CmbOnClickEmptyReq (BoxCfg s e) s e where + onClickEmptyReq req = def { + _boxOnClickEmptyReq = [req] + } + +instance WidgetEvent e => CmbOnEnter (BoxCfg s e) e where + onEnter handler = def { + _boxOnEnterReq = [RaiseEvent handler] + } + +instance CmbOnEnterReq (BoxCfg s e) s e where + onEnterReq req = def { + _boxOnEnterReq = [req] + } + +instance WidgetEvent e => CmbOnLeave (BoxCfg s e) e where + onLeave handler = def { + _boxOnLeaveReq = [RaiseEvent handler] + } + +instance CmbOnLeaveReq (BoxCfg s e) s e where + onLeaveReq req = def { + _boxOnLeaveReq = [req] + } + +-- | Assigns all the available space to its contained child. +expandContent :: BoxCfg s e +expandContent = def { + _boxExpandContent = Just True +} + +newtype BoxState s = BoxState { + _bxsModel :: Maybe s +} + +-- | Creates a box widget with a single node as child. +box :: (WidgetModel s, WidgetEvent e) => WidgetNode s e -> WidgetNode s e +box managed = box_ def managed + +-- | Creates a box widget with a single node as child. Accepts config. +box_ + :: (WidgetModel s, WidgetEvent e) + => [BoxCfg s e] + -> WidgetNode s e + -> WidgetNode s e +box_ configs managed = makeNode (makeBox config state) managed where + config = mconcat configs + state = BoxState Nothing + +makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode widget managedWidget = defaultWidgetNode "box" widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeBox + :: (WidgetModel s, WidgetEvent e) + => BoxCfg s e + -> BoxState s + -> Widget s e +makeBox config state = widget where + widget = createContainer state def { + containerIgnoreEmptyArea = ignoreEmptyArea && emptyHandlersCount == 0, + containerGetCurrentStyle = getCurrentStyle, + containerInit = init, + containerMergeChildrenReq = mergeRequired, + containerMerge = merge, + containerHandleEvent = handleEvent, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + + ignoreEmptyArea = Just True == _boxIgnoreEmptyArea config + emptyHandlersCount = length (_boxOnClickEmptyReq config) + + init wenv node = resultNode newNode where + newState = BoxState (Just $ wenv ^. L.model) + newNode = node + & L.widget .~ makeBox config newState + + 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 + _ -> True + + merge wenv node oldNode oldState = resultNode newNode where + newState = BoxState (Just $ wenv ^. L.model) + newNode = node + & L.widget .~ makeBox config newState + + getCurrentStyle = currentStyle_ currentStyleConfig where + currentStyleConfig = def + & L.isActive .~ isNodeTreeActive + + handleEvent wenv node target evt = case evt of + Focus prev -> handleFocusChange node prev (_boxOnFocusReq config) + Blur next -> handleFocusChange node next (_boxOnBlurReq config) + + Enter point + | not (null reqs) && inChildVp point -> result where + reqs = _boxOnEnterReq config + result = Just (resultReqs node reqs) + + Leave point + | not (null reqs) -> result where + reqs = _boxOnLeaveReq config + result = Just (resultReqs node reqs) + + Click point btn _ + | not (null reqs) && inChildVp point -> result where + reqs = _boxOnClickReq config + result = Just (resultReqs node reqs) + + Click point btn _ + | not (null reqs) && not (inChildVp point) -> result where + reqs = _boxOnClickEmptyReq config + result = Just (resultReqs node reqs) + + ButtonAction point btn BtnPressed clicks + | not (null reqs) && inChildVp point -> result where + reqs = _boxOnBtnPressedReq config <*> pure btn <*> pure clicks + result = Just (resultReqs node reqs) + + ButtonAction point btn BtnReleased clicks + | clicks == 1 && not (null reqs) && inChildVp point -> result where + reqs = _boxOnBtnReleasedReq config <*> pure btn <*> pure clicks + result = Just (resultReqs node reqs) + + ButtonAction point btn BtnReleased clicks + | clicks > 1 && not (null reqs) && inChildVp point -> result where + reqsA = _boxOnClickReq config + reqsB = _boxOnBtnReleasedReq config <*> pure btn <*> pure clicks + reqs = reqsA <> reqsB + result = Just (resultReqs node reqs) + + ButtonAction point btn BtnReleased clicks + | clicks > 1 && not (null reqs) && not (inChildVp point) -> result where + reqs = _boxOnClickEmptyReq config + result = Just (resultReqs node reqs) + + _ -> Nothing + where + child = Seq.index (node ^. L.children) 0 + inChildVp point = pointInRect point (child ^. L.info . L.viewport) + + getSizeReq :: ContainerGetSizeReqHandler s e + getSizeReq wenv node children = newSizeReq where + updateSizeReq = fromMaybe id (_boxSizeReqUpdater config) + child = Seq.index children 0 + newReqW = child ^. L.info . L.sizeReqW + newReqH = child ^. L.info . L.sizeReqH + newSizeReq = updateSizeReq (newReqW, newReqH) + + resize wenv node viewport children = resized where + style = getCurrentStyle wenv node + child = Seq.index children 0 + contentArea = fromMaybe def (removeOuterBounds style viewport) + Rect cx cy cw ch = contentArea + + contentW = snd $ assignStackAreas True contentArea children + contentH = snd $ assignStackAreas False contentArea children + + raChild = Rect cx cy (min cw contentW) (min ch contentH) + ah = fromMaybe ACenter (_boxAlignH config) + av = fromMaybe AMiddle (_boxAlignV config) + raAligned = alignInRect contentArea raChild ah av + + expand = fromMaybe False (_boxExpandContent config) + resized + | expand = (resultNode node, Seq.singleton contentArea) + | otherwise = (resultNode node, Seq.singleton raAligned) diff --git a/src/Monomer/Widgets/Containers/Confirm.hs b/src/Monomer/Widgets/Containers/Confirm.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Confirm.hs @@ -0,0 +1,194 @@ +{-| +Module : Monomer.Widgets.Containers.Confirm +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +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 +context. + +Config: + +- titleCaption: the title of the alert dialog. +- acceptCaption: the caption of the accept button. +- closeCaption: the caption of the close button. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Monomer.Widgets.Containers.Confirm ( + confirm, + confirm_, + confirmMsg, + confirmMsg_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), (<>~)) +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import Monomer.Core +import Monomer.Core.Combinators + +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Keystroke +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Icon +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +data ConfirmCfg = ConfirmCfg { + _cfcTitle :: Maybe Text, + _cfcAccept :: Maybe Text, + _cfcCancel :: Maybe Text +} + +instance Default ConfirmCfg where + def = ConfirmCfg { + _cfcTitle = Nothing, + _cfcAccept = Nothing, + _cfcCancel = Nothing + } + +instance Semigroup ConfirmCfg where + (<>) a1 a2 = ConfirmCfg { + _cfcTitle = _cfcTitle a2 <|> _cfcTitle a1, + _cfcAccept = _cfcAccept a2 <|> _cfcAccept a1, + _cfcCancel = _cfcCancel a2 <|> _cfcCancel a1 + } + +instance Monoid ConfirmCfg where + mempty = def + +instance CmbTitleCaption ConfirmCfg where + titleCaption t = def { + _cfcTitle = Just t + } + +instance CmbAcceptCaption ConfirmCfg where + acceptCaption t = def { + _cfcAccept = Just t + } + +instance CmbCancelCaption ConfirmCfg where + cancelCaption t = def { + _cfcCancel = Just t + } + +newtype ConfirmEvt e + = ConfirmParentEvt e + deriving (Eq, Show) + +-- | Creates a confirm dialog with the provided content. +confirm + :: (WidgetModel sp, WidgetEvent ep) + => ep -- ^ The accept button event. + -> ep -- ^ The cancel button event. + -> WidgetNode () (ConfirmEvt ep) -- ^ The content to display in the dialog. + -> WidgetNode sp ep -- ^ 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 sp, WidgetEvent ep) + => ep -- ^ The accept button event. + -> ep -- ^ The cancel button event. + -> [ConfirmCfg] -- ^ The config options for the dialog. + -> WidgetNode () (ConfirmEvt ep) -- ^ The content to display in the dialog. + -> WidgetNode sp ep -- ^ The created dialog. +confirm_ acceptEvt cancelEvt configs dialogBody = newNode where + config = mconcat configs + createUI = buildUI (const dialogBody) acceptEvt cancelEvt config + compCfg = [compositeMergeReqs mergeReqs] + newNode = compositeD_ "confirm" (WidgetValue ()) createUI handleEvent compCfg + +-- | Creates an alert dialog with a text message as content. +confirmMsg + :: (WidgetModel sp, WidgetEvent ep) + => Text -- ^ The message to display in the dialog. + -> ep -- ^ The accept button event. + -> ep -- ^ The cancel button event. + -> WidgetNode sp ep -- ^ 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 sp, WidgetEvent ep) + => Text -- ^ The message to display in the dialog. + -> ep -- ^ The accept button event. + -> ep -- ^ The cancel button event. + -> [ConfirmCfg] -- ^ The config options for the dialog. + -> WidgetNode sp ep -- ^ The created dialog. +confirmMsg_ message acceptEvt cancelEvt configs = newNode where + config = mconcat configs + dialogBody wenv = label_ message [multiline] + & L.info . L.style .~ collectTheme wenv L.dialogMsgBodyStyle + createUI = buildUI dialogBody acceptEvt cancelEvt config + compCfg = [compositeMergeReqs mergeReqs] + newNode = compositeD_ "confirm" (WidgetValue ()) createUI handleEvent compCfg + +mergeReqs :: MergeReqsHandler s e +mergeReqs wenv newNode oldNode model = reqs where + acceptPath = SetFocus <$> widgetIdFromKey wenv "acceptBtn" + isVisible node = node ^. L.info . L.visible + reqs + | not (isVisible oldNode) && isVisible newNode = catMaybes [acceptPath] + | otherwise = [] + +buildUI + :: (WidgetModel s, WidgetEvent ep) + => (WidgetEnv s (ConfirmEvt ep) -> WidgetNode s (ConfirmEvt ep)) + -> ep + -> ep + -> ConfirmCfg + -> WidgetEnv s (ConfirmEvt ep) + -> s + -> WidgetNode s (ConfirmEvt ep) +buildUI dialogBody pAcceptEvt pCancelEvt config wenv model = mainTree where + acceptEvt = ConfirmParentEvt pAcceptEvt + cancelEvt = ConfirmParentEvt pCancelEvt + + title = fromMaybe "" (_cfcTitle config) + accept = fromMaybe "Accept" (_cfcAccept config) + cancel = fromMaybe "Cancel" (_cfcCancel config) + emptyOverlay = collectTheme wenv L.emptyOverlayStyle + + acceptBtn = mainButton accept acceptEvt `nodeKey` "acceptBtn" + cancelBtn = button cancel cancelEvt + buttons = hstack [ acceptBtn, spacer, cancelBtn ] + + closeIcon = icon_ IconClose [width 2] + & L.info . L.style .~ collectTheme wenv L.dialogCloseIconStyle + confirmTree = vstack_ [sizeReqUpdater clearExtra] [ + hstack [ + label title & L.info . L.style .~ collectTheme wenv L.dialogTitleStyle, + filler, + box_ [alignTop, onClick cancelEvt] closeIcon + ], + dialogBody wenv, + filler, + box_ [alignRight] buttons + & L.info . L.style <>~ collectTheme wenv L.dialogButtonsStyle + ] & L.info . L.style .~ collectTheme wenv L.dialogFrameStyle + confirmBox = box_ [onClickEmpty cancelEvt] confirmTree + & L.info . L.style .~ emptyOverlay + mainTree = keystroke [("Esc", cancelEvt)] confirmBox + +handleEvent + :: WidgetEnv s (ConfirmEvt ep) + -> WidgetNode s (ConfirmEvt ep) + -> s + -> ConfirmEvt ep + -> [EventResponse s (ConfirmEvt 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 new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Draggable.hs @@ -0,0 +1,197 @@ +{-| +Module : Monomer.Widgets.Containers.Draggable +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +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'. + +The regular styling of this component apply only when the item is not being +dragged. To style the dragged container, use draggableStyle. + +The transparency config only applies to the inner content. + +Config: + +- transparency: the alpha level to apply when rendering content in drag mode. +- maxDim: the maximum size of the largest axis when dragging. Keeps proportions. +- draggableStyle: the style to use when the item is being dragged. +- draggableRender: rendering function for the dragged state. Allows customizing +this step without implementing a custom widget all the lifecycle steps. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Containers.Draggable ( + draggable, + draggable_, + draggableMaxDim, + draggableStyle, + draggableRender +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (^?!), (.~), _Just, _1, _2, at, ix) +import Control.Monad (when) +import Data.Default +import Data.Maybe + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +-- | Rendering function for the dragged state. +type DraggableRender s e + = DraggableCfg s e -- ^ The configuration of the draggable. + -> WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Renderer -- ^ The renderer. + -> IO () -- ^ The drawing actions. + +-- | Configuration options for draggable widget. +data DraggableCfg s e = DraggableCfg { + _dgcTransparency :: Maybe Double, + _dgcMaxDim :: Maybe Double, + _dgcDragStyle :: Maybe StyleState, + _dgcCustomRender :: Maybe (DraggableRender s e) +} + +instance Default (DraggableCfg s e) where + def = DraggableCfg { + _dgcTransparency = Nothing, + _dgcMaxDim = Nothing, + _dgcDragStyle = Nothing, + _dgcCustomRender = Nothing + } + +instance Semigroup (DraggableCfg s e) where + (<>) t1 t2 = DraggableCfg { + _dgcTransparency = _dgcTransparency t2 <|> _dgcTransparency t1, + _dgcMaxDim = _dgcMaxDim t2 <|> _dgcMaxDim t1, + _dgcDragStyle = _dgcDragStyle t2 <|> _dgcDragStyle t1, + _dgcCustomRender = _dgcCustomRender t2 <|> _dgcCustomRender t1 + } + +instance Monoid (DraggableCfg s e) where + mempty = def + +instance CmbTransparency (DraggableCfg s e) where + transparency transp = def { + _dgcTransparency = Just transp + } + +{-| +Maximum dimension. Useful when aspect ratio needs to be maintained while at the +same time restricting growth. +-} +draggableMaxDim :: Double -> DraggableCfg s e +draggableMaxDim dim = def { + _dgcMaxDim = Just dim +} + +-- | The style of the dragged container. +draggableStyle :: [StyleState] -> DraggableCfg s e +draggableStyle styles = def { + _dgcDragStyle = Just (mconcat styles) +} + +-- | Rendering function for the dragged state. +draggableRender :: DraggableRender s e -> DraggableCfg s e +draggableRender render = def { + _dgcCustomRender = Just render +} + +-- | Creates a draggable container with a single node as child. +draggable :: DragMsg a => a -> WidgetNode s e -> WidgetNode s e +draggable msg managed = draggable_ msg def managed + +-- | Creates a draggable container with a single node as child. Accepts config. +draggable_ + :: DragMsg a + => a + -> [DraggableCfg s e] + -> WidgetNode s e + -> WidgetNode s e +draggable_ msg configs managed = makeNode widget managed where + config = mconcat configs + widget = makeDraggable msg config + +makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode widget managedWidget = defaultWidgetNode "draggable" widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeDraggable :: DragMsg a => a -> DraggableCfg s e -> Widget s e +makeDraggable msg config = widget where + widget = createContainer () def { + containerHandleEvent = handleEvent, + containerGetSizeReq = getSizeReq, + containerResize = resize, + containerRender = render + } + + handleEvent wenv node target evt = case evt of + ButtonAction p btn BtnPressed 1 -> Just result where + result = resultReqs node [StartDrag wid path dragMsg] + + ButtonAction p btn BtnReleased _ -> Just result where + result = resultReqs node [StopDrag wid] + + _ -> Nothing + where + wid = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + dragMsg = WidgetDragMsg msg + + getSizeReq :: ContainerGetSizeReqHandler s e + getSizeReq wenv node children = (newReqW, newReqH) where + child = Seq.index children 0 + newReqW = child ^. L.info . L.sizeReqW + newReqH = child ^. L.info . L.sizeReqH + + resize :: ContainerResizeHandler s e + resize wenv node viewport children = resized where + style = currentStyle wenv node + contentArea = fromMaybe def (removeOuterBounds style viewport) + resized = (resultNode node, Seq.singleton contentArea) + + defaultRender config wenv node renderer = + drawStyledAction renderer (moveRect scOffset draggedRect) style $ \_ -> do + saveContext renderer + setTranslation renderer (addPoint scOffset offset) + setScale renderer (Point scale scale) + setGlobalAlpha renderer transparency + widgetRender (cnode ^. L.widget) wenv cnode renderer + restoreContext renderer + where + style = fromMaybe def (_dgcDragStyle config) + transparency = fromMaybe 1 (_dgcTransparency config) + cnode = Seq.index (_wnChildren node) 0 + + Rect cx cy cw ch = cnode ^. L.info . L.viewport + Point mx my = wenv ^. L.inputStatus . L.mousePos + Point px py = wenv ^?! L.mainBtnPress . _Just . _2 + + dim = fromMaybe (max cw ch) (_dgcMaxDim config) + scale = dim / max cw ch + offset = Point (mx - px * scale) (my - py * scale) + -- Background rectangle (using draggable style) + (dx, dy) = (cx - px, cy - py) + rect = Rect (mx + dx * scale) (my + dy * scale) (cw * scale) (ch * scale) + draggedRect = fromMaybe rect (addOuterBounds style rect) + scOffset = wenv ^. L.offset + + render wenv node renderer = do + when dragged $ + createOverlay renderer $ do + renderAction config wenv node renderer + where + dragged = isNodeDragged wenv node + renderAction = fromMaybe defaultRender (_dgcCustomRender config) diff --git a/src/Monomer/Widgets/Containers/DropTarget.hs b/src/Monomer/Widgets/Containers/DropTarget.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/DropTarget.hs @@ -0,0 +1,122 @@ +{-| +Module : Monomer.Widgets.Containers.DropTarget +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +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'. + +Raises a user provided event when an item is dropped. The type must match with +the dragged message, otherwise it will not be raised. + +Configs: + +- dropTargetStyle: The style to apply to the container when a dragged item is +on top. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Containers.DropTarget ( + dropTarget, + dropTarget_, + dropTargetStyle +) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Monad (when) +import Data.Default +import Data.Maybe +import Data.Typeable (cast) + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +newtype DropTargetCfg = DropTargetCfg { + _dtcDropStyle :: Maybe StyleState +} + +instance Default DropTargetCfg where + def = DropTargetCfg { + _dtcDropStyle = Nothing + } + +instance Semigroup DropTargetCfg where + (<>) t1 t2 = DropTargetCfg { + _dtcDropStyle = _dtcDropStyle t1 <> _dtcDropStyle t2 + } + +instance Monoid DropTargetCfg where + mempty = def + +-- | The style to apply to the container when a dragged item is on top. +dropTargetStyle :: [StyleState] -> DropTargetCfg +dropTargetStyle styles = def { + _dtcDropStyle = Just (mconcat styles) +} + +-- | Creates a drop target container with a single node as child. +dropTarget + :: (DragMsg a, WidgetEvent e) => (a -> e) -> WidgetNode s e -> WidgetNode s e +dropTarget dropEvt managed = dropTarget_ dropEvt def managed + +-- | Creates a drop target container with a single node as child. Accepts +-- | config. +dropTarget_ + :: (DragMsg a, WidgetEvent e) + => (a -> e) + -> [DropTargetCfg] + -> WidgetNode s e + -> WidgetNode s e +dropTarget_ dropEvt configs managed = makeNode widget managed where + config = mconcat configs + widget = makeDropTarget dropEvt config + +makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode widget managedWidget = defaultWidgetNode "dropTarget" widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeDropTarget + :: (DragMsg a, WidgetEvent e) => (a -> e) -> DropTargetCfg -> Widget s e +makeDropTarget dropEvt config = widget where + widget = createContainer () def { + containerGetCurrentStyle = getCurrentStyle, + containerHandleEvent = handleEvent + } + + getCurrentStyle wenv node + | isJust style && isDropTarget wenv node && isValid = fromJust style + | otherwise = currentStyle wenv node + where + mousePos = wenv ^. L.inputStatus . L.mousePos + isHovered = isPointInNodeVp node mousePos + isTopLevel = isNodeTopLevel wenv node + isValid = isHovered && isTopLevel + style = _dtcDropStyle config + + handleEvent wenv node target evt = case evt of + Drop point path dragMsg + | not (isNodeParentOfPath node path) -> Just result where + widgetId = node ^. L.info . L.widgetId + evts = msgToEvts dragMsg + result = resultEvts node evts + _ -> Nothing + + isDropTarget wenv node = case wenv ^. L.dragStatus of + Just (path, msg) -> not (isNodeParentOfPath node path) && isValidMsg msg + _ -> False + where + isValidMsg = not . null . msgToEvts + + msgToEvts (WidgetDragMsg dragMsg) = case cast dragMsg of + Just msg -> [dropEvt msg] + _ -> [] diff --git a/src/Monomer/Widgets/Containers/Dropdown.hs b/src/Monomer/Widgets/Containers/Dropdown.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Dropdown.hs @@ -0,0 +1,542 @@ +{-| +Module : Monomer.Widgets.Containers.Dropdown +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Dropdown widget, allowing selection of a single item from a collapsable list. +Both header and list content is customizable, plus its styling. In case only +text content is needed, 'Monomer.Widgets.Singles.TextDropdown' is easier to use. + +Configs: + +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetReqest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetReqest to generate when focus is lost. +- onChange: event to raise when selected item changes. +- onChangeReq: WidgetRequest to generate when selected item changes. +- onChangeIdx: event to raise when selected item changes. Includes index, +- onChangeIdxReq: WidgetRequest to generate when selected item changes. Includes +index. +- maxHeight: maximum height of the list when dropdown is expanded. +- itemBasicStyle: style of an item in the list when not selected. +- itemSelectedStyle: style of the selected item in the list. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Containers.Dropdown ( + DropdownCfg, + DropdownItem(..), + dropdown, + dropdown_, + dropdownV, + dropdownV_, + dropdownD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (^?), (^?!), (.~), (%~), (<>~), _Just, ix, non) +import Control.Monad +import Data.Default +import Data.List (foldl') +import Data.Maybe +import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Text (Text) +import Data.Typeable (cast) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Helper +import Monomer.Widgets.Container +import Monomer.Widgets.Containers.SelectList +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +-- | Constraints for an item handled by dropdown. +type DropdownItem a = SelectListItem a + +-- | Configuration options for dropdown widget. +data DropdownCfg s e a = DropdownCfg { + _ddcMaxHeight :: Maybe Double, + _ddcItemStyle :: Maybe Style, + _ddcItemSelectedStyle :: Maybe Style, + _ddcOnFocusReq :: [Path -> WidgetRequest s e], + _ddcOnBlurReq :: [Path -> WidgetRequest s e], + _ddcOnChangeReq :: [a -> WidgetRequest s e], + _ddcOnChangeIdxReq :: [Int -> a -> WidgetRequest s e] +} + +instance Default (DropdownCfg s e a) where + def = DropdownCfg { + _ddcMaxHeight = Nothing, + _ddcItemStyle = Nothing, + _ddcItemSelectedStyle = Nothing, + _ddcOnFocusReq = [], + _ddcOnBlurReq = [], + _ddcOnChangeReq = [], + _ddcOnChangeIdxReq = [] + } + +instance Semigroup (DropdownCfg s e a) where + (<>) t1 t2 = DropdownCfg { + _ddcMaxHeight = _ddcMaxHeight t2 <|> _ddcMaxHeight t1, + _ddcItemStyle = _ddcItemStyle t2 <|> _ddcItemStyle t1, + _ddcItemSelectedStyle = _ddcItemSelectedStyle t2 <|> _ddcItemSelectedStyle t1, + _ddcOnFocusReq = _ddcOnFocusReq t1 <> _ddcOnFocusReq t2, + _ddcOnBlurReq = _ddcOnBlurReq t1 <> _ddcOnBlurReq t2, + _ddcOnChangeReq = _ddcOnChangeReq t1 <> _ddcOnChangeReq t2, + _ddcOnChangeIdxReq = _ddcOnChangeIdxReq t1 <> _ddcOnChangeIdxReq t2 + } + +instance Monoid (DropdownCfg s e a) where + mempty = def + +instance WidgetEvent e => CmbOnFocus (DropdownCfg s e a) e Path where + onFocus fn = def { + _ddcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (DropdownCfg s e a) s e Path where + onFocusReq req = def { + _ddcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (DropdownCfg s e a) e Path where + onBlur fn = def { + _ddcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (DropdownCfg s e a) s e Path where + onBlurReq req = def { + _ddcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (DropdownCfg s e a) a e where + onChange fn = def { + _ddcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (DropdownCfg s e a) s e a where + onChangeReq req = def { + _ddcOnChangeReq = [req] + } + +instance WidgetEvent e => CmbOnChangeIdx (DropdownCfg s e a) e a where + onChangeIdx fn = def { + _ddcOnChangeIdxReq = [(RaiseEvent .) . fn] + } + +instance CmbOnChangeIdxReq (DropdownCfg s e a) s e a where + onChangeIdxReq req = def { + _ddcOnChangeIdxReq = [req] + } + +instance CmbMaxHeight (DropdownCfg s e a) where + maxHeight h = def { + _ddcMaxHeight = Just h + } + +instance CmbItemBasicStyle (DropdownCfg s e a) Style where + itemBasicStyle style = def { + _ddcItemStyle = Just style + } + +instance CmbItemSelectedStyle (DropdownCfg s e a) Style where + itemSelectedStyle style = def { + _ddcItemSelectedStyle = Just style + } + +data DropdownState = DropdownState { + _ddsOpen :: Bool, + _ddsOffset :: Point +} deriving (Eq, Show, Generic) + +data DropdownMessage + = forall a . DropdownItem a => OnChangeMessage Int a + | OnListBlur + +-- | Creates a dropdown using the given lens. +dropdown + :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a) + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of selectable items. + -> (a -> WidgetNode s e) -- ^ Function to create the header (always visible). + -> (a -> WidgetNode s e) -- ^ Function to create the list (collapsable). + -> WidgetNode s e -- ^ The created dropdown. +dropdown field items makeMain makeRow = newNode where + newNode = dropdown_ field items makeMain makeRow def + +-- | Creates a dropdown using the given lens. Accepts config. +dropdown_ + :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a) + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of selectable items. + -> (a -> WidgetNode s e) -- ^ Function to create the header (always visible). + -> (a -> WidgetNode s e) -- ^ Function to create the list (collapsable). + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. +dropdown_ field items makeMain makeRow configs = newNode where + widgetData = WidgetLens field + newNode = dropdownD_ widgetData items makeMain makeRow configs + +-- | Creates a dropdown using the given value and onChange event handler. +dropdownV + :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a) + => a -- ^ The current value. + -> (Int -> a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of selectable items. + -> (a -> WidgetNode s e) -- ^ Function to create the header (always visible). + -> (a -> WidgetNode s e) -- ^ Function to create the list (collapsable). + -> WidgetNode s e -- ^ The created dropdown. +dropdownV value handler items makeMain makeRow = newNode where + newNode = dropdownV_ value handler items makeMain makeRow def + +-- | Creates a dropdown using the given value and onChange event handler. +-- | Accepts config. +dropdownV_ + :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a) + => a -- ^ The current value. + -> (Int -> a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of selectable items. + -> (a -> WidgetNode s e) -- ^ Function to create the header (always visible). + -> (a -> WidgetNode s e) -- ^ Function to create the list (collapsable). + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. +dropdownV_ value handler items makeMain makeRow configs = newNode where + newConfigs = onChangeIdx handler : configs + newNode = dropdownD_ (WidgetValue value) items makeMain makeRow newConfigs + +-- | Creates a dropdown providing a WidgetData instance and config. +dropdownD_ + :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a) + => WidgetData s a -- ^ The WidgetData to retrieve the value from. + -> t a -- ^ The list of selectable items. + -> (a -> WidgetNode s e) -- ^ Function to create the header (always visible). + -> (a -> WidgetNode s e) -- ^ Function to create the list (collapsable). + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. +dropdownD_ widgetData items makeMain makeRow configs = makeNode widget where + config = mconcat configs + newState = DropdownState False def + newItems = foldl' (|>) Empty items + widget = makeDropdown widgetData newItems makeMain makeRow config newState + +makeNode :: Widget s e -> WidgetNode s e +makeNode widget = defaultWidgetNode "dropdown" widget + & L.info . L.focusable .~ True + +makeDropdown + :: (WidgetModel s, WidgetEvent e, DropdownItem a) + => WidgetData s a + -> Seq a + -> (a -> WidgetNode s e) + -> (a -> WidgetNode s e) + -> DropdownCfg s e a + -> DropdownState + -> Widget s e +makeDropdown widgetData items makeMain makeRow config state = widget where + container = def { + containerAddStyleReq = False, + containerChildrenOffset = Just (_ddsOffset state), + containerGetBaseStyle = getBaseStyle, + containerInit = init, + containerFindNextFocus = findNextFocus, + containerFindByPoint = findByPoint, + containerMerge = merge, + containerDispose = dispose, + containerHandleEvent = handleEvent, + containerHandleMessage = handleMessage, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + baseWidget = createContainer state container + widget = baseWidget { + widgetRender = render + } + + mainIdx = 0 + listIdx = 1 + isOpen = _ddsOpen state + currentValue wenv = widgetDataGet (_weModel wenv) widgetData + + createDropdown wenv node newState = newNode where + selected = currentValue wenv + nodeStyle = _wnInfo node ^. L.style + mainNode = makeMain selected + & L.info . L.style .~ nodeStyle + widgetId = node ^. L.info . L.widgetId + selectListNode = makeSelectList wenv widgetData items makeRow config widgetId + newWidget = makeDropdown widgetData items makeMain makeRow config newState + newNode = node + & L.widget .~ newWidget + & L.children .~ Seq.fromList [mainNode, selectListNode] + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.dropdownStyle + + init wenv node = resultNode $ createDropdown wenv node state + + merge wenv newNode oldNode oldState = result where + result = resultNode $ createDropdown wenv newNode oldState + + dispose wenv node = resultReqs node reqs where + widgetId = node ^. L.info . L.widgetId + reqs = [ ResetOverlay widgetId | isOpen ] + + findNextFocus wenv node direction start + | isOpen = node ^. L.children + | otherwise = Empty + + findByPoint wenv node start point = result where + children = node ^. L.children + mainNode = Seq.index children mainIdx + listNode = Seq.index children listIdx + result + | isOpen && isPointInNodeVp listNode point = Just listIdx + | not isOpen && isPointInNodeVp mainNode point = Just mainIdx + | otherwise = Nothing + + ddFocusChange node prev reqs = Just newResult where + tmpResult = handleFocusChange node prev reqs + newResult = fromMaybe (resultNode node) tmpResult + & L.requests %~ (|> IgnoreChildrenEvents) + + handleEvent wenv node target evt = case evt of + Focus prev + | not isOpen -> ddFocusChange node prev (_ddcOnFocusReq config) + + Blur next + | not isOpen && not (seqStartsWith path focusedPath) + -> ddFocusChange node next (_ddcOnBlurReq config) + + Move point -> result where + mainNode = Seq.index (node ^. L.children) mainIdx + listNode = Seq.index (node ^. L.children) listIdx + slPoint = addPoint (negPoint (_ddsOffset state)) point + + validMainPos = not isOpen && isPointInNodeVp mainNode point + validListPos = isOpen && isPointInNodeVp listNode slPoint + validPos = validMainPos || validListPos + + isArrow = Just CursorArrow == (snd <$> wenv ^. L.cursor) + resetRes = resultReqs node [SetCursorIcon widgetId CursorArrow] + result + | not validPos && not isArrow = Just resetRes + | otherwise = Nothing + + ButtonAction _ btn BtnPressed _ + | btn == wenv ^. L.mainButton && not isOpen -> result where + result = Just $ resultReqs node [SetFocus (node ^. L.info . L.widgetId)] + + Click point _ _ + | openRequired point node -> Just resultOpen + | closeRequired point node -> Just resultClose + where + inVp = isPointInNodeVp node point + resultOpen = openDropdown wenv node + & L.requests <>~ Seq.fromList [SetCursorIcon widgetId CursorArrow] + resultClose = closeDropdown wenv node + & L.requests <>~ Seq.fromList [ResetCursorIcon widgetId | not inVp] + + KeyAction mode code KeyPressed + | isKeyOpenDropdown && not isOpen -> Just $ openDropdown wenv node + | isKeyEscape code && isOpen -> Just $ closeDropdown wenv node + where + activationKeys = [isKeyDown, isKeyUp, isKeySpace, isKeyReturn] + isKeyOpenDropdown = or (fmap ($ code) activationKeys) + + _ + | not isOpen -> Just $ resultReqs node [IgnoreChildrenEvents] + | otherwise -> Nothing + where + style = currentStyle wenv node + widgetId = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + focusedPath = wenv ^. L.focusedPath + overlayPath = wenv ^. L.overlayPath + + overlayParent = isNodeParentOfPath node (fromJust overlayPath) + nodeValid = isNothing overlayPath || overlayParent + + openRequired point node = not isOpen && inViewport where + inViewport = pointInRect point (node ^. L.info . L.viewport) + + closeRequired point node = isOpen && not inOverlay where + offset = _ddsOffset state + listNode = Seq.index (node ^. L.children) listIdx + listVp = moveRect offset (listNode ^. L.info . L.viewport) + inOverlay = pointInRect point listVp + + openDropdown wenv node = resultReqs newNode requests where + newState = state { + _ddsOpen = True, + _ddsOffset = listOffset wenv node + } + newNode = node + & L.widget .~ makeDropdown widgetData items makeMain makeRow config newState + -- selectList is wrapped by a scroll widget + (slWid, slPath) = scrollListInfo node + (listWid, _) = selectListInfo node + scrollMsg = SendMessage listWid SelectListShowSelected + requests = [SetOverlay slWid slPath, SetFocus listWid, scrollMsg] + + closeDropdown wenv node = resultReqs newNode requests where + widgetId = node ^. L.info . L.widgetId + (slWid, _) = scrollListInfo node + (listWid, _) = selectListInfo node + newState = state { + _ddsOpen = False, + _ddsOffset = def + } + newNode = node + & L.widget .~ makeDropdown widgetData items makeMain makeRow config newState + requests = [ResetOverlay slWid, SetFocus widgetId] + + scrollListInfo node = (scrollInfo ^. L.widgetId, scrollInfo ^. L.path) where + scrollInfo = node ^?! L.children . ix listIdx . L.info + + selectListInfo node = (listInfo ^. L.widgetId, listInfo ^. L.path) where + listInfo = node ^?! L.children . ix listIdx . L.children . ix 0 . L.info + + handleMessage wenv node target msg = + cast msg >>= handleLvMsg wenv node + + handleLvMsg wenv node (OnChangeMessage idx _) = + Seq.lookup idx items >>= \value -> Just $ onChange wenv node idx value + handleLvMsg wenv node OnListBlur = Just result where + tempResult = closeDropdown wenv node + result = tempResult & L.requests %~ (|> createMoveFocusReq wenv) + + onChange wenv node idx item = result where + WidgetResult newNode reqs = closeDropdown wenv node + newReqs = Seq.fromList $ widgetDataSet widgetData item + ++ fmap ($ item) (_ddcOnChangeReq config) + ++ fmap (\fn -> fn idx item) (_ddcOnChangeIdxReq config) + result = WidgetResult newNode (reqs <> newReqs) + + getSizeReq :: ContainerGetSizeReqHandler s e + getSizeReq wenv node children = (newReqW, newReqH) where + -- Main section reqs + mainC = Seq.index children 0 + mainReqW = mainC ^. L.info . L.sizeReqW + mainReqH = mainC ^. L.info . L.sizeReqH + -- List items reqs + listC = Seq.index children 1 + listReqW = listC ^. L.info . L.sizeReqW + -- Items other than main could be wider + -- Height only matters for the selected item, since the rest is in a scroll + newReqW = sizeReqMergeMax mainReqW listReqW + newReqH = mainReqH + + listHeight wenv node = maxHeight where + Size _ winH = _weWindowSize wenv + theme = currentTheme wenv node + maxHeightTheme = theme ^. L.dropdownMaxHeight + cfgMaxHeight = _ddcMaxHeight config + -- Avoid having an invisible list if style/theme is not set + maxHeightStyle = max 20 $ fromMaybe maxHeightTheme cfgMaxHeight + reqHeight = case Seq.lookup 1 (node ^. L.children) of + Just child -> sizeReqMaxBounded $ child ^. L.info . L.sizeReqH + _ -> 0 + maxHeight = min winH (min reqHeight maxHeightStyle) + + listOffset wenv node = Point 0 newOffset where + Size _ winH = _weWindowSize wenv + viewport = node ^. L.info . L.viewport + scOffset = wenv ^. L.offset + Rect rx ry rw rh = moveRect scOffset viewport + lh = listHeight wenv node + newOffset + | ry + rh + lh > winH = - (rh + lh) + | otherwise = 0 + + resize wenv node viewport children = resized where + style = currentStyle wenv node + Rect rx ry rw rh = viewport + !mainArea = viewport + !listArea = viewport { + _rY = ry + rh, + _rH = listHeight wenv node + } + assignedAreas = Seq.fromList [mainArea, listArea] + resized = (resultNode node, assignedAreas) + + render wenv node renderer = do + drawInScissor renderer True viewport $ + drawStyledAction renderer viewport style $ \contentArea -> do + widgetRender (mainNode ^. L.widget) wenv mainNode renderer + renderArrow renderer style contentArea + + when isOpen $ + createOverlay renderer $ + drawInTranslation renderer totalOffset $ do + renderOverlay renderer cwenv listOverlay + where + style = currentStyle wenv node + viewport = node ^. L.info . L.viewport + mainNode = Seq.index (node ^. L.children) mainIdx + -- List view is rendered with an offset to accommodate for window height + listOverlay = Seq.index (node ^. L.children) listIdx + listOverlayVp = listOverlay ^. L.info . L.viewport + scOffset = wenv ^. L.offset + offset = _ddsOffset state + totalOffset = addPoint scOffset offset + cwenv = updateWenvOffset container wenv node + & L.viewport .~ listOverlayVp + + renderArrow renderer style contentArea = + drawArrowDown renderer arrowRect (_sstFgColor style) + where + Rect x y w h = contentArea + size = style ^. L.text . non def . L.fontSize . non def + arrowW = unFontSize size / 2 + dh = (h - arrowW) / 2 + arrowRect = Rect (x + w - dh * 2) (y + dh * 1.25) arrowW (arrowW / 2) + + renderOverlay renderer wenv overlayNode = renderAction where + widget = overlayNode ^. L.widget + renderAction = widgetRender widget wenv overlayNode renderer + +makeSelectList + :: (WidgetModel s, WidgetEvent e, DropdownItem a) + => WidgetEnv s e + -> WidgetData s a + -> Seq a + -> (a -> WidgetNode s e) + -> DropdownCfg s e a + -> WidgetId + -> WidgetNode s e +makeSelectList wenv value items makeRow config widgetId = selectListNode where + normalTheme = collectTheme wenv L.dropdownItemStyle + selectedTheme = collectTheme wenv L.dropdownItemSelectedStyle + + itemStyle = fromJust (Just normalTheme <> _ddcItemStyle config) + itemSelStyle = fromJust (Just selectedTheme <> _ddcItemSelectedStyle config) + + slConfig = [ + selectOnBlur, + onBlurReq (const $ SendMessage widgetId OnListBlur), + onChangeIdxReq (\idx it -> SendMessage widgetId (OnChangeMessage idx it)), + itemBasicStyle itemStyle, + itemSelectedStyle itemSelStyle + ] + slStyle = collectTheme wenv L.dropdownListStyle + selectListNode = selectListD_ value items makeRow slConfig + & L.info . L.style .~ slStyle + +createMoveFocusReq :: WidgetEnv s e -> WidgetRequest s e +createMoveFocusReq wenv = MoveFocus Nothing direction where + direction + | wenv ^. L.inputStatus . L.keyMod . L.leftShift = FocusBwd + | otherwise = FocusFwd diff --git a/src/Monomer/Widgets/Containers/Grid.hs b/src/Monomer/Widgets/Containers/Grid.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Grid.hs @@ -0,0 +1,137 @@ +{-| +Module : Monomer.Widgets.Containers.Grid +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +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. + +Configs: + +- sizeReqUpdater: allows modifying the 'SizeReq' generated by the grid. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Containers.Grid ( + hgrid, + hgrid_, + vgrid, + vgrid_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.List (foldl') +import Data.Maybe +import Data.Sequence (Seq(..), (|>)) + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +newtype GridCfg = GridCfg { + _grcSizeReqUpdater :: Maybe SizeReqUpdater +} + +instance Default GridCfg where + def = GridCfg { + _grcSizeReqUpdater = Nothing + } + +instance Semigroup GridCfg where + (<>) s1 s2 = GridCfg { + _grcSizeReqUpdater = _grcSizeReqUpdater s2 <|> _grcSizeReqUpdater s1 + } + +instance Monoid GridCfg where + mempty = def + +instance CmbSizeReqUpdater GridCfg where + sizeReqUpdater updater = def { + _grcSizeReqUpdater = Just updater + } + +-- | Creates a grid of items with the same width. +hgrid :: Traversable t => t (WidgetNode s e) -> WidgetNode s e +hgrid children = hgrid_ def children + +-- | Creates a grid of items with the same width. Accepts config. +hgrid_ :: Traversable t => [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e +hgrid_ configs children = newNode where + config = mconcat configs + newNode = defaultWidgetNode "hgrid" (makeFixedGrid True config) + & L.children .~ foldl' (|>) Empty children + +-- | Creates a grid of items with the same height. +vgrid :: Traversable t => t (WidgetNode s e) -> WidgetNode s e +vgrid children = vgrid_ def children + +-- | Creates a grid of items with the same height. Accepts config. +vgrid_ :: Traversable t => [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e +vgrid_ configs children = newNode where + config = mconcat configs + newNode = defaultWidgetNode "vgrid" (makeFixedGrid False config) + & L.children .~ foldl' (|>) Empty children + +makeFixedGrid :: Bool -> GridCfg -> Widget s e +makeFixedGrid isHorizontal config = widget where + widget = createContainer () def { + containerLayoutDirection = getLayoutDirection isHorizontal, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + + isVertical = not isHorizontal + + getSizeReq wenv node children = newSizeReq where + updateSizeReq = fromMaybe id (_grcSizeReqUpdater config) + vchildren = Seq.filter (_wniVisible . _wnInfo) children + newSizeReqW = getDimSizeReq isHorizontal (_wniSizeReqW . _wnInfo) vchildren + newSizeReqH = getDimSizeReq isVertical (_wniSizeReqH . _wnInfo) vchildren + newSizeReq = updateSizeReq (newSizeReqW, newSizeReqH) + + getDimSizeReq mainAxis accesor vchildren + | Seq.null vreqs = fixedSize 0 + | mainAxis = foldl1 sizeReqMergeSum (Seq.replicate nreqs maxSize) + | otherwise = maxSize + where + vreqs = accesor <$> vchildren + nreqs = Seq.length vreqs + maxSize = foldl1 sizeReqMergeMax vreqs + + resize wenv node viewport children = resized where + style = currentStyle wenv node + contentArea = fromMaybe def (removeOuterBounds style viewport) + Rect l t w h = contentArea + vchildren = Seq.filter (_wniVisible . _wnInfo) children + + cols = if isHorizontal then length vchildren else 1 + rows = if isHorizontal then 1 else length vchildren + + cw = if cols > 0 then w / fromIntegral cols else 0 + ch = if rows > 0 then h / fromIntegral rows else 0 + + cx i + | rows > 0 = l + fromIntegral (i `div` rows) * cw + | otherwise = 0 + cy i + | cols > 0 = t + fromIntegral (i `div` cols) * ch + | otherwise = 0 + + foldHelper (currAreas, index) child = (newAreas, newIndex) where + (newIndex, newViewport) + | child ^. L.info . L.visible = (index + 1, calcViewport index) + | otherwise = (index, def) + newArea = newViewport + newAreas = currAreas |> newArea + calcViewport i = Rect (cx i) (cy i) cw ch + + assignedAreas = fst $ foldl' foldHelper (Seq.empty, 0) children + resized = (resultNode node, assignedAreas) diff --git a/src/Monomer/Widgets/Containers/Keystroke.hs b/src/Monomer/Widgets/Containers/Keystroke.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Keystroke.hs @@ -0,0 +1,223 @@ +{-| +Module : Monomer.Widgets.Containers.Keystroke +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Container which generates user provided events when combinations of keys happen. +Using this event makes sense at the application level or Composite level. If +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: + +- 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 +- Lowercase letters (uppercase keys are reserved for mod and action keys) +- Numbers + +These can be combined, for example: + +- Copy: "Ctrl-c" or "C-c" +- App config: "Ctrl-Shift-p" or "C-S-p" + +Configs: + +- ignoreChildrenEvts: If True, when a shortcut is detected, the KeyAction event +will not be passed down to children. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Containers.Keystroke ( + keystroke, + keystroke_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), (%~), at) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Bifunctor (first) +import Data.Char (chr, isAscii, isPrint, ord) +import Data.Default +import Data.List (foldl') +import Data.Maybe +import Data.Set (Set) +import Data.Text (Text) + +import qualified Data.Map as M +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +newtype KeystrokeCfg = KeystrokeCfg { + _kscIgnoreChildren :: Maybe Bool +} + +instance Default KeystrokeCfg where + def = KeystrokeCfg { + _kscIgnoreChildren = Nothing + } + +instance Semigroup KeystrokeCfg where + (<>) t1 t2 = KeystrokeCfg { + _kscIgnoreChildren = _kscIgnoreChildren t2 <|> _kscIgnoreChildren t1 + } + +instance Monoid KeystrokeCfg where + mempty = def + +instance CmbIgnoreChildrenEvts KeystrokeCfg where + ignoreChildrenEvts_ ignore = def { + _kscIgnoreChildren = Just ignore + } + +data KeyStroke = KeyStroke { + _kstKsC :: Bool, + _kstKsCtrl :: Bool, + _kstKsCmd :: Bool, + _kstKsAlt :: Bool, + _kstKsShift :: Bool, + _kstKsKeys :: Set KeyCode +} deriving (Eq, Show) + +instance Default KeyStroke where + def = KeyStroke { + _kstKsC = False, + _kstKsCtrl = False, + _kstKsCmd = False, + _kstKsAlt = False, + _kstKsShift = False, + _kstKsKeys = Set.empty + } + +makeLensesWith abbreviatedFields ''KeyStroke + +-- | Creates a keystroke container with a single node as child. +keystroke :: WidgetEvent e => [(Text, e)] -> WidgetNode s e -> WidgetNode s e +keystroke bindings managed = keystroke_ bindings def managed + +-- | Creates a keystroke container with a single node as child. Accepts config, +keystroke_ + :: WidgetEvent e + => [(Text, e)] + -> [KeystrokeCfg] + -> WidgetNode s e + -> WidgetNode s e +keystroke_ bindings configs managed = makeNode widget managed where + config = mconcat configs + newBindings = fmap (first textToStroke) bindings + widget = makeKeystroke newBindings config + +makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode widget managedWidget = defaultWidgetNode "keystroke" widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeKeystroke :: WidgetEvent e => [(KeyStroke, e)] -> KeystrokeCfg -> Widget s e +makeKeystroke bindings config = widget where + widget = createContainer () def { + containerHandleEvent = handleEvent + } + + handleEvent wenv node target evt = case evt of + KeyAction mod code KeyPressed -> Just result where + ignoreChildren = Just True == _kscIgnoreChildren config + newWenv = wenv & L.inputStatus %~ removeMods + evts = snd <$> filter (keyStrokeActive newWenv code . fst) bindings + reqs + | ignoreChildren && not (null evts) = [IgnoreChildrenEvents] + | otherwise = [] + result = resultReqsEvts node reqs evts + _ -> Nothing + +keyStrokeActive :: WidgetEnv s e -> KeyCode -> KeyStroke -> Bool +keyStrokeActive wenv code 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 + + ctrlPressed = isCtrlPressed keyMod + cmdPressed = isMacOS wenv && isGUIPressed keyMod + + 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 + validAlt = ks ^. ksAlt == isAltPressed keyMod + + validMods = (validC && validCtrl && validCmd) && validShift && validAlt + +textToStroke :: Text -> KeyStroke +textToStroke text = ks where + parts = T.split (=='-') text + ks = foldl' partToStroke def parts + +partToStroke :: KeyStroke -> Text -> KeyStroke +partToStroke ks "A" = ks & ksAlt .~ True +partToStroke ks "Alt" = ks & ksAlt .~ True +partToStroke ks "C" = ks & ksC .~ True +partToStroke ks "Ctrl" = ks & ksCtrl .~ True +partToStroke ks "Cmd" = ks & ksCmd .~ True +partToStroke ks "O" = ks & ksAlt .~ True +partToStroke ks "Option" = ks & ksAlt .~ True +partToStroke ks "S" = ks & ksShift .~ True +partToStroke ks "Shift" = ks & ksShift .~ True +-- Main keys +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 "Esc" = ks & ksKeys %~ Set.insert keyEscape +partToStroke ks "Return" = ks & ksKeys %~ Set.insert keyReturn +partToStroke ks "Space" = ks & ksKeys %~ Set.insert keySpace +partToStroke ks "Tab" = ks & ksKeys %~ Set.insert keyTab +-- Arrows +partToStroke ks "Up" = ks & ksKeys %~ Set.insert keyUp +partToStroke ks "Down" = ks & ksKeys %~ Set.insert keyDown +partToStroke ks "Left" = ks & ksKeys %~ Set.insert keyLeft +partToStroke ks "Right" = ks & ksKeys %~ Set.insert keyRight +-- Function keys +partToStroke ks "F1" = ks & ksKeys %~ Set.insert keyF1 +partToStroke ks "F2" = ks & ksKeys %~ Set.insert keyF2 +partToStroke ks "F3" = ks & ksKeys %~ Set.insert keyF3 +partToStroke ks "F4" = ks & ksKeys %~ Set.insert keyF4 +partToStroke ks "F5" = ks & ksKeys %~ Set.insert keyF5 +partToStroke ks "F6" = ks & ksKeys %~ Set.insert keyF6 +partToStroke ks "F7" = ks & ksKeys %~ Set.insert keyF7 +partToStroke ks "F8" = ks & ksKeys %~ Set.insert keyF8 +partToStroke ks "F9" = ks & ksKeys %~ Set.insert keyF9 +partToStroke ks "F10" = ks & ksKeys %~ Set.insert keyF10 +partToStroke ks "F11" = ks & ksKeys %~ Set.insert keyF11 +partToStroke ks "F12" = ks & ksKeys %~ Set.insert keyF12 +-- Other keys (numbers, letters, points, etc) +partToStroke ks txt + | isValid = ks & ksKeys %~ Set.insert (KeyCode (ord txtHead)) + | otherwise = ks + where + isValid = T.length txt == 1 && isAscii txtHead && isPrint txtHead + txtHead = T.index txt 0 + +removeMods :: InputStatus -> InputStatus +removeMods status = status + & L.keys %~ M.filterWithKey (\k v -> k `notElem` modKeys) + +modKeys :: [KeyCode] +modKeys = [ + keyLAlt, keyRAlt, keyLCtrl, keyRCtrl, keyLGUI, keyRGUI, keyLShift, keyRShift + ] diff --git a/src/Monomer/Widgets/Containers/Scroll.hs b/src/Monomer/Widgets/Containers/Scroll.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Scroll.hs @@ -0,0 +1,779 @@ +{-| +Module : Monomer.Widgets.Containers.Scroll +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Scroll container of a single node. Assigns all the space the inner node requests +but limits itself to what its parent assigns. It allows navigating the content +of the inner node with the scroll bars. It also supports automatic focus +following. + +Configs: + +- wheelRate: rate at which wheel movement causes scrolling. +- barColor: the color of the bar (container of the thumb). +- barHoverColor: the color of the bar when mouse is on top. +- barWidth: the width of the bar. +- thumbColor: the color of the thumb. +- thumbHoverColor: the color of the thumb when mouse is on top. +- thumbWidth: the width of the thumb. +- thumbRadius: the radius of the corners of the thumb. +- scrollOverlay_: whether scroll bar should be on top of content or by the side. +- scrollInvisible_: shortcut for setting invisible style. Useful with scroll +overlay, since it allows scrolling without taking up space or hiding content. +- scrollFollowFocus_: whether to auto scroll when focusing a non visible item. +- scrollStyle: the base style of the scroll bar. + +Messages: + +- ScrollTo: Causes the scroll to update its handles to ensure rect is visible. +- ScrollReset: Sets both handle positions to zero. +-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Monomer.Widgets.Containers.Scroll ( + ScrollMessage(..), + scroll, + scroll_, + hscroll, + hscroll_, + vscroll, + vscroll_, + scrollOverlay, + scrollOverlay_, + scrollFwdStyle, + scrollFwdDefault, + scrollInvisible, + scrollInvisible_, + scrollFollowFocus, + scrollFollowFocus_, + scrollStyle +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~), (^?), (^?!), (<>~), (%~), _Just, cloneLens, ix) +import Control.Monad +import Data.Default +import Data.Maybe +import Data.Typeable (cast) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Helper +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +data ScrollType + = ScrollH + | ScrollV + | ScrollBoth + deriving (Eq, Show) + +data ActiveBar + = HBar + | VBar + deriving (Eq, Show, Generic) + +data ScrollCfg s e = ScrollCfg { + _scScrollType :: Maybe ScrollType, + _scScrollOverlay :: Maybe Bool, + _scScrollFwdStyle :: Maybe (WidgetEnv s e -> Style -> (Style, Style)), + _scFollowFocus :: Maybe Bool, + _scWheelRate :: Maybe Rational, + _scBarColor :: Maybe Color, + _scBarHoverColor :: Maybe Color, + _scThumbColor :: Maybe Color, + _scThumbHoverColor :: Maybe Color, + _scStyle :: Maybe (ALens' ThemeState StyleState), + _scBarWidth :: Maybe Double, + _scThumbWidth :: Maybe Double, + _scThumbRadius :: Maybe Double +} + +instance Default (ScrollCfg s e) where + def = ScrollCfg { + _scScrollType = Nothing, + _scScrollOverlay = Nothing, + _scScrollFwdStyle = Nothing, + _scFollowFocus = Nothing, + _scWheelRate = Nothing, + _scBarColor = Nothing, + _scBarHoverColor = Nothing, + _scThumbColor = Nothing, + _scThumbHoverColor = Nothing, + _scStyle = Nothing, + _scBarWidth = Nothing, + _scThumbWidth = Nothing, + _scThumbRadius = Nothing + } + +instance Semigroup (ScrollCfg s e) where + (<>) t1 t2 = ScrollCfg { + _scScrollType = _scScrollType t2 <|> _scScrollType t1, + _scScrollOverlay = _scScrollOverlay t2 <|> _scScrollOverlay t1, + _scScrollFwdStyle = _scScrollFwdStyle t2 <|> _scScrollFwdStyle t1, + _scFollowFocus = _scFollowFocus t2 <|> _scFollowFocus t1, + _scWheelRate = _scWheelRate t2 <|> _scWheelRate t1, + _scBarColor = _scBarColor t2 <|> _scBarColor t1, + _scBarHoverColor = _scBarHoverColor t2 <|> _scBarHoverColor t1, + _scThumbColor = _scThumbColor t2 <|> _scThumbColor t1, + _scThumbHoverColor = _scThumbHoverColor t2 <|> _scThumbHoverColor t1, + _scStyle = _scStyle t2 <|> _scStyle t1, + _scBarWidth = _scBarWidth t2 <|> _scBarWidth t1, + _scThumbWidth = _scThumbWidth t2 <|> _scThumbWidth t1, + _scThumbRadius = _scThumbRadius t2 <|> _scThumbRadius t1 + } + +instance Monoid (ScrollCfg s e) where + mempty = def + +instance CmbWheelRate (ScrollCfg s e) Rational where + wheelRate rate = def { + _scWheelRate = Just rate + } + +instance CmbBarColor (ScrollCfg s e) where + barColor col = def { + _scBarColor = Just col + } + +instance CmbBarHoverColor (ScrollCfg s e) where + barHoverColor col = def { + _scBarHoverColor = Just col + } + +instance CmbBarWidth (ScrollCfg s e) where + barWidth w = def { + _scBarWidth = Just w + } + +-- Thumb +instance CmbThumbColor (ScrollCfg s e) where + thumbColor col = def { + _scThumbColor = Just col + } + +instance CmbThumbHoverColor (ScrollCfg s e) where + thumbHoverColor col = def { + _scThumbHoverColor = Just col + } + +instance CmbThumbWidth (ScrollCfg s e) where + thumbWidth w = def { + _scThumbWidth = Just w + } + +instance CmbThumbRadius (ScrollCfg s e) where + thumbRadius r = def { + _scThumbRadius = Just r + } + +-- | Scroll bars will be displayed on top of the content. +scrollOverlay :: ScrollCfg s e +scrollOverlay = scrollOverlay_ True + +{-| +Sets whether scroll bars will be displayed on top of the content or next to it. +-} +scrollOverlay_ :: Bool -> ScrollCfg s e +scrollOverlay_ overlay = def { + _scScrollOverlay = Just overlay +} + +{-| +Sets a function that will split the node's style into one for the scroll and one +for the child node. Useful for widgets which wrap themselves in a scroll, such +as textArea, to be able to receive customizations made by the user. +-} +scrollFwdStyle :: (WidgetEnv s e -> Style -> (Style, Style)) -> ScrollCfg s e +scrollFwdStyle fwd = def { + _scScrollFwdStyle = Just fwd +} + +-- | Default style forward function, keeping standard fields for scroll. +scrollFwdDefault :: WidgetEnv s e -> Style -> (Style, Style) +scrollFwdDefault wenv style = (scrollStyle, childStyle) where + scrollStyle = def + & collectStyleField_ L.sizeReqW style + & collectStyleField_ L.sizeReqH style + & collectStyleField_ L.border style + & collectStyleField_ L.radius style + & collectStyleField_ L.bgColor style + childStyle = def + & collectStyleField_ L.padding style + & collectStyleField_ L.fgColor style + & collectStyleField_ L.sndColor style + & collectStyleField_ L.hlColor style + & collectStyleField_ L.text style + & collectStyleField_ L.cursorIcon style + +-- | Sets the style of the scroll bars to transparent. +scrollInvisible :: ScrollCfg s e +scrollInvisible = scrollInvisible_ True + +-- | Whether to set the style of the scroll bars to transparent. +scrollInvisible_ :: Bool -> ScrollCfg s e +scrollInvisible_ False = def +scrollInvisible_ True = def { + _scScrollOverlay = Just True, + _scBarColor = Just transparent, + _scBarHoverColor = Just transparent, + _scThumbColor = Just transparent, + _scThumbHoverColor = Just transparent +} + +-- | Makes the scroll automatically follow focused items to make them visible. +scrollFollowFocus :: ScrollCfg s e +scrollFollowFocus = scrollFollowFocus_ True + +-- | Whether to automatically follow focused items to make them visible. +scrollFollowFocus_ :: Bool -> ScrollCfg s e +scrollFollowFocus_ follow = def { + _scFollowFocus = Just follow +} + +{-| +Sets the base style of the scroll bar. Useful when creating widgets which use +scroll and may need to customize it. +-} +scrollStyle :: ALens' ThemeState StyleState -> ScrollCfg s e +scrollStyle style = def { + _scStyle = Just style +} + +-- Not exported +scrollType :: ScrollType -> ScrollCfg s e +scrollType st = def { + _scScrollType = Just st +} + +data ScrollState = ScrollState { + _sstDragging :: Maybe ActiveBar, + _sstDeltaX :: !Double, + _sstDeltaY :: !Double, + _sstVpSize :: Size, + _sstChildSize :: Size, + _sstScissor :: Rect +} deriving (Eq, Show, Generic) + +data ScrollContext = ScrollContext { + hScrollRatio :: Double, + vScrollRatio :: Double, + hScrollRequired :: Bool, + vScrollRequired :: Bool, + hMouseInScroll :: Bool, + vMouseInScroll :: Bool, + hMouseInThumb :: Bool, + vMouseInThumb :: Bool, + hScrollRect :: Rect, + vScrollRect :: Rect, + hThumbRect :: Rect, + vThumbRect :: Rect +} deriving (Eq, Show) + +instance Default ScrollState where + def = ScrollState { + _sstDragging = Nothing, + _sstDeltaX = 0, + _sstDeltaY = 0, + _sstVpSize = def, + _sstChildSize = def, + _sstScissor = def + } + +-- | Messages the scroll component supports. +data ScrollMessage + -- | Causes the scroll to update its bars to ensure rect is visible. + = ScrollTo Rect + -- | Sets both bars to zero. + | ScrollReset + deriving (Eq, Show) + +-- | Creates a scroll node that may show both bars. +scroll :: WidgetNode s e -> WidgetNode s e +scroll managedWidget = scroll_ def managedWidget + +-- | Creates a scroll node that may show both bars. Accepts config. +scroll_ :: [ScrollCfg s e] -> WidgetNode s e -> WidgetNode s e +scroll_ configs managed = makeNode (makeScroll config def) managed where + config = mconcat configs + +-- | Creates a horizontal scroll node. Vertical space is equal to what the +-- | parent node assigns. +hscroll :: WidgetNode s e -> WidgetNode s e +hscroll managedWidget = hscroll_ def managedWidget + +-- | Creates a horizontal scroll node. Vertical space is equal to what the +-- | parent node assigns. Accepts config. +hscroll_ :: [ScrollCfg s e] -> WidgetNode s e -> WidgetNode s e +hscroll_ configs managed = makeNode (makeScroll config def) managed where + config = mconcat (scrollType ScrollH : configs) + +-- | Creates a vertical scroll node. Vertical space is equal to what the +-- | parent node assigns. +vscroll :: WidgetNode s e -> WidgetNode s e +vscroll managedWidget = vscroll_ def managedWidget + +-- | Creates a vertical scroll node. Vertical space is equal to what the +-- | parent node assigns. Accepts config. +vscroll_ :: [ScrollCfg s e] -> WidgetNode s e -> WidgetNode s e +vscroll_ configs managed = makeNode (makeScroll config def) managed where + config = mconcat (scrollType ScrollV : configs) + +makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode widget managedWidget = defaultWidgetNode "scroll" widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeScroll :: ScrollCfg s e -> ScrollState -> Widget s e +makeScroll config state = widget where + widget = createContainer state def { + containerChildrenOffset = Just offset, + containerChildrenScissor = Just (_sstScissor state), + containerLayoutDirection = layoutDirection, + containerGetBaseStyle = getBaseStyle, + containerGetCurrentStyle = scrollCurrentStyle, + containerInit = init, + containerMerge = merge, + containerFindByPoint = findByPoint, + containerHandleEvent = handleEvent, + containerHandleMessage = handleMessage, + containerGetSizeReq = getSizeReq, + containerResize = resize, + containerRenderAfter = renderAfter + } + + ScrollState dragging dx dy _ _ _ = state + Size childWidth childHeight = _sstChildSize state + Size maxVpW maxVpH = _sstVpSize state + offset = Point dx dy + scrollType = fromMaybe ScrollBoth (_scScrollType config) + layoutDirection = case scrollType of + ScrollH -> LayoutHorizontal + ScrollV -> LayoutVertical + ScrollBoth -> LayoutNone + + getBaseStyle wenv node = _scStyle config >>= handler where + handler lstyle = Just $ collectTheme wenv (cloneLens lstyle) + + checkFwdStyle wenv node = newNode where + fwdStyle = _scScrollFwdStyle config + style = node ^. L.info . L.style + (parentStyle, childStyle) = fromJust fwdStyle wenv style + newNode + | isJust fwdStyle = node + & L.info . L.style .~ parentStyle + & L.children . ix 0 . L.info . L.style .~ childStyle + | otherwise = node + + init wenv node = resultNode newNode where + newNode = checkFwdStyle wenv node + + merge wenv node oldNode oldState = resultNode newNode where + newNode = checkFwdStyle wenv $ node + & L.widget .~ makeScroll config oldState + + findByPoint wenv node start point = result where + sctx = scrollStatus config wenv node state point + mouseInScroll + = (hMouseInScroll sctx && hScrollRequired sctx) + || (vMouseInScroll sctx && vScrollRequired sctx) + childPoint = addPoint point offset + + child = Seq.index (node ^. L.children) 0 + childHovered = isPointInNodeVp child childPoint + childDragged = isNodePressed wenv child + result + | (not mouseInScroll && childHovered) || childDragged = Just 0 + | otherwise = Nothing + + handleEvent wenv node target evt = case evt of + Focus{} -> result where + overlay = wenv ^. L.overlayPath + inOverlay info + | isJust overlay = seqStartsWith (fromJust overlay) (info ^. L.path) + | otherwise = False + focusPath = wenv ^. L.focusedPath + focusInst = findInstOrScroll wenv node focusPath + focusVp = focusInst ^? _Just . L.viewport + focusOverlay = maybe False inOverlay focusInst + + follow = fromMaybe (theme ^. L.scrollFollowFocus) (_scFollowFocus config) + overlayMatch = focusOverlay == inOverlay (node ^. L.info) + + result + | follow && overlayMatch = focusVp >>= scrollTo wenv node + | otherwise = Nothing + + ButtonAction point btn status _ -> result where + leftPressed = status == BtnPressed && btn == wenv ^. L.mainButton + btnReleased = status == BtnReleased && btn == wenv ^. L.mainButton + + isDragging = isJust $ _sstDragging state + startDrag = leftPressed && not isDragging + + jumpScrollH = btnReleased && not isDragging && hMouseInScroll sctx + jumpScrollV = btnReleased && not isDragging && vMouseInScroll sctx + + mouseInScroll = hMouseInScroll sctx || vMouseInScroll sctx + mouseInThumb = hMouseInThumb sctx || vMouseInThumb sctx + + newState + | startDrag && hMouseInThumb sctx = state { _sstDragging = Just HBar } + | startDrag && vMouseInThumb sctx = state { _sstDragging = Just VBar } + | jumpScrollH = updateScrollThumb state HBar point contentArea sctx + | jumpScrollV = updateScrollThumb state VBar point contentArea sctx + | btnReleased = state { _sstDragging = Nothing } + | otherwise = state + + newRes = rebuildWidget wenv node newState + handledResult = Just $ newRes + & L.requests <>~ Seq.fromList scrollReqs + result + | leftPressed && mouseInThumb = handledResult + | btnReleased && mouseInScroll = handledResult + | btnReleased && isDragging = handledResult + | otherwise = Nothing + + Move point | isJust dragging -> result where + drag bar = updateScrollThumb state bar point contentArea sctx + makeWidget state = rebuildWidget wenv node state + makeResult state = makeWidget state + & L.requests <>~ Seq.fromList (RenderOnce : scrollReqs) + result = fmap (makeResult . drag) dragging + + Move point | isNothing dragging -> result where + mousePosPrev = wenv ^. L.inputStatus . L.mousePosPrev + psctx = scrollStatus config wenv node state mousePosPrev + changed + = hMouseInThumb sctx /= hMouseInThumb psctx + || vMouseInThumb sctx /= vMouseInThumb psctx + || hMouseInScroll sctx /= hMouseInScroll psctx + || vMouseInScroll sctx /= vMouseInScroll psctx + result + | changed = Just $ resultReqs node [RenderOnce] + | otherwise = Nothing + + WheelScroll _ (Point wx wy) wheelDirection -> result where + changedX = wx /= 0 && childWidth > cw + changedY = wy /= 0 && childHeight > ch + + needsUpdate = changedX || changedY + makeWidget state = rebuildWidget wenv node state + makeResult state = makeWidget state + & L.requests <>~ Seq.fromList scrollReqs + + result + | needsUpdate = Just $ makeResult newState + | otherwise = Nothing + stepX + | wheelDirection == WheelNormal = -wheelRate * wx + | otherwise = wheelRate * wx + stepY + | wheelDirection == WheelNormal = wheelRate * wy + | otherwise = -wheelRate * wy + newState = state { + _sstDeltaX = scrollAxisH (stepX + dx), + _sstDeltaY = scrollAxisV (stepY + dy) + } + + _ -> Nothing + where + theme = currentTheme wenv node + style = scrollCurrentStyle wenv node + contentArea = getContentArea node style + mousePos = wenv ^. L.inputStatus . L.mousePos + + Rect cx cy cw ch = contentArea + sctx = scrollStatus config wenv node state mousePos + scrollReqs = [IgnoreParentEvents] + wheelCfg = fromMaybe (theme ^. L.scrollWheelRate) (_scWheelRate config) + wheelRate = fromRational wheelCfg + + scrollAxis reqDelta childLength vpLength + | maxDelta == 0 = 0 + | reqDelta < 0 = max reqDelta (-maxDelta) + | otherwise = min reqDelta 0 + where + maxDelta = max 0 (childLength - vpLength) + scrollAxisH delta = scrollAxis delta childWidth maxVpW + scrollAxisV delta = scrollAxis delta childHeight maxVpH + + handleMessage wenv node target message = result where + handleScrollMessage (ScrollTo rect) = scrollTo wenv node rect + handleScrollMessage ScrollReset = scrollReset wenv node + result = cast message >>= handleScrollMessage + + scrollTo wenv node targetRect = result where + style = scrollCurrentStyle wenv node + contentArea = getContentArea node style + + rect = moveRect offset targetRect + Rect rx ry rw rh = rect + Rect cx cy _ _ = contentArea + + diffL = cx - rx + diffR = cx + maxVpW - (rx + rw) + diffT = cy - ry + diffB = cy + maxVpH - (ry + rh) + + stepX + | rectInRectH rect contentArea = dx + | abs diffL <= abs diffR = diffL + dx + | otherwise = diffR + dx + stepY + | rectInRectV rect contentArea = dy + | abs diffT <= abs diffB = diffT + dy + | otherwise = diffB + dy + + newState = state { + _sstDeltaX = scrollAxisH stepX, + _sstDeltaY = scrollAxisV stepY + } + result + | rectInRect rect contentArea = Nothing + | otherwise = Just $ rebuildWidget wenv node newState + + scrollReset wenv node = result where + newState = state { + _sstDeltaX = 0, + _sstDeltaY = 0 + } + result = Just $ rebuildWidget wenv node newState + + updateScrollThumb state activeBar point contentArea sctx = newState where + Point px py = point + ScrollContext{..} = sctx + Rect cx cy _ _ = contentArea + + hMid = _rW hThumbRect / 2 + vMid = _rH vThumbRect / 2 + + hDelta = (cx - px + hMid) / hScrollRatio + vDelta = (cy - py + vMid) / vScrollRatio + + newDeltaX + | activeBar == HBar = scrollAxisH hDelta + | otherwise = dx + newDeltaY + | activeBar == VBar = scrollAxisV vDelta + | otherwise = dy + + newState = state { + _sstDeltaX = newDeltaX, + _sstDeltaY = newDeltaY + } + + rebuildWidget wenv node newState = result where + newNode = node + & L.widget .~ makeScroll config newState + result = resultNode newNode + + getSizeReq :: ContainerGetSizeReqHandler s e + getSizeReq wenv node children = sizeReq where + style = scrollCurrentStyle wenv node + child = Seq.index children 0 + + tw = sizeReqMaxBounded $ child ^. L.info . L.sizeReqW + th = sizeReqMaxBounded $ child ^. L.info . L.sizeReqH + + Size w h = fromMaybe def (addOuterSize style (Size tw th)) + factor = 1 + + sizeReq = (expandSize w factor, expandSize h factor) + + resize wenv node viewport children = result where + theme = currentTheme wenv node + style = scrollCurrentStyle wenv node + + Rect cl ct cw ch = fromMaybe def (removeOuterBounds style viewport) + dx = _sstDeltaX state + dy = _sstDeltaY state + + child = Seq.index (node ^. L.children) 0 + childW = sizeReqMaxBounded $ child ^. L.info . L.sizeReqW + childH = sizeReqMaxBounded $ child ^. L.info . L.sizeReqH + + barW = fromMaybe (theme ^. L.scrollBarWidth) (_scBarWidth config) + overlay = fromMaybe (theme ^. L.scrollOverlay) (_scScrollOverlay config) + + (ncw, nch) + | not overlay = (cw - barW, ch - barW) + | otherwise = (cw, ch) + (maxW, areaW) + | scrollType == ScrollV && childH > ch = (ncw, ncw) + | scrollType == ScrollV = (cw, cw) + | scrollType == ScrollH = (cw, max cw childW) + | childH <= ch && childW <= cw = (cw, cw) + | childH <= ch = (cw, max cw childW) + | otherwise = (ncw, max ncw childW) + (maxH, areaH) + | scrollType == ScrollH && childW > cw = (nch, nch) + | scrollType == ScrollH = (ch, ch) + | scrollType == ScrollV = (ch, max ch childH) + | childW <= cw && childH <= ch = (ch, ch) + | childW <= cw = (ch, max ch childH) + | otherwise = (nch, max nch childH) + + newDx = scrollAxis dx areaW maxW + newDy = scrollAxis dy areaH maxH + + scissor = Rect cl ct maxW maxH + cViewport = Rect cl ct areaW areaH + + newState = state { + _sstDeltaX = newDx, + _sstDeltaY = newDy, + _sstVpSize = Size maxW maxH, + _sstChildSize = Size areaW areaH, + _sstScissor = scissor + } + newNode = resultNode $ node + & L.widget .~ makeScroll config newState + result = (newNode, Seq.singleton cViewport) + + renderAfter wenv node renderer = do + when hScrollRequired $ + drawRect renderer hScrollRect barColorH Nothing + + when vScrollRequired $ + drawRect renderer vScrollRect barColorV Nothing + + when hScrollRequired $ + drawRect renderer hThumbRect thumbColorH thumbRadius + + when vScrollRequired $ + drawRect renderer vThumbRect thumbColorV thumbRadius + where + ScrollContext{..} = scrollStatus config wenv node state mousePos + mousePos = wenv ^. L.inputStatus . L.mousePos + + draggingH = _sstDragging state == Just HBar + draggingV = _sstDragging state == Just VBar + + theme = wenv ^. L.theme + athm = currentTheme wenv node + tmpRad = fromMaybe (athm ^. L.scrollThumbRadius) (_scThumbRadius config) + thumbRadius + | tmpRad > 0 = Just (radius tmpRad) + | otherwise = Nothing + + cfgBarBCol = _scBarColor config + cfgBarHCol = _scBarHoverColor config + cfgThumbBCol = _scThumbColor config + cfgThumbHCol = _scThumbHoverColor config + + barBCol = cfgBarBCol <|> Just (theme ^. L.basic . L.scrollBarColor) + barHCol = cfgBarHCol <|> Just (theme ^. L.hover . L.scrollBarColor) + + thumbBCol = cfgThumbBCol <|> Just (theme ^. L.basic . L.scrollThumbColor) + thumbHCol = cfgThumbHCol <|> Just (theme ^. L.hover. L.scrollThumbColor) + + barColorH + | hMouseInScroll = barHCol + | otherwise = barBCol + barColorV + | vMouseInScroll = barHCol + | otherwise = barBCol + thumbColorH + | hMouseInThumb || draggingH = thumbHCol + | otherwise = thumbBCol + thumbColorV + | vMouseInThumb || draggingV = thumbHCol + | otherwise = thumbBCol + +scrollCurrentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState +scrollCurrentStyle wenv node + | isNodeFocused wenv child = focusedStyle wenv node + | otherwise = currentStyle wenv node + where + child = node ^. L.children ^?! ix 0 + +scrollStatus + :: ScrollCfg s e + -> WidgetEnv s e + -> WidgetNode s e + -> 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 + 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) + + caLeft = _rX contentArea + caTop = _rY contentArea + caWidth = _rW contentArea + caHeight = _rH contentArea + + hScrollTop = caHeight - barW + vScrollLeft = caWidth - barW + + 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) + hScrollRequired = hScrollRatio < 1 + vScrollRequired = vScrollRatio < 1 + + hScrollRect = Rect { + _rX = caLeft, + _rY = caTop + hScrollTop, + _rW = vpWidth, + _rH = barW + } + vScrollRect = Rect { + _rX = caLeft + vScrollLeft, + _rY = caTop, + _rW = barW, + _rH = vpHeight + } + hThumbRect = Rect { + _rX = caLeft - hScrollRatio * dx, + _rY = caTop + hScrollTop + (barW - thumbW) / 2, + _rW = hScrollRatio * vpWidth, + _rH = thumbW + } + vThumbRect = Rect { + _rX = caLeft + vScrollLeft + (barW - thumbW) / 2, + _rY = caTop - vScrollRatio * dy, + _rW = thumbW, + _rH = vScrollRatio * vpHeight + } + + hMouseInScroll = pointInRect mousePos hScrollRect + vMouseInScroll = pointInRect mousePos vScrollRect + + hMouseInThumb = pointInRect mousePos hThumbRect + vMouseInThumb = pointInRect mousePos vThumbRect + +findInstOrScroll + :: WidgetEnv s e -> WidgetNode s e -> Seq.Seq PathStep -> Maybe WidgetNodeInfo +findInstOrScroll wenv node target = wniScroll <|> wniTarget where + child = Seq.index (node ^. L.children) 0 + isScroll wni = wni ^. L.widgetType == "scroll" + branch = widgetFindBranchByPath (child ^. L.widget) wenv child target + scrolls = Seq.filter isScroll branch + wniTarget = Seq.lookup (length branch - 1) branch + wniScroll = Seq.lookup (length scrolls - 1) scrolls diff --git a/src/Monomer/Widgets/Containers/SelectList.hs b/src/Monomer/Widgets/Containers/SelectList.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/SelectList.hs @@ -0,0 +1,527 @@ +{-| +Module : Monomer.Widgets.Containers.SelectList +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Select list widget, allowing selection of a single item. List content (rows) is +customizable, plus its styling. + +Configs: + +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetReqest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetReqest to generate when focus is lost. +- onChange: event to raise when selected item changes. +- onChangeReq: WidgetRequest to generate when selected item changes. +- onChangeIdx: event to raise when selected item changes. Includes index, +- onChangeIdxReq: WidgetRequest to generate when selected item changes. Includes +index. +- selectOnBlur: whether to select the currently highlighted item when navigating +away from the widget with tab key. +- itemBasicStyle: style of an item in the list when not selected. +- itemSelectedStyle: style of the selected item in the list. +- mergeRequired: whether merging children is required. Useful when select list +is part of another widget such as dropdown. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +module Monomer.Widgets.Containers.SelectList ( + SelectListCfg, + SelectListItem(..), + SelectListMessage(..), + selectList, + selectList_, + selectListV, + selectListV_, + selectListD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (^?), (^?!), (.~), (%~), (?~), (<>~), at, ix, non, _Just) +import Control.Monad (when) +import Data.Default +import Data.List (foldl') +import Data.Maybe +import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Text (Text) +import Data.Typeable (Typeable, cast) + +import qualified Data.Map as Map +import qualified Data.Sequence as Seq + +import Monomer.Graphics.Lens +import Monomer.Widgets.Container +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Scroll +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +-- | Constraints for an item handled by selectList. +type SelectListItem a = (Eq a, Show a, Typeable a) +-- | Creates a row from an item. +type MakeRow s e a = a -> WidgetNode s e + +-- | Configuration options for selectList widget. +data SelectListCfg s e a = SelectListCfg { + _slcSelectOnBlur :: Maybe Bool, + _slcItemStyle :: Maybe Style, + _slcItemSelectedStyle :: Maybe Style, + _slcMergeRequired :: Maybe (Seq a -> Seq a -> Bool), + _slcOnFocusReq :: [Path -> WidgetRequest s e], + _slcOnBlurReq :: [Path -> WidgetRequest s e], + _slcOnChangeReq :: [a -> WidgetRequest s e], + _slcOnChangeIdxReq :: [Int -> a -> WidgetRequest s e] +} + +instance Default (SelectListCfg s e a) where + def = SelectListCfg { + _slcSelectOnBlur = Nothing, + _slcItemStyle = Nothing, + _slcItemSelectedStyle = Nothing, + _slcMergeRequired = Nothing, + _slcOnFocusReq = [], + _slcOnBlurReq = [], + _slcOnChangeReq = [], + _slcOnChangeIdxReq = [] + } + +instance Semigroup (SelectListCfg s e a) where + (<>) t1 t2 = SelectListCfg { + _slcSelectOnBlur = _slcSelectOnBlur t2 <|> _slcSelectOnBlur t1, + _slcItemStyle = _slcItemStyle t2 <|> _slcItemStyle t1, + _slcItemSelectedStyle = _slcItemSelectedStyle t2 <|> _slcItemSelectedStyle t1, + _slcMergeRequired = _slcMergeRequired t2 <|> _slcMergeRequired t1, + _slcOnFocusReq = _slcOnFocusReq t1 <> _slcOnFocusReq t2, + _slcOnBlurReq = _slcOnBlurReq t1 <> _slcOnBlurReq t2, + _slcOnChangeReq = _slcOnChangeReq t1 <> _slcOnChangeReq t2, + _slcOnChangeIdxReq = _slcOnChangeIdxReq t1 <> _slcOnChangeIdxReq t2 + } + +instance Monoid (SelectListCfg s e a) where + mempty = def + +instance WidgetEvent e => CmbOnFocus (SelectListCfg s e a) e Path where + onFocus fn = def { + _slcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (SelectListCfg s e a) s e Path where + onFocusReq req = def { + _slcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (SelectListCfg s e a) e Path where + onBlur fn = def { + _slcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (SelectListCfg s e a) s e Path where + onBlurReq req = def { + _slcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (SelectListCfg s e a) a e where + onChange fn = def { + _slcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (SelectListCfg s e a) s e a where + onChangeReq req = def { + _slcOnChangeReq = [req] + } + +instance WidgetEvent e => CmbOnChangeIdx (SelectListCfg s e a) e a where + onChangeIdx fn = def { + _slcOnChangeIdxReq = [(RaiseEvent .) . fn] + } + +instance CmbOnChangeIdxReq (SelectListCfg s e a) s e a where + onChangeIdxReq req = def { + _slcOnChangeIdxReq = [req] + } + +instance CmbSelectOnBlur (SelectListCfg s e a) where + selectOnBlur_ select = def { + _slcSelectOnBlur = Just select + } + +instance CmbItemBasicStyle (SelectListCfg s e a) Style where + itemBasicStyle style = def { + _slcItemStyle = Just style + } + +instance CmbItemSelectedStyle (SelectListCfg s e a) Style where + itemSelectedStyle style = def { + _slcItemSelectedStyle = Just style + } + +instance CmbMergeRequired (SelectListCfg s e a) (Seq a) where + mergeRequired fn = def { + _slcMergeRequired = Just fn + } + +data SelectListState a = SelectListState { + _prevItems :: Seq a, + _slIdx :: Int, + _hlIdx :: Int +} deriving (Eq, Show) + +-- | Messages received by selectList. In general used internally. +data SelectListMessage + = SelectListClickItem Int + | SelectListShowSelected + deriving (Eq, Show) + +-- | Creates a select list using the given lens. +selectList + :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of selectable items. + -> MakeRow s e a -- ^ Function to create the list items. + -> WidgetNode s e -- ^ The created dropdown. +selectList field items makeRow = selectList_ field items makeRow def + +-- | Creates a select list using the given lens. Accepts config. +selectList_ + :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of selectable items. + -> MakeRow s e a -- ^ Function to create the list items. + -> [SelectListCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. +selectList_ field items makeRow configs = newNode where + newNode = selectListD_ (WidgetLens field) items makeRow configs + +-- | Creates a select list using the given value and onChange event handler. +selectListV + :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) + => a -- ^ The event to raise on change. + -> (Int -> a -> e) -- ^ The list of selectable items. + -> t a -- ^ The list of selectable items. + -> MakeRow s e a -- ^ Function to create the list items. + -> WidgetNode s e -- ^ The created dropdown. +selectListV value handler items makeRow = newNode where + newNode = selectListV_ value handler items makeRow def + +-- | Creates a select list using the given value and onChange event handler. +-- | Accepts config. +selectListV_ + :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) + => a -- ^ The event to raise on change. + -> (Int -> a -> e) -- ^ The list of selectable items. + -> t a -- ^ The list of selectable items. + -> MakeRow s e a -- ^ Function to create the list items. + -> [SelectListCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. +selectListV_ value handler items makeRow configs = newNode where + widgetData = WidgetValue value + newConfigs = onChangeIdx handler : configs + newNode = selectListD_ widgetData items makeRow newConfigs + +-- | Creates a dropdown providing a WidgetData instance and config. +selectListD_ + :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) + => WidgetData s a -- ^ The WidgetData to retrieve the value from. + -> t a -- ^ The list of selectable items. + -> MakeRow s e a -- ^ Function to create the list items. + -> [SelectListCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. +selectListD_ widgetData items makeRow configs = makeNode widget where + config = mconcat configs + newItems = foldl' (|>) Empty items + newState = SelectListState newItems (-1) 0 + widget = makeSelectList widgetData newItems makeRow config newState + +makeNode :: Widget s e -> WidgetNode s e +makeNode widget = scroll_ [scrollStyle L.selectListStyle] childNode where + childNode = defaultWidgetNode "selectList" widget + & L.info . L.focusable .~ True + +makeSelectList + :: (WidgetModel s, WidgetEvent e, SelectListItem a) + => WidgetData s a + -> Seq a + -> MakeRow s e a + -> SelectListCfg s e a + -> SelectListState a + -> Widget s e +makeSelectList widgetData items makeRow config state = widget where + widget = createContainer state def { + containerInit = init, + containerInitPost = initPost, + containerMergeChildrenReq = mergeChildrenReq, + containerMerge = merge, + containerMergePost = mergePost, + containerHandleEvent = handleEvent, + containerHandleMessage = handleMessage + } + + currentValue wenv = widgetDataGet (_weModel wenv) widgetData + + createSelectListChildren wenv node = children where + widgetId = node ^. L.info . L.widgetId + selected = currentValue wenv + itemsList = makeItemsList wenv items makeRow config widgetId selected + children = Seq.singleton itemsList + + init wenv node = resultNode newNode where + selected = currentValue wenv + newSl = fromMaybe (-1) (Seq.elemIndexL selected items) + newHl = if newSl < 0 then 0 else newSl + newState = state { + _slIdx = newSl, + _hlIdx = newHl + } + newNode = node + & L.widget .~ makeSelectList widgetData items makeRow config newState + & L.children .~ createSelectListChildren wenv node + + initPost wenv node newState result = newResult where + newResult = updateResultStyle wenv config result state newState + + mergeChildrenReq wenv node oldNode oldState = result where + oldItems = _prevItems oldState + mergeRequiredFn = fromMaybe (/=) (_slcMergeRequired config) + result = mergeRequiredFn oldItems items + + merge wenv node oldNode oldState = resultNode newNode where + selected = currentValue wenv + newSl = fromMaybe (-1) (Seq.elemIndexL selected items) + newHl + | newSl /= _slIdx oldState = newSl + | otherwise = _hlIdx oldState + newState = oldState { + _slIdx = newSl, + _hlIdx = newHl, + _prevItems = items + } + newNode = node + & L.widget .~ makeSelectList widgetData items makeRow config newState + & L.children .~ createSelectListChildren wenv node + + mergePost wenv node oldNode oldState newState result = newResult where + newResult = updateResultStyle wenv config result oldState newState + + handleEvent wenv node target evt = case evt of + ButtonAction _ btn BtnPressed _ + | btn == wenv ^. L.mainButton -> result where + result = Just $ resultReqs node [SetFocus (node ^. L.info . L.widgetId)] + + Focus prev -> handleFocusChange node prev (_slcOnFocusReq config) + + Blur next -> result where + tabPressed = wenv ^. L.inputStatus . L.keys . at keyTab == Just KeyPressed + changeReq = tabPressed && _slcSelectOnBlur config == Just True + WidgetResult tempNode tempReqs + | changeReq = selectItem wenv node (_hlIdx state) + | otherwise = resultNode node + reqs = tempReqs <> Seq.fromList (($ next) <$> _slcOnBlurReq config) + result + | changeReq || not (null reqs) = Just $ WidgetResult tempNode reqs + | otherwise = Nothing + + KeyAction mode code status + | isKeyDown code && status == KeyPressed -> highlightNext wenv node + | isKeyUp code && status == KeyPressed -> highlightPrev wenv node + | isSelectKey code && status == KeyPressed -> resultSelected + where + resultSelected = Just $ selectItem wenv node (_hlIdx state) + isSelectKey code = isKeyReturn code || isKeySpace code + _ -> Nothing + + highlightNext wenv node = highlightItem wenv node nextIdx where + tempIdx = _hlIdx state + nextIdx + | tempIdx < length items - 1 = tempIdx + 1 + | otherwise = tempIdx + + highlightPrev wenv node = highlightItem wenv node nextIdx where + tempIdx = _hlIdx state + nextIdx + | tempIdx > 0 = tempIdx - 1 + | otherwise = tempIdx + + handleMessage wenv node target message = result where + handleSelect (SelectListClickItem idx) = handleItemClick wenv node idx + handleSelect SelectListShowSelected = handleItemShow wenv node + result = fmap handleSelect (cast message) + + handleItemClick wenv node idx = result where + focusReq = SetFocus $ node ^. L.info . L.widgetId + tempResult = selectItem wenv node idx + result + | isNodeFocused wenv node = tempResult + | otherwise = tempResult & L.requests %~ (|> focusReq) + + handleItemShow wenv node = resultReqs node reqs where + reqs = itemScrollTo wenv node (_slIdx state) + + highlightItem wenv node nextIdx = Just result where + newState = state { + _hlIdx = nextIdx + } + tmpNode = node + & L.widget .~ makeSelectList widgetData items makeRow config newState + slIdx = _slIdx state + + (newNode, resizeReq) = updateStyles wenv config state tmpNode slIdx nextIdx + reqs = itemScrollTo wenv newNode nextIdx ++ resizeReq + result = resultReqs newNode reqs + + selectItem wenv node idx = result where + selected = currentValue wenv + value = fromMaybe selected (Seq.lookup idx items) + valueSetReq = widgetDataSet widgetData value + scrollToReq = itemScrollTo wenv node idx + changeReqs = fmap ($ value) (_slcOnChangeReq config) + ++ fmap (\fn -> fn idx value) (_slcOnChangeIdxReq config) + (styledNode, resizeReq) = updateStyles wenv config state node idx idx + + newState = state { + _slIdx = idx, + _hlIdx = idx + } + newNode = styledNode + & L.widget .~ makeSelectList widgetData items makeRow config newState + reqs = valueSetReq ++ scrollToReq ++ changeReqs ++ resizeReq + result = resultReqs newNode reqs + + itemScrollTo wenv node idx = maybeToList (scrollToReq <$> mwid <*> vp) where + vp = itemViewport node idx + mwid = findWidgetIdFromPath wenv (parentPath node) + scrollToReq wid rect = SendMessage wid (ScrollTo rect) + + itemViewport node idx = viewport where + lookup idx node = Seq.lookup idx (node ^. L.children) + viewport = fmap (_wniViewport . _wnInfo) $ pure node + >>= lookup 0 -- vstack + >>= lookup idx -- item + +updateStyles + :: WidgetEnv s e + -> SelectListCfg s e a + -> SelectListState a + -> WidgetNode s e + -> Int + -> Int + -> (WidgetNode s e, [WidgetRequest s e]) +updateStyles wenv config state node newSlIdx newHlIdx = (newNode, newReqs) where + widgetId = node ^. L.info . L.widgetId + items = node ^. L.children . ix 0 . L.children + normalStyle = getNormalStyle wenv config + idxMatch = newSlIdx == newHlIdx + + (slStyle, hlStyle) + | idxMatch = (getSlHlStyle wenv config, getSlHlStyle wenv config) + | otherwise = (getSlStyle wenv config, getHlStyle wenv config) + + (newChildren, resizeReq) = (items, False) + & updateItemStyle wenv (_slIdx state) (Just normalStyle) + & updateItemStyle wenv (_hlIdx state) (Just normalStyle) + & updateItemStyle wenv newHlIdx (Just hlStyle) + & updateItemStyle wenv newSlIdx (Just slStyle) + + newNode = node + & L.children . ix 0 . L.children .~ newChildren + newReqs = [ ResizeWidgets widgetId | resizeReq ] + +updateItemStyle + :: WidgetEnv s e + -> Int + -> Maybe Style + -> (Seq (WidgetNode s e), Bool) + -> (Seq (WidgetNode s e), Bool) +updateItemStyle wenv idx mstyle (items, resizeReq) = result where + result = case Seq.lookup idx items of + Just item -> (newItems, resizeReq || newResizeReq) where + tmpItem = setItemStyle item mstyle + (newItem, newResizeReq) = updateItemSizeReq wenv tmpItem + newItems = Seq.update idx newItem items + Nothing -> (items, resizeReq) + +updateItemSizeReq :: WidgetEnv s e -> WidgetNode s e -> (WidgetNode s e, Bool) +updateItemSizeReq wenv item = (newItem, resizeReq) where + (oldReqW, oldReqH) = (item^. L.info . L.sizeReqW, item^. L.info . L.sizeReqH) + (newReqW, newReqH) = widgetGetSizeReq (item ^. L.widget) wenv item + newItem = item + & L.info . L.sizeReqW .~ newReqW + & L.info . L.sizeReqH .~ newReqH + resizeReq = (oldReqW, oldReqH) /= (newReqW, newReqH) + +setItemStyle :: WidgetNode s e -> Maybe Style -> WidgetNode s e +setItemStyle item Nothing = item +setItemStyle item (Just st) = item + & L.children . ix 0 . L.info . L.style .~ st + +getSlStyle :: WidgetEnv s e -> SelectListCfg s e a -> Style +getSlStyle wenv config = style where + theme = collectTheme wenv L.selectListItemSelectedStyle + style = fromJust (Just theme <> _slcItemSelectedStyle config) + slStyle = style + & L.basic .~ style ^. L.focus + & L.hover .~ style ^. L.focusHover + +getSlHlStyle :: WidgetEnv s e -> SelectListCfg s e a -> Style +getSlHlStyle wenv config = slStyle where + style = getSlStyle wenv config + slStyle = style + & L.basic .~ style ^. L.focus + & L.hover .~ style ^. L.focusHover + +getHlStyle :: WidgetEnv s e -> SelectListCfg s e a -> Style +getHlStyle wenv config = hlStyle where + theme = collectTheme wenv L.selectListItemStyle + style = fromJust (Just theme <> _slcItemStyle config) + hlStyle = style + & L.basic .~ style ^. L.focus + & L.hover .~ style ^. L.focusHover + +getNormalStyle :: WidgetEnv s e -> SelectListCfg s e a -> Style +getNormalStyle wenv config = style where + theme = collectTheme wenv L.selectListItemStyle + style = fromJust (Just theme <> _slcItemStyle config) + +updateResultStyle + :: WidgetEnv s e + -> SelectListCfg s e a + -> WidgetResult s e + -> SelectListState a + -> SelectListState a + -> WidgetResult s e +updateResultStyle wenv config result oldState newState = newResult where + slIdx = _slIdx newState + hlIdx = _hlIdx newState + tmpNode = result ^. L.node + (newNode, reqs) = updateStyles wenv config oldState tmpNode slIdx hlIdx + newResult = resultReqs newNode reqs + +makeItemsList + :: (WidgetModel s, WidgetEvent e, Eq a) + => WidgetEnv s e + -> Seq a + -> MakeRow s e a + -> SelectListCfg s e a + -> WidgetId + -> a + -> WidgetNode s e +makeItemsList wenv items makeRow config widgetId selected = itemsList where + normalTheme = collectTheme wenv L.selectListItemStyle + normalStyle = fromJust (Just normalTheme <> _slcItemStyle config) + + makeItem idx item = newItem where + clickCfg = onClickReq $ SendMessage widgetId (SelectListClickItem idx) + itemCfg = [expandContent, clickCfg] + content = makeRow item + newItem = box_ itemCfg (content & L.info . L.style .~ normalStyle) + itemsList = vstack $ Seq.mapWithIndex makeItem items diff --git a/src/Monomer/Widgets/Containers/Split.hs b/src/Monomer/Widgets/Containers/Split.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Split.hs @@ -0,0 +1,380 @@ +{-| +Module : Monomer.Widgets.Containers.Split +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Splits the assigned space into two parts, 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. + +Configs: + +- splitHandlePos: lens to a model field which provides the handle position. +- splitHandlePosV: value which provides the handle position. +- splitHandleSize: width of the handle. +- splitIgnoreChildResize: whether to ignore changes in size to its children +(otherwise, the handle position may change because of this). +- onChange: raises an event when the handle is moved. +- onChangeReq: generates a WidgetReqest when the handle is moved. +-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Containers.Split ( + hsplit, + hsplit_, + vsplit, + vsplit_, + splitHandlePos, + splitHandlePosV, + splitHandleSize, + splitIgnoreChildResize +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~), (<>~)) +import Data.Default +import Data.Maybe +import Data.Tuple (swap) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container +import Monomer.Widgets.Containers.Stack (assignStackAreas) + +import qualified Monomer.Lens as L + +data SplitCfg s e = SplitCfg { + _spcHandlePos :: Maybe (WidgetData s Double), + _spcHandleSize :: Maybe Double, + _spcIgnoreChildResize :: Maybe Bool, + _spcOnChangeReq :: [Double -> WidgetRequest s e] +} + +instance Default (SplitCfg s e) where + def = SplitCfg { + _spcHandlePos = Nothing, + _spcHandleSize = Nothing, + _spcIgnoreChildResize = Nothing, + _spcOnChangeReq = [] + } + +instance Semigroup (SplitCfg s e) where + (<>) s1 s2 = SplitCfg { + _spcHandlePos = _spcHandlePos s2 <|> _spcHandlePos s1, + _spcHandleSize = _spcHandleSize s2 <|> _spcHandleSize s1, + _spcIgnoreChildResize = _spcIgnoreChildResize s2 <|> _spcIgnoreChildResize s1, + _spcOnChangeReq = _spcOnChangeReq s2 <|> _spcOnChangeReq s1 + } + +instance Monoid (SplitCfg s e) where + mempty = def + +instance WidgetEvent e => CmbOnChange (SplitCfg s e) Double e where + onChange fn = def { + _spcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (SplitCfg s e) s e Double where + onChangeReq req = def { + _spcOnChangeReq = [req] + } + +-- | Lens to a model field which provides the handle position. +splitHandlePos :: ALens' s Double -> SplitCfg s e +splitHandlePos field = def { + _spcHandlePos = Just (WidgetLens field) +} + +-- | Value which provides the handle position. +splitHandlePosV :: Double -> SplitCfg s e +splitHandlePosV value = def { + _spcHandlePos = Just (WidgetValue value) +} + +-- | Width of the handle. +splitHandleSize :: Double -> SplitCfg s e +splitHandleSize w = def { + _spcHandleSize = Just w +} + +-- | Whether to ignore changes in size to its children. +splitIgnoreChildResize :: Bool -> SplitCfg s e +splitIgnoreChildResize ignore = def { + _spcIgnoreChildResize = Just ignore +} + +data SplitState = SplitState { + _spsPrevReqs :: (SizeReq, SizeReq), + _spsMaxSize :: Double, + _spsHandlePosUserSet :: Bool, + _spsHandlePos :: Double, + _spsHandleRect :: Rect +} deriving (Eq, Show, Generic) + +-- | Creates a horizontal split between the two provided nodes. +hsplit :: WidgetEvent e => (WidgetNode s e, WidgetNode s e) -> WidgetNode s e +hsplit nodes = hsplit_ def nodes + +-- | Creates a horizontal split between the two provided nodes. Accepts config. +hsplit_ + :: WidgetEvent e + => [SplitCfg s e] -> (WidgetNode s e, WidgetNode s e) -> WidgetNode s e +hsplit_ configs nodes = split_ True nodes configs + +-- | Creates a vertical split between the two provided nodes. +vsplit :: WidgetEvent e => (WidgetNode s e, WidgetNode s e) -> WidgetNode s e +vsplit nodes = vsplit_ def nodes + +-- | Creates a vertical split between the two provided nodes. Accepts config. +vsplit_ + :: WidgetEvent e + => [SplitCfg s e] + -> (WidgetNode s e, WidgetNode s e) + -> WidgetNode s e +vsplit_ configs nodes = split_ False nodes configs + +split_ + :: WidgetEvent e + => Bool + -> (WidgetNode s e, WidgetNode s e) + -> [SplitCfg s e] + -> WidgetNode s e +split_ isHorizontal (node1, node2) configs = newNode where + config = mconcat configs + state = SplitState { + _spsPrevReqs = def, + _spsMaxSize = 0, + _spsHandlePosUserSet = False, + _spsHandlePos = 0.5, + _spsHandleRect = def + } + widget = makeSplit isHorizontal config state + widgetName = if isHorizontal then "hsplit" else "vsplit" + newNode = defaultWidgetNode widgetName widget + & L.children .~ Seq.fromList [node1, node2] + +makeSplit :: WidgetEvent e => Bool -> SplitCfg s e -> SplitState -> Widget s e +makeSplit isHorizontal config state = widget where + widget = createContainer state def { + containerUseCustomCursor = True, + containerLayoutDirection = getLayoutDirection isHorizontal, + containerInit = init, + containerMerge = merge, + containerHandleEvent = handleEvent, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + + handleW = fromMaybe 5 (_spcHandleSize config) + + init wenv node = result where + useModelValue value = resultNode newNode where + newState = state { + _spsHandlePosUserSet = True, + _spsHandlePos = value + } + newNode = node + & L.widget .~ makeSplit isHorizontal config newState + result = case getModelPos wenv config of + Just val + | val >= 0 && val <= 1 -> useModelValue val + _ -> resultNode node + + merge wenv newNode oldNode oldState = result where + oldHandlePos = _spsHandlePos oldState + modelPos = getModelPos wenv config + newState = oldState { + _spsHandlePos = fromMaybe oldHandlePos modelPos + } + result = resultNode $ newNode + & L.widget .~ makeSplit isHorizontal config newState + + handleEvent wenv node target evt = case evt of + Move point + | isTarget && isDragging -> Just resultDrag + | isInHandle point && curIcon /= dragIcon -> Just resultHover + | not (isInHandle point) && curPath == path -> Just resultReset + where + Point px py = getValidHandlePos maxSize vp point children + newHandlePos + | isHorizontal = (px - vp ^. L.x) / maxSize + | otherwise = (py - vp ^. L.y) / maxSize + newState = state { + _spsHandlePosUserSet = True, + _spsHandlePos = newHandlePos + } + + resizeReq = const True + tmpNode = node + & L.widget .~ makeSplit isHorizontal config newState + newNode = widgetResize (tmpNode ^. L.widget) wenv tmpNode vp resizeReq + + resultDrag + | handlePos /= newHandlePos = newNode + & L.requests <>~ Seq.fromList [cursorIconReq, RenderOnce] + | otherwise = resultReqs node [cursorIconReq] + + resultHover = resultReqs node [cursorIconReq] + resultReset = resultReqs node [ResetCursorIcon widgetId] + _ -> Nothing + where + maxSize = _spsMaxSize state + handlePos = _spsHandlePos state + handleRect = _spsHandleRect state + + widgetId = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + vp = node ^. L.info . L.viewport + children = node ^. L.children + + isTarget = target == node ^. L.info . L.path + (curPath, curIcon) = fromMaybe def (wenv ^. L.cursor) + isDragging = isNodePressed wenv node + isInHandle p = pointInRect p handleRect + dragIcon + | isHorizontal = CursorSizeH + | otherwise = CursorSizeV + cursorIconReq = SetCursorIcon widgetId dragIcon + + getSizeReq :: ContainerGetSizeReqHandler s e + getSizeReq wenv node children = (reqW, reqH) where + node1 = Seq.index children 0 + node2 = Seq.index children 1 + + reqW1 = node1 ^. L.info . L.sizeReqW + reqH1 = node1 ^. L.info . L.sizeReqH + reqW2 = node2 ^. L.info . L.sizeReqW + reqH2 = node2 ^. L.info . L.sizeReqH + + reqWS = fixedSize handleW + reqW + | isHorizontal = foldl1 sizeReqMergeSum [reqWS, reqW1, reqW2] + | otherwise = foldl1 sizeReqMergeMax [reqW1, reqW2] + reqH + | isHorizontal = foldl1 sizeReqMergeMax [reqH1, reqH2] + | otherwise = foldl1 sizeReqMergeSum [reqWS, reqH1, reqH2] + + resize wenv node viewport children = resized where + style = currentStyle wenv node + contentArea = fromMaybe def (removeOuterBounds style viewport) + Rect rx ry rw rh = contentArea + (areas, newSize) = assignStackAreas isHorizontal contentArea children + oldHandlePos = _spsHandlePos state + + sizeReq1 = sizeReq $ Seq.index children 0 + sizeReq2 = sizeReq $ Seq.index children 1 + valid1 = sizeReqValid sizeReq1 0 (newSize * oldHandlePos) + valid2 = sizeReqValid sizeReq2 0 (newSize * (1 - oldHandlePos)) + validSize = valid1 && valid2 + + handlePosUserSet = _spsHandlePosUserSet state + ignoreSizeReq = Just True == _spcIgnoreChildResize config + sizeReqEquals = (sizeReq1, sizeReq2) == _spsPrevReqs state + resizeNeeded = not (sizeReqEquals && handlePosUserSet) + + customPos = isJust (_spcHandlePos config) + useOldPos = customPos || ignoreSizeReq || sizeReqEquals + initialPos = initialHandlePos children + + handlePos + | useOldPos && handlePosUserSet && validSize = oldHandlePos + | resizeNeeded = calcHandlePos newSize initialPos viewport children + | otherwise = calcHandlePos newSize oldHandlePos viewport children + (w1, h1) + | isHorizontal = ((newSize - handleW) * handlePos, rh) + | otherwise = (rw, (newSize - handleW) * handlePos) + (w2, h2) + | isHorizontal = (newSize - w1 - handleW, rh) + | otherwise = (rw, newSize - h1 - handleW) + + rect1 = Rect rx ry w1 h1 + rect2 + | isHorizontal = Rect (rx + w1 + handleW) ry w2 h2 + | otherwise = Rect rx (ry + h1 + handleW) w2 h2 + newHandleRect + | isHorizontal = Rect (rx + w1) ry handleW h1 + | otherwise = Rect rx (ry + h1) w1 handleW + + newState = state { + _spsHandlePos = handlePos, + _spsHandleRect = newHandleRect, + _spsMaxSize = newSize, + _spsPrevReqs = (sizeReq1, sizeReq2) + } + + reqOnChange = fmap ($ handlePos) (_spcOnChangeReq config) + requestPos = setModelPos config handlePos + result = resultNode node + & L.node . L.widget .~ makeSplit isHorizontal config newState + & L.requests .~ Seq.fromList (requestPos ++ reqOnChange) + newVps = Seq.fromList [rect1, rect2] + resized = (result, newVps) + + getValidHandlePos maxDim vp handleXY children = addPoint origin newPoint where + Rect rx ry _ _ = vp + Point vx vy = rectBoundedPoint vp handleXY + + origin = Point rx ry + isVertical = not isHorizontal + child1 = Seq.index children 0 + child2 = Seq.index children 1 + + minSize1 = sizeReqMin (sizeReq child1) + maxSize1 = sizeReqMax (sizeReq child1) + minSize2 = sizeReqMin (sizeReq child2) + maxSize2 = sizeReqMax (sizeReq child2) + + (tw, th) + | isHorizontal = (max minSize1 (min maxSize1 $ abs (vx - rx)), 0) + | otherwise = (0, max minSize1 (min maxSize1 $ abs (vy - ry))) + newPoint + | isHorizontal && tw + minSize2 > maxDim = Point (maxDim - minSize2) th + | isHorizontal && maxDim - tw > maxSize2 = Point (maxDim - maxSize2) th + | isVertical && th + minSize2 > maxDim = Point tw (maxDim - minSize2) + | isVertical && maxDim - th > maxSize2 = Point tw (maxDim - maxSize2) + | otherwise = Point tw th + + calcHandlePos maxDim handlePos vp children = newPos where + Rect rx ry _ _ = vp + handleXY + | isHorizontal = Point (rx + maxDim * handlePos) 0 + | otherwise = Point 0 (ry + maxDim * handlePos) + Point px py = getValidHandlePos maxDim vp handleXY children + newPos + | isHorizontal = (px - rx) / maxDim + | otherwise = (py - ry) / maxDim + + initialHandlePos children = handlePos where + child1 = Seq.index children 0 + child2 = Seq.index children 1 + maxSize1 = sizeReqMaxBounded (sizeReq child1) + maxSize2 = sizeReqMaxBounded (sizeReq child2) + handlePos = maxSize1 / (maxSize1 + maxSize2) + + selector + | isHorizontal = _rW + | otherwise = _rH + + sizeReq + | isHorizontal = (^. L.info . L.sizeReqW) + | otherwise = (^. L.info . L.sizeReqH) + +setModelPos :: SplitCfg s e -> Double -> [WidgetRequest s e] +setModelPos cfg + | isJust (_spcHandlePos cfg) = widgetDataSet (fromJust $ _spcHandlePos cfg) + | otherwise = const [] + +getModelPos :: WidgetEnv s e -> SplitCfg s e -> Maybe Double +getModelPos wenv cfg + | isJust handlePosL = Just $ widgetDataGet model (fromJust handlePosL) + | otherwise = Nothing + where + model = wenv ^. L.model + handlePosL = _spcHandlePos cfg diff --git a/src/Monomer/Widgets/Containers/Stack.hs b/src/Monomer/Widgets/Containers/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Stack.hs @@ -0,0 +1,210 @@ +{-| +Module : Monomer.Widgets.Containers.Stack +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +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 the 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. + +Configs: + +- ignoreEmptyArea: when the widgets do not use all the available space, +ignoring the unassigned space allows for mouse events to pass through. This is +useful in zstack layers. +- sizeReqUpdater: allows modifying the 'SizeReq' generated by the stack. +-} +module Monomer.Widgets.Containers.Stack ( + hstack, + hstack_, + vstack, + vstack_, + assignStackAreas +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.Foldable (toList) +import Data.List (foldl') +import Data.Maybe +import Data.Sequence (Seq(..), (<|), (|>)) + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +data StackCfg = StackCfg { + _stcIgnoreEmptyArea :: Maybe Bool, + _stcSizeReqUpdater :: Maybe SizeReqUpdater +} + +instance Default StackCfg where + def = StackCfg { + _stcIgnoreEmptyArea = Nothing, + _stcSizeReqUpdater = Nothing + } + +instance Semigroup StackCfg where + (<>) s1 s2 = StackCfg { + _stcIgnoreEmptyArea = _stcIgnoreEmptyArea s2 <|> _stcIgnoreEmptyArea s1, + _stcSizeReqUpdater = _stcSizeReqUpdater s2 <|> _stcSizeReqUpdater s1 + } + +instance Monoid StackCfg where + mempty = def + +instance CmbIgnoreEmptyArea StackCfg where + ignoreEmptyArea_ ignore = def { + _stcIgnoreEmptyArea = Just ignore + } + +instance CmbSizeReqUpdater StackCfg where + sizeReqUpdater updater = def { + _stcSizeReqUpdater = Just updater + } + +-- | Creates a horizontal stack. +hstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e +hstack children = hstack_ def children + +-- | Creates a horizontal stack. Accepts config. +hstack_ + :: (Traversable t) + => [StackCfg] + -> t (WidgetNode s e) + -> WidgetNode s e +hstack_ configs children = newNode where + config = mconcat configs + newNode = defaultWidgetNode "hstack" (makeStack True config) + & L.children .~ foldl' (|>) Empty children + +-- | Creates a vertical stack. +vstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e +vstack children = vstack_ def children + +-- | Creates a vertical stack. Accepts config. +vstack_ + :: (Traversable t) + => [StackCfg] + -> t (WidgetNode s e) + -> WidgetNode s e +vstack_ configs children = newNode where + config = mconcat configs + newNode = defaultWidgetNode "vstack" (makeStack False config) + & L.children .~ foldl' (|>) Empty children + +makeStack :: Bool -> StackCfg -> Widget s e +makeStack isHorizontal config = widget where + widget = createContainer () def { + containerIgnoreEmptyArea = ignoreEmptyArea, + containerLayoutDirection = getLayoutDirection isHorizontal, + containerUseCustomSize = True, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + + isVertical = not isHorizontal + ignoreEmptyArea = fromMaybe False (_stcIgnoreEmptyArea config) + + getSizeReq wenv node children = newSizeReq where + updateSizeReq = fromMaybe id (_stcSizeReqUpdater config) + vchildren = Seq.filter (_wniVisible . _wnInfo) children + newSizeReqW = getDimSizeReq isHorizontal (_wniSizeReqW . _wnInfo) vchildren + newSizeReqH = getDimSizeReq isVertical (_wniSizeReqH . _wnInfo) vchildren + newSizeReq = updateSizeReq (newSizeReqW, newSizeReqH) + + getDimSizeReq mainAxis accesor vchildren + | Seq.null vreqs = fixedSize 0 + | mainAxis = foldl1 sizeReqMergeSum vreqs + | otherwise = foldl1 sizeReqMergeMax vreqs + where + vreqs = accesor <$> vchildren + + resize wenv node viewport children = resized where + style = currentStyle wenv node + contentArea = fromMaybe def (removeOuterBounds style viewport) + (newVps, newDim) = assignStackAreas isHorizontal contentArea children + newCa + | isHorizontal = contentArea & L.w .~ newDim + | otherwise = contentArea & L.h .~ newDim + newNode = node + & L.info . L.viewport .~ fromMaybe newCa (addOuterBounds style newCa) + resized = (resultNode newNode, newVps) + +{-| +Assigns space from rect to each of the provided widgets based on their size +requirements. +-} +assignStackAreas + :: Bool -- ^ True if horizontal, False for vertical. + -> Rect -- ^ The available space to assign. + -> Seq (WidgetNode s e) -- ^ The widgets that will be assigned space. + -> (Seq Rect, Double) -- ^ The assigned areas and used space in main axis. +assignStackAreas isHorizontal contentArea children = result where + Rect x y w h = contentArea + mainSize = if isHorizontal then w else h + mainStart = if isHorizontal then x else y + rectSelector + | isHorizontal = _rW + | otherwise = _rH + vchildren = Seq.filter (_wniVisible . _wnInfo) children + reqs = fmap (mainReqSelector isHorizontal) vchildren + + sumSizes accum req = newStep where + (cFixed, cFlex, cFlexFac, cExtraFac) = accum + newFixed = cFixed + sizeReqFixed req + newFlex = cFlex + sizeReqFlex req + newFlexFac = cFlexFac + sizeReqFlex req * sizeReqFactor req + newExtraFac = cExtraFac + sizeReqExtra req * sizeReqFactor req + newStep = (newFixed, newFlex, newFlexFac, newExtraFac) + + (fixed, flex, flexFac, extraFac) = foldl' sumSizes def reqs + flexAvail = min flex (mainSize - fixed) + extraAvail = max 0 (mainSize - fixed - flexAvail) + + -- flexCoeff can only be negative + flexCoeff + | flexAvail < flex && flexFac > 0 = (flexAvail - flex) / flexFac + | otherwise = 0 + extraCoeff + | extraAvail > 0 && extraFac > 0 = extraAvail / extraFac + | otherwise = 0 + + foldHelper (accum, offset) child = (newAccum, newOffset) where + newRect = resizeChild isHorizontal contentArea flexCoeff extraCoeff offset child + newAccum = accum |> newRect + newOffset = offset + rectSelector newRect + + (areas, usedDim) = foldl' foldHelper (Seq.empty, mainStart) children + result = (areas, usedDim - mainStart) + +resizeChild :: Bool -> Rect -> Factor -> Factor -> Double -> WidgetNode s e -> Rect +resizeChild horizontal contentArea flexCoeff extraCoeff offset child = result where + Rect l t w h = contentArea + emptyRect = Rect l t 0 0 + -- Either flex or extra is active (flex is negative or extra is >= 0) + SizeReq fixed flex extra factor = mainReqSelector horizontal child + + tempMainSize = fixed + + (1 + flexCoeff * factor) * flex + + extraCoeff * factor * extra + mainSize = max 0 tempMainSize + + hRect = Rect offset t mainSize h + vRect = Rect l offset w mainSize + result + | not $ (_wniVisible . _wnInfo) child = emptyRect + | horizontal = hRect + | otherwise = vRect + +mainReqSelector :: Bool -> WidgetNode s e -> SizeReq +mainReqSelector isHorizontal + | isHorizontal = _wniSizeReqW . _wnInfo + | otherwise = _wniSizeReqH . _wnInfo diff --git a/src/Monomer/Widgets/Containers/ThemeSwitch.hs b/src/Monomer/Widgets/Containers/ThemeSwitch.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/ThemeSwitch.hs @@ -0,0 +1,124 @@ +{-| +Module : Monomer.Widgets.Containers.ThemeSwitch +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +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 config, set it on the child node or wrap the themeSwitch +widget in a `Monomer.Widgets.Containers.Box`. + +Configs: + +- themeClearBg: indicates the clear color of the theme should be applied before +rendering children. Defaults to False. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Containers.ThemeSwitch ( + themeClearBg, + themeClearBg_, + themeSwitch, + themeSwitch_ +) where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Lens ((&), (^.), (.~), (%~), at) +import Data.Default +import Data.Maybe + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +newtype ThemeSwitchCfg = ThemeSwitchCfg { + _tmcClearBg :: Maybe Bool +} deriving (Eq, Show) + + +instance Default ThemeSwitchCfg where + def = ThemeSwitchCfg { + _tmcClearBg = Nothing + } + +instance Semigroup ThemeSwitchCfg where + (<>) s1 s2 = ThemeSwitchCfg { + _tmcClearBg = _tmcClearBg s2 <|> _tmcClearBg s1 + } + +instance Monoid ThemeSwitchCfg where + mempty = def + +-- | Indicates the clear color should be applied before rendering children. +themeClearBg :: ThemeSwitchCfg +themeClearBg = themeClearBg_ True + +-- | Sets whether the clear color should be applied before rendering children. +themeClearBg_ :: Bool -> ThemeSwitchCfg +themeClearBg_ clear = def { + _tmcClearBg = Just clear +} + +data ThemeSwitchState = ThemeSwitchState { + _tssPrevTheme :: Maybe Theme, + _tssChanged :: Bool +} + +-- | Switches to a new theme starting from its child node. +themeSwitch :: Theme -> WidgetNode s e -> WidgetNode s e +themeSwitch theme managed = themeSwitch_ theme def managed + +-- | Switches to a new theme starting from its child node. Accepts config. +themeSwitch_ :: Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e +themeSwitch_ theme configs managed = makeNode widget managed where + config = mconcat configs + state = ThemeSwitchState Nothing False + widget = makeThemeSwitch theme config state + +makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode widget managedWidget = defaultWidgetNode "themeSwitch" widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeThemeSwitch :: Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e +makeThemeSwitch theme config state = widget where + widget = createContainer state def { + containerUpdateCWenv = updateCWenv, + containerGetCurrentStyle = getCurrentStyle, + containerInit = init, + containerMerge = merge + } + + updateCWenv wenv cidx cnode node = newWenv where + oldTheme = _tssPrevTheme state + -- When called during merge, the state has not yet been updated + themeChanged = _tssChanged state || Just theme /= oldTheme + parentChanged = wenv ^. L.themeChanged + newWenv = wenv + & L.theme .~ theme + & L.themeChanged .~ (themeChanged || parentChanged) + + getCurrentStyle wenv node = style where + clearBg = _tmcClearBg config == Just True + clearColor = theme ^. L.clearColor + style + | clearBg = bgColor clearColor + | otherwise = def + + init wenv node = resultNode newNode where + newState = ThemeSwitchState (Just theme) False + newNode = node + & L.widget .~ makeThemeSwitch theme config newState + + merge wenv node oldNode oldState = resultNode newNode where + oldTheme = _tssPrevTheme oldState + newState = ThemeSwitchState (Just theme) (Just theme /= oldTheme) + newNode = node + & L.widget .~ makeThemeSwitch theme config newState diff --git a/src/Monomer/Widgets/Containers/Tooltip.hs b/src/Monomer/Widgets/Containers/Tooltip.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/Tooltip.hs @@ -0,0 +1,220 @@ +{-| +Module : Monomer.Widgets.Containers.Tooltip +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +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. + +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 +on the message when the tooltip is active. If you need padding around the child +element, you may want to use a box. + +Config: + +- width: the maximum width of the tooltip. Used for multiline. +- height: the maximum height of the tooltip. Used for multiline. +- tooltipDelay: the delay in ms before the tooltip is displayed. +- tooltipFollow: if, after tooltip is displayed, it should follow the mouse. +-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Containers.Tooltip ( + tooltip, + tooltip_, + tooltipDelay, + tooltipFollow +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), (%~), at) +import Control.Monad (forM_, when) +import Data.Default +import Data.Maybe +import Data.Text (Text) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +data TooltipCfg = TooltipCfg { + _ttcDelay :: Maybe Int, + _ttcFollowCursor :: Maybe Bool, + _ttcMaxWidth :: Maybe Double, + _ttcMaxHeight :: Maybe Double +} + +instance Default TooltipCfg where + def = TooltipCfg { + _ttcDelay = Nothing, + _ttcFollowCursor = Nothing, + _ttcMaxWidth = Nothing, + _ttcMaxHeight = Nothing + } + +instance Semigroup TooltipCfg where + (<>) s1 s2 = TooltipCfg { + _ttcDelay = _ttcDelay s2 <|> _ttcDelay s1, + _ttcFollowCursor = _ttcFollowCursor s2 <|> _ttcFollowCursor s1, + _ttcMaxWidth = _ttcMaxWidth s2 <|> _ttcMaxWidth s1, + _ttcMaxHeight = _ttcMaxHeight s2 <|> _ttcMaxHeight s1 + } + +instance Monoid TooltipCfg where + mempty = def + +instance CmbMaxWidth TooltipCfg where + maxWidth w = def { + _ttcMaxWidth = Just w + } + +instance CmbMaxHeight TooltipCfg where + maxHeight h = def { + _ttcMaxHeight = Just h + } + +-- | Delay before the tooltip is displayed when child widget is hovered. +tooltipDelay :: Int -> TooltipCfg +tooltipDelay ms = def { + _ttcDelay = Just ms +} + +-- | Whether the tooltip should move with the mouse after being displayed. +tooltipFollow :: TooltipCfg +tooltipFollow = def { + _ttcFollowCursor = Just True +} + +data TooltipState = TooltipState { + _ttsLastPos :: Point, + _ttsLastPosTs :: Int +} deriving (Eq, Show, Generic) + +-- | Creates a tooltip for the child widget. +tooltip :: Text -> WidgetNode s e -> WidgetNode s e +tooltip caption managed = tooltip_ caption def managed + +-- | Creates a tooltip for the child widget. Accepts config. +tooltip_ :: Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e +tooltip_ caption configs managed = makeNode widget managed where + config = mconcat configs + state = TooltipState def maxBound + widget = makeTooltip caption config state + +makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e +makeNode widget managedWidget = defaultWidgetNode "tooltip" widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managedWidget + +makeTooltip :: Text -> TooltipCfg -> TooltipState -> Widget s e +makeTooltip caption config state = widget where + baseWidget = createContainer state def { + containerAddStyleReq = False, + containerGetBaseStyle = getBaseStyle, + containerMerge = merge, + containerHandleEvent = handleEvent, + containerResize = resize + } + widget = baseWidget { + widgetRender = render + } + + delay = fromMaybe 1000 (_ttcDelay config) + followCursor = fromMaybe False (_ttcFollowCursor config) + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.tooltipStyle + + merge wenv node oldNode oldState = result where + newNode = node + & L.widget .~ makeTooltip caption config oldState + result = resultNode newNode + + handleEvent wenv node target evt = case evt of + Leave point -> Just $ resultReqs newNode [RenderOnce] where + newState = state { + _ttsLastPos = Point (-1) (-1), + _ttsLastPosTs = maxBound + } + newNode = node + & L.widget .~ makeTooltip caption config newState + + Move point + | isPointInNodeVp node point -> Just result where + widgetId = node ^. L.info . L.widgetId + prevDisplayed = tooltipDisplayed wenv node + newState = state { + _ttsLastPos = point, + _ttsLastPosTs = wenv ^. L.timestamp + } + newNode = node + & L.widget .~ makeTooltip caption config newState + delayedRender = RenderEvery widgetId delay (Just 1) + result + | not prevDisplayed = resultReqs newNode [delayedRender] + | prevDisplayed && followCursor = resultReqs node [RenderOnce] + | otherwise = resultNode node + + _ -> Nothing + + -- Padding/border is not removed. Styles are only considerer for the overlay + resize wenv node viewport children = resized where + resized = (resultNode node, Seq.singleton viewport) + + render wenv node renderer = do + forM_ children $ \child -> + widgetRender (child ^. L.widget) wenv child renderer + + when tooltipVisible $ + createOverlay renderer $ do + drawStyledAction renderer rect style $ \textRect -> do + let textLines = alignTextLines style textRect fittedLines + forM_ textLines (drawTextLine renderer style) + where + fontMgr = wenv ^. L.fontManager + style = currentStyle wenv node + children = node ^. L.children + mousePos = wenv ^. L.inputStatus . L.mousePos + + scOffset = wenv ^. L.offset + isDragging = isJust (wenv ^. L.dragStatus) + maxW = wenv ^. L.windowSize . L.w + maxH = wenv ^. L.windowSize . L.h + + targetW = fromMaybe maxW (_ttcMaxWidth config) + targetH = fromMaybe maxH (_ttcMaxHeight config) + targetSize = Size targetW targetH + fittedLines = fitTextToSize fontMgr style Ellipsis MultiLine TrimSpaces + Nothing targetSize caption + textSize = getTextLinesSize fittedLines + + Size tw th = fromMaybe def (addOuterSize style textSize) + TooltipState lastPos _ = state + Point mx my + | followCursor = addPoint scOffset mousePos + | otherwise = addPoint scOffset lastPos + rx + | wenv ^. L.windowSize . L.w - mx > tw = mx + | otherwise = wenv ^. L.windowSize . L.w - tw + -- Add offset to have space between the tooltip and the cursor + ry + | wenv ^. L.windowSize . L.h - (my + 50) > th = my + 20 + | otherwise = my - th - 5 + rect = Rect rx ry tw th + tooltipVisible = tooltipDisplayed wenv node && not isDragging + + tooltipDisplayed wenv node = displayed where + TooltipState lastPos lastPosTs = state + ts = wenv ^. L.timestamp + viewport = node ^. L.info . L.viewport + inViewport = pointInRect lastPos viewport + delayEllapsed = ts - lastPosTs >= delay + displayed = inViewport && delayEllapsed diff --git a/src/Monomer/Widgets/Containers/ZStack.hs b/src/Monomer/Widgets/Containers/ZStack.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Containers/ZStack.hs @@ -0,0 +1,230 @@ +{-| +Module : Monomer.Widgets.Containers.ZStack +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +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). + +The order of the widgets is from bottom to top. + +The container will request the largest horizontal and vertical size from its +child nodes. + +Config: + +- onlyTopActive: whether the top visible node is the only node that may receive +events. +-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Containers.ZStack ( + zstack, + zstack_, + onlyTopActive +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (^?), (.~), (%~), (?~), at, ix) +import Control.Monad (forM_, void, when) +import Data.Default +import Data.Maybe +import Data.List (foldl', any) +import Data.Sequence (Seq(..), (<|), (|>)) +import GHC.Generics + +import qualified Data.Map.Strict as M +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container + +import qualified Monomer.Lens as L + +newtype ZStackCfg = ZStackCfg { + _zscOnlyTopActive :: Maybe Bool +} + +instance Default ZStackCfg where + def = ZStackCfg Nothing + +instance Semigroup ZStackCfg where + (<>) z1 z2 = ZStackCfg { + _zscOnlyTopActive = _zscOnlyTopActive z2 <|> _zscOnlyTopActive z1 + } + +instance Monoid ZStackCfg where + mempty = def + +-- | Whether the top visible node is the only node that may receive events. +-- | Defaults to True. +onlyTopActive :: Bool -> ZStackCfg +onlyTopActive active = def { + _zscOnlyTopActive = Just active +} + +data ZStackState = ZStackState { + _zssFocusMap :: M.Map PathStep WidgetId, + _zssTopIdx :: Int +} deriving (Eq, Show, Generic) + +-- | Creates a zstack container with the provided nodes. +zstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e +zstack children = zstack_ def children + +-- | Creates a zstack container with the provided nodes. Accepts config. +zstack_ + :: (Traversable t) + => [ZStackCfg] + -> t (WidgetNode s e) + -> WidgetNode s e +zstack_ configs children = newNode where + config = mconcat configs + state = ZStackState M.empty 0 + newNode = defaultWidgetNode "zstack" (makeZStack config state) + & L.children .~ Seq.reverse (foldl' (|>) Empty children) + +makeZStack :: ZStackCfg -> ZStackState -> Widget s e +makeZStack config state = widget where + baseWidget = createContainer state def { + containerUseChildrenSizes = True, + containerInit = init, + containerMergePost = mergePost, + containerFindNextFocus = findNextFocus, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + widget = baseWidget { + widgetFindByPoint = findByPoint, + widgetRender = render + } + + onlyTopActive = fromMaybe True (_zscOnlyTopActive config) + + init wenv node = resultNode newNode where + children = node ^. L.children + focusedPath = wenv ^. L.focusedPath + newState = state { + _zssTopIdx = fromMaybe 0 (Seq.findIndexL (^.L.info . L.visible) children) + } + newNode = node + & L.widget .~ makeZStack config newState + + mergePost wenv node oldNode oldState newState result = newResult where + ZStackState oldFocusMap oldTopIdx = oldState + children = node ^. L.children + focusedPath = wenv ^. L.focusedPath + focusedWid = findWidgetIdFromPath wenv focusedPath + isFocusParent = isNodeParentOfPath node focusedPath + + topLevel = isNodeTopLevel wenv node + flagsChanged = childrenFlagsChanged oldNode node + newTopIdx = fromMaybe 0 (Seq.findIndexL (^.L.info . L.visible) children) + focusReq = isJust $ Seq.findIndexL isFocusRequest (result ^. L.requests) + needsFocus = isFocusParent && topLevel && flagsChanged && not focusReq + + oldTopWid = M.lookup newTopIdx oldFocusMap + fstTopWid = node ^? L.children . ix newTopIdx . L.info . L.widgetId + newState = oldState { + _zssFocusMap = oldFocusMap & at oldTopIdx .~ focusedWid, + _zssTopIdx = newTopIdx + } + + tmpResult = result + & L.node . L.widget .~ makeZStack config newState + newResult + | needsFocus && isJust oldTopWid = tmpResult + & L.requests %~ (|> SetFocus (fromJust oldTopWid)) + | needsFocus = tmpResult + & L.requests %~ (|> MoveFocus fstTopWid FocusFwd) + | isFocusParent = tmpResult + | otherwise = result + + -- | Find instance matching point + findByPoint wenv node start point = result where + children = node ^. L.children + vchildren + | onlyTopActive = Seq.take 1 $ Seq.filter (_wniVisible . _wnInfo) children + | otherwise = Seq.filter (_wniVisible . _wnInfo) children + + nextStep = nextTargetStep node start + ch = Seq.index children (fromJust nextStep) + visible = node ^. L.info . L.visible + childVisible = ch ^. L.info . L.visible + isNextValid = isJust nextStep && visible && childVisible + result + | isNextValid = widgetFindByPoint (ch ^. L.widget) wenv ch start point + | visible = findFirstByPoint vchildren wenv start point + | otherwise = Nothing + + findNextFocus wenv node direction start = result where + children = node ^. L.children + vchildren = Seq.filter (_wniVisible . _wnInfo) children + result + | onlyTopActive = Seq.take 1 vchildren + | otherwise = vchildren + + getSizeReq wenv node children = (newSizeReqW, newSizeReqH) where + vchildren = Seq.filter (_wniVisible . _wnInfo) children + newSizeReqW = getDimSizeReq (_wniSizeReqW . _wnInfo) vchildren + newSizeReqH = getDimSizeReq (_wniSizeReqH . _wnInfo) vchildren + + getDimSizeReq accesor vchildren + | Seq.null vreqs = fixedSize 0 + | otherwise = foldl1 sizeReqMergeMax vreqs + where + vreqs = accesor <$> vchildren + + resize wenv node viewport children = resized where + style = currentStyle wenv node + vpChild = fromMaybe def (removeOuterBounds style viewport) + assignedAreas = fmap (const vpChild) children + resized = (resultNode node, assignedAreas) + + render wenv node renderer = + drawInScissor renderer True viewport $ + drawStyledAction renderer viewport style $ \_ -> + void $ Seq.traverseWithIndex renderChild children + where + style = currentStyle wenv node + children = Seq.reverse $ node ^. L.children + viewport = node ^. L.info . L.viewport + isVisible c = c ^. L.info . L.visible + topVisibleIdx = fromMaybe 0 (Seq.findIndexR (_wniVisible . _wnInfo) children) + + isPointEmpty point idx = not covered where + prevs = Seq.drop (idx + 1) children + target c = widgetFindByPoint (c ^. L.widget) wenv c emptyPath point + isCovered c = isVisible c && isJust (target c) + covered = any isCovered prevs + + isTopLayer idx child point = prevTopLayer && isValid where + prevTopLayer = _weInTopLayer wenv point + isValid + | onlyTopActive = idx == topVisibleIdx + | otherwise = isPointEmpty point idx + + cWenv idx child = wenv { + _weInTopLayer = isTopLayer idx child + } + renderChild idx child = when (isVisible child) $ + widgetRender (child ^. L.widget) (cWenv idx child) child renderer + +findFirstByPoint + :: Seq (WidgetNode s e) + -> WidgetEnv s e + -> Seq PathStep + -> Point + -> Maybe WidgetNodeInfo +findFirstByPoint Empty _ _ _ = Nothing +findFirstByPoint (ch :<| chs) wenv start point = result where + isVisible = ch ^. L.info . L.visible + newPath = widgetFindByPoint (ch ^. L.widget) wenv ch start point + result + | isVisible && isJust newPath = newPath + | otherwise = findFirstByPoint chs wenv start point diff --git a/src/Monomer/Widgets/Single.hs b/src/Monomer/Widgets/Single.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Single.hs @@ -0,0 +1,602 @@ +{-| +Module : Monomer.Widgets.Single +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper for creating widgets without children elements +-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} + +module Monomer.Widgets.Single ( + module Monomer.Core, + module Monomer.Core.Combinators, + module Monomer.Event, + module Monomer.Graphics, + module Monomer.Widgets.Util, + + SingleGetBaseStyle, + SingleGetCurrentStyle, + SingleInitHandler, + SingleMergeHandler, + SingleDisposeHandler, + SingleFindNextFocusHandler, + SingleFindByPointHandler, + SingleEventHandler, + SingleMessageHandler, + SingleGetSizeReqHandler, + SingleResizeHandler, + SingleRenderHandler, + + Single(..), + createSingle +) where + +import Control.Exception (AssertionFailed(..), throw) +import Control.Lens ((&), (^.), (^?), (.~), (%~), _Just) +import Data.Default +import Data.Maybe +import Data.Sequence (Seq(..), (|>)) +import Data.Typeable (Typeable, cast) + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics +import Monomer.Helper +import Monomer.Widgets.Util + +import qualified Monomer.Core.Lens as L + +{-| +Returns the base style for this type of widget. + +Usually this style comes from the active theme. +-} +type SingleGetBaseStyle s e + = GetBaseStyle s e -- ^ The base style for a new node. + +{-| +Returns the current style for this type of widget. It depends on the state of +the widget, which can be: + +- Basic +- Hovered +- Focused +- Hovered and Focused +- Active +- Disabled + +In general there's no needed to override it, except when the widget does not use +the full content rect. An example can be found in "Monomer.Widgets.Singles.Radio". +-} +type SingleGetCurrentStyle s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> StyleState -- ^ The active style for the node. + +{-| +Initializes the given node. This could include rebuilding the widget in case +internal state needs to use model/environment information, generate user +events or make requests to the runtime. + +An examples can be found in "Monomer.Widgets.Singles.Label" and +"Monomer.Widgets.Singles.Image". On the other hand, "Monomer.Widgets.Radio" does +not need to override /init/. +-} +type SingleInitHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetResult s e -- ^ The result of the init operation. + +{-| +Merges the current node with the node it matched with during the merge process. +Receives the newly created node (whose *init* function is not called), the +previous node and the state extracted from that node. This process is widget +dependent, and may use or ignore the previous state depending on newly available +information. + +In general, you want to at least keep the previous state unless the widget is +stateless or only consumes model/environment information. + +Examples can be found in "Monomer.Widgets.Singles.Label" and +"Monomer.Widgets.Singles.Image". On the other hand, +"Monomer.Widgets.Singles.Radio" does not need to override merge since it's +stateless. +-} +type SingleMergeHandler s e a + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetNode s e -- ^ The previous widget node. + -> a -- ^ The state of the previous widget node. + -> WidgetResult s e -- ^ The result of the merge operation. + +{-| +Disposes the current node. Only used by widgets which allocate resources during +/init/ or /merge/, and will usually involve requests to the runtime. + +An example can be found "Monomer.Widgets.Singles.Image". +-} +type SingleDisposeHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetResult s e -- ^ The result of the dispose operation. + +{-| +Returns the next focusable node. Since this type of widget does not have +children, there is not need to override this function, as there are only +two options: + +- The node is focusable and target is valid: the node is returned +- The node is not focusable: Nothing is returned +-} +type SingleFindNextFocusHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> FocusDirection -- ^ The direction in which focus is moving. + -> Path -- ^ The start path from which to search. + -> Maybe WidgetNodeInfo -- ^ The next focusable node info. + +{-| +Returns the currently hovered widget, if any. If the widget is rectangular and +uses the full content area, there is not need to override this function. + +An example can be found "Monomer.Widgets.Singles.Radio". +-} +type SingleFindByPointHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Path -- ^ The start path from which to search. + -> Point -- ^ The point to test for. + -> Maybe WidgetNodeInfo -- ^ The hovered node info, if any. + +{-| +Receives a System event and, optionally, returns a result. This can include an +updated version of the widget (in case it has internal state), user events or +requests to the runtime. + +Examples can be found in "Monomer.Widgets.Singles.Button" and +"Monomer.Widgets.Singles.Slider". +-} +type SingleEventHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Path -- ^ The target path of the event. + -> SystemEvent -- ^ The SystemEvent to handle. + -> Maybe (WidgetResult s e) -- ^ The result of handling the event, if any. + +{-| +Receives a message and, optionally, returns a result. This can include an +updated version of the widget (in case it has internal state), user events or +requests to the runtime. There is no validation regarding the message type, and +the widget should take care of _casting_ to the correct type using +"Data.Typeable.cast" + +Examples can be found in "Monomer.Widgets.Singles.Button" and +"Monomer.Widgets.Singles.Slider". +-} +type SingleMessageHandler s e + = forall i . Typeable i + => WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Path -- ^ The target path of the message. + -> i -- ^ The message to handle. + -> Maybe (WidgetResult s e) -- ^ The result of handling the message, if any. + +{-| +Returns the preferred size for the widget. This size should not include border +and padding; those are added automatically by Single. + +This is called to update WidgetNodeInfo only at specific times. + +Examples can be found in "Monomer.Widgets.Singles.Checkbox" and +"Monomer.Widgets.Singles.Label". +-} +type SingleGetSizeReqHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> (SizeReq, SizeReq) -- ^ The horizontal and vertical requirements. + +{-| +Resizes the widget to the provided size. If the widget state does not depend +on the viewport size, this function does not need to be overriden. + +Examples can be found in "Monomer.Widgets.Singles.Label". +-} +type SingleResizeHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Rect -- ^ The new viewport. + -> WidgetResult s e -- ^ The result of resizing the widget. + +{-| +Renders the widget's content using the given Renderer. In general, this method +needs to be overriden. + +Examples can be found in "Monomer.Widgets.Singles.Checkbox" and +"Monomer.Widgets.Singles.Slider". +-} +type SingleRenderHandler s e + = WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> Renderer -- ^ The renderer, providing low level drawing functions. + -> IO () -- ^ The IO action with rendering instructions. + +-- | Interface for Single widgets. +data Single s e a = Single { + -- | True if border and padding should be added to size requirement. Defaults + -- | to True. + singleAddStyleReq :: Bool, + -- | True if focus should be requested when mouse button is pressed (before + -- | click). Defaults to True. + singleFocusOnBtnPressed :: Bool, + -- | True if style cursor should be ignored. If it's False, cursor changes need + -- | to be handled in custom code. Defaults to False. + singleUseCustomCursor :: Bool, + -- | If true, it will ignore extra space assigned by the parent container, but + -- | it will not use more space than assigned. Defaults to False. + singleUseCustomSize :: Bool, + -- | True if automatic scissoring needs to be applied. Defaults to False. + singleUseScissor :: Bool, + -- | Returns the base style for this type of widget. + singleGetBaseStyle :: SingleGetBaseStyle s e, + -- | Returns the active style, depending on the status of the widget. + singleGetCurrentStyle :: SingleGetCurrentStyle s e, + -- | Initializes the given node. + singleInit :: SingleInitHandler s e, + -- | Merges the node with the node it matched with during the merge process. + singleMerge :: SingleMergeHandler s e a, + -- | Disposes the current node. + singleDispose :: SingleDisposeHandler s e, + -- | Returns the next focusable node. + singleFindNextFocus :: SingleFindNextFocusHandler s e, + -- | Returns the currently hovered widget, if any. + singleFindByPoint :: SingleFindByPointHandler s e, + -- | Receives a System event and, optionally, returns a result. + singleHandleEvent :: SingleEventHandler s e, + -- | Receives a message and, optionally, returns a result. + singleHandleMessage :: SingleMessageHandler s e, + -- | Returns the preferred size for the widget. + singleGetSizeReq :: SingleGetSizeReqHandler s e, + -- | Resizes the widget to the provided size. + singleResize :: SingleResizeHandler s e, + -- | Renders the widget's content. + singleRender :: SingleRenderHandler s e +} + +instance Default (Single s e a) where + def = Single { + singleAddStyleReq = True, + singleFocusOnBtnPressed = True, + singleUseCustomCursor = False, + singleUseCustomSize = False, + singleUseScissor = False, + singleGetBaseStyle = defaultGetBaseStyle, + singleGetCurrentStyle = defaultGetCurrentStyle, + singleInit = defaultInit, + singleMerge = defaultMerge, + singleDispose = defaultDispose, + singleFindNextFocus = defaultFindNextFocus, + singleFindByPoint = defaultFindByPoint, + singleHandleEvent = defaultHandleEvent, + singleHandleMessage = defaultHandleMessage, + singleGetSizeReq = defaultGetSizeReq, + singleResize = defaultResize, + singleRender = defaultRender + } + +{-| +Creates a widget based on the Single infrastructure. An initial state and the +Single definition need to be provided. In case internal state is not needed, +__()__ can be provided. Using the __def__ instance as a starting point is +recommended to focus on overriding only what is needed: + +@ +widget = createSingle () def { + singleRender = ... +} +@ +-} +createSingle :: WidgetModel a => a -> Single s e a -> Widget s e +createSingle state single = Widget { + widgetInit = initWrapper single, + widgetMerge = mergeWrapper single, + widgetDispose = disposeWrapper single, + widgetGetState = makeState state, + widgetGetInstanceTree = getInstanceTreeWrapper single, + widgetFindNextFocus = singleFindNextFocus single, + widgetFindByPoint = singleFindByPoint single, + widgetFindBranchByPath = singleFindBranchByPath, + widgetHandleEvent = handleEventWrapper single, + widgetHandleMessage = handleMessageWrapper single, + widgetGetSizeReq = getSizeReqWrapper single, + widgetResize = resizeHandlerWrapper single, + widgetRender = renderWrapper single +} + +defaultGetBaseStyle :: SingleGetBaseStyle s e +defaultGetBaseStyle wenv node = Nothing + +defaultGetCurrentStyle :: SingleGetCurrentStyle s e +defaultGetCurrentStyle wenv node = currentStyle wenv node + +defaultInit :: SingleInitHandler s e +defaultInit wenv node = resultNode node + +initWrapper + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetResult s e +initWrapper single wenv node = newResult where + initHandler = singleInit single + getBaseStyle = singleGetBaseStyle single + styledNode = initNodeStyle getBaseStyle wenv node + tmpResult = initHandler wenv styledNode + newResult = tmpResult + & L.node .~ updateSizeReq wenv (tmpResult ^. L.node) + +defaultMerge :: SingleMergeHandler s e a +defaultMerge wenv newNode oldState oldNode = resultNode newNode + +mergeWrapper + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e + -> WidgetResult s e +mergeWrapper single wenv newNode oldNode = newResult where + mergeHandler = singleMerge single + oldState = widgetGetState (oldNode ^. L.widget) wenv oldNode + oldInfo = oldNode ^. L.info + + nodeHandler wenv styledNode = case useState oldState of + Just state -> mergeHandler wenv styledNode oldNode state + _ -> resultNode styledNode + tmpResult = runNodeHandler single wenv newNode oldInfo nodeHandler + newResult = handleWidgetIdChange oldNode tmpResult + +runNodeHandler + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetNodeInfo + -> (WidgetEnv s e -> WidgetNode s e -> WidgetResult s e) + -> WidgetResult s e +runNodeHandler single wenv newNode oldInfo nodeHandler = newResult where + getBaseStyle = singleGetBaseStyle single + tempNode = newNode + & L.info . L.widgetId .~ oldInfo ^. L.widgetId + & L.info . L.viewport .~ oldInfo ^. L.viewport + & L.info . L.sizeReqW .~ oldInfo ^. L.sizeReqW + & L.info . L.sizeReqH .~ oldInfo ^. L.sizeReqH + styledNode = initNodeStyle getBaseStyle wenv tempNode + + tmpResult = nodeHandler wenv styledNode + newResult + | isResizeAnyResult (Just tmpResult) = tmpResult + & L.node .~ updateSizeReq wenv (tmpResult ^. L.node) + | otherwise = tmpResult + +getInstanceTreeWrapper + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetInstanceNode +getInstanceTreeWrapper container wenv node = instNode where + instNode = WidgetInstanceNode { + _winInfo = node ^. L.info, + _winState = widgetGetState (node ^. L.widget) wenv node, + _winChildren = fmap (getChildTree wenv) (node ^. L.children) + } + getChildTree wenv child = widgetGetInstanceTree (child ^. L.widget) wenv child + +defaultDispose :: SingleDisposeHandler s e +defaultDispose wenv node = resultNode node + +disposeWrapper + :: Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> WidgetResult s e +disposeWrapper single wenv node = result where + disposeHandler = singleDispose single + WidgetResult newNode reqs = disposeHandler wenv node + widgetId = node ^. L.info . L.widgetId + newReqs = reqs |> ResetWidgetPath widgetId + result = WidgetResult newNode newReqs + +defaultFindNextFocus :: SingleFindNextFocusHandler s e +defaultFindNextFocus wenv node direction startFrom + | isFocusCandidate node startFrom direction = Just (node ^. L.info) + | otherwise = Nothing + +defaultFindByPoint :: SingleFindByPointHandler s e +defaultFindByPoint wenv node start point + | visible && validPath && isPointInNodeVp node point = Just info + | otherwise = Nothing + where + info = node ^. L.info + visible = info ^. L.visible + path = node ^. L.info . L.path + validPath = seqStartsWith start path + +singleFindBranchByPath + :: WidgetEnv s e + -> WidgetNode s e + -> Path + -> Seq WidgetNodeInfo +singleFindBranchByPath wenv node path + | info ^. L.path == path = Seq.singleton info + | otherwise = Seq.empty + where + info = node ^. L.info + +defaultHandleEvent :: SingleEventHandler s e +defaultHandleEvent wenv node target evt = Nothing + +handleEventWrapper + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Path + -> SystemEvent + -> Maybe (WidgetResult s e) +handleEventWrapper single wenv node target evt + | not (node ^. L.info . L.visible) = Nothing + | otherwise = handleStyleChange wenv target style handleCursor node evt result + where + style = singleGetCurrentStyle single wenv node + handleCursor = not (singleUseCustomCursor single) + focusOnPressed = singleFocusOnBtnPressed single + handler = singleHandleEvent single + handlerRes = handler wenv node target evt + sizeResult = handleSizeReqChange single wenv node (Just evt) handlerRes + result + | focusOnPressed = handleFocusRequest wenv node evt sizeResult + | otherwise = sizeResult + +handleFocusRequest + :: WidgetEnv s e + -> WidgetNode s e + -> SystemEvent + -> Maybe (WidgetResult s e) + -> Maybe (WidgetResult s e) +handleFocusRequest wenv oldNode evt mResult = newResult where + node = maybe oldNode (^. L.node) mResult + prevReqs = maybe Empty (^. L.requests) mResult + isFocusable = node ^. L.info . L.focusable + btnPressed = case evt of + ButtonAction _ btn BtnPressed _ -> Just btn + _ -> Nothing + isFocusReq = btnPressed == Just (wenv ^. L.mainButton) + && isFocusable + && not (isNodeFocused wenv node) + && isNodeTopLevel wenv node + && isNothing (Seq.findIndexL isFocusRequest prevReqs) + + newReq = SetFocus (node ^. L.info . L.widgetId) + newResult + | isFocusReq && isJust mResult = (& L.requests %~ (|> newReq)) <$> mResult + | isFocusReq = Just $ resultReqs node [newReq] + | otherwise = mResult + +defaultHandleMessage :: SingleMessageHandler s e +defaultHandleMessage wenv node target message = Nothing + +handleMessageWrapper :: forall s e a i . (WidgetModel a, Typeable i) + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Path + -> i + -> Maybe (WidgetResult s e) +handleMessageWrapper single wenv node target msg = result where + handler = singleHandleMessage single + result = handleSizeReqChange single wenv node Nothing + $ handler wenv node target msg + +defaultGetSizeReq :: SingleGetSizeReqHandler s e +defaultGetSizeReq wenv node = def + +getSizeReqWrapper + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> (SizeReq, SizeReq) +getSizeReqWrapper single wenv node = (newReqW, newReqH) where + addStyleReq = singleAddStyleReq single + handler = singleGetSizeReq single + style = singleGetCurrentStyle single wenv node + + reqs = handler wenv node + (tmpReqW, tmpReqH) + | addStyleReq = sizeReqAddStyle style reqs + | otherwise = reqs + -- User settings take precedence + newReqW = fromMaybe tmpReqW (style ^. L.sizeReqW) + newReqH = fromMaybe tmpReqH (style ^. L.sizeReqH) + +updateSizeReq + :: WidgetEnv s e + -> WidgetNode s e + -> WidgetNode s e +updateSizeReq wenv node = newNode where + (newReqW, newReqH) = widgetGetSizeReq (node ^. L.widget) wenv node + newNode = node + & L.info . L.sizeReqW .~ newReqW + & L.info . L.sizeReqH .~ newReqH + +handleSizeReqChange + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Maybe SystemEvent + -> Maybe (WidgetResult s e) + -> Maybe (WidgetResult s e) +handleSizeReqChange single wenv node evt mResult = result where + baseResult = fromMaybe (resultNode node) mResult + newNode = baseResult ^. L.node + resizeReq = isResizeAnyResult mResult + styleChanged = isJust evt && styleStateChanged wenv newNode (fromJust evt) + result + | styleChanged || resizeReq = Just $ baseResult + & L.node .~ updateSizeReq wenv newNode + | otherwise = mResult + +defaultResize :: SingleResizeHandler s e +defaultResize wenv node viewport = resultNode node + +resizeHandlerWrapper + :: WidgetModel a + => Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Rect + -> (Path -> Bool) + -> WidgetResult s e +resizeHandlerWrapper single wenv node viewport resizeReq = result where + useCustomSize = singleUseCustomSize single + handler = singleResize single + + tmpRes = handler wenv node viewport + lensVp = L.info . L.viewport + newVp + | useCustomSize = tmpRes ^. L.node . lensVp + | otherwise = viewport + tmpResult = Just $ tmpRes + & L.node . L.info . L.viewport .~ newVp + + newNode = tmpRes ^. L.node + result = fromJust $ handleSizeReqChange single wenv newNode Nothing tmpResult + +defaultRender :: SingleRenderHandler s e +defaultRender wenv node renderer = return () + +renderWrapper + :: Single s e a + -> WidgetEnv s e + -> WidgetNode s e + -> Renderer + -> IO () +renderWrapper single wenv node renderer = + drawInScissor renderer useScissor viewport $ + drawStyledAction renderer viewport style $ \_ -> + handler wenv node renderer + where + handler = singleRender single + useScissor = singleUseScissor single + style = singleGetCurrentStyle single wenv node + viewport = node ^. L.info . L.viewport diff --git a/src/Monomer/Widgets/Singles/Base/InputField.hs b/src/Monomer/Widgets/Singles/Base/InputField.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Base/InputField.hs @@ -0,0 +1,942 @@ +{-| +Module : Monomer.Widgets.Singles.Base.InputField +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Base single line text editing field. Extensible for handling specific textual +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'. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Monomer.Widgets.Singles.Base.InputField ( + InputFieldCfg(..), + InputFieldState(..), + inputField_ +) where + +import Control.Applicative ((<|>)) +import Control.Monad +import Control.Lens + (ALens', (&), (.~), (?~), (%~), (^.), (^?), _2, _Just, cloneLens, non) +import Data.Default +import Data.Maybe +import Data.Sequence (Seq(..), (|>)) +import Data.Text (Text) +import Data.Typeable +import GHC.Generics + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Helper +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +-- | Constaints for a value handled by input field. +type InputFieldValue a = (Eq a, Show a, Typeable a) + +{-| +Handler for wheel events. Useful for values on which increase/decrease makes +sense. +-} +type InputWheelHandler a + = InputFieldState a -- ^ The state of the input field + -> Point -- ^ The mouse position. + -> Point -- ^ The wheel movement along x/y. + -> WheelDirection -- ^ Whether movement is normal or inverted. + -> (Text, Int, Maybe Int) -- ^ New text, cursor position and selection start. + +{-| +Handler for drag events. Useful for values on which increase/decrease makes +sense. +-} +type InputDragHandler a + = InputFieldState a -- ^ The state of the input field + -> Point -- ^ The mouse position. + -> Point -- ^ The wheel movement along x/y. + -> (Text, Int, Maybe Int) -- ^ New text, cursor position and selection start. + +{-| +Configuration options for an input field. These options are not directly exposed +to users; each derived widget should expose its own options. +-} +data InputFieldCfg s e a = InputFieldCfg { + -- | Placeholder text to show when input is empty. + _ifcPlaceholder :: Maybe Text, + -- | Initial value for the input field, before retrieving from model. + _ifcInitialValue :: a, + -- | Where to get current data from. + _ifcValue :: WidgetData s a, + -- | Flag to indicate if the field is valid or not, using a lens. + _ifcValid :: Maybe (WidgetData s Bool), + -- | Flag to indicate if the field is valid or not, using an event handler. + _ifcValidV :: [Bool -> e], + -- | Whether to put cursor at the end of input on init. Defaults to False. + _ifcDefCursorEnd :: Bool, + -- | Default width of the input field. + _ifcDefWidth :: Double, + -- | Caret width. + _ifcCaretWidth :: Maybe Double, + -- | Caret blink period. + _ifcCaretMs :: Maybe Int, + -- | 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, + -- | Conversion from text to the expected value. Failure returns Nothing. + _ifcFromText :: Text -> Maybe a, + -- | Conversion from a value to text. Cannot fail. + _ifcToText :: a -> Text, + {-| + Whether to accept the current input status. The conversion fromText may still + fail, but input still will be accepted. This is used, for instance, in date + fields when input is not complete and a valid date cannot be created. + -} + _ifcAcceptInput :: Text -> Bool, + {-| + Whether the current text is valid input. Valid input means being able to + convert to the expected type, and after that conversion the value matches the + expected constraints (for instance, a well formed number between 1 and 100). + -} + _ifcIsValidInput :: Text -> Bool, + -- | Base style retrieved from the active theme. + _ifcStyle :: Maybe (ALens' ThemeState StyleState), + -- | Handler for wheel events. + _ifcWheelHandler :: Maybe (InputWheelHandler a), + -- | Handler for drag events. + _ifcDragHandler :: Maybe (InputDragHandler a), + -- | Cursor to display on drag events. + _ifcDragCursor :: Maybe CursorIcon, + -- | WidgetRequest to generate when focus is received. + _ifcOnFocusReq :: [Path -> WidgetRequest s e], + -- | WidgetRequest to generate when focus is lost. + _ifcOnBlurReq :: [Path -> WidgetRequest s e], + -- | WidgetRequest to generate when value changes. + _ifcOnChangeReq :: [a -> WidgetRequest s e] +} + +data HistoryStep a = HistoryStep { + _ihsValue :: a, + _ihsText :: !Text, + _ihsCursorPos :: !Int, + _ihsSelStart :: Maybe Int, + _ihsOffset :: !Double +} deriving (Eq, Show, Generic) + +initialHistoryStep :: a -> HistoryStep a +initialHistoryStep value = HistoryStep { + _ihsValue = value, + _ihsText = "", + _ihsCursorPos = 0, + _ihsSelStart = Nothing, + _ihsOffset = 0 +} + +-- | Current state of the input field. Provided to some event handlers. +data InputFieldState a = InputFieldState { + {-| + The placeholder text to show when input is empty. Does not depend on cursor + position. + -} + _ifsPlaceholder :: Seq TextLine, + -- | The latest valid value. + _ifsCurrValue :: a, + -- | The latest accepted input text. + _ifsCurrText :: !Text, + -- | The current cursor position. + _ifsCursorPos :: !Int, + -- | The selection start. Once selection begins, it doesn't change until done. + _ifsSelStart :: Maybe Int, + -- | The value when drag event started. + _ifsDragSelValue :: a, + -- | The glyphs of the current text. + _ifsGlyphs :: Seq GlyphPos, + -- | The offset of the current text, given cursor position and text length. + _ifsOffset :: !Double, + -- | The rect of the current text, given cursor position and text length. + _ifsTextRect :: Rect, + -- | Text metrics of the current font and size. + _ifsTextMetrics :: TextMetrics, + -- | Edit history of the current field. Supports undo and redo. + _ifsHistory :: Seq (HistoryStep a), + -- | Current index into history. + _ifsHistIdx :: Int, + -- | The timestamp when focus was received (used for caret blink) + _ifsFocusStart :: Int +} deriving (Eq, Show, Typeable, Generic) + +initialState :: a -> InputFieldState a +initialState value = InputFieldState { + _ifsPlaceholder = Seq.empty, + _ifsCurrValue = value, + _ifsCurrText = "", + _ifsGlyphs = Seq.empty, + _ifsCursorPos = 0, + _ifsSelStart = Nothing, + _ifsDragSelValue = value, + _ifsOffset = 0, + _ifsTextRect = def, + _ifsTextMetrics = def, + _ifsHistory = Seq.empty, + _ifsHistIdx = 0, + _ifsFocusStart = 0 +} + +defCaretW :: Double +defCaretW = 2 + +defCaretMs :: Int +defCaretMs = 500 + +-- | Creates an instance of an input field, with customizations in config. +inputField_ + :: (InputFieldValue a, WidgetEvent e) + => WidgetType + -> InputFieldCfg s e a + -> WidgetNode s e +inputField_ widgetType config = node where + value = _ifcInitialValue config + widget = makeInputField config (initialState value) + node = defaultWidgetNode widgetType widget + & L.info . L.focusable .~ True + +makeInputField + :: (InputFieldValue a, WidgetEvent e) + => InputFieldCfg s e a + -> InputFieldState a + -> Widget s e +makeInputField config state = widget where + widget = createSingle state def { + singleFocusOnBtnPressed = False, + singleUseCustomCursor = True, + singleUseScissor = True, + singleGetBaseStyle = getBaseStyle, + singleInit = init, + singleMerge = merge, + singleDispose = dispose, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleResize = resize, + singleRender = render + } + + -- Simpler access to state members + currPlaceholder = _ifsPlaceholder state + currVal = _ifsCurrValue state + currText = _ifsCurrText state + currGlyphs = _ifsGlyphs state + currPos = _ifsCursorPos state + currSel = _ifsSelStart state + currOffset = _ifsOffset state + currHistory = _ifsHistory state + currHistIdx = _ifsHistIdx state + -- Text/value conversion functions + caretW = fromMaybe defCaretW (_ifcCaretWidth config) + caretMs = fromMaybe defCaretMs (_ifcCaretMs config) + fromText = _ifcFromText config + toText = _ifcToText config + getModelValue wenv = widgetDataGet (_weModel wenv) (_ifcValue config) + -- Mouse select handling options + wheelHandler = _ifcWheelHandler config + dragHandler = _ifcDragHandler config + dragCursor = _ifcDragCursor config + + getBaseStyle wenv node = _ifcStyle config >>= handler where + handler lstyle = Just $ collectTheme wenv (cloneLens lstyle) + + init wenv node = result where + newValue = getModelValue wenv + txtValue = toText newValue + txtPos + | _ifcDefCursorEnd config = T.length txtValue + | otherwise = 0 + newFieldState = newTextState wenv node state config + newState = newFieldState newValue txtValue txtPos Nothing + newNode = node + & L.widget .~ makeInputField config newState + parsedVal = fromText (toText newValue) + reqs = setModelValid config (isJust parsedVal) + result = resultReqs newNode reqs + + merge wenv node oldNode oldState = resultReqs newNode reqs where + oldInfo = node ^. L.info + oldValue = _ifsCurrValue oldState + oldText = _ifsCurrText oldState + oldPos = _ifsCursorPos oldState + oldSel = _ifsSelStart oldState + value = getModelValue wenv + newText + | oldValue /= getModelValue wenv = toText value + | otherwise = oldText + newTextL = T.length newText + newPos + | oldText == newText = oldPos + | _ifcDefCursorEnd config = newTextL + | otherwise = 0 + newSelStart + | isNothing oldSel || newTextL < fromJust oldSel = Nothing + | otherwise = oldSel + newFieldState = newTextState wenv node oldState config + newState = newFieldState value newText newPos newSelStart + newNode = node + & L.widget .~ makeInputField config newState + parsedVal = fromText newText + oldPath = oldInfo ^. L.path + oldWid = oldInfo ^. L.widgetId + newPath = node ^. L.info . L.path + newWid = node ^. L.info . L.widgetId + updateFocus = wenv ^. L.focusedPath == oldPath && oldPath /= newPath + renderReqs + | updateFocus = [RenderStop oldWid, RenderEvery newWid caretMs Nothing] + | otherwise = [] + reqs = setModelValid config (isJust parsedVal) ++ renderReqs + + dispose wenv node = resultReqs node reqs where + widgetId = node ^. L.info . L.widgetId + 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 + | isMoveLeft = Just $ moveCursor txt (tp - 1) Nothing + | isMoveRight = Just $ moveCursor txt (tp + 1) Nothing + | isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing + | isMoveWordR = Just $ moveCursor txt nextWordEndIdx Nothing + | isMoveLineL = Just $ moveCursor txt 0 Nothing + | isMoveLineR = Just $ moveCursor txt txtLen Nothing + | isSelectAll = Just $ moveCursor txt 0 (Just txtLen) + | isSelectLeft = Just $ moveCursor txt (tp - 1) (Just tp) + | isSelectRight = Just $ moveCursor txt (tp + 1) (Just tp) + | isSelectWordL = Just $ moveCursor txt prevWordStartIdx (Just tp) + | isSelectWordR = Just $ moveCursor txt nextWordEndIdx (Just tp) + | isSelectLineL = Just $ moveCursor txt 0 (Just tp) + | isSelectLineR = Just $ moveCursor txt txtLen (Just tp) + | isDeselectLeft = Just $ moveCursor txt minTpSel Nothing + | isDeselectRight = Just $ moveCursor txt maxTpSel Nothing + | otherwise = Nothing + where + txt = currText + txtLen = T.length txt + tp = currPos + emptySel = isNothing currSel + (part1, part2) = T.splitAt currPos currText + currSelVal = fromMaybe 0 currSel + activeSel = isJust currSel + minTpSel = min tp currSelVal + maxTpSel = max tp currSelVal + prevWordStart = T.dropWhileEnd (not . delim) $ T.dropWhileEnd delim part1 + prevWordStartIdx = T.length prevWordStart + nextWordEnd = T.dropWhile (not . delim) $ T.dropWhile delim part2 + nextWordEndIdx = txtLen - T.length nextWordEnd + isShift = _kmLeftShift mod + isLeft = isKeyLeft code + isRight = isKeyRight code + isHome = isKeyHome code + isEnd = isKeyEnd code + isWordMod + | isMacOS wenv = _kmLeftAlt mod + | otherwise = _kmLeftCtrl mod + isLineMod + | isMacOS wenv = _kmLeftCtrl mod || _kmLeftGUI mod + | otherwise = _kmLeftAlt mod + isAllMod + | isMacOS wenv = _kmLeftGUI mod + | otherwise = _kmLeftCtrl mod + isBackspace = isKeyBackspace code && (tp > 0 || isJust currSel) + isDelBackWord = isBackspace && isWordMod + isDelBackWordNoSel = isDelBackWord && emptySel + isMove = not isShift && not isWordMod && not isLineMod + isMoveWord = not isShift && isWordMod && not isLineMod + isMoveLine = not isShift && isLineMod && not isWordMod + isSelect = isShift && not isWordMod && not isLineMod + isSelectWord = isShift && isWordMod && not isLineMod + isSelectLine = isShift && isLineMod && not isWordMod + isMoveLeft = isMove && not activeSel && isLeft + isMoveRight = isMove && not activeSel && isRight + isMoveWordL = isMoveWord && isLeft + isMoveWordR = isMoveWord && isRight + isMoveLineL = (isMoveLine && isLeft) || (not isShift && isHome) + isMoveLineR = (isMoveLine && isRight) || (not isShift && isEnd) + isSelectAll = isAllMod && isKeyA code + isSelectLeft = isSelect && isLeft + isSelectRight = isSelect && isRight + isSelectWordL = isSelectWord && isLeft + isSelectWordR = isSelectWord && isRight + isSelectLineL = (isSelectLine && isLeft) || (isShift && isHome) + isSelectLineR = (isSelectLine && isRight) || (isShift && isEnd) + isDeselectLeft = isMove && activeSel && isLeft + isDeselectRight = isMove && activeSel && isRight + removeText + | isJust currSel = replaceText txt "" + | otherwise = T.init part1 <> part2 + removeWord + | isJust currSel = replaceText txt "" + | otherwise = prevWordStart <> part2 + moveCursor txt newPos newSel + | isJust currSel && isNothing newSel = (txt, fixedPos, Nothing) + | isJust currSel && Just fixedPos == currSel = (txt, fixedPos, Nothing) + | isJust currSel = (txt, fixedPos, currSel) + | Just fixedPos == fixedSel = (txt, fixedPos, Nothing) + | otherwise = (txt, fixedPos, fixedSel) + where + fixedPos = fixIdx newPos + fixedSel = fmap fixIdx newSel + fixIdx idx + | idx < 0 = 0 + | idx >= txtLen = txtLen + | otherwise = idx + + handleEvent wenv node target evt = case evt of + -- Begin regular text selection + ButtonAction point btn BtnPressed clicks + | dragSelectText btn && clicks == 1 -> Just result where + style = currentStyle wenv node + contentArea = getContentArea node style + newPos = findClosestGlyphPos state point + newState = newFieldState currVal currText newPos Nothing + newNode = node + & L.widget .~ makeInputField config newState + newReqs = [ SetFocus widgetId | not (isNodeFocused wenv node) ] + result = resultReqs newNode newReqs + + -- Begin custom drag + ButtonAction point btn BtnPressed clicks + | dragHandleExt btn && clicks == 1 -> Just (resultNode newNode) where + newState = state { _ifsDragSelValue = currVal } + newNode = node + & L.widget .~ makeInputField config newState + + -- Select one word if clicked twice in a row + ButtonAction point btn BtnReleased clicks + | dragSelectText btn && clicks == 2 -> Just result where + (part1, part2) = T.splitAt currPos currText + txtLen = T.length currText + wordStart = T.dropWhileEnd (not . delim) part1 + wordStartIdx = T.length wordStart + wordEnd = T.dropWhile (not . delim) part2 + wordEndIdx = txtLen - T.length wordEnd + newPos = wordStartIdx + newSel = Just wordEndIdx + newState = newFieldState currVal currText newPos newSel + newNode = node + & L.widget .~ makeInputField config newState + result = resultReqs newNode [RenderOnce] + + -- Select all if clicked three times in a row + ButtonAction point btn BtnReleased clicks + | dragSelectText btn && clicks == 3 -> Just result where + newPos = 0 + newSel = Just (T.length currText) + newState = newFieldState currVal currText newPos newSel + newNode = node + & L.widget .~ makeInputField config newState + result = resultReqs newNode [RenderOnce] + + -- If a custom drag handler is used, generate onChange events and history + ButtonAction point btn BtnReleased clicks + | dragHandleExt btn && clicks == 0 -> Just result where + reqs = [RenderOnce] + result = genInputResult wenv node True currText currPos currSel reqs + + -- Handle regular text selection + Move point + | isNodePressed wenv node && not shiftPressed -> Just result where + style = currentStyle wenv node + contentArea = getContentArea node style + newPos = findClosestGlyphPos state point + newSel = currSel <|> Just currPos + newState = newFieldState currVal currText newPos newSel + newNode = node + & L.widget .~ makeInputField config newState + result = resultReqs newNode (RenderOnce : changeCursorReq validCursor) + + -- Handle custom drag + Move point + | isNodePressed wenv node && shiftPressed -> Just result where + (_, stPoint) = fromJust $ wenv ^. L.mainBtnPress + handlerRes = fromJust dragHandler state stPoint point + (newText, newPos, newSel) = handlerRes + reqs = RenderOnce : changeCursorReq validCursor + result = genInputResult wenv node True newText newPos newSel reqs + + -- Sets the correct cursor icon + Move point -> Just (resultReqs node reqs) where + reqs = changeCursorReq validCursor + + -- Handle wheel + WheelScroll point move dir + | isJust wheelHandler -> Just result where + handlerRes = fromJust wheelHandler state point move dir + (newText, newPos, newSel) = handlerRes + reqs = [RenderOnce] + result = genInputResult wenv node True newText newPos newSel reqs + + -- Handle keyboard shortcuts and possible cursor changes + KeyAction mod code KeyPressed + | isKeyboardCopy wenv evt + -> Just $ resultReqs node [SetClipboard (ClipboardText selectedText)] + | isKeyboardPaste wenv evt + -> 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 + | otherwise -> fmap handleKeyRes keyRes <|> cursorRes where + keyRes = handleKeyPress wenv mod code + handleKeyRes (newText, newPos, newSel) = result where + result = genInputResult wenv node False newText newPos newSel [] + cursorReq = changeCursorReq validCursor + cursorRes + | not (null cursorReq) = Just (resultReqs node cursorReq) + | otherwise = Nothing + + -- Handle possible cursor reset + KeyAction mod code KeyReleased + | (pressed || hovered) && not (null reqs) -> result where + pressed = isNodePressed wenv node + hovered = isNodeHovered wenv node + reqs = changeCursorReq validCursor + 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 + + -- Paste clipboard contents + Clipboard (ClipboardText newText) -> result where + result = insertTextRes wenv node newText + + -- Handle focus, maybe select all and disable custom drag handlers + Focus prev -> Just result where + tmpState + | _ifcSelectOnFocus config && T.length currText > 0 = state { + _ifsSelStart = Just 0, + _ifsCursorPos = T.length currText + } + | otherwise = state + newState = tmpState { + _ifsFocusStart = wenv ^. L.timestamp + } + reqs = [RenderEvery widgetId caretMs Nothing, StartTextInput viewport] + newNode = node + & L.widget .~ makeInputField config newState + newResult = resultReqs newNode reqs + focusRs = handleFocusChange newNode prev (_ifcOnFocusReq config) + result = maybe newResult (newResult <>) focusRs + + -- Handle blur and disable custom drag handlers + Blur next -> Just result where + reqs = [RenderStop widgetId, StopTextInput] + newResult = resultReqs node reqs + blurResult = handleFocusChange node next (_ifcOnBlurReq config) + result = maybe newResult (newResult <>) blurResult + + _ -> Nothing + where + widgetId = node ^. L.info . L.widgetId + viewport = node ^. L.info . L.viewport + newFieldState = newTextState wenv node state config + shiftPressed = wenv ^. L.inputStatus . L.keyMod . L.leftShift + dragSelectText btn + = wenv ^. L.mainButton == btn + && not shiftPressed + dragHandleExt btn + = wenv ^. L.mainButton == btn + && shiftPressed + && isJust dragHandler + validCursor + | not shiftPressed = CursorIBeam + | otherwise = fromMaybe CursorArrow dragCursor + changeCursorReq newCursor = reqs where + cursorMatch = wenv ^? L.cursor . _Just . _2 == Just newCursor + reqs + | not cursorMatch = [SetCursorIcon widgetId newCursor] + | otherwise = [] + + insertTextRes wenv node addedText = Just result where + addedLen = T.length addedText + newText = replaceText currText addedText + newPos + | isJust currSel = addedLen + min currPos (fromJust currSel) + | otherwise = addedLen + currPos + result = genInputResult wenv node True newText newPos Nothing [] + + cutTextRes wenv node = Just result where + tmpResult = fromMaybe (resultNode node) (insertTextRes wenv node "") + result = tmpResult + & L.requests %~ (|> SetClipboard (ClipboardText selectedText)) + + replaceText txt newTxt + | isJust currSel = T.take start txt <> newTxt <> T.drop end txt + | otherwise = T.take currPos txt <> newTxt <> T.drop currPos txt + where + start = min currPos (fromJust currSel) + end = max currPos (fromJust currSel) + + selectedText + | isJust currSel = T.take (end - start) $ T.drop start currText + | otherwise = "" + where + start = min currPos (fromJust currSel) + end = max currPos (fromJust currSel) + + genInputResult wenv node textAdd newText newPos newSel newReqs = result where + acceptInput = _ifcAcceptInput config newText + isValid = _ifcIsValidInput config newText + newVal = fromText newText + stVal + | isValid = fromMaybe currVal newVal + | otherwise = currVal + tempState = newTextState wenv node state config stVal newText newPos newSel + newOffset = _ifsOffset tempState + history = _ifsHistory tempState + histIdx = _ifsHistIdx tempState + newStep = HistoryStep stVal newText newPos newSel newOffset + newState + | currText == newText = tempState + | length history == histIdx = tempState { + _ifsHistory = history |> newStep, + _ifsHistIdx = histIdx + 1 + } + | otherwise = tempState { + _ifsHistory = Seq.take (histIdx - 1) history |> newStep, + _ifsHistIdx = histIdx + } + newNode = node + & L.widget .~ makeInputField config newState + (reqs, events) = genReqsEvents node config state newText newReqs + result + | acceptInput || not textAdd = resultReqsEvts newNode reqs events + | otherwise = resultReqsEvts node reqs events + + getSizeReq wenv node = sizeReq where + defWidth = _ifcDefWidth config + resizeOnChange = _ifcResizeOnChange config + currText + | _ifsCurrText state /= "" = _ifsCurrText state + | otherwise = fromMaybe "" (_ifcPlaceholder config) + style = currentStyle wenv node + Size w h = getTextSize wenv style currText + targetW + | resizeOnChange = max w 100 + | otherwise = defWidth + factor = 1 + sizeReq = (expandSize targetW factor, fixedSize h) + + resize wenv node viewport = resultNode newNode where + -- newTextState depends on having correct viewport in the node + tempNode = node + & L.info . L.viewport .~ viewport + newFieldState = newTextState wenv tempNode state config + newState = newFieldState currVal currText currPos currSel + newNode = tempNode + & L.widget .~ makeInputField config newState + + render wenv node renderer = do + when (isJust currSel && (focused || not selectOnFocus)) $ + drawRect renderer selRect (Just selColor) Nothing + + when (currText == "" && not (null currPlaceholder)) $ + drawInTranslation renderer (Point cx cy) $ + forM_ currPlaceholder (drawTextLine renderer placeholderStyle) + + renderContent renderer state style (getDisplayText config currText) + + when caretRequired $ + drawRect renderer caretRect (Just caretColor) Nothing + where + style = currentStyle wenv node + placeholderStyle = style + & L.text . non def . L.fontColor .~ style ^. L.sndColor + carea = getContentArea node style + Rect cx cy _ _ = carea + selectOnFocus = _ifcSelectOnFocus config + focused = isNodeFocused wenv node + ts = _weTimestamp wenv + + caretTs = ts - _ifsFocusStart state + caretRequired = focused && even (caretTs `div` caretMs) + caretColor = styleFontColor style + caretRect = getCaretRect config state style carea + + selColor = styleHlColor style + selRect = getSelRect state style + +textOffsetY :: TextMetrics -> StyleState -> Double +textOffsetY (TextMetrics ta td tl tlx) style = offset where + offset = case styleTextAlignV style of + ATBaseline -> -td + _ -> 0 + +renderContent :: Renderer -> InputFieldState a -> StyleState -> Text -> IO () +renderContent renderer state style currText = do + setFillColor renderer tsFontColor + renderText renderer textPos tsFont tsFontSize tsFontSpcH currText + where + Rect tx ty tw th = _ifsTextRect state + textMetrics = _ifsTextMetrics state + textPos = Point tx (ty + th + textOffsetY textMetrics style) + textStyle = fromMaybe def (_sstText style) + tsFont = styleFont style + tsFontSize = styleFontSize style + tsFontSpcH = styleFontSpaceH style + tsFontColor = styleFontColor style + +getCaretH :: InputFieldState a -> Double +getCaretH state = ta - td * 2 where + TextMetrics ta td _ _ = _ifsTextMetrics state + +getCaretRect + :: InputFieldCfg s e a + -> InputFieldState a + -> StyleState + -> Rect + -> Rect +getCaretRect config state style carea = caretRect where + Rect cx cy cw ch = carea + Rect tx ty tw th = _ifsTextRect state + caretW = fromMaybe defCaretW (_ifcCaretWidth config) + textMetrics = _ifsTextMetrics state + glyphs = _ifsGlyphs state + pos = _ifsCursorPos state + caretPos + | pos == 0 || null glyphs = 0 + | 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 + caretRect = Rect (caretX tx) caretY caretW (getCaretH state) + +getSelRect :: InputFieldState a -> StyleState -> Rect +getSelRect state style = selRect where + Rect tx ty tw th = _ifsTextRect state + textMetrics = _ifsTextMetrics state + glyphs = _ifsGlyphs state + pos = _ifsCursorPos state + sel = _ifsSelStart state + caretY = ty + textOffsetY textMetrics style + caretH = getCaretH state + glyph idx = Seq.index glyphs (min idx (length glyphs - 1)) + gx idx = _glpXMin (glyph idx) + gw start end = abs $ _glpXMax (glyph end) - _glpXMin (glyph start) + mkSelRect end + | pos > end = Rect (tx + gx end) caretY (gw end (pos - 1)) caretH + | otherwise = Rect (tx + gx pos) caretY (gw pos (end - 1)) caretH + selRect = maybe def mkSelRect sel + +findClosestGlyphPos :: InputFieldState a -> Point -> Int +findClosestGlyphPos state point = newPos where + Point x y = point + textRect = _ifsTextRect state + localX = x - _rX textRect + textLen = getGlyphsMax (_ifsGlyphs state) + glyphs + | Seq.null (_ifsGlyphs state) = Seq.empty + | otherwise = _ifsGlyphs state |> GlyphPos ' ' 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 + diffs = Seq.sortBy cpm pairs + newPos = maybe 0 fst (Seq.lookup 0 diffs) + +genReqsEvents + :: (Eq a) + => WidgetNode s e + -> InputFieldCfg s e a + -> InputFieldState a + -> Text + -> [WidgetRequest s e] + -> ([WidgetRequest s e], [e]) +genReqsEvents node config state newText newReqs = result where + widgetId = node ^. L.info . L.widgetId + resizeOnChange = _ifcResizeOnChange config + fromText = _ifcFromText config + setModelValue = widgetDataSet (_ifcValue config) + currVal = _ifsCurrValue state + currText = _ifsCurrText state + accepted = _ifcAcceptInput config newText + isValid = _ifcIsValidInput config newText + newVal = fromText newText + stateVal = fromMaybe currVal newVal + txtChanged = newText /= currText + valChanged = stateVal /= currVal + evtValid + | txtChanged = fmap ($ isValid) (_ifcValidV config) + | otherwise = [] + reqValid = setModelValid config isValid + reqUpdateModel + | accepted && valChanged = setModelValue stateVal + | otherwise = [] + reqResize + | resizeOnChange && valChanged = [ResizeWidgets widgetId] + | otherwise = [] + reqOnChange + | accepted && valChanged = fmap ($ stateVal) (_ifcOnChangeReq config) + | otherwise = [] + reqs = newReqs ++ reqUpdateModel ++ reqValid ++ reqResize ++ reqOnChange + result = (reqs, evtValid) + +moveHistory + :: (InputFieldValue a, WidgetEvent e) + => WidgetEnv s e + -> WidgetNode s e + -> InputFieldState a + -> InputFieldCfg s e a + -> Int + -> Maybe (WidgetResult s e) +moveHistory wenv node state config steps = result where + historyStep = initialHistoryStep (_ifcInitialValue config) + currHistory = _ifsHistory state + currHistIdx = _ifsHistIdx state + lenHistory = length currHistory + reqHistIdx + | steps == -1 && currHistIdx == lenHistory = currHistIdx - 2 + | otherwise = currHistIdx + steps + histStep = Seq.lookup reqHistIdx currHistory + result + | null currHistory || reqHistIdx < 0 = Just (createResult historyStep) + | otherwise = fmap createResult histStep + createResult histStep = resultReqsEvts newNode reqs evts where + (reqs, evts) = genReqsEvents node config state (_ihsText histStep) [] + tempState = newStateFromHistory wenv node state config histStep + newState = tempState { + _ifsHistIdx = clamp 0 lenHistory reqHistIdx + } + newNode = node & L.widget .~ makeInputField config newState + +newStateFromHistory + :: WidgetEnv s e + -> WidgetNode s e + -> InputFieldState a + -> InputFieldCfg s e a + -> HistoryStep a + -> InputFieldState a +newStateFromHistory wenv node oldState config inputHist = newState where + HistoryStep hValue hText hPos hSel hOffset = inputHist + tempState = oldState { _ifsOffset = hOffset } + newState = newTextState wenv node oldState config hValue hText hPos hSel + +newTextState + :: WidgetEnv s e + -> WidgetNode s e + -> InputFieldState a + -> InputFieldCfg s e a + -> a + -> Text + -> Int + -> Maybe Int + -> InputFieldState a +newTextState wenv node oldState config value text cursor sel = newState where + style = currentStyle wenv node + contentArea = getContentArea node style + caretW = fromMaybe defCaretW (_ifcCaretWidth config) + Rect cx cy cw ch = contentArea + alignH = inputFieldAlignH style + alignV = inputFieldAlignV style + alignL = alignH == ATLeft + alignR = alignH == ATRight + alignC = alignH == ATCenter + cursorL = cursor == 0 + cursorR = cursor == T.length text + !textMetrics = getTextMetrics wenv style + !textRect = getSingleTextLineRect wenv style contentArea alignH alignV text + Rect tx ty tw th = textRect + textFits = cw >= tw + glyphs = getTextGlyphs wenv style (getDisplayText config text) + glyphStart = maybe 0 _glpXMax $ Seq.lookup (cursor - 1) glyphs + glyphOffset = getGlyphsMin glyphs + glyphX = glyphStart - glyphOffset + curX = tx + glyphX + oldOffset = _ifsOffset oldState + newOffset + | round cw == 0 = 0 + | textFits && alignR = -caretW + | textFits = 0 + | alignL && cursorL = cx - tx + caretW + | alignL && curX + oldOffset > cx + cw = cx + cw - curX + | alignL && curX + oldOffset < cx = cx - curX + | alignR && cursorR = -caretW + | alignR && curX + oldOffset > cx + cw = tw - glyphX + | alignR && curX + oldOffset < cx = tw - cw - glyphX + | alignC && curX + oldOffset > cx + cw = cx + cw - curX + | alignC && curX + oldOffset < cx = cx - curX + | otherwise = oldOffset + justSel = fromJust sel + newSel + | Just cursor == sel = Nothing + | isJust sel && (justSel < 0 || justSel > T.length text) = Nothing + | otherwise = sel + tmpState = updatePlaceholder wenv node oldState config + newState = tmpState { + _ifsCurrValue = value, + _ifsCurrText = text, + _ifsCursorPos = cursor, + _ifsSelStart = newSel, + _ifsGlyphs = glyphs, + _ifsOffset = newOffset, + _ifsTextRect = textRect & L.x .~ tx + newOffset, + _ifsTextMetrics = textMetrics + } + +updatePlaceholder + :: WidgetEnv s e + -> WidgetNode s e + -> InputFieldState a + -> InputFieldCfg s e a + -> InputFieldState a +updatePlaceholder wenv node state config = newState where + fontMgr = wenv ^. L.fontManager + style = currentStyle wenv node + Rect cx cy cw ch = getContentArea node style + carea = Rect 0 0 cw ch + size = Size cw ch + -- Placeholder style + pstyle = style + & L.text . non def . L.alignH ?~ inputFieldAlignH style + & L.text . non def . L.alignV ?~ inputFieldAlignV style + text = _ifcPlaceholder config + fitText = fitTextToSize fontMgr pstyle Ellipsis MultiLine KeepSpaces Nothing + lines + | isJust text = fitText size (fromJust text) + | otherwise = Seq.empty + newState = state { + _ifsPlaceholder = alignTextLines pstyle carea lines + } + +setModelValid :: InputFieldCfg s e a -> Bool -> [WidgetRequest s e] +setModelValid config + | isJust (_ifcValid config) = widgetDataSet (fromJust $ _ifcValid config) + | otherwise = const [] + +inputFieldAlignH :: StyleState -> AlignTH +inputFieldAlignH style = fromMaybe ATLeft alignH where + alignH = style ^? L.text . _Just . L.alignH . _Just + +inputFieldAlignV :: StyleState -> AlignTV +inputFieldAlignV style = fromMaybe ATLowerX alignV where + alignV = style ^? L.text . _Just . L.alignV . _Just + +getDisplayText :: InputFieldCfg s e a -> Text -> Text +getDisplayText config text = displayText where + displayChar = T.singleton <$> _ifcDisplayChar config + displayText + | isJust displayChar = T.replicate (T.length text) (fromJust displayChar) + | otherwise = text + +delim :: Char -> Bool +delim c = c `elem` [' ', '.', ',', '/', '-', ':'] diff --git a/src/Monomer/Widgets/Singles/Button.hs b/src/Monomer/Widgets/Singles/Button.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Button.hs @@ -0,0 +1,264 @@ +{-| +Module : Monomer.Widgets.Singles.Button +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Button widget, with support for multiline text. At the most basic level, a +button consists of a caption and an event to raised when clicked. + +Configs: + +- 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. +- maxLines: maximum number of text lines to show. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onClick: event to raise when button is clicked. +- onClickReq: WidgetRequest to generate when button is clicked. +- resizeFactor: flexibility to have more or less spaced assigned. +- resizeFactorW: flexibility to have more or less horizontal spaced assigned. +- resizeFactorH: flexibility to have more or less vertical spaced assigned. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.Button ( + button, + button_, + mainButton, + mainButton_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Container +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data ButtonType + = ButtonNormal + | ButtonMain + deriving (Eq, Show) + +data ButtonCfg s e = ButtonCfg { + _btnButtonType :: Maybe ButtonType, + _btnIgnoreTheme :: Maybe Bool, + _btnLabelCfg :: LabelCfg s e, + _btnOnFocusReq :: [Path -> WidgetRequest s e], + _btnOnBlurReq :: [Path -> WidgetRequest s e], + _btnOnClickReq :: [WidgetRequest s e] +} + +instance Default (ButtonCfg s e) where + def = ButtonCfg { + _btnButtonType = Nothing, + _btnIgnoreTheme = Nothing, + _btnLabelCfg = def, + _btnOnFocusReq = [], + _btnOnBlurReq = [], + _btnOnClickReq = [] + } + +instance Semigroup (ButtonCfg s e) where + (<>) t1 t2 = ButtonCfg { + _btnButtonType = _btnButtonType t2 <|> _btnButtonType t1, + _btnIgnoreTheme = _btnIgnoreTheme t2 <|> _btnIgnoreTheme t1, + _btnLabelCfg = _btnLabelCfg t1 <> _btnLabelCfg t2, + _btnOnFocusReq = _btnOnFocusReq t1 <> _btnOnFocusReq t2, + _btnOnBlurReq = _btnOnBlurReq t1 <> _btnOnBlurReq t2, + _btnOnClickReq = _btnOnClickReq t1 <> _btnOnClickReq t2 + } + +instance Monoid (ButtonCfg s e) where + mempty = def + +instance CmbIgnoreTheme (ButtonCfg s e) where + ignoreTheme_ ignore = def { + _btnIgnoreTheme = Just ignore + } + +instance CmbTrimSpaces (ButtonCfg s e) where + trimSpaces_ trim = def { + _btnLabelCfg = trimSpaces_ trim + } + +instance CmbEllipsis (ButtonCfg s e) where + ellipsis_ ellipsis = def { + _btnLabelCfg = ellipsis_ ellipsis + } + +instance CmbMultiline (ButtonCfg s e) where + multiline_ multi = def { + _btnLabelCfg = multiline_ multi + } + +instance CmbMaxLines (ButtonCfg s e) where + maxLines count = def { + _btnLabelCfg = maxLines count + } + +instance CmbResizeFactor (ButtonCfg s e) where + resizeFactor s = def { + _btnLabelCfg = resizeFactor s + } + +instance CmbResizeFactorDim (ButtonCfg s e) where + resizeFactorW w = def { + _btnLabelCfg = resizeFactorW w + } + resizeFactorH h = def { + _btnLabelCfg = resizeFactorH h + } + +instance WidgetEvent e => CmbOnFocus (ButtonCfg s e) e Path where + onFocus fn = def { + _btnOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (ButtonCfg s e) s e Path where + onFocusReq req = def { + _btnOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (ButtonCfg s e) e Path where + onBlur fn = def { + _btnOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (ButtonCfg s e) s e Path where + onBlurReq req = def { + _btnOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnClick (ButtonCfg s e) e where + onClick handler = def { + _btnOnClickReq = [RaiseEvent handler] + } + +instance CmbOnClickReq (ButtonCfg s e) s e where + onClickReq req = def { + _btnOnClickReq = [req] + } + +mainConfig :: ButtonCfg s e +mainConfig = def { + _btnButtonType = Just ButtonMain +} + +-- | Creates a button with main styling. Useful for dialogs. +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. +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 normal styling. +button :: WidgetEvent e => Text -> e -> WidgetNode s e +button caption handler = button_ caption handler def + +-- | 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 + widget = makeButton caption config + buttonNode = defaultWidgetNode "button" widget + & L.info . L.focusable .~ True + +makeButton :: WidgetEvent e => Text -> ButtonCfg s e -> Widget s e +makeButton caption config = widget where + widget = createContainer () def { + containerAddStyleReq = False, + containerUseScissor = True, + containerGetBaseStyle = getBaseStyle, + containerGetCurrentStyle = getCurrentStyle, + containerInit = init, + containerMerge = merge, + containerHandleEvent = handleEvent, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + + buttonType = fromMaybe ButtonNormal (_btnButtonType config) + + getBaseStyle wenv node + | ignoreTheme = Nothing + | otherwise = case buttonType of + ButtonNormal -> Just (collectTheme wenv L.btnStyle) + ButtonMain -> Just (collectTheme wenv L.btnMainStyle) + where + ignoreTheme = _btnIgnoreTheme config == Just True + + getCurrentStyle wenv node = styleState where + style = node ^. L.info . L.style + isEnabled = node ^. L.info . L.enabled + isActive = isNodeTreeActive wenv node + styleState + | isEnabled && isActive = fromMaybe def (_styleActive style) + | otherwise = currentStyle wenv node + + createChildNode wenv node = newNode where + nodeStyle = node ^. L.info . L.style + labelCfg = (_btnLabelCfg config) { + _lscCurrentStyle = Just childOfFocusedStyle + } + labelNode = label_ caption [ignoreTheme, labelCfg] + & L.info . L.style .~ nodeStyle + newNode = node + & L.children .~ Seq.singleton labelNode + + init wenv node = result where + result = resultNode (createChildNode wenv node) + + merge wenv node oldNode oldState = result where + result = resultNode (createChildNode wenv node) + + handleEvent wenv node target evt = case evt of + Focus prev -> handleFocusChange node prev (_btnOnFocusReq config) + Blur next -> handleFocusChange node next (_btnOnBlurReq config) + + KeyAction mode code status + | isSelectKey code && status == KeyPressed -> Just result + where + isSelectKey code = isKeyReturn code || isKeySpace code + + Click p _ _ + | isPointInNodeVp node p -> Just result + + ButtonAction p btn BtnPressed 1 -- Set focus on click + | mainBtn btn && pointInVp p && not focused -> Just resultFocus + + _ -> Nothing + where + mainBtn btn = btn == wenv ^. L.mainButton + focused = isNodeFocused wenv node + pointInVp p = isPointInNodeVp node p + reqs = _btnOnClickReq config + result = resultReqs node reqs + resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)] + + getSizeReq :: ContainerGetSizeReqHandler s e + getSizeReq wenv node children = (newReqW, newReqH) where + -- Main section reqs + child = Seq.index children 0 + newReqW = child ^. L.info . L.sizeReqW + newReqH = child ^. L.info . L.sizeReqH + + resize wenv node viewport children = resized where + assignedAreas = Seq.fromList [viewport] + resized = (resultNode node, assignedAreas) diff --git a/src/Monomer/Widgets/Singles/Checkbox.hs b/src/Monomer/Widgets/Singles/Checkbox.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Checkbox.hs @@ -0,0 +1,240 @@ +{-| +Module : Monomer.Widgets.Singles.Checkbox +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +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, `LabeledCheckbox` provides this functionality out of the +box. + +Configs: + +- checkboxMark: the type of checkbox mark. +- width: sets the max width/height of the checkbox. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes/is clicked. +- onChangeReq: WidgetRequest to generate when the value changes/is clicked. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.Checkbox ( + CmbCheckboxMark(..), + CheckboxCfg(..), + CheckboxMark(..), + checkbox, + checkbox_, + checkboxV, + checkboxV_, + checkboxD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~)) +import Control.Monad +import Data.Default +import Data.Maybe + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +-- | Type of drawing for the checkbox mark. +data CheckboxMark + = CheckboxSquare + | CheckboxTimes + deriving (Eq, Show) + +-- | Sets the type of checkbox mark. +class CmbCheckboxMark t where + checkboxMark :: CheckboxMark -> t + checkboxSquare :: t + checkboxTimes :: t + +-- | Configuration options for checkbox widget. +data CheckboxCfg s e = CheckboxCfg { + _ckcMark :: Maybe CheckboxMark, + _ckcWidth :: Maybe Double, + _ckcOnFocusReq :: [Path -> WidgetRequest s e], + _ckcOnBlurReq :: [Path -> WidgetRequest s e], + _ckcOnChangeReq :: [Bool -> WidgetRequest s e] +} + +instance Default (CheckboxCfg s e) where + def = CheckboxCfg { + _ckcMark = Nothing, + _ckcWidth = Nothing, + _ckcOnFocusReq = [], + _ckcOnBlurReq = [], + _ckcOnChangeReq = [] + } + +instance Semigroup (CheckboxCfg s e) where + (<>) t1 t2 = CheckboxCfg { + _ckcMark = _ckcMark t2 <|> _ckcMark t1, + _ckcWidth = _ckcWidth t2 <|> _ckcWidth t1, + _ckcOnFocusReq = _ckcOnFocusReq t1 <> _ckcOnFocusReq t2, + _ckcOnBlurReq = _ckcOnBlurReq t1 <> _ckcOnBlurReq t2, + _ckcOnChangeReq = _ckcOnChangeReq t1 <> _ckcOnChangeReq t2 + } + +instance Monoid (CheckboxCfg s e) where + mempty = def + +instance CmbCheckboxMark (CheckboxCfg s e) where + checkboxMark mark = def { + _ckcMark = Just mark + } + checkboxSquare = checkboxMark CheckboxSquare + checkboxTimes = checkboxMark CheckboxTimes + +instance CmbWidth (CheckboxCfg s e) where + width w = def { + _ckcWidth = Just w + } + +instance WidgetEvent e => CmbOnFocus (CheckboxCfg s e) e Path where + onFocus fn = def { + _ckcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (CheckboxCfg s e) s e Path where + onFocusReq req = def { + _ckcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (CheckboxCfg s e) e Path where + onBlur fn = def { + _ckcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (CheckboxCfg s e) s e Path where + onBlurReq req = def { + _ckcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (CheckboxCfg s e) Bool e where + onChange fn = def { + _ckcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (CheckboxCfg s e) s e Bool where + onChangeReq req = def { + _ckcOnChangeReq = [req] + } + +-- | Creates a checkbox using the given lens. +checkbox :: WidgetEvent e => ALens' s Bool -> WidgetNode s e +checkbox field = checkbox_ field def + +-- | Creates a checkbox using the given lens. Accepts config. +checkbox_ + :: WidgetEvent e => ALens' s Bool -> [CheckboxCfg s e] -> WidgetNode s e +checkbox_ field config = checkboxD_ (WidgetLens field) config + +-- | Creates a checkbox using the given value and onChange event handler. +checkboxV :: WidgetEvent e => Bool -> (Bool -> e) -> WidgetNode s e +checkboxV value handler = checkboxV_ value handler def + +{-| +Creates a checkbox using the given value and onChange event handler. Accepts +config. +-} +checkboxV_ + :: WidgetEvent e => Bool -> (Bool -> e) -> [CheckboxCfg s e] -> WidgetNode s e +checkboxV_ value handler config = checkboxD_ (WidgetValue value) newConfig where + newConfig = onChange handler : config + +-- | Creates a checkbox providing a WidgetData instance and config. +checkboxD_ + :: WidgetEvent e => WidgetData s Bool -> [CheckboxCfg s e] -> WidgetNode s e +checkboxD_ widgetData configs = checkboxNode where + config = mconcat configs + widget = makeCheckbox widgetData config + checkboxNode = defaultWidgetNode "checkbox" widget + & L.info . L.focusable .~ True + +makeCheckbox + :: WidgetEvent e => WidgetData s Bool -> CheckboxCfg s e -> Widget s e +makeCheckbox widgetData config = widget where + widget = createSingle () def { + singleGetBaseStyle = getBaseStyle, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.checkboxStyle + + handleEvent wenv node target evt = case evt of + Focus prev -> handleFocusChange node prev (_ckcOnFocusReq config) + Blur next -> handleFocusChange node next (_ckcOnBlurReq config) + + Click p _ _ + | isPointInNodeVp node p -> Just $ resultReqs node reqs + + KeyAction mod code KeyPressed + | isSelectKey code -> Just $ resultReqs node reqs + _ -> Nothing + where + model = _weModel wenv + path = node ^. L.info . L.path + + isSelectKey code = isKeyReturn code || isKeySpace code + value = widgetDataGet model widgetData + newValue = not value + setValueReq = widgetDataSet widgetData newValue + reqs = setValueReq ++ fmap ($ newValue) (_ckcOnChangeReq config) + + getSizeReq wenv node = req where + theme = currentTheme wenv node + width = fromMaybe (theme ^. L.checkboxWidth) (_ckcWidth config) + req = (fixedSize width, fixedSize width) + + render wenv node renderer = do + renderCheckbox renderer checkboxBW checkboxArea radius fgColor + + when value $ + renderMark renderer checkboxBW checkboxArea hlColor mark + where + model = _weModel wenv + theme = currentTheme wenv node + style = currentStyle wenv node + value = widgetDataGet model widgetData + carea = getContentArea node style + + checkboxW = fromMaybe (theme ^. L.checkboxWidth) (_ckcWidth config) + checkboxBW = max 1 (checkboxW * 0.1) + checkboxL = _rX carea + (_rW carea - checkboxW) / 2 + checkboxT = _rY carea + (_rH carea - checkboxW) / 2 + checkboxArea = Rect checkboxL checkboxT checkboxW checkboxW + + radius = style ^. L.radius + fgColor = styleFgColor style + hlColor = styleHlColor style + mark = fromMaybe CheckboxTimes (_ckcMark config) + +renderCheckbox :: Renderer -> Double -> Rect -> Maybe Radius -> Color -> IO () +renderCheckbox renderer checkboxBW rect radius color = action where + side = Just $ BorderSide checkboxBW color + border = Border side side side side + action = drawRectBorder renderer rect border radius + +renderMark :: Renderer -> Double -> Rect -> Color -> CheckboxMark -> IO () +renderMark renderer checkboxBW rect color mark = action where + w = checkboxBW * 2 + lw = checkboxBW * 2 + newRect = fromMaybe def (subtractFromRect rect w w w w) + action + | mark == CheckboxSquare = drawRect renderer newRect (Just color) Nothing + | otherwise = drawTimesX renderer newRect lw (Just color) diff --git a/src/Monomer/Widgets/Singles/ColorPicker.hs b/src/Monomer/Widgets/Singles/ColorPicker.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/ColorPicker.hs @@ -0,0 +1,271 @@ +{-| +Module : Monomer.Widgets.Singles.ColorPicker +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Color picker using sliders and numeric fields. + +Configs: + +- showAlpha: whether to allow modifying the alpha channel or not. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when any of the values changes. +- onChangeReq: WidgetRequest to generate when any of the values changes. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.ColorPicker ( + colorPicker, + colorPicker_, + colorPickerV, + colorPickerV_, + colorPickerD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), ALens', abbreviatedFields, makeLensesWith) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder, toLazyByteString) +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Builder as B +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Graphics + +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Containers.ZStack +import Monomer.Widgets.Singles.Image +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.NumericField +import Monomer.Widgets.Singles.Slider +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +data ColorPickerCfg s e = ColorPickerCfg { + _cpcShowAlpha :: Maybe Bool, + _cpcOnFocusReq :: [Path -> WidgetRequest s e], + _cpcOnBlurReq :: [Path -> WidgetRequest s e], + _cpcOnChangeReq :: [Color -> WidgetRequest s e] +} + +instance Default (ColorPickerCfg s e) where + def = ColorPickerCfg { + _cpcShowAlpha = Nothing, + _cpcOnFocusReq = [], + _cpcOnBlurReq = [], + _cpcOnChangeReq = [] + } + +instance Semigroup (ColorPickerCfg s e) where + (<>) a1 a2 = def { + _cpcShowAlpha = _cpcShowAlpha a2 <|> _cpcShowAlpha a1, + _cpcOnFocusReq = _cpcOnFocusReq a1 <> _cpcOnFocusReq a2, + _cpcOnBlurReq = _cpcOnBlurReq a1 <> _cpcOnBlurReq a2, + _cpcOnChangeReq = _cpcOnChangeReq a1 <> _cpcOnChangeReq a2 + } + +instance Monoid (ColorPickerCfg s e) where + mempty = def + +instance CmbShowAlpha (ColorPickerCfg s e) where + showAlpha_ show = def { + _cpcShowAlpha = Just show + } + +instance WidgetEvent e => CmbOnFocus (ColorPickerCfg s e) e Path where + onFocus fn = def { + _cpcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (ColorPickerCfg s e) s e Path where + onFocusReq req = def { + _cpcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (ColorPickerCfg s e) e Path where + onBlur fn = def { + _cpcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (ColorPickerCfg s e) s e Path where + onBlurReq req = def { + _cpcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (ColorPickerCfg s e) Color e where + onChange fn = def { + _cpcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (ColorPickerCfg s e) s e Color where + onChangeReq req = def { + _cpcOnChangeReq = [req] + } + +data ColorPickerEvt + = PickerFocus Path + | PickerBlur Path + | ColorChanged Int + | AlphaChanged Double + deriving (Eq, Show) + +-- | Creates a color picker using the given lens. +colorPicker + :: (WidgetModel sp, WidgetEvent ep) + => ALens' sp Color + -> WidgetNode sp ep +colorPicker field = colorPicker_ field def + +-- | Creates a color picker using the given lens. Accepts config. +colorPicker_ + :: (WidgetModel sp, WidgetEvent ep) + => ALens' sp Color + -> [ColorPickerCfg sp ep] + -> WidgetNode sp ep +colorPicker_ field configs = colorPickerD_ wlens configs [] where + wlens = WidgetLens field + +-- | Creates a color picker using the given value and onChange event handler. +colorPickerV + :: (WidgetModel sp, WidgetEvent ep) + => Color + -> (Color -> ep) + -> WidgetNode sp ep +colorPickerV value handler = colorPickerV_ value handler def + +{-| +Creates a color picker using the given value and onChange event handler. Accepts +config. +-} +colorPickerV_ + :: (WidgetModel sp, WidgetEvent ep) + => Color + -> (Color -> ep) + -> [ColorPickerCfg sp ep] + -> WidgetNode sp ep +colorPickerV_ value handler configs = colorPickerD_ wdata newCfgs [] where + wdata = WidgetValue value + newCfgs = onChange handler : configs + +-- | Creates a color picker providing a WidgetData instance and config. +colorPickerD_ + :: (WidgetModel sp, WidgetEvent ep) + => WidgetData sp Color + -> [ColorPickerCfg sp ep] + -> [CompositeCfg Color ColorPickerEvt sp ep] + -> WidgetNode sp ep +colorPickerD_ wdata cfgs cmpCfgs = newNode where + cfg = mconcat cfgs + uiBuilder = buildUI cfg + evtHandler = handleEvent cfg + newNode = compositeD_ "colorPicker" wdata uiBuilder evtHandler cmpCfgs + +buildUI + :: ColorPickerCfg sp ep + -> WidgetEnv Color ColorPickerEvt + -> Color + -> WidgetNode Color ColorPickerEvt +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] + ] `styleBasic` [width 32] + + compRow lensCol evt lbl minV maxV = hstack [ + label lbl `styleBasic` [width 48], + spacer_ [width 2], + hslider_ lensCol minV maxV [onChange evt, onFocus PickerFocus, + onBlur PickerBlur] + `styleBasic` [paddingV 5], + spacer_ [width 2], + numericField_ lensCol [minValue minV, maxValue maxV, onChange evt, + onFocus PickerFocus, onBlur PickerBlur] + `styleBasic` [width 40, padding 0, textRight] + ] + + colorRow lens lbl = compRow lens ColorChanged lbl 0 255 + alphaRow lens lbl = compRow lens AlphaChanged lbl 0 1 + + mainTree = hstack_ [sizeReqUpdater clearExtra] [ + vstack [ + colorRow L.r "Red", + spacer_ [width 2], + colorRow L.g "Green", + spacer_ [width 2], + colorRow L.b "Blue", + spacer_ [width 2] `nodeVisible` showAlpha, + alphaRow L.a "Alpha" `nodeVisible` showAlpha + ], + spacer_ [width 2], + box_ [alignTop] colorSample `styleBasic` [flexHeight 50] + ] `styleBasic` [padding 0] + +handleEvent + :: (WidgetModel sp, WidgetEvent ep) + => ColorPickerCfg sp ep + -> WidgetEnv Color ColorPickerEvt + -> WidgetNode Color ColorPickerEvt + -> Color + -> ColorPickerEvt + -> [EventResponse Color ColorPickerEvt sp ep] +handleEvent cfg wenv node model evt = case evt of + PickerFocus prev + | not (isNodeParentOfPath node prev) -> reportFocus prev + PickerBlur next + | not (isNodeParentOfPath node next) -> reportBlur next + ColorChanged _ -> reportChange + AlphaChanged _ -> reportChange + _ -> [] + where + report reqs = RequestParent <$> reqs + reportFocus prev = report (($ prev) <$> _cpcOnFocusReq cfg) + reportBlur next = report (($ next) <$> _cpcOnBlurReq cfg) + reportChange = report (($ model) <$> _cpcOnChangeReq cfg) + +patternImage :: WidgetEvent e => Int -> Int -> Color -> Color -> WidgetNode s e +patternImage steps blockW col1 col2 = newImg where + row1 = encodeRow steps blockW col1 col2 + row2 = encodeRow steps blockW col2 col1 + builder = mconcat (replicate steps (row1 <> row2)) + + imgData = BL.toStrict $ toLazyByteString builder + imgLen = fromIntegral (steps * blockW) + imgSize = Size imgLen imgLen + imgConfig = [fitFill, imageRepeatX, imageRepeatY] + + newImg = imageMem_ "colorPickerAlphaBg" imgData imgSize imgConfig + +encodeRow :: Int -> Int -> Color -> Color -> Builder +encodeRow steps blockW col1 col2 = builder where + line = encodeLine steps blockW col1 col2 + builder = mconcat (replicate blockW line) + +encodeLine :: Int -> Int -> Color -> Color -> Builder +encodeLine steps blockW col1 col2 = builder where + p1 = mconcat $ replicate blockW (encodeColor col1) + p2 = mconcat $ replicate blockW (encodeColor col2) + builder = mconcat $ replicate (steps `div` 2) (p1 <> p2) + +encodeColor :: Color -> Builder +encodeColor (Color r g b a) = mconcat [er, eg, eb, ea] where + er = B.int8 $ fromIntegral r + eg = B.int8 $ fromIntegral g + eb = B.int8 $ fromIntegral b + ea = B.int8 $ round (255 * a) diff --git a/src/Monomer/Widgets/Singles/DateField.hs b/src/Monomer/Widgets/Singles/DateField.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/DateField.hs @@ -0,0 +1,507 @@ +{-| +Module : Monomer.Widgets.Singles.DateField +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Input field for dates types. + +Supports the Day type of the +library, but other types can be supported by implementing 'DayConverter'. Maybe +is also supported. + +Supports different date formats and separators. + +Handles mouse wheel and shift + vertical drag to increase/decrease days. + +Configs: + +- validInput: field indicating if the current input is valid. Useful to show +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. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes. +- onChangeReq: WidgetRequest to generate when the value changes. +- dateFormatDelimiter: which text delimiter to separate year, month and day. +- dateFormatDDMMYYYY: using the current delimiter, accept DD/MM/YYYY. +- dateFormatMMDDYYYY: using the current delimiter, accept MM/DD/YYYY. +- dateFormatYYYYMMDD: using the current delimiter, accept YYYY/MM/DD. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UndecidableInstances #-} + +module Monomer.Widgets.Singles.DateField ( + DayConverter(..), + dateField, + dateField_, + dateFieldV, + dateFieldV_, + dateFormatDelimiter, + dateFormatDDMMYYYY, + dateFormatMMDDYYYY, + dateFormatYYYYMMDD +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((^.), ALens', _1, _2, _3) +import Control.Monad (join) +import Data.Default +import Data.Either +import Data.Maybe +import Data.Text (Text) +import Data.Time +import Data.Typeable (Typeable, typeOf) + +import qualified Data.Attoparsec.Text as A +import qualified Data.Text as T + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event.Types +import Monomer.Widgets.Singles.Base.InputField + +import qualified Monomer.Lens as L +import qualified Monomer.Widgets.Util.Parser as P + +data DateFormat + = FormatDDMMYYYY + | FormatYYYYMMDD + | FormatMMDDYYYY + deriving (Eq, Show) + +defaultDateFormat :: DateFormat +defaultDateFormat = FormatDDMMYYYY + +defaultDateDelim :: Char +defaultDateDelim = '/' + +{-| +Converter to and form the Day type of the time library. To use types other than +Day of said library, this typeclass needs to be implemented. +--} +class (Eq a, Ord a, Show a, Typeable a) => DayConverter a where + convertFromDay :: Day -> a + convertToDay :: a -> Maybe Day + +instance DayConverter Day where + convertFromDay = id + convertToDay = Just + +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 + dateFromDay :: Day -> a + dateToDay :: a -> Maybe Day + +instance {-# OVERLAPPABLE #-} DayConverter a => DateTextConverter a where + dateAcceptText format delim minVal maxVal text = result where + accept = acceptTextInput format delim text + parsed = dateFromText format delim text + isValid = isJust parsed && dateInBounds minVal maxVal (fromJust parsed) + fromText + | isValid = parsed + | otherwise = Nothing + result = (accept, isValid, fromText) + dateFromText = dateFromTextSimple + dateToText = dateToTextSimple + dateFromDay = convertFromDay + dateToDay = convertToDay + +instance (DayConverter a, DateTextConverter a) => DateTextConverter (Maybe a) where + dateAcceptText format delim minVal maxVal text + | T.strip text == "" = (True, True, Just Nothing) + | otherwise = (accept, isValid, result) where + resp = dateAcceptText format delim (join minVal) (join maxVal) text + (accept, isValid, tmpResult) = resp + result + | isJust tmpResult = Just tmpResult + | otherwise = Nothing + dateFromText format delim = Just . dateFromText format delim + dateToText format delim Nothing = "" + dateToText format delim (Just value) = dateToText format delim value + dateFromDay = Just . dateFromDay + dateToDay Nothing = Nothing + dateToDay (Just value) = dateToDay value + +type FormattableDate a + = (Eq a, Ord a, Show a, DateTextConverter a, Typeable a) + +data DateFieldCfg s e a = DateFieldCfg { + _dfcCaretWidth :: Maybe Double, + _dfcCaretMs :: Maybe Int, + _dfcValid :: Maybe (WidgetData s Bool), + _dfcValidV :: [Bool -> e], + _dfcDateDelim :: Maybe Char, + _dfcDateFormat :: Maybe DateFormat, + _dfcMinValue :: Maybe a, + _dfcMaxValue :: Maybe a, + _dfcWheelRate :: Maybe Double, + _dfcDragRate :: Maybe Double, + _dfcResizeOnChange :: Maybe Bool, + _dfcSelectOnFocus :: Maybe Bool, + _dfcOnFocusReq :: [Path -> WidgetRequest s e], + _dfcOnBlurReq :: [Path -> WidgetRequest s e], + _dfcOnChangeReq :: [a -> WidgetRequest s e] +} + +instance Default (DateFieldCfg s e a) where + def = DateFieldCfg { + _dfcCaretWidth = Nothing, + _dfcCaretMs = Nothing, + _dfcValid = Nothing, + _dfcValidV = [], + _dfcDateDelim = Nothing, + _dfcDateFormat = Nothing, + _dfcMinValue = Nothing, + _dfcMaxValue = Nothing, + _dfcWheelRate = Nothing, + _dfcDragRate = Nothing, + _dfcResizeOnChange = Nothing, + _dfcSelectOnFocus = Nothing, + _dfcOnFocusReq = [], + _dfcOnBlurReq = [], + _dfcOnChangeReq = [] + } + +instance Semigroup (DateFieldCfg s e a) where + (<>) t1 t2 = DateFieldCfg { + _dfcCaretWidth = _dfcCaretWidth t2 <|> _dfcCaretWidth t1, + _dfcCaretMs = _dfcCaretMs t2 <|> _dfcCaretMs t1, + _dfcValid = _dfcValid t2 <|> _dfcValid t1, + _dfcValidV = _dfcValidV t1 <> _dfcValidV t2, + _dfcDateDelim = _dfcDateDelim t2 <|> _dfcDateDelim t1, + _dfcDateFormat = _dfcDateFormat t2 <|> _dfcDateFormat t1, + _dfcMinValue = _dfcMinValue t2 <|> _dfcMinValue t1, + _dfcMaxValue = _dfcMaxValue t2 <|> _dfcMaxValue t1, + _dfcWheelRate = _dfcWheelRate t2 <|> _dfcWheelRate t1, + _dfcDragRate = _dfcDragRate t2 <|> _dfcDragRate t1, + _dfcResizeOnChange = _dfcResizeOnChange t2 <|> _dfcResizeOnChange t1, + _dfcSelectOnFocus = _dfcSelectOnFocus t2 <|> _dfcSelectOnFocus t1, + _dfcOnFocusReq = _dfcOnFocusReq t1 <> _dfcOnFocusReq t2, + _dfcOnBlurReq = _dfcOnBlurReq t1 <> _dfcOnBlurReq t2, + _dfcOnChangeReq = _dfcOnChangeReq t1 <> _dfcOnChangeReq t2 + } + +instance Monoid (DateFieldCfg s e a) where + mempty = def + +instance CmbCaretWidth (DateFieldCfg s e a) Double where + caretWidth w = def { + _dfcCaretWidth = Just w + } + +instance CmbCaretMs (DateFieldCfg s e a) Int where + caretMs ms = def { + _dfcCaretMs = Just ms + } + +instance CmbValidInput (DateFieldCfg s e a) s where + validInput field = def { + _dfcValid = Just (WidgetLens field) + } + +instance CmbValidInputV (DateFieldCfg s e a) e where + validInputV fn = def { + _dfcValidV = [fn] + } + +instance CmbResizeOnChange (DateFieldCfg s e a) where + resizeOnChange_ resize = def { + _dfcResizeOnChange = Just resize + } + +instance CmbSelectOnFocus (DateFieldCfg s e a) where + selectOnFocus_ sel = def { + _dfcSelectOnFocus = Just sel + } + +instance FormattableDate a => CmbMinValue (DateFieldCfg s e a) a where + minValue len = def { + _dfcMinValue = Just len + } + +instance FormattableDate a => CmbMaxValue (DateFieldCfg s e a) a where + maxValue len = def { + _dfcMaxValue = Just len + } + +instance CmbWheelRate (DateFieldCfg s e a) Double where + wheelRate rate = def { + _dfcWheelRate = Just rate + } + +instance CmbDragRate (DateFieldCfg s e a) Double where + dragRate rate = def { + _dfcDragRate = Just rate + } + +instance WidgetEvent e => CmbOnFocus (DateFieldCfg s e a) e Path where + onFocus fn = def { + _dfcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (DateFieldCfg s e a) s e Path where + onFocusReq req = def { + _dfcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (DateFieldCfg s e a) e Path where + onBlur fn = def { + _dfcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (DateFieldCfg s e a) s e Path where + onBlurReq req = def { + _dfcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (DateFieldCfg s e a) a e where + onChange fn = def { + _dfcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (DateFieldCfg s e a) s e a where + onChangeReq req = def { + _dfcOnChangeReq = [req] + } + +-- | Which character should be used to delimit dates. +dateFormatDelimiter :: Char -> DateFieldCfg s e a +dateFormatDelimiter delim = def { + _dfcDateDelim = Just delim +} + +-- | Date format DD/MM/YYYY, using the appropriate delimiter. +dateFormatDDMMYYYY :: DateFieldCfg s e a +dateFormatDDMMYYYY = def { + _dfcDateFormat = Just FormatDDMMYYYY +} + +-- | Date format MM/DD/YYYY, using the appropriate delimiter. +dateFormatMMDDYYYY :: DateFieldCfg s e a +dateFormatMMDDYYYY = def { + _dfcDateFormat = Just FormatMMDDYYYY +} + +-- | Date format YYYY/MM/DD, using the appropriate delimiter. +dateFormatYYYYMMDD :: DateFieldCfg s e a +dateFormatYYYYMMDD = def { + _dfcDateFormat = Just FormatYYYYMMDD +} + +-- | Creates a date field using the given lens. +dateField + :: (FormattableDate a, WidgetEvent e) + => ALens' s a -> WidgetNode s e +dateField field = dateField_ field def + +-- | Creates a date field using the given lens. Accepts config. +dateField_ + :: (FormattableDate a, WidgetEvent e) + => ALens' s a + -> [DateFieldCfg s e a] + -> WidgetNode s e +dateField_ field configs = widget where + widget = dateFieldD_ (WidgetLens field) configs + +-- | Creates a date field using the given value and onChange event handler. +dateFieldV + :: (FormattableDate a, WidgetEvent e) + => a -> (a -> e) -> WidgetNode s e +dateFieldV value handler = dateFieldV_ value handler def + +-- | Creates a date field using the given value and onChange event handler. +-- | Accepts config. +dateFieldV_ + :: (FormattableDate a, WidgetEvent e) + => a + -> (a -> e) + -> [DateFieldCfg s e a] + -> WidgetNode s e +dateFieldV_ value handler configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = dateFieldD_ widgetData newConfigs + +-- | Creates a date field providing a WidgetData instance and config. +dateFieldD_ + :: (FormattableDate a, WidgetEvent e) + => WidgetData s a + -> [DateFieldCfg s e a] + -> WidgetNode s e +dateFieldD_ widgetData configs = newNode where + config = mconcat configs + format = fromMaybe defaultDateFormat (_dfcDateFormat config) + delim = fromMaybe defaultDateDelim (_dfcDateDelim config) + minVal = _dfcMinValue config + maxVal = _dfcMaxValue config + + initialValue + | isJust minVal = fromJust minVal + | isJust maxVal = fromJust maxVal + | otherwise = dateFromDay (fromGregorian 1970 1 1) + + acceptText = dateAcceptText format delim minVal maxVal + acceptInput text = acceptText text ^. _1 + validInput text = acceptText text ^. _2 + fromText text = acceptText text ^. _3 + toText = dateToText format delim + + inputConfig = InputFieldCfg { + _ifcPlaceholder = Nothing, + _ifcInitialValue = initialValue, + _ifcValue = widgetData, + _ifcValid = _dfcValid config, + _ifcValidV = _dfcValidV config, + _ifcFromText = fromText, + _ifcToText = toText, + _ifcAcceptInput = acceptInput, + _ifcIsValidInput = validInput, + _ifcDefCursorEnd = True, + _ifcDefWidth = 160, + _ifcCaretWidth = _dfcCaretWidth config, + _ifcCaretMs = _dfcCaretMs config, + _ifcDisplayChar = Nothing, + _ifcResizeOnChange = fromMaybe False (_dfcResizeOnChange config), + _ifcSelectOnFocus = fromMaybe True (_dfcSelectOnFocus config), + _ifcStyle = Just L.dateFieldStyle, + _ifcWheelHandler = Just (handleWheel config), + _ifcDragHandler = Just (handleDrag config), + _ifcDragCursor = Just CursorSizeV, + _ifcOnFocusReq = _dfcOnFocusReq config, + _ifcOnBlurReq = _dfcOnBlurReq config, + _ifcOnChangeReq = _dfcOnChangeReq config + } + newNode = inputField_ "dateField" inputConfig + +handleWheel + :: FormattableDate a + => DateFieldCfg s e a + -> InputFieldState a + -> Point + -> Point + -> WheelDirection + -> (Text, Int, Maybe Int) +handleWheel config state point move dir = result where + Point _ dy = move + sign = if dir == WheelNormal then 1 else -1 + curValue = _ifsCurrValue state + wheelRate = fromMaybe 1 (_dfcWheelRate config) + result = handleMove config state wheelRate curValue (dy * sign) + +handleDrag + :: FormattableDate a + => DateFieldCfg s e a + -> InputFieldState a + -> Point + -> Point + -> (Text, Int, Maybe Int) +handleDrag config state clickPos currPos = result where + Point _ dy = subPoint clickPos currPos + selValue = _ifsDragSelValue state + dragRate = fromMaybe 1 (_dfcDragRate config) + result = handleMove config state dragRate selValue dy + +handleMove + :: FormattableDate a + => DateFieldCfg s e a + -> InputFieldState a + -> Double + -> a + -> Double + -> (Text, Int, Maybe Int) +handleMove config state rate value dy = result where + format = fromMaybe defaultDateFormat (_dfcDateFormat config) + delim = fromMaybe defaultDateDelim (_dfcDateDelim config) + minVal = _dfcMinValue config + maxVal = _dfcMaxValue config + + acceptText = dateAcceptText format delim minVal maxVal + fromText text = acceptText text ^. _3 + toText = dateToText format delim + + (valid, mParsedVal, parsedVal) = case dateToDay value of + Just val -> (True, mParsedVal, parsedVal) where + tmpValue = addDays (round (dy * rate)) val + mParsedVal = fromText (toText (dateFromDay tmpValue)) + parsedVal = fromJust mParsedVal + Nothing -> (False, Nothing, undefined) + newVal + | isJust mParsedVal = parsedVal + | valid && dy > 0 && isJust maxVal = fromJust maxVal + | valid && dy < 0 && isJust minVal = fromJust minVal + | otherwise = _ifsCurrValue state + + newText = toText newVal + newPos = _ifsCursorPos state + newSel = _ifsSelStart state + result = (newText, newPos, newSel) + +dateFromTextSimple + :: (DayConverter a, FormattableDate a) + => DateFormat + -> Char + -> Text + -> Maybe a +dateFromTextSimple format delim text = newDate where + compParser = A.char delim *> A.decimal + dateParser = (,,) <$> A.decimal <*> compParser <*> compParser + tmpDate = case A.parseOnly dateParser text of + Left _ -> Nothing + Right (n1, n2, n3) + | format == FormatDDMMYYYY -> fromGregorianValid (fromIntegral n3) n2 n1 + | format == FormatMMDDYYYY -> fromGregorianValid (fromIntegral n3) n1 n2 + | otherwise -> fromGregorianValid (fromIntegral n1) n2 n3 + newDate = tmpDate >>= dateFromDay + +dateToTextSimple :: FormattableDate a => DateFormat -> Char -> a -> Text +dateToTextSimple format delim val = result where + converted = dateToDay val + (year, month, day) = toGregorian (fromJust converted) + sep = T.singleton delim + padd num + | num < 10 = "0" <> T.pack (show num) + | otherwise = T.pack (show num) + tday = padd day + tmonth = padd month + tyear = T.pack (show year) + result + | isNothing converted = "" + | format == FormatDDMMYYYY = tday <> sep <> tmonth <> sep <> tyear + | format == FormatMMDDYYYY = tmonth <> sep <> tday <> sep <> tyear + | otherwise = tyear <> sep <> tmonth <> sep <> tday + +acceptTextInput :: DateFormat -> Char -> Text -> Bool +acceptTextInput format delim text = isRight (A.parseOnly parser text) where + numP = A.digit *> "" + delimP = A.char delim *> "" + dayP = P.upto 2 numP + monthP = P.upto 2 numP + yearP = P.upto 4 numP + withDelim parser = A.option "" (delimP *> parser) + parsers + | format == FormatDDMMYYYY = [dayP, withDelim monthP, withDelim yearP] + | format == FormatMMDDYYYY = [monthP, withDelim dayP, withDelim yearP] + | otherwise = [yearP, withDelim monthP, withDelim dayP] + parser = P.join parsers <* A.endOfInput + +dateInBounds :: (Ord a) => Maybe a -> Maybe a -> a -> Bool +dateInBounds Nothing Nothing _ = True +dateInBounds (Just minVal) Nothing val = val >= minVal +dateInBounds Nothing (Just maxVal) val = val <= maxVal +dateInBounds (Just minVal) (Just maxVal) val = val >= minVal && val <= maxVal diff --git a/src/Monomer/Widgets/Singles/Dial.hs b/src/Monomer/Widgets/Singles/Dial.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Dial.hs @@ -0,0 +1,398 @@ +{-| +Module : Monomer.Widgets.Singles.Dial +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +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. + +Similar in objective to Slider, but uses less space. + +Configs: + +- width: sets the max width/height of the dial. +- wheelRate: The rate at which wheel movement affects the number. +- dragRate: The rate at which drag movement affects the number. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes. +- onChangeReq: WidgetRequest to generate when the value changes. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Singles.Dial ( + dial, + dial_, + dialV, + dialV_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~), (<>~)) +import Control.Monad +import Data.Default +import Data.Maybe +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Helper +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +type DialValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a) + +-- | Configuration options for dial widget. +data DialCfg s e a = DialCfg { + _dlcWidth :: Maybe Double, + _dlcWheelRate :: Maybe Rational, + _dlcDragRate :: Maybe Rational, + _dlcOnFocusReq :: [Path -> WidgetRequest s e], + _dlcOnBlurReq :: [Path -> WidgetRequest s e], + _dlcOnChangeReq :: [a -> WidgetRequest s e] +} + +instance Default (DialCfg s e a) where + def = DialCfg { + _dlcWidth = Nothing, + _dlcWheelRate = Nothing, + _dlcDragRate = Nothing, + _dlcOnFocusReq = [], + _dlcOnBlurReq = [], + _dlcOnChangeReq = [] + } + +instance Semigroup (DialCfg s e a) where + (<>) t1 t2 = DialCfg { + _dlcWidth = _dlcWidth t2 <|> _dlcWidth t1, + _dlcWheelRate = _dlcWheelRate t2 <|> _dlcWheelRate t1, + _dlcDragRate = _dlcDragRate t2 <|> _dlcDragRate t1, + _dlcOnFocusReq = _dlcOnFocusReq t1 <> _dlcOnFocusReq t2, + _dlcOnBlurReq = _dlcOnBlurReq t1 <> _dlcOnBlurReq t2, + _dlcOnChangeReq = _dlcOnChangeReq t1 <> _dlcOnChangeReq t2 + } + +instance Monoid (DialCfg s e a) where + mempty = def + +instance CmbWheelRate (DialCfg s e a) Rational where + wheelRate rate = def { + _dlcWheelRate = Just rate + } + +instance CmbDragRate (DialCfg s e a) Rational where + dragRate rate = def { + _dlcDragRate = Just rate + } + +instance CmbWidth (DialCfg s e a) where + width w = def { + _dlcWidth = Just w + } + +instance WidgetEvent e => CmbOnFocus (DialCfg s e a) e Path where + onFocus fn = def { + _dlcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (DialCfg s e a) s e Path where + onFocusReq req = def { + _dlcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (DialCfg s e a) e Path where + onBlur fn = def { + _dlcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (DialCfg s e a) s e Path where + onBlurReq req = def { + _dlcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (DialCfg s e a) a e where + onChange fn = def { + _dlcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (DialCfg s e a) s e a where + onChangeReq req = def { + _dlcOnChangeReq = [req] + } + +data DialState = DialState { + _dlsMaxPos :: Integer, + _dlsPos :: Integer +} deriving (Eq, Show, Generic) + +-- | Creates a dial using the given lens, providing minimum and maximum values. +dial + :: (DialValue a, WidgetEvent e) + => ALens' s a + -> a + -> a + -> WidgetNode s e +dial field minVal maxVal = dial_ field minVal maxVal def + +{-| +Creates a dial using the given lens, providing minimum and maximum values. +Accepts config. +-} +dial_ + :: (DialValue a, WidgetEvent e) + => ALens' s a + -> a + -> a + -> [DialCfg s e a] + -> WidgetNode s e +dial_ field minVal maxVal cfgs = dialD_ (WidgetLens field) minVal maxVal cfgs + +{-| +Creates a dial using the given value and onChange event handler, providing +minimum and maximum values. +-} +dialV + :: (DialValue a, WidgetEvent e) + => a + -> (a -> e) + -> a + -> a + -> WidgetNode s e +dialV value handler minVal maxVal = dialV_ value handler minVal maxVal def + +{-| +Creates a dial using the given value and onChange event handler, providing +minimum and maximum values. +Accepts config. +-} +dialV_ + :: (DialValue a, WidgetEvent e) + => a + -> (a -> e) + -> a + -> a + -> [DialCfg s e a] + -> WidgetNode s e +dialV_ value handler minVal maxVal configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = dialD_ widgetData minVal maxVal newConfigs + +{-| +Creates a dial providing a WidgetData instance, minimum and maximum values and +config. +-} +dialD_ + :: (DialValue a, WidgetEvent e) + => WidgetData s a + -> a + -> a + -> [DialCfg s e a] + -> WidgetNode s e +dialD_ widgetData minVal maxVal configs = dialNode where + config = mconcat configs + state = DialState 0 0 + widget = makeDial widgetData minVal maxVal config state + dialNode = defaultWidgetNode "dial" widget + & L.info . L.focusable .~ True + +makeDial + :: (DialValue a, WidgetEvent e) + => WidgetData s a + -> a + -> a + -> DialCfg s e a + -> DialState + -> Widget s e +makeDial field minVal maxVal config state = widget where + widget = createSingle state def { + singleFocusOnBtnPressed = False, + singleGetBaseStyle = getBaseStyle, + singleGetCurrentStyle = getCurrentStyle, + singleInit = init, + singleMerge = merge, + singleFindByPoint = findByPoint, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + dragRate + | isJust (_dlcDragRate config) = fromJust (_dlcDragRate config) + | otherwise = toRational (maxVal - minVal) / 1000 + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.dialStyle + + getCurrentStyle wenv node = style where + (_, dialArea) = getDialInfo wenv node config + style = currentStyle_ (currentStyleConfig dialArea) wenv node + + init wenv node = resultNode resNode where + newState = newStateFromModel wenv node state + resNode = node + & L.widget .~ makeDial field minVal maxVal config newState + + merge wenv newNode oldNode oldState = resultNode resNode where + newState + | isNodePressed wenv newNode = oldState + | otherwise = newStateFromModel wenv newNode oldState + resNode = newNode + & L.widget .~ makeDial field minVal maxVal config newState + + findByPoint wenv node path point + | isVisible && pointInEllipse point dialArea = Just wni + | otherwise = Nothing + where + isVisible = node ^. L.info . L.visible + wni = node ^. L.info + (_, dialArea) = getDialInfo wenv node config + + handleEvent wenv node target evt = case evt of + Focus prev -> handleFocusChange node prev (_dlcOnFocusReq config) + + Blur next -> handleFocusChange node next (_dlcOnBlurReq config) + + KeyAction mod code KeyPressed + | ctrlPressed && isKeyUp code -> handleNewPos (pos + warpSpeed) + | ctrlPressed && isKeyDown code -> handleNewPos (pos - warpSpeed) + | shiftPressed && isKeyUp code -> handleNewPos (pos + baseSpeed) + | shiftPressed && isKeyDown code -> handleNewPos (pos - baseSpeed) + | isKeyUp code -> handleNewPos (pos + fastSpeed) + | isKeyDown code -> handleNewPos (pos - fastSpeed) + where + DialState maxPos pos = state + ctrlPressed = isShortCutControl wenv mod + baseSpeed = max 1 $ round (fromIntegral maxPos / 1000) + fastSpeed = max 1 $ round (fromIntegral maxPos / 100) + warpSpeed = max 1 $ round (fromIntegral maxPos / 10) + vPos pos = clamp 0 maxPos pos + newResult newPos = addReqsEvts (resultNode newNode) newVal where + newVal = valueFromPos minVal dragRate newPos + newState = state { _dlsPos = newPos } + newNode = node + & L.widget .~ makeDial field minVal maxVal config newState + handleNewPos newPos + | vPos newPos /= pos = Just $ newResult (vPos newPos) + | otherwise = Nothing + + Move point + | isNodePressed wenv node -> Just result where + (_, start) = fromJust $ wenv ^. L.mainBtnPress + (_, newVal) = posFromPoint minVal maxVal state dragRate start point + result = addReqsEvts (resultReqs node [RenderOnce]) newVal + + ButtonAction point btn BtnPressed clicks + | not (isNodeFocused wenv node) && not shiftPressed -> Just result where + result = resultReqs node [SetFocus widgetId] + + ButtonAction point btn BtnReleased clicks -> Just result where + reqs = [RenderOnce] + newState = newStateFromModel wenv node state + newNode = node + & L.widget .~ makeDial field minVal maxVal config newState + result = resultReqs newNode reqs + + WheelScroll _ (Point _ wy) wheelDirection -> Just result where + DialState maxPos pos = state + wheelCfg = fromMaybe (theme ^. L.sliderWheelRate) (_dlcWheelRate config) + wheelRate = fromRational wheelCfg + tmpPos = pos + round (wy * wheelRate) + newPos = clamp 0 maxPos tmpPos + newVal = valueFromPos minVal dragRate newPos + result = addReqsEvts (resultReqs node [RenderOnce]) newVal + _ -> Nothing + where + theme = currentTheme wenv node + (_, dialArea) = getDialInfo wenv node config + widgetId = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + + shiftPressed = wenv ^. L.inputStatus . L.keyMod . L.leftShift + isSelectKey code = isKeyReturn code || isKeySpace code + addReqsEvts result newVal = newResult where + currVal = widgetDataGet (wenv ^. L.model) field + reqs = widgetDataSet field newVal + ++ fmap ($ newVal) (_dlcOnChangeReq config) + newResult + | currVal /= newVal = result + & L.requests <>~ Seq.fromList reqs + | otherwise = result + + getSizeReq wenv node = req where + theme = currentTheme wenv node + width = fromMaybe (theme ^. L.dialWidth) (_dlcWidth config) + req = (fixedSize width, fixedSize width) + + render wenv node renderer = do + drawArcBorder renderer dialArea start endSnd CW (Just sndColor) dialBW + drawArcBorder renderer dialArea start endFg CW (Just fgColor) dialBW + where + (dialCenter, dialArea) = getDialInfo wenv node config + DialState maxPos pos = newStateFromModel wenv node state + posPct = fromIntegral pos / fromIntegral maxPos + dialBW = max 1 (_rW dialArea * 0.15) + style = getCurrentStyle wenv node + fgColor = styleFgColor style + sndColor = styleSndColor style + start = 90 + 45 + endFg = start + 270 * posPct + endSnd = 45 + + newStateFromModel wenv node oldState = newState where + currVal = widgetDataGet (wenv ^. L.model) field + newMaxPos = round (toRational (maxVal - minVal) / dragRate) + newPos = round (toRational (currVal - minVal) / dragRate) + newState = oldState { + _dlsMaxPos = newMaxPos, + _dlsPos = newPos + } + +posFromPoint + :: DialValue a + => a + -> a + -> DialState + -> Rational + -> Point + -> Point + -> (Integer, a) +posFromPoint minVal maxVal state dragRate stPoint point = (newPos, newVal) where + DialState maxPos pos = state + Point _ dy = subPoint stPoint point + tmpPos = pos + round dy + newPos = clamp 0 maxPos tmpPos + newVal = valueFromPos minVal dragRate newPos + +valueFromPos :: DialValue a => a -> Rational -> Integer -> a +valueFromPos minVal dragRate newPos = newVal where + newVal = minVal + fromFractional (dragRate * fromIntegral newPos) + +getDialInfo :: WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect) +getDialInfo wenv node config = (dialCenter, dialArea) where + theme = currentTheme wenv node + style = currentStyle wenv node + carea = getContentArea node style + + dialW = fromMaybe (theme ^. L.dialWidth) (_dlcWidth config) + dialL = _rX carea + (_rW carea - dialW) / 2 + dialT = _rY carea + (_rH carea - dialW) / 2 + dialCenter = Point (dialL + dialW / 2) (dialT + dialW / 2) + dialArea = Rect dialL dialT dialW dialW + +currentStyleConfig :: Rect -> CurrentStyleCfg s e +currentStyleConfig dialArea = def + & L.isHovered .~ isNodeHoveredEllipse_ dialArea diff --git a/src/Monomer/Widgets/Singles/ExternalLink.hs b/src/Monomer/Widgets/Singles/ExternalLink.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/ExternalLink.hs @@ -0,0 +1,233 @@ +{-| +Module : Monomer.Widgets.Singles.ExternalLink +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +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. + +Configs: + +- 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. +- maxLines: maximum number of text lines to show. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onClick: event to raise when button is clicked. +- onClickReq: WidgetRequest to generate when button is clicked. +- resizeFactor: flexibility to have more or less spaced assigned. +- resizeFactorW: flexibility to have more or less horizontal spaced assigned. +- resizeFactorH: flexibility to have more or less vertical spaced assigned. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.ExternalLink ( + externalLink, + externalLink_ +) where + +import Control.Applicative ((<|>)) +import Control.Exception (SomeException, catch) +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.Maybe +import Data.Text (Text) +import System.Process (callCommand) + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Widgets.Container +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data ExternalLinkCfg s e = ExternalLinkCfg { + _elcLabelCfg :: LabelCfg s e, + _elcOnFocusReq :: [Path -> WidgetRequest s e], + _elcOnBlurReq :: [Path -> WidgetRequest s e] +} + +instance Default (ExternalLinkCfg s e) where + def = ExternalLinkCfg { + _elcLabelCfg = def, + _elcOnFocusReq = [], + _elcOnBlurReq = [] + } + +instance Semigroup (ExternalLinkCfg s e) where + (<>) t1 t2 = ExternalLinkCfg { + _elcLabelCfg = _elcLabelCfg t1 <> _elcLabelCfg t2, + _elcOnFocusReq = _elcOnFocusReq t1 <> _elcOnFocusReq t2, + _elcOnBlurReq = _elcOnBlurReq t1 <> _elcOnBlurReq t2 + } + +instance Monoid (ExternalLinkCfg s e) where + mempty = def + +instance CmbTrimSpaces (ExternalLinkCfg s e) where + trimSpaces_ trim = def { + _elcLabelCfg = trimSpaces_ trim + } + +instance CmbEllipsis (ExternalLinkCfg s e) where + ellipsis_ ellipsis = def { + _elcLabelCfg = ellipsis_ ellipsis + } + +instance CmbMultiline (ExternalLinkCfg s e) where + multiline_ multi = def { + _elcLabelCfg = multiline_ multi + } + +instance CmbMaxLines (ExternalLinkCfg s e) where + maxLines count = def { + _elcLabelCfg = maxLines count + } + +instance CmbResizeFactor (ExternalLinkCfg s e) where + resizeFactor s = def { + _elcLabelCfg = resizeFactor s + } + +instance CmbResizeFactorDim (ExternalLinkCfg s e) where + resizeFactorW w = def { + _elcLabelCfg = resizeFactorW w + } + resizeFactorH h = def { + _elcLabelCfg = resizeFactorH h + } + +instance WidgetEvent e => CmbOnFocus (ExternalLinkCfg s e) e Path where + onFocus fn = def { + _elcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (ExternalLinkCfg s e) s e Path where + onFocusReq req = def { + _elcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (ExternalLinkCfg s e) e Path where + onBlur fn = def { + _elcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (ExternalLinkCfg s e) s e Path where + onBlurReq req = def { + _elcOnBlurReq = [req] + } + +-- | Creates an external link with the given caption and url. +externalLink :: WidgetEvent e => Text -> Text -> WidgetNode s e +externalLink caption url = externalLink_ caption url def + +-- | Creates an external link with the given caption and url. Accepts config. +externalLink_ + :: WidgetEvent e => Text -> Text -> [ExternalLinkCfg s e] -> WidgetNode s e +externalLink_ caption url configs = externalLinkNode where + config = mconcat configs + widget = makeExternalLink caption url config + externalLinkNode = defaultWidgetNode "externalLink" widget + & L.info . L.focusable .~ True + +makeExternalLink + :: WidgetEvent e => Text -> Text -> ExternalLinkCfg s e -> Widget s e +makeExternalLink caption url config = widget where + widget = createContainer () def { + containerAddStyleReq = False, + containerUseScissor = True, + containerGetBaseStyle = getBaseStyle, + containerInit = init, + containerMerge = merge, + containerHandleEvent = handleEvent, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.externalLinkStyle + + createChildNode wenv node = newNode where + nodeStyle = node ^. L.info . L.style + labelCfg = (_elcLabelCfg config) { + _lscCurrentStyle = Just childOfFocusedStyle + } + labelNode = label_ caption [ignoreTheme, labelCfg] + & L.info . L.style .~ nodeStyle + childNode = labelNode + newNode = node + & L.children .~ Seq.singleton childNode + + init wenv node = result where + result = resultNode (createChildNode wenv node) + + merge wenv node oldNode oldState = result where + result = resultNode (createChildNode wenv node) + + handleEvent wenv node target evt = case evt of + Focus prev -> handleFocusChange node prev (_elcOnFocusReq config) + + Blur next -> handleFocusChange node next (_elcOnBlurReq config) + + KeyAction mode code status + | isSelectKey code && status == KeyPressed -> Just result + where + isSelectKey code = isKeyReturn code || isKeySpace code + + Click p _ _ + | isPointInNodeVp node p -> Just result + + ButtonAction p btn BtnPressed 1 -- Set focus on click + | mainBtn btn && pointInVp p && not focused -> Just resultFocus + + ButtonAction p btn BtnReleased clicks + | mainBtn btn && focused && pointInVp p && clicks > 1 -> Just result + _ -> Nothing + where + widgetId = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + mainBtn btn = btn == wenv ^. L.mainButton + + focused = isNodeFocused wenv node + pointInVp p = isPointInNodeVp node p + openLinkTask = openLink wenv (T.unpack url) + + requests = [RunTask widgetId path openLinkTask] + result = resultReqs node requests + resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)] + + getSizeReq :: ContainerGetSizeReqHandler s e + getSizeReq wenv node children = (newReqW, newReqH) where + -- Main section reqs + child = Seq.index children 0 + newReqW = child ^. L.info . L.sizeReqW + newReqH = child ^. L.info . L.sizeReqH + + resize wenv node viewport children = resized where + assignedAreas = Seq.fromList [viewport] + resized = (resultNode node, assignedAreas) + +openLink :: WidgetEnv s e -> String -> IO () +openLink wenv url = catchIgnore (callCommand openCommand) where + os = wenv ^. L.os + command + | os == "Windows" = "start" + | os == "Mac OS X" = "open" + | os == "Linux" = "xdg-open" + | otherwise = "ls" + openCommand = command ++ " \"" ++ url ++ "\"" + +catchIgnore :: IO () -> IO () +catchIgnore task = catchAny task (const $ return ()) + +catchAny :: IO a -> (SomeException -> IO a) -> IO a +catchAny = catch diff --git a/src/Monomer/Widgets/Singles/Icon.hs b/src/Monomer/Widgets/Singles/Icon.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Icon.hs @@ -0,0 +1,131 @@ +{-| +Module : Monomer.Widgets.Singles.Icon +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Icon widget. Used for showing some standard icos without the need of an asset. + +Configs: + +- width: the maximum width and height of the icon. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.Icon ( + IconType(..), + icon, + icon_ +) where + +import Control.Lens ((^.)) +import Control.Applicative ((<|>)) +import Data.Default +import Data.Maybe + +import qualified Data.Text as T + +import Monomer.Graphics.Util + +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +-- | Different types of icons that can be displayed. +data IconType + = IconClose + | IconPlus + | IconMinus + deriving (Eq, Show) + +-- | Configuration options for icon widget. +newtype IconCfg = IconCfg { + _icWidth :: Maybe Double +} + +instance Default IconCfg where + def = IconCfg { + _icWidth = Nothing + } + +instance Semigroup IconCfg where + (<>) i1 i2 = IconCfg { + _icWidth = _icWidth i2 <|> _icWidth i1 + } + +instance Monoid IconCfg where + mempty = def + +instance CmbWidth IconCfg where + width w = def { + _icWidth = Just w + } + +-- | Creates an icon of the given type. +icon :: IconType -> WidgetNode s e +icon iconType = icon_ iconType def + +-- | Creates an icon of the given type. Accepts config. +icon_ :: IconType -> [IconCfg] -> WidgetNode s e +icon_ iconType configs = defaultWidgetNode widgetType widget where + iconName = T.pack $ show iconType + widgetType = WidgetType ("i" <> T.tail iconName) + config = mconcat configs + widget = makeImage iconType config + +makeImage :: IconType -> IconCfg -> Widget s e +makeImage iconType config = widget where + widget = createSingle () def { + singleGetSizeReq = getSizeReq, + singleRender = render + } + + getSizeReq wenv node = sizeReq where + (w, h) = (16, 16) + factor = 1 + sizeReq = (minSize w factor, minSize h factor) + + render wenv node renderer = do + drawIcon renderer style iconType iconVp width + where + style = currentStyle wenv node + contentArea = getContentArea node style + vp = node ^. L.info . L.viewport + dim = min (vp ^. L.w) (vp ^. L.h) + width = fromMaybe (dim / 2) (_icWidth config) + iconVp = centeredSquare contentArea + +centeredSquare :: Rect -> Rect +centeredSquare (Rect x y w h) = Rect newX newY dim dim where + dim = min w h + newX = x + (w - dim) / 2 + newY = y + (h - dim) / 2 + +drawIcon :: Renderer -> StyleState -> IconType -> Rect -> Double -> IO () +drawIcon renderer style iconType viewport lw = case iconType of + IconClose -> + drawTimesX renderer viewport lw (Just fgColor) + + IconPlus -> do + beginPath renderer + setFillColor renderer fgColor + renderRect renderer (Rect (cx - hw) y lw h) + renderRect renderer (Rect x (cy - hw) w lw) + fill renderer + + IconMinus -> do + beginPath renderer + setFillColor renderer fgColor + renderRect renderer (Rect x (cy - hw) w lw) + fill renderer + where + Rect x y w h = viewport + fgColor = fromMaybe (rgb 0 0 0) (style ^. L.fgColor) + hw = lw / 2 + cx = x + w / 2 + cy = y + h / 2 + mx = x + w + my = y + h diff --git a/src/Monomer/Widgets/Singles/Image.hs b/src/Monomer/Widgets/Singles/Image.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Image.hs @@ -0,0 +1,545 @@ +{-| +Module : Monomer.Widgets.Singles.Image +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Displays an image from local storage or a url. + +Notes: + +- Depending on the type of image fit chosen and the assigned viewport, some + space may remain unused. The alignment options exist to handle this situation. +- If you choose `fitNone`, `imageRepeatX` and `imageRepeatY` won't have any kind + of effect. + +Configs: + +- transparency: the alpha to apply when rendering the image. +- onLoadError: an event to report a load error. +- imageNearest: apply nearest filtering when stretching an image. +- imageRepeatX: repeat the image across the x coordinate. +- imageRepeatY: repeat the image across the y coordinate. +- fitNone: does not perform any streching if the size does not match viewport. +- fitFill: stretches the image to match the viewport. +- fitWidth: stretches the image to match the viewport width. Maintains ratio. +- fitHeight: stretches the image to match the viewport height. Maintains ratio. +- alignLeft: aligns left if extra space is available. +- alignRight: aligns right if extra space is available. +- alignCenter: aligns center if extra space is available. +- alignTop: aligns top if extra space is available. +- alignMiddle: aligns middle if extra space is available. +- alignBottom: aligns bottom if extra space is available. +-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Singles.Image ( + ImageLoadError(..), + image, + image_, + imageMem, + imageMem_ +) where + +import Codec.Picture (DynamicImage, Image(..)) +import Control.Applicative ((<|>)) +import Control.Concurrent +import Control.Exception (try) +import Control.Lens ((&), (^.), (.~), (%~), (?~), at) +import Control.Monad (when) +import Data.ByteString (ByteString) +import Data.Char (toLower) +import Data.Default +import Data.Map (Map) +import Data.Maybe +import Data.List (isPrefixOf) +import Data.Text (Text) +import Data.Typeable (cast) +import Data.Vector.Storable.ByteString (vectorToByteString) +import GHC.Generics +import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) +import Network.Wreq + +import qualified Codec.Picture as Pic +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Network.Wreq as Wreq + +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +data ImageFit + = FitNone + | FitFill + | FitWidth + | FitHeight + deriving (Eq, Show) + +-- | Posible errors when loading an image. +data ImageLoadError + = ImageLoadFailed String + | ImageInvalid String + deriving (Eq, Show) + +-- | Configuration options for image widget. +data ImageCfg e = ImageCfg { + _imcLoadError :: [ImageLoadError -> e], + _imcFlags :: [ImageFlag], + _imcFit :: Maybe ImageFit, + _imcTransparency :: Maybe Double, + _imcAlignH :: Maybe AlignH, + _imcAlignV :: Maybe AlignV, + _imcFactorW :: Maybe Double, + _imcFactorH :: Maybe Double +} + +instance Default (ImageCfg e) where + def = ImageCfg { + _imcLoadError = [], + _imcFlags = [], + _imcFit = Nothing, + _imcTransparency = Nothing, + _imcAlignH = Nothing, + _imcAlignV = Nothing, + _imcFactorW = Nothing, + _imcFactorH = Nothing + } + +instance Semigroup (ImageCfg e) where + (<>) i1 i2 = ImageCfg { + _imcLoadError = _imcLoadError i1 ++ _imcLoadError i2, + _imcFlags = _imcFlags i1 ++ _imcFlags i2, + _imcFit = _imcFit i2 <|> _imcFit i1, + _imcTransparency = _imcTransparency i2 <|> _imcTransparency i1, + _imcAlignH = _imcAlignH i2 <|> _imcAlignH i1, + _imcAlignV = _imcAlignV i2 <|> _imcAlignV i1, + _imcFactorW = _imcFactorW i2 <|> _imcFactorW i1, + _imcFactorH = _imcFactorH i2 <|> _imcFactorH i1 + } + +instance Monoid (ImageCfg e) where + mempty = def + +instance CmbOnLoadError (ImageCfg e) e ImageLoadError where + onLoadError err = def { + _imcLoadError = [err] + } + +instance CmbImageNearest (ImageCfg e) where + imageNearest = def { + _imcFlags = [ImageNearest] + } + +instance CmbImageRepeatX (ImageCfg e) where + imageRepeatX = def { + _imcFlags = [ImageRepeatX] + } + +instance CmbImageRepeatY (ImageCfg e) where + imageRepeatY = def { + _imcFlags = [ImageRepeatY] + } + +instance CmbFitNone (ImageCfg e) where + fitNone = def { + _imcFit = Just FitNone + } + +instance CmbFitFill (ImageCfg e) where + fitFill = def { + _imcFit = Just FitFill + } + +instance CmbFitWidth (ImageCfg e) where + fitWidth = def { + _imcFit = Just FitWidth + } + +instance CmbFitHeight (ImageCfg e) where + fitHeight = def { + _imcFit = Just FitHeight + } + +instance CmbTransparency (ImageCfg e) where + transparency alpha = def { + _imcTransparency = Just alpha + } + +instance CmbAlignLeft (ImageCfg e) where + alignLeft_ False = def + alignLeft_ True = def { + _imcAlignH = Just ALeft + } + +instance CmbAlignCenter (ImageCfg e) where + alignCenter_ False = def + alignCenter_ True = def { + _imcAlignH = Just ACenter + } + +instance CmbAlignRight (ImageCfg e) where + alignRight_ False = def + alignRight_ True = def { + _imcAlignH = Just ARight + } + +instance CmbAlignTop (ImageCfg e) where + alignTop_ False = def + alignTop_ True = def { + _imcAlignV = Just ATop + } + +instance CmbAlignMiddle (ImageCfg e) where + alignMiddle_ False = def + alignMiddle_ True = def { + _imcAlignV = Just AMiddle + } + +instance CmbAlignBottom (ImageCfg e) where + alignBottom_ False = def + alignBottom_ True = def { + _imcAlignV = Just ABottom + } + +instance CmbResizeFactor (ImageCfg e) where + resizeFactor s = def { + _imcFactorW = Just s, + _imcFactorH = Just s + } + +instance CmbResizeFactorDim (ImageCfg e) where + resizeFactorW w = def { + _imcFactorW = Just w + } + resizeFactorH h = def { + _imcFactorH = Just h + } + +data ImageSource + = ImageMem Text + | ImagePath Text + deriving (Eq, Show) + +data ImageState = ImageState { + isImageSource :: ImageSource, + isImageData :: Maybe (ByteString, Size) +} deriving (Eq, Show, Generic) + +data ImageMessage + = ImageLoaded ImageState + | ImageFailed ImageLoadError + +-- | Creates an image with the given local path or url. +image :: WidgetEvent e => Text -> WidgetNode s e +image path = image_ path def + +-- | Creates an image with the given local path or url. Accepts config. +image_ :: WidgetEvent e => Text -> [ImageCfg e] -> WidgetNode s e +image_ path configs = defaultWidgetNode "image" widget where + config = mconcat configs + source = ImagePath path + imageState = ImageState source Nothing + widget = makeImage source config imageState + +-- | Creates an image with the given binary data. +imageMem + :: WidgetEvent e + => Text -- ^ The logical name of the image. + -> ByteString -- ^ The image data as 4-byte RGBA blocks. + -> Size -- ^ The size of the image. + -> WidgetNode s e -- ^ The created image widget. +imageMem name imgData imgSize = imageMem_ name imgData imgSize def + +-- | Creates an image with the given binary data. Accepts config. +imageMem_ + :: WidgetEvent e + => Text -- ^ The logical name of the image. + -> ByteString -- ^ The image data as 4-byte RGBA blocks. + -> Size -- ^ The size of the image. + -> [ImageCfg e] -- ^ The configuration of the image. + -> WidgetNode s e -- ^ The created image widget. +imageMem_ name imgData imgSize configs = defaultWidgetNode "image" widget where + config = mconcat configs + source = ImageMem name + imageState = ImageState source (Just (imgData, imgSize)) + widget = makeImage source config imageState + +makeImage + :: WidgetEvent e => ImageSource -> ImageCfg e -> ImageState -> Widget s e +makeImage imgSource config state = widget where + widget = createSingle state def { + singleUseScissor = True, + singleInit = init, + singleMerge = merge, + singleDispose = dispose, + singleHandleMessage = handleMessage, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + isImageMem = case imgSource of + ImageMem{} -> True + _ -> False + + imgName source = case source of + ImageMem path -> path + ImagePath path -> path + + init wenv node = result where + wid = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + imgPath = imgName imgSource + + reqs = [RunTask wid path $ handleImageLoad config wenv imgPath] + result = case imgSource of + ImageMem _ -> resultNode node + ImagePath _ -> resultReqs node reqs + + merge wenv newNode oldNode oldState = result where + wid = newNode ^. L.info . L.widgetId + path = newNode ^. L.info . L.path + oldSource = isImageSource oldState + imgPath = imgName imgSource + prevPath = imgName oldSource + + sameImgNode = newNode + & L.widget .~ makeImage imgSource config oldState + newMemReqs = [ RemoveRendererImage prevPath ] + newImgReqs = [ + RemoveRendererImage prevPath, + RunTask wid path (handleImageLoad config wenv imgPath) + ] + result + | oldSource == imgSource = resultNode sameImgNode + | isImageMem = resultReqs newNode newMemReqs + | otherwise = resultReqs newNode newImgReqs + + dispose wenv node = resultReqs node reqs where + wid = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + imgPath = imgName imgSource + reqs = [ + RemoveRendererImage imgPath, + RunTask wid path (handleImageDispose wenv imgPath) + ] + + handleMessage wenv node target message = result where + result = cast message >>= useImage node + + useImage node (ImageFailed msg) = result where + evts = fmap ($ msg) (_imcLoadError config) + result = Just $ resultEvts node evts + useImage node (ImageLoaded newState) = result where + widgetId = node ^. L.info . L.widgetId + newNode = node + & L.widget .~ makeImage imgSource config newState + result = Just $ resultReqs newNode [ResizeWidgets widgetId] + + getSizeReq wenv node = (sizeW, sizeH) where + Size w h = maybe def snd (isImageData state) + factorW = fromMaybe 1 (_imcFactorW config) + factorH = fromMaybe 1 (_imcFactorH config) + + sizeW + | abs factorW < 0.01 = fixedSize w + | otherwise = expandSize w factorW + sizeH + | abs factorH < 0.01 = fixedSize h + | otherwise = expandSize h factorH + + render wenv node renderer = do + imageDef <- getImage renderer imgPath + + when (imageLoaded && isNothing imageDef) $ + addImage renderer imgPath imgSize imgBytes imgFlags + + when imageLoaded $ + showImage renderer imgPath imgFlags imgSize carea imgRect imgRadius alpha + where + style = currentStyle wenv node + border = style ^. L.border + radius = style ^. L.radius + carea = getContentArea node style + + alpha = fromMaybe 1 (_imcTransparency config) + alignH = fromMaybe ALeft (_imcAlignH config) + alignV = fromMaybe ATop (_imcAlignV config) + + imgPath = imgName imgSource + imgFlags = _imcFlags config + imgFit = fromMaybe FitNone (_imcFit config) + imgRect = fitImage carea imgSize imgFlags imgFit alignH alignV + imgRadius = subtractBorderFromRadius border <$> radius + + ImageState _ imgData = state + imageLoaded = isJust imgData + (imgBytes, imgSize) = fromJust imgData + +showImage + :: Renderer + -> Text + -> [ImageFlag] + -> Size + -> Rect + -> Rect + -> Maybe Radius + -> Double + -> IO () +showImage renderer imgPath imgFlags imgSize vp rect radius alpha = + when (isJust targetRect) $ do + beginPath renderer + setFillImagePattern renderer imgPath topLeft size angle alpha + drawRoundedRect renderer (fromJust targetRect) (fromMaybe def radius) + fill renderer + where + Rect x y w h = rect + Size dw dh = imgSize + targetRect = intersectRects vp rect + iw + | ImageRepeatX `elem` imgFlags = dw + | otherwise = w + ih + | ImageRepeatY `elem` imgFlags = dh + | otherwise = h + topLeft = Point x y + size = Size iw ih + angle = 0 + +fitImage :: Rect -> Size -> [ImageFlag] -> ImageFit -> AlignH -> AlignV -> Rect +fitImage viewport imageSize imgFlags imgFit alignH alignV = case imgFit of + FitNone -> alignImg iw ih + FitFill -> alignImg w h + FitWidth + | ImageRepeatY `elem` imgFlags -> alignImg w ih + | otherwise -> alignImg w (w * ih / iw) + FitHeight + | ImageRepeatX `elem` imgFlags -> alignImg iw h + | otherwise -> alignImg (h * iw / ih) h + where + Rect x y w h = viewport + Size iw ih = imageSize + alignImg nw nh = alignInRect viewport (Rect x y nw nh) alignH alignV + +handleImageLoad :: ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage +handleImageLoad config wenv path = do + -- Get the image's MVar. One MVar per image name/path is created, to allow + -- loading images in parallel. The main MVar is only taken until the image's + -- MVar is retrieved/created. + sharedMap <- takeMVar sharedMapMVar + sharedImgMVar <- case useShared (Map.lookup key sharedMap) of + Just mvar -> return mvar + Nothing -> newMVar emptyImgState + putMVar sharedMapMVar (sharedMap & at key ?~ WidgetShared sharedImgMVar) + + -- Take the image's MVar until done + sharedImg <- takeMVar sharedImgMVar + (result, newSharedImg) <- case sharedImg of + Just (oldState, oldCount) -> do + return (ImageLoaded oldState, Just (oldState, oldCount + 1)) + Nothing -> do + res <- loadImage path + + case res >>= decodeImage of + Left loadError -> return (ImageFailed loadError, Nothing) + Right dimg -> do + let newState = makeImgState config wenv path dimg + return (ImageLoaded newState, Just (newState, 1)) + + putMVar sharedImgMVar newSharedImg + return result + where + key = imgKey path + sharedMapMVar = wenv ^. L.widgetShared + emptyImgState :: Maybe (ImageState, Int) + emptyImgState = Nothing + +handleImageDispose :: WidgetEnv s e -> Text -> IO () +handleImageDispose wenv path = do + sharedMap <- takeMVar sharedMapMVar + newSharedMap <- case useShared (Map.lookup key sharedMap) of + Just mvar -> do + sharedImg <- takeMVar mvar + return $ case sharedImg of + Just (oldState :: ImageState, oldCount :: Int) + | oldCount > 1 -> + sharedMap & at key ?~ WidgetShared (oldState, oldCount - 1) + _ -> sharedMap & at key .~ Nothing + Nothing -> return sharedMap + putMVar sharedMapMVar newSharedMap + where + sharedMapMVar = wenv ^. L.widgetShared + key = imgKey path + +imgKey :: Text -> Text +imgKey path = "image-widget-key-" <> path + +loadImage :: Text -> IO (Either ImageLoadError ByteString) +loadImage path + | not (isUrl path) = loadLocal path + | otherwise = loadRemote path + +decodeImage :: ByteString -> Either ImageLoadError DynamicImage +decodeImage bs = either (Left . ImageInvalid) Right (Pic.decodeImage bs) + +loadLocal :: Text -> IO (Either ImageLoadError ByteString) +loadLocal name = do + let path = T.unpack name + content <- BS.readFile path + + if BS.length content == 0 + then return . Left . ImageLoadFailed $ "Failed to load: " ++ path + else return . Right $ content + +loadRemote :: Text -> IO (Either ImageLoadError ByteString) +loadRemote name = do + let path = T.unpack name + eresp <- try $ getUrl path + + return $ case eresp of + Left e -> remoteException path e + Right r -> Right $ respBody r + where + respBody r = BSL.toStrict $ r ^. responseBody + getUrl = getWith (defaults & checkResponse ?~ (\_ _ -> return ())) + +remoteException + :: String -> HttpException -> Either ImageLoadError ByteString +remoteException path (HttpExceptionRequest _ (StatusCodeException r _)) = + Left . ImageLoadFailed $ respErrorMsg path $ show (respCode r) +remoteException path _ = + Left . ImageLoadFailed $ respErrorMsg path "Unknown" + +respCode :: Response a -> Int +respCode r = r ^. responseStatus . statusCode + +respErrorMsg :: String -> String -> String +respErrorMsg path code = "Status: " ++ code ++ " - Path: " ++ path + +makeImgState + :: ImageCfg e + -> WidgetEnv s e + -> Text + -> DynamicImage + -> ImageState +makeImgState config wenv name dimg = newState where + img = Pic.convertRGBA8 dimg + cw = imageWidth img + ch = imageHeight img + size = Size (fromIntegral cw) (fromIntegral ch) + bs = vectorToByteString $ imageData img + newState = ImageState { + isImageSource = ImagePath name, + isImageData = Just (bs, size) + } + +isUrl :: Text -> Bool +isUrl url = T.isPrefixOf "http://" lurl || T.isPrefixOf "https://" lurl where + lurl = T.toLower url diff --git a/src/Monomer/Widgets/Singles/Label.hs b/src/Monomer/Widgets/Singles/Label.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Label.hs @@ -0,0 +1,289 @@ +{-| +Module : Monomer.Widgets.Singles.Label +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Label widget, with support for multiline text. + +Configs: + +- 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. +- maxLines: maximum number of text lines to show. +- ignoreTheme: whether to load default style from theme or start empty. +- resizeFactor: flexibility to have more or less spaced assigned. +- resizeFactorW: flexibility to have more or less horizontal spaced assigned. +- resizeFactorH: flexibility to have more or less vertical spaced assigned. +-} +{-# LANGUAGE DeriveGeneric #-} + +module Monomer.Widgets.Singles.Label ( + LabelCfg(..), + label, + label_, + labelS, + labelS_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), (^?), non, ix) +import Control.Monad (forM_) +import Data.Default +import Data.Maybe +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import GHC.Generics + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +-- | Configuration options for label widget. +data LabelCfg s e = LabelCfg { + _lscIgnoreTheme :: Maybe Bool, + _lscTextTrim :: Maybe Bool, + _lscTextEllipsis :: Maybe Bool, + _lscTextMultiLine :: Maybe Bool, + _lscTextMaxLines :: Maybe Int, + _lscFactorW :: Maybe Double, + _lscFactorH :: Maybe Double, + _lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState) +} + +instance Default (LabelCfg s e) where + def = LabelCfg { + _lscIgnoreTheme = Nothing, + _lscTextTrim = Nothing, + _lscTextEllipsis = Nothing, + _lscTextMultiLine = Nothing, + _lscTextMaxLines = Nothing, + _lscFactorW = Nothing, + _lscFactorH = Nothing, + _lscCurrentStyle = Nothing + } + +instance Semigroup (LabelCfg s e) where + (<>) l1 l2 = LabelCfg { + _lscIgnoreTheme = _lscIgnoreTheme l2 <|> _lscIgnoreTheme l1, + _lscTextTrim = _lscTextTrim l2 <|> _lscTextTrim l1, + _lscTextEllipsis = _lscTextEllipsis l2 <|> _lscTextEllipsis l1, + _lscTextMultiLine = _lscTextMultiLine l2 <|> _lscTextMultiLine l1, + _lscTextMaxLines = _lscTextMaxLines l2 <|> _lscTextMaxLines l1, + _lscFactorW = _lscFactorW l2 <|> _lscFactorW l1, + _lscFactorH = _lscFactorH l2 <|> _lscFactorH l1, + _lscCurrentStyle = _lscCurrentStyle l2 <|> _lscCurrentStyle l1 + } + +instance Monoid (LabelCfg s e) where + mempty = def + +instance CmbIgnoreTheme (LabelCfg s e) where + ignoreTheme_ ignore = def { + _lscIgnoreTheme = Just ignore + } + +instance CmbTrimSpaces (LabelCfg s e) where + trimSpaces_ trim = def { + _lscTextTrim = Just trim + } + +instance CmbEllipsis (LabelCfg s e) where + ellipsis_ ellipsis = def { + _lscTextEllipsis = Just ellipsis + } + +instance CmbMultiline (LabelCfg s e) where + multiline_ multi = def { + _lscTextMultiLine = Just multi + } + +instance CmbMaxLines (LabelCfg s e) where + maxLines count = def { + _lscTextMaxLines = Just count + } + +instance CmbResizeFactor (LabelCfg s e) where + resizeFactor s = def { + _lscFactorW = Just s, + _lscFactorH = Just s + } + +instance CmbResizeFactorDim (LabelCfg s e) where + resizeFactorW w = def { + _lscFactorW = Just w + } + resizeFactorH h = def { + _lscFactorH = Just h + } + +data LabelState = LabelState { + _lstCaption :: Text, + _lstTextStyle :: Maybe TextStyle, + _lstTextRect :: Rect, + _lstTextLines :: Seq TextLine, + _lstPrevResize :: (Int, Bool) +} deriving (Eq, Show, Generic) + +-- | Creates a label using the provided 'Text'. +label :: Text -> WidgetNode s e +label caption = label_ caption def + +-- | Creates a label using the provided 'Text'. Accepts config. +label_ :: Text -> [LabelCfg s e] -> WidgetNode s e +label_ caption configs = defaultWidgetNode "label" widget where + config = mconcat configs + state = LabelState caption Nothing def Seq.Empty (0, False) + widget = makeLabel config state + +-- | Creates a label using the 'Show' instance of the type. +labelS :: Show a => a -> WidgetNode s e +labelS caption = labelS_ caption def + +-- | Creates a label using the 'Show' instance of the type. Accepts config. +labelS_ :: Show a => a -> [LabelCfg s e] -> WidgetNode s e +labelS_ caption configs = label_ (T.pack . show $ caption) configs + +makeLabel :: LabelCfg s e -> LabelState -> Widget s e +makeLabel config state = widget where + baseWidget = createSingle state def { + singleGetBaseStyle = getBaseStyle, + singleInit = init, + singleMerge = merge, + singleGetSizeReq = getSizeReq, + singleResize = resize + } + widget = baseWidget { + widgetRender = render + } + + ignoreTheme = _lscIgnoreTheme config == Just True + trim + | _lscTextTrim config == Just True = TrimSpaces + | otherwise = KeepSpaces + overflow + | _lscTextEllipsis config == Just True = Ellipsis + | otherwise = ClipText + mode + | _lscTextMultiLine config == Just True = MultiLine + | otherwise = SingleLine + maxLines = _lscTextMaxLines config + labelCurrentStyle = fromMaybe currentStyle (_lscCurrentStyle config) + LabelState caption textStyle textRect textLines prevResize = state + + getBaseStyle wenv node + | ignoreTheme = Nothing + | otherwise = Just $ collectTheme wenv L.labelStyle + + init wenv node = resultNode newNode where + style = labelCurrentStyle wenv node + newState = state { + _lstTextStyle = style ^. L.text + } + newNode = node + & L.widget .~ makeLabel config newState + + merge wenv newNode oldNode oldState = result where + widgetId = newNode ^. L.info . L.widgetId + style = labelCurrentStyle wenv newNode + newTextStyle = style ^. L.text + + captionChanged = _lstCaption oldState /= caption + styleChanged = _lstTextStyle oldState /= newTextStyle + changeReq = captionChanged || styleChanged + -- This is used in resize to know if glyphs have to be recalculated + newRect + | changeReq = def + | otherwise = _lstTextRect oldState + newState = oldState { + _lstCaption = caption, + _lstTextRect = newRect, + _lstTextStyle = newTextStyle + } + + reqs = [ ResizeWidgets widgetId | changeReq ] + resNode = newNode + & L.widget .~ makeLabel config newState + result = resultReqs resNode reqs + + getSizeReq wenv node = (sizeW, sizeH) where + ts = wenv ^. L.timestamp + caption = _lstCaption state + prevResize = _lstPrevResize state + style = labelCurrentStyle wenv node + + cw = getContentArea node style ^. L.w + defaultFactor + | mode == MultiLine = 1 + | overflow == Ellipsis = 0.01 + | otherwise = 0 + + targetW + | mode == MultiLine && prevResize == (ts, True) = Just cw + | otherwise = fmap sizeReqMaxBounded (style ^. L.sizeReqW) + Size w h = getTextSize_ wenv style mode trim targetW maxLines caption + + factorW = fromMaybe defaultFactor (_lscFactorW config) + factorH = fromMaybe defaultFactor (_lscFactorH config) + + sizeW + | abs factorW < 0.01 = fixedSize w + | otherwise = flexSize w factorW + sizeH + | abs factorH < 0.01 = fixedSize h + | otherwise = flexSize h factorH + + resize wenv node viewport = result where + fontMgr = wenv ^. L.fontManager + ts = wenv ^. L.timestamp + widgetId = newNode ^. L.info . L.widgetId + style = labelCurrentStyle wenv node + crect = fromMaybe def (removeOuterBounds style viewport) + newTextStyle = style ^. L.text + + Rect px py pw ph = textRect + Rect _ _ cw ch = crect + size = Size cw ch + alignRect = Rect 0 0 cw ch + + fittedLines + = fitTextToSize fontMgr style overflow mode trim maxLines size caption + newTextLines = alignTextLines style alignRect fittedLines + + newGlyphsReq = pw /= cw || ph /= ch || textStyle /= newTextStyle + newLines + | not newGlyphsReq = textLines + | otherwise = newTextLines + + (prevTs, prevStep) = prevResize + needsSndResize = mode == MultiLine && (prevTs /= ts || not prevStep) + + newState = state { + _lstTextStyle = newTextStyle, + _lstTextRect = crect, + _lstTextLines = newLines, + _lstPrevResize = (ts, needsSndResize && prevTs == ts) + } + newNode = node + & L.widget .~ makeLabel config newState + result = resultReqs newNode [ResizeWidgets widgetId | needsSndResize] + + render wenv node renderer = do + drawInScissor renderer True scissorVp $ + drawStyledAction renderer viewport style $ \(Rect cx cy _ _) -> + drawInTranslation renderer (Point cx cy) $ + forM_ textLines (drawTextLine renderer style) + where + style = labelCurrentStyle wenv node + viewport = node ^. L.info . L.viewport + textMetrics = textLines ^? ix 0 . L.metrics + desc = abs (textMetrics ^. non def . L.desc) + scissorVp = viewport + & L.y .~ (viewport ^. L.y - desc) + & L.h .~ (viewport ^. L.h + desc) diff --git a/src/Monomer/Widgets/Singles/LabeledCheckbox.hs b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs @@ -0,0 +1,237 @@ +{-| +Module : Monomer.Widgets.Singles.LabeledCheckbox +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Labeled checkbox, used for interacting with boolean values with an associated +clickable label. + +Configs: + +- Text related + - textLeft: places the label to the left of the checkbox. + - textRight: places the label to the right of the checkbox. + - textTop: places the label to the top of the checkbox. + - textBottom: places the label to the bottom of the checkbox. + - 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. + - maxLines: maximum number of text lines to show. + - resizeFactor: flexibility to have more or less spaced assigned. + - resizeFactorW: flexibility to have more or less horizontal spaced assigned. + - resizeFactorH: flexibility to have more or less vertical spaced assigned. + +- Checkbox related + - checkboxMark: the type of checkbox mark. + - width: sets the max width/height of the checkbox. + - onFocus: event to raise when focus is received. + - onFocusReq: WidgetRequest to generate when focus is received. + - onBlur: event to raise when focus is lost. + - onBlurReq: WidgetRequest to generate when focus is lost. + - onChange: event to raise when the value changes/is clicked. + - onChangeReq: WidgetRequest to generate when the value changes/is clicked. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.LabeledCheckbox ( + labeledCheckbox, + labeledCheckbox_, + labeledCheckboxV, + labeledCheckboxV_, + labeledCheckboxD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~)) +import Control.Monad +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Containers.Base.LabeledItem +import Monomer.Widgets.Single +import Monomer.Widgets.Singles.Checkbox +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data LabeledCheckboxCfg s e = LabeledCheckboxCfg { + _lchTextSide :: Maybe RectSide, + _lchLabelCfg :: LabelCfg s e, + _lchCheckboxCfg :: CheckboxCfg s e +} + +instance Default (LabeledCheckboxCfg s e) where + def = LabeledCheckboxCfg { + _lchTextSide = Nothing, + _lchLabelCfg = def, + _lchCheckboxCfg = def + } + +instance Semigroup (LabeledCheckboxCfg s e) where + (<>) t1 t2 = LabeledCheckboxCfg { + _lchTextSide = _lchTextSide t2 <|> _lchTextSide t1, + _lchLabelCfg = _lchLabelCfg t1 <> _lchLabelCfg t2, + _lchCheckboxCfg = _lchCheckboxCfg t1 <> _lchCheckboxCfg t2 + } + +instance Monoid (LabeledCheckboxCfg s e) where + mempty = def + +instance CmbTextLeft (LabeledCheckboxCfg s e) where + textLeft_ False = def + textLeft_ True = def { + _lchTextSide = Just SideLeft + } + +instance CmbTextRight (LabeledCheckboxCfg s e) where + textRight_ False = def + textRight_ True = def { + _lchTextSide = Just SideRight + } + +instance CmbTextTop (LabeledCheckboxCfg s e) where + textTop_ False = def + textTop_ True = def { + _lchTextSide = Just SideTop + } + +instance CmbTextBottom (LabeledCheckboxCfg s e) where + textBottom_ False = def + textBottom_ True = def { + _lchTextSide = Just SideBottom + } + +instance CmbTrimSpaces (LabeledCheckboxCfg s e) where + trimSpaces_ trim = def { + _lchLabelCfg = trimSpaces_ trim + } + +instance CmbEllipsis (LabeledCheckboxCfg s e) where + ellipsis_ ellipsis = def { + _lchLabelCfg = ellipsis_ ellipsis + } + +instance CmbMultiline (LabeledCheckboxCfg s e) where + multiline_ multi = def { + _lchLabelCfg = multiline_ multi + } + +instance CmbMaxLines (LabeledCheckboxCfg s e) where + maxLines count = def { + _lchLabelCfg = maxLines count + } + +instance CmbResizeFactor (LabeledCheckboxCfg s e) where + resizeFactor s = def { + _lchLabelCfg = resizeFactor s + } + +instance CmbResizeFactorDim (LabeledCheckboxCfg s e) where + resizeFactorW w = def { + _lchLabelCfg = resizeFactorW w + } + resizeFactorH h = def { + _lchLabelCfg = resizeFactorH h + } + +instance CmbCheckboxMark (LabeledCheckboxCfg s e) where + checkboxMark mark = def { + _lchCheckboxCfg = checkboxMark mark + } + checkboxSquare = checkboxMark CheckboxSquare + checkboxTimes = checkboxMark CheckboxTimes + +instance CmbWidth (LabeledCheckboxCfg s e) where + width w = def { + _lchCheckboxCfg = width w + } + +instance WidgetEvent e => CmbOnFocus (LabeledCheckboxCfg s e) e Path where + onFocus fn = def { + _lchCheckboxCfg = onFocus fn + } + +instance CmbOnFocusReq (LabeledCheckboxCfg s e) s e Path where + onFocusReq req = def { + _lchCheckboxCfg = onFocusReq req + } + +instance WidgetEvent e => CmbOnBlur (LabeledCheckboxCfg s e) e Path where + onBlur fn = def { + _lchCheckboxCfg = onBlur fn + } + +instance CmbOnBlurReq (LabeledCheckboxCfg s e) s e Path where + onBlurReq req = def { + _lchCheckboxCfg = onBlurReq req + } + +instance WidgetEvent e => CmbOnChange (LabeledCheckboxCfg s e) Bool e where + onChange fn = def { + _lchCheckboxCfg = onChange fn + } + +instance CmbOnChangeReq (LabeledCheckboxCfg s e) s e Bool where + onChangeReq req = def { + _lchCheckboxCfg = onChangeReq req + } + +-- | Creates a labeled checkbox using the given lens. +labeledCheckbox :: WidgetEvent e => Text -> ALens' s Bool -> WidgetNode s e +labeledCheckbox caption field = labeledCheckbox_ caption field def + +-- | Creates a labeled checkbox using the given lens. Accepts config. +labeledCheckbox_ + :: WidgetEvent e + => Text + -> ALens' s Bool + -> [LabeledCheckboxCfg s e] + -> WidgetNode s e +labeledCheckbox_ caption field config = newNode where + newNode = labeledCheckboxD_ caption (WidgetLens field) config + +-- | Creates a labeled checkbox using the given value and onChange event handler. +labeledCheckboxV + :: WidgetEvent e + => Text + -> Bool + -> (Bool -> e) + -> WidgetNode s e +labeledCheckboxV caption value handler = newNode where + newNode = labeledCheckboxV_ caption value handler def + +{-| +Creates a labeled checkbox using the given value and onChange event handler. +Accepts config. +-} +labeledCheckboxV_ + :: WidgetEvent e + => Text + -> Bool + -> (Bool -> e) + -> [LabeledCheckboxCfg s e] + -> WidgetNode s e +labeledCheckboxV_ caption value handler config = newNode where + newConfig = onChange handler : config + newNode = labeledCheckboxD_ caption (WidgetValue value) newConfig + +-- | Creates a labeled checkbox providing a WidgetData instance and config. +labeledCheckboxD_ + :: WidgetEvent e + => Text + -> WidgetData s Bool + -> [LabeledCheckboxCfg s e] + -> WidgetNode s e +labeledCheckboxD_ caption widgetData configs = newNode where + config = mconcat configs + labelSide = fromMaybe SideLeft (_lchTextSide config) + labelCfg = _lchLabelCfg config + widget = checkboxD_ widgetData [_lchCheckboxCfg config] + newNode = labeledItem "labeledCheckbox" labelSide caption labelCfg widget diff --git a/src/Monomer/Widgets/Singles/LabeledRadio.hs b/src/Monomer/Widgets/Singles/LabeledRadio.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/LabeledRadio.hs @@ -0,0 +1,238 @@ +{-| +Module : Monomer.Widgets.Singles.LabeledRadio +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +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. + +Configs: + +- Text related + - textLeft: places the label to the left of the radio. + - textRight: places the label to the right of the radio. + - textTop: places the label to the top of the radio. + - textBottom: places the label to the bottom of the radio. + - 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. + - maxLines: maximum number of text lines to show. + - resizeFactor: flexibility to have more or less spaced assigned. + - resizeFactorW: flexibility to have more or less horizontal spaced assigned. + - resizeFactorH: flexibility to have more or less vertical spaced assigned. + +- Radio related + - width: sets the max width/height of the radio. + - onFocus: event to raise when focus is received. + - onFocusReq: WidgetRequest to generate when focus is received. + - onBlur: event to raise when focus is lost. + - onBlurReq: WidgetRequest to generate when focus is lost. + - onChange: event to raise when the value changes/is clicked. + - onChangeReq: WidgetRequest to generate when the value changes/is clicked. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.LabeledRadio ( + labeledRadio, + labeledRadio_, + labeledRadioV, + labeledRadioV_, + labeledRadioD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~)) +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import qualified Data.Sequence as Seq + +import Monomer.Widgets.Containers.Base.LabeledItem +import Monomer.Widgets.Single +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Radio + +import qualified Monomer.Lens as L + +data LabeledRadioCfg s e a = LabeledRadioCfg { + _lchTextSide :: Maybe RectSide, + _lchLabelCfg :: LabelCfg s e, + _lchRadioCfg :: RadioCfg s e a +} + +instance Default (LabeledRadioCfg s e a) where + def = LabeledRadioCfg { + _lchTextSide = Nothing, + _lchLabelCfg = def, + _lchRadioCfg = def + } + +instance Semigroup (LabeledRadioCfg s e a) where + (<>) t1 t2 = LabeledRadioCfg { + _lchTextSide = _lchTextSide t2 <|> _lchTextSide t1, + _lchLabelCfg = _lchLabelCfg t1 <> _lchLabelCfg t2, + _lchRadioCfg = _lchRadioCfg t1 <> _lchRadioCfg t2 + } + +instance Monoid (LabeledRadioCfg s e a) where + mempty = def + +instance CmbTextLeft (LabeledRadioCfg s e a) where + textLeft_ False = def + textLeft_ True = def { + _lchTextSide = Just SideLeft + } + +instance CmbTextRight (LabeledRadioCfg s e a) where + textRight_ False = def + textRight_ True = def { + _lchTextSide = Just SideRight + } + +instance CmbTextTop (LabeledRadioCfg s e a) where + textTop_ False = def + textTop_ True = def { + _lchTextSide = Just SideTop + } + +instance CmbTextBottom (LabeledRadioCfg s e a) where + textBottom_ False = def + textBottom_ True = def { + _lchTextSide = Just SideBottom + } + +instance CmbTrimSpaces (LabeledRadioCfg s e a) where + trimSpaces_ trim = def { + _lchLabelCfg = trimSpaces_ trim + } + +instance CmbEllipsis (LabeledRadioCfg s e a) where + ellipsis_ ellipsis = def { + _lchLabelCfg = ellipsis_ ellipsis + } + +instance CmbMultiline (LabeledRadioCfg s e a) where + multiline_ multi = def { + _lchLabelCfg = multiline_ multi + } + +instance CmbMaxLines (LabeledRadioCfg s e a) where + maxLines count = def { + _lchLabelCfg = maxLines count + } + +instance CmbResizeFactor (LabeledRadioCfg s e a) where + resizeFactor s = def { + _lchLabelCfg = resizeFactor s + } + +instance CmbResizeFactorDim (LabeledRadioCfg s e a) where + resizeFactorW w = def { + _lchLabelCfg = resizeFactorW w + } + resizeFactorH h = def { + _lchLabelCfg = resizeFactorH h + } + +instance CmbWidth (LabeledRadioCfg s e a) where + width w = def { + _lchRadioCfg = width w + } + +instance WidgetEvent e => CmbOnFocus (LabeledRadioCfg s e a) e Path where + onFocus fn = def { + _lchRadioCfg = onFocus fn + } + +instance CmbOnFocusReq (LabeledRadioCfg s e a) s e Path where + onFocusReq req = def { + _lchRadioCfg = onFocusReq req + } + +instance WidgetEvent e => CmbOnBlur (LabeledRadioCfg s e a) e Path where + onBlur fn = def { + _lchRadioCfg = onBlur fn + } + +instance CmbOnBlurReq (LabeledRadioCfg s e a) s e Path where + onBlurReq req = def { + _lchRadioCfg = onBlurReq req + } + +instance WidgetEvent e => CmbOnChange (LabeledRadioCfg s e a) a e where + onChange fn = def { + _lchRadioCfg = onChange fn + } + +instance CmbOnChangeReq (LabeledRadioCfg s e a) s e a where + onChangeReq req = def { + _lchRadioCfg = onChangeReq req + } + +-- | Creates a labeled radio using the given lens. +labeledRadio + :: (Eq a, WidgetEvent e) + => Text + -> a + -> ALens' s a + -> WidgetNode s e +labeledRadio caption option field = labeledRadio_ caption option field def + +-- | Creates a labeled radio using the given lens. Accepts config. +labeledRadio_ + :: (Eq a, WidgetEvent e) + => Text + -> a + -> ALens' s a + -> [LabeledRadioCfg s e a] + -> WidgetNode s e +labeledRadio_ caption option field config = newNode where + newNode = labeledRadioD_ caption option (WidgetLens field) config + +-- | Creates a labeled radio using the given value and onChange event handler. +labeledRadioV + :: (Eq a, WidgetEvent e) + => Text + -> a + -> a + -> (a -> e) + -> WidgetNode s e +labeledRadioV caption option value handler = newNode where + newNode = labeledRadioV_ caption option value handler def + +{-| +Creates a labeled radio using the given value and onChange event handler. +Accepts config. +-} +labeledRadioV_ + :: (Eq a, WidgetEvent e) + => Text + -> a + -> a + -> (a -> e) + -> [LabeledRadioCfg s e a] + -> WidgetNode s e +labeledRadioV_ caption option value handler config = newNode where + newConfig = onChange handler : config + newNode = labeledRadioD_ caption option (WidgetValue value) newConfig + +-- | Creates a labeled radio providing a WidgetData instance and config. +labeledRadioD_ + :: (Eq a, WidgetEvent e) + => Text + -> a + -> WidgetData s a + -> [LabeledRadioCfg s e a] + -> WidgetNode s e +labeledRadioD_ caption option widgetData configs = newNode where + config = mconcat configs + labelSide = fromMaybe SideLeft (_lchTextSide config) + labelCfg = _lchLabelCfg config + widget = radioD_ option widgetData [_lchRadioCfg config] + newNode = labeledItem "labeledRadio" labelSide caption labelCfg widget diff --git a/src/Monomer/Widgets/Singles/NumericField.hs b/src/Monomer/Widgets/Singles/NumericField.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/NumericField.hs @@ -0,0 +1,438 @@ +{-| +Module : Monomer.Widgets.Singles.NumericField +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Input field for numeric types. + +Supports instances of the 'FromFractional' typeclass. Several basic types are +implemented, both for integer and floating point types. + +Handles mouse wheel and shift + vertical drag to increase/decrease the number. + +Configs: + +- validInput: field indicating if the current input is valid. Useful to show +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 number. +- maxValue: Maximum valid number. +- wheelRate: The rate at which wheel movement affects the number. +- dragRate: The rate at which drag movement affects the number. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes. +- onChangeReq: WidgetRequest to generate when the value changes. +- decimals: the maximum number of digits after the decimal separator. Defaults +to zero for integers and two for floating point types. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Monomer.Widgets.Singles.NumericField ( + numericField, + numericField_, + numericFieldV, + numericFieldV_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((^.), ALens', _1, _2, _3) +import Control.Monad (join) +import Data.Char +import Data.Default +import Data.Either +import Data.List (isPrefixOf) +import Data.Maybe +import Data.Text (Text) +import Data.Text.Read (signed, rational) +import Data.Typeable (Typeable, typeOf) + +import qualified Data.Attoparsec.Text as A +import qualified Data.Text as T +import qualified Formatting as F + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event.Types +import Monomer.Widgets.Singles.Base.InputField + +import qualified Monomer.Lens as L +import qualified Monomer.Widgets.Util.Parser as P + +class NumericTextConverter a where + numericAcceptText :: Maybe a -> Maybe a -> Int -> Text -> (Bool, Bool, Maybe a) + numericFromText :: Text -> Maybe a + numericToText :: Int -> a -> Text + numericToFractional :: Fractional b => a -> Maybe b + numericFromFractional :: (Real b, Fractional b) => b -> a + +instance {-# OVERLAPPABLE #-} FromFractional a => NumericTextConverter a where + numericAcceptText minVal maxVal decimals text = result where + accept = acceptNumberInput decimals text + parsed = numericFromText text + isValid = isJust parsed && numberInBounds minVal maxVal (fromJust parsed) + fromText + | isValid = parsed + | otherwise = Nothing + result = (accept, isValid, fromText) + numericFromText text = case signed rational text of + Right (frac :: Rational, _) -> Just (fromFractional frac) + _ -> Nothing + numericToText decimals value = F.sformat (F.fixed decimals) value + numericToFractional = Just . realToFrac + numericFromFractional = fromFractional + +instance (FromFractional a, NumericTextConverter a) => NumericTextConverter (Maybe a) where + numericAcceptText minVal maxVal decimals text + | T.strip text == "" = (True, True, Just Nothing) + | otherwise = (accept, isValid, result) where + resp = numericAcceptText (join minVal) (join maxVal) decimals text + (accept, isValid, tmpResult) = resp + result + | isJust tmpResult = Just tmpResult + | otherwise = Nothing + numericFromText = Just . numericFromText + numericToText _ Nothing = "" + numericToText decimals (Just value) = numericToText decimals value + numericToFractional Nothing = Nothing + numericToFractional (Just value) = numericToFractional value + numericFromFractional = Just . numericFromFractional + +type FormattableNumber a + = (Eq a, Ord a, Show a, NumericTextConverter a, Typeable a) + +data NumericFieldCfg s e a = NumericFieldCfg { + _nfcCaretWidth :: Maybe Double, + _nfcCaretMs :: Maybe Int, + _nfcValid :: Maybe (WidgetData s Bool), + _nfcValidV :: [Bool -> e], + _nfcDecimals :: Maybe Int, + _nfcMinValue :: Maybe a, + _nfcMaxValue :: Maybe a, + _nfcWheelRate :: Maybe Double, + _nfcDragRate :: Maybe Double, + _nfcResizeOnChange :: Maybe Bool, + _nfcSelectOnFocus :: Maybe Bool, + _nfcOnFocusReq :: [Path -> WidgetRequest s e], + _nfcOnBlurReq :: [Path -> WidgetRequest s e], + _nfcOnChangeReq :: [a -> WidgetRequest s e] +} + +instance Default (NumericFieldCfg s e a) where + def = NumericFieldCfg { + _nfcCaretWidth = Nothing, + _nfcCaretMs = Nothing, + _nfcValid = Nothing, + _nfcValidV = [], + _nfcDecimals = Nothing, + _nfcMinValue = Nothing, + _nfcMaxValue = Nothing, + _nfcWheelRate = Nothing, + _nfcDragRate = Nothing, + _nfcResizeOnChange = Nothing, + _nfcSelectOnFocus = Nothing, + _nfcOnFocusReq = [], + _nfcOnBlurReq = [], + _nfcOnChangeReq = [] + } + +instance Semigroup (NumericFieldCfg s e a) where + (<>) t1 t2 = NumericFieldCfg { + _nfcCaretWidth = _nfcCaretWidth t2 <|> _nfcCaretWidth t1, + _nfcCaretMs = _nfcCaretMs t2 <|> _nfcCaretMs t1, + _nfcValid = _nfcValid t2 <|> _nfcValid t1, + _nfcValidV = _nfcValidV t1 <> _nfcValidV t2, + _nfcDecimals = _nfcDecimals t2 <|> _nfcDecimals t1, + _nfcMinValue = _nfcMinValue t2 <|> _nfcMinValue t1, + _nfcMaxValue = _nfcMaxValue t2 <|> _nfcMaxValue t1, + _nfcWheelRate = _nfcWheelRate t2 <|> _nfcWheelRate t1, + _nfcDragRate = _nfcDragRate t2 <|> _nfcDragRate t1, + _nfcResizeOnChange = _nfcResizeOnChange t2 <|> _nfcResizeOnChange t1, + _nfcSelectOnFocus = _nfcSelectOnFocus t2 <|> _nfcSelectOnFocus t1, + _nfcOnFocusReq = _nfcOnFocusReq t1 <> _nfcOnFocusReq t2, + _nfcOnBlurReq = _nfcOnBlurReq t1 <> _nfcOnBlurReq t2, + _nfcOnChangeReq = _nfcOnChangeReq t1 <> _nfcOnChangeReq t2 + } + +instance Monoid (NumericFieldCfg s e a) where + mempty = def + +instance CmbCaretWidth (NumericFieldCfg s e a) Double where + caretWidth w = def { + _nfcCaretWidth = Just w + } + +instance CmbCaretMs (NumericFieldCfg s e a) Int where + caretMs ms = def { + _nfcCaretMs = Just ms + } + +instance CmbValidInput (NumericFieldCfg s e a) s where + validInput field = def { + _nfcValid = Just (WidgetLens field) + } + +instance CmbValidInputV (NumericFieldCfg s e a) e where + validInputV fn = def { + _nfcValidV = [fn] + } + +instance CmbResizeOnChange (NumericFieldCfg s e a) where + resizeOnChange_ resize = def { + _nfcResizeOnChange = Just resize + } + +instance CmbSelectOnFocus (NumericFieldCfg s e a) where + selectOnFocus_ sel = def { + _nfcSelectOnFocus = Just sel + } + +instance FormattableNumber a => CmbMinValue (NumericFieldCfg s e a) a where + minValue len = def { + _nfcMinValue = Just len + } + +instance FormattableNumber a => CmbMaxValue (NumericFieldCfg s e a) a where + maxValue len = def { + _nfcMaxValue = Just len + } + +instance CmbWheelRate (NumericFieldCfg s e a) Double where + wheelRate rate = def { + _nfcWheelRate = Just rate + } + +instance CmbDragRate (NumericFieldCfg s e a) Double where + dragRate rate = def { + _nfcDragRate = Just rate + } + +instance CmbDecimals (NumericFieldCfg s e a) where + decimals num = def { + _nfcDecimals = Just num + } + +instance WidgetEvent e => CmbOnFocus (NumericFieldCfg s e a) e Path where + onFocus fn = def { + _nfcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (NumericFieldCfg s e a) s e Path where + onFocusReq req = def { + _nfcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (NumericFieldCfg s e a) e Path where + onBlur fn = def { + _nfcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (NumericFieldCfg s e a) s e Path where + onBlurReq req = def { + _nfcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (NumericFieldCfg s e a) a e where + onChange fn = def { + _nfcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (NumericFieldCfg s e a) s e a where + onChangeReq req = def { + _nfcOnChangeReq = [req] + } + +-- | Creates a numeric field using the given lens. +numericField + :: (FormattableNumber a, WidgetEvent e) + => ALens' s a -> WidgetNode s e +numericField field = numericField_ field def + +-- | Creates a numeric field using the given lens. Accepts config. +numericField_ + :: (FormattableNumber a, WidgetEvent e) + => ALens' s a + -> [NumericFieldCfg s e a] + -> WidgetNode s e +numericField_ field configs = widget where + widget = numericFieldD_ (WidgetLens field) configs + +-- | Creates a numeric field using the given value and onChange event handler. +numericFieldV + :: (FormattableNumber a, WidgetEvent e) + => a -> (a -> e) -> WidgetNode s e +numericFieldV value handler = numericFieldV_ value handler def + +-- | Creates a numeric field using the given value and onChange event handler. +-- | Accepts config. +numericFieldV_ + :: (FormattableNumber a, WidgetEvent e) + => a + -> (a -> e) + -> [NumericFieldCfg s e a] + -> WidgetNode s e +numericFieldV_ value handler configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = numericFieldD_ widgetData newConfigs + +-- | Creates a numeric field providing a WidgetData instance and config. +numericFieldD_ + :: forall s e a . (FormattableNumber a, WidgetEvent e) + => WidgetData s a + -> [NumericFieldCfg s e a] + -> WidgetNode s e +numericFieldD_ widgetData configs = newNode where + config = mconcat configs + minVal = _nfcMinValue config + maxVal = _nfcMaxValue config + + initialValue + | isJust minVal = fromJust minVal + | isJust maxVal = fromJust maxVal + | otherwise = numericFromFractional 0 + decimals + | isIntegral initialValue = 0 + | otherwise = max 0 $ fromMaybe 2 (_nfcDecimals config) + defWidth + | isIntegral initialValue = 50 + | otherwise = 70 + + acceptText = numericAcceptText minVal maxVal decimals + acceptInput text = acceptText text ^. _1 + validInput text = acceptText text ^. _2 + fromText text = acceptText text ^. _3 + toText = numericToText decimals + + inputConfig = InputFieldCfg { + _ifcPlaceholder = Nothing, + _ifcInitialValue = initialValue, + _ifcValue = widgetData, + _ifcValid = _nfcValid config, + _ifcValidV = _nfcValidV config, + _ifcFromText = fromText, + _ifcToText = toText, + _ifcAcceptInput = acceptInput, + _ifcIsValidInput = validInput, + _ifcDefCursorEnd = False, + _ifcDefWidth = defWidth, + _ifcCaretWidth = _nfcCaretWidth config, + _ifcCaretMs = _nfcCaretMs config, + _ifcDisplayChar = Nothing, + _ifcResizeOnChange = fromMaybe False (_nfcResizeOnChange config), + _ifcSelectOnFocus = fromMaybe True (_nfcSelectOnFocus config), + _ifcStyle = Just L.numericFieldStyle, + _ifcWheelHandler = Just (handleWheel config), + _ifcDragHandler = Just (handleDrag config), + _ifcDragCursor = Just CursorSizeV, + _ifcOnFocusReq = _nfcOnFocusReq config, + _ifcOnBlurReq = _nfcOnBlurReq config, + _ifcOnChangeReq = _nfcOnChangeReq config + } + newNode = inputField_ "numericField" inputConfig + +handleWheel + :: FormattableNumber a + => NumericFieldCfg s e a + -> InputFieldState a + -> Point + -> Point + -> WheelDirection + -> (Text, Int, Maybe Int) +handleWheel config state point move dir = result where + Point _ dy = move + sign = if dir == WheelNormal then 1 else -1 + curValue = _ifsCurrValue state + wheelRate + | isIntegral curValue = fromMaybe 1 (_nfcWheelRate config) + | otherwise = fromMaybe 0.1 (_nfcWheelRate config) + result = handleMove config state wheelRate curValue (dy * sign) + +handleDrag + :: FormattableNumber a + => NumericFieldCfg s e a + -> InputFieldState a + -> Point + -> Point + -> (Text, Int, Maybe Int) +handleDrag config state clickPos currPos = result where + Point _ dy = subPoint clickPos currPos + selValue = _ifsDragSelValue state + dragRate + | isIntegral selValue = fromMaybe 1 (_nfcDragRate config) + | otherwise = fromMaybe 0.1 (_nfcDragRate config) + result = handleMove config state dragRate selValue dy + +handleMove + :: forall s e a . FormattableNumber a + => NumericFieldCfg s e a + -> InputFieldState a + -> Double + -> a + -> Double + -> (Text, Int, Maybe Int) +handleMove config state rate value dy = result where + decimals + | isIntegral value = 0 + | otherwise = max 0 $ fromMaybe 2 (_nfcDecimals config) + minVal = _nfcMinValue config + maxVal = _nfcMaxValue config + + acceptText = numericAcceptText minVal maxVal decimals + fromText text = acceptText text ^. _3 + toText = numericToText + + (valid, mParsedVal, parsedVal) = case numericToFractional value of + Just val -> (True, mParsedVal, parsedVal) where + tmpValue = realToFrac val + dy * rate + mParsedVal = fromText (toText decimals (numericFromFractional tmpValue)) + parsedVal = fromJust mParsedVal + Nothing -> (False, Nothing, undefined) + newVal + | isJust mParsedVal = parsedVal + | valid && dy > 0 && isJust maxVal = fromJust maxVal + | valid && dy < 0 && isJust minVal = fromJust minVal + | otherwise = _ifsCurrValue state + + newText = toText decimals newVal + newPos = _ifsCursorPos state + newSel = _ifsSelStart state + result = (newText, newPos, newSel) + +acceptNumberInput :: Int -> Text -> Bool +acceptNumberInput decimals text = isRight (A.parseOnly parser text) where + sign = A.option "" (P.single '-') + number = A.takeWhile isDigit + digit = T.singleton <$> A.digit + dot = P.single '.' + dots = if decimals > 0 then 1 else 0 + rest = P.join [P.upto dots dot, P.upto decimals digit] + parser = P.join [sign, number, A.option "" rest] <* A.endOfInput + +numberInBounds :: Ord a => Maybe a -> Maybe a -> a -> Bool +numberInBounds Nothing Nothing _ = True +numberInBounds (Just minVal) Nothing val = val >= minVal +numberInBounds Nothing (Just maxVal) val = val <= maxVal +numberInBounds (Just minVal) (Just maxVal) val = val >= minVal && val <= maxVal + +isIntegral :: Typeable a => a -> Bool +isIntegral val + | "Int" `isPrefixOf` name = True + | "Fixed" `isPrefixOf` name = True + | "Word" `isPrefixOf` name = True + | otherwise = False + where + typeName = show (typeOf val) + name + | "Maybe " `isPrefixOf` typeName = drop 6 typeName + | otherwise = typeName diff --git a/src/Monomer/Widgets/Singles/Radio.hs b/src/Monomer/Widgets/Singles/Radio.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Radio.hs @@ -0,0 +1,231 @@ +{-| +Module : Monomer.Widgets.Singles.Radio +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +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, `LabeledRadio` provides this functionality out of the box. + +Configs: + +- width: sets the max width/height of the radio. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes/is clicked. +- onChangeReq: WidgetRequest to generate when the value changes/is clicked. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.Radio ( + RadioCfg(..), + radio, + radio_, + radioV, + radioV_, + radioD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~)) +import Control.Monad +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +-- | Configuration options for radio widget. +data RadioCfg s e a = RadioCfg { + _rdcWidth :: Maybe Double, + _rdcOnFocusReq :: [Path -> WidgetRequest s e], + _rdcOnBlurReq :: [Path -> WidgetRequest s e], + _rdcOnChangeReq :: [a -> WidgetRequest s e] +} + +instance Default (RadioCfg s e a) where + def = RadioCfg { + _rdcWidth = Nothing, + _rdcOnFocusReq = [], + _rdcOnBlurReq = [], + _rdcOnChangeReq = [] + } + +instance Semigroup (RadioCfg s e a) where + (<>) t1 t2 = RadioCfg { + _rdcWidth = _rdcWidth t2 <|> _rdcWidth t1, + _rdcOnFocusReq = _rdcOnFocusReq t1 <> _rdcOnFocusReq t2, + _rdcOnBlurReq = _rdcOnBlurReq t1 <> _rdcOnBlurReq t2, + _rdcOnChangeReq = _rdcOnChangeReq t1 <> _rdcOnChangeReq t2 + } + +instance Monoid (RadioCfg s e a) where + mempty = def + +instance CmbWidth (RadioCfg s e a) where + width w = def { + _rdcWidth = Just w + } + +instance WidgetEvent e => CmbOnFocus (RadioCfg s e a) e Path where + onFocus fn = def { + _rdcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (RadioCfg s e a) s e Path where + onFocusReq req = def { + _rdcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (RadioCfg s e a) e Path where + onBlur fn = def { + _rdcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (RadioCfg s e a) s e Path where + onBlurReq req = def { + _rdcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (RadioCfg s e a) a e where + onChange fn = def { + _rdcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (RadioCfg s e a) s e a where + onChangeReq req = def { + _rdcOnChangeReq = [req] + } + +-- | Creates a radio using the given lens. +radio :: (Eq a, WidgetEvent e) => a -> ALens' s a -> WidgetNode s e +radio option field = radio_ option field def + +-- | Creates a radio using the given lens. Accepts config. +radio_ + :: (Eq a, WidgetEvent e) + => a + -> ALens' s a + -> [RadioCfg s e a] + -> WidgetNode s e +radio_ option field configs = radioD_ option (WidgetLens field) configs + +-- | Creates a radio using the given value and onChange event handler. +radioV :: (Eq a, WidgetEvent e) => a -> a -> (a -> e) -> WidgetNode s e +radioV option value handler = radioV_ option value handler def + +-- | Creates a radio using the given value and onChange event handler. +-- | Accepts config. +radioV_ + :: (Eq a, WidgetEvent e) + => a + -> a + -> (a -> e) + -> [RadioCfg s e a] + -> WidgetNode s e +radioV_ option value handler configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = radioD_ option widgetData newConfigs + +-- | Creates a radio providing a WidgetData instance and config. +radioD_ + :: (Eq a, WidgetEvent e) + => a + -> WidgetData s a + -> [RadioCfg s e a] + -> WidgetNode s e +radioD_ option widgetData configs = radioNode where + config = mconcat configs + widget = makeRadio widgetData option config + radioNode = defaultWidgetNode "radio" widget + & L.info . L.focusable .~ True + +makeRadio :: (Eq a, WidgetEvent e) => WidgetData s a -> a -> RadioCfg s e a -> Widget s e +makeRadio field option config = widget where + widget = createSingle () def { + singleGetBaseStyle = getBaseStyle, + singleGetCurrentStyle = getCurrentStyle, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.radioStyle + + getCurrentStyle wenv node = style where + radioArea = getRadioArea wenv node config + style = currentStyle_ (currentStyleConfig radioArea) wenv node + + handleEvent wenv node target evt = case evt of + Focus prev -> handleFocusChange node prev (_rdcOnFocusReq config) + + Blur next -> handleFocusChange node next (_rdcOnBlurReq config) + + Click p _ _ + | pointInEllipse p rdArea -> Just $ resultReqs node reqs + + KeyAction mod code KeyPressed + | isSelectKey code -> Just $ resultReqs node reqs + _ -> Nothing + where + rdArea = getRadioArea wenv node config + path = node ^. L.info . L.path + isSelectKey code = isKeyReturn code || isKeySpace code + setValueReq = widgetDataSet field option + reqs = setValueReq ++ fmap ($ option) (_rdcOnChangeReq config) + + getSizeReq wenv node = req where + theme = currentTheme wenv node + width = fromMaybe (theme ^. L.radioWidth) (_rdcWidth config) + req = (fixedSize width, fixedSize width) + + render wenv node renderer = do + renderRadio renderer radioBW radioArea fgColor + + when (value == option) $ + renderMark renderer radioBW radioArea hlColor + where + model = _weModel wenv + value = widgetDataGet model field + radioArea = getRadioArea wenv node config + radioBW = max 1 (_rW radioArea * 0.1) + + style_ = currentStyle_ (currentStyleConfig radioArea) wenv node + fgColor = styleFgColor style_ + hlColor = styleHlColor style_ + +getRadioArea :: WidgetEnv s e -> WidgetNode s e -> RadioCfg s e a -> Rect +getRadioArea wenv node config = radioArea where + theme = currentTheme wenv node + style = currentStyle wenv node + rarea = getContentArea node style + + radioW = fromMaybe (theme ^. L.radioWidth) (_rdcWidth config) + radioL = _rX rarea + (_rW rarea - radioW) / 2 + radioT = _rY rarea + (_rH rarea - radioW) / 2 + radioArea = Rect radioL radioT radioW radioW + +renderRadio :: Renderer -> Double -> Rect -> Color -> IO () +renderRadio renderer radioBW rect color = action where + action = drawEllipseBorder renderer rect (Just color) radioBW + +renderMark :: Renderer -> Double -> Rect -> Color -> IO () +renderMark renderer radioBW rect color = action where + w = radioBW * 2 + newRect = fromMaybe def (subtractFromRect rect w w w w) + action = drawEllipse renderer newRect (Just color) + +currentStyleConfig :: Rect -> CurrentStyleCfg s e +currentStyleConfig radioArea = def & + L.isHovered .~ isNodeHoveredEllipse_ radioArea diff --git a/src/Monomer/Widgets/Singles/SeparatorLine.hs b/src/Monomer/Widgets/Singles/SeparatorLine.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/SeparatorLine.hs @@ -0,0 +1,130 @@ +{-| +Module : Monomer.Widgets.Singles.SeparatorLine +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +SeparatorLine is used for adding a separator line between two widgets. It adapts +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 +wanting a shorter line, padding should be used. + +Configs: + +- width: the max width of the line. +- resizeFactor: flexibility to have more or less spaced assigned. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Singles.SeparatorLine ( + separatorLine, + separatorLine_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((^.)) +import Data.Default +import Data.Maybe +import Data.Tuple + +import Monomer.Widgets.Single + +import qualified Monomer.Core.Lens as L + +-- | Configuration options for separatorLine widget. +data SeparatorLineCfg = SeparatorLineCfg { + _slcWidth :: Maybe Double, + _slcFactor :: Maybe Double +} + +instance Default SeparatorLineCfg where + def = SeparatorLineCfg { + _slcWidth = Nothing, + _slcFactor = Nothing + } + +instance Semigroup SeparatorLineCfg where + (<>) s1 s2 = SeparatorLineCfg { + _slcWidth = _slcWidth s2 <|> _slcWidth s1, + _slcFactor = _slcFactor s2 <|> _slcFactor s1 + } + +instance Monoid SeparatorLineCfg where + mempty = def + +instance CmbWidth SeparatorLineCfg where + width w = def { + _slcWidth = Just w + } + +instance CmbResizeFactor SeparatorLineCfg where + resizeFactor f = def { + _slcFactor = Just f + } + +-- | Creates a separatorLine widget. +separatorLine :: WidgetNode s e +separatorLine = separatorLine_ def + +-- | Creates a separatorLine widget. Accepts config. +separatorLine_ :: [SeparatorLineCfg] -> WidgetNode s e +separatorLine_ configs = defaultWidgetNode "separatorLine" widget where + config = mconcat (resizeFactor 0 : configs) + widget = makeSeparatorLine config + +makeSeparatorLine :: SeparatorLineCfg -> Widget s e +makeSeparatorLine config = widget where + widget = createSingle () def { + singleGetBaseStyle = getBaseStyle, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + factor = fromMaybe 0 (_slcFactor config) + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.separatorLineStyle + + getSizeReq wenv node = sizeReq where + theme = currentTheme wenv node + direction = wenv ^. L.layoutDirection + width = fromMaybe (theme ^. L.separatorLineWidth) (_slcWidth config) + + isFixed = factor < 0.01 + flexSide = flexSize 10 0.5 + fixedW = fixedSize width + flexW = flexSize width factor + expandW = expandSize width factor + + sizeReq + | isFixed && direction == LayoutNone = (fixedW, fixedW) + | isFixed && direction == LayoutHorizontal = (fixedW, flexSide) + | isFixed = (flexSide, fixedW) + | direction == LayoutNone = (expandW, expandW) + | direction == LayoutHorizontal = (expandW, flexW) + | otherwise = (flexW, expandW) + + render wenv node renderer = do + beginPath renderer + setFillColor renderer fgColor + renderRect renderer lineRect + fill renderer + where + theme = currentTheme wenv node + style = currentStyle wenv node + direction = wenv ^. L.layoutDirection + fgColor = styleFgColor style + width = fromMaybe (theme ^. L.separatorLineWidth) (_slcWidth config) + + Rect cx cy cw ch = getContentArea node style + lineW = cx + (cw - width) / 2 + lineH = cy + (ch - width) / 2 + lineRect + | direction == LayoutNone = Rect cx cy cw ch + | direction == LayoutHorizontal = Rect lineW cy width ch + | otherwise = Rect cx lineH cw width diff --git a/src/Monomer/Widgets/Singles/Slider.hs b/src/Monomer/Widgets/Singles/Slider.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Slider.hs @@ -0,0 +1,492 @@ +{-| +Module : Monomer.Widgets.Singles.Slider +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +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. + +Similar in objective to Dial, but more convenient in some layouts. + +- width: sets the size of the secondary axis of the Slider. +- radius: the radius of the corners of the Slider. +- wheelRate: The rate at which wheel movement affects the number. +- dragRate: The rate at which drag movement affects the number. +- thumbVisible: whether a thumb should be visible or not. +- thumbFactor: the size of the thumb relative to width. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes. +- onChangeReq: WidgetRequest to generate when the value changes. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Singles.Slider ( + hslider, + hslider_, + vslider, + vslider_, + hsliderV, + hsliderV_, + vsliderV, + vsliderV_, + sliderD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens', (&), (^.), (.~), (%~), (<>~)) +import Control.Monad +import Data.Default +import Data.Maybe +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics + +import qualified Data.Sequence as Seq + +import Monomer.Helper +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +-- | Constraints for the values handled by slider widget. +type SliderValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a) + +-- | Configuration options for slider widget. +data SliderCfg s e a = SliderCfg { + _slcRadius :: Maybe Double, + _slcWidth :: Maybe Double, + _slcWheelRate :: Maybe Rational, + _slcDragRate :: Maybe Rational, + _slcThumbVisible :: Maybe Bool, + _slcThumbFactor :: Maybe Double, + _slcOnFocusReq :: [Path -> WidgetRequest s e], + _slcOnBlurReq :: [Path -> WidgetRequest s e], + _slcOnChangeReq :: [a -> WidgetRequest s e] +} + +instance Default (SliderCfg s e a) where + def = SliderCfg { + _slcRadius = Nothing, + _slcWidth = Nothing, + _slcWheelRate = Nothing, + _slcDragRate = Nothing, + _slcThumbVisible = Nothing, + _slcThumbFactor = Nothing, + _slcOnFocusReq = [], + _slcOnBlurReq = [], + _slcOnChangeReq = [] + } + +instance Semigroup (SliderCfg s e a) where + (<>) t1 t2 = SliderCfg { + _slcRadius = _slcRadius t2 <|> _slcRadius t1, + _slcWidth = _slcWidth t2 <|> _slcWidth t1, + _slcWheelRate = _slcWheelRate t2 <|> _slcWheelRate t1, + _slcDragRate = _slcDragRate t2 <|> _slcDragRate t1, + _slcThumbVisible = _slcThumbVisible t2 <|> _slcThumbVisible t1, + _slcThumbFactor = _slcThumbFactor t2 <|> _slcThumbFactor t1, + _slcOnFocusReq = _slcOnFocusReq t1 <> _slcOnFocusReq t2, + _slcOnBlurReq = _slcOnBlurReq t1 <> _slcOnBlurReq t2, + _slcOnChangeReq = _slcOnChangeReq t1 <> _slcOnChangeReq t2 + } + +instance Monoid (SliderCfg s e a) where + mempty = def + +instance CmbWidth (SliderCfg s e a) where + width w = def { + _slcWidth = Just w +} + +instance CmbRadius (SliderCfg s e a) where + radius w = def { + _slcRadius = Just w + } + +instance CmbWheelRate (SliderCfg s e a) Rational where + wheelRate rate = def { + _slcWheelRate = Just rate + } + +instance CmbDragRate (SliderCfg s e a) Rational where + dragRate rate = def { + _slcDragRate = Just rate + } + +instance CmbThumbFactor (SliderCfg s e a) where + thumbFactor w = def { + _slcThumbFactor = Just w + } + +instance CmbThumbVisible (SliderCfg s e a) where + thumbVisible_ w = def { + _slcThumbVisible = Just w + } + +instance WidgetEvent e => CmbOnFocus (SliderCfg s e a) e Path where + onFocus fn = def { + _slcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (SliderCfg s e a) s e Path where + onFocusReq req = def { + _slcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (SliderCfg s e a) e Path where + onBlur fn = def { + _slcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (SliderCfg s e a) s e Path where + onBlurReq req = def { + _slcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (SliderCfg s e a) a e where + onChange fn = def { + _slcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (SliderCfg s e a) s e a where + onChangeReq req = def { + _slcOnChangeReq = [req] + } + +data SliderState = SliderState { + _slsMaxPos :: Integer, + _slsPos :: Integer +} deriving (Eq, Show, Generic) + + +{-| +Creates a horizontal slider using the given lens, providing minimum and maximum +values. +-} +hslider + :: (SliderValue a, WidgetEvent e) + => ALens' s a + -> a + -> a + -> WidgetNode s e +hslider field minVal maxVal = hslider_ field minVal maxVal def + +{-| +Creates a horizontal slider using the given lens, providing minimum and maximum +values. Accepts config. +-} +hslider_ + :: (SliderValue a, WidgetEvent e) + => ALens' s a + -> a + -> a + -> [SliderCfg s e a] + -> WidgetNode s e +hslider_ field minVal maxVal cfg = sliderD_ True wlens minVal maxVal cfg where + wlens = WidgetLens field + +{-| +Creates a vertical slider using the given lens, providing minimum and maximum +values. +-} +vslider + :: (SliderValue a, WidgetEvent e) + => ALens' s a + -> a + -> a + -> WidgetNode s e +vslider field minVal maxVal = vslider_ field minVal maxVal def + +{-| +Creates a vertical slider using the given lens, providing minimum and maximum +values. Accepts config. +-} +vslider_ + :: (SliderValue a, WidgetEvent e) + => ALens' s a + -> a + -> a + -> [SliderCfg s e a] + -> WidgetNode s e +vslider_ field minVal maxVal cfg = sliderD_ False wlens minVal maxVal cfg where + wlens = WidgetLens field + +{-| +Creates a horizontal slider using the given value and onChange event handler, +providing minimum and maximum values. +-} +hsliderV + :: (SliderValue a, WidgetEvent e) + => a + -> (a -> e) + -> a + -> a + -> WidgetNode s e +hsliderV value handler minVal maxVal = hsliderV_ value handler minVal maxVal def + +{-| +Creates a horizontal slider using the given value and onChange event handler, +providing minimum and maximum values. Accepts config. +-} +hsliderV_ + :: (SliderValue a, WidgetEvent e) + => a + -> (a -> e) + -> a + -> a + -> [SliderCfg s e a] + -> WidgetNode s e +hsliderV_ value handler minVal maxVal configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = sliderD_ True widgetData minVal maxVal newConfigs + +{-| +Creates a vertical slider using the given value and onChange event handler, +providing minimum and maximum values. +-} +vsliderV + :: (SliderValue a, WidgetEvent e) + => a + -> (a -> e) + -> a + -> a + -> WidgetNode s e +vsliderV value handler minVal maxVal = vsliderV_ value handler minVal maxVal def + +{-| +Creates a vertical slider using the given value and onChange event handler, +providing minimum and maximum values. Accepts config. +-} +vsliderV_ + :: (SliderValue a, WidgetEvent e) + => a + -> (a -> e) + -> a + -> a + -> [SliderCfg s e a] + -> WidgetNode s e +vsliderV_ value handler minVal maxVal configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = sliderD_ False widgetData minVal maxVal newConfigs + +{-| +Creates a slider providing direction, a WidgetData instance, minimum and maximum +values and config. +-} +sliderD_ + :: (SliderValue a, WidgetEvent e) + => Bool + -> WidgetData s a + -> a + -> a + -> [SliderCfg s e a] + -> WidgetNode s e +sliderD_ isHz widgetData minVal maxVal configs = sliderNode where + config = mconcat configs + state = SliderState 0 0 + widget = makeSlider isHz widgetData minVal maxVal config state + sliderNode = defaultWidgetNode "slider" widget + & L.info . L.focusable .~ True + +makeSlider + :: (SliderValue a, WidgetEvent e) + => Bool + -> WidgetData s a + -> a + -> a + -> SliderCfg s e a + -> SliderState + -> Widget s e +makeSlider isHz field minVal maxVal config state = widget where + widget = createSingle state def { + singleFocusOnBtnPressed = False, + singleGetBaseStyle = getBaseStyle, + singleInit = init, + singleMerge = merge, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + dragRate + | isJust (_slcDragRate config) = fromJust (_slcDragRate config) + | otherwise = toRational (maxVal - minVal) / 1000 + + getBaseStyle wenv node = Just style where + style = collectTheme wenv L.sliderStyle + + init wenv node = resultNode resNode where + currVal = widgetDataGet (wenv ^. L.model) field + newState = newStateFromValue currVal + resNode = node + & L.widget .~ makeSlider isHz field minVal maxVal config newState + + merge wenv newNode oldNode oldState = resultNode resNode where + stateVal = valueFromPos (_slsPos oldState) + modelVal = widgetDataGet (wenv ^. L.model) field + newState + | isNodePressed wenv newNode = oldState + | stateVal == modelVal = oldState + | otherwise = newStateFromValue modelVal + resNode = newNode + & L.widget .~ makeSlider isHz field minVal maxVal config newState + + handleEvent wenv node target evt = case evt of + Focus prev -> handleFocusChange node prev (_slcOnFocusReq config) + + Blur next -> handleFocusChange node next (_slcOnBlurReq config) + + KeyAction mod code KeyPressed + | ctrlPressed && isInc code -> handleNewPos (pos + warpSpeed) + | ctrlPressed && isDec code -> handleNewPos (pos - warpSpeed) + | shiftPressed && isInc code -> handleNewPos (pos + baseSpeed) + | shiftPressed && isDec code -> handleNewPos (pos - baseSpeed) + | isInc code -> handleNewPos (pos + fastSpeed) + | isDec code -> handleNewPos (pos - fastSpeed) + where + ctrlPressed = isShortCutControl wenv mod + (isDec, isInc) + | isHz = (isKeyLeft, isKeyRight) + | otherwise = (isKeyDown, isKeyUp) + + baseSpeed = max 1 $ round (fromIntegral maxPos / 1000) + fastSpeed = max 1 $ round (fromIntegral maxPos / 100) + warpSpeed = max 1 $ round (fromIntegral maxPos / 10) + + handleNewPos newPos + | validPos /= pos = resultFromPos validPos [] + | otherwise = Nothing + where + validPos = clamp 0 maxPos newPos + + Move point + | isNodePressed wenv node -> resultFromPoint point [] + + ButtonAction point btn BtnPressed clicks -> resultFromPoint point reqs where + reqs + | shiftPressed = [] + | otherwise = [SetFocus widgetId] + + ButtonAction point btn BtnReleased clicks -> resultFromPoint point [] + + WheelScroll _ (Point _ wy) wheelDirection -> resultFromPos newPos [] where + wheelCfg = fromMaybe (theme ^. L.sliderWheelRate) (_slcWheelRate config) + wheelRate = fromRational wheelCfg + tmpPos = pos + round (wy * wheelRate) + newPos = clamp 0 maxPos tmpPos + _ -> Nothing + where + theme = currentTheme wenv node + style = currentStyle wenv node + vp = getContentArea node style + widgetId = node ^. L.info . L.widgetId + shiftPressed = wenv ^. L.inputStatus . L.keyMod . L.leftShift + SliderState maxPos pos = state + + resultFromPoint point reqs = resultFromPos newPos reqs where + newPos = posFromMouse isHz vp point + + resultFromPos newPos extraReqs = Just newResult where + newState = state { + _slsPos = newPos + } + newNode = node + & L.widget .~ makeSlider isHz field minVal maxVal config newState + result = resultReqs newNode [RenderOnce] + newVal = valueFromPos newPos + + reqs = widgetDataSet field newVal + ++ fmap ($ newVal) (_slcOnChangeReq config) + ++ extraReqs + newResult + | pos /= newPos = result + & L.requests <>~ Seq.fromList reqs + | otherwise = result + + getSizeReq wenv node = req where + theme = currentTheme wenv node + maxPos = realToFrac (toRational (maxVal - minVal) / dragRate) + width = fromMaybe (theme ^. L.sliderWidth) (_slcWidth config) + req + | isHz = (expandSize maxPos 1, fixedSize width) + | otherwise = (fixedSize width, expandSize maxPos 1) + + render wenv node renderer = do + drawRect renderer sliderBgArea (Just sndColor) sliderRadius + + drawInScissor renderer True sliderFgArea $ + drawRect renderer sliderBgArea (Just fgColor) sliderRadius + + when thbVisible $ + drawEllipse renderer thbArea (Just hlColor) + where + theme = currentTheme wenv node + style = currentStyle wenv node + + fgColor = styleFgColor style + hlColor = styleHlColor style + sndColor = styleSndColor style + + radiusW = _slcRadius config <|> theme ^. L.sliderRadius + sliderRadius = radius <$> radiusW + SliderState maxPos pos = state + posPct = fromIntegral pos / fromIntegral maxPos + carea = getContentArea node style + Rect cx cy cw ch = carea + barW + | isHz = ch + | otherwise = cw + -- Thumb + thbVisible = fromMaybe False (_slcThumbVisible config) + thbF = fromMaybe (theme ^. L.sliderThumbFactor) (_slcThumbFactor config) + thbW = thbF * barW + thbPos dim = (dim - thbW) * posPct + thbDif = (thbW - barW) / 2 + thbArea + | isHz = Rect (cx + thbPos cw) (cy - thbDif) thbW thbW + | otherwise = Rect (cx - thbDif) (cy + ch - thbW - thbPos ch) thbW thbW + -- Bar + tw2 = thbW / 2 + sliderBgArea + | not thbVisible = carea + | isHz = fromMaybe def (subtractFromRect carea tw2 tw2 0 0) + | otherwise = fromMaybe def (subtractFromRect carea 0 0 tw2 tw2) + sliderFgArea + | isHz = sliderBgArea & L.w %~ (*posPct) + | otherwise = sliderBgArea + & L.y %~ (+ (sliderBgArea ^. L.h * (1 - posPct))) + & L.h %~ (*posPct) + + newStateFromValue currVal = newState where + newMaxPos = round (toRational (maxVal - minVal) / dragRate) + newPos = round (toRational (currVal - minVal) / dragRate) + newState = SliderState { + _slsMaxPos = newMaxPos, + _slsPos = newPos + } + + posFromMouse isHz vp point = newPos where + SliderState maxPos _ = state + dv + | isHz = point ^. L.x - vp ^. L.x + | otherwise = vp ^. L.y + vp ^. L.h - point ^. L.y + tmpPos + | isHz = round (dv * fromIntegral maxPos / vp ^. L.w) + | otherwise = round (dv * fromIntegral maxPos / vp ^. L.h) + newPos = clamp 0 maxPos tmpPos + + valueFromPos newPos = newVal where + newVal = minVal + fromFractional (dragRate * fromIntegral newPos) diff --git a/src/Monomer/Widgets/Singles/Spacer.hs b/src/Monomer/Widgets/Singles/Spacer.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/Spacer.hs @@ -0,0 +1,115 @@ +{-| +Module : Monomer.Widgets.Singles.Spacer +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Spacer is used for adding a fixed space between two widgets. +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. + +Configs: + +- width: the max width for spacer, the reference for filler. +- resizeFactor: flexibility to have more or less spaced assigned. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Singles.Spacer ( + spacer, + spacer_, + filler, + filler_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((^.)) +import Data.Default +import Data.Maybe +import Data.Tuple + +import Monomer.Widgets.Single + +import qualified Monomer.Core.Lens as L + +-- | Configuration options for spacer widget. +data SpacerCfg = SpacerCfg { + _spcWidth :: Maybe Double, + _spcFactor :: Maybe Double +} + +instance Default SpacerCfg where + def = SpacerCfg { + _spcWidth = Nothing, + _spcFactor = Nothing + } + +instance Semigroup SpacerCfg where + (<>) s1 s2 = SpacerCfg { + _spcWidth = _spcWidth s2 <|> _spcWidth s1, + _spcFactor = _spcFactor s2 <|> _spcFactor s1 + } + +instance Monoid SpacerCfg where + mempty = def + +instance CmbWidth SpacerCfg where + width w = def { + _spcWidth = Just w + } + +instance CmbResizeFactor SpacerCfg where + resizeFactor f = def { + _spcFactor = Just f + } + +-- | Creates a spacer widget. +spacer :: WidgetNode s e +spacer = spacer_ def + +-- | Creates a spacer widget. Accepts config. +spacer_ :: [SpacerCfg] -> WidgetNode s e +spacer_ configs = defaultWidgetNode "spacer" widget where + config = mconcat (resizeFactor 0 : configs) + widget = makeSpacer config + +-- | Creates a filler widget. +filler :: WidgetNode s e +filler = filler_ def + +-- | Creates a filler widget. Accepts config. +filler_ :: [SpacerCfg] -> WidgetNode s e +filler_ configs = defaultWidgetNode "filler" widget where + config = mconcat configs + widget = makeSpacer config + +makeSpacer :: SpacerCfg -> Widget s e +makeSpacer config = widget where + widget = createSingle () def { + singleGetSizeReq = getSizeReq + } + + getSizeReq wenv node = sizeReq where + direction = wenv ^. L.layoutDirection + factor = fromMaybe 0.5 (_spcFactor config) + isFixed = factor < 0.01 + width + | isFixed = fromMaybe 10 (_spcWidth config) + | otherwise = fromMaybe 5 (_spcWidth config) + + flexSide = flexSize 5 0.5 + fixedW = fixedSize width + flexW = flexSize width factor + expandW = expandSize width factor + + sizeReq + | isFixed && direction == LayoutNone = (fixedW, fixedW) + | isFixed && direction == LayoutHorizontal = (fixedW, flexSide) + | isFixed = (flexSide, fixedW) + | direction == LayoutNone = (expandW, expandW) + | direction == LayoutHorizontal = (expandW, flexW) + | otherwise = (flexW, expandW) diff --git a/src/Monomer/Widgets/Singles/TextArea.hs b/src/Monomer/Widgets/Singles/TextArea.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/TextArea.hs @@ -0,0 +1,917 @@ +{-| +Module : Monomer.Widgets.Singles.TextArea +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Input field for multi line Text. + +Configs: + +- maxLength: the maximum length of input text. +- maxLines: the maximum number of lines of input text. +- 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. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes. +- onChangeReq: WidgetRequest to generate when the value changes. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.TextArea ( + textArea, + textArea_, + textAreaV, + textAreaV_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (^?), (.~), (%~), (<>~), ALens', ix, view) +import Control.Monad (forM_, when) +import Data.Default +import Data.Foldable (toList) +import Data.Maybe +import Data.Sequence (Seq(..), (|>)) +import Data.Tuple (swap) +import Data.Text (Text) +import GHC.Generics + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Helper +import Monomer.Widgets.Containers.Scroll +import Monomer.Widgets.Single + +import qualified Monomer.Lens as L + +defCaretW :: Double +defCaretW = 2 + +defCaretMs :: Int +defCaretMs = 500 + +data TextAreaCfg s e = TextAreaCfg { + _tacCaretWidth :: Maybe Double, + _tacCaretMs :: Maybe Int, + _tacMaxLength :: Maybe Int, + _tacMaxLines :: Maybe Int, + _tacAcceptTab :: Maybe Bool, + _tacSelectOnFocus :: Maybe Bool, + _tacOnFocusReq :: [Path -> WidgetRequest s e], + _tacOnBlurReq :: [Path -> WidgetRequest s e], + _tacOnChangeReq :: [Text -> WidgetRequest s e] +} + +instance Default (TextAreaCfg s e) where + def = TextAreaCfg { + _tacCaretWidth = Nothing, + _tacCaretMs = Nothing, + _tacMaxLength = Nothing, + _tacMaxLines = Nothing, + _tacAcceptTab = Nothing, + _tacSelectOnFocus = Nothing, + _tacOnFocusReq = [], + _tacOnBlurReq = [], + _tacOnChangeReq = [] + } + +instance Semigroup (TextAreaCfg s e) where + (<>) t1 t2 = TextAreaCfg { + _tacCaretWidth = _tacCaretWidth t2 <|> _tacCaretWidth t1, + _tacCaretMs = _tacCaretMs t2 <|> _tacCaretMs t1, + _tacMaxLength = _tacMaxLength t2 <|> _tacMaxLength t1, + _tacMaxLines = _tacMaxLines t2 <|> _tacMaxLines t1, + _tacAcceptTab = _tacAcceptTab t2 <|> _tacAcceptTab t1, + _tacSelectOnFocus = _tacSelectOnFocus t2 <|> _tacSelectOnFocus t1, + _tacOnFocusReq = _tacOnFocusReq t1 <> _tacOnFocusReq t2, + _tacOnBlurReq = _tacOnBlurReq t1 <> _tacOnBlurReq t2, + _tacOnChangeReq = _tacOnChangeReq t1 <> _tacOnChangeReq t2 + } + +instance Monoid (TextAreaCfg s e) where + mempty = def + +instance CmbCaretWidth (TextAreaCfg s e) Double where + caretWidth w = def { + _tacCaretWidth = Just w + } + +instance CmbCaretMs (TextAreaCfg s e) Int where + caretMs ms = def { + _tacCaretMs = Just ms + } + +instance CmbMaxLength (TextAreaCfg s e) where + maxLength len = def { + _tacMaxLength = Just len + } + +instance CmbMaxLines (TextAreaCfg s e) where + maxLines lines = def { + _tacMaxLines = Just lines + } + +instance CmbAcceptTab (TextAreaCfg s e) where + acceptTab_ accept = def { + _tacAcceptTab = Just accept + } + +instance CmbSelectOnFocus (TextAreaCfg s e) where + selectOnFocus_ sel = def { + _tacSelectOnFocus = Just sel + } + +instance WidgetEvent e => CmbOnFocus (TextAreaCfg s e) e Path where + onFocus fn = def { + _tacOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (TextAreaCfg s e) s e Path where + onFocusReq req = def { + _tacOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (TextAreaCfg s e) e Path where + onBlur fn = def { + _tacOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (TextAreaCfg s e) s e Path where + onBlurReq req = def { + _tacOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (TextAreaCfg s e) Text e where + onChange fn = def { + _tacOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (TextAreaCfg s e) s e Text where + onChangeReq req = def { + _tacOnChangeReq = [req] + } + +data HistoryStep = HistoryStep { + _tahText :: !Text, + _tahCursorPos :: !(Int, Int), + _tahSelStart :: Maybe (Int, Int) +} deriving (Eq, Show, Generic) + +data TextAreaState = TextAreaState { + _tasText :: Text, + _tasTextMetrics :: TextMetrics, + _tasTextStyle :: Maybe TextStyle, + _tasCursorPos :: (Int, Int), + _tasSelStart :: Maybe (Int, Int), + _tasTextLines :: Seq TextLine, + _tasHistory :: Seq HistoryStep, + _tasHistoryIdx :: Int, + _tasFocusStart :: Int +} deriving (Eq, Show, Generic) + +instance Default TextAreaState where + def = TextAreaState { + _tasText = "", + _tasTextMetrics = def, + _tasTextStyle = def, + _tasCursorPos = def, + _tasSelStart = def, + _tasTextLines = Seq.empty, + _tasHistory = Seq.empty, + _tasHistoryIdx = 0, + _tasFocusStart = 0 + } + +-- | Creates a text area using the given lens. +textArea :: WidgetEvent e => ALens' s Text -> WidgetNode s e +textArea field = textArea_ field def + +-- | Creates a text area using the given lens. Accepts config. +textArea_ + :: WidgetEvent e => ALens' s Text -> [TextAreaCfg s e] -> WidgetNode s e +textArea_ field configs = textAreaD_ wdata configs where + wdata = WidgetLens field + +-- | Creates a text area using the given value and onChange event handler. +textAreaV :: WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e +textAreaV value handler = textAreaV_ value handler def + +-- | Creates a text area using the given value and onChange event handler. +-- | Accepts config. +textAreaV_ + :: WidgetEvent e => Text -> (Text -> e) -> [TextAreaCfg s e] -> WidgetNode s e +textAreaV_ value handler configs = textAreaD_ wdata newConfig where + wdata = WidgetValue value + newConfig = onChange handler : configs + +-- | Creates a text area providing a WidgetData instance and config. +textAreaD_ + :: WidgetEvent e + => WidgetData s Text + -> [TextAreaCfg s e] + -> WidgetNode s e +textAreaD_ wdata configs = scrollNode where + config = mconcat configs + widget = makeTextArea wdata config def + node = defaultWidgetNode "textArea" widget + & L.info . L.focusable .~ True + scrollCfg = [scrollStyle L.textAreaStyle, scrollFwdStyle scrollFwdDefault] + scrollNode = scroll_ scrollCfg node + +makeTextArea + :: WidgetEvent e + => WidgetData s Text + -> TextAreaCfg s e + -> TextAreaState + -> Widget s e +makeTextArea wdata config state = widget where + widget = createSingle state def { + singleInit = init, + singleMerge = merge, + singleDispose = dispose, + singleHandleEvent = handleEvent, + singleGetSizeReq = getSizeReq, + singleRender = render + } + + caretMs = fromMaybe defCaretMs (_tacCaretMs config) + maxLength = _tacMaxLength config + maxLines = _tacMaxLines config + getModelValue wenv = widgetDataGet (_weModel wenv) wdata + -- State + currText = _tasText state + textLines = _tasTextLines state + -- Helpers + validText state = validLen && validLines where + text = _tasText state + lines = _tasTextLines state + validLen = T.length text <= fromMaybe maxBound maxLength + validLines = length lines <= fromMaybe maxBound maxLines + line idx + | idx >= 0 && idx < length textLines = Seq.index textLines idx ^. L.text + | otherwise = "" + lineLen = T.length . line + totalLines = length textLines + lastPos = (lineLen (totalLines - 1), totalLines) + + init wenv node = resultNode newNode where + text = getModelValue wenv + newState = stateFromText wenv node state text + newNode = node + & L.widget .~ makeTextArea wdata config newState + + merge wenv node oldNode oldState = resultNode newNode where + oldText = _tasText oldState + newText = getModelValue wenv + newState + | oldText /= newText = stateFromText wenv node state newText + | otherwise = oldState + newNode = node + & L.widget .~ makeTextArea wdata config newState + + dispose wenv node = resultReqs node reqs where + widgetId = node ^. L.info . L.widgetId + reqs = [RenderStop widgetId] + + handleKeyPress wenv mod code + | isDelBackWordNoSel = Just removeWordL + | isDelBackWord = Just (replaceText state selStart "") + | isBackspace && emptySel = Just removeCharL + | isBackspace = 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 + | isMoveDown = Just $ moveCursor txt (tpX, tpY + 1) Nothing + | isMovePageUp = Just $ moveCursor txt (tpX, tpY - vpLines) Nothing + | isMovePageDown = Just $ moveCursor txt (tpX, tpY + vpLines) Nothing + | isMoveWordL = Just $ moveCursor txt prevWordPos Nothing + | isMoveWordR = Just $ moveCursor txt nextWordPos Nothing + | isMoveLineL = Just $ moveCursor txt (0, tpY) Nothing + | isMoveLineR = Just $ moveCursor txt (lineLen tpY, tpY) Nothing + | isMoveFullUp = Just $ moveCursor txt (0, 0) Nothing + | isMoveFullDn = Just $ moveCursor txt lastPos Nothing + | isSelectAll = Just $ moveCursor txt (0, 0) (Just lastPos) + | isSelectLeft = Just $ moveCursor txt (tpX - 1, tpY) (Just tp) + | isSelectRight = Just $ moveCursor txt (tpX + 1, tpY) (Just tp) + | isSelectUp = Just $ moveCursor txt (tpX, tpY - 1) (Just tp) + | isSelectDown = Just $ moveCursor txt (tpX, tpY + 1) (Just tp) + | isSelectPageUp = Just $ moveCursor txt (tpX, tpY - vpLines) (Just tp) + | isSelectPageDown = Just $ moveCursor txt (tpX, tpY + vpLines) (Just tp) + | isSelectWordL = Just $ moveCursor txt prevWordPos (Just tp) + | isSelectWordR = Just $ moveCursor txt nextWordPos (Just tp) + | isSelectLineL = Just $ moveCursor txt (0, tpY) (Just tp) + | isSelectLineR = Just $ moveCursor txt (lineLen tpY, tpY) (Just tp) + | isSelectFullUp = Just $ moveCursor txt (0, 0) (Just tp) + | isSelectFullDn = Just $ moveCursor txt lastPos (Just tp) + | isDeselectLeft = Just $ moveCursor txt minTpSel Nothing + | isDeselectRight = Just $ moveCursor txt maxTpSel Nothing + | isDeselectUp = Just $ moveCursor txt minTpSel Nothing + | isDeselectDown = Just $ moveCursor txt maxTpSel Nothing + | otherwise = Nothing + where + txt = currText + txtLen = T.length txt + textMetrics = _tasTextMetrics state + tp@(tpX, tpY) = _tasCursorPos state + selStart = _tasSelStart state + + (minTpSel, maxTpSel) + | swap tp <= swap (fromJust selStart) = (tp, fromJust selStart) + | otherwise = (fromJust selStart, tp) + emptySel = isNothing selStart + vpLines = round (wenv ^. L.viewport . L.h / textMetrics ^. L.lineH) + activeSel = isJust selStart + + prevTxt + | tpX > 0 = T.take tpX (line tpY) + | otherwise = line (tpY - 1) + prevWordStart = T.dropWhileEnd (not . delim) . T.dropWhileEnd delim $ prevTxt + prevWordPos + | tpX == 0 && tpY == 0 = (tpX, tpY) + | tpX > 0 = (T.length prevWordStart, tpY) + | otherwise = (T.length prevWordStart, tpY - 1) + + nextTxt + | tpX < lineLen tpY = T.drop tpX (line tpY) + | otherwise = line (tpY + 1) + nextWordEnd = T.dropWhile (not . delim) . T.dropWhile delim $ nextTxt + nextWordPos + | tpX == lineLen tpY && tpY == length textLines - 1 = (tpX, tpY) + | tpX < lineLen tpY = (lineLen tpY - T.length nextWordEnd, tpY) + | otherwise = (lineLen (tpY + 1) - T.length nextWordEnd, tpY + 1) + + isShift = _kmLeftShift mod + isLeft = isKeyLeft code + isRight = isKeyRight code + isUp = isKeyUp code + isDown = isKeyDown code + isHome = isKeyHome code + isEnd = isKeyEnd code + isPageUp = isKeyPageUp code + isPageDown = isKeyPageDown code + + isWordMod + | isMacOS wenv = _kmLeftAlt mod + | otherwise = _kmLeftCtrl mod + isLineMod + | isMacOS wenv = _kmLeftCtrl mod || _kmLeftGUI mod + | otherwise = _kmLeftAlt mod + isAllMod + | isMacOS wenv = _kmLeftGUI mod + | otherwise = _kmLeftCtrl mod + + isBackspace = isKeyBackspace code + isDelBackWord = isBackspace && isWordMod + isDelBackWordNoSel = isDelBackWord && emptySel + + isMove = not isShift && not isWordMod && not isLineMod + isMoveWord = not isShift && isWordMod && not isLineMod + isMoveLine = not isShift && isLineMod && not isWordMod + + isSelect = isShift && not isWordMod && not isLineMod + isSelectWord = isShift && isWordMod && not isLineMod + isSelectLine = isShift && isLineMod && not isWordMod + + isMoveLeft = isMove && not activeSel && isLeft + isMoveRight = isMove && not activeSel && isRight + isMoveWordL = isMoveWord && isLeft + isMoveWordR = isMoveWord && isRight + isMoveLineL = (isMoveLine && isLeft) || (not isShift && isHome) + isMoveLineR = (isMoveLine && isRight) || (not isShift && isEnd) + isMoveFullUp = isMoveLine && isUp + isMoveFullDn = isMoveLine && isDown + isMoveUp = isMove && not activeSel && isUp + isMoveDown = isMove && not activeSel && isDown + isMovePageUp = isMove && not activeSel && isPageUp + isMovePageDown = isMove && not activeSel && isPageDown + + isSelectAll = isAllMod && isKeyA code + isSelectLeft = isSelect && isLeft + isSelectRight = isSelect && isRight + isSelectUp = isSelect && isUp + isSelectDown = isSelect && isDown + isSelectPageUp = isSelect && isPageUp + isSelectPageDown = isSelect && isPageDown + isSelectWordL = isSelectWord && isLeft + isSelectWordR = isSelectWord && isRight + isSelectLineL = (isSelectLine && isLeft) || (isShift && isHome) + isSelectLineR = (isSelectLine && isRight) || (isShift && isEnd) + isSelectFullUp = isSelectLine && isUp + isSelectFullDn = isSelectLine && isDown + + isDeselectLeft = isMove && activeSel && isLeft + isDeselectRight = isMove && activeSel && isRight + isDeselectUp = isMove && activeSel && isUp + isDeselectDown = isMove && activeSel && isDown + + replaceFix sel text = replaceText state (Just $ fixPos sel) text + removeCharL + | tpX > 0 = replaceFix (tpX - 1, tpY) "" + | otherwise = replaceFix (lineLen (tpY - 1), tpY - 1) "" + removeWordL = replaceFix prevWordPos "" + moveCursor txt newPos newSel + | isJust selStart && isNothing newSel = (txt, fixedPos, Nothing) + | isJust selStart && Just fixedPos == selStart = (txt, fixedPos, Nothing) + | isJust selStart = (txt, fixedPos, selStart) + | Just fixedPos == fixedSel = (txt, fixedPos, Nothing) + | otherwise = (txt, fixedPos, fixedSel) + where + fixedPos = fixPos newPos + fixedSel = fmap fixPos newSel + fixPos (cX, cY) = result where + nlines = length textLines + vcY = clamp 0 (nlines - 1) cY + vcX = clamp 0 (lineLen tpY) cX + ncX = clamp 0 (lineLen vcY) cX + sameX = vcX == tpX + sameY = vcY == tpY + result + | sameY && cX < 0 && vcY == 0 = (0, 0) + | sameY && cX < 0 && vcY > 0 = (lineLen (vcY - 1) + cX + 1, vcY - 1) + | sameY && cX > lineLen vcY && vcY < nlines - 1 = (cX - lineLen vcY - 1, vcY + 1) + | sameX && cX > lineLen vcY = (min cX (lineLen vcY), vcY) + | otherwise = (ncX, vcY) + + handleEvent wenv node target evt = case evt of + ButtonAction point btn BtnPressed clicks + | clicks == 1 -> Just result where + newPos = findClosestGlyphPos state (localPoint point) + newState = state { + _tasCursorPos = newPos, + _tasSelStart = Nothing + } + newNode = node + & L.widget .~ makeTextArea wdata config newState + result = resultReqs newNode [RenderOnce] + + -- Select word if clicked twice in a row + ButtonAction point btn BtnReleased clicks + | clicks == 2 -> result where + (tx, ty) = findClosestGlyphPos state (localPoint point) + currText = Seq.index textLines ty ^. L.text + (part1, part2) = T.splitAt tx currText + txtLen = T.length currText + wordStart = T.dropWhileEnd (not . delim) part1 + wordStartIdx = T.length wordStart + wordEnd = T.dropWhile (not . delim) part2 + wordEndIdx = txtLen - T.length wordEnd + newPos = (wordStartIdx, ty) + newSel = Just (wordEndIdx, ty) + newState = state { + _tasCursorPos = newPos, + _tasSelStart = newSel + } + newNode = node + & L.widget .~ makeTextArea wdata config newState + result + | ty < totalLines = Just (resultReqs newNode [RenderOnce]) + | otherwise = Nothing + + -- Select line if clicked three times in a row + ButtonAction point btn BtnReleased clicks + | clicks == 3 -> result where + (tx, ty) = findClosestGlyphPos state (localPoint point) + glyphs = Seq.index textLines ty ^. L.glyphs + newPos = (0, ty) + newSel = Just (length glyphs, ty) + newState = state { + _tasCursorPos = newPos, + _tasSelStart = newSel + } + newNode = node + & L.widget .~ makeTextArea wdata config newState + result + | ty < totalLines = Just (resultReqs newNode [RenderOnce]) + | otherwise = Nothing + + -- Select all if clicked four times in a row + ButtonAction point btn BtnReleased clicks + | clicks == 4 -> result where + glyphs = Seq.index textLines (totalLines - 1) ^. L.glyphs + newPos = (0, 0) + newSel = Just (length glyphs, totalLines - 1) + newState = state { + _tasCursorPos = newPos, + _tasSelStart = newSel + } + newNode = node + & L.widget .~ makeTextArea wdata config newState + result + | totalLines > 0 = Just (resultReqs newNode [RenderOnce]) + | otherwise = Nothing + + Move point + | isNodePressed wenv node -> Just result where + curPos = _tasCursorPos state + selStart = _tasSelStart state + newPos = findClosestGlyphPos state (localPoint point) + newSel = selStart <|> Just curPos + newState = state { + _tasCursorPos = newPos, + _tasSelStart = newSel + } + scrollReq = generateScrollReq wenv node newState + newNode = node + & L.widget .~ makeTextArea wdata config newState + result = resultReqs newNode (RenderOnce : scrollReq) + + 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 + | otherwise -> fmap handleKeyRes (handleKeyPress wenv mod code) + where + acceptTab = fromMaybe False (_tacAcceptTab config) + selectedText = fromMaybe "" (getSelection state) + clipboardReq = SetClipboard (ClipboardText selectedText) + + resultCopy = resultReqs node [clipboardReq] + resultPaste = resultReqs node [GetClipboard widgetId] + resultCut = insertText wenv node "" + & L.requests <>~ Seq.singleton clipboardReq + resultReturn = insertText wenv node "\n" + resultTab = insertText wenv node " " + & L.requests <>~ Seq.singleton IgnoreParentEvents + + history = _tasHistory state + historyIdx = _tasHistoryIdx state + + bwdState = addHistory state (historyIdx == length history) + + moveHistory state steps = result where + newIdx = clamp 0 (length history) (historyIdx + steps) + newState = restoreHistory wenv node state newIdx + newNode = node + & L.widget .~ makeTextArea wdata config newState + result = resultReqs newNode (generateReqs wenv node newState) + + handleKeyRes (newText, newPos, newSel) = result where + tmpState = addHistory state (_tasText state /= newText) + newState = (stateFromText wenv node tmpState newText) { + _tasCursorPos = newPos, + _tasSelStart = newSel + } + newNode = node + & L.widget .~ makeTextArea wdata config newState + result = resultReqs newNode (generateReqs wenv node newState) + + TextInput newText -> Just result where + result = insertText wenv node newText + + Clipboard (ClipboardText newText) -> Just result where + result = insertText wenv node newText + + Focus prev -> Just result where + selectOnFocus = fromMaybe False (_tacSelectOnFocus config) + tmpState + | selectOnFocus && T.length currText > 0 = state { + _tasCursorPos = lastPos, + _tasSelStart = Just (0, 0) + } + | otherwise = state + newState = tmpState { + _tasFocusStart = wenv ^. L.timestamp + } + reqs = [RenderEvery widgetId caretMs Nothing, StartTextInput viewport] + newNode = node + & L.widget .~ makeTextArea wdata config newState + newResult = resultReqs newNode reqs + focusRs = handleFocusChange newNode prev (_tacOnFocusReq config) + result = maybe newResult (newResult <>) focusRs + + Blur next -> Just result where + reqs = [RenderStop widgetId, StopTextInput] + newResult = resultReqs node reqs + blurRes = handleFocusChange node next (_tacOnBlurReq config) + result = maybe newResult (newResult <>) blurRes + _ -> Nothing + + where + widgetId = node ^. L.info . L.widgetId + viewport = node ^. L.info . L.viewport + style = currentStyle wenv node + Rect cx cy cw ch = getContentArea node style + localPoint point = subPoint point (Point cx cy) + + insertText wenv node addedText = result where + currSel = _tasSelStart state + (newText, newPos, newSel) = replaceText state currSel addedText + tmpState = addHistory state (_tasText state /= newText) + newState = (stateFromText wenv node tmpState newText) { + _tasCursorPos = newPos, + _tasSelStart = newSel + } + newNode = node + & L.widget .~ makeTextArea wdata config newState + newReqs = generateReqs wenv node newState + result + | validText newState = resultReqs newNode newReqs + | otherwise = resultNode node + + generateReqs wenv node newState = reqs ++ reqScroll where + widgetId = node ^. L.info . L.widgetId + oldText = _tasText state + newText = _tasText newState + reqUpdate = widgetDataSet wdata newText + reqOnChange = fmap ($ newText) (_tacOnChangeReq config) + reqResize = [ResizeWidgetsImmediate widgetId] + reqScroll = generateScrollReq wenv node newState + reqs + | oldText /= newText = reqUpdate ++ reqOnChange ++ reqResize + | otherwise = [] + + generateScrollReq wenv node newState = scrollReq where + style = currentStyle wenv node + scPath = parentPath node + scWid = findWidgetIdFromPath wenv scPath + contentArea = getContentArea node style + offset = Point (contentArea ^. L.x) (contentArea ^. L.y) + caretRect = getCaretRect config newState True + -- Padding/border added to show left/top borders when moving near them + scrollRect = fromMaybe caretRect (addOuterBounds style caretRect) + scrollMsg = ScrollTo $ moveRect offset scrollRect + scrollReq + | rectInRect caretRect (wenv ^. L.viewport) || isNothing scWid = [] + | otherwise = [SendMessage (fromJust scWid) scrollMsg] + + getSizeReq wenv node = sizeReq where + Size w h = getTextLinesSize textLines + {- getTextLines does not return the vertical spacing for the last line, but + we need it since the selection rect displays it. -} + spaceV = getSpaceV textLines + sizeReq = (minWidth (max 100 w), minHeight (max 20 (h + spaceV))) + + render wenv node renderer = + drawInTranslation renderer offset $ do + when selRequired $ + forM_ selRects $ \rect -> + when (rect ^. L.w > 0) $ + drawRect renderer rect (Just selColor) Nothing + + forM_ textLines (drawTextLine renderer style) + + when caretRequired $ + drawRect renderer caretRect (Just caretColor) Nothing + where + style = currentStyle wenv node + contentArea = getContentArea node style + ts = _weTimestamp wenv + offset = Point (contentArea ^. L.x) (contentArea ^. L.y) + focused = isNodeFocused wenv node + + caretTs = ts - _tasFocusStart state + caretRequired = focused && even (caretTs `div` caretMs) + caretColor = styleFontColor style + caretRect = getCaretRect config state False + + 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) + (cursorX, cursorY) = _tasCursorPos state + TextMetrics _ _ lineh _ = _tasTextMetrics state + textLines = _tasTextLines state + + (lineRect, glyphs, spaceV) = 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 + + 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 + +getSelectionRects :: TextAreaState -> Rect -> [Rect] +getSelectionRects state contentArea = rects where + currPos = _tasCursorPos state + currSel = fromMaybe def (_tasSelStart state) + TextMetrics _ _ lineh _ = _tasTextMetrics state + textLines = _tasTextLines state + + spaceV = getSpaceV textLines + line idx + | length textLines > idx = Seq.index textLines idx ^. L.text + | otherwise = "" + lineLen = T.length . line + + glyphs idx + | length textLines > idx = Seq.index textLines idx ^. L.glyphs + | otherwise = Seq.empty + glyphPos posx posy + | posx == 0 = 0 + | posx == lineLen posy = _glpXMax (Seq.index (glyphs posy) (posx - 1)) + | otherwise = _glpXMin (Seq.index (glyphs posy) posx) + + ((selX1, selY1), (selX2, selY2)) + | swap currPos <= swap currSel = (currPos, currSel) + | otherwise = (currSel, currPos) + + updateRect rect = rect + & L.h .~ lineh + spaceV + & 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 + rects + | selY1 == selY2 = [makeRect selX1 selX2 selY1] + | otherwise = begin : middle ++ end where + begin = makeRect selX1 (lineLen selY1) selY1 + middleLines = Seq.drop (selY1 + 1) . Seq.take selY2 $ textLines + middle = toList (updateRect . view L.rect <$> middleLines) + end = [makeRect 0 selX2 selY2] + +stateFromText + :: WidgetEnv s e -> WidgetNode s e -> TextAreaState -> Text -> TextAreaState +stateFromText wenv node state text = newState where + style = currentStyle wenv node + fontMgr = wenv ^. L.fontManager + newTextMetrics = getTextMetrics wenv style + tmpTextLines = fitTextToWidth fontMgr style maxNumericValue KeepSpaces text + totalH = newTextMetrics ^. L.lineH + getSpaceV tmpTextLines + lastRect = def + & L.y .~ fromIntegral (length tmpTextLines) * totalH + & L.h .~ totalH + + lastTextLine = def + & L.rect .~ lastRect + & L.size .~ Size 0 (lastRect ^. L.h) + newTextLines + | T.isSuffixOf "\n" text = tmpTextLines |> lastTextLine + | otherwise = tmpTextLines + + newState = state { + _tasText = text, + _tasTextMetrics = newTextMetrics, + _tasTextStyle = style ^. L.text, + _tasTextLines = newTextLines + } + +textFromState :: Seq TextLine -> Text +textFromState textLines = T.unlines lines where + lines = toList (view L.text <$> textLines) + +addHistory :: TextAreaState -> Bool -> TextAreaState +addHistory state False = state +addHistory state _ = newState where + text = _tasText state + curPos = _tasCursorPos state + selStart = _tasSelStart state + prevStepIdx = _tasHistoryIdx state + prevSteps = _tasHistory state + steps = Seq.take prevStepIdx prevSteps + newState = state { + _tasHistory = steps |> HistoryStep text curPos selStart, + _tasHistoryIdx = prevStepIdx + 1 + } + +restoreHistory + :: WidgetEnv s e -> WidgetNode s e -> TextAreaState -> Int -> TextAreaState +restoreHistory wenv node state idx + | idx >= 0 && idx < length hist && idx /= histIdx = newState + | otherwise = state + where + hist = _tasHistory state + histIdx = _tasHistoryIdx state + HistoryStep text curPos selStart = Seq.index hist idx + tmpState = stateFromText wenv node state text + newState = tmpState { + _tasCursorPos = curPos, + _tasSelStart = selStart, + _tasHistoryIdx = idx + } + +getSelection + :: TextAreaState + -> Maybe Text +getSelection state = result where + currPos = _tasCursorPos state + currSel = fromJust (_tasSelStart state) + textLines = _tasTextLines state + oldLines = view L.text <$> textLines + + ((selX1, selY1), (selX2, selY2)) + | swap currPos <= swap currSel = (currPos, currSel) + | otherwise = (currSel, currPos) + newText + | selY1 == selY2 = singleLine + | selX2 == 0 = T.unlines . toList $ begin :<| middle + | otherwise = T.unlines . toList $ begin :<| (middle :|> end) + where + singleLine = T.drop selX1 $ T.take selX2 (Seq.index oldLines selY1) + begin = T.drop selX1 $ Seq.index oldLines selY1 + middle = Seq.drop (selY1 + 1) $ Seq.take selY2 oldLines + end = T.take selX2 $ Seq.index oldLines selY2 + result + | isJust (_tasSelStart state) = Just newText + | otherwise = Nothing + +replaceText + :: TextAreaState + -> Maybe (Int, Int) + -> Text + -> (Text, (Int, Int), Maybe (Int, Int)) +replaceText state currSel newTxt + | isJust currSel = replaceSelection lines currPos (fromJust currSel) newTxt + | otherwise = replaceSelection lines currPos currPos newTxt + where + currPos = _tasCursorPos state + lines = _tasTextLines state + +replaceSelection + :: Seq TextLine + -> (Int, Int) + -> (Int, Int) + -> Text + -> (Text, (Int, Int), Maybe (Int, Int)) +replaceSelection textLines currPos currSel addText = result where + oldLines = view L.text <$> textLines + ((selX1, selY1), (selX2, selY2)) + | swap currPos <= swap currSel = (currPos, currSel) + | otherwise = (currSel, currPos) + prevLines = Seq.take selY1 oldLines + postLines = Seq.drop (selY2 + 1) oldLines + returnAdded = T.isSuffixOf "\n" addText + + linePre + | length oldLines > selY1 = T.take selX1 (Seq.index oldLines selY1) + | otherwise = "" + lineSuf + | length oldLines > selY2 = T.drop selX2 (Seq.index oldLines selY2) + | otherwise = "" + addLines + | not returnAdded = Seq.fromList (T.lines addText) + | otherwise = Seq.fromList (T.lines addText) :|> "" + + (newX, newY, midLines) + | length addLines <= 1 = (T.length (linePre <> addText), selY1, singleLine) + | otherwise = (T.length end, selY1 + length addLines - 1, multiline) + where + singleLine = Seq.singleton $ linePre <> addText <> lineSuf + begin = Seq.index addLines 0 + middle = Seq.drop 1 $ Seq.take (length addLines - 1) addLines + end = Seq.index addLines (length addLines - 1) + multiline = (linePre <> begin) :<| (middle :|> (end <> lineSuf)) + + newLines = prevLines <> midLines <> postLines + newText = T.dropEnd 1 $ T.unlines (toList newLines) + result = (newText, (newX, newY), Nothing) + +findClosestGlyphPos :: TextAreaState -> Point -> (Int, Int) +findClosestGlyphPos state point = (newPos, lineIdx) where + Point x y = point + TextMetrics _ _ lineh _ = _tasTextMetrics state + textLines = _tasTextLines state + + totalH = lineh + getSpaceV textLines + lineIdx = clamp 0 (length textLines - 1) (floor (y / totalH)) + lineGlyphs + | null textLines = Seq.empty + | otherwise = Seq.index (view L.glyphs <$> textLines) lineIdx + textLen = getGlyphsMax lineGlyphs + + glyphs + | Seq.null lineGlyphs = Seq.empty + | otherwise = lineGlyphs |> GlyphPos ' ' textLen 0 0 0 0 0 + glyphStart i g = (i, abs (_glpXMin g - x)) + + pairs = Seq.mapWithIndex glyphStart glyphs + cpm (_, g1) (_, g2) = compare g1 g2 + diffs = Seq.sortBy cpm pairs + newPos = maybe 0 fst (Seq.lookup 0 diffs) + +getSpaceV :: Seq TextLine -> Double +getSpaceV textLines = spaceV where + spaceV = unFontSpace $ maybe def (view L.fontSpaceV) (textLines ^? ix 0) + +delim :: Char -> Bool +delim c = c `elem` [' ', '.', ',', '/', '-', ':'] diff --git a/src/Monomer/Widgets/Singles/TextDropdown.hs b/src/Monomer/Widgets/Singles/TextDropdown.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/TextDropdown.hs @@ -0,0 +1,193 @@ +{-| +Module : Monomer.Widgets.Singles.TextDropdown +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +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. + +Configs: + +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetReqest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetReqest to generate when focus is lost. +- onChange: event to raise when selected item changes. +- onChangeReq: WidgetRequest to generate when selected item changes. +- onChangeIdx: event to raise when selected item changes. Includes index, +- onChangeIdxReq: WidgetRequest to generate when selected item changes. Includes +index. +- maxHeight: maximum height of the list when dropdown is expanded. +- itemBasicStyle: style of an item in the list when not selected. +- itemSelectedStyle: style of the selected item in the list. +-} +{-# LANGUAGE ConstraintKinds #-} + +module Monomer.Widgets.Singles.TextDropdown ( + textDropdown, + textDropdown_, + textDropdownV, + textDropdownV_, + textDropdownS, + textDropdownS_, + textDropdownSV, + textDropdownSV_ +) where + +import Control.Lens (ALens') +import Data.Default +import Data.Text (Text, pack) +import TextShow + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Widgets.Containers.Dropdown +import Monomer.Widgets.Singles.Label + +type TextDropdownItem a = DropdownItem a + +{-| +Creates a text dropdown using the given lens. The type must be have a 'TextShow' +instance. +-} +textDropdown + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, TextShow a) + => ALens' s a + -> t a + -> WidgetNode s e +textDropdown field items = newNode where + newNode = textDropdown_ field items showt def + +{-| +Creates a text dropdown using the given lens. Takes a function for converting +the type to Text. Accepts config. +-} +textDropdown_ + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a) + => ALens' s a + -> t a + -> (a -> Text) + -> [DropdownCfg s e a] + -> WidgetNode s e +textDropdown_ field items toText configs = newNode where + newNode = textDropdownD_ (WidgetLens field) items toText configs + +{-| +Creates a text dropdown using the given value and onChange event handler. Takes +a function for converting the type to Text. +-} +textDropdownV + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, TextShow a) + => a + -> (a -> e) + -> t a + -> WidgetNode s e +textDropdownV value handler items = newNode where + newNode = textDropdownV_ value handler items showt def + +{-| +Creates a text dropdown using the given value and onChange event handler. Takes +a function for converting the type to Text. Accepts config. +-} +textDropdownV_ + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a) + => a + -> (a -> e) + -> t a + -> (a -> Text) + -> [DropdownCfg s e a] + -> WidgetNode s e +textDropdownV_ value handler items toText configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = textDropdownD_ widgetData items toText newConfigs + +{-| +Creates a text dropdown providing a WidgetData instance and config. Takes +a function for converting the type to Text. +-} +textDropdownD_ + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a) + => WidgetData s a + -> t a + -> (a -> Text) + -> [DropdownCfg s e a] + -> WidgetNode s e +textDropdownD_ widgetData items toText configs = newNode where + makeMain t = label_ (toText t) [resizeFactorW 0.01] + makeRow t = label_ (toText t) [resizeFactorW 0.01] + newNode = dropdownD_ widgetData items makeMain makeRow configs + +{-| +Creates a text dropdown using the given lens. The type must be have a 'Show' +instance. +-} +textDropdownS + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) + => ALens' s a + -> t a + -> WidgetNode s e +textDropdownS field items = newNode where + newNode = textDropdownS_ field items def + +{-| +Creates a text dropdown using the given lens. The type must be have a 'Show' +instance. Accepts config. +-} +textDropdownS_ + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) + => ALens' s a + -> t a + -> [DropdownCfg s e a] + -> WidgetNode s e +textDropdownS_ field items configs = newNode where + newNode = textDropdownDS_ (WidgetLens field) items configs + +{-| +Creates a text dropdown using the given value and onChange event handler. The +type must be have a 'Show' instance. +-} +textDropdownSV + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) + => a + -> (a -> e) + -> t a + -> WidgetNode s e +textDropdownSV value handler items = newNode where + newNode = textDropdownSV_ value handler items def + +{-| +Creates a text dropdown using the given value and onChange event handler. The +type must be have a 'Show' instance. Accepts config. +-} +textDropdownSV_ + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) + => a + -> (a -> e) + -> t a + -> [DropdownCfg s e a] + -> WidgetNode s e +textDropdownSV_ value handler items configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = textDropdownDS_ widgetData items newConfigs + +{-| +Creates a text dropdown providing a WidgetData instance and config. The +type must be have a 'Show' instance. +-} +textDropdownDS_ + :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) + => WidgetData s a + -> t a + -> [DropdownCfg s e a] + -> WidgetNode s e +textDropdownDS_ widgetData items configs = newNode where + toText = pack . show + makeMain t = label_ (toText t) [resizeFactorW 0.01] + makeRow t = label_ (toText t) [resizeFactorW 0.01] + newNode = dropdownD_ widgetData items makeMain makeRow configs diff --git a/src/Monomer/Widgets/Singles/TextField.hs b/src/Monomer/Widgets/Singles/TextField.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/TextField.hs @@ -0,0 +1,243 @@ +{-| +Module : Monomer.Widgets.Singles.TextField +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Input field for single line Text. + +Configs: + +- validInput: field indicating if the current input is valid. Useful to show + 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. +- maxLength: the maximum length of input text. +- textFieldDisplayChar: the character that will be displayed as replacement of the + real text. Useful for password fields. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes. +- onChangeReq: WidgetRequest to generate when the value changes. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Singles.TextField ( + textFieldDisplayChar, + textField, + textField_, + textFieldV, + textFieldV_, + textFieldD_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens (ALens') +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import qualified Data.Text as T + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Widgets.Singles.Base.InputField + +import qualified Monomer.Lens as L + +data TextFieldCfg s e = TextFieldCfg { + _tfcCaretWidth :: Maybe Double, + _tfcCaretMs :: Maybe Int, + _tfcDisplayChar :: Maybe Char, + _tfcPlaceholder :: Maybe Text, + _tfcValid :: Maybe (WidgetData s Bool), + _tfcValidV :: [Bool -> e], + _tfcMaxLength :: Maybe Int, + _tfcResizeOnChange :: Maybe Bool, + _tfcSelectOnFocus :: Maybe Bool, + _tfcOnFocusReq :: [Path -> WidgetRequest s e], + _tfcOnBlurReq :: [Path -> WidgetRequest s e], + _tfcOnChangeReq :: [Text -> WidgetRequest s e] +} + +instance Default (TextFieldCfg s e) where + def = TextFieldCfg { + _tfcCaretWidth = Nothing, + _tfcCaretMs = Nothing, + _tfcDisplayChar = Nothing, + _tfcPlaceholder = Nothing, + _tfcValid = Nothing, + _tfcValidV = [], + _tfcMaxLength = Nothing, + _tfcResizeOnChange = Nothing, + _tfcSelectOnFocus = Nothing, + _tfcOnFocusReq = [], + _tfcOnBlurReq = [], + _tfcOnChangeReq = [] + } + +instance Semigroup (TextFieldCfg s e) where + (<>) t1 t2 = TextFieldCfg { + _tfcCaretWidth = _tfcCaretWidth t2 <|> _tfcCaretWidth t1, + _tfcCaretMs = _tfcCaretMs t2 <|> _tfcCaretMs t1, + _tfcDisplayChar = _tfcDisplayChar t2 <|> _tfcDisplayChar t1, + _tfcPlaceholder = _tfcPlaceholder t2 <|> _tfcPlaceholder t1, + _tfcValid = _tfcValid t2 <|> _tfcValid t1, + _tfcValidV = _tfcValidV t1 <> _tfcValidV t2, + _tfcMaxLength = _tfcMaxLength t2 <|> _tfcMaxLength t1, + _tfcResizeOnChange = _tfcResizeOnChange t2 <|> _tfcResizeOnChange t1, + _tfcSelectOnFocus = _tfcSelectOnFocus t2 <|> _tfcSelectOnFocus t1, + _tfcOnFocusReq = _tfcOnFocusReq t1 <> _tfcOnFocusReq t2, + _tfcOnBlurReq = _tfcOnBlurReq t1 <> _tfcOnBlurReq t2, + _tfcOnChangeReq = _tfcOnChangeReq t1 <> _tfcOnChangeReq t2 + } + +instance Monoid (TextFieldCfg s e) where + mempty = def + +instance CmbCaretWidth (TextFieldCfg s e) Double where + caretWidth w = def { + _tfcCaretWidth = Just w + } + +instance CmbCaretMs (TextFieldCfg s e) Int where + caretMs ms = def { + _tfcCaretMs = Just ms + } + +instance CmbPlaceholder (TextFieldCfg s e) Text where + placeholder value = def { + _tfcPlaceholder = Just value + } + +instance CmbValidInput (TextFieldCfg s e) s where + validInput field = def { + _tfcValid = Just (WidgetLens field) + } + +instance CmbValidInputV (TextFieldCfg s e) e where + validInputV fn = def { + _tfcValidV = [fn] + } + +instance CmbResizeOnChange (TextFieldCfg s e) where + resizeOnChange_ resize = def { + _tfcResizeOnChange = Just resize + } + +instance CmbSelectOnFocus (TextFieldCfg s e) where + selectOnFocus_ sel = def { + _tfcSelectOnFocus = Just sel + } + +instance CmbMaxLength (TextFieldCfg s e) where + maxLength len = def { + _tfcMaxLength = Just len + } + +instance WidgetEvent e => CmbOnFocus (TextFieldCfg s e) e Path where + onFocus fn = def { + _tfcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (TextFieldCfg s e) s e Path where + onFocusReq req = def { + _tfcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (TextFieldCfg s e) e Path where + onBlur fn = def { + _tfcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (TextFieldCfg s e) s e Path where + onBlurReq req = def { + _tfcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (TextFieldCfg s e) Text e where + onChange fn = def { + _tfcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (TextFieldCfg s e) s e Text where + onChangeReq req = def { + _tfcOnChangeReq = [req] + } + +-- | Replacement character to show instead of real text. Useful for passwords. +textFieldDisplayChar :: Char -> TextFieldCfg s e +textFieldDisplayChar char = def { + _tfcDisplayChar = Just char + } + +-- | Creates a text field using the given lens. +textField :: WidgetEvent e => ALens' s Text -> WidgetNode s e +textField field = textField_ field def + +-- | Creates a text field using the given lens. Accepts config. +textField_ + :: WidgetEvent e => ALens' s Text -> [TextFieldCfg s e] -> WidgetNode s e +textField_ field configs = textFieldD_ (WidgetLens field) configs + +-- | Creates a text field using the given value and onChange event handler. +textFieldV :: WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e +textFieldV value handler = textFieldV_ value handler def + +-- | Creates a text field using the given value and onChange event handler. +-- | Accepts config. +textFieldV_ + :: WidgetEvent e => Text -> (Text -> e) -> [TextFieldCfg s e] -> WidgetNode s e +textFieldV_ value handler configs = textFieldD_ widgetData newConfig where + widgetData = WidgetValue value + newConfig = onChange handler : configs + +-- | Creates a text field providing a WidgetData instance and config. +textFieldD_ + :: WidgetEvent e => WidgetData s Text -> [TextFieldCfg s e] -> WidgetNode s e +textFieldD_ widgetData configs = inputField where + config = mconcat configs + fromText = textToText (_tfcMaxLength config) + inputConfig = InputFieldCfg { + _ifcPlaceholder = _tfcPlaceholder config, + _ifcInitialValue = "", + _ifcValue = widgetData, + _ifcValid = _tfcValid config, + _ifcValidV = _tfcValidV config, + _ifcFromText = fromText, + _ifcToText = id, + _ifcAcceptInput = acceptInput (_tfcMaxLength config), + _ifcIsValidInput = acceptInput (_tfcMaxLength config), + _ifcDefCursorEnd = True, + _ifcDefWidth = 100, + _ifcCaretWidth = _tfcCaretWidth config, + _ifcCaretMs = _tfcCaretMs config, + _ifcDisplayChar = _tfcDisplayChar config, + _ifcResizeOnChange = fromMaybe False (_tfcResizeOnChange config), + _ifcSelectOnFocus = fromMaybe False (_tfcSelectOnFocus config), + _ifcStyle = Just L.textFieldStyle, + _ifcWheelHandler = Nothing, + _ifcDragHandler = Nothing, + _ifcDragCursor = Nothing, + _ifcOnFocusReq = _tfcOnFocusReq config, + _ifcOnBlurReq = _tfcOnBlurReq config, + _ifcOnChangeReq = _tfcOnChangeReq config + } + inputField = inputField_ "textField" inputConfig + +textToText :: Maybe Int -> Text -> Maybe Text +textToText Nothing text = Just text +textToText (Just len) text + | T.length text <= len = Just text + | otherwise = Nothing + +acceptInput :: Maybe Int -> Text -> Bool +acceptInput Nothing _ = True +acceptInput (Just len) text = T.length text <= len diff --git a/src/Monomer/Widgets/Singles/TimeField.hs b/src/Monomer/Widgets/Singles/TimeField.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/TimeField.hs @@ -0,0 +1,492 @@ +{-| +Module : Monomer.Widgets.Singles.TimeField +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Input field for time types. + +Supports TimeOfDay type of the +library, but other types can be supported by implementing 'TimeOfDayConverter'. +Maybe is also supported. + +Supports different time formats. + +Handles mouse wheel and shift + vertical drag to increase/decrease minutes. + +Configs: + +- validInput: field indicating if the current input is valid. Useful to show +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. +- onFocus: event to raise when focus is received. +- onFocusReq: WidgetRequest to generate when focus is received. +- onBlur: event to raise when focus is lost. +- onBlurReq: WidgetRequest to generate when focus is lost. +- onChange: event to raise when the value changes. +- onChangeReq: WidgetRequest to generate when the value changes. +- timeFormatHHMM: accepts HH:MM. +- timeFormatHHMMSS: accepts HH:MM:SS. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UndecidableInstances #-} + +module Monomer.Widgets.Singles.TimeField ( + timeField, + timeField_, + timeFieldV, + timeFieldV_, + timeFormatHHMM, + timeFormatHHMMSS +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((^.), ALens', _1, _2, _3) +import Control.Monad (join) +import Data.Default +import Data.Either +import Data.Maybe +import Data.Text (Text) +import Data.Time +import Data.Typeable (Typeable, typeOf) + +import qualified Data.Attoparsec.Text as A +import qualified Data.Text as T + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event.Types +import Monomer.Widgets.Singles.Base.InputField + +import qualified Monomer.Lens as L +import qualified Monomer.Widgets.Util.Parser as P + +data TimeFormat + = FormatHHMM + | FormatHHMMSS + deriving (Eq, Show) + +defaultTimeFormat :: TimeFormat +defaultTimeFormat = FormatHHMM + +defaultTimeDelim :: Char +defaultTimeDelim = ':' + +{-| +Converter to and form the TimeOfDay type of the time library. To use types other +than TimeOfDay of said library, this typeclass needs to be implemented. +--} +class (Eq a, Ord a, Show a, Typeable a) => TimeOfDayConverter a where + convertFromTimeOfDay :: TimeOfDay -> a + convertToTimeOfDay :: a -> Maybe TimeOfDay + +instance TimeOfDayConverter TimeOfDay where + convertFromTimeOfDay = id + convertToTimeOfDay = Just + +class TimeTextConverter a where + timeAcceptText :: TimeFormat -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a) + timeFromText :: TimeFormat -> Text -> Maybe a + timeToText :: TimeFormat -> a -> Text + timeFromTimeOfDay' :: TimeOfDay -> a + timeToTimeOfDay' :: a -> Maybe TimeOfDay + +instance {-# OVERLAPPABLE #-} TimeOfDayConverter a => TimeTextConverter a where + timeAcceptText format minVal maxVal text = result where + accept = acceptTextInput format text + parsed = timeFromText format text + isValid = isJust parsed && timeInBounds minVal maxVal (fromJust parsed) + fromText + | isValid = parsed + | otherwise = Nothing + result = (accept, isValid, fromText) + timeFromText = timeFromTextSimple + timeToText = timeToTextSimple + timeFromTimeOfDay' = convertFromTimeOfDay + timeToTimeOfDay' = convertToTimeOfDay + +instance (TimeOfDayConverter a, TimeTextConverter a) => TimeTextConverter (Maybe a) where + timeAcceptText format minVal maxVal text + | T.strip text == "" = (True, True, Just Nothing) + | otherwise = (accept, isValid, result) where + resp = timeAcceptText format (join minVal) (join maxVal) text + (accept, isValid, tmpResult) = resp + result + | isJust tmpResult = Just tmpResult + | otherwise = Nothing + timeFromText format = Just . timeFromText format + timeToText format Nothing = "" + timeToText format (Just value) = timeToText format value + timeFromTimeOfDay' = Just . timeFromTimeOfDay' + timeToTimeOfDay' Nothing = Nothing + timeToTimeOfDay' (Just value) = timeToTimeOfDay' value + +type FormattableTime a + = (Eq a, Ord a, Show a, TimeTextConverter a, Typeable a) + +data TimeFieldCfg s e a = TimeFieldCfg { + _tfcCaretWidth :: Maybe Double, + _tfcCaretMs :: Maybe Int, + _tfcValid :: Maybe (WidgetData s Bool), + _tfcValidV :: [Bool -> e], + _tfcTimeFormat :: Maybe TimeFormat, + _tfcMinValue :: Maybe a, + _tfcMaxValue :: Maybe a, + _tfcWheelRate :: Maybe Double, + _tfcDragRate :: Maybe Double, + _tfcResizeOnChange :: Maybe Bool, + _tfcSelectOnFocus :: Maybe Bool, + _tfcOnFocusReq :: [Path -> WidgetRequest s e], + _tfcOnBlurReq :: [Path -> WidgetRequest s e], + _tfcOnChangeReq :: [a -> WidgetRequest s e] +} + +instance Default (TimeFieldCfg s e a) where + def = TimeFieldCfg { + _tfcCaretWidth = Nothing, + _tfcCaretMs = Nothing, + _tfcValid = Nothing, + _tfcValidV = [], + _tfcTimeFormat = Nothing, + _tfcMinValue = Nothing, + _tfcMaxValue = Nothing, + _tfcWheelRate = Nothing, + _tfcDragRate = Nothing, + _tfcResizeOnChange = Nothing, + _tfcSelectOnFocus = Nothing, + _tfcOnFocusReq = [], + _tfcOnBlurReq = [], + _tfcOnChangeReq = [] + } + +instance Semigroup (TimeFieldCfg s e a) where + (<>) t1 t2 = TimeFieldCfg { + _tfcCaretWidth = _tfcCaretWidth t2 <|> _tfcCaretWidth t1, + _tfcCaretMs = _tfcCaretMs t2 <|> _tfcCaretMs t1, + _tfcValid = _tfcValid t2 <|> _tfcValid t1, + _tfcValidV = _tfcValidV t1 <> _tfcValidV t2, + _tfcTimeFormat = _tfcTimeFormat t2 <|> _tfcTimeFormat t1, + _tfcMinValue = _tfcMinValue t2 <|> _tfcMinValue t1, + _tfcMaxValue = _tfcMaxValue t2 <|> _tfcMaxValue t1, + _tfcWheelRate = _tfcWheelRate t2 <|> _tfcWheelRate t1, + _tfcDragRate = _tfcDragRate t2 <|> _tfcDragRate t1, + _tfcResizeOnChange = _tfcResizeOnChange t2 <|> _tfcResizeOnChange t1, + _tfcSelectOnFocus = _tfcSelectOnFocus t2 <|> _tfcSelectOnFocus t1, + _tfcOnFocusReq = _tfcOnFocusReq t1 <> _tfcOnFocusReq t2, + _tfcOnBlurReq = _tfcOnBlurReq t1 <> _tfcOnBlurReq t2, + _tfcOnChangeReq = _tfcOnChangeReq t1 <> _tfcOnChangeReq t2 + } + +instance Monoid (TimeFieldCfg s e a) where + mempty = def + +instance CmbCaretWidth (TimeFieldCfg s e a) Double where + caretWidth w = def { + _tfcCaretWidth = Just w + } + +instance CmbCaretMs (TimeFieldCfg s e a) Int where + caretMs ms = def { + _tfcCaretMs = Just ms + } + +instance CmbValidInput (TimeFieldCfg s e a) s where + validInput field = def { + _tfcValid = Just (WidgetLens field) + } + +instance CmbValidInputV (TimeFieldCfg s e a) e where + validInputV fn = def { + _tfcValidV = [fn] + } + +instance CmbResizeOnChange (TimeFieldCfg s e a) where + resizeOnChange_ resize = def { + _tfcResizeOnChange = Just resize + } + +instance CmbSelectOnFocus (TimeFieldCfg s e a) where + selectOnFocus_ sel = def { + _tfcSelectOnFocus = Just sel + } + +instance FormattableTime a => CmbMinValue (TimeFieldCfg s e a) a where + minValue len = def { + _tfcMinValue = Just len + } + +instance FormattableTime a => CmbMaxValue (TimeFieldCfg s e a) a where + maxValue len = def { + _tfcMaxValue = Just len + } + +instance CmbWheelRate (TimeFieldCfg s e a) Double where + wheelRate rate = def { + _tfcWheelRate = Just rate + } + +instance CmbDragRate (TimeFieldCfg s e a) Double where + dragRate rate = def { + _tfcDragRate = Just rate + } + +instance WidgetEvent e => CmbOnFocus (TimeFieldCfg s e a) e Path where + onFocus fn = def { + _tfcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (TimeFieldCfg s e a) s e Path where + onFocusReq req = def { + _tfcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (TimeFieldCfg s e a) e Path where + onBlur fn = def { + _tfcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (TimeFieldCfg s e a) s e Path where + onBlurReq req = def { + _tfcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (TimeFieldCfg s e a) a e where + onChange fn = def { + _tfcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (TimeFieldCfg s e a) s e a where + onChangeReq req = def { + _tfcOnChangeReq = [req] + } + +-- | Time format HH:MM +timeFormatHHMM :: TimeFieldCfg s e a +timeFormatHHMM = def { + _tfcTimeFormat = Just FormatHHMM +} + +-- | Time format HH:MM:SS +timeFormatHHMMSS :: TimeFieldCfg s e a +timeFormatHHMMSS = def { + _tfcTimeFormat = Just FormatHHMMSS +} + +-- | Creates a time field using the given lens. +timeField + :: (FormattableTime a, WidgetEvent e) + => ALens' s a -> WidgetNode s e +timeField field = timeField_ field def + +-- | Creates a time field using the given lens. Accepts config. +timeField_ + :: (FormattableTime a, WidgetEvent e) + => ALens' s a + -> [TimeFieldCfg s e a] + -> WidgetNode s e +timeField_ field configs = widget where + widget = timeFieldD_ (WidgetLens field) configs + +-- | Creates a time field using the given value and onChange event handler. +timeFieldV + :: (FormattableTime a, WidgetEvent e) + => a -> (a -> e) -> WidgetNode s e +timeFieldV value handler = timeFieldV_ value handler def + +-- | Creates a time field using the given value and onChange event handler. +-- | Accepts config. +timeFieldV_ + :: (FormattableTime a, WidgetEvent e) + => a + -> (a -> e) + -> [TimeFieldCfg s e a] + -> WidgetNode s e +timeFieldV_ value handler configs = newNode where + widgetData = WidgetValue value + newConfigs = onChange handler : configs + newNode = timeFieldD_ widgetData newConfigs + +-- | Creates a time field providing a WidgetData instance and config. +timeFieldD_ + :: (FormattableTime a, WidgetEvent e) + => WidgetData s a + -> [TimeFieldCfg s e a] + -> WidgetNode s e +timeFieldD_ widgetData configs = newNode where + config = mconcat configs + format = fromMaybe defaultTimeFormat (_tfcTimeFormat config) + minVal = _tfcMinValue config + maxVal = _tfcMaxValue config + initialValue + | isJust minVal = fromJust minVal + | isJust maxVal = fromJust maxVal + | otherwise = timeFromTimeOfDay' midnight + + acceptText = timeAcceptText format minVal maxVal + acceptInput text = acceptText text ^. _1 + validInput text = acceptText text ^. _2 + fromText text = acceptText text ^. _3 + toText = timeToText format + + inputConfig = InputFieldCfg { + _ifcPlaceholder = Nothing, + _ifcInitialValue = initialValue, + _ifcValue = widgetData, + _ifcValid = _tfcValid config, + _ifcValidV = _tfcValidV config, + _ifcFromText = fromText, + _ifcToText = toText, + _ifcAcceptInput = acceptInput, + _ifcIsValidInput = validInput, + _ifcDefCursorEnd = True, + _ifcDefWidth = 160, + _ifcCaretWidth = _tfcCaretWidth config, + _ifcCaretMs = _tfcCaretMs config, + _ifcDisplayChar = Nothing, + _ifcResizeOnChange = fromMaybe False (_tfcResizeOnChange config), + _ifcSelectOnFocus = fromMaybe True (_tfcSelectOnFocus config), + _ifcStyle = Just L.timeFieldStyle, + _ifcWheelHandler = Just (handleWheel config), + _ifcDragHandler = Just (handleDrag config), + _ifcDragCursor = Just CursorSizeV, + _ifcOnFocusReq = _tfcOnFocusReq config, + _ifcOnBlurReq = _tfcOnBlurReq config, + _ifcOnChangeReq = _tfcOnChangeReq config + } + newNode = inputField_ "timeField" inputConfig + +handleWheel + :: FormattableTime a + => TimeFieldCfg s e a + -> InputFieldState a + -> Point + -> Point + -> WheelDirection + -> (Text, Int, Maybe Int) +handleWheel config state point move dir = result where + Point _ dy = move + sign = if dir == WheelNormal then 1 else -1 + curValue = _ifsCurrValue state + wheelRate = fromMaybe 1 (_tfcWheelRate config) + result = handleMove config state wheelRate curValue (dy * sign) + +handleDrag + :: FormattableTime a + => TimeFieldCfg s e a + -> InputFieldState a + -> Point + -> Point + -> (Text, Int, Maybe Int) +handleDrag config state clickPos currPos = result where + Point _ dy = subPoint clickPos currPos + selValue = _ifsDragSelValue state + dragRate = fromMaybe 1 (_tfcDragRate config) + result = handleMove config state dragRate selValue dy + +handleMove + :: FormattableTime a + => TimeFieldCfg s e a + -> InputFieldState a + -> Double + -> a + -> Double + -> (Text, Int, Maybe Int) +handleMove config state rate value dy = result where + format = fromMaybe defaultTimeFormat (_tfcTimeFormat config) + minVal = _tfcMinValue config + maxVal = _tfcMaxValue config + + acceptText = timeAcceptText format minVal maxVal + fromText text = acceptText text ^. _3 + toText = timeToText format + + (valid, mParsedVal, parsedVal) = case timeToTimeOfDay' value of + Just val -> (True, mParsedVal, parsedVal) where + tmpValue = addMinutes (round (dy * rate)) val + mParsedVal = fromText (toText (timeFromTimeOfDay' tmpValue)) + parsedVal = fromJust mParsedVal + Nothing -> (False, Nothing, undefined) + newVal + | isJust mParsedVal = parsedVal + | valid && dy > 0 && isJust maxVal = fromJust maxVal + | valid && dy < 0 && isJust minVal = fromJust minVal + | otherwise = _ifsCurrValue state + + newText = toText newVal + newPos = _ifsCursorPos state + newSel = _ifsSelStart state + result = (newText, newPos, newSel) + +timeFromTextSimple + :: (TimeOfDayConverter a, FormattableTime a) + => TimeFormat + -> Text + -> Maybe a +timeFromTextSimple format text = newTime where + compParser = A.char ':' *> A.decimal + timeParser + | format == FormatHHMM = (,,) <$> A.decimal <*> compParser <*> pure 0 + | otherwise = (,,) <$> A.decimal <*> compParser <*> compParser + tmpTime = case A.parseOnly timeParser text of + Left _ -> Nothing + Right (n1, n2, n3) + | format == FormatHHMM -> makeTimeOfDayValid n1 n2 0 + | otherwise -> makeTimeOfDayValid n1 n2 (fromIntegral n3) + newTime = tmpTime >>= timeFromTimeOfDay' + +timeToTextSimple :: FormattableTime a => TimeFormat -> a -> Text +timeToTextSimple format val = result where + sep = T.singleton defaultTimeDelim + converted = timeToTimeOfDay' val + TimeOfDay hh mm ss = fromJust converted + padd num + | num < 10 = "0" <> T.pack (show num) + | otherwise = T.pack (show num) + thh = padd hh + tmm = padd mm + tss = padd (round ss) + result + | isNothing converted = "" + | format == FormatHHMM = thh <> sep <> tmm + | otherwise = thh <> sep <> tmm <> sep <> tss + +acceptTextInput :: TimeFormat -> Text -> Bool +acceptTextInput format text = isRight (A.parseOnly parser text) where + numP = A.digit *> "" + delimP = A.char defaultTimeDelim *> "" + hhP = P.upto 2 numP + mmP = P.upto 2 numP + ssP = P.upto 2 numP + withDelim parser = A.option "" (delimP *> parser) + parsers + | format == FormatHHMM = [hhP, withDelim mmP] + | otherwise = [hhP, withDelim mmP, withDelim ssP] + parser = P.join parsers <* A.endOfInput + +timeInBounds :: (Ord a) => Maybe a -> Maybe a -> a -> Bool +timeInBounds Nothing Nothing _ = True +timeInBounds (Just minVal) Nothing val = val >= minVal +timeInBounds Nothing (Just maxVal) val = val <= maxVal +timeInBounds (Just minVal) (Just maxVal) val = val >= minVal && val <= maxVal + +addMinutes :: Int -> TimeOfDay -> TimeOfDay +addMinutes mins time = newTime where + baseDate = fromGregorian 2000 1 1 + baseTime = timeOfDayToTime time + baseUTC = UTCTime baseDate baseTime + UTCTime newDate diff = addUTCTime (fromIntegral mins * 60) baseUTC + newTime + | newDate > baseDate = TimeOfDay 23 59 59 + | newDate < baseDate = TimeOfDay 0 0 0 + | otherwise = timeToTimeOfDay diff diff --git a/src/Monomer/Widgets/Util.hs b/src/Monomer/Widgets/Util.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util.hs @@ -0,0 +1,31 @@ +{-| +Module : Monomer.Widgets.Util +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for creating custom widgets. +-} +module Monomer.Widgets.Util ( + module Monomer.Widgets.Util.Drawing, + module Monomer.Widgets.Util.Focus, + module Monomer.Widgets.Util.Hover, + module Monomer.Widgets.Util.Keyboard, + module Monomer.Widgets.Util.Style, + module Monomer.Widgets.Util.Text, + module Monomer.Widgets.Util.Theme, + module Monomer.Widgets.Util.Types, + module Monomer.Widgets.Util.Widget +) where + +import Monomer.Widgets.Util.Drawing +import Monomer.Widgets.Util.Focus +import Monomer.Widgets.Util.Hover +import Monomer.Widgets.Util.Keyboard +import Monomer.Widgets.Util.Style +import Monomer.Widgets.Util.Text +import Monomer.Widgets.Util.Theme +import Monomer.Widgets.Util.Types +import Monomer.Widgets.Util.Widget diff --git a/src/Monomer/Widgets/Util/Drawing.hs b/src/Monomer/Widgets/Util/Drawing.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Drawing.hs @@ -0,0 +1,615 @@ +{-| +Module : Monomer.Widgets.Util.Drawing +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Utility drawing functions. Built on top the lower level primitives provided by +"Monomer.Graphics.Types.Renderer". +-} +{-# LANGUAGE RecordWildCards #-} + +module Monomer.Widgets.Util.Drawing ( + drawInScissor, + drawInTranslation, + drawInScale, + drawInRotation, + drawInAlpha, + drawTextLine, + drawRect, + drawRectBorder, + drawArc, + drawArcBorder, + drawEllipse, + drawEllipseBorder, + drawArrowDown, + drawTimesX, + drawStyledAction, + drawRoundedRect, + drawRectRoundedBorder +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (^?), (^?!), (.~), non) +import Control.Monad (forM_, void, when) +import Data.ByteString (ByteString) +import Data.Default +import Data.Maybe +import Data.Text (Text) + +import Monomer.Core +import Monomer.Graphics.Types + +import qualified Monomer.Common.Lens as L +import qualified Monomer.Core.Lens as L +import qualified Monomer.Graphics.Lens as L + +-- | Performs the provided drawing operations with an active scissor, and then +-- | disables it. +drawInScissor + :: Renderer -- ^ The renderer. + -> Bool -- ^ Whether to apply the scissor (useful to selectively apply). + -> Rect -- ^ Scissor rect, where drawing will be visible. + -> IO () -- ^ Drawing operations. + -> IO () -- ^ The resulting action. +drawInScissor renderer False _ action = action +drawInScissor renderer True rect action = do + saveContext renderer + intersectScissor renderer rect + action + restoreContext renderer + +-- | Performs the provided drawing operations displaced by the given offset. +drawInTranslation + :: Renderer -- ^ The renderer. + -> Point -- ^ The offset to apply. + -> IO () -- ^ Drawing operations. + -> IO () -- ^ The resulting action. +drawInTranslation renderer offset action = do + saveContext renderer + setTranslation renderer offset + action + restoreContext renderer + +-- | Performs the provided drawing operations with the given resize scale. +drawInScale + :: Renderer -- ^ The renderer. + -> Point -- ^ The horizontal and vertical scale factor to apply. + -> IO () -- ^ Drawing operations. + -> IO () -- ^ The resulting action. +drawInScale renderer scale action = do + saveContext renderer + setScale renderer scale + action + restoreContext renderer + +-- | Performs the provided drawing operations with the given rotation angle. +drawInRotation + :: Renderer -- ^ The renderer. + -> Double -- ^ The angle in degrees. + -> IO () -- ^ Drawing operations. + -> IO () -- ^ The resulting action. +drawInRotation renderer angle action = do + saveContext renderer + setRotation renderer angle + action + restoreContext renderer + +-- | Performs the provided drawing operations with a global alpha applied. +drawInAlpha + :: Renderer -- ^ The renderer. + -> Double -- ^ The global alpha to apply. + -> IO () -- ^ Drawing operations. + -> IO () -- ^ The resulting action. +drawInAlpha renderer alpha action = do + saveContext renderer + setGlobalAlpha renderer alpha + action + restoreContext renderer + +-- | Draws a TextLine with the provided style. Font and size must be the same +-- | as when the TextLine was created, but color and decorations can change. +drawTextLine + :: Renderer -- ^ The renderer. + -> StyleState -- ^ The style to apply. + -> TextLine -- ^ The TextLine with the text to render. + -> IO () -- ^ The resulting action. +drawTextLine renderer style textLine = do + setFillColor renderer fontColor + renderText renderer txtOrigin _tlFont _tlFontSize _tlFontSpaceH _tlText + + when underline $ do + drawLine renderer (Point tx uy) (Point tr uy) lw (Just fontColor) + + when overline $ do + drawLine renderer (Point tx oy) (Point tr oy) lw (Just fontColor) + + when throughline $ do + drawLine renderer (Point tx hy) (Point tr hy) lw (Just fontColor) + where + TextLine{..} = textLine + TextMetrics asc desc _ _ = _tlMetrics + Rect tx ty tw th = _tlRect + tr = tx + tw + + fontColor = styleFontColor style + alignV = styleTextAlignV style + + underline = style ^?! L.text . non def . L.underline . non False + overline = style ^?! L.text . non def . L.overline . non False + throughline = style ^?! L.text . non def . L.throughline . non False + + offset + | alignV == ATBaseline = 0 + | otherwise = desc + {- + There's not a scientific reason for choosing 1/20 as the scale, it just + looked reasonably good as the line width on a set of different fonts. + -} + lw = max 1.5 (unFontSize _tlFontSize / 20) + by = ty + th + offset + uy = by + 1.5 * lw + oy = ty + hy = by - asc * 0.35 + txtOrigin = Point tx by + +-- | Draws a line with the given width and color. +drawLine + :: Renderer -- ^ The renderer. + -> Point -- ^ The start point. + -> Point -- ^ The end point. + -> Double -- ^ The line width. + -> Maybe Color -- ^ The color. If Nothing, the line will not be drawn. + -> IO () -- ^ The resulting action. +drawLine _ _ _ _ Nothing = pure () +drawLine renderer p1 p2 width (Just color) = do + beginPath renderer + setStrokeColor renderer color + setStrokeWidth renderer width + renderLine renderer p1 p2 + stroke renderer + +-- | Draws a filled rect with the given color and radius. +drawRect + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rectangle to be drawn. + -> Maybe Color -- ^ The color. If Nothing, the rect will not be drawn. + -> Maybe Radius -- ^ The optional radius config. + -> IO () -- ^ The resulting action. +drawRect _ _ Nothing _ = pure () +drawRect renderer rect (Just color) Nothing = do + beginPath renderer + setFillColor renderer color + renderRect renderer rect + fill renderer +drawRect renderer rect (Just color) (Just radius) = do + beginPath renderer + setFillColor renderer color + drawRoundedRect renderer rect radius + fill renderer + +-- | Draws a rect's border, with an optional radius. +drawRectBorder + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rectangle to be drawn. + -> Border -- ^ The border config. + -> Maybe Radius -- ^ The optional radius config. + -> IO () -- ^ The resulting action. +drawRectBorder renderer rect border Nothing = + drawRectSimpleBorder renderer rect border +drawRectBorder renderer rect border (Just radius) = + drawRectRoundedBorder renderer rect border radius + +-- | Draws a filled arc, delimited by a rect and within the given angles. +drawArc + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rect delimiting the arc area. + -> Double -- ^ The start angle in degrees. + -> Double -- ^ The end angle in degrees. + -> Winding -- ^ The direction in which the arc is drawn. + -> Maybe Color -- ^ The color. If Nothing, the arc will not be drawn. + -> IO () -- ^ The resulting action. +drawArc renderer rect start end winding Nothing = return () +drawArc renderer rect start end winding (Just color) = do + beginPath renderer + setFillColor renderer color + renderArc renderer center radius start end winding + fill renderer + where + Rect rx ry rw rh = rect + radius = min (rw / 2) (rh / 2) + center = Point (rx + rw / 2) (ry + rh / 2) + +-- | Draws an arc's border, delimited by a rect and within the given angles. +drawArcBorder + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rect delimiting the arc area. + -> Double -- ^ The start angle in degrees. + -> Double -- ^ The end angle in degrees. + -> Winding -- ^ The direction in which the arc is drawn. + -> Maybe Color -- ^ The color. If Nothing, the arc will not be drawn. + -> Double -- ^ The arc width. + -> IO () -- ^ The resulting action. +drawArcBorder renderer rect start end winding Nothing width = return () +drawArcBorder renderer rect start end winding (Just color) width = do + beginPath renderer + setStrokeColor renderer color + setStrokeWidth renderer width + renderArc renderer center radius start end winding + stroke renderer + where + Rect rx ry rw rh = rect + radius = min ((rw - width) / 2) ((rh - width) / 2) + center = Point (rx + rw / 2) (ry + rh / 2) + +-- | Draws a filled ellipse, delimited by a rect. +drawEllipse + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rect delimiting the ellipse. + -> Maybe Color -- ^ The color. If Nothing, the ellipse will not be drawn. + -> IO () -- ^ The resulting action. +drawEllipse renderer rect Nothing = return () +drawEllipse renderer rect (Just color) = do + beginPath renderer + setFillColor renderer color + renderEllipse renderer rect + fill renderer + +-- | Draws an ellipse's border, delimited by a rect. +drawEllipseBorder + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rect delimiting the ellipse. + -> Maybe Color -- ^ The color. If Nothing, the ellipse will not be drawn. + -> Double -- ^ The border width. + -> IO () -- ^ The resulting action. +drawEllipseBorder renderer rect Nothing _ = return () +drawEllipseBorder renderer rect (Just color) width = + forM_ contentRect $ \finalRect -> do + beginPath renderer + setStrokeColor renderer color + setStrokeWidth renderer width + renderEllipse renderer finalRect + stroke renderer + where + contentRect = subtractFromRect rect w w w w + w = width / 2 + +-- | Draws a triangular arrow pointing down, delimited by the given rect. +drawArrowDown + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rect delimiting the arrow. + -> Maybe Color -- ^ The color. If Nothing, the arrow will not be drawn. + -> IO () -- ^ The resulting action. +drawArrowDown renderer rect Nothing = return () +drawArrowDown renderer rect (Just color) = do + beginPath renderer + setFillColor renderer color + moveTo renderer p1 + renderLineTo renderer p2 + renderLineTo renderer p3 + renderLineTo renderer p1 + fill renderer + where + Rect x y w h = rect + p1 = Point x y + p2 = Point (x + w) y + p3 = Point (x + w / 2) (y + h) + +-- | Draws an X, delimited by the given rect. +drawTimesX + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rect delimiting the arrow. + -> Double -- ^ The width of the lines. + -> Maybe Color -- ^ The color. If Nothing, the X will not be drawn. + -> IO () -- ^ The resulting action. +drawTimesX renderer rect lw Nothing = return () +drawTimesX renderer rect lw (Just fgColor) = do + beginPath renderer + setFillColor renderer fgColor + moveTo renderer (Point (x + hw) y) + renderLineTo renderer (Point cx (cy - hw)) + renderLineTo renderer (Point (mx - hw) y) + renderLineTo renderer (Point mx (y + hw)) + renderLineTo renderer (Point (cx + hw) cy) + renderLineTo renderer (Point mx (my - hw)) + renderLineTo renderer (Point (mx - hw) my) + renderLineTo renderer (Point cx (cy + hw)) + renderLineTo renderer (Point (x + hw) my) + renderLineTo renderer (Point x (my - hw)) + renderLineTo renderer (Point (cx - hw) cy) + renderLineTo renderer (Point x (y + hw)) + renderLineTo renderer (Point (x + hw) y) + fill renderer + where + Rect x y w h = rect + hw = lw / 2 + cx = x + w / 2 + cy = y + h / 2 + mx = x + w + my = y + h + +{-| +Runs a set of rendering operations after drawing the style's background, and +before drawing the style's border. +-} +drawStyledAction + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rect where background and border will be drawn. + -> StyleState -- ^ The style defining background and border. + -> (Rect -> IO ()) -- ^ The drawing actions. They receive the content area. + -> IO () -- ^ The resulting action. +drawStyledAction renderer rect style action = do + drawRect renderer rect _sstBgColor _sstRadius + + forM_ contentRect action + + when (isJust _sstBorder) $ + drawRectBorder renderer rect (fromJust _sstBorder) _sstRadius + where + StyleState{..} = style + contentRect = removeOuterBounds style rect + +-- | Draws a rounded rect with the provided radius config. +drawRoundedRect :: Renderer -> Rect -> Radius -> IO () +drawRoundedRect renderer rect radius = + let + Rect _ _ w h = rect + Radius{..} = fixRadius rect radius + midw = min w h / 2 + validTL = min midw (radW _radTopLeft) + validTR = min midw (radW _radTopRight) + validBR = min midw (radW _radBottomRight) + validBL = min midw (radW _radBottomLeft) + in do + renderRoundedRect renderer rect validTL validTR validBR validBL + +drawRectSimpleBorder :: Renderer -> Rect -> Border -> IO () +drawRectSimpleBorder renderer (Rect x y w h) Border{..} = + let + ptl = Point x y + ptr = Point (x + w) y + pbr = Point (x + w) (y + h) + pbl = Point x (y + h) + + borderL = _brdLeft + borderR = _brdRight + borderT = _brdTop + borderB = _brdBottom + in do + (olt, otl, itl) <- drawRectCorner renderer CornerTL ptl borderL borderT + (otr, ort, itr) <- drawRectCorner renderer CornerTR ptr borderT borderR + (orb, obr, ibr) <- drawRectCorner renderer CornerBR pbr borderR borderB + (obl, olb, ibl) <- drawRectCorner renderer CornerBL pbl borderB borderL + + drawQuad renderer otl otr itr itl borderT + drawQuad renderer ort orb ibr itr borderR + drawQuad renderer obr obl ibl ibr borderB + drawQuad renderer olb olt itl ibl borderL + +drawRectCorner + :: Renderer + -> RectCorner + -> Point + -> Maybe BorderSide + -> Maybe BorderSide + -> IO (Point, Point, Point) +drawRectCorner _ _ ocorner Nothing Nothing = return points where + points = (ocorner, ocorner, ocorner) +drawRectCorner renderer cor ocorner ms1 ms2 = do + beginPath renderer + + if color1 == color2 + then setFillColor renderer color1 + else setFillLinearGradient renderer g1 g2 color1 color2 + + moveTo renderer o1 + renderLineTo renderer icorner + renderLineTo renderer o2 + renderLineTo renderer ocorner + closePath renderer + + fill renderer + return (o1, o2, icorner) + where + Point cx cy = ocorner + s1 = fromMaybe def ms1 + s2 = fromMaybe def ms2 + w1 = _bsWidth s1 + w2 = _bsWidth s2 + + color1 = _bsColor (fromJust (ms1 <|> ms2)) + color2 = _bsColor (fromJust (ms2 <|> ms1)) + + (o1, o2) = case cor of + CornerTL -> (Point cx (cy + w2), Point (cx + w1) cy) + CornerTR -> (Point (cx - w2) cy, Point cx (cy + w1)) + CornerBR -> (Point cx (cy - w2), Point (cx - w1) cy) + CornerBL -> (Point (cx + w2) cy, Point cx (cy - w1)) + icorner = case cor of + CornerTL -> Point (cx + w1) (cy + w2) + CornerTR -> Point (cx - w2) (cy + w1) + CornerBR -> Point (cx - w1) (cy - w2) + CornerBL -> Point (cx + w2) (cy - w1) + (g1, g2) = cornerGradientPoints ocorner icorner + +-- | Draws the border of a rounded rect. Borders' widths may not match. +drawRectRoundedBorder :: Renderer -> Rect -> Border -> Radius -> IO () +drawRectRoundedBorder renderer rect border radius = + let + Rect xl yt w h = rect + Border borL borR borT borB = border + Radius radTL radTR radBL radBR = fixRadius rect radius + xr = xl + w + yb = yt + h + hw = w / 2 + hh = h / 2 + midw = min w h / 2 + + rtl = Rect xl yt hw hh + rtr = Rect (xl + hw) yt hw hh + rbr = Rect (xl + hw) (yt + hh) hw hh + rbl = Rect xl (yt + hh) hw hh + + validTL = min midw (radW radTL) + validTR = min midw (radW radTR) + validBR = min midw (radW radBR) + validBL = min midw (radW radBL) + + xt1 = xl + validTL + xt2 = xr - validTR + + xb1 = xl + validBL + xb2 = xr - validBR + + yl1 = yt + validTL + yl2 = yb - validBL + + yr1 = yt + validTR + yr2 = yb - validBR + in do + (lt1, lt2, tl1, tl2) <- drawRoundedCorner renderer CornerTL rtl (p2 xt1 yl1) radTL borL borT + (tr1, tr2, rt1, rt2) <- drawRoundedCorner renderer CornerTR rtr (p2 xt2 yr1) radTR borT borR + (rb1, rb2, br1, br2) <- drawRoundedCorner renderer CornerBR rbr (p2 xb2 yr2) radBR borR borB + (bl1, bl2, lb1, lb2) <- drawRoundedCorner renderer CornerBL rbl (p2 xb1 yl2) radBL borB borL + + drawQuad renderer lb1 lt1 lt2 lb2 borL + drawQuad renderer tl1 tr1 tr2 tl2 borT + drawQuad renderer rt1 rb1 rb2 rt2 borR + drawQuad renderer br1 bl1 bl2 br2 borB + +drawRoundedCorner + :: Renderer + -> RectCorner + -> Rect + -> Point + -> Maybe RadiusCorner + -> Maybe BorderSide + -> Maybe BorderSide + -> IO (Point, Point, Point, Point) +drawRoundedCorner _ _ _ center _ Nothing Nothing = return points where + points = (center, center, center, center) +drawRoundedCorner renderer cor bounds ocenter mrcor ms1 ms2 = do + beginPath renderer + + if color1 == color2 + then setFillColor renderer color1 + else setFillLinearGradient renderer g1 g2 color1 color2 + + if round orad == 0 + then drawRectArc renderer cor icenter w1 w2 + else renderArc renderer ocenter orad deg (deg - 90) CCW + + renderLineTo renderer o1 + + if round orad > 0 && round irad > 0 + then do + renderLineTo renderer i1 + renderArc renderer icenter irad (deg - 90) deg CW + renderLineTo renderer i2 + else do + renderLineTo renderer icenter + + renderLineTo renderer o2 + + closePath renderer + fill renderer + + return bordersCorners + where + Point ocx ocy = ocenter + Point icx icy = icenter + rcor = fromMaybe def mrcor + s1 = fromMaybe def ms1 + s2 = fromMaybe def ms2 + w1 = _bsWidth s1 + w2 = _bsWidth s2 + color1 = _bsColor (fromJust (ms1 <|> ms2)) + color2 = _bsColor (fromJust (ms2 <|> ms1)) + minW = min w1 w2 + + orad = max 0 (_rcrWidth rcor) + irad = max 0 (orad - minW) + omax1 = max orad w1 + omax2 = max orad w2 + + cxmin = min ocx icx + cxmax = max ocx icx + cymin = min ocy icy + cymax = max ocy icy + + restrict (p1, p2) = (rectBoundedPoint bounds p1, rectBoundedPoint bounds p2) + (deg, icenter) = case cor of + CornerTL -> (270, Point (ocx - orad + w1 + irad) (ocy - orad + w2 + irad)) + CornerTR -> ( 0, Point (ocx + orad - w2 - irad) (ocy - orad + w1 + irad)) + CornerBR -> ( 90, Point (ocx + orad - w1 - irad) (ocy + orad - w2 - irad)) + CornerBL -> (180, Point (ocx - orad + w2 + irad) (ocy + orad - w1 - irad)) + (o1, o2) = restrict $ case cor of + CornerTL -> (Point (ocx - omax1) cymax, Point cxmax (ocy - omax2)) + CornerTR -> (Point cxmin (ocy - omax2), Point (ocx + omax1) cymax) + CornerBR -> (Point (ocx + omax1) cymin, Point cxmin (ocy + omax2)) + CornerBL -> (Point cxmax (ocy + omax2), Point (ocx - omax1) cymin) + (i1, i2) = restrict $ case cor of + CornerTL -> (Point (ocx - orad + w1) cymax, Point cxmax (ocy - orad + w2)) + CornerTR -> (Point cxmin (ocy - orad + w1), Point (ocx + orad - w2) cymax) + CornerBR -> (Point (ocx + orad - w1) cymin, Point cxmin (ocy + orad - w2)) + CornerBL -> (Point cxmax (ocy + orad - w1), Point (ocx - orad + w2) cymin) + bordersCorners + | round orad == 0 = (o1, icenter, o2, icenter) + | otherwise = (o1, i1, o2, i2) + ocorner = Point (o1 ^. L.x) (o2 ^. L.y) + icorner = Point (o2 ^. L.x) (o1 ^. L.y) + (g1, g2) + | cor `elem` [CornerTL, CornerBR] = cornerGradientPoints ocorner icorner + | otherwise = cornerGradientPoints icorner ocorner + +drawRectArc :: Renderer -> RectCorner -> Point -> Double -> Double -> IO () +drawRectArc renderer corner c1 pw1 pw2 = do + moveTo renderer (addPoint c1 p1) + renderLineTo renderer (addPoint c1 p2) + renderLineTo renderer (addPoint c1 p3) + where + nw1 = -pw1 + nw2 = -pw2 + (p1, p2, p3) = case corner of + CornerTL -> (Point 0 nw2, Point nw1 nw2, Point nw1 0) + CornerTR -> (Point pw2 0, Point pw2 nw1, Point 0 nw1) + CornerBR -> (Point 0 pw2, Point pw1 pw2, Point pw1 0) + CornerBL -> (Point nw2 0, Point nw2 pw1, Point 0 pw1) + +drawQuad :: Renderer -> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO () +drawQuad renderer p1 p2 p3 p4 Nothing = pure () +drawQuad renderer p1 p2 p3 p4 (Just BorderSide{..}) = do + beginPath renderer + setFillColor renderer _bsColor + moveTo renderer p1 + renderLineTo renderer p2 + renderLineTo renderer p3 + renderLineTo renderer p4 + closePath renderer + fill renderer + +cornerGradientPoints :: Point -> Point -> (Point, Point) +cornerGradientPoints outer inner = (g1, g2) where + Point ox oy = outer + Point ix iy = inner + Point mx my = midPoint outer inner + (vx, vy) = (ix - ox, iy - oy) + (nx, ny) = (vy, -vx) + factor = 0.01 + g1 = Point (mx - factor * nx) (my - factor * ny) + g2 = Point (mx + factor * nx) (my + factor * ny) + +p2 :: Double -> Double -> Point +p2 x y = Point x y + +radW :: Maybe RadiusCorner -> Double +radW r = _rcrWidth (fromMaybe def r) + +fixRadius :: Rect -> Radius -> Radius +fixRadius (Rect _ _ w h) (Radius tl tr bl br) = newRadius where + fixC (RadiusCorner cwidth) + | cwidth < min w h / 2= RadiusCorner cwidth + | otherwise = RadiusCorner (min w h / 2) + newRadius = Radius (fixC <$> tl) (fixC <$> tr) (fixC <$> bl) (fixC <$> br) diff --git a/src/Monomer/Widgets/Util/Focus.hs b/src/Monomer/Widgets/Util/Focus.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Focus.hs @@ -0,0 +1,139 @@ +{-| +Module : Monomer.Widgets.Util.Focus +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for focus handling. +-} +module Monomer.Widgets.Util.Focus ( + isNodeFocused, + isNodeInfoFocused, + isNodeParentOfFocused, + parentPath, + nextTargetStep, + isFocusCandidate, + isTargetReached, + isTargetValid, + isNodeParentOfPath, + isNodeBeforePath, + isNodeAfterPath, + handleFocusChange +) where + +import Control.Lens ((&), (^.), (.~), (%~)) +import Data.Maybe +import Data.Sequence (Seq(..), (|>)) +import Data.Typeable (Typeable) + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Helper +import Monomer.Widgets.Util.Widget + +import qualified Monomer.Core.Lens as L + +-- | Checks if the given node is focused. +isNodeFocused :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeFocused wenv node = wenv ^. L.focusedPath == node ^. L.info . L.path + +-- | Checks if the given nodeInfo is focused. +isNodeInfoFocused :: WidgetEnv s e -> WidgetNodeInfo -> Bool +isNodeInfoFocused wenv info = wenv ^. L.focusedPath == info ^. L.path + +-- | Checks if the given node is a parent of the focused node. +isNodeParentOfFocused :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeParentOfFocused wenv node = seqStartsWith parentPath focusedPath where + parentPath = node ^. L.info . L.path + focusedPath = wenv ^. L.focusedPath + +-- | Returns the parent path of a node. +parentPath :: WidgetNode s e -> Path +parentPath node = Seq.take (Seq.length path - 1) path where + path = node ^. L.info . L.path + +-- | Returns the index of the child matching the next step implied by target. +nextTargetStep :: WidgetNode s e -> Path -> Maybe PathStep +nextTargetStep node target = nextStep where + currentPath = node ^. L.info . L.path + nextStep = Seq.lookup (Seq.length currentPath) target + +{-| +Checks if the node is a candidate for next focus in the given direction. The +node must be focusable, enabled and visible, plus having the correct position +considering the direction. +-} +isFocusCandidate :: WidgetNode s e -> Path -> FocusDirection -> Bool +isFocusCandidate node path FocusFwd = isFocusFwdCandidate node path +isFocusCandidate node path FocusBwd = isFocusBwdCandidate node path + +-- | Checks if the node's path matches the target. +isTargetReached :: WidgetNode s e -> Path -> Bool +isTargetReached node target = target == node ^. L.info . L.path + +-- | Checks if the node has a child matching the next target step. +isTargetValid :: WidgetNode s e -> Path -> Bool +isTargetValid node target = valid where + children = node ^. L.children + valid = case nextTargetStep node target of + Just step -> step < Seq.length children + Nothing -> False + +-- | Checks if the node is parent of the provided path. +isNodeParentOfPath :: WidgetNode s e -> Path -> Bool +isNodeParentOfPath node path = result where + widgetPath = node ^. L.info . L.path + lenWidgetPath = Seq.length widgetPath + pathPrefix = Seq.take lenWidgetPath path + result = widgetPath == pathPrefix + +-- | Checks if the node's path is after the target (deeper or to the right). +isNodeAfterPath :: WidgetNode s e -> Path -> Bool +isNodeAfterPath node path = result where + widgetPath = node ^. L.info . L.path + lenPath = Seq.length path + lenWidgetPath = Seq.length widgetPath + widgetPathPrefix = Seq.take lenPath widgetPath + result + | lenWidgetPath > lenPath = path <= widgetPathPrefix + | otherwise = path < widgetPath + +-- | Checks if the node's path is after the target (higher or to the left). +isNodeBeforePath :: WidgetNode s e -> Path -> Bool +isNodeBeforePath node path = result where + widgetPath = node ^. L.info . L.path + result + | path == emptyPath = True + | otherwise = path > widgetPath + +-- | Generates a result with events and requests associated to a focus change. +handleFocusChange + :: WidgetNode s e -- ^ The node receiving the event. + -> Path -- ^ The path of next/prev target, accordingly. + -> [Path -> WidgetRequest s e] -- ^ Getter for reqs handler in a config type. + -> Maybe (WidgetResult s e) -- ^ The result. +handleFocusChange node path reqFns = result where + reqs = ($ path) <$> reqFns + result + | not (null reqs) = Just $ resultReqs node reqs + | otherwise = Nothing + +-- Helpers +isFocusFwdCandidate :: WidgetNode s e -> Path -> Bool +isFocusFwdCandidate node startFrom = isValid where + info = node ^. L.info + isAfter = isNodeAfterPath node startFrom + isFocusable = info ^. L.focusable + isEnabled = info ^. L.visible && info ^. L.enabled + isValid = isAfter && isFocusable && isEnabled + +isFocusBwdCandidate :: WidgetNode s e -> Path -> Bool +isFocusBwdCandidate node startFrom = isValid where + info = node ^. L.info + isBefore = isNodeBeforePath node startFrom + isFocusable = info ^. L.focusable + isEnabled = info ^. L.visible && info ^. L.enabled + isValid = isBefore && isFocusable && isEnabled diff --git a/src/Monomer/Widgets/Util/Hover.hs b/src/Monomer/Widgets/Util/Hover.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Hover.hs @@ -0,0 +1,150 @@ +{-| +Module : Monomer.Widgets.Util.Hover +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for hover related actions. +-} +module Monomer.Widgets.Util.Hover ( + isPointInNodeVp, + isPointInNodeEllipse, + isNodeActive, + isNodeInfoActive, + isNodePressed, + isNodeInfoPressed, + isNodeTreeActive, + isNodeTreePressed, + isNodeDragged, + isNodeInfoDragged, + isNodeHovered, + isNodeInfoHovered, + isNodeHoveredEllipse_, + isNodeTopLevel, + isNodeInfoTopLevel, + isNodeInOverlay, + isNodeInfoInOverlay +) where + +import Control.Lens ((&), (^.), (^?), _1, _Just) +import Data.Maybe + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Helper + +import qualified Monomer.Core.Lens as L +import qualified Monomer.Event.Lens as L + +-- | Checks if the given point is inside the node's viewport. +isPointInNodeVp :: WidgetNode s e -> Point -> Bool +isPointInNodeVp node p = pointInRect p (node ^. L.info . L.viewport) + +-- | Checks if the given point is inside the ellipse delimited by the viewport. +isPointInNodeEllipse :: WidgetNode s e -> Point -> Bool +isPointInNodeEllipse node p = pointInEllipse p (node ^. L.info . L.viewport) + +-- | Checks if the main button is pressed and pointer inside the vieport. +isNodeActive :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeActive wenv node = isNodeInfoActive False wenv (node ^. L.info) + +-- | Checks if the main button is pressed inside the vieport. +isNodePressed :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodePressed wenv node = isNodeInfoPressed False wenv (node ^. L.info) + +-- | Checks if the node or any of its children is active. +isNodeTreeActive :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeTreeActive wenv node = isNodeInfoActive True wenv (node ^. L.info) + +-- | Checks if the node or any of its children is pressed. +isNodeTreePressed :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeTreePressed wenv node = isNodeInfoPressed True wenv (node ^. L.info) + +{-| +Checks if the node is active, optionally including children. An active node was +clicked with the main button and has the pointer inside its viewport. +-} +isNodeInfoActive :: Bool -> WidgetEnv s e -> WidgetNodeInfo -> Bool +isNodeInfoActive includeChildren wenv info = validPos && pressed where + viewport = info ^. L.viewport + mousePos = wenv ^. L.inputStatus . L.mousePos + validPos = pointInRect mousePos viewport + pressed = isNodeInfoPressed includeChildren wenv info + +{-| +Checks if the node is pressed, optionally including children. A pressed node was +clicked with the main button, but the pointer may not be inside its viewport. +-} +isNodeInfoPressed :: Bool -> WidgetEnv s e -> WidgetNodeInfo -> Bool +isNodeInfoPressed includeChildren wenv info = result == Just True where + path = info ^. L.path + pressed = wenv ^. L.mainBtnPress ^? _Just . _1 + result + | includeChildren = seqStartsWith path <$> pressed + | otherwise = (path ==) <$> pressed + +{-| +Checks if the node is being dragged. The node must have made a previous request +to be in that state. +-} +isNodeDragged :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeDragged wenv node = isNodeInfoDragged wenv (node ^. L.info) + +-- | Checks if the nodeInfo is being dragged. +isNodeInfoDragged :: WidgetEnv s e -> WidgetNodeInfo -> Bool +isNodeInfoDragged wenv info = mainPressed && draggedPath == Just nodePath where + mainPressed = isJust (wenv ^. L.mainBtnPress) + draggedPath = wenv ^? L.dragStatus . _Just . _1 + nodePath = info ^. L.path + +-- | Checks if node is hovered. Pointer must be in viewport and node top layer. +isNodeHovered :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeHovered wenv node = isNodeInfoHovered wenv (node ^. L.info) + +-- | Checks if nodeInfo is hovered. +isNodeInfoHovered :: WidgetEnv s e -> WidgetNodeInfo -> Bool +isNodeInfoHovered wenv info = validPos && validPress && topLevel where + viewport = info ^. L.viewport + mousePos = wenv ^. L.inputStatus . L.mousePos + validPos = pointInRect mousePos viewport + pressed = wenv ^. L.mainBtnPress ^? _Just . _1 + validPress = isNothing pressed || isNodeInfoPressed False wenv info + topLevel = isNodeInfoTopLevel wenv info + +-- | Checks if node is hovered, limited to an elliptical shape. +isNodeHoveredEllipse_ :: Rect -> WidgetEnv s e -> WidgetNode s e -> Bool +isNodeHoveredEllipse_ area wenv node = validPos && validPress && topLevel where + mousePos = wenv ^. L.inputStatus . L.mousePos + validPos = pointInEllipse mousePos area + pressed = wenv ^. L.mainBtnPress ^? _Just . _1 + validPress = isNothing pressed || isNodePressed wenv node + topLevel = isNodeTopLevel wenv node + +{-| +Checks if a node is in a top layer. Being in zstack can cause this to be False. +-} +isNodeTopLevel :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeTopLevel wenv node = isNodeInfoTopLevel wenv (node ^. L.info) + +-- | Checks if a nodeInfo is in a top layer. +isNodeInfoTopLevel :: WidgetEnv s e -> WidgetNodeInfo -> Bool +isNodeInfoTopLevel wenv info = result where + mousePos = wenv ^. L.inputStatus . L.mousePos + inTopLayer = wenv ^. L.inTopLayer $ mousePos + path = info ^. L.path + isPrefix parent = Seq.take (Seq.length parent) path == parent + result = maybe inTopLayer isPrefix (wenv ^. L.overlayPath) + +-- | Checks if the node is part of the active overlay, if any. +isNodeInOverlay :: WidgetEnv s e -> WidgetNode s e -> Bool +isNodeInOverlay wenv node = isNodeInfoInOverlay wenv (node ^. L.info) + +-- | Checks if the nodeInfo is part of the active overlay, if any. +isNodeInfoInOverlay :: WidgetEnv s e -> WidgetNodeInfo -> Bool +isNodeInfoInOverlay wenv info = result where + path = info ^. L.path + isPrefix overlayPath = Seq.take (Seq.length overlayPath) path == overlayPath + result = maybe False isPrefix (wenv ^. L.overlayPath) diff --git a/src/Monomer/Widgets/Util/Keyboard.hs b/src/Monomer/Widgets/Util/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Keyboard.hs @@ -0,0 +1,62 @@ +{-| +Module : Monomer.Widgets.Util.Keyboard +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Utility functions for widget keyboard handling. +-} +module Monomer.Widgets.Util.Keyboard ( + isShortCutControl, + isKeyboardCopy, + isKeyboardPaste, + isKeyboardCut, + isKeyboardUndo, + isKeyboardRedo +) where + +import Data.Maybe (fromMaybe) + +import qualified Data.Map as M + +import Monomer.Core +import Monomer.Event.Keyboard +import Monomer.Event.Types +import Monomer.Event.Util + +-- | Checks if Ctrl/Cmd, depending on OS, is pressed. +isShortCutControl :: WidgetEnv s e -> KeyMod -> Bool +isShortCutControl wenv mod = isControl || isCommand where + isControl = not (isMacOS wenv) && isCtrlPressed mod + isCommand = isMacOS wenv && isGUIPressed mod + +-- | Checks if a copy shortcut has been pressed. +isKeyboardCopy :: WidgetEnv s e -> SystemEvent -> Bool +isKeyboardCopy wenv event = checkKeyboard event testFn where + testFn mod code motion = isShortCutControl wenv mod && isKeyC code + +-- | Checks if a paste shortcut has been pressed. +isKeyboardPaste :: WidgetEnv s e -> SystemEvent -> Bool +isKeyboardPaste wenv event = checkKeyboard event testFn where + testFn mod code motion = isShortCutControl wenv mod && isKeyV code + +-- | Checks if a cut shortcut has been pressed. +isKeyboardCut :: WidgetEnv s e -> SystemEvent -> Bool +isKeyboardCut wenv event = checkKeyboard event testFn where + testFn mod code motion = isShortCutControl wenv mod && isKeyX code + +-- | Checks if an undo shortcut has been pressed. +isKeyboardUndo :: WidgetEnv s e -> SystemEvent -> Bool +isKeyboardUndo wenv event = checkKeyboard event testFn where + testFn mod code motion = isShortCutControl wenv mod + && not (_kmLeftShift mod) + && isKeyZ code + +-- | Checks if a redo shortcut has been pressed. +isKeyboardRedo :: WidgetEnv s e -> SystemEvent -> Bool +isKeyboardRedo wenv event = checkKeyboard event testFn where + testFn mod code motion = isShortCutControl wenv mod + && _kmLeftShift mod + && isKeyZ code diff --git a/src/Monomer/Widgets/Util/Lens.hs b/src/Monomer/Widgets/Util/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Lens.hs @@ -0,0 +1,21 @@ +{-| +Module : Monomer.Widgets.Util.Lens +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Lenses for the Widget types. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Util.Lens where + +import Control.Lens.TH (abbreviatedFields, makeLensesWith) + +import Monomer.Widgets.Util.Types + +makeLensesWith abbreviatedFields ''CurrentStyleCfg diff --git a/src/Monomer/Widgets/Util/Parser.hs b/src/Monomer/Widgets/Util/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Parser.hs @@ -0,0 +1,32 @@ +{-| +Module : Monomer.Widgets.Util.Parser +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Very basic parsing helpers used by numeric input fields. +-} +module Monomer.Widgets.Util.Parser where + +import Control.Applicative ((<|>)) +import Data.Text (Text) + +import qualified Data.Attoparsec.Text as A +import qualified Data.Text as T + +-- | Combines a list of text parsers. +join :: [A.Parser Text] -> A.Parser Text +join [] = return T.empty +join (x:xs) = (<>) <$> x <*> join xs + +-- | Combines a parser up to a maximum of repetitions. +upto :: Int -> A.Parser Text -> A.Parser Text +upto n p + | n > 0 = (<>) <$> A.try p <*> upto (n-1) p <|> return T.empty + | otherwise = return T.empty + +-- | Matches a single character. +single :: Char -> A.Parser Text +single c = T.singleton <$> A.char c diff --git a/src/Monomer/Widgets/Util/Style.hs b/src/Monomer/Widgets/Util/Style.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Style.hs @@ -0,0 +1,325 @@ +{-| +Module : Monomer.Widgets.Util.Style +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for style related operations. +-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Monomer.Widgets.Util.Style ( + collectStyleField, + collectStyleField_, + currentTheme, + currentTheme_, + currentStyle, + currentStyle_, + focusedStyle, + styleStateChanged, + initNodeStyle, + mergeBasicStyle, + handleStyleChange, + childOfFocusedStyle +) where + +import Control.Applicative ((<|>)) +import Control.Lens (Lens', (&), (^.), (^?), (.~), (?~), (<>~), _Just, _1, non) + +import Data.Bits (xor) +import Data.Default +import Data.Maybe +import Data.Sequence (Seq(..), (<|), (|>)) + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Event +import Monomer.Helper +import Monomer.Widgets.Util.Focus +import Monomer.Widgets.Util.Hover +import Monomer.Widgets.Util.Types +import Monomer.Widgets.Util.Widget + +import qualified Monomer.Core.Lens as L +import qualified Monomer.Event.Lens as L + +instance Default (CurrentStyleCfg s e) where + def = CurrentStyleCfg { + _ascIsHovered = isNodeHovered, + _ascIsFocused = isNodeFocused, + _ascIsActive = isNodeActive + } + +-- | Extracts/copies the field of a style into an empty style. +collectStyleField + :: Lens' StyleState (Maybe t) -- ^ The field into the state. + -> Style -- ^ The source style. + -> Style -- ^ The new style. +collectStyleField fieldS source = collectStyleField_ fieldS source def + +-- | Extracts/copies the field of a style into a provided style. +collectStyleField_ + :: Lens' StyleState (Maybe t) -- ^ The field into the state. + -> Style -- ^ The source style. + -> Style -- ^ The target style. + -> Style -- ^ The updated style. +collectStyleField_ fieldS source target = style where + setValue stateLens = result where + sourceState = source ^. stateLens + targetState = target ^. stateLens + value = sourceState ^? _Just . fieldS . _Just + setTarget val = targetState ^. non def + & fieldS ?~ val + resetTarget = targetState ^. non def + & fieldS .~ Nothing + result + | isJust value = setTarget <$> value + | isJust targetState = Just resetTarget + | otherwise = Nothing + + basic = setValue L.basic + hover = setValue L.hover + focus = setValue L.focus + focusHover = setValue L.focusHover + active = setValue L.active + disabled = setValue L.disabled + style = Style basic hover focus focusHover active disabled + +-- | Returns the current style state for the given node. +currentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState +currentStyle wenv node = currentStyle_ def wenv node + +{-| +Returns the current style state for the given node, using the provided functions +to determine hover, focus and active status. +-} +currentStyle_ + :: CurrentStyleCfg s e -> WidgetEnv s e -> WidgetNode s e -> StyleState +currentStyle_ config wenv node = fromMaybe def styleState where + Style{..} = node ^. L.info . L.style + mousePos = wenv ^. L.inputStatus . L.mousePos + isEnabled = node ^. L.info . L.enabled + + isHover = _ascIsHovered config wenv node + isFocus = _ascIsFocused config wenv node + isActive = _ascIsActive config wenv node + + styleState + | not isEnabled = _styleDisabled + | isActive = _styleActive + | isHover && isFocus = _styleFocusHover + | isHover = _styleHover + | isFocus = _styleFocus + | otherwise = _styleBasic + +-- | Returns the correct focused style, depending if it's hovered or not. +focusedStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState +focusedStyle wenv node = focusedStyle_ isNodeHovered wenv node + +{-| +Returns the correct focused style, depending if it's hovered or not, using the +provided function. +-} +focusedStyle_ :: IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> StyleState +focusedStyle_ isHoveredFn wenv node = fromMaybe def styleState where + Style{..} = node ^. L.info . L.style + isHover = isHoveredFn wenv node + styleState + | isHover = _styleFocusHover + | otherwise = _styleFocus + +-- | Returns the current theme for the node. +currentTheme :: WidgetEnv s e -> WidgetNode s e -> ThemeState +currentTheme wenv node = currentTheme_ isNodeHovered wenv node + +-- | Returns the current theme for the node. +currentTheme_ :: IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> ThemeState +currentTheme_ isHoveredFn wenv node = themeState where + theme = _weTheme wenv + mousePos = wenv ^. L.inputStatus . L.mousePos + isEnabled = node ^. L.info . L.enabled + + isHover = isHoveredFn wenv node + isFocus = isNodeFocused wenv node + isActive = isNodeActive wenv node + + themeState + | not isEnabled = _themeDisabled theme + | isActive = _themeActive theme + | isHover && isFocus = _themeFocusHover theme + | isHover = _themeHover theme + | isFocus = _themeFocus theme + | otherwise = _themeBasic theme + +-- | Checks if hover or focus states changed between versions of the node. +styleStateChanged :: WidgetEnv s e -> WidgetNode s e -> SystemEvent -> Bool +styleStateChanged wenv node evt = hoverChanged || focusChanged where + -- Hover + hoverChanged = isOnEnter evt || isOnLeave evt + -- Focus + focusChanged = isOnFocus evt || isOnBlur evt + +{-| +Initializes the node style states. Mainly, it uses basic as the base of all the +other styles. +-} +initNodeStyle + :: GetBaseStyle s e -- ^ The function to get the base style. + -> WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The widget node. + -> WidgetNode s e -- ^ The updated widget node. +initNodeStyle getBaseStyle wenv node = newNode where + nodeStyle = mergeBasicStyle $ node ^. L.info . L.style + baseStyle = mergeBasicStyle $ fromMaybe def (getBaseStyle wenv node) + newNode = node + & L.info . L.style .~ (baseStyle <> nodeStyle) + +-- | Uses the basic style state as the base for all the other style states. +mergeBasicStyle :: Style -> Style +mergeBasicStyle st = newStyle where + focusHover = _styleHover st <> _styleFocus st <> _styleFocusHover st + active = focusHover <> _styleActive st + newStyle = Style { + _styleBasic = _styleBasic st, + _styleHover = _styleBasic st <> _styleHover st, + _styleFocus = _styleBasic st <> _styleFocus st, + _styleFocusHover = _styleBasic st <> focusHover, + _styleActive = _styleBasic st <> active, + _styleDisabled = _styleBasic st <> _styleDisabled st + } + +{-| +Checks for style changes between the old node and the provided result, in the +context of an event. Generates requests for resize, render and cursor change as +necessary. +-} +handleStyleChange + :: WidgetEnv s e -- ^ The widget environment. + -> Path -- ^ The target of the event. + -> StyleState -- ^ The active style. + -> Bool -- ^ Whether to check/update the cursor. + -> WidgetNode s e -- ^ The old node. + -> SystemEvent -- ^ The event. + -> Maybe (WidgetResult s e) -- ^ The result containing the new node. + -> Maybe (WidgetResult s e) -- ^ The updated result. +handleStyleChange wenv target style doCursor node evt result = newResult where + tmpResult = handleSizeChange wenv target evt node result + newResult + | doCursor = handleCursorChange wenv target evt style node tmpResult + | otherwise = tmpResult + +{-| +Replacement of currentStyle for child widgets embedded in a focusable parent. It +selects the correct style state according to the situation. + +Used, for example, in `Button` and `ExternalLink`, which are focusable but have +an embedded label. Since label is not focusable, that style would not be handled +correctly. +-} +childOfFocusedStyle + :: WidgetEnv s e -- ^ The widget environment. + -> WidgetNode s e -- ^ The embedded child node. + -> StyleState -- ^ The currently active state. +childOfFocusedStyle wenv cnode = newStyle where + pinfo = fromMaybe def (wenv ^. L.findByPath $ parentPath cnode) + cstyle = cnode ^. L.info . L.style + enabled = cnode ^. L.info . L.enabled + + activeC = isNodeActive wenv cnode + activeP = isNodeInfoActive False wenv pinfo + + hoverC = isNodeHovered wenv cnode + hoverP = isNodeInfoHovered wenv pinfo + focusP = isNodeInfoFocused wenv pinfo + + newStyle + | not enabled = fromMaybe def (_styleDisabled cstyle) + | activeC || activeP = fromMaybe def (_styleActive cstyle) + | (hoverC || hoverP) && focusP = fromMaybe def (_styleFocusHover cstyle) + | hoverC || hoverP = fromMaybe def (_styleHover cstyle) + | focusP = fromMaybe def (_styleFocus cstyle) + | otherwise = currentStyle wenv cnode + +-- Helpers +handleSizeChange + :: WidgetEnv s e + -> Path + -> SystemEvent + -> WidgetNode s e + -> Maybe (WidgetResult s e) + -> Maybe (WidgetResult s e) +handleSizeChange wenv target evt oldNode result = newResult where + baseResult = fromMaybe (resultNode oldNode) result + newNode = baseResult ^. L.node + widgetId = newNode ^. L.info . L.widgetId + path = newNode ^. L.info . L.path + -- Size + oldSizeReqW = oldNode ^. L.info . L.sizeReqW + oldSizeReqH = oldNode ^. L.info . L.sizeReqH + newSizeReqW = newNode ^. L.info . L.sizeReqW + newSizeReqH = newNode ^. L.info . L.sizeReqH + sizeReqChanged = oldSizeReqW /= newSizeReqW || oldSizeReqH /= newSizeReqH + -- Hover drag changed (if dragging, Enter/Leave is not sent) + prevInVp = isPointInNodeVp newNode (wenv ^. L.inputStatus . L.mousePosPrev) + currInVp = isPointInNodeVp newNode (wenv ^. L.inputStatus . L.mousePos) + pressedPath = wenv ^. L.mainBtnPress ^? _Just . _1 + hoverDragChg = Just path == pressedPath && prevInVp /= currInVp + -- Result + renderReq = isOnEnter evt || isOnLeave evt || hoverDragChg + resizeReq = [ ResizeWidgets widgetId | sizeReqChanged ] + enterReq = [ RenderOnce | renderReq ] + reqs = resizeReq ++ enterReq + newResult + | not (null reqs) = Just $ baseResult + & L.requests <>~ Seq.fromList reqs + | otherwise = result + +handleCursorChange + :: WidgetEnv s e + -> Path + -> SystemEvent + -> StyleState + -> WidgetNode s e + -> Maybe (WidgetResult s e) + -> Maybe (WidgetResult s e) +handleCursorChange wenv target evt style oldNode result = newResult where + baseResult = fromMaybe (resultNode oldNode) result + baseReqs = baseResult ^. L.requests + node = baseResult ^. L.node + -- Cursor + widgetId = node ^. L.info . L.widgetId + path = node ^. L.info . L.path + isTarget = path == target + hasCursor = isJust (style ^. L.cursorIcon) + isPressed = isNodePressed wenv node + (curPath, curIcon) = fromMaybe def (wenv ^. L.cursor) + isParent = seqStartsWith path curPath && path /= curPath + newIcon = fromMaybe CursorArrow (style ^. L.cursorIcon) + + setCursor = hasCursor + && isCursorEvt evt + && not isParent + && curIcon /= newIcon + resetCursor = isTarget + && not hasCursor + && isCursorEvt evt + && not isPressed + && curPath == path + -- Result + newResult + | setCursor = Just $ baseResult + & L.requests .~ SetCursorIcon widgetId newIcon <| baseReqs + | resetCursor = Just $ baseResult + & L.requests .~ baseReqs |> ResetCursorIcon widgetId + | otherwise = result + +isCursorEvt :: SystemEvent -> Bool +isCursorEvt Enter{} = True +isCursorEvt Click{} = True +isCursorEvt ButtonAction{} = True +isCursorEvt Move{} = True +isCursorEvt _ = False diff --git a/src/Monomer/Widgets/Util/Text.hs b/src/Monomer/Widgets/Util/Text.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Text.hs @@ -0,0 +1,101 @@ +{-| +Module : Monomer.Widgets.Util.Text +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions to text related operations in widgets. +-} +{-# LANGUAGE BangPatterns #-} + +module Monomer.Widgets.Util.Text ( + getTextMetrics, + getTextSize, + getTextSize_, + getSingleTextLineRect, + getTextGlyphs +) where + +import Control.Lens ((&), (^.), (+~)) +import Data.Default +import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Text (Text) + +import Monomer.Core +import Monomer.Graphics + +import qualified Monomer.Core.Lens as L + +-- | Returns the text metrics of the active style. +getTextMetrics :: WidgetEnv s e -> StyleState -> TextMetrics +getTextMetrics wenv style = textMetrics where + fontMgr = wenv ^. L.fontManager + !textMetrics = computeTextMetrics fontMgr font fontSize + font = styleFont style + fontSize = styleFontSize style + +-- | Returns the size of the text using the active style and default options. +getTextSize :: WidgetEnv s e -> StyleState -> Text -> Size +getTextSize wenv style !text = size where + fontMgr = wenv ^. L.fontManager + size = calcTextSize_ fontMgr style SingleLine KeepSpaces Nothing Nothing text + +-- | Returns the size of the text using the active style. +getTextSize_ + :: WidgetEnv s e -- ^ The widget environment. + -> StyleState -- ^ The active style. + -> TextMode -- ^ Whether to use single or multi line. + -> TextTrim -- ^ Whether to trim spacers or keep them. + -> Maybe Double -- ^ Maximum width (required for multi line). + -> Maybe Int -- ^ Max lines. + -> Text -- ^ Text to measure. + -> Size -- ^ The calculated size. +getTextSize_ wenv style mode trim mwidth mlines text = newSize where + fontMgr = wenv ^. L.fontManager + newSize = calcTextSize_ fontMgr style mode trim mwidth mlines text + +-- | Returns the rect a single line of text needs to be displayed completely. +getSingleTextLineRect + :: WidgetEnv s e -- ^ The widget environment. + -> StyleState -- ^ The active style. + -> Rect -- ^ The bounding rect. + -> AlignTH -- ^ The horizontal alignment. + -> AlignTV -- ^ The vertical alignment. + -> Text -- ^ The text to measure. + -> Rect -- ^ The used rect. May be larger than the bounding rect. +getSingleTextLineRect wenv style !rect !alignH !alignV !text = textRect where + fontMgr = wenv ^. L.fontManager + font = styleFont style + fSize = styleFontSize style + fSpcH = styleFontSpaceH style + + Rect x y w h = rect + Size tw _ = computeTextSize fontMgr font fSize fSpcH text + TextMetrics asc desc lineh lowerX = computeTextMetrics fontMgr font fSize + + tx | alignH == ATLeft = x + | alignH == ATCenter = x + (w - tw) / 2 + | otherwise = x + (w - tw) + ty | alignV == ATTop = y + asc + | alignV == ATMiddle = y + h + desc - (h - lineh) / 2 + | alignV == ATAscender = y + h - (h - asc) / 2 + | alignV == ATLowerX = y + h - (h - lowerX) / 2 + | otherwise = y + h + desc + + textRect = Rect { + _rX = tx, + _rY = ty - lineh, + _rW = tw, + _rH = lineh + } + +-- | Returns the glyphs of a single line of text. +getTextGlyphs :: WidgetEnv s e -> StyleState -> Text -> Seq GlyphPos +getTextGlyphs wenv style !text = glyphs where + fontMgr = wenv ^. L.fontManager + font = styleFont style + fSize = styleFontSize style + fSpcH = styleFontSpaceH style + !glyphs = computeGlyphsPos fontMgr font fSize fSpcH text diff --git a/src/Monomer/Widgets/Util/Theme.hs b/src/Monomer/Widgets/Util/Theme.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Theme.hs @@ -0,0 +1,74 @@ +{-| +Module : Monomer.Widgets.Util.Theme +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for loading theme values. +-} +{-# LANGUAGE RankNTypes #-} + +module Monomer.Widgets.Util.Theme where + +import Control.Lens (Lens', (&), (^.), (^?), (.~), (?~), (<>~), at, non) +import Data.Default +import Data.Maybe + +import Monomer.Core.StyleTypes +import Monomer.Core.ThemeTypes +import Monomer.Core.WidgetTypes + +import qualified Monomer.Core.Lens as L + +-- | Updates a the field of style with the field value from the active theme. +collectThemeField_ + :: WidgetEnv s e -- ^ The widget environment (to get the theme). + -> Lens' StyleState (Maybe t) -- ^ The target field of the style. + -> Lens' ThemeState (Maybe t) -- ^ The source field of the theme. + -> Style -- ^ The target style. + -> Style -- ^ The updated style. +collectThemeField_ wenv fieldStyle fieldTheme target = style where + basic = Just $ target ^. L.basic . non def + & fieldStyle .~ wenv ^. L.theme . L.basic . fieldTheme + hover = Just $ target ^. L.hover . non def + & fieldStyle .~ wenv ^. L.theme . L.hover . fieldTheme + focus = Just $ target ^. L.focus . non def + & fieldStyle .~ wenv ^. L.theme . L.focus . fieldTheme + focusHover = Just $ target ^. L.focusHover . non def + & fieldStyle .~ wenv ^. L.theme . L.focusHover . fieldTheme + active = Just $ target ^. L.active . non def + & fieldStyle .~ wenv ^. L.theme . L.active . fieldTheme + disabled = Just $ target ^. L.disabled . non def + & fieldStyle .~ wenv ^. L.theme . L.disabled . fieldTheme + style = Style basic hover focus focusHover active disabled + +-- | Collects all the style states from a given field in the active theme. +collectTheme + :: WidgetEnv s e -- ^ The widget environment (to get the theme). + -> Lens' ThemeState StyleState -- ^ The field into the theme + -> Style -- ^ The collected style. +collectTheme wenv fieldT = style where + basic = Just $ wenv ^. L.theme . L.basic . fieldT + hover = Just $ wenv ^. L.theme . L.hover . fieldT + focus = Just $ wenv ^. L.theme . L.focus . fieldT + focusHover = Just $ wenv ^. L.theme . L.focusHover . fieldT + active = Just $ wenv ^. L.theme . L.active . fieldT + disabled = Just $ wenv ^. L.theme . L.disabled . fieldT + style = Style basic hover focus focusHover active disabled + +-- | Collects all the style states from a given entry in the map of user styles +-- | in the active theme. +collectUserTheme + :: WidgetEnv s e -- ^ The widget environment (to get the theme). + -> String -- ^ The key into the user map. + -> Style -- ^ The collected style. +collectUserTheme wenv name = style where + basic = wenv ^. L.theme . L.basic . L.userStyleMap . at name + hover = wenv ^. L.theme . L.hover . L.userStyleMap . at name + focus = wenv ^. L.theme . L.focus . L.userStyleMap . at name + focusHover = wenv ^. L.theme . L.focusHover . L.userStyleMap . at name + active = wenv ^. L.theme . L.active . L.userStyleMap . at name + disabled = wenv ^. L.theme . L.disabled . L.userStyleMap . at name + style = Style basic hover focus focusHover active disabled diff --git a/src/Monomer/Widgets/Util/Types.hs b/src/Monomer/Widgets/Util/Types.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Types.hs @@ -0,0 +1,49 @@ +{-| +Module : Monomer.Widgets.Util.Types +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Common types for widget related functions. +-} +module Monomer.Widgets.Util.Types ( + IsHovered, + IsFocused, + IsActive, + GetBaseStyle, + CurrentStyleCfg(..) +) where + +import Monomer.Core.StyleTypes +import Monomer.Core.WidgetTypes + +-- | Indicates whether the mouse pointer is over a valid region the given node. +type IsHovered s e = WidgetEnv s e -> WidgetNode s e -> Bool +-- | Indicates whether the given node has keyboard focus. +type IsFocused s e = WidgetEnv s e -> WidgetNode s e -> Bool +-- | Indicates whether the given node is clicked on a valid region. +type IsActive s e = WidgetEnv s e -> WidgetNode s e -> Bool + +{-| +Returns the base style for a given node, if any. This is widget dependent. + +Usually this style comes from the active theme. +-} +type GetBaseStyle s e + = WidgetEnv s e + -> WidgetNode s e + -> Maybe Style + +{-| +Configuration for style related functions. It allows to override how each of the +states (hovered, focused and active) is defined for a given widget type. + +A usage example can be found in "Monomer.Widgets.Radio". +-} +data CurrentStyleCfg s e = CurrentStyleCfg { + _ascIsHovered :: IsHovered s e, + _ascIsFocused :: IsFocused s e, + _ascIsActive :: IsActive s e +} diff --git a/src/Monomer/Widgets/Util/Widget.hs b/src/Monomer/Widgets/Util/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Util/Widget.hs @@ -0,0 +1,221 @@ +{-| +Module : Monomer.Widgets.Util.Widget +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for widget lifecycle. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Util.Widget ( + defaultWidgetNode, + isWidgetVisible, + nodeVisibleChanged, + nodeEnabledChanged, + nodeFlagsChanged, + childrenVisibleChanged, + childrenEnabledChanged, + childrenFlagsChanged, + widgetDataGet, + widgetDataSet, + resultNode, + resultEvts, + resultReqs, + resultReqsEvts, + makeState, + useState, + useShared, + infoMatches, + nodeMatches, + handleWidgetIdChange, + findWidgetIdFromPath, + delayedMessage, + delayedMessage_ +) where + +import Control.Concurrent (threadDelay) +import Control.Lens ((&), (^#), (#~), (^.), (^?), (.~), (%~), _Just) +import Data.ByteString.Lazy (ByteString) +import Data.Default +import Data.Maybe +import Data.Map.Strict (Map) +import Data.Sequence (Seq(..), (<|)) +import Data.Text (Text) +import Data.Typeable (Typeable, cast) + +import qualified Data.Map.Strict as M +import qualified Data.Sequence as Seq + +import Monomer.Common +import Monomer.Core.WidgetTypes + +import qualified Monomer.Core.Lens as L + +-- | Creates a basic widget node, with the given type, instance and no children. +defaultWidgetNode :: WidgetType -> Widget s e -> WidgetNode s e +defaultWidgetNode widgetType widget = WidgetNode { + _wnWidget = widget, + _wnInfo = def & L.widgetType .~ widgetType, + _wnChildren = Seq.empty +} + +-- | Checks if the node is within the visible viewport, and itself visible. +isWidgetVisible :: WidgetEnv s e -> WidgetNode s e -> Bool +isWidgetVisible wenv node = isVisible && isOverlapped where + info = node ^. L.info + isVisible = info ^. L.visible + viewport = wenv ^. L.viewport + isOverlapped = rectsOverlap viewport (info ^. L.viewport) + +-- | Checks if the visibility flags changed between the old and new node. +nodeVisibleChanged :: WidgetNode s e -> WidgetNode s e -> Bool +nodeVisibleChanged oldNode newNode = oldVisible /= newVisible where + oldVisible = oldNode ^. L.info . L.visible + newVisible = newNode ^. L.info . L.visible + +-- | Checks if the enabled flags changed between the old and new node. +nodeEnabledChanged :: WidgetNode s e -> WidgetNode s e -> Bool +nodeEnabledChanged oldNode newNode = oldEnabled /= newEnabled where + oldEnabled = oldNode ^. L.info . L.enabled + newEnabled = newNode ^. L.info . L.enabled + +-- | Checks if the enabled/visible flags changed between the old and new node. +nodeFlagsChanged :: WidgetNode s e -> WidgetNode s e -> Bool +nodeFlagsChanged oldNode newNode = visibleChanged || enabledChanged where + visibleChanged = nodeVisibleChanged oldNode newNode + enabledChanged = nodeEnabledChanged oldNode newNode + +-- | Checks if the visibility flags changed between the old and new children. +-- | A change in count will result in a True result. +childrenVisibleChanged :: WidgetNode s e -> WidgetNode s e -> Bool +childrenVisibleChanged oldNode newNode = oldVisible /= newVisible where + oldVisible = fmap (^. L.info . L.visible) (oldNode ^. L.children) + newVisible = fmap (^. L.info . L.visible) (newNode ^. L.children) + +-- | Checks if the enabled flags changed between the old and new children. +-- | A change in count will result in a True result. +childrenEnabledChanged :: WidgetNode s e -> WidgetNode s e -> Bool +childrenEnabledChanged oldNode newNode = oldVisible /= newVisible where + oldVisible = fmap (^. L.info . L.enabled) (oldNode ^. L.children) + newVisible = fmap (^. L.info . L.enabled) (newNode ^. L.children) + +-- | Checks if enabled/visible flags changed between the old and new children. +-- | A change in count will result in a True result. +childrenFlagsChanged :: WidgetNode s e -> WidgetNode s e -> Bool +childrenFlagsChanged oldNode newNode = lenChanged || flagsChanged where + oldChildren = oldNode ^. L.children + newChildren = newNode ^. L.children + flagsChanged = or (Seq.zipWith nodeFlagsChanged oldChildren newChildren) + lenChanged = length oldChildren /= length newChildren + +-- | Returns the current value associated to the WidgetData. +widgetDataGet :: s -> WidgetData s a -> a +widgetDataGet _ (WidgetValue value) = value +widgetDataGet model (WidgetLens lens) = model ^# lens + +{-| +Generates a model update request with the provided value when the WidgetData is +WidgetLens. For WidgetValue and onChange event should be used. +-} +widgetDataSet :: WidgetData s a -> a -> [WidgetRequest s e] +widgetDataSet WidgetValue{} _ = [] +widgetDataSet (WidgetLens lens) value = [UpdateModel updateFn] where + updateFn model = model & lens #~ value + +-- | Generates a WidgetResult with only the node field filled. +resultNode :: WidgetNode s e -> WidgetResult s e +resultNode node = WidgetResult node Seq.empty + +-- | Generates a WidgetResult with the node field and events filled. +resultEvts :: Typeable e => WidgetNode s e -> [e] -> WidgetResult s e +resultEvts node events = result where + result = WidgetResult node (Seq.fromList $ RaiseEvent <$> events) + +-- | Generates a WidgetResult with the node field and reqs filled. +resultReqs :: WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e +resultReqs node requests = result where + result = WidgetResult node (Seq.fromList requests) + +{-| +Generates a WidgetResult with the node, events and reqs fields filled. These +related helpers exist because list has nicer literal syntax than Seq. + +The events are appended __after__ the requests. If a specific order of events +and requests is needed, add the events to reqs using RaiseEvent. +-} +resultReqsEvts + :: Typeable e + => WidgetNode s e -- ^ The new version of the node. + -> [WidgetRequest s e] -- ^ The widget requests. + -> [e] -- ^ The user events. + -> WidgetResult s e -- ^ The result. +resultReqsEvts node requests events = result where + result = WidgetResult node (Seq.fromList requests <> evtSeq) + evtSeq = Seq.fromList $ RaiseEvent <$> events + +{-| +Wraps a value in WidgetState, ignoring wenv and node. Useful when creating +Widget instances if the state is available beforehand. +-} +makeState + :: WidgetModel i => i -> WidgetEnv s e -> WidgetNode s e -> Maybe WidgetState +makeState state wenv node = Just (WidgetState state) + +-- | Casts the wrapped value in WidgetState to the expected type, if possible. +useState :: WidgetModel i => Maybe WidgetState -> Maybe i +useState Nothing = Nothing +useState (Just (WidgetState state)) = cast state + +-- | Casts the wrapped value in WidgetShared to the expected type, if possible. +useShared :: Typeable i => Maybe WidgetShared -> Maybe i +useShared Nothing = Nothing +useShared (Just (WidgetShared shared)) = cast shared + +-- | Checks if the type and key of two WidgetNodeInfo match. +infoMatches :: WidgetNodeInfo -> WidgetNodeInfo -> Bool +infoMatches oldInfo newInfo = typeMatches && keyMatches where + typeMatches = oldInfo ^. L.widgetType == newInfo ^. L.widgetType + keyMatches = oldInfo ^. L.key == newInfo ^. L.key + +-- | Checks if the type and key of two WidgetNodes match. +nodeMatches :: WidgetNode s e -> WidgetNode s e -> Bool +nodeMatches oldNode newNode = infoMatches oldInfo newInfo where + oldInfo = oldNode ^. L.info + newInfo = newNode ^. L.info + +{-| +Checks if the path the node in the provided result changed compared to the old +node. In case it did, it appends a SetWidgetPath request to keep track of the +new location. +-} +handleWidgetIdChange :: WidgetNode s e -> WidgetResult s e -> WidgetResult s e +handleWidgetIdChange oldNode result = newResult where + oldPath = oldNode ^. L.info . L.path + newPath = result ^. L.node . L.info . L.path + widgetId = result ^. L.node . L.info . L.widgetId + newResult + | oldPath /= newPath = result + & 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 + mwni = wenv ^. L.findByPath $ path + +-- | 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 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 +delayedMessage_ widgetId path msg delay = RunTask widgetId path $ do + threadDelay (delay * 1000) + return msg diff --git a/test/unit/Monomer/Common/CursorIconSpec.hs b/test/unit/Monomer/Common/CursorIconSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Common/CursorIconSpec.hs @@ -0,0 +1,166 @@ +{-| +Module : Monomer.Common.CursorIconSpec +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 Cursor handling. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Common.CursorIconSpec (spec) where + +import Control.Lens +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Maybe +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Safe +import Test.Hspec + +import qualified Data.Map.Strict as M +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.Main +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Grid +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer +import Monomer.Widgets.Singles.TextDropdown + +import qualified Monomer.Lens as L + +newtype TestModel = TestModel { + _tmSelectedItem :: Int +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Cursor Icon" $ do + handleEventSimple + handleEventNested + handleEventOverlay + +handleEventSimple :: Spec +handleEventSimple = describe "handleEventSimple" $ do + it "should not change the cursor if not event happened" $ do + icons [] `shouldBe` [CursorArrow] + + it "should not change the cursor if the widget does not have a cursor" $ do + icons [[evtMove p1]] `shouldBe` [CursorArrow, CursorArrow] + + it "should change the cursor if the widget has a custom cursor" $ do + icons [[evtMove p2]] `shouldBe` [CursorArrow, CursorHand] + icons [[evtMove p3]] `shouldBe` [CursorArrow, CursorIBeam] + icons [[evtMove p4]] `shouldBe` [CursorArrow, CursorInvalid] + + it "should generate the correct sequence of cursors from the events" $ do + let evtsGroups = [[evtMove p2], [evtMove p3], [evtMove p4]] + icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorIBeam, CursorInvalid] + + where + wenv = mockWenvEvtUnit () + node = vstack [ + label "Test", + label "Test" `styleBasic` [cursorIcon CursorHand], + label "Test" `styleBasic` [cursorIcon CursorIBeam], + label "Test" `styleBasic` [cursorIcon CursorInvalid] + ] + icons egs = getIcons wenv node egs + p1 = Point 100 10 + p2 = Point 100 30 + p3 = Point 100 50 + p4 = Point 100 70 + +handleEventNested :: Spec +handleEventNested = describe "handleEventNested" $ do + it "should change the cursor if the widget has a custom cursor" $ do + icons [[evtMove p11]] `shouldBe` [CursorArrow, CursorArrow] + icons [[evtMove p21]] `shouldBe` [CursorArrow, CursorSizeH] + icons [[evtMove p22]] `shouldBe` [CursorArrow, CursorHand] + icons [[evtMove p31]] `shouldBe` [CursorArrow, CursorSizeV] + icons [[evtMove p32]] `shouldBe` [CursorArrow, CursorHand] + + it "should generate the correct sequence of cursors from the events" $ do + let evtsGroups = [[evtMove p11], [evtMove p21], [evtMove p22], [evtMove p31], [evtMove p32]] + icons evtsGroups `shouldBe` [CursorArrow, CursorArrow, CursorSizeH, CursorHand, CursorSizeV, CursorHand] + + where + wenv = mockWenvEvtUnit () + node = vstack [ + label "Test", + hgrid [ + hgrid [ + label "Test" `styleBasic` [cursorIcon CursorSizeH], + filler + ] + ] `styleBasic` [cursorIcon CursorHand], + hgrid [ + hgrid [ + label "Test" `styleBasic` [cursorIcon CursorSizeV], + filler + ] `styleBasic` [cursorIcon CursorInvalid], + spacer + ] `styleBasic` [cursorIcon CursorHand] + ] + icons egs = getIcons wenv node egs + p11 = Point 100 10 + p21 = Point 100 30 + p22 = Point 400 30 + p31 = Point 100 50 + p32 = Point 400 50 + +handleEventOverlay :: Spec +handleEventOverlay = describe "handleEventOverlay" $ do + it "should not change the cursor if not event happened" $ do + icons [] `shouldBe` [CursorArrow] + + it "should not show arrow in overlay area if dropdown is not open" $ do + let evtsGroups = [[evtMove p1], [evtMove p2], [evtMove p3]] + icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorInvalid, CursorInvalid] + + it "should show arrow in overlay area if dropdown is open" $ do + let evtsGroups = [[evtMove p1], [evtClick p1], [evtMove p2], [evtMove p3]] + icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorArrow, CursorHand, CursorArrow] + + it "should show arrow in overlay area when dropdown is open, invalid after it's closed" $ do + let evtsGroups = [[evtMove p1], [evtClick p1], [evtMove p3], [evtClick p3]] + icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorArrow, CursorArrow, CursorInvalid] + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + node = vstack [ + textDropdown selectedItem [0..10::Int], + filler + ] `styleBasic` [cursorIcon CursorInvalid] + icons egs = getIcons wenv node egs + p1 = Point 100 10 -- Header + p2 = Point 100 50 -- List overlay + p3 = Point 100 460 -- Outside + +getIcons + :: Eq s + => WidgetEnv s e + -> WidgetNode s e + -> [[SystemEvent]] + -> [CursorIcon] +getIcons wenv root evtsGroups = iconsRes where + firstIcon stack = fromMaybe CursorArrow (headMay stack) + ctxs = snd <$> tail (nodeHandleEvents_ wenv WInit evtsGroups root) + cursors = (^.. L.cursorStack . folded . _2) <$> ctxs + iconsRes = firstIcon <$> cursors diff --git a/test/unit/Monomer/Graphics/UtilSpec.hs b/test/unit/Monomer/Graphics/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Graphics/UtilSpec.hs @@ -0,0 +1,37 @@ +{-| +Module : Monomer.Common.CursorIconSpec +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 graphics related utilities. +-} +module Monomer.Graphics.UtilSpec (spec) where + +import Test.Hspec + +import Monomer.Graphics + +spec :: Spec +spec = describe "Util" $ do + colorHex + colorHSL + +colorHex :: Spec +colorHex = describe "colorHex" $ do + it "should generate the correct color" $ do + rgbHex "#FFFFFF" `shouldBe` Color 255 255 255 1 + rgbHex "#FF0000" `shouldBe` Color 255 0 0 1 + rgbHex "#00FF00" `shouldBe` Color 0 255 0 1 + rgbHex "#0000FF" `shouldBe` Color 0 0 255 1 + rgbHex "#B06430" `shouldBe` Color 176 100 48 1 + +colorHSL :: Spec +colorHSL = describe "colorHSL" $ do + it "should generate the correct color" $ do + hsl 0 100 100 `shouldBe` rgbHex "#FFFFFF" + hsl 0 100 50 `shouldBe` rgbHex "#FF0000" + hsl 120 100 50 `shouldBe` rgbHex "#00FF00" + hsl 240 100 50 `shouldBe` rgbHex "#0000FF" diff --git a/test/unit/Monomer/TestEventUtil.hs b/test/unit/Monomer/TestEventUtil.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/TestEventUtil.hs @@ -0,0 +1,170 @@ +{-| +Module : Monomer.TestEventUtil +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for creating events in unit tests. +-} +module Monomer.TestEventUtil where + +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.Text (Text) + +import Monomer.Core +import Monomer.Event + +import qualified Monomer.Lens as L + +-- Tests were written assuming Mac OS is the host +-- For Mac OS, Meta acts as Windows' Ctrl (and viceversa) on text movement/selection + +modA :: KeyMod +modA = def + & L.leftAlt .~ True + +modC :: KeyMod +modC = def + & L.leftCtrl .~ True + +modG :: KeyMod +modG = def + & L.leftGUI .~ True + +modS :: KeyMod +modS = def & L.leftShift .~ True + +modAS :: KeyMod +modAS = def + & L.leftAlt .~ True + & L.leftShift .~ True + +modCS :: KeyMod +modCS = def + & L.leftCtrl .~ True + & L.leftShift .~ True + +modGS :: KeyMod +modGS = def + & L.leftGUI .~ True + & L.leftShift .~ True + +evtFocus :: SystemEvent +evtFocus = Focus emptyPath + +evtBlur :: SystemEvent +evtBlur = Blur emptyPath + +evtClick :: Point -> SystemEvent +evtClick p = Click p BtnLeft 1 + +evtDblClick :: Point -> SystemEvent +evtDblClick p = Click p BtnLeft 2 + +evtPress :: Point -> SystemEvent +evtPress p = ButtonAction p BtnLeft BtnPressed 1 + +evtRelease :: Point -> SystemEvent +evtRelease p = ButtonAction p BtnLeft BtnReleased 1 + +evtMove :: Point -> SystemEvent +evtMove p = Move p + +evtDrag :: Point -> Point -> [SystemEvent] +evtDrag start end = [evtPress start, evtMove end, evtRelease end] + +evtK :: KeyCode -> SystemEvent +evtK k = KeyAction def k KeyPressed + +evtKA :: KeyCode -> SystemEvent +evtKA k = KeyAction modA k KeyPressed + +evtKC :: KeyCode -> SystemEvent +evtKC k = KeyAction modC k KeyPressed + +evtKG :: KeyCode -> SystemEvent +evtKG k = KeyAction modG k KeyPressed + +evtKS :: KeyCode -> SystemEvent +evtKS k = KeyAction modS k KeyPressed + +evtKAS :: KeyCode -> SystemEvent +evtKAS k = KeyAction modAS k KeyPressed + +evtKCS :: KeyCode -> SystemEvent +evtKCS k = KeyAction modCS k KeyPressed + +evtKGS :: KeyCode -> SystemEvent +evtKGS k = KeyAction modGS k KeyPressed + +evtRK :: KeyCode -> SystemEvent +evtRK k = KeyAction def k KeyReleased + +evtRKA :: KeyCode -> SystemEvent +evtRKA k = KeyAction modA k KeyReleased + +evtRKC :: KeyCode -> SystemEvent +evtRKC k = KeyAction modC k KeyReleased + +evtRKG :: KeyCode -> SystemEvent +evtRKG k = KeyAction modG k KeyReleased + +evtRKS :: KeyCode -> SystemEvent +evtRKS k = KeyAction modS k KeyReleased + +evtRKAS :: KeyCode -> SystemEvent +evtRKAS k = KeyAction modAS k KeyReleased + +evtRKCS :: KeyCode -> SystemEvent +evtRKCS k = KeyAction modCS k KeyReleased + +evtRKGS :: KeyCode -> SystemEvent +evtRKGS k = KeyAction modGS k KeyReleased + +evtT :: Text -> SystemEvent +evtT t = TextInput t + +moveCharL :: SystemEvent +moveCharL = evtK keyLeft + +moveCharR :: SystemEvent +moveCharR = evtK keyRight + +moveWordL :: SystemEvent +moveWordL = evtKA keyLeft + +moveWordR :: SystemEvent +moveWordR = evtKA keyRight + +moveLineL :: SystemEvent +moveLineL = evtKC keyLeft + +moveLineR :: SystemEvent +moveLineR = evtKC keyRight + +selCharL :: SystemEvent +selCharL = evtKS keyLeft + +selCharR :: SystemEvent +selCharR = evtKS keyRight + +selWordL :: SystemEvent +selWordL = evtKAS keyLeft + +selWordR :: SystemEvent +selWordR = evtKAS keyRight + +selLineL :: SystemEvent +selLineL = evtKCS keyLeft + +selLineR :: SystemEvent +selLineR = evtKCS keyRight + +delCharL :: SystemEvent +delCharL = evtK keyBackspace + +delWordL :: SystemEvent +delWordL = evtKA keyBackspace diff --git a/test/unit/Monomer/TestUtil.hs b/test/unit/Monomer/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/TestUtil.hs @@ -0,0 +1,350 @@ +{-| +Module : Monomer.TestUtil +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Helper functions for testing Monomer widgets. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.TestUtil where + +import Control.Concurrent (newMVar) +import Control.Concurrent.STM.TChan (newTChanIO) +import Control.Lens ((&), (^.), (.~), (.=)) +import Control.Monad.State +import Data.Default +import Data.Maybe +import Data.Text (Text) +import Data.Sequence (Seq) +import System.IO.Unsafe + +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Event +import Monomer.Graphics +import Monomer.Main.Handlers +import Monomer.Main.Types +import Monomer.Main.Util +import Monomer.Widgets.Util.Widget + +import qualified Monomer.Lens as L + +data InitWidget + = WInit + | WNoInit + deriving (Eq, Show) + +testW :: Double +testW = 640 + +testH :: Double +testH = 480 + +testWindowSize :: Size +testWindowSize = Size testW testH + +testWindowRect :: Rect +testWindowRect = Rect 0 0 testW testH + +mockTextMetrics :: Font -> FontSize -> TextMetrics +mockTextMetrics 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 + 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 + w = fromMaybe fs mw + unFontSpace spaceH + chars = Seq.fromList $ T.unpack text + mkGlyph idx chr = GlyphPos { + _glpGlyph = chr, + _glpXMin = fromIntegral idx * w, + _glpXMax = (fromIntegral idx + 1) * w, + _glpYMin = 0, + _glpYMax = 10, + _glpW = w, + _glpH = 10 + } + glyphs = Seq.mapWithIndex mkGlyph chars + +mockRenderText :: Point -> Font -> FontSize -> FontSpace -> Text -> IO () +mockRenderText point font size spaceH text = return () + +mockRenderer :: Renderer +mockRenderer = Renderer { + beginFrame = \w h -> return (), + endFrame = return (), + -- Path + beginPath = return (), + closePath = return (), + -- Context management + saveContext = return (), + restoreContext = return (), + -- Overlays + createOverlay = \overlay -> return (), + renderOverlays = return (), + -- Raw tasks + createRawTask = \task -> return (), + renderRawTasks = return (), + -- Raw overlays + createRawOverlay = \overlay -> return (), + renderRawOverlays = return (), + -- Scissor operations + intersectScissor = \rect -> return (), + -- Translation + setTranslation = \point -> return (), + -- Scale + setScale = \point -> return (), + -- Rotation + setRotation = \angle -> return (), + -- Global Alpha + setGlobalAlpha = \alpha -> return (), + -- Path Winding + setPathWinding = \winding -> return (), + -- Strokes + stroke = return (), + setStrokeColor = \color -> return (), + setStrokeWidth = \width -> return (), + setStrokeLinearGradient = \p1 p2 c1 c2 -> return (), + setStrokeRadialGradient = \p1 a1 a2 c1 c2 -> return (), + setStrokeImagePattern = \n1 p1 s1 w1 h1 -> return (), + -- Fill + fill = return (), + setFillColor = \color -> return (), + setFillLinearGradient = \p1 p2 c1 c2 -> return (), + setFillRadialGradient = \p1 a1 a2 c1 c2 -> return (), + setFillImagePattern = \n1 p1 s1 w1 h1 -> return (), + -- Drawing + moveTo = \point -> return (), + renderLine = \p1 p2 -> return (), + renderLineTo = \point -> return (), + renderRect = \rect -> return (), + renderRoundedRect = \rect r1 r2 r3 r4 -> return (), + renderArc = \center radius angleStart angleEnd winding -> return (), + renderQuadTo = \p1 p2 -> return (), + renderEllipse = \rect -> return (), + -- Text + renderText = mockRenderText, + + -- Image + getImage = const . return $ Just $ ImageDef "test" def BS.empty [], + addImage = \name size imgData flags -> return (), + updateImage = \name size imgData -> return (), + deleteImage = \name -> return () +} + +mockFontManager :: FontManager +mockFontManager = FontManager { + computeTextMetrics = mockTextMetrics, + computeTextSize = mockTextSize (Just 10), + computeGlyphsPos = mockGlyphsPos (Just 10) +} + +mockWenv :: s -> WidgetEnv s e +mockWenv model = WidgetEnv { + _weOs = "Mac OS X", + _weFontManager = mockFontManager, + _weFindByPath = const Nothing, + _weMainButton = BtnLeft, + _weContextButton = BtnRight, + _weTheme = def, + _weWindowSize = testWindowSize, + _weWidgetShared = unsafePerformIO (newMVar M.empty), + _weWidgetKeyMap = M.empty, + _weHoveredPath = Nothing, + _weFocusedPath = emptyPath, + _weOverlayPath = Nothing, + _weDragStatus = Nothing, + _weMainBtnPress = Nothing, + _weCursor = Nothing, + _weModel = model, + _weInputStatus = def, + _weTimestamp = 0, + _weThemeChanged = False, + _weInTopLayer = const True, + _weLayoutDirection = LayoutNone, + _weViewport = Rect 0 0 testW testH, + _weOffset = def +} + +mockWenvEvtUnit :: s -> WidgetEnv s () +mockWenvEvtUnit model = mockWenv model + +nodeInit :: (Eq s) => WidgetEnv s e -> WidgetNode s e -> WidgetNode s e +nodeInit wenv node = nodeHandleEventRoot wenv [] node + +nodeMerge :: WidgetEnv s e -> WidgetNode s e -> WidgetNode s e -> WidgetNode s e +nodeMerge wenv node oldNode = resNode where + newNode = node + & L.info . L.path .~ oldNode ^. L.info . L.path + WidgetResult resNode _ = widgetMerge (newNode^. L.widget) wenv newNode oldNode + +nodeGetSizeReq :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq) +nodeGetSizeReq wenv node = (sizeReqW, sizeReqH) where + WidgetResult node2 _ = widgetInit (node ^. L.widget) wenv node + sizeReqW = node2 ^. L.info . L.sizeReqW + sizeReqH = node2 ^. L.info . L.sizeReqH + +nodeResize :: WidgetEnv s e -> WidgetNode s e -> Rect -> WidgetNode s e +nodeResize wenv node viewport = result ^. L.node where + resizeCheck = const True + widget = node ^. L.widget + result = widgetResize widget wenv node viewport resizeCheck + +nodeHandleEventCtx + :: (Eq s) + => WidgetEnv s e + -> [SystemEvent] + -> WidgetNode s e + -> MonomerCtx s e +nodeHandleEventCtx wenv evts node = ctx where + ctx = snd $ nodeHandleEvents wenv WInit evts node + +nodeHandleEventModel + :: (Eq s) + => WidgetEnv s e + -> [SystemEvent] + -> WidgetNode s e + -> s +nodeHandleEventModel wenv evts node = _weModel wenv2 where + (wenv2, _, _) = fst $ nodeHandleEvents wenv WInit evts node + +nodeHandleEventRoot + :: (Eq s) + => WidgetEnv s e + -> [SystemEvent] + -> WidgetNode s e + -> WidgetNode s e +nodeHandleEventRoot wenv evts node = newRoot where + (_, newRoot, _) = fst $ nodeHandleEvents wenv WInit evts node + +nodeHandleEventReqs + :: (Eq s) + => WidgetEnv s e + -> [SystemEvent] + -> WidgetNode s e + -> Seq (WidgetRequest s e) +nodeHandleEventReqs wenv evts node = reqs where + (_, _, reqs) = fst $ nodeHandleEvents wenv WInit evts node + +nodeHandleEventEvts + :: (Eq s) + => WidgetEnv s e + -> [SystemEvent] + -> WidgetNode s e + -> Seq e +nodeHandleEventEvts wenv evts node = eventsFromReqs reqs where + (_, _, reqs) = fst $ nodeHandleEvents wenv WInit evts node + +nodeHandleEvents + :: (Eq s) + => WidgetEnv s e + -> InitWidget + -> [SystemEvent] + -> WidgetNode s e + -> (HandlerStep s e, MonomerCtx s e) +nodeHandleEvents wenv init evts node = result where + steps + | init == WInit = tail $ nodeHandleEvents_ wenv init [evts] node + | otherwise = nodeHandleEvents_ wenv init [evts] node + result = foldl1 stepper steps + stepper step1 step2 = result where + ((_, _, reqs1), _) = step1 + ((wenv2, root2, reqs2), ctx2) = step2 + result = ((wenv2, root2, reqs1 <> reqs2), ctx2) + +nodeHandleEvents_ + :: (Eq s) + => WidgetEnv s e + -> InitWidget + -> [[SystemEvent]] + -> WidgetNode s e + -> [(HandlerStep s e, MonomerCtx s e)] +nodeHandleEvents_ wenv init evtsG node = unsafePerformIO $ do + -- Do NOT test code involving SDL Window functions + channel <- liftIO newTChanIO + + fmap fst $ flip runStateT (monomerCtx channel) $ do + L.inputStatus .= wenv ^. L.inputStatus + handleResourcesInit + + stepA <- if init == WInit + then do + handleWidgetInit wenv pathReadyRoot + else + return (wenv, pathReadyRoot, Seq.empty) + + ctxA <- get + let (wenvA, nodeA, reqsA) = stepA + let resizeCheck = const True + let resizeRes = widgetResize (nodeA ^. L.widget) wenv nodeA vp resizeCheck + step <- handleWidgetResult wenvA True resizeRes + ctx <- get + let (wenvr, rootr, reqsr) = step + + (_, _, steps) <- foldM runStep (wenvr, rootr, [(step, ctx)]) evtsG + + return $ if init == WInit + then (stepA, ctxA) : reverse steps + else reverse steps + where + winSize = _weWindowSize wenv + vp = Rect 0 0 (_sW winSize) (_sH winSize) + dpr = 1 + epr = 1 + model = _weModel wenv + monomerCtx channel = initMonomerCtx undefined channel winSize dpr epr model + pathReadyRoot = node + & L.info . L.path .~ rootPath + & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) rootPath + runStep (wenv, root, accum) evts = do + step <- handleSystemEvents wenv root evts + ctx <- get + let (wenv2, root2, reqs2) = step + + return (wenv2, root2, (step, ctx) : accum) + +nodeHandleResult + :: (Eq s) + => WidgetEnv s e + -> WidgetResult s e + -> (HandlerStep s e, MonomerCtx s e) +nodeHandleResult wenv result = unsafePerformIO $ do + channel <- liftIO newTChanIO + + let winSize = _weWindowSize wenv + let dpr = 1 + let epr = 1 + let model = _weModel wenv + -- Do NOT test code involving SDL Window functions + let monomerCtx = initMonomerCtx undefined channel winSize dpr epr model + + flip runStateT monomerCtx $ do + L.inputStatus .= wenv ^. L.inputStatus + handleResourcesInit + + handleWidgetResult wenv True result + +roundRectUnits :: Rect -> Rect +roundRectUnits (Rect x y w h) = Rect nx ny nw nh where + nx = fromIntegral (round x) + ny = fromIntegral (round y) + nw = fromIntegral (round w) + nh = fromIntegral (round h) diff --git a/test/unit/Monomer/Widgets/Animation/FadeSpec.hs b/test/unit/Monomer/Widgets/Animation/FadeSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Animation/FadeSpec.hs @@ -0,0 +1,98 @@ +{-| +Module : Monomer.Widgets.Animation.FadeSpec +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 Fade animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Animation.FadeSpec (spec) where + +import Control.Lens ((&), (^.), (.~), (?~), (^?!), _1, _3, ix) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Animation.Fade +import Monomer.Widgets.Animation.Types +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Containers.Scroll +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data TestEvt + = OnTestFinished + deriving (Eq, Show) + +spec :: Spec +spec = describe "Fade" $ do + initWidget + handleMessage + getSizeReq + +initWidget :: Spec +initWidget = describe "initWidget" $ do + it "should not request rendering if autoStart = False" $ + reqs nodeNormal `shouldBe` Seq.empty + + it "should request rendering if autoStart = True" $ do + reqs nodeAuto ^?! ix 0 `shouldSatisfy` isRunTask + reqs nodeAuto ^?! ix 1 `shouldSatisfy` isRenderEvery + + where + wenv = mockWenvEvtUnit () + nodeNormal = animFadeIn (label "Test") + nodeAuto = animFadeIn_ [autoStart, duration 100] (label "Test") + reqs node = nodeHandleEvents_ wenv WInit [] node ^?! ix 0 . _1 . _3 + +handleMessage :: Spec +handleMessage = describe "handleMessage" $ do + it "should not request rendering if an invalid message is received" $ + reqs ScrollReset `shouldBe` Seq.empty + + it "should request rendering if AnimationStart is received" $ do + reqs AnimationStart ^?! ix 0 `shouldSatisfy` isRunTask + reqs AnimationStart ^?! ix 1 `shouldSatisfy` isRenderEvery + evts AnimationStart `shouldBe` Seq.empty + + it "should cancel rendering if AnimationStop is received" $ do + reqs AnimationStop ^?! ix 0 `shouldSatisfy` isRenderStop + evts AnimationStop `shouldBe` Seq.empty + + it "should generate an event if AnimationFinished is received" $ + evts AnimationFinished `shouldBe` Seq.singleton OnTestFinished + + where + wenv = mockWenv () + baseNode = animFadeIn_ [autoStart, duration 100, onFinished OnTestFinished] (label "Test") + node = nodeInit wenv baseNode + res msg = widgetHandleMessage (node^. L.widget) wenv node rootPath msg + evts msg = eventsFromReqs (reqs msg) + reqs msg = maybe Seq.empty (^. L.requests) (res msg) + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return same reqW as child node" $ + tSizeReqW `shouldBe` lSizeReqW + + it "should return same reqH as child node" $ + tSizeReqH `shouldBe` lSizeReqH + + where + wenv = mockWenvEvtUnit () + lblNode = label "Test label" + (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode + (tSizeReqW, tSizeReqH) = nodeGetSizeReq wenv (animFadeIn lblNode) diff --git a/test/unit/Monomer/Widgets/Animation/SlideSpec.hs b/test/unit/Monomer/Widgets/Animation/SlideSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Animation/SlideSpec.hs @@ -0,0 +1,98 @@ +{-| +Module : Monomer.Widgets.Animation.SlideSpec +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 Slide animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Animation.SlideSpec (spec) where + +import Control.Lens ((&), (^.), (.~), (?~), (^?!), _1, _3, ix) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Animation.Slide +import Monomer.Widgets.Animation.Types +import Monomer.Widgets.Containers.Scroll +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data TestEvt + = OnTestFinished + deriving (Eq, Show) + +spec :: Spec +spec = describe "Slide" $ do + initWidget + handleMessage + getSizeReq + +initWidget :: Spec +initWidget = describe "initWidget" $ do + it "should not request rendering if autoStart = False" $ + reqs nodeNormal `shouldBe` Seq.empty + + it "should request rendering if autoStart = True" $ do + reqs nodeAuto ^?! ix 0 `shouldSatisfy` isRunTask + reqs nodeAuto ^?! ix 1 `shouldSatisfy` isRenderEvery + + where + wenv = mockWenvEvtUnit () + nodeNormal = animSlideIn (label "Test") + nodeAuto = animSlideIn_ [autoStart, duration 100] (label "Test") + reqs node = nodeHandleEvents_ wenv WInit [] node ^?! ix 0 . _1 . _3 + +handleMessage :: Spec +handleMessage = describe "handleMessage" $ do + it "should not request rendering if an invalid message is received" $ + reqs ScrollReset `shouldBe` Seq.empty + + it "should request rendering if AnimationStart is received" $ do + reqs AnimationStart ^?! ix 0 `shouldSatisfy` isRunTask + reqs AnimationStart ^?! ix 1 `shouldSatisfy` isRenderEvery + evts AnimationStart `shouldBe` Seq.empty + + it "should cancel rendering if AnimationStop is received" $ do + reqs AnimationStop ^?! ix 0 `shouldSatisfy` isRenderStop + evts AnimationStop `shouldBe` Seq.empty + + it "should generate an event if AnimationFinished is received" $ + evts AnimationFinished `shouldBe` Seq.singleton OnTestFinished + + where + wenv = mockWenv () + baseNode = animSlideIn_ [autoStart, duration 100, onFinished OnTestFinished] (label "Test") + node = nodeInit wenv baseNode + res msg = widgetHandleMessage (node^. L.widget) wenv node rootPath msg + evts msg = eventsFromReqs (reqs msg) + reqs msg = maybe Seq.empty (^. L.requests) (res msg) + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return same reqW as child node" $ + tSizeReqW `shouldBe` lSizeReqW + + it "should return same reqH as child node" $ + tSizeReqH `shouldBe` lSizeReqH + + where + wenv = mockWenvEvtUnit () + lblNode = label "Test label" + (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode + (tSizeReqW, tSizeReqH) = nodeGetSizeReq wenv (animSlideIn lblNode) diff --git a/test/unit/Monomer/Widgets/CompositeSpec.hs b/test/unit/Monomer/Widgets/CompositeSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/CompositeSpec.hs @@ -0,0 +1,507 @@ +{-| +Module : Monomer.Widgets.CompositeSpec +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 Composite widget. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.CompositeSpec (spec) where + +import Control.Lens ( + (&), (^.), (^?), (^..), (.~), (%~), _Just, ix, folded, traverse, dropping) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Maybe +import Data.Text (Text) +import Data.Typeable (Typeable, cast) +import TextShow +import Test.Hspec + +import qualified Data.Map as Map +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Grid +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Containers.ZStack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.TextField +import Monomer.Widgets.Util.Widget + +import qualified Monomer.Lens as L +import qualified Monomer.Widgets.Single as SG + +data MainEvt + = MainBtnClicked + | ChildClicked + | MainResize Rect + deriving (Eq, Show) + +data ChildEvt + = ChildBtnClicked + | ChildMessage String + | ChildResize Rect + deriving (Eq, Show) + +data MainModel = MainModel { + _tmClicks :: Int, + _tmChild :: ChildModel +} deriving (Eq, Show) + +instance Default MainModel where + def = MainModel { + _tmClicks = 0, + _tmChild = def + } + +data ChildModel = ChildModel { + _cmClicks :: Int, + _cmMessage :: String +} deriving (Eq, Show) + +instance Default ChildModel where + def = ChildModel { + _cmClicks = 0, + _cmMessage = "" + } + +data TestModel = TestModel { + _tmItems :: [Int], + _tmText1 :: Text, + _tmText2 :: Text +} deriving (Eq, Show) + +instance Default TestModel where + def = TestModel { + _tmItems = [], + _tmText1 = "", + _tmText2 = "" + } + +msgWidget = defaultWidgetNode "msgWidget" $ SG.createSingle () def { + SG.singleHandleMessage = msgWidgetHandleMessage +} + +msgWidgetHandleMessage wenv node target message = Just (resultEvts node evts) where + val = fromMaybe "" (cast message) + evts = [ChildMessage val] + +makeLensesWith abbreviatedFields ''MainModel +makeLensesWith abbreviatedFields ''ChildModel +makeLensesWith abbreviatedFields ''TestModel + +baseLens idx = L.children . ix 0 . L.children . ix idx . L.children . ix 0 +pathLens idx = baseLens idx . L.info . L.path +widLens idx = baseLens idx . L.info . L.widgetId + +spec :: Spec +spec = describe "Composite" $ do + handleEvent + handleMessage + findByPoint + findByPath + findNextFocus + getSizeReq + resize + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + handleEventBasic + handleEventChild + handleEventResize + handleEventLocalKey + +handleEventBasic :: Spec +handleEventBasic = describe "handleEventBasic" $ do + it "should not generate an event if clicked outside" $ + model [evtClick (Point 3000 3000)] ^. clicks `shouldBe` 0 + + it "should generate a user provided event when clicked" $ + model [evtClick (Point 10 10)] ^. clicks `shouldBe` 1 + + 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))] + _ -> [] + buildUI wenv model = button "Click" MainBtnClicked + cmpNode = composite "main" id buildUI handleEvent + model es = nodeHandleEventModel wenv es cmpNode + +handleEventChild :: Spec +handleEventChild = describe "handleEventChild" $ do + it "should not generate an event if clicked outside" $ do + model [evtClick (Point 3000 3000)] ^. clicks `shouldBe` 0 + model [evtClick (Point 3000 3000)] ^. child . clicks `shouldBe` 0 + + it "should generate a main event when clicked in main button" $ do + model [evtClick (Point 10 10)] ^. clicks `shouldBe` 1 + model [evtClick (Point 10 10)] ^. child . clicks `shouldBe` 0 + + it "should generate a child event when clicked in child button" $ do + model [evtClick (Point 10 30)] ^. clicks `shouldBe` 0 + model [evtClick (Point 10 30)] ^. child . clicks `shouldBe` 1 + + where + wenv = mockWenv def + handleChild + :: WidgetEnv ChildModel ChildEvt + -> WidgetNode ChildModel ChildEvt + -> ChildModel + -> ChildEvt + -> [EventResponse ChildModel ChildEvt MainModel MainEvt] + handleChild wenv node model evt = [Model (model & clicks %~ (+1))] + buildChild wenv model = button "Click" ChildBtnClicked + handleEvent + :: WidgetEnv MainModel MainEvt + -> WidgetNode MainModel MainEvt + -> MainModel + -> MainEvt + -> [EventResponse MainModel MainEvt MainModel ()] + handleEvent wenv node model evt = [Model (model & clicks %~ (+1))] + buildUI wenv model = vstack [ + button "Click" MainBtnClicked, + composite "child" child buildChild handleChild + ] + cmpNode = composite "main" id buildUI handleEvent + model es = nodeHandleEventModel wenv es cmpNode + +handleEventResize :: Spec +handleEventResize = describe "handleEventResize" $ do + it "should not generate a resize event on init" $ + events [] `shouldBe` Seq.fromList [] + + it "should generate a resize event when size changes" $ + events [evtClick (Point 10 10)] `shouldBe` Seq.fromList [MainResize cvp] + + where + wenv = mockWenv def + handleChild + :: WidgetEnv ChildModel ChildEvt + -> WidgetNode ChildModel ChildEvt + -> ChildModel + -> ChildEvt + -> [EventResponse ChildModel ChildEvt MainModel MainEvt] + handleChild wenv node model evt = case evt of + ChildResize rect -> [Report (MainResize rect)] + _ -> [Model (model & clicks %~ (+1))] + buildChild wenv model = vstack [ + button "Click" ChildBtnClicked, + label "Test" `styleBasic` [height 3000] `nodeVisible` (model ^. clicks > 0) + ] + handleEvent + :: WidgetEnv MainModel MainEvt + -> WidgetNode MainModel MainEvt + -> MainModel + -> MainEvt + -> [EventResponse MainModel MainEvt MainModel MainEvt] + handleEvent wenv node model evt = case evt of + MainResize{} -> [Report evt] + _ -> [Model (model & clicks %~ (+1))] + buildUI wenv model = vstack [ + composite_ "child" child buildChild handleChild [onResize ChildResize] + ] + cmpNode = composite_ "main" id buildUI handleEvent [onResize MainResize] + model es = nodeHandleEventModel wenv es cmpNode + events es = nodeHandleEventEvts wenv es cmpNode + vp = Rect 0 0 640 480 + cvp = Rect 0 0 640 3020 + +handleEventLocalKey :: Spec +handleEventLocalKey = describe "handleEventLocalKey" $ do + handleEventLocalKeySingleState + handleEventLocalKeyRemoveItem + +handleEventLocalKeySingleState :: Spec +handleEventLocalKeySingleState = describe "handleEventLocalKeySingleState" $ + it "should insert new text at the end, since its merged with a local key" $ do + wenv1 ^. L.model . text1 `shouldBe` "aacc" + wenv1 ^. L.model . text2 `shouldBe` "" + wenv2 ^. L.model . text1 `shouldBe` "aaccbb" + wenv2 ^. L.model . text2 `shouldBe` "" + newInstRoot ^? pathLens 0 `shouldBe` Just (Seq.fromList [0, 0, 0, 0]) + newInstRoot ^? pathLens 1 `shouldBe` Just (Seq.fromList [0, 0, 1, 0]) + newInstRoot ^? widLens 0 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0, 1, 0])) + newInstRoot ^? widLens 1 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0, 0, 0])) + + where + wenv = mockWenv def + handleEvent + :: WidgetEnv TestModel () + -> WidgetNode TestModel () + -> TestModel + -> () + -> [EventResponse TestModel () TestModel ()] + handleEvent wenv node model evt = [] + buildUI1 wenv model = hstack [ + vstack [ + textField text1 + ] `nodeKey` "localTxt1", + vstack [ + textField text1 + ] `nodeKey` "localTxt2" + ] + buildUI2 wenv model = hstack [ + vstack [ + textField text1 + ] `nodeKey` "localTxt2", + vstack [ + textField text1 + ] `nodeKey` "localTxt1" + ] + cmpNode1 = composite "main" id buildUI1 handleEvent + 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 + evts2 = [evtK keyTab, evtK keyTab, evtT "bb"] + (wenv2, root2, _) = fst $ nodeHandleEvents wenv1 WNoInit evts2 cntNodeM + newInstRoot = widgetGetInstanceTree (root2 ^. L.widget) wenv1 root2 + +handleEventLocalKeyRemoveItem :: Spec +handleEventLocalKeyRemoveItem = describe "handleEventLocalKeyRemoveItem" $ + it "should remove an element and keep the correct keys" $ do + getKeys oldInstRoot `shouldBe` ["key0", "key1", "key2", "key3"] + getKeys newInstRoot `shouldBe` ["key0", "key2", "key3"] + length (newCtx ^. L.widgetPaths) `shouldBe` 2 + + where + initModel = def & items .~ [0..3] + wenv = mockWenv initModel + handleEvent + :: WidgetEnv TestModel MainEvt + -> WidgetNode TestModel MainEvt + -> TestModel + -> MainEvt + -> [EventResponse TestModel MainEvt TestModel MainEvt] + handleEvent wenv node model evt = case evt of + MainBtnClicked -> [Model $ model & items .~ [0, 2, 3]] + _ -> [] + buildUI wenv model = vstack (button "Button" MainBtnClicked : (keyedLabel <$> model ^. items)) + keyedLabel idx = label "Test" `nodeKey` ("key" <> showt idx) + node = composite "main" id buildUI handleEvent + evts = [evtClick (Point 100 10)] + oldNode = nodeInit wenv node + ((_, newRoot, _), newCtx) = nodeHandleEvents wenv WInit evts node + oldInstRoot = widgetGetInstanceTree (oldNode ^. L.widget) wenv oldNode + newInstRoot = widgetGetInstanceTree (newRoot ^. L.widget) wenv newRoot + getKeys inst = inst ^.. L.children . ix 0 . L.children . folded . L.info . L.key . _Just . L._WidgetKey + +handleMessage :: Spec +handleMessage = describe "handleMessage" $ do + it "should not generate an event if clicked outside" $ do + model [evtClick (Point 50 10)] ^. child . message `shouldBe` "Test" + + where + wenv = mockWenv def + msg :: String + msg = "Test" + path = Seq.fromList [0, 0, 1, 0, 0] + handleChild + :: WidgetEnv ChildModel ChildEvt + -> WidgetNode ChildModel ChildEvt + -> ChildModel + -> ChildEvt + -> [EventResponse ChildModel ChildEvt MainModel MainEvt] + handleChild wenv node model evt = case evt of + ChildMessage m -> [Model (model & message .~ m)] + _ -> [] + buildChild wenv model = vstack [ msgWidget ] + handleEvent + :: WidgetEnv MainModel MainEvt + -> WidgetNode MainModel MainEvt + -> MainModel + -> MainEvt + -> [EventResponse MainModel MainEvt MainModel ()] + handleEvent wenv node model evt = [Request (SendMessage wid msg)] where + wni = wenv ^. L.findByPath $ path + wid = maybe def (^. L.widgetId) wni + buildUI wenv model = vstack [ + button "Start" MainBtnClicked, + composite "child" child buildChild handleChild + ] + cmpNode = composite "main" id buildUI handleEvent + model es = nodeHandleEventModel wenv es cmpNode + +findByPoint :: Spec +findByPoint = describe "findByPoint" $ do + it "should return Nothing" $ + wni emptyPath (Point 3000 3000) `shouldBe` Nothing + + it "should return item number 5" $ do + let res = wni emptyPath (Point 320 240) + res ^? _Just . L.path ^.. traverse . traverse `shouldBe` [0, 0, 0, 0, 1, 1] + + it "should return item number 8" $ do + let res = wni emptyPath (Point 600 240) + res ^? _Just . L.path ^.. traverse . traverse `shouldBe` [0, 0, 0, 0, 1, 2] + + it "should return background item" $ do + let res = wni emptyPath (Point 560 400) + res ^? _Just . L.path ^.. traverse . traverse `shouldBe` [0, 0, 0, 1] + + it "should return item number 9 when starting from the second level" $ do + let res = wni (Seq.fromList [0, 0]) (Point 560 340) + res ^? _Just . L.path ^.. traverse . traverse `shouldBe` [0, 0, 0, 0, 2, 2, 0, 1] + + it "should return Nothing if start path is not valid" $ do + let res = wni (Seq.fromList [0, 1]) (Point 600 400) + res `shouldBe` Nothing + + where + wenv = mockWenvEvtUnit def + cmpNode = findByHelperUI + wni start point = res where + inode = nodeInit wenv cmpNode + res = widgetFindByPoint (inode ^. L.widget) wenv inode start point + +findByPath :: Spec +findByPath = describe "findByPath" $ do + it "should return Nothing" $ do + wni emptyPath `shouldBe` Nothing + wni (Seq.fromList [1]) `shouldBe` Nothing + wni (Seq.fromList [0, 100]) `shouldBe` Nothing + + it "should return item number 5" $ do + let res = wni (Seq.fromList [0, 0, 0, 0, 1, 1]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 213 160 213 160) + + it "should return item number 8" $ do + let res = wni (Seq.fromList [0, 0, 0, 0, 1, 2]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 427 160 213 160) + + it "should return background item" $ do + let res = wni (Seq.fromList [0, 0, 0, 1]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 0 0 640 480) + + it "should return item number 9 when starting from the second level" $ do + let res = wni (Seq.fromList [0, 0, 0, 0, 2, 2, 0, 1]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 427 340 213 20) + + where + wenv = mockWenvEvtUnit def + cmpNode = findByHelperUI + wni path = res where + inode = nodeInit wenv cmpNode + res = findWidgetByPath wenv inode path + +findNextFocus :: Spec +findNextFocus = describe "findNextFocus" $ do + it "should return the first textfield" $ do + let res = wni FocusFwd emptyPath + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 0 0 213 160) + res ^? _Just . L.path `shouldBe` Just (Seq.fromList [0, 0, 0, 0, 0, 0]) + + it "should return the second textfield" $ do + let res = wni FocusFwd (Seq.fromList [0, 0, 0, 0, 0, 0]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 213 160 213 160) + res ^? _Just . L.path `shouldBe` Just (Seq.fromList [0, 0, 0, 0, 1, 1]) + + it "should return the third textfield" $ do + let res = wni FocusFwd (Seq.fromList [0, 0, 0, 0, 1, 1]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 427 360 213 20) + res ^? _Just . L.path `shouldBe` Just (Seq.fromList [0, 0, 0, 0, 2, 2, 0, 2]) + + it "should return the third textfield (starts backwards)" $ do + let res = wni FocusBwd emptyPath + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 427 360 213 20) + res ^? _Just . L.path `shouldBe` Just (Seq.fromList [0, 0, 0, 0, 2, 2, 0, 2]) + + it "should return the second textfield (starts backwards)" $ do + let res = wni FocusBwd (Seq.fromList [0, 0, 0, 0, 2, 2, 0, 2]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 213 160 213 160) + res ^? _Just . L.path `shouldBe` Just (Seq.fromList [0, 0, 0, 0, 1, 1]) + + it "should return the first textfield (starts backwards)" $ do + let res = wni FocusBwd (Seq.fromList [0, 0, 0, 0, 1, 1]) + roundRectUnits <$> res ^? _Just . L.viewport `shouldBe` Just (Rect 0 0 213 160) + res ^? _Just . L.path `shouldBe` Just (Seq.fromList [0, 0, 0, 0, 0, 0]) + + where + wenv = mockWenvEvtUnit def + cmpNode = findByHelperUI + wni dir start = res where + inode = nodeInit wenv cmpNode + res = widgetFindNextFocus (inode ^. L.widget) wenv inode dir start + +findByHelperUI :: Typeable ep => WidgetNode TestModel ep +findByHelperUI = composite "main" id buildUI handleEvent where + handleEvent wenv node model evt = [] + buildLabels :: WidgetEnv TestModel () -> TestModel -> WidgetNode TestModel () + buildLabels wenv model = vstack_ [ignoreEmptyArea] [ + label "a", label "b", textField text1 + ] + cmpLabels = composite "main" id buildLabels handleEvent + buildUI :: WidgetEnv TestModel () -> TestModel -> WidgetNode TestModel () + buildUI wenv model = box_ [ignoreEmptyArea, expandContent] $ + zstack_ [onlyTopActive False] [ + label "Background", + vgrid [ + hgrid [ textField text1, label "2", label "3" ], + hgrid [ label "4", textField text1, label "6" ], + hgrid [ label "7", label "8", cmpLabels ] + ] + ] + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 70" $ + sizeReqW `shouldBe` fixedSize 70 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 40 + + where + wenv = mockWenvEvtUnit () + handleEvent wenv node model evt = [] + buildUI :: WidgetEnv () () -> () -> WidgetNode () () + buildUI wenv model = vstack [ + label "label 1", + label "label 2" + ] + cmpNode = composite "main" id buildUI handleEvent + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv cmpNode + +resize :: Spec +resize = describe "resize" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign the same viewport size to its child" $ + childrenVp `shouldBe` Seq.singleton cvp1 + + where + wenv = mockWenvEvtUnit () + & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 480 + handleEvent wenv node model evt = [] + buildUI :: WidgetEnv () () -> () -> WidgetNode () () + buildUI wenv model = hstack [] + cmpNode = composite "main" id buildUI handleEvent + tmpNode = nodeInit wenv cmpNode + newNode = widgetGetInstanceTree (tmpNode ^. L.widget) wenv tmpNode + viewport = newNode ^. L.info . L.viewport + childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children diff --git a/test/unit/Monomer/Widgets/ContainerSpec.hs b/test/unit/Monomer/Widgets/ContainerSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/ContainerSpec.hs @@ -0,0 +1,150 @@ +{-| +Module : Monomer.Widgets.ContainerSpec +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 Container base widget. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.ContainerSpec (spec) where + +import Control.Lens ((&), (^.), (^?), (.~), (%~), ix) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.TextField + +import qualified Monomer.Lens as L + +data TestModel = TestModel { + _tmText1 :: Text, + _tmText2 :: Text +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +pathLens idx = L.children . ix idx . L.info . L.path +widLens idx = L.children . ix idx . L.info . L.widgetId + +-- This uses Stack for testing, since Container is a template and not a real container +spec :: Spec +spec = describe "Container" + handleEvent + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + handleEventNormal + handleEventNoKey + handleEventLocalKey + +handleEventNormal :: Spec +handleEventNormal = describe "handleEventNormal" $ + it "should insert new text at the right location, since widgets match" $ do + model1 ^. text1 `shouldBe` "aacc" + model1 ^. text2 `shouldBe` "" + modelM ^. text1 `shouldBe` "aabbcc" + modelM ^. text2 `shouldBe` "" + newRoot ^? pathLens 0 `shouldBe` Just (Seq.fromList [0, 0]) + newRoot ^? pathLens 1 `shouldBe` Just (Seq.fromList [0, 1]) + newRoot ^? widLens 0 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0])) + newRoot ^? widLens 1 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 1])) + + where + wenv = mockWenvEvtUnit (TestModel "" "") + cntNode1 = vstack [ + textField text1, + textField text2 + ] + cntNode2 = vstack [ + textField text1, + textField text2 + ] + evts1 = [evtT "aacc", moveCharL, moveCharL] + model1 = nodeHandleEventModel wenv evts1 cntNode1 + (wenv1, root1, _) = fst $ nodeHandleEvents wenv WInit evts1 cntNode1 + cntNodeM = nodeMerge wenv1 cntNode2 root1 + evts2 = [evtK keyTab, evtT "bb"] + (wenv2, root2, _) = fst $ nodeHandleEvents wenv WNoInit evts2 cntNodeM + modelM = wenv2 ^. L.model + newRoot = root2 + +handleEventNoKey :: Spec +handleEventNoKey = describe "handleEventNoKey" $ + it "should insert new text at the end, since its merged without a key and state is lost" $ do + model1 ^. text1 `shouldBe` "aacc" + model1 ^. text2 `shouldBe` "" + modelM ^. text1 `shouldBe` "aaccbb" + modelM ^. text2 `shouldBe` "" + newRoot ^? pathLens 0 `shouldBe` Just (Seq.fromList [0, 0]) + newRoot ^? pathLens 1 `shouldBe` Just (Seq.fromList [0, 1]) + newRoot ^? widLens 0 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0])) + newRoot ^? widLens 1 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 1])) + + where + wenv = mockWenvEvtUnit (TestModel "" "") + cntNode1 = vstack [ + textField text1, + textField text2 + ] + cntNode2 = vstack [ + textField text2, + textField text1 + ] + evts1 = [evtT "aacc", moveCharL, moveCharL] + model1 = nodeHandleEventModel wenv evts1 cntNode1 + (wenv1, root1, _) = fst $ nodeHandleEvents wenv WInit evts1 cntNode1 + cntNodeM = nodeMerge wenv1 cntNode2 root1 + evts2 = [evtK keyTab, evtK keyTab, evtT "bb"] + (wenv2, root2, _) = fst $ nodeHandleEvents wenv WNoInit evts2 cntNodeM + modelM = wenv2 ^. L.model + newRoot = root2 + +handleEventLocalKey :: Spec +handleEventLocalKey = describe "handleEventLocalKey" $ + it "should insert new text at the correct location, since its merged with a key" $ do + model1 ^. text1 `shouldBe` "aacc" + model1 ^. text2 `shouldBe` "" + modelM ^. text1 `shouldBe` "aabbcc" + modelM ^. text2 `shouldBe` "" + -- WidgetId stays the same even after path changed + newRoot ^? pathLens 0 `shouldBe` Just (Seq.fromList [0, 0]) + newRoot ^? pathLens 1 `shouldBe` Just (Seq.fromList [0, 1]) + newRoot ^? widLens 0 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 1])) + newRoot ^? widLens 1 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0])) + + where + wenv = mockWenvEvtUnit (TestModel "" "") + cntNode1 = vstack [ + textField text1 `nodeKey` "txt1", + textField text2 `nodeKey` "txt2" + ] + cntNode2 = vstack [ + textField text2 `nodeKey` "txt2", + textField text1 `nodeKey` "txt1" + ] + evts1 = [evtT "aacc", moveCharL, moveCharL] + model1 = nodeHandleEventModel wenv evts1 cntNode1 + (wenv1, root1, _) = fst $ nodeHandleEvents wenv WInit evts1 cntNode1 + cntNodeM = nodeMerge wenv1 cntNode2 root1 + evts2 = [evtK keyTab, evtK keyTab, evtT "bb"] + (wenv2, root2, _) = fst $ nodeHandleEvents wenv WNoInit evts2 cntNodeM + modelM = wenv2 ^. L.model + newRoot = root2 diff --git a/test/unit/Monomer/Widgets/Containers/AlertSpec.hs b/test/unit/Monomer/Widgets/Containers/AlertSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/AlertSpec.hs @@ -0,0 +1,50 @@ +{-| +Module : Monomer.Widgets.Containers.AlertSpec +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 Alert dialog widget. +-} +module Monomer.Widgets.Containers.AlertSpec (spec) where + +import Control.Lens ((&), (.~)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Containers.Alert + +import qualified Monomer.Lens as L + +data AlertEvent + = CloseClick + deriving (Eq, Show) + +spec :: Spec +spec = describe "Alert" + handleEvent + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should generate a close event if clicked outside the dialog" $ + events (Point 3000 3000) `shouldBe` Seq.singleton CloseClick + + it "should generate a close event when clicking the Accept button" $ + events (Point 50 450) `shouldBe` Seq.singleton CloseClick + + it "should not generate a close event when clicking the dialog" $ + events (Point 300 200) `shouldBe` Seq.empty + + where + wenv = mockWenv () & L.theme .~ darkTheme + alertNode = alertMsg "Alert!" CloseClick + events p = nodeHandleEventEvts wenv [evtClick p] alertNode diff --git a/test/unit/Monomer/Widgets/Containers/BoxSpec.hs b/test/unit/Monomer/Widgets/Containers/BoxSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/BoxSpec.hs @@ -0,0 +1,253 @@ +{-| +Module : Monomer.Widgets.Containers.BoxSpec +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 Box widget. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Containers.BoxSpec (spec) where + +import Control.Lens ((&), (^.), (^?!), (.~), ix) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.ZStack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data TestEvent + = BtnClick Int + | BoxOnEnter + | BoxOnLeave + | BoxOnPressed Button Int + | BoxOnReleased Button Int + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +spec :: Spec +spec = describe "Box" $ do + mergeReq + handleEvent + handleEventIgnoreEmpty + handleEventSinkEmpty + getSizeReq + getSizeReqUpdater + resize + +mergeReq :: Spec +mergeReq = describe "mergeReq" $ do + it "should return the new node, since a handler was not provided" $ + mergeWith box1 boxM ^. L.info . L.key `shouldBe` Just (WidgetKey "btnNew") + + it "should return the new node, since the handler returned merge is needed" $ + mergeWith box2 boxM ^. L.info . L.key `shouldBe` Just (WidgetKey "btnNew") + + it "should return the old node, since the handler returned merge is not needed" $ + mergeWith box3 boxM ^. L.info . L.key `shouldBe` Just (WidgetKey "btnOld") + + where + wenv = mockWenv () + 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 + boxM = box btnOld + mergeWith newNode oldNode = result ^?! L.node . L.children . ix 0 where + oldNode2 = nodeInit wenv oldNode + result = widgetMerge (newNode ^. L.widget) wenv newNode oldNode2 + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not generate an event if clicked outside" $ + evts [evtClick (Point 3000 3000)] `shouldBe` Seq.empty + + it "should generate an event if the button (centered) is clicked" $ + evts [evtClick (Point 320 240)] `shouldBe` Seq.singleton (BtnClick 0) + + it "should generate an event when the cursor enters the viewport" $ + evts [evtMove (Point 320 240)] `shouldBe` Seq.singleton BoxOnEnter + + it "should generate an event when the cursor leaves the viewport" $ + evts [evtMove (Point 320 240), evtMove (Point 3000 3000)] `shouldBe` Seq.fromList [BoxOnEnter, BoxOnLeave] + + it "should generate an event if the button is pressed in the child viewport" $ + evts [evtPress (Point 320 240)] `shouldBe` Seq.singleton (BoxOnPressed BtnLeft 1) + + it "should generate an event if the button is released in the child viewport" $ + evts [evtMove (Point 320 240), evtRelease (Point 320 240)] `shouldBe` Seq.fromList [BoxOnEnter, BoxOnReleased BtnLeft 1] + + it "should generate an event when focus is received" $ + evts [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + evts [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv () + btnBox = box_ [onClick (BtnClick 0), + onFocus GotFocus, + onBlur LostFocus, + onEnter BoxOnEnter, + onLeave BoxOnLeave, + onBtnPressed BoxOnPressed, + onBtnReleased BoxOnReleased] (label "Test") + boxNode = nodeInit wenv (btnBox `nodeFocusable` True) + evts es = nodeHandleEventEvts wenv es boxNode + +handleEventIgnoreEmpty :: Spec +handleEventIgnoreEmpty = describe "handleEventIgnoreEmpty" $ do + it "should click the bottom layer, since nothing is handled on top" $ + clickIgnored (Point 200 15) `shouldBe` Seq.singleton (BtnClick 1) + + it "should click the top layer, since pointer is on the button" $ + clickIgnored (Point 320 240) `shouldBe` Seq.singleton (BtnClick 2) + + where + wenv = mockWenv () + btn2 = button "Click 2" (BtnClick 2) `styleBasic` [height 10] + ignoredNode = zstack_ [onlyTopActive False] [ + button "Click 1" (BtnClick 1), + box_ [ignoreEmptyArea_ True] btn2 + ] + clickIgnored p = nodeHandleEventEvts wenv [evtClick p] ignoredNode + +handleEventSinkEmpty :: Spec +handleEventSinkEmpty = describe "handleEventSinkEmpty" $ do + it "should do nothing, since event is not passed down" $ + clickSunk (Point 200 15) `shouldBe` Seq.empty + + it "should click the top layer, since pointer is on the button" $ + clickSunk (Point 320 240) `shouldBe` Seq.singleton (BtnClick 2) + + where + wenv = mockWenv () + centeredBtn = button "Click 2" (BtnClick 2) `styleBasic` [height 10] + sunkNode = zstack_ [onlyTopActive False] [ + button "Click 1" (BtnClick 1), + box_ [ignoreEmptyArea_ False] centeredBtn + ] + clickSunk p = nodeHandleEventEvts wenv [evtClick p] sunkNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 50" $ + sizeReqW `shouldBe` fixedSize 50 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit () + boxNode = box (label "Label") + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv boxNode + +getSizeReqUpdater :: Spec +getSizeReqUpdater = describe "getSizeReqUpdater" $ do + it "should return width = Min 50 2" $ + sizeReqW `shouldBe` minSize 50 2 + + it "should return height = Max 20" $ + sizeReqH `shouldBe` maxSize 20 3 + + where + wenv = mockWenvEvtUnit () + updater (rw, rh) = (minSize (rw ^. L.fixed) 2, maxSize (rh ^. L.fixed) 3) + boxNode = box_ [sizeReqUpdater updater] (label "Label") + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv boxNode + +resize :: Spec +resize = describe "resize" $ do + resizeDefault + resizeExpand + resizeAlign + +resizeDefault :: Spec +resizeDefault = describe "default" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should have one child" $ + children `shouldSatisfy` (== 1) . Seq.length + + it "should have its children assigned a viewport" $ + cViewport `shouldBe` cvp + + where + wenv = mockWenvEvtUnit () + vp = Rect 0 0 640 480 + cvp = Rect 295 230 50 20 + boxNode = box (label "Label") + newNode = nodeInit wenv boxNode + children = newNode ^. L.children + viewport = newNode ^. L.info . L.viewport + cViewport = getChildVp wenv [] + +resizeExpand :: Spec +resizeExpand = describe "expand" $ + it "should have its children assigned a valid viewport" $ + cViewport `shouldBe` vp + + where + wenv = mockWenvEvtUnit () + vp = Rect 0 0 640 480 + cViewport = getChildVp wenv [expandContent] + +resizeAlign :: Spec +resizeAlign = describe "align" $ do + it "should align its child left" $ + childVpL `shouldBe` cvpl + + it "should align its child right" $ + childVpR `shouldBe` cvpr + + it "should align its child top" $ + childVpT `shouldBe` cvpt + + it "should align its child bottom" $ + childVpB `shouldBe` cvpb + + it "should align its child top-left" $ + childVpTL `shouldBe` cvplt + + it "should align its child bottom-right" $ + childVpBR `shouldBe` cvpbr + + where + wenv = mockWenvEvtUnit () + cvpl = Rect 0 230 50 20 + cvpr = Rect 590 230 50 20 + cvpt = Rect 295 0 50 20 + cvpb = Rect 295 460 50 20 + cvplt = Rect 0 0 50 20 + cvpbr = Rect 590 460 50 20 + childVpL = getChildVp wenv [alignLeft] + childVpR = getChildVp wenv [alignRight] + childVpT = getChildVp wenv [alignTop] + childVpB = getChildVp wenv [alignBottom] + childVpTL = getChildVp wenv [alignTop, alignLeft] + childVpBR = getChildVp wenv [alignBottom, alignRight] + +getChildVp :: (Eq s, WidgetModel s, WidgetEvent e) => WidgetEnv s e -> [BoxCfg s e] -> Rect +getChildVp wenv cfgs = childLC ^. L.info . L.viewport where + lblNode = label "Label" + boxNodeLC = nodeInit wenv (box_ cfgs lblNode) + childLC = Seq.index (boxNodeLC ^. L.children) 0 diff --git a/test/unit/Monomer/Widgets/Containers/ConfirmSpec.hs b/test/unit/Monomer/Widgets/Containers/ConfirmSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/ConfirmSpec.hs @@ -0,0 +1,54 @@ +{-| +Module : Monomer.Widgets.Containers.ConfirmSpec +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 Confirm dialog widget. +-} +module Monomer.Widgets.Containers.ConfirmSpec (spec) where + +import Control.Lens ((&), (.~)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Containers.Confirm + +import qualified Monomer.Lens as L + +data ConfirmEvent + = AcceptClick + | CancelClick + deriving (Eq, Show) + +spec :: Spec +spec = describe "Confirm" + handleEvent + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should generate a close event if clicked outside the dialog" $ + events (Point 3000 3000) `shouldBe` Seq.singleton CancelClick + + it "should generate an Accept event when clicking the Accept button" $ + events (Point 500 280) `shouldBe` Seq.singleton AcceptClick + + it "should generate a Cancel event when clicking the Cancel button" $ + events (Point 600 280) `shouldBe` Seq.singleton CancelClick + + it "should not generate a close event when clicking the dialog" $ + events (Point 300 200) `shouldBe` Seq.empty + + where + wenv = mockWenv () & L.theme .~ darkTheme + confirmNode = confirmMsg "Confirm!" AcceptClick CancelClick + events p = nodeHandleEventEvts wenv [evtClick p] confirmNode diff --git a/test/unit/Monomer/Widgets/Containers/DragDropSpec.hs b/test/unit/Monomer/Widgets/Containers/DragDropSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/DragDropSpec.hs @@ -0,0 +1,126 @@ +{-| +Module : Monomer.Widgets.Containers.DragDropSpec +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 Drag and Drop related widgets. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Containers.DragDropSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.List (delete) +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.Draggable +import Monomer.Widgets.Containers.DropTarget +import Monomer.Widgets.Containers.Grid +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data TestEvt + = DropTo1 Int + | DropTo2 Int + deriving (Eq, Show) + +data TestItem = TestItem { + _tiIdx :: Int, + _tiMsg :: Text +} deriving (Eq, Show) + +data TestModel = TestModel { + _tmItems1 :: [Int], + _tmItems2 :: [Int] +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestItem +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Drag & Drop" $ do + handleEvent + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should leave items intact if drag is not completed" $ do + let selStart = Point 20 10 + let selEnd = Point 20 100 + let steps = evtDrag selStart selEnd + model steps ^. items1 `shouldBe` [1, 2, 3, 4, 5] + model steps ^. items2 `shouldBe` [] + + it "should update items list if drag was successful" $ do + let selStart = Point 20 10 + let selEnd = Point 400 10 + let steps = evtDrag selStart selEnd + model steps ^. items1 `shouldBe` [2, 3, 4, 5] + model steps ^. items2 `shouldBe` [1] + + it "should both update items list if successive drags were successful" $ do + let selStart = Point 20 10 + let selEnd = Point 400 10 + let steps = evtDrag selStart selEnd + ++ evtDrag selStart selEnd + ++ evtDrag selStart selEnd + ++ evtDrag selEnd selStart + model steps ^. items1 `shouldBe` [4, 5, 1] + model steps ^. items2 `shouldBe` [2, 3] + + where + wenv = mockWenvEvtUnit (TestModel [1..5] []) + handleEvent wenv node model evt = case evt of + DropTo1 idx -> [Model $ model + & items2 .~ delete idx (model ^. items2) + & items1 .~ model ^. items1 ++ [idx]] + DropTo2 idx -> [Model $ model + & items1 .~ delete idx (model ^. items1) + & items2 .~ model ^. items2 ++ [idx]] + buildUI wenv model = hgrid [ + dropTarget DropTo1 $ vstack (fmap dragLbl (model ^. items1)), + dropTarget DropTo2 $ vstack (fmap dragLbl (model ^. items2)) + ] + dragLbl idx = draggable idx (label "Label") + mainNode = composite "main" id buildUI handleEvent + model es = nodeHandleEventModel wenv es mainNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return same reqW as child node" $ do + dgSizeReqW `shouldBe` lSizeReqW + dtSizeReqW `shouldBe` lSizeReqW + + it "should return same reqH as child node" $ do + dgSizeReqH `shouldBe` lSizeReqH + dtSizeReqH `shouldBe` lSizeReqH + + where + wenv = mockWenv (TestModel [] []) + item = TestItem 0 "" + lblNode = label "Test label" + (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode + (dgSizeReqW, dgSizeReqH) = nodeGetSizeReq wenv (draggable item lblNode) + (dtSizeReqW, dtSizeReqH) = nodeGetSizeReq wenv (dropTarget DropTo2 lblNode) diff --git a/test/unit/Monomer/Widgets/Containers/DropdownSpec.hs b/test/unit/Monomer/Widgets/Containers/DropdownSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/DropdownSpec.hs @@ -0,0 +1,166 @@ +{-| +Module : Monomer.Widgets.Containers.DropdownSpec +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 Dropdown widget. +-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Containers.DropdownSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Functor ((<&>)) +import Data.Text (Text) +import Test.Hspec +import TextShow + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Containers.Dropdown +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data TestEvt + = ItemSel Int TestItem + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestItem = TestItem { + _tiCode :: Int +} deriving (Eq, Show) + +instance TextShow TestItem where + showb (TestItem c) = "TestItem: " <> showb c + +newtype TestModel = TestModel { + _tmSelectedItem :: TestItem +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestItem +makeLensesWith abbreviatedFields ''TestModel + +testItems = [0..50] <&> TestItem +testItem0 = head testItems +testItem3 = testItems!!3 +testItem7 = testItems!!7 +testItem10 = testItems!!10 + +spec :: Spec +spec = describe "Dropdown" $ do + handleEvent + handleEventValue + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + let mainP = Point 50 10 + + it "should not update the model if not clicked" $ + model [evtClick (Point 3000 3000)] ^. selectedItem `shouldBe` testItem0 + + it "should update the model when clicked" $ do + let itemP = Point 50 90 + model [evtClick mainP, evtClick itemP] ^. selectedItem `shouldBe` testItem3 + + it "should update the model when clicked, after wheel scrolled" $ do + let itemP = Point 50 90 + let steps = [evtClick mainP, WheelScroll itemP (Point 0 (-14)) WheelNormal, evtClick itemP] + model steps ^. selectedItem `shouldBe` testItem10 + + it "should update the model when clicked, after list is displaced because of arrow press" $ do + let p = Point 50 30 + let steps = [evtClick mainP] ++ replicate 12 (evtK keyDown) ++ [evtClick p] + model steps ^. selectedItem `shouldBe` testItem3 + + it "should update the model when Enter/Space is pressed, after navigating to an element" $ do + let steps = [evtClick mainP] ++ replicate 11 (evtK keyDown) ++ [evtK keyUp, evtK keySpace] + model steps ^. selectedItem `shouldBe` testItem10 + + it "should generate an event when focus is received" $ do + eventsCnt [evtK keyTab] `shouldBe` Seq.singleton (GotFocus $ Seq.fromList [0, 0]) + + it "should generate an event when focus is lost and list is not open" $ do + let path = Seq.fromList [0, 0] + eventsCnt [evtK keyTab, evtK keyTab] `shouldBe` Seq.fromList [GotFocus path, LostFocus path] + + where + wenv = mockWenv (TestModel testItem0) + labelItem = label . showt + ddNode :: WidgetNode TestModel TestEvt + ddNode = vstack [ + dropdown_ selectedItem testItems labelItem labelItem [maxHeight 200] + ] + cntNode = vstack [ + button "Test" (ItemSel 0 testItem0), + dropdown_ selectedItem testItems labelItem labelItem [onFocus GotFocus, onBlur LostFocus] + ] + model es = nodeHandleEventModel wenv es ddNode + eventsCnt evts = nodeHandleEventEvts wenv evts cntNode + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + let outP = Point 3000 3000 + let mainP = Point 50 10 + + it "should not generate an event if clicked outside" $ + clickEvts outP `shouldBe` Seq.empty + + it "should not generate an event when clicked outside, after being opened with keyboard" $ do + let itemP = Point 50 90 + events [evtK keyDown, evtClick outP, evtClick itemP] `shouldBe` Seq.empty + + it "should generate an event when clicked, after being opened with keyboard" $ do + let itemP = Point 50 90 + events [evtK keyDown, evtClick itemP] `shouldBe` Seq.singleton (ItemSel 3 testItem3) + + it "should generate an event when Enter/Space is pressed, after navigating to an element" $ do + let steps = [evtK keyDown] ++ replicate 7 (evtK keyDown) ++ [evtK keySpace] + events steps `shouldBe` Seq.singleton (ItemSel 7 testItem7) + + it "should generate a focus lost event when opened, canceled, and navigated away" $ do + let steps = [evtK keyDown, evtK keyEscape, evtK keyTab] + events steps `shouldBe` Seq.singleton (LostFocus $ Seq.fromList [0, 1]) + + it "should generate an event when focus is lost and list is open. The navigation also generates a change event" $ do + let steps = [evtK keyDown] ++ replicate 3 (evtK keyDown) ++ [evtK keyTab] + events steps `shouldBe` Seq.fromList [ItemSel 3 testItem3, LostFocus $ Seq.fromList [0, 1]] + where + wenv = mockWenv (TestModel testItem0) + labelItem = label . showt + ddNode = vstack [ + dropdownV_ testItem0 ItemSel testItems labelItem labelItem [maxHeight 200, onBlur LostFocus], + button "Test" (ItemSel 0 testItem0) + ] + clickEvts p = nodeHandleEventEvts wenv [evtClick p] ddNode + events es = nodeHandleEventEvts wenv es ddNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Flex 120" $ + sizeReqW `shouldBe` expandSize 120 1 + + it "should return height = Flex 20 1" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (TestModel testItem0) + labelItem l = label_ (showt l) [resizeFactorW 0.01] + ddNode = dropdown selectedItem testItems labelItem labelItem + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv ddNode diff --git a/test/unit/Monomer/Widgets/Containers/GridSpec.hs b/test/unit/Monomer/Widgets/Containers/GridSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/GridSpec.hs @@ -0,0 +1,208 @@ +{-| +Module : Monomer.Widgets.Containers.GridSpec +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 Grid widget. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Containers.GridSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.Widgets.Containers.Grid +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Grid" $ do + getSizeReq + resize + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + getSizeReqEmpty + getSizeReqItemsH + getSizeReqItemsV + getSizeReqMixedH + getSizeReqMixedV + getSizeReqUpdater + +getSizeReqEmpty :: Spec +getSizeReqEmpty = describe "empty" $ do + it "should return width = Fixed 0" $ + sizeReqW `shouldBe` fixedSize 0 + + it "should return height = Fixed 0" $ + sizeReqH `shouldBe` fixedSize 0 + + where + wenv = mockWenv () + gridNode = vgrid [] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv gridNode + +getSizeReqItemsH :: Spec +getSizeReqItemsH = describe "several items, horizontal" $ do + it "should return width = Fixed 240 (largest width * 3)" $ + sizeReqW `shouldBe` fixedSize 240 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenv () + gridNode = hgrid [ + label "Hello", + label "how", + label "are you?" + ] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv gridNode + +getSizeReqItemsV :: Spec +getSizeReqItemsV = describe "several items, vertical, one not visible" $ do + it "should return width = Fixed 80" $ + sizeReqW `shouldBe` fixedSize 80 + + it "should return height = Fixed 60" $ + sizeReqH `shouldBe` fixedSize 60 + + where + wenv = mockWenv () + gridNode = vgrid [ + label "Hello", + label "how", + label "" `nodeVisible` False, + label "are you?" + ] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv gridNode + +getSizeReqMixedH :: Spec +getSizeReqMixedH = describe "several items, different reqSizes" $ do + it "should return width = Range 300 900 1 (3 * Range 100 300)" $ + sizeReqW `shouldBe` rangeSize 300 900 1 + + it "should return height = Range 100 300 1" $ + sizeReqH `shouldBe` rangeSize 100 300 1 + + where + wenv = mockWenv () + gridNode = hgrid [ + label "Label 1" `styleBasic` [width 100, height 100], + label "Label 2" `styleBasic` [maxWidth 300, maxHeight 300], + label "Label 3" + ] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv gridNode + +getSizeReqMixedV :: Spec +getSizeReqMixedV = describe "several items, different reqSizes" $ do + it "should return width = Min 100 1" $ + sizeReqW `shouldBe` SizeReq 100 200 100 1 + + it "should return height = Min 300 1 (3 * Min 100)" $ + sizeReqH `shouldBe` SizeReq 300 600 300 1 + + where + wenv = mockWenv () + gridNode = vgrid [ + label "Label 1" `styleBasic` [minWidth 100, minHeight 100], + label "Label 2" `styleBasic` [maxWidth 300, maxHeight 300], + label "Label 3" + ] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv gridNode + +getSizeReqUpdater :: Spec +getSizeReqUpdater = describe "getSizeReqUpdater" $ do + it "should return width = Min 50 2" $ + sizeReqW `shouldBe` minSize 50 2 + + it "should return height = Max 20" $ + sizeReqH `shouldBe` maxSize 20 3 + + where + wenv = mockWenv () + updater (rw, rh) = (minSize (rw ^. L.fixed) 2, maxSize (rh ^. L.fixed) 3) + vgridNode = vgrid_ [sizeReqUpdater updater] [label "Label"] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv vgridNode + +resize :: Spec +resize = describe "resize" $ do + resizeEmpty + resizeItemsH + resizeItemsV + +resizeEmpty :: Spec +resizeEmpty = describe "empty" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should not have children" $ + children `shouldSatisfy` Seq.null + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + gridNode = vgrid [] + newNode = nodeInit wenv gridNode + viewport = newNode ^. L.info . L.viewport + children = newNode ^. L.children + +resizeItemsH :: Spec +resizeItemsH = describe "several items, horizontal" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign the same viewport size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () & L.windowSize .~ Size 480 640 + vp = Rect 0 0 480 640 + cvp1 = Rect 0 0 160 640 + cvp2 = Rect 160 0 160 640 + cvp3 = Rect 320 0 160 640 + gridNode = hgrid [ + label "Label 1", + label "Label Number Two", + label "Label 3" + ] + newNode = nodeInit wenv gridNode + viewport = newNode ^. L.info . L.viewport + childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children + +resizeItemsV :: Spec +resizeItemsV = describe "several items, vertical, one not visible" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign the same viewport size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3, cvp4] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 160 + cvp2 = Rect 0 160 640 160 + cvp3 = Rect 0 0 0 0 + cvp4 = Rect 0 320 640 160 + gridNode = vgrid [ + label "Label 1", + label "Label Number Two", + label "Label invisible" `nodeVisible` False, + label "Label 3" + ] + newNode = nodeInit wenv gridNode + viewport = newNode ^. L.info . L.viewport + childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children diff --git a/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs b/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs @@ -0,0 +1,127 @@ +{-| +Module : Monomer.Widgets.Containers.KeystrokeSpec +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 Keystroke widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Containers.KeystrokeSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Keystroke +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.TextField + +import qualified Monomer.Lens as L + +data TestEvt + = CtrlA + | CtrlSpace + | CtrlShiftSpace + | MultiKey Int + | FunctionKey Int + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmTextValue :: Text +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Keystroke" $ do + handleEvent + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not generate events" $ do + events [] `shouldBe` Seq.empty + + 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-Shift-Space is pressed" $ do + events [evtKCS keySpace] `shouldBe` Seq.fromList [CtrlShiftSpace] + + it "should generate events when function keys are pressed" $ do + events [evtK keyF1] `shouldBe` Seq.fromList [FunctionKey 1] + events [evtKC keyF3] `shouldBe` Seq.fromList [FunctionKey 3] + events [evtKG keyF7] `shouldBe` Seq.fromList [FunctionKey 7] + events [evtKS keyF12] `shouldBe` Seq.fromList [FunctionKey 12] + + 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 [] + events [evtKC keyA, evtKC keyB, evtKC keyC] `shouldBe` Seq.fromList [MultiKey 1] + events [ + evtKC keyA, evtKC keyB, evtKC keyC, + evtKC keyD, evtKC keyE] `shouldBe` Seq.fromList [MultiKey 1] + events [ + evtKC keyA, evtKC keyB, evtKC keyC, + evtRKC keyA, evtRKC keyB, evtRKC keyC, + evtKC keyD, evtKC keyE] `shouldBe` Seq.fromList [MultiKey 1, MultiKey 2] + + it "should not ignore children events if not explicitly requested" $ do + events1 [evtKG keyA, evtT "d"] `shouldBe` Seq.fromList [CtrlA] + model1 [evtKG keyA, evtT "d"] ^. textValue `shouldBe` "d" + + it "should ignore children events if requested" $ do + events2 [evtKG keyA, evtT "d"] `shouldBe` Seq.fromList [CtrlA] + model2 [evtKG keyA, evtT "d"] ^. textValue `shouldBe` "abcd" + + where + wenv = mockWenv (TestModel "") + bindings = [ + ("C-Space", CtrlSpace), + ("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) + ] + kstNode = keystroke bindings (textField textValue) + events es = nodeHandleEventEvts wenv es kstNode + wenv2 = mockWenv (TestModel "abc") + kstModel1 = keystroke [("C-a", CtrlA)] (textField textValue) + kstModel2 = keystroke_ [("C-a", CtrlA)] [ignoreChildrenEvts] (textField textValue) + model1 es = nodeHandleEventModel wenv2 es kstModel1 + model2 es = nodeHandleEventModel wenv2 es kstModel2 + events1 es = nodeHandleEventEvts wenv2 es kstModel1 + events2 es = nodeHandleEventEvts wenv2 es kstModel2 + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return same reqW as child node" $ + kSizeReqW `shouldBe` lSizeReqW + + it "should return same reqH as child node" $ + kSizeReqH `shouldBe` lSizeReqH + + where + wenv = mockWenvEvtUnit (TestModel "Test value") + lblNode = label "Test label" + (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode + (kSizeReqW, kSizeReqH) = nodeGetSizeReq wenv (keystroke [] lblNode) diff --git a/test/unit/Monomer/Widgets/Containers/ScrollSpec.hs b/test/unit/Monomer/Widgets/Containers/ScrollSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/ScrollSpec.hs @@ -0,0 +1,290 @@ +{-| +Module : Monomer.Widgets.Containers.ScrollSpec +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 Scroll widget. +-} +module Monomer.Widgets.Containers.ScrollSpec (spec) where + +import Control.Lens ((&), (^.), (^?), (^?!), (.~), _Just, ix) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics.ColorTable +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.Scroll +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +data ButtonEvt + = Button1 + | Button2 + | Button3 + | Button4 + deriving (Eq, Show) + +spec :: Spec +spec = describe "Scroll" $ do + handleEvent + forwardStyle + resize + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + handleChildrenFocus + handleNestedWheel + handleMessageReset + +handleChildrenFocus :: Spec +handleChildrenFocus = describe "handleChildrenFocus" $ do + it "should not follow focus events" $ do + evtsIgnore evts1 `shouldBe` Seq.fromList [Button1] + evtsIgnore evts2 `shouldBe` Seq.fromList [Button1] + evtsIgnore evts3 `shouldBe` Seq.fromList [Button1] + + it "should follow focus events" $ do + evtsFollow evts1 `shouldBe` Seq.fromList [Button2] + evtsFollow evts3 `shouldBe` Seq.fromList [Button4] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + point = Point 320 200 + evts1 = [evtK keyTab, evtClick point] + evts2 = [evtK keyTab, evtK keyTab, evtClick point] + evts3 = [evtK keyTab, evtK keyTab, evtK keyTab, evtClick point] + st = [width 640, height 480] + stackNode = vstack [ + button "Button 1" Button1 `styleBasic` st, + button "Button 2" Button2 `styleBasic` st, + button "Button 3" Button3 `styleBasic` st, + button "Button 4" Button4 `styleBasic` st + ] + ignoreNode = scroll_ [scrollFollowFocus_ False] stackNode + followNode = scroll stackNode + evtsIgnore es = nodeHandleEventEvts wenv es ignoreNode + evtsFollow es = nodeHandleEventEvts wenv es followNode + +handleNestedWheel :: Spec +handleNestedWheel = describe "handleNestedWheel" $ do + it "should scroll main widget" $ do + events evts1 `shouldBe` Seq.fromList [Button4] + + it "should scroll child widget" $ do + events evts2 `shouldBe` Seq.fromList [Button3] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + pointClick = Point 160 240 + pointWheel1 = Point 480 240 + pointWheel2 = Point 160 240 + evtWheel p = WheelScroll p (Point 0 (-2000)) WheelNormal + evts1 = [evtWheel pointWheel1, evtClick pointClick] + evts2 = [evtWheel pointWheel2, evtClick pointClick] + st = [width 320, height 480] + childNode = vscroll (vstack [ + button "Button 1" Button1 `styleBasic` st, + button "Button 2" Button2 `styleBasic` st, + button "Button 3" Button3 `styleBasic` st + ]) `styleBasic` [height 480] + mainNode = vstack [ + childNode, + button "Button 4" Button4 `styleBasic` st + ] `styleBasic` [width 320] + scrollNode = vscroll $ hstack [ + mainNode, + filler + ] + events es = nodeHandleEventEvts wenv es scrollNode + +handleMessageReset :: Spec +handleMessageReset = describe "handleMessageReset" $ do + it "should not generate an event if scroll does not show Button1" $ + events es `shouldBe` Seq.empty + + it "should generate an event if scroll shows Button1" $ + events (evtK keyTab : es) `shouldBe` Seq.singleton Button1 + + where + wenv = mockWenv () + es = [evtK keyTab, evtClick (Point 10 10), evtClick (Point 10 10)] + handleEvent + :: WidgetEnv () ButtonEvt + -> WidgetNode () ButtonEvt + -> () + -> ButtonEvt + -> [EventResponse () ButtonEvt () ButtonEvt] + handleEvent wenv node model evt = case evt of + Button1 -> [Report Button1] + Button3 -> [Message "mainScroll" ScrollReset] + _ -> [] + buildUI wenv model = scroll (vstack [ + button "Button 1" Button1 `styleBasic` [height 480], + button "Button 2" Button2 `styleBasic` [height 480], + button "Button 3" Button3 `styleBasic` [height 480] + ]) `nodeKey` "mainScroll" + cmpNode = composite "main" id buildUI handleEvent + events es = nodeHandleEventEvts wenv es cmpNode + +forwardStyle :: Spec +forwardStyle = describe "forwardStyle" $ do + it "should assign scroll the top style, while the child be set to default" $ do + pnode1 ^? L.info . L.style . L.basic . _Just `shouldBe` Just (border 1 black <> padding 10) + cnode1 ^? L.info . L.style . L.basic . _Just `shouldBe` Just def + + it "should split the style according to the rules of scrollFwdDefault" $ do + pnode2 ^? L.info . L.style . L.basic . _Just `shouldBe` Just (border 1 black) + cnode2 ^? L.info . L.style . L.basic . _Just `shouldBe` Just (padding 10) + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + snode1 = scroll (label "Test") `styleBasic` [border 1 black, padding 10] + snode2 = scroll_ [scrollFwdStyle scrollFwdDefault] (label "Test") `styleBasic` [border 1 black, padding 10] + pnode1 = nodeInit wenv snode1 + cnode1 = pnode1 ^?! L.children . ix 0 + pnode2 = nodeInit wenv snode2 + cnode2 = pnode2 ^?! L.children . ix 0 + +resize :: Spec +resize = describe "resize" $ do + resizeLarge + resizeSmall + resizeOverlaySmall + resizeH + resizeV + resizeOverlayH + resizeOverlayV + +resizeLarge :: Spec +resizeLarge = describe "resizeLarge" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign all the requested space" $ + childrenVp `shouldBe` Seq.fromList [cvp1] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 3000 2000 + scrollNode = scroll (label "" `styleBasic` [width 3000, height 2000]) + newNode = nodeInit wenv scrollNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeSmall :: Spec +resizeSmall = describe "resizeSmall" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign all the requested space" $ + childrenVp `shouldBe` Seq.fromList [cvp1] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 480 + scrollNode = scroll (label "" `styleBasic` [width 300, height 200]) + newNode = nodeInit wenv scrollNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeOverlaySmall :: Spec +resizeOverlaySmall = describe "resizeOverlaySmall" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign all the requested space" $ + childrenVp `shouldBe` Seq.fromList [cvp1] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 480 + scrollNode = scroll_ [scrollOverlay] (label "" `styleBasic` [width 300, height 200]) + newNode = nodeInit wenv scrollNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeH :: Spec +resizeH = describe "resizeH" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign all the requested horizontal space" $ + childrenVp `shouldBe` Seq.fromList [cvp1] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 3000 470 + scrollNode = hscroll (label "" `styleBasic` [width 3000, height 2000]) + newNode = nodeInit wenv scrollNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeV :: Spec +resizeV = describe "resizeV" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign all the requested vertical space" $ + childrenVp `shouldBe` Seq.fromList [cvp1] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 630 2000 + scrollNode = vscroll (label "" `styleBasic` [width 3000, height 2000]) + newNode = nodeInit wenv scrollNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeOverlayH :: Spec +resizeOverlayH = describe "resizeOverlayH" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign all the requested horizontal space" $ + childrenVp `shouldBe` Seq.fromList [cvp1] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 3000 480 + scrollNode = hscroll_ [scrollOverlay] (label "" `styleBasic` [width 3000, height 2000]) + newNode = nodeInit wenv scrollNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeOverlayV :: Spec +resizeOverlayV = describe "resizeOverlayV" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign all the requested vertical space" $ + childrenVp `shouldBe` Seq.fromList [cvp1] + + where + wenv = mockWenv () & L.windowSize .~ Size 640 480 + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 2000 + scrollNode = vscroll_ [scrollOverlay] (label "" `styleBasic` [width 3000, height 2000]) + newNode = nodeInit wenv scrollNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children diff --git a/test/unit/Monomer/Widgets/Containers/SelectListSpec.hs b/test/unit/Monomer/Widgets/Containers/SelectListSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/SelectListSpec.hs @@ -0,0 +1,145 @@ +{-| +Module : Monomer.Widgets.Containers.SelectListSpec +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 SelectList widget. +-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Containers.SelectListSpec (spec) where + +import Control.Lens ((&), (^.), (.~), _1) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Functor ((<&>)) +import Data.Text (Text) +import Test.Hspec +import TextShow + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Containers.SelectList +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +data TestEvt + = ItemSel Int TestItem + | BtnClick + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestItem = TestItem { + _tiCode :: Int +} deriving (Eq, Show) + +instance TextShow TestItem where + showb (TestItem c) = "TestItem: " <> showb c + +newtype TestModel = TestModel { + _tmSelectedItem :: TestItem +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestItem +makeLensesWith abbreviatedFields ''TestModel + +testItems = [0..99] <&> TestItem +testItem0 = head testItems +testItem3 = testItems!!3 +testItem7 = testItems!!7 +testItem10 = testItems!!10 +testItem70 = testItems!!70 + +spec :: Spec +spec = describe "SelectList" $ do + handleEvent + handleEventValue + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not update the model if not clicked" $ + clickModel (Point 3000 3000) ^. selectedItem `shouldBe` testItem0 + + it "should update the model when clicked" $ + clickModel (Point 100 70) ^. selectedItem `shouldBe` testItem3 + + it "should update the model when clicked, after wheel scrolled" $ do + let p = Point 100 10 + let steps = [evtK keyTab, WheelScroll p (Point 0 (-140)) WheelNormal, evtClick p] + model steps ^. selectedItem `shouldBe` testItem70 + + it "should update the model when clicked, after list is displaced because of arrow press" $ do + let p = Point 100 10 + let steps = [evtK keyTab] ++ replicate 26 (evtK keyDown) ++ [evtClick p] + model steps ^. selectedItem `shouldBe` testItem3 + + it "should update the model when Enter/Space is pressed, after navigating to an element" $ do + let steps = [evtK keyTab] ++ replicate 71 (evtK keyDown) ++ [evtK keyUp, evtK keySpace] + model steps ^. selectedItem `shouldBe` testItem70 + + it "should generate an event when focus is received" $ do + let p = Point 100 30 + eventsCnt [evtClick p] `shouldBe` Seq.singleton (GotFocus $ Seq.fromList [0, 0]) + + it "should generate an event when focus is lost" $ do + let p = Point 100 30 + let path = Seq.fromList [0, 0] + eventsCnt [evtClick p, evtBlur] `shouldBe` Seq.fromList [GotFocus path, LostFocus emptyPath] + + where + wenv = mockWenv (TestModel testItem0) + slNode = selectList_ selectedItem testItems (label . showt) [onFocus GotFocus, onBlur LostFocus] + cntNode = vstack [ + button "Test" BtnClick, + selectList_ selectedItem testItems (label . showt) [onFocus GotFocus, onBlur LostFocus] + ] + clickModel p = nodeHandleEventModel wenv [evtClick p] slNode + model keys = nodeHandleEventModel wenv keys slNode + events evts = nodeHandleEventEvts wenv evts slNode + eventsCnt evts = nodeHandleEventEvts wenv evts cntNode + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + it "should not generate an event if clicked outside" $ + clickEvts (Point 3000 3000) `shouldBe` Seq.empty + + it "should generate an event when clicked" $ + events [evtK keyTab, evtClick (Point 100 70)] `shouldBe` Seq.singleton (ItemSel 3 testItem3) + + it "should generate an event when Enter/Space is pressed, after navigating to an element" $ do + let steps = [evtK keyTab] ++ replicate 7 (evtK keyDown) ++ [evtK keySpace] + events steps `shouldBe` Seq.singleton (ItemSel 7 testItem7) + + where + wenv = mockWenv (TestModel testItem0) + slNode = selectListV_ testItem0 ItemSel testItems (label . showt) [onFocus GotFocus, onBlur LostFocus] + clickEvts p = nodeHandleEventEvts wenv [evtClick p] slNode + events evts = Seq.drop (Seq.length res - 1) res where + res = nodeHandleEventEvts wenv evts slNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Flex 120" $ + sizeReqW `shouldBe` expandSize 120 1 + + it "should return height = Flex 2000 1" $ + sizeReqH `shouldBe` expandSize 2000 1 + + where + wenv = mockWenvEvtUnit (TestModel testItem0) + slNode = selectList selectedItem testItems (label . showt) + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv slNode diff --git a/test/unit/Monomer/Widgets/Containers/SplitSpec.hs b/test/unit/Monomer/Widgets/Containers/SplitSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/SplitSpec.hs @@ -0,0 +1,169 @@ +{-| +Module : Monomer.Widgets.Containers.SplitSpec +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 Split widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Containers.SplitSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Split +import Monomer.Widgets.Singles.Button + +import qualified Monomer.Lens as L + +data TestEvt + = SliderChanged Double + | Button1 + | Button2 + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmSliderPos :: Double +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Split" $ do + handleEventMouseDragH + handleEventMouseDragV + getSizeReq + +handleEventMouseDragH :: Spec +handleEventMouseDragH = describe "handleEventMouseDragH" $ do + it "should drag left 100 pixels, moving the slider" $ do + let selStart = Point 320 240 + let selEnd = Point 220 100 + let steps = evtDrag selStart selEnd + model steps ^. sliderPos `shouldBe` (220 / 640) + areas steps `shouldBe` Seq.fromList [Rect 0 0 218 480, Rect 223 0 417 480] + + it "should drag left 200 pixels, but move the slider only 120" $ do + let selStart = Point 320 240 + let selEnd = Point 120 100 + let steps = evtDrag selStart selEnd + model steps ^. sliderPos `shouldBe` (200 / 640) + areas steps `shouldBe` Seq.fromList [Rect 0 0 198 480, Rect 203 0 437 480] + + it "should drag right 100 pixels, but move the slider only 80" $ do + let selStart = Point 320 240 + let selEnd = Point 420 100 + let steps = evtDrag selStart selEnd + model steps ^. sliderPos `shouldBe` (400 / 640) + areas steps `shouldBe` Seq.fromList [Rect 0 0 397 480, Rect 402 0 238 480] + + it "should drag up 100 pixels, keeping the slider intact" $ do + let selStart = Point 320 240 + let selEnd = Point 320 140 + let steps = evtDrag selStart selEnd + model steps ^. sliderPos `shouldBe` 0.5 + areas steps `shouldBe` Seq.fromList [Rect 0 0 318 480, Rect 322 0 318 480] + + it "should drag down 100 pixels, keeping the slider intact" $ do + let selStart = Point 320 240 + let selEnd = Point 320 340 + let steps = evtDrag selStart selEnd + model steps ^. sliderPos `shouldBe` 0.5 + areas steps `shouldBe` Seq.fromList [Rect 0 0 318 480, Rect 322 0 318 480] + + where + wenv = mockWenv (TestModel 0.5) + btn1 = button "Text" Button1 `styleBasic` [rangeWidth 200 400] + btn2 = button "Longer" Button2 `styleBasic` [expandWidth 60] + splitNode = hsplit_ [splitHandlePos sliderPos] (btn1, btn2) + model es = nodeHandleEventModel wenv es splitNode + areas es = vp where + root = nodeHandleEventRoot wenv es splitNode + vp = fmap (roundRectUnits . _wniViewport . _wnInfo) (root ^. L.children) + +handleEventMouseDragV :: Spec +handleEventMouseDragV = describe "handleEventMouseDragV" $ do + it "should drag up 100 pixels, moving the slider" $ do + let selStart = Point 320 240 + let selEnd = Point 320 140 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 0.5, SliderChanged (140 / 480)] + areas steps `shouldBe` Seq.fromList [Rect 0 0 640 139, Rect 0 144 640 336] + + it "should drag up 200 pixels, but move the slider only 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 40 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 0.5, SliderChanged (80 / 480)] + areas steps `shouldBe` Seq.fromList [Rect 0 0 640 79, Rect 0 84 640 396] + + it "should drag down 100 pixels, but move the slider only 40" $ do + let selStart = Point 320 240 + let selEnd = Point 320 340 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 0.5, SliderChanged (280 / 480)] + areas steps `shouldBe` Seq.fromList [Rect 0 0 640 277, Rect 0 282 640 198] + + it "should drag left 100 pixels, keeping the slider intact" $ do + let selStart = Point 320 240 + let selEnd = Point 220 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 0.5] + areas steps `shouldBe` Seq.fromList [Rect 0 0 640 238, Rect 0 242 640 238] + + it "should drag right 100 pixels, keeping the slider intact" $ do + let selStart = Point 320 240 + let selEnd = Point 420 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 0.5] + areas steps `shouldBe` Seq.fromList [Rect 0 0 640 238, Rect 0 242 640 238] + + where + wenv = mockWenv (TestModel 0.5) + -- Uses flexHeight otherwise buttons are fixed size and split will not move + btn1 = button "Text" Button1 `styleBasic` [flexHeight 20] + btn2 = button "Longer" Button2 `styleBasic` [rangeHeight 200 400] + splitNode = vsplit_ [splitHandlePosV 0.5, onChange SliderChanged] (btn1, btn2) + evts es = nodeHandleEventEvts wenv es splitNode + areas es = vp where + root = nodeHandleEventRoot wenv es splitNode + vp = fmap (roundRectUnits . _wniViewport . _wnInfo) (root ^. L.children) + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Range 5 125 0.01" $ + hsizeReqW `shouldBe` SizeReq 5 120 120 1 + + it "should return height = Fixed 20" $ + hsizeReqH `shouldBe` fixedSize 20 + + it "should return width = Expand 60 1" $ + vsizeReqW `shouldBe` expandSize 60 1 + + it "should return height = Fixed 45" $ + vsizeReqH `shouldBe` fixedSize 45 + + where + wenv = mockWenv (TestModel 0) + btn1 = button "Button" Button1 `styleBasic` [expandWidth 60] + btn2 = button "Button" Button2 `styleBasic` [expandWidth 60] + (hsizeReqW, hsizeReqH) = nodeGetSizeReq wenv (hsplit (btn1, btn2)) + (vsizeReqW, vsizeReqH) = nodeGetSizeReq wenv (vsplit (btn1, btn2)) diff --git a/test/unit/Monomer/Widgets/Containers/StackSpec.hs b/test/unit/Monomer/Widgets/Containers/StackSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/StackSpec.hs @@ -0,0 +1,359 @@ +{-| +Module : Monomer.Widgets.Containers.StackSpec +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 Stack widget. +-} +{-# LANGUAGE FlexibleContexts #-} + +module Monomer.Widgets.Containers.StackSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +-- Event handling (ignoreEmptyClick) is tested in zstack +spec :: Spec +spec = describe "Stack" $ do + getSizeReq + resize + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + getSizeReqEmpty + getSizeReqItems + getSizeReqUpdater + +getSizeReqEmpty :: Spec +getSizeReqEmpty = describe "empty" $ do + it "should return Fixed width = 0" $ + sizeReqW `shouldBe` fixedSize 0 + + it "should return Fixed height = 0" $ + sizeReqH `shouldBe` fixedSize 0 + + where + wenv = mockWenv () + vstackNode = vstack [] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv vstackNode + +getSizeReqItems :: Spec +getSizeReqItems = describe "several items" $ do + it "should return width = Fixed 80" $ + sizeReqW `shouldBe` fixedSize 80 + + it "should return height = Fixed 60" $ + sizeReqH `shouldBe` fixedSize 60 + + where + wenv = mockWenv () + vstackNode = vstack [ + label "Hello", + label "how", + label "are you?" + ] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv vstackNode + +getSizeReqUpdater :: Spec +getSizeReqUpdater = describe "getSizeReqUpdater" $ do + it "should return width = Min 50 2" $ + sizeReqW `shouldBe` minSize 50 2 + + it "should return height = Max 20" $ + sizeReqH `shouldBe` maxSize 20 3 + + where + wenv = mockWenv () + updater (rw, rh) = (minSize (rw ^. L.fixed) 2, maxSize (rh ^. L.fixed) 3) + vstackNode = vstack_ [sizeReqUpdater updater] [label "Label"] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv vstackNode + +resize :: Spec +resize = describe "resize" $ do + resizeEmpty + resizeFlexibleH + resizeFlexibleV + resizeStrictFlexH + resizeStrictFlexV + resizeMixedH + resizeMixedV + resizeAllV + resizeNoSpaceV + resizeSpacerFlexH + resizeSpacerFixedH + +resizeEmpty :: Spec +resizeEmpty = describe "empty" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should not have children" $ + children `shouldSatisfy` Seq.null + + where + wenv = mockWenv () + -- Main axis is adjusted to content + vp = Rect 0 0 640 0 + vstackNode = vstack [] + newNode = nodeInit wenv vstackNode + viewport = newNode ^. L.info . L.viewport + children = newNode ^. L.children + +resizeFlexibleH :: Spec +resizeFlexibleH = describe "flexible items, horizontal" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () & L.windowSize .~ Size 480 640 + vp = Rect 0 0 480 640 + cvp1 = Rect 0 0 112 640 + cvp2 = Rect 112 0 256 640 + cvp3 = Rect 368 0 112 640 + hstackNode = hstack [ + label "Label 1" `styleBasic` [expandWidth 70], + label "Label 2" `styleBasic` [expandWidth 160], + label "Label 3" `styleBasic` [expandWidth 70] + ] + newNode = nodeInit wenv hstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeFlexibleV :: Spec +resizeFlexibleV = describe "flexible items, vertical" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 160 + cvp2 = Rect 0 160 640 160 + cvp3 = Rect 0 320 640 160 + vstackNode = vstack [ + label "Label 1" `styleBasic` [flexHeight 20], + label "Label Number Two" `styleBasic` [flexHeight 20], + label "Label 3" `styleBasic` [flexHeight 20] + ] + newNode = nodeInit wenv vstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children + +resizeStrictFlexH :: Spec +resizeStrictFlexH = describe "strict/flexible items, horizontal" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign requested size to the main labels and the rest to grid" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 100 480 + cvp2 = Rect 100 0 100 480 + cvp3 = Rect 200 0 440 480 + hstackNode = hstack [ + label "Label 1" `styleBasic` [width 100], + label "Label 2" `styleBasic` [width 100], + label "Label 3" `styleBasic` [expandWidth 70] + ] + newNode = nodeInit wenv hstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children + +resizeStrictFlexV :: Spec +resizeStrictFlexV = describe "strict/flexible items, vertical" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign requested size to the main labels and the rest to grid" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 100 + cvp2 = Rect 0 100 640 20 + cvp3 = Rect 0 120 640 360 + vstackNode = vstack [ + label "Label 1" `styleBasic` [height 100], + label "Label 2", + label "Label 3" `styleBasic` [flexHeight 100] + ] + newNode = nodeInit wenv vstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children + +resizeMixedH :: Spec +resizeMixedH = describe "mixed items, horizontal" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2] + + where + wenv = mockWenv () + vp = Rect 0 0 640 20 + cvp1 = Rect 0 0 196 20 + cvp2 = Rect 196 0 444 20 + hstackNode = vstack [ + hstack [ + label "Label 1" `styleBasic` [expandWidth 110], + label "Label 2" `styleBasic` [expandWidth 250] + ] + ] + newNode = nodeInit wenv hstackNode + viewport = newNode ^. L.info . L.viewport + firstChild = Seq.index (newNode ^. L.children) 0 + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> firstChild ^. L.children + +resizeMixedV :: Spec +resizeMixedV = describe "mixed items, vertical" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () + vp = Rect 0 0 70 480 + cvp1 = Rect 0 0 70 20 + cvp2 = Rect 0 20 70 426 + cvp3 = Rect 0 446 70 34 + vstackNode = hstack [ + vstack [ + label "Label 1", + label "Label 2" `styleBasic` [minHeight 250], + label "Label 3" `styleBasic` [flexHeight 20] + ] + ] + newNode = nodeInit wenv vstackNode + viewport = newNode ^. L.info . L.viewport + firstChild = Seq.index (newNode ^. L.children) 0 + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> firstChild ^. L.children + +resizeAllV :: Spec +resizeAllV = describe "all kinds of sizeReq, vertical" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3, cvp4, cvp5] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 640 50 + cvp2 = Rect 0 50 640 115 + cvp3 = Rect 0 165 640 135 + cvp4 = Rect 0 300 640 80 + cvp5 = Rect 0 380 640 100 + vstackNode = vstack [ + label "Label 1" `styleBasic` [width 50, height 50], + label "Label 2" `styleBasic` [flexWidth 60, flexHeight 60], + label "Label 3" `styleBasic` [minWidth 70, minHeight 70], + label "Label 4" `styleBasic` [maxWidth 80, maxHeight 80], + label "Label 5" `styleBasic` [rangeWidth 90 100, rangeHeight 90 100] + ] + newNode = nodeInit wenv vstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeNoSpaceV :: Spec +resizeNoSpaceV = describe "vertical, without enough space" $ do + it "should have a larger viewport size (parent should fix it)" $ do + viewport `shouldBe` vp + viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3, cvp4, cvp5] + + where + wenv = mockWenv () + vp = Rect 0 0 640 800 + cvp1 = Rect 0 0 640 200 + cvp2 = Rect 0 200 640 200 + cvp3 = Rect 0 400 640 0 + cvp4 = Rect 0 400 640 200 + cvp5 = Rect 0 600 640 200 + vstackNode = vstack [ + label "Label 1" `styleBasic` [height 200], + label "Label 2" `styleBasic` [height 200], + label "Label 3" `styleBasic` [flexHeight 200], + label "Label 4" `styleBasic` [height 200], + label "Label 5" `styleBasic` [height 200] + ] + newNode = nodeInit wenv vstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeSpacerFlexH :: Spec +resizeSpacerFlexH = describe "label flex and spacer, horizontal" $ do + it "should have the provided viewport size" $ + roundRectUnits viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 211 480 + cvp2 = Rect 211 0 8 480 + cvp3 = Rect 219 0 421 480 + hstackNode = hstack [ + label "Label" `styleBasic` [flexWidth 100], + filler, + label "Label" `styleBasic` [flexWidth 200] + ] + newNode = nodeInit wenv hstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children + +resizeSpacerFixedH :: Spec +resizeSpacerFixedH = describe "label fixed and spacer, horizontal" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign size proportional to requested size to each children" $ + childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + cvp1 = Rect 0 0 100 480 + cvp2 = Rect 100 0 340 480 + cvp3 = Rect 440 0 200 480 + hstackNode = hstack [ + label "Label" `styleBasic` [width 100], + filler, + label "Label" `styleBasic` [width 200] + ] + newNode = nodeInit wenv hstackNode + viewport = newNode ^. L.info . L.viewport + childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children diff --git a/test/unit/Monomer/Widgets/Containers/ThemeSwitchSpec.hs b/test/unit/Monomer/Widgets/Containers/ThemeSwitchSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/ThemeSwitchSpec.hs @@ -0,0 +1,80 @@ +{-| +Module : Monomer.Widgets.Containers.ThemeSwitchSpec +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 ThemeSwitch widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Containers.ThemeSwitchSpec (spec) where + +import Control.Lens ((&), (^.), (.~), (?~)) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Containers.ThemeSwitch +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Theme Switch" $ do + switchTheme + getSizeReq + +switchTheme :: Spec +switchTheme = describe "switchTheme" $ do + it "should return different sizes when theme changes" $ do + sizeReqW1 `shouldBe` sizeReqW2 + sizeReqH1 `shouldBe` sizeReqH2 + sizeReqW1 `shouldNotBe` sizeReqW3 + sizeReqH1 `shouldNotBe` sizeReqH3 + + where + wenv = mockWenvEvtUnit () + & L.theme .~ theme1 + theme1 :: Theme = def + theme2 :: Theme = def + & L.basic . L.labelStyle . L.padding ?~ padding 10 + node = hstack [ + label "Test", + label "Test", + themeSwitch theme2 (label "Test") + ] + newNode = nodeInit wenv node + inst = widgetGetInstanceTree (newNode ^. L.widget) wenv newNode + child1 = Seq.index (inst ^. L.children) 0 + child2 = Seq.index (inst ^. L.children) 1 + child3 = Seq.index (inst ^. L.children) 2 + childReq ch = (ch ^. L.info . L.sizeReqW, ch ^. L.info . L.sizeReqH) + (sizeReqW1, sizeReqH1) = childReq child1 + (sizeReqW2, sizeReqH2) = childReq child2 + (sizeReqW3, sizeReqH3) = childReq child3 + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return same reqW as child node" $ + tSizeReqW `shouldBe` lSizeReqW + + it "should return same reqH as child node" $ + tSizeReqH `shouldBe` lSizeReqH + + where + wenv = mockWenvEvtUnit () + lblNode = label "Test label" + (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode + (tSizeReqW, tSizeReqH) = nodeGetSizeReq wenv (themeSwitch def lblNode) diff --git a/test/unit/Monomer/Widgets/Containers/TooltipSpec.hs b/test/unit/Monomer/Widgets/Containers/TooltipSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/TooltipSpec.hs @@ -0,0 +1,117 @@ +{-| +Module : Monomer.Widgets.Containers.TooltipSpec +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 Tooltip widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Containers.TooltipSpec (spec) where + +import Control.Lens ((&), (^.), (.~), (%~)) +import Data.Default +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Map.Strict as M +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.Main +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Containers.Tooltip +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Tooltip" $ do + handleEvent + handleEventFollow + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not generate a render schedule" $ do + reqs [] `shouldBe` Seq.empty + + it "should generate a render schedule after moving" $ do + let evt = Move (Point 10 10) + let widgetId = WidgetId 0 rootPath + let renderEveryReq = RenderEvery widgetId 1000 (Just 1) + reqs [evt] `shouldBe` Seq.fromList [renderEveryReq] + + it "should ony generate a render schedule even after moving, since delay has not passed" $ do + let evt1 = Move (Point 10 10) + let evt2 = Move (Point 50 50) + let widgetId = WidgetId 0 rootPath + let renderEveryReq = RenderEvery widgetId 1000 (Just 1) + reqs [evt1, evt2] `shouldBe` Seq.fromList [renderEveryReq] + + where + wenv = mockWenvEvtUnit () + ttNode = tooltip "" (label "Test") + reqs es = getReqs wenv ttNode es + +handleEventFollow :: Spec +handleEventFollow = describe "handleEventFollow" $ do + it "should not generate a render schedule" $ do + reqs [] `shouldBe` Seq.empty + + it "should generate a render schedule after moving" $ do + let evt = Move (Point 10 10) + let widgetId = WidgetId 0 rootPath + let renderEveryReq = RenderEvery widgetId 500 (Just 1) + reqs [evt] `shouldBe` Seq.fromList [renderEveryReq] + + it "should generate a render schedule even after moving, and RenderOnce after" $ do + let evt1 = Move (Point 10 10) + let evt2 = Move (Point 50 50) + let widgetId = WidgetId 0 rootPath + let renderEveryReq = RenderEvery widgetId 500 (Just 1) + reqs [evt1, evt2] `shouldBe` Seq.fromList [renderEveryReq, RenderOnce] + + where + wenv = mockWenvEvtUnit () + ttNode = tooltip_ "" [tooltipDelay 500, tooltipFollow] (label "Test") + reqs es = getReqs wenv ttNode es + +getReqs + :: Eq s + => WidgetEnv s e + -> WidgetNode s e + -> [SystemEvent] + -> Seq (WidgetRequest s e) +getReqs wenv node [] = Seq.empty +getReqs wenv node (e:es) = tmpReqs <> newReqs where + -- Each component generates a RenderOnce request when Enter event is received + tmpNode = nodeHandleEventRoot wenv [e] node + tmpReqs = Seq.drop 2 $ nodeHandleEventReqs wenv [e] node + newWenv = wenv & L.timestamp %~ (+1000) + newReqs = Seq.drop 2 $ nodeHandleEventReqs newWenv es tmpNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return same reqW as child node" $ + tSizeReqW `shouldBe` lSizeReqW + + it "should return same reqH as child node" $ + tSizeReqH `shouldBe` lSizeReqH + + where + wenv = mockWenvEvtUnit () + & L.theme .~ darkTheme + lblNode = label "Test label" + (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode + (tSizeReqW, tSizeReqH) = nodeGetSizeReq wenv (tooltip "" lblNode) diff --git a/test/unit/Monomer/Widgets/Containers/ZStackSpec.hs b/test/unit/Monomer/Widgets/Containers/ZStackSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Containers/ZStackSpec.hs @@ -0,0 +1,293 @@ +{-| +Module : Monomer.Widgets.Containers.ZStackSpec +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 ZStack widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Containers.ZStackSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.Confirm +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Containers.ZStack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.TextField + +import qualified Monomer.Lens as L + +newtype BtnEvent + = BtnClick Int + deriving (Eq, Show) + +data TestModel = TestModel { + _tmTextValue1 :: Text, + _tmTextValue2 :: Text +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "ZStack" $ do + handleEvent + getSizeReq + resize + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + handleEventFirstVisible + handleEventAllLayersActive + handleEventFocusTop + handleEventFocusAll + handleEventFocusChange + handleEventFocusKeep + +handleEventFirstVisible :: Spec +handleEventFirstVisible = describe "handleEventFirstVisible" $ do + it "should not generate an event if clicked outside" $ + clickEvts (Point 3000 3000) `shouldBe` Seq.empty + + it "should click the second layer, since top is not visible" $ + clickEvts (Point 100 100) `shouldBe` Seq.singleton (BtnClick 2) + + where + wenv = mockWenv () + zstackNode = zstack [ + button "Click 1" (BtnClick 1), + button "Click 2" (BtnClick 2), + button "Click 3" (BtnClick 3) `nodeVisible` False + ] + clickEvts p = nodeHandleEventEvts wenv [evtClick p] zstackNode + +handleEventAllLayersActive :: Spec +handleEventAllLayersActive = describe "handleEventAllLayersActive" $ do + it "should not generate an event if clicked outside" $ + clickEvts (Point 3000 3000) `shouldBe` Seq.empty + + it "should click the first layer, since top is not visible and second does not have widgets in that location" $ + clickEvts (Point 200 15) `shouldBe` Seq.singleton (BtnClick 1) + + where + wenv = mockWenv () + zstackNode = zstack_ [onlyTopActive False] [ + button "Click 1" (BtnClick 1), + vstack [ + button "Click 2" (BtnClick 2) `styleBasic` [height 10] + ], + button "Click 3" (BtnClick 3) `nodeVisible` False + ] + clickEvts p = nodeHandleEventEvts wenv [evtClick p] zstackNode + +handleEventFocusTop :: Spec +handleEventFocusTop = describe "handleEventFocusTop" $ + it "should not attempt to set focus on lower layers" $ do + let steps = [evtK keyTab, evtK keyTab, evtT "abc"] + model steps ^. textValue1 `shouldBe` "" + model steps ^. textValue2 `shouldBe` "abc" + + where + wenv = mockWenvEvtUnit (TestModel "" "") + zstackNode = zstack [ + textField textValue1, + textField textValue2 + ] + model es = nodeHandleEventModel wenv es zstackNode + +handleEventFocusAll :: Spec +handleEventFocusAll = describe "handleEventFocusAll" $ + it "should set focus on second layer, since it's enabled" $ do + let steps = [evtK keyTab, evtT "abc"] + model steps ^. textValue1 `shouldBe` "abc" + model steps ^. textValue2 `shouldBe` "" + + where + wenv = mockWenvEvtUnit (TestModel "" "") + zstackNode = zstack_ [onlyTopActive False] [ + textField textValue1, + textField textValue2 + ] + model es = nodeHandleEventModel wenv es zstackNode + +handleEventFocusChange :: Spec +handleEventFocusChange = describe "handleEventFocusChange" $ + it "should restore focus when switching between layers" $ do + let steps = [ evtK keyTab, evtK keyReturn, evtK keyTab, evtK keyReturn, evtK keyReturn, evtK keyReturn ] + evts steps `shouldBe` Seq.fromList [BtnClick 2, BtnClick 4, BtnClick 2, BtnClick 4] + + where + wenv = mockWenv 10 + handleEvent + :: WidgetEnv Int BtnEvent + -> WidgetNode Int BtnEvent + -> Int + -> BtnEvent + -> [EventResponse Int BtnEvent Int BtnEvent] + handleEvent wenv _ model (BtnClick idx) = [Report (BtnClick idx), Model idx] + buildUI wenv model = zstack [ + hstack [ + button "3" (BtnClick 3), + button "4" (BtnClick 4) + ], + hstack [ + button "1" (BtnClick 1), + button "2" (BtnClick 2) + ] `nodeVisible` (model > 2) + ] + cmpNode = composite "main" id buildUI handleEvent + evts es = nodeHandleEventEvts wenv es cmpNode + +handleEventFocusKeep :: Spec +handleEventFocusKeep = describe "handleEventFocusKeep" $ + it "should not restore focus when switching between layers if a focus change request is detected" $ do + let steps = [ evtK keyTab, evtK keyReturn, evtK keyTab, evtK keyReturn, evtK keyReturn, evtK keyReturn ] + evts steps `shouldBe` Seq.fromList [BtnClick 2, BtnClick 4, BtnClick 2, BtnClick 3] + + where + wenv = mockWenv 10 + handleEvent + :: WidgetEnv Int BtnEvent + -> WidgetNode Int BtnEvent + -> Int + -> BtnEvent + -> [EventResponse Int BtnEvent Int BtnEvent] + handleEvent wenv _ model (BtnClick idx) = [Report (BtnClick idx), Model idx] + buildUI wenv model = zstack [ + hstack [ + confirmMsg "Message" (BtnClick 3) (BtnClick 4) + ] `nodeVisible` (model <= 2), + hstack [ + button "1" (BtnClick 1), + button "2" (BtnClick 2) + ] `nodeVisible` (model > 2) + ] + cmpNode = composite "main" id buildUI handleEvent + evts es = nodeHandleEventEvts wenv es cmpNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + getSizeReqEmpty + getSizeReqItems + getSizeReqItemsFixed + +getSizeReqEmpty :: Spec +getSizeReqEmpty = describe "empty" $ do + it "should return width = Fixed 0" $ + sizeReqW `shouldBe` fixedSize 0 + + it "should return height = Fixed 0" $ + sizeReqH `shouldBe` fixedSize 0 + + where + wenv = mockWenv () + zstackNode = zstack [] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv zstackNode + +getSizeReqItems :: Spec +getSizeReqItems = describe "several items, horizontal" $ do + it "should return width = Fixed 130" $ + sizeReqW `shouldBe` fixedSize 130 + + it "should return height = Fixed 60" $ + sizeReqH `shouldBe` fixedSize 60 + + where + wenv = mockWenv () + zstackNode = zstack [ + vstack [ + label "Label a1" + ], + vstack [ + label "Long label b1", + label "Long label b2" + ], + vstack [ + label "Label c1", + label "Label c2", + label "Label c3" + ] + ] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv zstackNode + +getSizeReqItemsFixed :: Spec +getSizeReqItemsFixed = describe "several items, horizontal" $ do + it "should return width = Fixed 300" $ + sizeReqW `shouldBe` fixedSize 300 + + it "should return height = Fixed 40" $ + sizeReqH `shouldBe` fixedSize 40 + + where + wenv = mockWenv () + zstackNode = zstack [ + vstack [ + label "Label a1", + label "Label a2" + ], + vstack [ + label "Long b1", + label "Long b2" + ] `styleBasic` [width 300] + ] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv zstackNode + +resize :: Spec +resize = describe "resize" $ do + resizeEmpty + resizeItems + +resizeEmpty :: Spec +resizeEmpty = describe "empty" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should not have children" $ + children `shouldSatisfy` Seq.null + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + zstackNode = zstack [] + newNode = nodeInit wenv zstackNode + viewport = newNode ^. L.info . L.viewport + children = newNode ^. L.children + +resizeItems :: Spec +resizeItems = describe "several items, horizontal" $ do + it "should have the provided viewport size" $ + viewport `shouldBe` vp + + it "should assign the same viewport size to each children" $ + childrenRa `shouldBe` Seq.fromList [vp, vp, vp] + + where + wenv = mockWenv () + vp = Rect 0 0 640 480 + zstackNode = zstack [ + label "Label 1", + label "Label Number Two", + label "Label 3" + ] + newNode = nodeInit wenv zstackNode + viewport = newNode ^. L.info . L.viewport + childrenRa = (^. L.info . L.viewport) <$> newNode ^. L.children diff --git a/test/unit/Monomer/Widgets/Singles/ButtonSpec.hs b/test/unit/Monomer/Widgets/Singles/ButtonSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/ButtonSpec.hs @@ -0,0 +1,96 @@ +{-| +Module : Monomer.Widgets.Singles.ButtonSpec +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 Button widget. +-} +module Monomer.Widgets.Singles.ButtonSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Singles.Button + +import qualified Monomer.Lens as L + +data BtnEvent + = BtnClick + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +spec :: Spec +spec = describe "Button" $ do + handleEvent + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not generate an event if clicked outside" $ + clickEvts (Point 3000 3000) `shouldBe` Seq.empty + + it "should generate a user provided event when clicked" $ + clickEvts (Point 100 100) `shouldBe` Seq.singleton BtnClick + + it "should generate a user provided event when Enter/Space is pressed" $ + keyEvts keyReturn `shouldBe` Seq.singleton BtnClick + + it "should generate an event when focus is received" $ + events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv () + btnNode = button_ "Click" BtnClick [onFocus GotFocus, onBlur LostFocus] + clickEvts p = nodeHandleEventEvts wenv [evtClick p] btnNode + keyEvts key = nodeHandleEventEvts wenv [KeyAction def key KeyPressed] btnNode + events evt = nodeHandleEventEvts wenv [evt] btnNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + describe "fixed" $ do + it "should return width = Fixed 50" $ + sizeReqW1 `shouldBe` fixedSize 50 + + it "should return height = Fixed 20" $ + sizeReqH1 `shouldBe` fixedSize 20 + + describe "flex" $ do + it "should return width = Flex 70 1" $ + sizeReqW2 `shouldBe` flexSize 70 1 + + it "should return height = Flex 20 2" $ + sizeReqH2 `shouldBe` flexSize 20 2 + + describe "multi" $ do + it "should return width = Fixed 50" $ + sizeReqW3 `shouldBe` fixedSize 50 + + it "should return height = Flex 60 1" $ + sizeReqH3 `shouldBe` flexSize 60 1 + + where + wenv = mockWenv () + btnNode1 = button "Click" BtnClick + btnNode2 = button_ "Click 2" BtnClick [resizeFactorW 1, resizeFactorH 2] + btnNode3 = button_ "Line line line" BtnClick [multiline, trimSpaces] `styleBasic` [width 50] + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv btnNode1 + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv btnNode2 + (sizeReqW3, sizeReqH3) = nodeGetSizeReq wenv btnNode3 diff --git a/test/unit/Monomer/Widgets/Singles/CheckboxSpec.hs b/test/unit/Monomer/Widgets/Singles/CheckboxSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/CheckboxSpec.hs @@ -0,0 +1,110 @@ +{-| +Module : Monomer.Widgets.Singles.CheckboxSpec +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 Checkbox widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.CheckboxSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Singles.Checkbox + +import qualified Monomer.Lens as L + +data TestEvt + = BoolSel Bool + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmTestBool :: Bool +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Checkbox" $ do + handleEvent + handleEventValue + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not update the model if not clicked" $ + clickModel (Point 3000 3000) ^. testBool `shouldBe` False + + it "should update the model when clicked" $ + clickModel (Point 100 100) ^. testBool `shouldBe` True + + it "should update the model when Enter/Space is pressed" $ + keyModel keyReturn ^. testBool `shouldBe` True + + it "should generate an event when focus is received" $ + events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel False) + chkNode = checkbox_ testBool [onFocus GotFocus, onBlur LostFocus] + clickModel p = nodeHandleEventModel wenv [evtClick p] chkNode + keyModel key = nodeHandleEventModel wenv [KeyAction def key KeyPressed] chkNode + events evt = nodeHandleEventEvts wenv [evt] chkNode + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + it "should not generate an event if clicked outside" $ + clickModel (Point 3000 3000) chkNode `shouldBe` Seq.empty + + it "should generate a user provided event when clicked" $ + clickModel (Point 100 100) chkNode `shouldBe` Seq.singleton (BoolSel True) + + it "should generate a user provided event when clicked (True -> False)" $ + clickModel (Point 100 100) chkNodeT `shouldBe` Seq.singleton (BoolSel False) + + it "should generate a user provided event when Enter/Space is pressed" $ + keyModel keyReturn chkNode `shouldBe` Seq.singleton (BoolSel True) + + where + wenv = mockWenv (TestModel False) + chkNode = checkboxV False BoolSel + chkNodeT = checkboxV True BoolSel + clickModel p node = nodeHandleEventEvts wenv [evtClick p] node + keyModel key node = nodeHandleEventEvts wenv [KeyAction def key KeyPressed] node + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 20" $ + sizeReqW `shouldBe` fixedSize 20 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (TestModel False) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (checkbox testBool) diff --git a/test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs b/test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs @@ -0,0 +1,96 @@ +{-| +Module : Monomer.Widgets.Singles.ColorPickerSpec +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 ColorPicker widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.ColorPickerSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Singles.ColorPicker + +import qualified Monomer.Lens as L + +data PickerEvent + = ColorChanged Color + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmColor :: Color +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "ColorPicker" $ do + handleEvent + handleEventV + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should update the model" $ + model (Point 306 10) ^. color `shouldBe` rgb 127 0 0 + + it "should generate an event when focus is received" $ + events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel (rgb 0 0 0)) + pckNode = colorPicker_ color [onFocus GotFocus, onBlur LostFocus] + model p = nodeHandleEventModel wenv [evtRelease p] pckNode + events evt = nodeHandleEventEvts wenv [evt] pckNode + +handleEventV :: Spec +handleEventV = describe "handleEventV" $ do + it "should generante a change event" $ + events (evtRelease (Point 453 30)) `shouldBe` Seq.singleton (ColorChanged (rgb 0 200 0)) + + it "should generate an event when focus is received" $ + events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel (rgb 0 0 0)) + pckNode = colorPickerV_ (rgb 0 0 0) ColorChanged [onFocus GotFocus, onBlur LostFocus] + events evt = nodeHandleEventEvts wenv [evt] pckNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Range 126 1126" $ + sizeReqW `shouldBe` rangeSize 126 1126 1 + + it "should return height = Fixed 64" $ + sizeReqH `shouldBe` fixedSize 64 + + where + wenv = mockWenvEvtUnit (TestModel (rgb 0 0 0)) + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (colorPicker color) diff --git a/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs @@ -0,0 +1,284 @@ +{-| +Module : Monomer.Widgets.Singles.DateFieldSpec +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 DateField widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.DateFieldSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Data.Time +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.DateField + +import qualified Monomer.Lens as L + +data TestEvt + = DateChanged Day + | DateValid Bool + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +data DateModel = DateModel { + _imDateValue :: Day, + _imDateValid :: Bool +} deriving (Eq, Show) + +instance Default DateModel where + def = DateModel { + _imDateValue = fromGregorian 2000 01 01, + _imDateValid = True + } + +data MDateModel = MDateModel { + _imMDateValue :: Maybe Day, + _imMDateValid :: Bool +} deriving (Eq, Show) + +instance Default MDateModel where + def = MDateModel { + _imMDateValue = Nothing, + _imMDateValid = True + } + +makeLensesWith abbreviatedFields ''DateModel +makeLensesWith abbreviatedFields ''MDateModel + +spec :: Spec +spec = describe "DateField" $ do + handleEventDate + handleEventValueDate + handleEventMouseDragDate + handleShiftFocus + getSizeReqDate + +handleEventDate :: Spec +handleEventDate = describe "handleEventDate" $ do + it "should remove the contents and get Nothing as model value" $ do + modelBasic [evtKG keyA, evtK keyBackspace] ^. mDateValue `shouldBe` Nothing + modelBasic [evtKG keyA, evtK keyBackspace] ^. mDateValid `shouldBe` True + + it "should input '2000-02-14'" $ do + modelBasic [evtKG keyA, evtT "2000", evtT "-02-14"] ^. mDateValue `shouldBe` Just (fromGregorian 2000 02 14) + modelBasic [evtKG keyA, evtT "2000", evtT "-02-14"] ^. mDateValid `shouldBe` True + + it "should input '1' (invalid date)" $ do + model [evtKG keyA, evtT "1"] ^. mDateValue `shouldBe` Just midDate + model [evtKG keyA, evtT "1"] ^. mDateValid `shouldBe` False + events [evtKG keyA, evtT "1"] `shouldBe` Seq.fromList [DateValid False] + + it "should input '30/12/1999' but fail because of minValue" $ do + model [evtT "30/12/1999"] ^. mDateValue `shouldBe` Just midDate + model [evtT "30/12/1999"] ^. mDateValid `shouldBe` False + events [evtT "30/12/1999"] `shouldBe` Seq.fromList [DateValid False] + + it "should input '01/03/2005' but fail because of maxValue" $ do + model [evtT "01/04/2005"] ^. mDateValue `shouldBe` Just midDate + model [evtT "01/04/2005"] ^. mDateValid `shouldBe` False + events [evtT "01/04/2005"] `shouldBe` Seq.fromList [DateValid False] + + it "should remove one character and input '4'" $ do + model [moveCharR, delCharL, evtT "4"] ^. mDateValue `shouldBe` Just (fromGregorian 2004 03 02) + model [moveCharR, delCharL, evtT "4"] ^. mDateValid `shouldBe` True + events [moveCharR, delCharL, evtT "4"] `shouldBe` Seq.fromList [DateValid False, DateValid True] + + it "should input '14/02/2001', remove one word and input '2000'" $ do + model [evtT "14/02/2001", delWordL, evtT "2000"] ^. mDateValue `shouldBe` Just (fromGregorian 2000 02 14) + model [evtT "14/02/2001", delWordL, evtT "2000"] ^. mDateValid `shouldBe` True + events [evtT "14/02/2001", delWordL, evtT "2000"] `shouldBe` Seq.fromList [DateValid True, DateValid False, DateValid True] + + it "should update the model when using the wheel" $ do + let p = Point 100 10 + let steps1 = [WheelScroll p (Point 0 (-2000)) WheelNormal] + let steps2 = [WheelScroll p (Point 0 (-64)) WheelNormal] + let steps3 = [WheelScroll p (Point 0 64) WheelNormal] + let steps4 = [WheelScroll p (Point 0 (-2000)) WheelFlipped] + model steps1 ^. mDateValue `shouldBe` Just minDate + model steps2 ^. mDateValue `shouldBe` Just (fromGregorian 2001 12 28) + model steps3 ^. mDateValue `shouldBe` Just (fromGregorian 2002 05 05) + model steps4 ^. mDateValue `shouldBe` Just maxDate + + it "should generate an event when focus is received" $ + events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + minDate = fromGregorian 2000 01 01 + midDate = fromGregorian 2002 03 02 + maxDate = fromGregorian 2005 03 05 + wenv = mockWenv (MDateModel (Just midDate) True) + basicDateNode :: WidgetNode MDateModel TestEvt + basicDateNode = dateField_ mDateValue [validInput mDateValid, selectOnFocus_ False, dateFormatYYYYMMDD, dateFormatDelimiter '-'] + dateCfg = [minValue (Just minDate), maxValue (Just maxDate), validInput mDateValid, validInputV DateValid, onFocus GotFocus, onBlur LostFocus] + dateNode = dateField_ mDateValue dateCfg + model es = nodeHandleEventModel wenv (evtFocus : es) dateNode + modelBasic es = nodeHandleEventModel wenv es basicDateNode + events es = nodeHandleEventEvts wenv es dateNode + +handleEventValueDate :: Spec +handleEventValueDate = describe "handleEventDate" $ do + it "should input an '11/23/1983'" $ + evts [evtT "11/23/1983"] `shouldBe` Seq.fromList [DateChanged lowDate] + + it "should move right, delete one character and input '5'" $ do + let steps = [moveCharR, delCharL, evtT "5"] + lastEvt steps `shouldBe` DateChanged (fromGregorian 1985 03 02) + model steps ^. dateValid `shouldBe` True + + it "should move right and delete one character" $ do + let steps = [moveCharR, delCharL] + evts steps `shouldBe` Seq.empty + model steps ^. dateValid `shouldBe` False + + it "should input '11/23/198', input '.', 'a', then input '3'" $ do + let steps = [evtT "11/23/198", evtT ".", evtT "a", evtT "3"] + lastEvt steps `shouldBe` DateChanged lowDate + model steps ^. dateValid `shouldBe` True + + it "should input '03/0544/199555'" $ do + let steps = [evtT "03", evtT "/05", evtT "44", evtT "/1995", evtT "55"] + lastEvt steps `shouldBe` DateChanged maxDate + + where + minDate = fromGregorian 1980 01 01 + lowDate = fromGregorian 1983 11 23 + midDate = fromGregorian 1989 03 02 + maxDate = fromGregorian 1995 03 05 + wenv = mockWenv (DateModel minDate False) + dateNode = dateFieldV_ midDate DateChanged [minValue minDate, maxValue maxDate, selectOnFocus, validInput dateValid, dateFormatMMDDYYYY] + evts es = nodeHandleEventEvts wenv (evtFocus : es) dateNode + model es = nodeHandleEventModel wenv (evtFocus : es) dateNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleEventMouseDragDate :: Spec +handleEventMouseDragDate = describe "handleEventMouseDragDate" $ do + it "should drag upwards 100 pixels, setting the value to 10/06/1989" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` fromGregorian 1989 06 10 + + it "should drag downwards 100 pixels, setting the value to 14/08/1988 (dragRate = 2)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 150 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` fromGregorian 1988 08 14 + + it "should drag downwards 10000 pixels, staying at minDate (the minimum)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 10050 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` minDate + + it "should drag upwnwards 10000 pixels, staying at maxDate (the maximum)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 (-1950) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` maxDate + + it "should drag downwards 30 and 20 pixels, setting the value to 11/01/1989" $ do + let selStart = Point 50 30 + let selMid = Point 50 60 + let selEnd = Point 50 50 + let steps = [ + evtPress selStart, evtMove selMid, evtRelease selMid, + evtPress selStart, evtMove selEnd, evtRelease selEnd + ] + model steps ^. dateValue `shouldBe` fromGregorian 1989 01 11 + + it "should set focus and drag upwards 100 pixels, but value stay at midDate since shift is not pressed" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtK keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` midDate + + it "should set focus and drag upwards 100 pixels, setting the value to 10/06/1989 since shift is pressed" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtKS keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` fromGregorian 1989 06 10 + + it "should drag upwards 100 pixels, setting the value to 10/06/1989 even if it was double clicked on" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtDblClick selStart, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. dateValue `shouldBe` fromGregorian 1989 06 10 + + where + minDate = fromGregorian 1980 01 01 + midDate = fromGregorian 1989 03 02 + maxDate = fromGregorian 1995 03 05 + wenv = mockWenv (DateModel midDate True) + & L.inputStatus . L.keyMod . L.leftShift .~ True + dateNode = vstack [ + button "Test" (DateChanged midDate), -- Used only to have focus + dateField dateValue, + dateField_ dateValue [dragRate 2, minValue minDate, maxValue maxDate] + ] + evts es = nodeHandleEventEvts wenv es dateNode + model es = nodeHandleEventModel wenv es dateNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleShiftFocus :: Spec +handleShiftFocus = describe "handleShiftFocus" $ do + it "should set focus when clicked" $ do + evts [evtPress p] `shouldBe` Seq.fromList [GotFocus $ Seq.fromList [0, 0]] + + it "should not set focus when clicked with shift pressed" $ do + evts [evtKS keyA, evtPress p] `shouldBe` Seq.empty + + where + wenv = mockWenv (DateModel (fromGregorian 1989 03 02) True) + p = Point 100 30 + floatNode = vstack [ + dateField_ dateValue [wheelRate 1], + dateField_ dateValue [wheelRate 1, onFocus GotFocus] + ] + evts es = nodeHandleEventEvts wenv es floatNode + +getSizeReqDate :: Spec +getSizeReqDate = describe "getSizeReqDate" $ do + it "should return width = Flex 160 1" $ + sizeReqW `shouldBe` expandSize 160 1 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + it "should return width = Flex 100 1 when resizeOnChange = True" $ + sizeReqW2 `shouldBe` expandSize 100 1 + + it "should return height = Fixed 20 when resizeOnChange = True" $ + sizeReqH2 `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (def :: DateModel) + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (dateField dateValue) + dateResize = dateField_ dateValue [resizeOnChange] + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv dateResize diff --git a/test/unit/Monomer/Widgets/Singles/DialSpec.hs b/test/unit/Monomer/Widgets/Singles/DialSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/DialSpec.hs @@ -0,0 +1,231 @@ +{-| +Module : Monomer.Widgets.Singles.DialSpec +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 Dial widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.DialSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Dial + +import qualified Monomer.Lens as L + +data TestEvt + = DialChanged Double + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmDialVal :: Double +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Dial" $ do + handleKeyboard + handleMouseDrag + handleMouseDragVal + handleWheel + handleWheelVal + handleShiftFocus + getSizeReq + +handleKeyboard :: Spec +handleKeyboard = describe "handleKeyboard" $ do + it "should press arrow up ten times and set the dial value to 20" $ do + let steps = replicate 10 (evtK keyUp) + model steps ^. dialVal `shouldBe` 20 + + it "should press arrow up + shift ten times and set the dial value to 2" $ do + let steps = replicate 10 (evtKS keyUp) + model steps ^. dialVal `shouldBe` 2 + + it "should press arrow up + ctrl four times and set the dial value to 80" $ do + let steps = replicate 4 (evtKG keyUp) + model steps ^. dialVal `shouldBe` 80 + + it "should press arrow down ten times and set the dial value to -20" $ do + let steps = replicate 10 (evtK keyDown) + model steps ^. dialVal `shouldBe` (-20) + + it "should press arrow down + shift five times and set the dial value to 1" $ do + let steps = replicate 5 (evtKS keyDown) + model steps ^. dialVal `shouldBe` -1 + + it "should press arrow up + ctrl one time and set the dial value to -20" $ do + let steps = [evtKG keyDown] + model steps ^. dialVal `shouldBe` (-20) + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + dialNode = dial dialVal (-100) 100 + model es = nodeHandleEventModel wenv es dialNode + +handleMouseDrag :: Spec +handleMouseDrag = describe "handleMouseDrag" $ do + it "should not change the value when dragging off bounds" $ do + let selStart = Point 0 0 + let selEnd = Point 0 100 + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 0 + + it "should not change the value when dragging horizontally" $ do + let selStart = Point 320 240 + let selEnd = Point 500 240 + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 0 + + it "should drag 100 pixels up and set the dial value to 20" $ do + let selStart = Point 320 240 + let selEnd = Point 320 140 + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 20 + + it "should drag 500 pixels up and set the dial value 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-260) + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 100 + + it "should drag 1000 pixels up, but stay on 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-760) + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 100 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + dialNode = dial dialVal (-100) 100 + model es = nodeHandleEventModel wenv es dialNode + +handleMouseDragVal :: Spec +handleMouseDragVal = describe "handleMouseDragVal" $ do + it "should not change the value when dragging off bounds" $ do + let selStart = Point 0 0 + let selEnd = Point 0 100 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [] + + it "should not change the value when dragging horizontally" $ do + let selStart = Point 320 240 + let selEnd = Point 500 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [] + + it "should drag 100 pixels up and set the dial value to 110" $ do + let selStart = Point 320 240 + let selEnd = Point 320 140 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [DialChanged 110] + + it "should drag 490 pixels up and set the dial value 500" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-250) + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [DialChanged 500] + + it "should drag 1000 pixels up, but stay on 500" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-760) + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [DialChanged 500] + + it "should generate an event when focus is received" $ + evts [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + evts [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + dialNode = dialV_ 10 DialChanged (-500) 500 [dragRate 1, onFocus GotFocus, onBlur LostFocus] + evts es = nodeHandleEventEvts wenv es dialNode + +handleWheel :: Spec +handleWheel = describe "handleWheel" $ do + it "should update the model when using the wheel" $ do + let p = Point 320 240 + let steps = [WheelScroll p (Point 0 100) WheelNormal] + model steps ^. dialVal `shouldBe` 300 + + where + wenv = mockWenvEvtUnit (TestModel 200) + & L.theme .~ darkTheme + dialNode = dial_ dialVal (-500) 500 [wheelRate 1] + model es = nodeHandleEventModel wenv es dialNode + +handleWheelVal :: Spec +handleWheelVal = describe "handleWheelVal" $ do + it "should update the model when using the wheel" $ do + let p = Point 320 240 + let steps = [WheelScroll p (Point 0 (-200)) WheelNormal] + evts steps `shouldBe` Seq.singleton (DialChanged (-200)) + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + dialNode = dialV_ 0 DialChanged (-500) 500 [wheelRate 1] + evts es = nodeHandleEventEvts wenv es dialNode + +handleShiftFocus :: Spec +handleShiftFocus = describe "handleShiftFocus" $ do + it "should set focus when clicked" $ do + evts [evtPress p] `shouldBe` Seq.fromList [GotFocus $ Seq.fromList [0, 0, 0]] + + it "should not set focus when clicked with shift pressed" $ do + evts [evtKS keyA, evtPress p] `shouldBe` Seq.empty + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + p = Point 25 50 + dialNode = hstack [ + vstack [ + dial_ dialVal (-500) 500 [wheelRate 1], + dial_ dialVal (-500) 500 [wheelRate 1, onFocus GotFocus] + ] + ] + evts es = nodeHandleEventEvts wenv es dialNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 50" $ + sizeReqW `shouldBe` fixedSize 50 + + it "should return height = Fixed 50" $ + sizeReqH `shouldBe` fixedSize 50 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (dial dialVal 0 100) diff --git a/test/unit/Monomer/Widgets/Singles/ExternalLinkSpec.hs b/test/unit/Monomer/Widgets/Singles/ExternalLinkSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/ExternalLinkSpec.hs @@ -0,0 +1,68 @@ +{-| +Module : Monomer.Widgets.Singles.ExternalLinkSpec +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 ExternalLink widget. +-} +module Monomer.Widgets.Singles.ExternalLinkSpec (spec) where + +import Data.Default +import Test.Hspec + +import qualified Data.Sequence as Seq +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Singles.ExternalLink + +data TestEvent + = GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +spec :: Spec +spec = describe "ExternalLink" $ do + handleEvent + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not generate an event if clicked outside" $ + clickReqs (Point 3000 3000) `shouldBe` Seq.empty + + it "should generate a widget task when clicked" $ + Seq.index (clickReqs (Point 100 100)) 0 `shouldSatisfy` isRunTask + + it "should generate a user provided event when Enter/Space is pressed" $ + Seq.index (keyReqs keyReturn) 0 `shouldSatisfy` isRunTask + + it "should generate an event when focus is received" $ + events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv () + btnNode = externalLink_ "Link" "Url" [onFocus GotFocus, onBlur LostFocus] + clickReqs p = nodeHandleEventReqs wenv [evtClick p] btnNode + keyReqs key = nodeHandleEventReqs wenv [KeyAction def key KeyPressed] btnNode + events evt = nodeHandleEventEvts wenv [evt] btnNode + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 40" $ + sizeReqW `shouldBe` fixedSize 40 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit () + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (externalLink "Link" "Url") diff --git a/test/unit/Monomer/Widgets/Singles/ImageSpec.hs b/test/unit/Monomer/Widgets/Singles/ImageSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/ImageSpec.hs @@ -0,0 +1,66 @@ +{-| +Module : Monomer.Widgets.Singles.ImageSpec +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 Image widget. +-} +module Monomer.Widgets.Singles.ImageSpec (spec) where + +import Control.Lens ((&), (^.), (.~), _2) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Event +import Monomer.TestUtil +import Monomer.Widgets.Singles.Image + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Image" + initMergeWidget + +initMergeWidget :: Spec +initMergeWidget = describe "init/merge" $ do + it "should create a RunTask on init" $ do + Seq.length reqs1 `shouldBe` 1 + Seq.index reqs1 0 `shouldSatisfy` isRunTask + + it "should not create a task when merging to the same path" $ + Seq.length reqs2 `shouldBe` 0 + + it "should create a task when merging to a different path" $ do + Seq.length reqs3 `shouldBe` 2 + Seq.index reqs3 0 `shouldSatisfy` isRemoveRendererImage + Seq.index reqs3 1 `shouldSatisfy` isRunTask + + it "should have one widgetId on init (loading)" $ + ctx1 ^. L.widgetPaths `shouldSatisfy` (== 1) . length + + it "should not have any widgetId on merge with the same image (not loading)" $ + ctx2 ^. L.widgetPaths `shouldSatisfy` null + + it "should have one widgetId on merge with a different image (loading)" $ + ctx3 ^. L.widgetPaths `shouldSatisfy` (== 1) . length + + where + wenv = mockWenvEvtUnit () + node1 = image "assets/images/beach.jpg" + node2 = image "assets/images/beach.jpg" + node3 = image "assets/images/beach2.jpg" + initRes = widgetInit (node1 ^. L.widget) wenv node1 + WidgetResult newNode1 reqs1 = initRes + mergeRes1 = widgetMerge (node2 ^. L.widget) wenv node2 newNode1 + WidgetResult _ reqs2 = mergeRes1 + mergeRes2 = widgetMerge (node3 ^. L.widget) wenv node3 newNode1 + WidgetResult _ reqs3 = mergeRes2 + ctx1 = nodeHandleResult wenv initRes ^. _2 + ctx2 = nodeHandleResult wenv mergeRes1 ^. _2 + ctx3 = nodeHandleResult wenv mergeRes2 ^. _2 diff --git a/test/unit/Monomer/Widgets/Singles/LabelSpec.hs b/test/unit/Monomer/Widgets/Singles/LabelSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/LabelSpec.hs @@ -0,0 +1,154 @@ +{-| +Module : Monomer.Widgets.Singles.LabelSpec +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 Label widget. +-} +module Monomer.Widgets.Singles.LabelSpec (spec) where + +import Control.Lens ((&), (^.), (^?!), (.~), ix) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics +import Monomer.TestUtil +import Monomer.Widgets.Singles.Label + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Label" $ do + getSizeReq + getSizeReqMulti + getSizeReqMultiKeepSpaces + getSizeReqMultiMaxLines + getSizeReqMerge + resize + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 100" $ + sizeReqW `shouldBe` fixedSize 100 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + it "should return width = Flex 120 1" $ + sizeReq2W `shouldBe` flexSize 120 1 + + it "should return height = Flex 20 2" $ + sizeReq2H `shouldBe` flexSize 20 2 + + it "should return width = Flex 120 1" $ + sizeReq3W `shouldBe` flexSize 120 0.01 + + it "should return height = Flex 20 2" $ + sizeReq3H `shouldBe` flexSize 20 0.01 + + where + wenv = mockWenv () + lblNode = label "Test label" + lblNode2 = label_ "Test label 2" [resizeFactorW 1, resizeFactorH 2] + lblNode3 = label_ "Test label 3" [ellipsis] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv lblNode + (sizeReq2W, sizeReq2H) = nodeGetSizeReq wenv lblNode2 + (sizeReq3W, sizeReq3H) = nodeGetSizeReq wenv lblNode3 + +getSizeReqMulti :: Spec +getSizeReqMulti = describe "getSizeReq" $ do + it "should return width = Fixed 50" $ + sizeReqW `shouldBe` fixedSize 50 + + it "should return height = Flex 60 1" $ + sizeReqH `shouldBe` flexSize 60 1 + + where + wenv = mockWenv () + lblNode = label_ "Line line line" [multiline, trimSpaces] `styleBasic` [width 50] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv lblNode + +getSizeReqMultiKeepSpaces :: Spec +getSizeReqMultiKeepSpaces = describe "getSizeReq" $ do + it "should return width = Max 50 1" $ + sizeReqW `shouldBe` maxSize 50 1 + + it "should return height = Flex 100 1" $ + sizeReqH `shouldBe` flexSize 100 1 + + where + wenv = mockWenv () + caption = "Line line line" + lblNode = label_ caption [multiline, trimSpaces_ False] `styleBasic` [maxWidth 50] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv lblNode + +getSizeReqMultiMaxLines :: Spec +getSizeReqMultiMaxLines = describe "getSizeReq" $ do + it "should return width = Max 50 1" $ + sizeReqW `shouldBe` maxSize 50 1 + + it "should return height = Flex 80 1" $ + sizeReqH `shouldBe` flexSize 80 1 + + where + wenv = mockWenv () + caption = "Line line line line line" + lblNode = label_ caption [multiline, trimSpaces_ False, maxLines 4] `styleBasic` [maxWidth 50] + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv lblNode + +getSizeReqMerge :: Spec +getSizeReqMerge = describe "getSizeReqMerge" $ do + it "should return width = Fixed 320" $ + sizeReqW `shouldBe` fixedSize 320 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + it "should return width = Fixed 600" $ + sizeReq2W `shouldBe` fixedSize 600 + + it "should return height = Fixed 20" $ + sizeReq2H `shouldBe` fixedSize 20 + + where + fontMgr = mockFontManager { + computeGlyphsPos = mockGlyphsPos Nothing + } + wenv = mockWenvEvtUnit () + & L.fontManager .~ fontMgr + lblNode = nodeInit wenv (label "Test Label") + lblNode2 = label "Test Label" `styleBasic` [textSize 60] + lblRes = widgetMerge (lblNode2 ^. L.widget) wenv lblNode2 lblNode + WidgetResult lblMerged _ = lblRes + lblInfo = lblNode ^. L.info + mrgInfo = lblMerged ^. L.info + (sizeReqW, sizeReqH) = (lblInfo ^. L.sizeReqW, lblInfo ^. L.sizeReqH) + (sizeReq2W, sizeReq2H) = (mrgInfo ^. L.sizeReqW, mrgInfo ^. L.sizeReqH) + +resize :: Spec +resize = describe "resize" $ do + it "should resize single line in a single step" $ + reqsSingle `shouldBe` Seq.Empty + + it "should resize multi line in two steps" $ + reqsMulti ^?! ix 0 `shouldSatisfy` isResizeWidgets + + where + wenv = mockWenvEvtUnit () + vp = Rect 0 0 640 480 + single = label "Test label" + resizeCheck = const True + resSingle = widgetResize (single ^. L.widget) wenv single vp resizeCheck + reqsSingle = resSingle ^. L.requests + multi = label_ "Test label" [multiline] + resMulti = widgetResize (multi ^. L.widget) wenv multi vp resizeCheck + reqsMulti = resMulti ^. L.requests diff --git a/test/unit/Monomer/Widgets/Singles/LabeledCheckboxSpec.hs b/test/unit/Monomer/Widgets/Singles/LabeledCheckboxSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/LabeledCheckboxSpec.hs @@ -0,0 +1,122 @@ +{-| +Module : Monomer.Widgets.Singles.LabeledCheckboxSpec +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 labeledCheckbox widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.LabeledCheckboxSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Singles.LabeledCheckbox + +import qualified Monomer.Lens as L + +data TestEvt + = BoolSel Bool + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmTestBool :: Bool +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Labeled Checkbox" $ do + handleEvent + handleEventValue + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not update the model if not clicked" $ + clickModel (Point 3000 3000) ^. testBool `shouldBe` False + + it "should update the model when clicked on the label" $ + clickModel (Point 10 10) ^. testBool `shouldBe` True + + it "should not update the model when clicked on the spacer" $ + clickModel (Point 42 10) ^. testBool `shouldBe` False + + it "should update the model when clicked on the checkbox" $ + clickModel (Point 50 10) ^. testBool `shouldBe` True + + it "should update the model when Enter/Space is pressed" $ + keyModel keyReturn ^. testBool `shouldBe` True + + it "should generate an event when focus is received" $ + events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel False) + chkNode = labeledCheckbox_ "Test" testBool [onFocus GotFocus, onBlur LostFocus] + clickModel p = nodeHandleEventModel wenv [evtClick p] chkNode + keyModel key = nodeHandleEventModel wenv [KeyAction def key KeyPressed] chkNode + events evt = nodeHandleEventEvts wenv [evt] chkNode + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + it "should not generate an event if clicked outside" $ + clickModel (Point 3000 3000) chkNode `shouldBe` Seq.empty + + it "should generate a user provided event when clicked on the label" $ + clickModel (Point 10 10) chkNode `shouldBe` Seq.singleton (BoolSel True) + + it "should not generate a user provided event when clicked on the spacer" $ + clickModel (Point 42 10) chkNode `shouldBe` Seq.empty + + it "should generate a user provided event when clicked on the checkbox" $ + clickModel (Point 50 10) chkNode `shouldBe` Seq.singleton (BoolSel True) + + it "should generate a user provided event when clicked (True -> False)" $ + clickModel (Point 10 10) chkNodeT `shouldBe` Seq.singleton (BoolSel False) + + it "should generate a user provided event when Enter/Space is pressed" $ + keyModel keyReturn chkNode `shouldBe` Seq.singleton (BoolSel True) + + where + wenv = mockWenv (TestModel False) + chkNode = labeledCheckboxV "Test" False BoolSel + chkNodeT = labeledCheckboxV "Test" True BoolSel + clickModel p node = nodeHandleEventEvts wenv [evtClick p] node + keyModel key node = nodeHandleEventEvts wenv [KeyAction def key KeyPressed] node + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 70" $ + sizeReqW `shouldBe` fixedSize 70 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (TestModel False) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (labeledCheckbox "Test" testBool) diff --git a/test/unit/Monomer/Widgets/Singles/LabeledRadioSpec.hs b/test/unit/Monomer/Widgets/Singles/LabeledRadioSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/LabeledRadioSpec.hs @@ -0,0 +1,129 @@ +{-| +Module : Monomer.Widgets.Singles.LabeledRadioSpec +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 labeledRadio widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.LabeledRadioSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Singles.LabeledRadio + +import qualified Monomer.Lens as L + +data Fruit + = Apple + | Orange + | Banana + deriving (Eq, Show) + +data FruitEvt + = FruitSel Fruit + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmFruit :: Fruit +} deriving (Eq) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Labeled Radio" $ do + handleEvent + handleEventValue + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not update the model if not clicked" $ + clickModel (Point 3000 3000) orangeNode ^. fruit `shouldBe` Apple + + it "should update the model when clicked on the label" $ + clickModel (Point 10 240) orangeNode ^. fruit `shouldBe` Orange + + it "should not update the model when clicked on the spacer" $ + clickModel (Point 40 240) orangeNode ^. fruit `shouldBe` Apple + + it "should update the model when clicked on the radio" $ + clickModel (Point 60 240) orangeNode ^. fruit `shouldBe` Orange + + it "should update the model when Enter/Space is pressed" $ + keyModel keyReturn bananaNode ^. fruit `shouldBe` Banana + + it "should generate an event when focus is received" $ + events evtFocus orangeNode `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur orangeNode `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel Apple) + & L.theme .~ darkTheme + orangeNode = labeledRadio_ "Test" Orange fruit [onFocus GotFocus, onBlur LostFocus] + bananaNode :: WidgetNode TestModel FruitEvt + bananaNode = labeledRadio "Test" Banana fruit + 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 + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + it "should not generate an event if clicked outside" $ + clickModel (Point 3000 3000) orangeNode `shouldBe` Seq.empty + + it "should generate a user provided event when clicked on the label" $ + clickModel (Point 10 240) orangeNode `shouldBe` Seq.singleton (FruitSel Orange) + + it "should not generate a user provided event when clicked on the spacer" $ + clickModel (Point 40 240) orangeNode `shouldBe` Seq.empty + + it "should generate a user provided event when clicked on the radio" $ + clickModel (Point 60 240) orangeNode `shouldBe` Seq.singleton (FruitSel Orange) + + it "should generate a user provided event when Enter/Space is pressed" $ + keyModel keyReturn bananaNode `shouldBe` Seq.singleton (FruitSel Banana) + + where + wenv = mockWenv (TestModel Apple) + & L.theme .~ darkTheme + orangeNode = labeledRadioV "Test" Orange Apple FruitSel + bananaNode = labeledRadioV "Test" Banana Apple FruitSel + clickModel p node = nodeHandleEventEvts wenv [evtClick p] node + keyModel key node = nodeHandleEventEvts wenv [KeyAction def key KeyPressed] node + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 70" $ + sizeReqW `shouldBe` fixedSize 70 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (TestModel Apple) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (labeledRadio "Test" Apple fruit) diff --git a/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs @@ -0,0 +1,474 @@ +{-| +Module : Monomer.Widgets.Singles.NumericFieldSpec +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 NumericField widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.NumericFieldSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.NumericField + +import qualified Monomer.Lens as L + +data TestEvt + = IntegralChanged Int + | FractionalChanged (Maybe Double) + | ValidNumber Bool + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +data IntegralModel = IntegralModel { + _imIntegralValue :: Int, + _imIntegralValid :: Bool +} deriving (Eq, Show) + +data FractionalModel = FractionalModel { + _fmFractionalValue :: Maybe Double, + _fmFractionalValid :: Bool +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''IntegralModel +makeLensesWith abbreviatedFields ''FractionalModel + +spec :: Spec +spec = describe "NumericField" $ do + specIntegral + specFractional + +specIntegral :: Spec +specIntegral = describe "IntegralField" $ do + handleEventIntegral + handleEventValueIntegral + handleEventMouseDragIntegral + getSizeReqIntegral + +handleEventIntegral :: Spec +handleEventIntegral = describe "handleEventIntegral" $ do + it "should remove the contents and get Nothing as model value" $ do + modelBasic [evtKG keyA, evtK keyBackspace] ^. integralValue `shouldBe` 0 + modelBasic [evtKG keyA, evtK keyBackspace] ^. integralValid `shouldBe` False + + it "should input '123' without select on focus" $ do + modelBasic [evtT "1", evtT "2", evtT "3"] ^. integralValue `shouldBe` 1230 + modelBasic [evtT "1", evtT "2", evtT "3"] ^. integralValid `shouldBe` True + + it "should input '1'" $ do + model [evtT "1"] ^. integralValue `shouldBe` 1 + model [evtT "1"] ^. integralValid `shouldBe` True + events [evtT "1"] `shouldBe` Seq.fromList [ValidNumber True] + + it "should input '-1'" $ do + model [evtT "-1"] ^. integralValue `shouldBe` -1 + model [evtT "-1"] ^. integralValid `shouldBe` True + events [evtT "-1"] `shouldBe` Seq.fromList [ValidNumber True] + + it "should input '1501'" $ do + model [evtT "1", evtT "5", evtT "0", evtT "1"] ^. integralValue `shouldBe` 1501 + model [evtT "1", evtT "5", evtT "0", evtT "1"] ^. integralValid `shouldBe` True + events [evtT "1", evtT "5", evtT "0", evtT "1"] `shouldBe` Seq.fromList (replicate 4 (ValidNumber True)) + + it "should input '1502', but fail because of maxValue" $ do + model [evtT "1", evtT "5", evtT "0", evtT "2"] ^. integralValue `shouldBe` 150 + model [evtT "1", evtT "5", evtT "0", evtT "2"] ^. integralValid `shouldBe` False + events [evtT "1", evtT "5", evtT "0", evtT "2"] `shouldBe` Seq.fromList (replicate 3 (ValidNumber True) ++ [ValidNumber False]) + + it "should input '123', remove one character and input '4'" $ do + model [evtT "123", delCharL, evtT "4"] ^. integralValue `shouldBe` 124 + model [evtT "123", delCharL, evtT "4"] ^. integralValid `shouldBe` True + events [evtT "123", delCharL, evtT "4"] `shouldBe` Seq.fromList (replicate 3 (ValidNumber True)) + + it "should input '123', remove one word and input '456'" $ do + model [evtT "123", delWordL, evtT "456"] ^. integralValue `shouldBe` 456 + model [evtT "123", delWordL, evtT "456"] ^. integralValid `shouldBe` True + events [evtT "123", delWordL, evtT "456"] `shouldBe` Seq.fromList [ValidNumber True, ValidNumber False, ValidNumber True] + + it "should update the model when using the wheel" $ do + let p = Point 100 10 + let steps1 = [WheelScroll p (Point 0 (-64)) WheelNormal] + let steps2 = [WheelScroll p (Point 0 300) WheelFlipped] + let steps3 = [WheelScroll p (Point 0 100) WheelNormal] + let steps4 = [WheelScroll p (Point 0 2000) WheelNormal] + model steps1 ^. integralValue `shouldBe` -64 + model steps2 ^. integralValue `shouldBe` -200 + model steps3 ^. integralValue `shouldBe` 100 + model steps4 ^. integralValue `shouldBe` 1501 + + it "should generate an event when focus is received" $ + events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (IntegralModel 0 True) + basicIntNode :: WidgetNode IntegralModel TestEvt + basicIntNode = numericField_ integralValue [validInput integralValid, selectOnFocus_ False] + intCfg = [minValue (-200), maxValue 1501, validInput integralValid, validInputV ValidNumber, onFocus GotFocus, onBlur LostFocus] + intNode = numericField_ integralValue intCfg + model es = nodeHandleEventModel wenv (evtFocus : es) intNode + modelBasic es = nodeHandleEventModel wenv es basicIntNode + events es = nodeHandleEventEvts wenv es intNode + +handleEventValueIntegral :: Spec +handleEventValueIntegral = describe "handleEventIntegral" $ do + it "should input an '10'" $ + evts [evtT "1", evtT "0"] `shouldBe` Seq.fromList [IntegralChanged 1, IntegralChanged 10] + + it "should input '1', move to beginning and input '5'" $ do + let steps = [evtT "1", moveLineL, evtT "5"] + lastEvt steps `shouldBe` IntegralChanged 51 + + it "should input '1', input '.' then input '5'" $ do + let steps = [evtT "1", evtT ".", evtT "5"] + lastEvt steps `shouldBe` IntegralChanged 15 + model steps ^. integralValid `shouldBe` True + + it "should input '3', input 'a' then input '6'" $ do + let steps = [evtT "3", evtT "a", evtT "6"] + lastEvt steps `shouldBe` IntegralChanged 36 + model steps ^. integralValid `shouldBe` True + + it "should input '1234', delete line then input '777'" $ do + let steps = [evtT "1234", selLineL, evtT "777"] + lastEvt steps `shouldBe` IntegralChanged 777 + model steps ^. integralValid `shouldBe` True + + where + wenv = mockWenv (IntegralModel 0 False) + intNode = numericFieldV_ 0 IntegralChanged [maxValue 2345, selectOnFocus, validInput integralValid] + evts es = nodeHandleEventEvts wenv (evtFocus : es) intNode + model es = nodeHandleEventModel wenv (evtFocus : es) intNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleEventMouseDragIntegral :: Spec +handleEventMouseDragIntegral = describe "handleEventMouseDragIntegral" $ do + it "should drag upwards 100 pixels, setting the value to 100" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. integralValue `shouldBe` 100 + + it "should drag downwards 100 pixels, setting the value to -200 (dragRate = 2)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 150 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. integralValue `shouldBe` -200 + + it "should drag downwards 1000 pixels, staying at -500 (the minimum)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 1050 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. integralValue `shouldBe` -500 + + it "should drag upwnwards 1000 pixels, staying at 500 (the maximum)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 (-950) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. integralValue `shouldBe` 500 + + it "should drag downwards 30 and 20 pixels, setting the value to -5" $ do + let selStart = Point 50 30 + let selMid = Point 50 60 + let selEnd = Point 50 50 + let steps = [ + evtPress selStart, evtMove selMid, evtRelease selMid, + evtPress selStart, evtMove selEnd, evtRelease selEnd + ] + model steps ^. integralValue `shouldBe` -50 + + it "should set focus and drag upwards 100 pixels, but value stay at 0 since shift is not pressed" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtK keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. integralValue `shouldBe` 0 + + it "should set focus and drag upwards 100 pixels, setting the value to 100 since shift is pressed" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtKS keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. integralValue `shouldBe` 100 + + it "should drag upwards 100 pixels, setting the value to 100 even if it was double clicked on" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtDblClick selStart, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. integralValue `shouldBe` 100 + + where + wenv = mockWenv (IntegralModel 0 False) + & L.inputStatus . L.keyMod . L.leftShift .~ True + integralNode = vstack [ + button "Test" (IntegralChanged 0), -- Used only to have focus + numericField integralValue, + numericField_ integralValue [dragRate 2, minValue (-500), maxValue 500] + ] + evts es = nodeHandleEventEvts wenv es integralNode + model es = nodeHandleEventModel wenv es integralNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +getSizeReqIntegral :: Spec +getSizeReqIntegral = describe "getSizeReqIntegral" $ do + it "should return width = Flex 50 1" $ + sizeReqW `shouldBe` expandSize 50 1 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + it "should return width = Flex 110 1 when resizeOnChange = True" $ + sizeReqW2 `shouldBe` expandSize 110 1 + + it "should return height = Fixed 20 when resizeOnChange = True" $ + sizeReqH2 `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (IntegralModel 10000000000 True) + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (numericField integralValue) + numericResize = numericField_ integralValue [resizeOnChange] + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv numericResize + +-- ------------------------------ +-- Fractional field +-- ------------------------------ +specFractional :: Spec +specFractional = describe "FractionalField" $ do + handleEventFractional + handleEventValueFractional + handleEventMouseDragFractional + handleShiftFocusFractional + getSizeReqFractional + +handleEventFractional :: Spec +handleEventFractional = describe "handleEventFractional" $ do + it "should remove the contents and get Nothing as model value" $ do + modelBasic [evtKG keyA, evtK keyBackspace] ^. fractionalValue `shouldBe` Nothing + modelBasic [evtKG keyA, evtK keyBackspace] ^. fractionalValid `shouldBe` True + + it "should input '123' without select on focus" $ do + modelBasic [evtT "1", evtT "2", evtT "3"] ^. fractionalValue `shouldBe` Just 1230 + modelBasic [evtT "1", evtT "2", evtT "3"] ^. fractionalValid `shouldBe` True + + it "should input '1.23'" $ do + model [evtT "1.23"] ^. fractionalValue `shouldBe` Just 1.23 + model [evtT "1.23"] ^. fractionalValid `shouldBe` True + + it "should input '-1'" $ do + model [evtT "-1"] ^. fractionalValue `shouldBe` Just (-1) + model [evtT "-1"] ^. fractionalValid `shouldBe` True + + it "should input '1501'" $ do + model [evtT "1", evtT "5", evtT "0", evtT "1"] ^. fractionalValue `shouldBe` Just 1501 + model [evtT "1", evtT "5", evtT "0", evtT "1"] ^. fractionalValid `shouldBe` True + + it "should input '1502', but fail because of maxValue" $ do + model [evtT "1", evtT "5", evtT "0", evtT "2"] ^. fractionalValue `shouldBe` Just 150 + model [evtT "1", evtT "5", evtT "0", evtT "2"] ^. fractionalValid `shouldBe` False + + it "should input '123', remove one character and input '4'" $ do + model [evtT "123", delCharL, evtT "4"] ^. fractionalValue `shouldBe` Just 124 + model [evtT "123", delCharL, evtT "4"] ^. fractionalValid `shouldBe` True + + it "should input '123', remove one word and input '456'" $ do + model [evtT "123", delWordL, evtT "456"] ^. fractionalValue `shouldBe` Just 456 + model [evtT "123", delWordL, evtT "456"] ^. fractionalValid `shouldBe` True + + it "should input '123.34', remove one word and input '56'" $ do + model [evtT "123.34", delWordL, evtT "56"] ^. fractionalValue `shouldBe` Just 123.56 + model [evtT "123.34", delWordL, evtT "56"] ^. fractionalValid `shouldBe` True + + it "should input '123.34', remove two words and input '56'" $ do + model [evtT "123.34", delWordL, delWordL, evtT "56"] ^. fractionalValue `shouldBe` Just 56 + model [evtT "123.34", delWordL, delWordL, evtT "56"] ^. fractionalValid `shouldBe` True + + it "should update the model when using the wheel" $ do + let p = Point 100 10 + let steps1 = [WheelScroll p (Point 0 (-8000)) WheelNormal] + let steps2 = [WheelScroll p (Point 0 360) WheelFlipped] + let steps3 = [WheelScroll p (Point 0 8700) WheelNormal] + let steps4 = [WheelScroll p (Point 0 16000) WheelNormal] + model steps1 ^. fractionalValue `shouldBe` Just (-500) + model steps2 ^. fractionalValue `shouldBe` Just (-36) + model steps3 ^. fractionalValue `shouldBe` Just 870 + model steps4 ^. fractionalValue `shouldBe` Just 1501 + + it "should generate an event when focus is received" $ + events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (FractionalModel (Just 0) True) + basicFractionalNode :: WidgetNode FractionalModel TestEvt + basicFractionalNode = numericField_ fractionalValue [selectOnFocus_ False, validInput fractionalValid] + floatCfg = [minValue (Just (-500)), maxValue (Just 1501), validInput fractionalValid, onFocus GotFocus, onBlur LostFocus] + floatNode = numericField_ fractionalValue floatCfg + model es = nodeHandleEventModel wenv es floatNode + modelBasic es = nodeHandleEventModel wenv es basicFractionalNode + events evt = nodeHandleEventEvts wenv [evt] floatNode + +handleEventValueFractional :: Spec +handleEventValueFractional = describe "handleEventValueFractional" $ do + it "should input an '100'" $ + evts [evtT "1", evtT "0", evtT "0"] `shouldBe` Seq.fromList [FractionalChanged (Just 10), FractionalChanged (Just 100)] + + it "should input a '1' and be considered invalid" $ do + evts [evtT "1"] `shouldBe` Seq.fromList [] + model [evtT "1"] ^. fractionalValid `shouldBe` False + + it "should input '1', move to beginning and input '5'" $ do + let steps = [evtT "1", moveLineL, evtT "5"] + lastEvt steps `shouldBe` FractionalChanged (Just 51) + + it "should input '1', input '.' then input '5'" $ do + let steps = [evtT "10", evtT ".", evtT "5"] + lastEvt steps `shouldBe` FractionalChanged (Just 10.5) + model steps ^. fractionalValid `shouldBe` True + + it "should input '20', input '.' twice then input '777'" $ do + let steps = [evtT "20", evtT ".", evtT ".", evtT "7", evtT "7", evtT "7"] + lastEvt steps `shouldBe` FractionalChanged (Just 20.77) + model steps ^. fractionalValid `shouldBe` True + + it "should input '10', '.' then input '2345'" $ do + let steps = [evtT "10", evtT ".", evtT "2", evtT "3", evtT "4", evtT "5"] + lastEvtDecimals steps `shouldBe` FractionalChanged (Just 10.234) + + it "should input '3', input 'a' then input '6'" $ do + let steps = [evtT "3", evtT "a", evtT "6"] + lastEvt steps `shouldBe` FractionalChanged (Just 36) + model steps ^. fractionalValid `shouldBe` True + + it "should input '1234', delete line then input '777'" $ do + let steps = [evtT "1234", selLineL, evtT "777"] + lastEvt steps `shouldBe` FractionalChanged (Just 777) + model steps ^. fractionalValid `shouldBe` True + + where + wenv = mockWenv (FractionalModel (Just 0) False) + floatNode = numericFieldV_ (Just 0) FractionalChanged [minValue (Just 10), maxValue (Just 2345), selectOnFocus, validInput fractionalValid] + floatDecimalsNode = numericFieldV_ (Just 0) FractionalChanged [selectOnFocus, decimals 3] + evts es = nodeHandleEventEvts wenv (evtFocus : es) floatNode + evtsAlt es = nodeHandleEventEvts wenv (evtFocus : es) floatDecimalsNode + model es = nodeHandleEventModel wenv (evtFocus : es) floatNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + lastEvtDecimals es = lastIdx (evtsAlt es) + +handleEventMouseDragFractional :: Spec +handleEventMouseDragFractional = describe "handleEventMouseDragFractional" $ do + it "should drag upwards 100 pixels, setting the value to 10" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. fractionalValue `shouldBe` Just 10 + + it "should drag downwards 100 pixels, setting the value to -20 (dragRate = 0.2)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 150 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. fractionalValue `shouldBe` Just (-20) + + it "should drag downwards 30 and 20 pixels, setting the value to -5" $ do + let selStart = Point 50 30 + let selMid = Point 50 60 + let selEnd = Point 50 50 + let steps = [ + evtPress selStart, evtMove selMid, evtRelease selMid, + evtPress selStart, evtMove selEnd, evtRelease selEnd + ] + model steps ^. fractionalValue `shouldBe` Just (-5) + + it "should drag upwards 100 pixels, but value stay at 0 since shift is not pressed" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtK keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. fractionalValue `shouldBe` Just 0 + + it "should drag upwards 100 pixels, setting the value to 10 since shift not pressed" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtKS keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. fractionalValue `shouldBe` Just 10 + + it "should drag upwards 100 pixels, setting the value to 10 even if it was double clicked on" $ do + let selStart = Point 50 30 + let selEnd = Point 50 (-70) + let steps = [evtDblClick selStart, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. fractionalValue `shouldBe` Just 10 + + where + wenv = mockWenv (FractionalModel (Just 0) False) + & L.inputStatus . L.keyMod . L.leftShift .~ True + floatNode = vstack [ + button "Test" (FractionalChanged (Just 0)), -- Used only to have focus + numericField fractionalValue, + numericField_ fractionalValue [dragRate 0.2] + ] + evts es = nodeHandleEventEvts wenv es floatNode + model es = nodeHandleEventModel wenv es floatNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleShiftFocusFractional :: Spec +handleShiftFocusFractional = describe "handleShiftFocusFractional" $ do + it "should set focus when clicked" $ do + evts [evtPress p] `shouldBe` Seq.fromList [GotFocus $ Seq.fromList [0, 0]] + + it "should not set focus when clicked with shift pressed" $ do + evts [evtKS keyA, evtPress p] `shouldBe` Seq.empty + + where + wenv = mockWenv (FractionalModel (Just 0) False) + p = Point 100 30 + floatNode = vstack [ + numericField_ fractionalValue [wheelRate 1], + numericField_ fractionalValue [wheelRate 1, onFocus GotFocus] + ] + evts es = nodeHandleEventEvts wenv es floatNode + +getSizeReqFractional :: Spec +getSizeReqFractional = describe "getSizeReqFractional" $ do + it "should return width = Flex 70 1" $ + sizeReqW `shouldBe` expandSize 70 1 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + it "should return width = Flex 110 1 when resizeOnChange = True" $ + sizeReqW2 `shouldBe` expandSize 110 1 + + it "should return height = Fixed 20 when resizeOnChange = True" $ + sizeReqH2 `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (FractionalModel (Just 10000000) True) + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (numericField fractionalValue) + numericResize = numericField_ fractionalValue [resizeOnChange] + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv numericResize diff --git a/test/unit/Monomer/Widgets/Singles/RadioSpec.hs b/test/unit/Monomer/Widgets/Singles/RadioSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/RadioSpec.hs @@ -0,0 +1,117 @@ +{-| +Module : Monomer.Widgets.Singles.RadioSpec +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 Radio widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.RadioSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestEventUtil +import Monomer.TestUtil +import Monomer.Widgets.Singles.Radio + +import qualified Monomer.Lens as L + +data Fruit + = Apple + | Orange + | Banana + deriving (Eq, Show) + +data FruitEvt + = FruitSel Fruit + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmFruit :: Fruit +} deriving (Eq) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Radio" $ do + handleEvent + handleEventValue + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should not update the model if not clicked" $ + clickModel (Point 3000 3000) orangeNode ^. fruit `shouldBe` Apple + + it "should update the model when clicked" $ + clickModel (Point 320 240) orangeNode ^. fruit `shouldBe` Orange + + it "should update the model when Enter/Space is pressed" $ + keyModel keyReturn bananaNode ^. fruit `shouldBe` Banana + + it "should generate an event when focus is received" $ + events evtFocus orangeNode `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events evtBlur orangeNode `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel Apple) + & L.theme .~ darkTheme + orangeNode = radio_ Orange fruit [onFocus GotFocus, onBlur LostFocus] + bananaNode :: WidgetNode TestModel FruitEvt + bananaNode = radio Banana fruit + 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 + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + it "should not generate an event if clicked outside" $ + clickModel (Point 3000 3000) orangeNode `shouldBe` Seq.empty + + it "should generate a user provided event when clicked" $ + clickModel (Point 320 240) orangeNode `shouldBe` Seq.singleton (FruitSel Orange) + + it "should generate a user provided event when Enter/Space is pressed" $ + keyModel keyReturn bananaNode `shouldBe` Seq.singleton (FruitSel Banana) + + where + wenv = mockWenv (TestModel Apple) + & L.theme .~ darkTheme + orangeNode = radioV Orange Apple FruitSel + bananaNode = radioV Banana Apple FruitSel + clickModel p node = nodeHandleEventEvts wenv [evtClick p] node + keyModel key node = nodeHandleEventEvts wenv [KeyAction def key KeyPressed] node + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Fixed 20" $ + sizeReqW `shouldBe` fixedSize 20 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (TestModel Apple) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (radio Apple fruit) diff --git a/test/unit/Monomer/Widgets/Singles/SeparatorLineSpec.hs b/test/unit/Monomer/Widgets/Singles/SeparatorLineSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/SeparatorLineSpec.hs @@ -0,0 +1,76 @@ +{-| +Module : Monomer.Widgets.Singles.SeparatorLineSpec +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 Separator Line widget. +-} +module Monomer.Widgets.Singles.SeparatorLineSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.TestUtil +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Grid +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.SeparatorLine + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "SeparatorLine" $ do + separatorLineSizeReqBox + separatorLineSizeReqGrid + separatorLineSizeReqStack + +separatorLineSizeReqBox :: Spec +separatorLineSizeReqBox = describe "separatorLineSizeReqBox" $ do + it "should return (Fixed 1, Fixed 1)" $ do + sizeReqW1 `shouldBe` fixedSize 1 + sizeReqH1 `shouldBe` fixedSize 1 + + where + wenv = mockWenvEvtUnit () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (box separatorLine) + +separatorLineSizeReqGrid :: Spec +separatorLineSizeReqGrid = describe "separatorLineSizeReqGrid" $ do + it "should return (Fixed 1, Flex 10 0.5) for horizontal" $ do + sizeReqW1 `shouldBe` fixedSize 1 + sizeReqH1 `shouldBe` flexSize 10 0.5 + + it "should return (Flex 10 0.5, Fixed 1) for vertical" $ do + sizeReqW2 `shouldBe` flexSize 10 0.5 + sizeReqH2 `shouldBe` fixedSize 1 + + where + wenv = mockWenvEvtUnit () + & L.theme .~ darkTheme + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (hgrid [separatorLine]) + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv (vgrid [separatorLine]) + +separatorLineSizeReqStack :: Spec +separatorLineSizeReqStack = describe "separatorLineSizeReqStack" $ do + it "should return (Fixed 5, Flex 10 0.5) for horizontal" $ do + sizeReqW1 `shouldBe` fixedSize 5 + sizeReqH1 `shouldBe` flexSize 10 0.5 + + it "should return (Flex 10 0.5, Fixed 5) for vertical" $ do + sizeReqW2 `shouldBe` flexSize 10 0.5 + sizeReqH2 `shouldBe` fixedSize 5 + + where + wenv = mockWenv () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (hstack [separatorLine_ [width 5]]) + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv (vstack [separatorLine_ [width 5]]) diff --git a/test/unit/Monomer/Widgets/Singles/SliderSpec.hs b/test/unit/Monomer/Widgets/Singles/SliderSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/SliderSpec.hs @@ -0,0 +1,401 @@ +{-| +Module : Monomer.Widgets.Singles.SliderSpec +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 Slider widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.SliderSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Core.Themes.SampleThemes +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Slider + +import qualified Monomer.Lens as L + +data TestEvt + = SliderChanged Double + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmSliderVal :: Double +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Slider" $ do + handleKeyboardH + handleKeyboardV + handleMouseDragH + handleMouseDragV + handleMouseDragThumb + handleMouseDragValH + handleMouseDragValV + handleWheelH + handleWheelValV + handleShiftFocus + getSizeReqH + getSizeReqV + getSizeReqThumb + +handleKeyboardH :: Spec +handleKeyboardH = describe "handleKeyboardH" $ do + it "should not change the value when using vertical arrows" $ do + let steps = [evtK keyUp, evtK keyDown, evtK keyDown] + model steps ^. sliderVal `shouldBe` 0 + + it "should press arrow right ten times and set the slider value to 20" $ do + let steps = replicate 10 (evtK keyRight) + model steps ^. sliderVal `shouldBe` 20 + + it "should press arrow right + shift ten times and set the slider value to 2" $ do + let steps = replicate 10 (evtKS keyRight) + model steps ^. sliderVal `shouldBe` 2 + + it "should press arrow right + ctrl four times and set the slider value to 80" $ do + let steps = replicate 4 (evtKG keyRight) + model steps ^. sliderVal `shouldBe` 80 + + it "should press arrow left ten times and set the slider value to -20" $ do + let steps = replicate 10 (evtK keyLeft) + model steps ^. sliderVal `shouldBe` (-20) + + it "should press arrow left + shift five times and set the slider value to 1" $ do + let steps = replicate 5 (evtKS keyLeft) + model steps ^. sliderVal `shouldBe` -1 + + it "should press arrow right + ctrl one time and set the slider value to -20" $ do + let steps = [evtKG keyLeft] + model steps ^. sliderVal `shouldBe` (-20) + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + sliderNode = hslider sliderVal (-100) 100 + model es = nodeHandleEventModel wenv es sliderNode + +handleKeyboardV :: Spec +handleKeyboardV = describe "handleKeyboardV" $ do + it "should not change the value when using horizontal arrows" $ do + let steps = [evtK keyLeft, evtK keyRight, evtK keyRight] + model steps ^. sliderVal `shouldBe` 0 + + it "should press arrow up ten times and set the slider value to 20" $ do + let steps = replicate 10 (evtK keyUp) + model steps ^. sliderVal `shouldBe` 20 + + it "should press arrow up + shift ten times and set the slider value to 2" $ do + let steps = replicate 10 (evtKS keyUp) + model steps ^. sliderVal `shouldBe` 2 + + it "should press arrow up + ctrl four times and set the slider value to 80" $ do + let steps = replicate 4 (evtKG keyUp) + model steps ^. sliderVal `shouldBe` 80 + + it "should press arrow down ten times and set the slider value to -20" $ do + let steps = replicate 10 (evtK keyDown) + model steps ^. sliderVal `shouldBe` (-20) + + it "should press arrow down + shift five times and set the slider value to 1" $ do + let steps = replicate 5 (evtKS keyDown) + model steps ^. sliderVal `shouldBe` -1 + + it "should press arrow up + ctrl one time and set the slider value to -20" $ do + let steps = [evtKG keyDown] + model steps ^. sliderVal `shouldBe` (-20) + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + sliderNode = vslider sliderVal (-100) 100 + model es = nodeHandleEventModel wenv es sliderNode + +handleMouseDragH :: Spec +handleMouseDragH = describe "handleMouseDragH" $ do + it "should not change the value when dragging vertically" $ do + let selStart = Point 320 240 + let selEnd = Point 320 120 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 0 + + it "should drag 160 pixels right and set the slider value to 50" $ do + let selStart = Point 320 240 + let selEnd = Point 480 240 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 50 + + it "should drag 320 pixels right and set the slider value 100" $ do + let selStart = Point 320 240 + let selEnd = Point 640 240 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 100 + + it "should drag 1000 pixels right, but stay on 100" $ do + let selStart = Point 320 240 + let selEnd = Point 1320 240 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 100 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + sliderNode = hslider sliderVal (-100) 100 + model es = nodeHandleEventModel wenv es sliderNode + +handleMouseDragV :: Spec +handleMouseDragV = describe "handleMouseDragV" $ do + it "should not change the value when dragging horizontally" $ do + let selStart = Point 320 240 + let selEnd = Point 500 240 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 0 + + it "should drag 100 pixels up and set the slider value to 50" $ do + let selStart = Point 320 240 + let selEnd = Point 320 120 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 50 + + it "should drag 500 pixels up and set the slider value 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-260) + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 100 + + it "should drag 1000 pixels up, but stay on 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-760) + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 100 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + sliderNode = vslider sliderVal (-100) 100 + model es = nodeHandleEventModel wenv es sliderNode + +handleMouseDragThumb :: Spec +handleMouseDragThumb = describe "handleMouseDragThumb" $ do + it "should not change the value when dragging horizontally" $ do + let selStart = Point 320 240 + let selEnd = Point 500 240 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 0 + + it "should drag 100 pixels up and set the slider value to 50" $ do + let selStart = Point 320 240 + let selEnd = Point 320 120 + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 50 + + it "should drag 500 pixels up and set the slider value 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-260) + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 100 + + it "should drag 1000 pixels up, but stay on 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-760) + let steps = evtDrag selStart selEnd + model steps ^. sliderVal `shouldBe` 100 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + sliderNode = vslider_ sliderVal (-100) 100 [thumbVisible] + model es = nodeHandleEventModel wenv es sliderNode + +handleMouseDragValH :: Spec +handleMouseDragValH = describe "handleMouseDragValH" $ do + it "should not change the value when dragging vertically" $ do + let selStart = Point 320 240 + let selEnd = Point 320 0 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [] + + it "should drag 160 pixels left and set the slider value to -250" $ do + let selStart = Point 320 240 + let selEnd = Point 160 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged (-250.0)] + + it "should drag right to 640 and set the slider value 500" $ do + let selStart = Point 320 240 + let selEnd = Point 640 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 500] + + it "should drag 1000 pixels right, but stay on 500" $ do + let selStart = Point 320 240 + let selEnd = Point 1000 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 500] + + it "should click 160 pixels left and set the slider to -250" $ do + let point = Point 160 240 + let steps = [evtRelease point] + evts steps `shouldBe` Seq.fromList [SliderChanged (-250)] + + it "should generate an event when focus is received" $ + evts [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + evts [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel 500) + & L.theme .~ darkTheme + sliderNode = hsliderV_ 0 SliderChanged (-500) 500 [dragRate 1, onFocus GotFocus, onBlur LostFocus] + evts es = nodeHandleEventEvts wenv es sliderNode + +handleMouseDragValV :: Spec +handleMouseDragValV = describe "handleMouseDragValV" $ do + it "should not change the value when dragging horizontally" $ do + let selStart = Point 320 240 + let selEnd = Point 500 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [] + + it "should drag 100 pixels down and set the slider value to -250" $ do + let selStart = Point 320 240 + let selEnd = Point 320 360 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged (-250.0)] + + it "should drag up to zero and set the slider value 500" $ do + let selStart = Point 320 240 + let selEnd = Point 320 0 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 500] + + it "should drag 1000 pixels up, but stay on 500" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-760) + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [SliderChanged 500] + + it "should click 120 pixels down and set the slider to -250" $ do + let point = Point 320 360 + let steps = [evtRelease point] + evts steps `shouldBe` Seq.fromList [SliderChanged (-250)] + + it "should generate an event when focus is received" $ + evts [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + evts [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + wenv = mockWenv (TestModel 500) + & L.theme .~ darkTheme + sliderNode = vsliderV_ 0 SliderChanged (-500) 500 [dragRate 1, onFocus GotFocus, onBlur LostFocus] + evts es = nodeHandleEventEvts wenv es sliderNode + +handleWheelH :: Spec +handleWheelH = describe "handleWheelH" $ do + it "should update the model when using the wheel" $ do + let p = Point 100 10 + let steps = [WheelScroll p (Point 0 100) WheelNormal] + model steps ^. sliderVal `shouldBe` 300 + + where + wenv = mockWenvEvtUnit (TestModel 200) + & L.theme .~ darkTheme + sliderNode = hslider_ sliderVal (-500) 500 [wheelRate 1] + model es = nodeHandleEventModel wenv es sliderNode + +handleWheelValV :: Spec +handleWheelValV = describe "handleWheelValV" $ do + it "should update the model when using the wheel" $ do + let p = Point 100 10 + let steps = [WheelScroll p (Point 0 (-200)) WheelNormal] + evts steps `shouldBe` Seq.singleton (SliderChanged (-200)) + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + sliderNode = vsliderV_ 0 SliderChanged (-500) 500 [wheelRate 1] + evts es = nodeHandleEventEvts wenv es sliderNode + +handleShiftFocus :: Spec +handleShiftFocus = describe "handleShiftFocus" $ do + it "should set focus when clicked" $ do + evts [evtPress p] `shouldBe` Seq.fromList [GotFocus $ Seq.fromList [0, 0]] + + it "should not set focus when clicked with shift pressed" $ do + evts [evtKS keyA, evtPress p] `shouldBe` Seq.empty + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + p = Point 100 30 + sliderNode = vstack [ + hslider_ sliderVal (-500) 500 [wheelRate 1] `styleBasic` [height 20], + hslider_ sliderVal (-500) 500 [wheelRate 1, onFocus GotFocus] `styleBasic` [height 20] + ] + evts es = nodeHandleEventEvts wenv es sliderNode + +getSizeReqH :: Spec +getSizeReqH = describe "getSizeReqH" $ do + it "should return width = Expand 1000 1" $ + sizeReqW `shouldBe` expandSize 1000 1 + + it "should return height = Fixed 10" $ + sizeReqH `shouldBe` fixedSize 10 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (hslider sliderVal 0 100) + +getSizeReqV :: Spec +getSizeReqV = describe "getSizeReqV" $ do + it "should return width = Fixed 10" $ + sizeReqW `shouldBe` fixedSize 10 + + it "should return height = Expand 1000 1" $ + sizeReqH `shouldBe` expandSize 1000 1 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (vslider sliderVal 0 100) + +getSizeReqThumb :: Spec +getSizeReqThumb = describe "getSizeReqThumb" $ do + it "should return width = Fixed 10" $ + sizeReqW `shouldBe` fixedSize 10 + + it "should return height = Expand 1000 1" $ + sizeReqH `shouldBe` expandSize 1000 1 + + where + wenv = mockWenvEvtUnit (TestModel 0) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (vslider_ sliderVal 0 100 [thumbVisible]) diff --git a/test/unit/Monomer/Widgets/Singles/SpacerSpec.hs b/test/unit/Monomer/Widgets/Singles/SpacerSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/SpacerSpec.hs @@ -0,0 +1,124 @@ +{-| +Module : Monomer.Widgets.Singles.SpacerSpec +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 Spacer widget. +-} +module Monomer.Widgets.Singles.SpacerSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq +import qualified Data.Text as T + +import Monomer.Core +import Monomer.TestUtil +import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.Grid +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Spacer + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Spacer/Filler" $ do + spacerSpec + fillerSpec + +spacerSpec :: Spec +spacerSpec = describe "Spacer" $ do + spacerSizeReqBox + spacerSizeReqGrid + spacerSizeReqStack + +spacerSizeReqBox :: Spec +spacerSizeReqBox = describe "spacerSizeReqBox" $ do + it "should return (Fixed 10, Fixed 10)" $ do + sizeReqW1 `shouldBe` fixedSize 10 + sizeReqH1 `shouldBe` fixedSize 10 + + where + wenv = mockWenvEvtUnit () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (box spacer) + +spacerSizeReqGrid :: Spec +spacerSizeReqGrid = describe "spacerSizeReqGrid" $ do + it "should return (Fixed 10, Flex 5 0.5) for horizontal" $ do + sizeReqW1 `shouldBe` fixedSize 10 + sizeReqH1 `shouldBe` flexSize 5 0.5 + + it "should return (Flex 5 0.5, Fixed 10) for vertical" $ do + sizeReqW2 `shouldBe` flexSize 5 0.5 + sizeReqH2 `shouldBe` fixedSize 10 + + where + wenv = mockWenvEvtUnit () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (hgrid [spacer]) + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv (vgrid [spacer]) + +spacerSizeReqStack :: Spec +spacerSizeReqStack = describe "spacerSizeReqStack" $ do + it "should return (Fixed 10, Flex 5 0.5) for horizontal" $ do + sizeReqW1 `shouldBe` fixedSize 10 + sizeReqH1 `shouldBe` flexSize 5 0.5 + + it "should return (Flex 10 0.5, Fixed 5) for vertical" $ do + sizeReqW2 `shouldBe` flexSize 5 0.5 + sizeReqH2 `shouldBe` fixedSize 10 + + where + wenv = mockWenv () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (hstack [spacer]) + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv (vstack [spacer]) + +fillerSpec :: Spec +fillerSpec = describe "Filler" $ do + fillerSizeReqBox + fillerSizeReqGrid + fillerSizeReqStack + +fillerSizeReqBox :: Spec +fillerSizeReqBox = describe "fillerSizeReqBox" $ do + it "should return (Expand 5 0.5, Expand 5 0.5)" $ do + sizeReqW1 `shouldBe` expandSize 5 0.5 + sizeReqH1 `shouldBe` expandSize 5 0.5 + + where + wenv = mockWenvEvtUnit () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (box filler) + +fillerSizeReqGrid :: Spec +fillerSizeReqGrid = describe "fillerSizeReqGrid" $ do + it "should return (Expand 5 0.5, Flex 5 0.5) for horizontal" $ do + sizeReqW1 `shouldBe` expandSize 5 0.5 + sizeReqH1 `shouldBe` flexSize 5 0.5 + + it "should return (Flex 5 0.5, Expand 5 0.5) for vertical" $ do + sizeReqW2 `shouldBe` flexSize 5 0.5 + sizeReqH2 `shouldBe` expandSize 5 0.5 + + where + wenv = mockWenvEvtUnit () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (hgrid [filler]) + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv (vgrid [filler]) + +fillerSizeReqStack :: Spec +fillerSizeReqStack = describe "fillerSizeReqStack" $ do + it "should return (Expand 5 0.5, Flex 5 0.5) for horizontal" $ do + sizeReqW1 `shouldBe` expandSize 5 0.5 + sizeReqH1 `shouldBe` flexSize 5 0.5 + + it "should return (Flex 5 0.5, Expand 5 0.5) for vertical" $ do + sizeReqW2 `shouldBe` flexSize 5 0.5 + sizeReqH2 `shouldBe` expandSize 5 0.5 + + where + wenv = mockWenv () + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv (hstack [filler]) + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv (vstack [filler]) diff --git a/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs b/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs @@ -0,0 +1,334 @@ +{-| +Module : Monomer.Widgets.Singles.TextAreaSpec +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 TextArea widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.TextAreaSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.TextArea + +import qualified Monomer.Lens as L + +data TestEvt + = TextChanged Text + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmTextValue :: Text +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "TextArea" $ do + handleEvent + handleEventValue + handleEventMouseSelect + handleEventHistory + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should input an 'a'" $ do + model [evtT "a"] ^. textValue `shouldBe` "a" + ctx [evtT "a"] ^. L.renderSchedule `shouldSatisfy` (==1) . length + + it "should input 'ababa', remove the middle 'a' and input 'c'" $ do + let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"] + model steps ^. textValue `shouldBe` "abcba" + + it "should input 'ababa', select last two and input 'c'" $ do + let steps = [evtT "ababa", selCharL, selCharL, selCharL, evtT "c"] + model steps ^. textValue `shouldBe` "abc" + + it "should input 'This is a dog', move to beginning, select first word and input 'that'" $ do + let str = "This is a dog" + let steps = [evtT str, moveWordL, moveWordL, moveWordL, moveWordL, selWordR, evtT "that"] + model steps ^. textValue `shouldBe` "that is a dog" + + it "should input 'This is a dog', select one word, deselect and input 'big '" $ do + let str = "This is a dog" + let steps = [evtT str, selWordL, moveCharL, evtT "big "] + model steps ^. textValue `shouldBe` "This is a big dog" + + it "should input 'This string very long text is', and reject ' invalid' since maxLength == 40" $ do + let str = "This string very very long text is" + let steps = [evtT str, evtT " invalid"] + model steps ^. textValue `shouldBe` "This string very very long text is" + + it "should input 5 empty lines, and accept 'valid' since maxLines == 5" $ do + let str = "\n\n\n\n" + let steps = [evtT str, evtT "valid"] + model steps ^. textValue `shouldBe` str <> "valid" + + it "should input 5 empty lines, and reject '\ninvalid' since maxLines == 5" $ do + let str = "\n\n\n\n" + let steps = [evtT str, evtT "\ninvalid"] + model steps ^. textValue `shouldBe` str + + it "should input 'This is text\ntest', select all and input 'No'" $ do + let str = "This is text\ntest" + let steps = [evtT str, evtKG keyA, evtT "No"] + model steps ^. textValue `shouldBe` "No" + + it "should input 'This is text', receive focus (with select on Focus) and input 'No'" $ do + let str = "This is text" + let steps = [evtT str, evtFocus, evtT "No"] + model steps ^. textValue `shouldBe` "No" + + it "should copy and paste text around" $ do + let str = "This is some long text" + let steps = [evtT str, selWordL, selWordL, selCharL, evtKG keyC, moveWordL, moveWordL, moveCharL, evtKG keyV] + model steps ^. textValue `shouldBe` "This long text is some long text" + + it "should cut and paste text around" $ do + let str = "This is long text" + let steps = [evtT str, selWordL, selCharL, evtKG keyX, moveWordL, moveWordL, moveCharL, evtKG keyV] + model steps ^. textValue `shouldBe` "This text is long" + + it "should generate an event when focus is received" $ do + events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + ctx [evtFocus] ^. L.renderSchedule `shouldSatisfy` (==1) . length + + it "should generate an event when focus is lost" $ do + events [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + ctx [evtFocus, evtBlur] ^. L.renderSchedule `shouldSatisfy` null + + where + wenv = mockWenv (TestModel "") + txtCfg = [maxLength 40, maxLines 5, selectOnFocus, onFocus GotFocus, onBlur LostFocus] + txtNode = textArea_ textValue txtCfg + model es = nodeHandleEventModel wenv es txtNode + events es = nodeHandleEventEvts wenv es txtNode + ctx evts = nodeHandleEventCtx wenv evts txtNode + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + it "should input an 'ab'" $ + evts [evtT "a", evtT "b"] `shouldBe` Seq.fromList [TextChanged "a", TextChanged "ab"] + + it "should input 'this is a dog', input '?', move to beginning and input 'Is '" $ do + let str = "this is a dog" + let steps = [evtT str, evtT "?", moveLineL, evtT "Is "] + lastEvt steps `shouldBe` TextChanged "Is this is a dog?" + + it "should input 'This is a dog', move before 'is', select 'is', deselect it and input 'nt'" $ do + let str = "This is a dog" + let steps = [evtT str, moveWordL, moveWordL, moveWordL, selWordR, moveCharR, evtT "n't"] + lastEvt steps `shouldBe` TextChanged "This isn't a dog" + + it "should input 'This is a dog', remove one word and input 'bird'" $ do + let str = "This is a dog" + let steps = [evtT str, delWordL, evtT "cat"] + lastEvt steps `shouldBe` TextChanged "This is a cat" + + it "should input 'This is a dog', select to beginning and input 'No'" $ do + let str = "This is a dog" + let steps = [evtT str, selLineL, evtT "No"] + lastEvt steps `shouldBe` TextChanged "No" + + it "should input 'This is a dog', move to beginning, select until end of line and input 'No'" $ do + let str = "This is a dog" + let steps = [evtT str, moveLineL, selLineR, evtT "No"] + lastEvt steps `shouldBe` TextChanged "No" + + it "should input 'This is\n a dog', move to beginning, move one word right, select until end and input 'door'" $ do + let str = "This is\n a dog" + let steps = [evtT str, evtKG keyUp, moveWordR, evtKGS keyDown, evtT " door"] + lastEvt steps `shouldBe` TextChanged "This door" + + it "should input 'a', move to beginning, input 'H', move to end of line and input 't'" $ do + let steps = [evtT "a", evtK keyHome, evtT "H", evtK keyEnd, evtT "t"] + lastEvt steps `shouldBe` TextChanged "Hat" + + it "should input 'abc', select to beginning, input 'def', move back twice, select to end and input 'dd'" $ do + let steps = [evtT "abc", evtKCS keyHome, evtT "def", moveCharL, moveCharL, evtKCS keyEnd, evtT "dd"] + lastEvt steps `shouldBe` TextChanged "ddd" + + it "should input 'abc123', move to beginning, select three letters, copy, move to end, paste" $ do + let steps = [evtT "abc123", evtKC keyHome, selCharR, selCharR, selCharR, evtKG keyC, evtK keyEnd, evtKG keyV] + lastEvt steps `shouldBe` TextChanged "abc123abc" + + it "should input a-b-c-d on separate lines, then press Return" $ do + let steps = [evtT "a\nb\nc\nd", evtK keyReturn] + lastEvt steps `shouldBe` TextChanged "a\nb\nc\nd\n" + + it "should input a-b-c-d on separate lines, move to beginning, move down, select two lines, input 'e'" $ do + let steps = [evtT "a\nb\nc\nd", evtKC keyLeft, evtKC keyUp, evtK keyDown, evtKS keyDown, evtKS keyDown, evtT "e", evtK keyReturn] + lastEvt steps `shouldBe` TextChanged "a\ne\nd" + + where + wenv = mockWenv (TestModel "") + txtNode = textAreaV "" TextChanged + evts es = nodeHandleEventEvts wenv es txtNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleEventMouseSelect :: Spec +handleEventMouseSelect = describe "handleEventMouseSelect" $ do + it "should add text at the end, since click + drag started outside of viewport" $ do + let str = "This is text" + let selStart = Point 50 100 + let selEnd = Point 120 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "!"] + model steps ^. textValue `shouldBe` "This is text!" + + it "should drag around and input 'Text'" $ do + let str = "This is random" + let selStart = Point 50 10 + let selMid1 = Point 0 10 + let selMid2 = Point 200 10 + let selMid3 = Point (-200) 10 + let selEnd = Point 150 10 + let moves = [evtMove selMid1, evtMove selMid2, evtMove selMid3, evtMove selEnd] + let steps = [evtT str, evtPress selStart] ++ moves ++ [evtRelease selEnd, evtT "Text"] + model steps ^. textValue `shouldBe` "This Text" + + it "should input 'This is text', select 'is text' and input 'test'" $ do + let str = "This is text" + let selStart = Point 50 10 + let selEnd = Point 120 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "test"] + model steps ^. textValue `shouldBe` "This test" + + it "should input 'This is text', select all from beginning and input 'New'" $ do + let str = "This is new" + let selStart = Point 0 10 + let selEnd = Point 200 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "New"] + model steps ^. textValue `shouldBe` "New" + + it "should input 'This is text', select all from the end and input 'New'" $ do + let str = "This is" + let selStart = Point 70 10 + let selEnd = Point 0 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "New"] + model steps ^. textValue `shouldBe` "New" + + it "should input 'This is long\nline', click twice, input 'a'" $ do + let str = "This is long\nline" + let point = Point 80 10 + let steps = [evtT str, ButtonAction point BtnLeft BtnReleased 2, evtT "a"] + model steps ^. textValue `shouldBe` "This is a\nline" + + it "should input 'This is long\nline', click three times, input 'New'" $ do + let str = "This is long line\nline" + let point = Point 80 10 + let steps = [evtT str, ButtonAction point BtnLeft BtnReleased 3, evtT "New"] + model steps ^. textValue `shouldBe` "New\nline" + + it "should input 'This is long\nline', click four times, input 'Clear'" $ do + let str = "This is long line\nline" + let point = Point 80 10 + let steps = [evtT str, ButtonAction point BtnLeft BtnReleased 4, evtT "Clear"] + model steps ^. textValue `shouldBe` "Clear" + + it "should input multiline text, move to start, select the first line and clear it" $ do + let str = "a\nb\nc\nd\ne\nf\n" + let selStart = Point 20 10 + let steps = [evtT str, evtKG keyUp, ButtonAction selStart BtnLeft BtnReleased 3, evtT ""] + model steps ^. textValue `shouldBe` "\nb\nc\nd\ne\nf\n" + + it "should input multiline text, move to start, select drag four lines, unselect, select active line and clear it (tests auto scroll)" $ do + let str = "a\nb\nc\nd\ne\nf\n" + let selStart = Point 0 10 + let selEnd = Point 0 100 + let selSteps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + let lineSteps = [ButtonAction selStart BtnLeft BtnReleased 3, evtT ""] + let steps = [evtT str, evtKG keyUp] ++ selSteps ++ lineSteps + model steps ^. textValue `shouldBe` "a\nb\nc\nd\n\nf\n" + + where + wenv = mockWenvEvtUnit (TestModel "") + txtNode = vstack [ + hstack [ + textArea textValue `styleBasic` [height 50] + ] + ] + model es = nodeHandleEventModel wenv es txtNode + events es = nodeHandleEventEvts wenv es txtNode + +handleEventHistory :: Spec +handleEventHistory = describe "handleEventHistory" $ do + it "should input 'This is text', have the last word removed and then undo" $ do + let str = "This is text" + let steps1 = [evtT str, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ] + model steps1 ^. textValue `shouldBe` "This is " + model steps2 ^. textValue `shouldBe` "This is text" + lastEvt steps2 `shouldBe` TextChanged "This is text" + + it "should input 'This is text', have the last two words removed, undo and redo" $ do + let str = "This is text" + let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ, evtKG keyZ, evtKGS keyZ] + model steps1 ^. textValue `shouldBe` "This " + model steps2 ^. textValue `shouldBe` "This is " + lastEvt steps2 `shouldBe` TextChanged "This is " + + it "should input 'This is just a string', play around with history and come end up with 'This is just text" $ do + let str = "This is just a string" + let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKGS keyZ, evtKGS keyZ, evtT "text"] + model steps1 ^. textValue `shouldBe` "" + model steps2 ^. textValue `shouldBe` "This is just text" + lastEvt steps2 `shouldBe` TextChanged "This is just text" + + it "should input 'This is text', remove two words, undo, input 'not' and fail to redo" $ do + let str = "This is text" + let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ, evtT "not", evtKGS keyZ] + model steps1 ^. textValue `shouldBe` "This " + model steps2 ^. textValue `shouldBe` "This is not" + lastEvt steps2 `shouldBe` TextChanged "This is not" + + where + wenv = mockWenv (TestModel "") + txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus] + txtNode = textArea_ textValue txtCfg + model es = nodeHandleEventModel wenv es txtNode + evts es = nodeHandleEventEvts wenv es txtNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return (Min 100 1, Min 20 1), but transformed to expandSize by scroll" $ do + sizeReqW1 `shouldBe` expandSize 100 1 + sizeReqH1 `shouldBe` expandSize 20 1 + + it "should return (Min 150 1, Min 80 1), but transformed to expandSize by scroll" $ do + sizeReqW2 `shouldBe` expandSize 150 1 + sizeReqH2 `shouldBe` expandSize 100 1 + + where + wenv1 = mockWenvEvtUnit (TestModel "Test value") + (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv1 (textArea textValue) + wenv2 = mockWenvEvtUnit (TestModel "Test long value\n\n\n\n") + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv2 (textArea textValue) diff --git a/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs @@ -0,0 +1,275 @@ +{-| +Module : Monomer.Widgets.Singles.TextFieldSpec +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 TextField widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.TextFieldSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.TextField + +import qualified Monomer.Lens as L + +data TestEvt + = TextChanged Text + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmTextValue :: Text +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "TextField" $ do + handleEvent + handleEventValue + handleEventMouseSelect + handleEventHistory + getSizeReq + +handleEvent :: Spec +handleEvent = describe "handleEvent" $ do + it "should input an 'a'" $ do + model [evtT "a"] ^. textValue `shouldBe` "a" + ctx [evtT "a"] ^. L.renderSchedule `shouldSatisfy` (==1) . length + + it "should input 'ababa', remove the middle 'a' and input 'c'" $ do + let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"] + model steps ^. textValue `shouldBe` "abcba" + + it "should input 'ababa', select last two and input 'c'" $ do + let steps = [evtT "ababa", selCharL, selCharL, selCharL, evtT "c"] + model steps ^. textValue `shouldBe` "abc" + + it "should input 'This is a dog', move to beginning, select first word and input 'that'" $ do + let str = "This is a dog" + let steps = [evtT str, moveWordL, moveWordL, moveWordL, moveWordL, selWordR, evtT "that"] + model steps ^. textValue `shouldBe` "that is a dog" + + it "should input 'This is a dog', select one word, deselect and input 'big '" $ do + let str = "This is a dog" + let steps = [evtT str, selWordL, moveCharL, evtT "big "] + model steps ^. textValue `shouldBe` "This is a big dog" + + it "should input 'This string very long text is', and reject ' invalid' since maxLength == 40" $ do + let str = "This string very very long text is" + let steps = [evtT str, evtT " invalid"] + model steps ^. textValue `shouldBe` "This string very very long text is" + + it "should input 'This is text', select all and input 'No'" $ do + let str = "This is text" + let steps = [evtT str, evtKG keyA, evtT "No"] + model steps ^. textValue `shouldBe` "No" + + it "should input 'This is text', receive focus (with select on Focus) and input 'No'" $ do + let str = "This is text" + let steps = [evtT str, evtFocus, evtT "No"] + model steps ^. textValue `shouldBe` "No" + + it "should copy and paste text around" $ do + let str = "This is some long text" + let steps = [evtT str, selWordL, selWordL, selCharL, evtKG keyC, moveWordL, moveWordL, moveCharL, evtKG keyV] + model steps ^. textValue `shouldBe` "This long text is some long text" + + it "should cut and paste text around" $ do + let str = "This is long text" + let steps = [evtT str, selWordL, selCharL, evtKG keyX, moveWordL, moveWordL, moveCharL, evtKG keyV] + model steps ^. textValue `shouldBe` "This text is long" + + it "should generate an event when focus is received" $ do + events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + ctx [evtFocus] ^. L.renderSchedule `shouldSatisfy` (==1) . length + + it "should generate an event when focus is lost" $ do + events [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + ctx [evtFocus, evtBlur] ^. L.renderSchedule `shouldSatisfy` null + + where + wenv = mockWenv (TestModel "") + txtCfg = [maxLength 40, selectOnFocus, onFocus GotFocus, onBlur LostFocus] + txtNode = textField_ textValue txtCfg + model es = nodeHandleEventModel wenv es txtNode + events es = nodeHandleEventEvts wenv es txtNode + ctx evts = nodeHandleEventCtx wenv evts txtNode + +handleEventValue :: Spec +handleEventValue = describe "handleEventValue" $ do + it "should input an 'ab'" $ + evts [evtT "a", evtT "b"] `shouldBe` Seq.fromList [TextChanged "a", TextChanged "ab"] + + it "should input 'this is a dog', input '?', move to beginning and input 'Is '" $ do + let str = "this is a dog" + let steps = [evtT str, evtT "?", moveLineL, evtT "Is "] + lastEvt steps `shouldBe` TextChanged "Is this is a dog?" + + it "should input 'This is a dog', move before 'is', select 'is', deselect it and input 'nt'" $ do + let str = "This is a dog" + let steps = [evtT str, moveWordL, moveWordL, moveWordL, selWordR, moveCharR, evtT "n't"] + lastEvt steps `shouldBe` TextChanged "This isn't a dog" + + it "should input 'This is a dog', remove one word and input 'bird'" $ do + let str = "This is a dog" + let steps = [evtT str, delWordL, evtT "cat"] + lastEvt steps `shouldBe` TextChanged "This is a cat" + + it "should input 'This is a dog', select to beginning and input 'No'" $ do + let str = "This is a dog" + let steps = [evtT str, selLineL, evtT "No"] + lastEvt steps `shouldBe` TextChanged "No" + + it "should input 'This is a dog', move to beginning, select until end and input 'No'" $ do + let str = "This is a dog" + let steps = [evtT str, moveLineL, selLineR, evtT "No"] + lastEvt steps `shouldBe` TextChanged "No" + + it "should input 'a', move to beginning, input 'H', move to end and input 't'" $ do + let steps = [evtT "a", evtK keyHome, evtT "H", evtK keyEnd, evtT "t"] + lastEvt steps `shouldBe` TextChanged "Hat" + + it "should input 'abc', select to beginning, input 'def', move back twice, select to end and input 'dd'" $ do + let steps = [evtT "abc", evtKCS keyHome, evtT "def", moveCharL, moveCharL, evtKCS keyEnd, evtT "dd"] + lastEvt steps `shouldBe` TextChanged "ddd" + + it "should input 'abc123', move to beginning, select three letters, copy, move to end, paste" $ do + let steps = [evtT "abc123", evtKC keyHome, selCharR, selCharR, selCharR, evtKG keyC, evtK keyEnd, evtKG keyV] + lastEvt steps `shouldBe` TextChanged "abc123abc" + + where + wenv = mockWenv (TestModel "") + txtNode = textFieldV "" TextChanged + evts es = nodeHandleEventEvts wenv es txtNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleEventMouseSelect :: Spec +handleEventMouseSelect = describe "handleEventMouseSelect" $ do + it "should add text at the end, since click + drag started outside of viewport" $ do + let str = "This is text" + let selStart = Point 50 100 + let selEnd = Point 120 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "!"] + model steps ^. textValue `shouldBe` "This is text!" + + it "should drag around and input 'Text'" $ do + let str = "" + let selStart = Point 50 10 + let selMid1 = Point 0 10 + let selMid2 = Point 200 10 + let selMid3 = Point (-200) 10 + let selEnd = Point 120 10 + let moves = [evtMove selMid1, evtMove selMid2, evtMove selMid3, evtMove selEnd] + let steps = [evtT str, evtPress selStart] ++ moves ++ [evtRelease selEnd, evtT "Text"] + model steps ^. textValue `shouldBe` "Text" + + it "should input 'This is text', select 'is text' and input 'test'" $ do + let str = "This is text" + let selStart = Point 40 10 + let selEnd = Point 120 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "test"] + model steps ^. textValue `shouldBe` "This test" + + it "should input 'This is text', select all from beginning and input 'New'" $ do + let str = "This is new" + let selStart = Point 0 10 + let selEnd = Point 200 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "New"] + model steps ^. textValue `shouldBe` "New" + + it "should input 'This is text', select all from the end and input 'New'" $ do + let str = "This is" + let selStart = Point 70 10 + let selEnd = Point 0 10 + let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "New"] + model steps ^. textValue `shouldBe` "New" + + where + wenv = mockWenvEvtUnit (TestModel "") + txtNode = vstack [ + hstack [ + textField textValue `styleBasic` [width 105], + hstack [] + ] + ] + model es = nodeHandleEventModel wenv es txtNode + events es = nodeHandleEventEvts wenv es txtNode + +handleEventHistory :: Spec +handleEventHistory = describe "handleEventHistory" $ do + it "should input 'This is text', have the last word removed and then undo" $ do + let str = "This is text" + let steps1 = [evtT str, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ] + model steps1 ^. textValue `shouldBe` "This is " + model steps2 ^. textValue `shouldBe` "This is text" + lastEvt steps2 `shouldBe` TextChanged "This is text" + + it "should input 'This is text', have the last two words removed, undo and redo" $ do + let str = "This is text" + let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ, evtKG keyZ, evtKGS keyZ] + model steps1 ^. textValue `shouldBe` "This " + model steps2 ^. textValue `shouldBe` "This is " + lastEvt steps2 `shouldBe` TextChanged "This is " + + it "should input 'This is just a string', play around with history and come end up with 'This is just text" $ do + let str = "This is just a string" + let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKGS keyZ, evtKGS keyZ, evtT "text"] + model steps1 ^. textValue `shouldBe` "" + model steps2 ^. textValue `shouldBe` "This is just text" + lastEvt steps2 `shouldBe` TextChanged "This is just text" + + it "should input 'This is text', remove two words, undo, input 'not' and fail to redo" $ do + let str = "This is text" + let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace] + let steps2 = steps1 ++ [evtKG keyZ, evtT "not", evtKGS keyZ] + model steps1 ^. textValue `shouldBe` "This " + model steps2 ^. textValue `shouldBe` "This is not" + lastEvt steps2 `shouldBe` TextChanged "This is not" + + where + wenv = mockWenv (TestModel "") + txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus] + txtNode = textField_ textValue txtCfg + model es = nodeHandleEventModel wenv es txtNode + evts es = nodeHandleEventEvts wenv es txtNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +getSizeReq :: Spec +getSizeReq = describe "getSizeReq" $ do + it "should return width = Flex 100 1" $ + sizeReqW `shouldBe` expandSize 100 1 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (TestModel "Test value") + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (textField textValue) diff --git a/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs @@ -0,0 +1,293 @@ +{-| +Module : Monomer.Widgets.Singles.TimeFieldSpec +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 TimeField widget. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.TimeFieldSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +import Data.Default +import Data.Text (Text) +import Data.Time +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.TimeField + +import qualified Monomer.Lens as L + +data TestEvt + = TimeChanged TimeOfDay + | TimeValid Bool + | GotFocus Path + | LostFocus Path + deriving (Eq, Show) + +data TimeModel = TimeModel { + _imTimeValue :: TimeOfDay, + _imTimeValid :: Bool +} deriving (Eq, Show) + +instance Default TimeModel where + def = TimeModel { + _imTimeValue = midnight, + _imTimeValid = True + } + +data MTimeModel = MTimeModel { + _imMTimeValue :: Maybe TimeOfDay, + _imMTimeValid :: Bool +} deriving (Eq, Show) + +instance Default MTimeModel where + def = MTimeModel { + _imMTimeValue = Nothing, + _imMTimeValid = True + } + +makeLensesWith abbreviatedFields ''TimeModel +makeLensesWith abbreviatedFields ''MTimeModel + +spec :: Spec +spec = describe "TimeField" $ do + handleEventTime + handleEventValueTime + handleEventMouseDragTime + handleShiftFocus + getSizeReqTime + +handleEventTime :: Spec +handleEventTime = describe "handleEventTime" $ do + it "should remove the contents and get Nothing as model value" $ do + modelBasic [evtKG keyA, evtK keyBackspace] ^. mTimeValue `shouldBe` Nothing + modelBasic [evtKG keyA, evtK keyBackspace] ^. mTimeValid `shouldBe` True + + it "should input '01:30'" $ do + modelBasic [evtKG keyA, evtT "01", evtT ":30"] ^. mTimeValue `shouldBe` Just (TimeOfDay 1 30 0) + modelBasic [evtKG keyA, evtT "01", evtT ":30"] ^. mTimeValid `shouldBe` True + + it "should input '1' (invalid time)" $ do + model [evtKG keyA, evtT "1"] ^. mTimeValue `shouldBe` Just midTime + model [evtKG keyA, evtT "1"] ^. mTimeValid `shouldBe` False + events [evtKG keyA, evtT "1"] `shouldBe` Seq.fromList [TimeValid False] + + it "should input '02:35' but fail because of minValue" $ do + model [evtT "02:35"] ^. mTimeValue `shouldBe` Just midTime + model [evtT "02:35"] ^. mTimeValid `shouldBe` False + events [evtT "02:35"] `shouldBe` Seq.fromList [TimeValid False] + + it "should input '23:50' but fail because of maxValue" $ do + model [evtT "23:50"] ^. mTimeValue `shouldBe` Just midTime + model [evtT "23:50"] ^. mTimeValid `shouldBe` False + events [evtT "23:50"] `shouldBe` Seq.fromList [TimeValid False] + + it "should remove one character and input '4'" $ do + model [moveCharR, delCharL, evtT "4"] ^. mTimeValue `shouldBe` Just (TimeOfDay 14 24 0) + model [moveCharR, delCharL, evtT "4"] ^. mTimeValid `shouldBe` True + events [moveCharR, delCharL, evtT "4"] `shouldBe` Seq.fromList [TimeValid True, TimeValid True] + + it "should input '22:30', remove one word and input '15'" $ do + model [evtT "22:30", delWordL, evtT "15"] ^. mTimeValue `shouldBe` Just (TimeOfDay 22 15 0) + model [evtT "22:30", delWordL, evtT "15"] ^. mTimeValid `shouldBe` True + events [evtT "22:30", delWordL, evtT "15"] `shouldBe` Seq.fromList [TimeValid True, TimeValid False, TimeValid True] + + it "should update the model when using the wheel" $ do + let p = Point 100 10 + let steps1 = [WheelScroll p (Point 0 (-2000)) WheelNormal] + let steps2 = [WheelScroll p (Point 0 (-64)) WheelNormal] + let steps3 = [WheelScroll p (Point 0 64) WheelNormal] + let steps4 = [WheelScroll p (Point 0 (-2000)) WheelFlipped] + model steps1 ^. mTimeValue `shouldBe` Just minTime + model steps2 ^. mTimeValue `shouldBe` Just (TimeOfDay 13 16 0) + model steps3 ^. mTimeValue `shouldBe` Just (TimeOfDay 15 24 0) + model steps4 ^. mTimeValue `shouldBe` Just maxTime + + it "should generate an event when focus is received" $ + events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) + + it "should generate an event when focus is lost" $ + events [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath) + + where + minTime = TimeOfDay 3 15 0 + midTime = TimeOfDay 14 20 0 + maxTime = TimeOfDay 23 45 0 + wenv = mockWenv (MTimeModel (Just midTime) True) + basicTimeNode :: WidgetNode MTimeModel TestEvt + basicTimeNode = timeField_ mTimeValue [validInput mTimeValid, selectOnFocus_ False] + timeCfg = [minValue (Just minTime), maxValue (Just maxTime), validInput mTimeValid, validInputV TimeValid, onFocus GotFocus, onBlur LostFocus] + timeNode = timeField_ mTimeValue timeCfg + model es = nodeHandleEventModel wenv (evtFocus : es) timeNode + modelBasic es = nodeHandleEventModel wenv es basicTimeNode + events es = nodeHandleEventEvts wenv es timeNode + +handleEventValueTime :: Spec +handleEventValueTime = describe "handleEventTime" $ do + it "should input an '12:07:48'" $ + evts [evtT "12:07:48"] `shouldBe` Seq.fromList [TimeChanged (TimeOfDay 12 07 48)] + + it "should move right, delete one character and input '5'" $ do + let steps = [moveCharR, delCharL, evtT "5"] + lastEvt steps `shouldBe` TimeChanged (TimeOfDay 13 35 25) + model steps ^. timeValid `shouldBe` True + + it "should move right and delete one word" $ do + let steps = [moveCharR, delWordL] + evts steps `shouldBe` Seq.empty + model steps ^. timeValid `shouldBe` False + + it "should input '04:20:', input '.', 'a', then input '10'" $ do + let steps = [evtT "04:20:", evtT ".", evtT "a", evtT "10"] + lastEvt steps `shouldBe` TimeChanged lowTime + model steps ^. timeValid `shouldBe` True + + it "should input '22:5644:4555'" $ do + let steps = [evtT "22", evtT ":56", evtT "44", evtT ":45", evtT "55"] + lastEvt steps `shouldBe` TimeChanged maxTime + + where + minTime = TimeOfDay 1 35 30 + lowTime = TimeOfDay 4 20 10 + midTime = TimeOfDay 13 35 20 + maxTime = TimeOfDay 22 56 45 + wenv = mockWenv (TimeModel minTime True) + timeNode = timeFieldV_ midTime TimeChanged [minValue minTime, maxValue maxTime, selectOnFocus, validInput timeValid, timeFormatHHMMSS] + evts es = nodeHandleEventEvts wenv (evtFocus : es) timeNode + model es = nodeHandleEventModel wenv (evtFocus : es) timeNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleEventMouseDragTime :: Spec +handleEventMouseDragTime = describe "handleEventMouseDragTime" $ do + it "should drag upwards 100 pixels, setting the value to 18:50:15" $ do + let selStart = Point 50 50 + let selEnd = Point 50 (-70) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` TimeOfDay 18 50 15 + + it "should drag downwards 100 pixels, setting the value to 11:30:15 (dragRate = 2)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 150 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` TimeOfDay 11 30 15 + + it "should drag downwards 10000 pixels, staying at minTime (the minimum)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 10050 + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` minTime + + it "should drag upwnwards 10000 pixels, staying at maxTime (the maximum)" $ do + let selStart = Point 50 50 + let selEnd = Point 50 (-1950) + let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` maxTime + + it "should drag downwards 30 and 20 pixels, setting the value to 14:30:15" $ do + let selStart = Point 50 50 + let selMid = Point 50 60 + let selEnd = Point 50 50 + let steps = [ + evtPress selStart, evtMove selMid, evtRelease selMid, + evtPress selStart, evtMove selEnd, evtRelease selEnd + ] + model steps ^. timeValue `shouldBe` TimeOfDay 14 30 15 + + it "should set focus and drag upwards 100 pixels, but value stay at midTime since shift is not pressed" $ do + let selStart = Point 50 50 + let selEnd = Point 50 (-70) + let steps = [evtK keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` midTime + + it "should set focus and drag upwards 100 pixels, setting the value to 18:50:15 since shift is pressed" $ do + let selStart = Point 50 50 + let selEnd = Point 50 (-70) + let steps = [evtKS keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` TimeOfDay 18 50 15 + + it "should drag upwards 100 pixels, setting the value to 18:50:15 even if it was double clicked on" $ do + let selStart = Point 50 50 + let selEnd = Point 50 (-70) + let steps = [evtDblClick selStart, evtPress selStart, evtMove selEnd, evtRelease selEnd] + model steps ^. timeValue `shouldBe` TimeOfDay 18 50 15 + + it "should generate a focus event when clicked" $ do + let p = Point 50 50 + -- Presses a key to reset the shift = true state + evts [evtK keyA, evtPress p] `shouldBe` Seq.singleton (GotFocus (Seq.fromList [0, 0])) + + it "should not generate a focus event when clicked if shift is pressed" $ do + let p = Point 50 50 + evts [evtKS keyA, evtPress p] `shouldBe` Seq.empty + + where + minTime = TimeOfDay 01 20 30 + midTime = TimeOfDay 14 50 15 + maxTime = TimeOfDay 23 40 50 + wenv = mockWenv (TimeModel midTime True) + & L.inputStatus . L.keyMod . L.leftShift .~ True + timeNode = vstack [ + button "Test" (TimeChanged midTime), -- Used only to have focus + timeField timeValue, + timeField_ timeValue [dragRate 2, minValue minTime, maxValue maxTime, timeFormatHHMMSS, onFocus GotFocus] + ] + evts es = nodeHandleEventEvts wenv es timeNode + model es = nodeHandleEventModel wenv es timeNode + lastIdx es = Seq.index es (Seq.length es - 1) + lastEvt es = lastIdx (evts es) + +handleShiftFocus :: Spec +handleShiftFocus = describe "handleShiftFocus" $ do + it "should set focus when clicked" $ do + evts [evtPress p] `shouldBe` Seq.fromList [GotFocus $ Seq.fromList [0, 0]] + + it "should not set focus when clicked with shift pressed" $ do + evts [evtKS keyA, evtPress p] `shouldBe` Seq.empty + + where + wenv = mockWenv (TimeModel (TimeOfDay 14 50 15) True) + p = Point 100 30 + floatNode = vstack [ + timeField_ timeValue [wheelRate 1], + timeField_ timeValue [wheelRate 1, onFocus GotFocus] + ] + evts es = nodeHandleEventEvts wenv es floatNode + +getSizeReqTime :: Spec +getSizeReqTime = describe "getSizeReqTime" $ do + it "should return width = Flex 160 1" $ + sizeReqW `shouldBe` expandSize 160 1 + + it "should return height = Fixed 20" $ + sizeReqH `shouldBe` fixedSize 20 + + it "should return width = Flex 100 1 when resizeOnChange = True" $ + sizeReqW2 `shouldBe` expandSize 100 1 + + it "should return height = Fixed 20 when resizeOnChange = True" $ + sizeReqH2 `shouldBe` fixedSize 20 + + where + wenv = mockWenvEvtUnit (def :: TimeModel) + (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (timeField timeValue) + timeResize = timeField_ timeValue [resizeOnChange] + (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv timeResize diff --git a/test/unit/Monomer/Widgets/Util/FocusSpec.hs b/test/unit/Monomer/Widgets/Util/FocusSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Util/FocusSpec.hs @@ -0,0 +1,99 @@ +{-| +Module : Monomer.Widgets.Util.FocusSpec +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 Focus handling. +-} +module Monomer.Widgets.Util.FocusSpec (spec) where + +import Control.Lens ((&), (^.), (.~), ix) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Util.Focus +import Monomer.TestUtil + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Focus" $ do + testParentPath + testNextTargetStep + testIsFocusCandidate + +testParentPath :: Spec +testParentPath = describe "parentPath" $ do + it "should return root path" $ do + parentPath (pathNode []) `shouldBe` emptyPath + parentPath (pathNode [0]) `shouldBe` emptyPath + + it "should return a single element path" $ do + parentPath (pathNode [0, 1]) `shouldBe` Seq.fromList [0] + parentPath (pathNode [1, 4]) `shouldBe` Seq.fromList [1] + + it "should return a multiple element path" $ do + parentPath (pathNode [0, 1, 2]) `shouldBe` Seq.fromList [0, 1] + parentPath (pathNode [0, 1, 2, 3, 4]) `shouldBe` Seq.fromList [0, 1, 2, 3] + +testNextTargetStep :: Spec +testNextTargetStep = describe "nextTargetStep" $ do + it "should return Nothing if next step is not valid" $ do + nextTargetStep (pathNode []) (path []) `shouldBe` Nothing + nextTargetStep (pathNode_ [] 5) (path []) `shouldBe` Nothing + nextTargetStep (pathNode_ [0] 5) (path [0]) `shouldBe` Nothing + nextTargetStep (pathNode_ [0] 5) (path [3]) `shouldBe` Nothing + + it "should return a valid target step" $ do + nextTargetStep (pathNode_ [] 5) (path [2]) `shouldBe` Just 2 + nextTargetStep (pathNode_ [0] 5) (path [0, 3]) `shouldBe` Just 3 + +testIsFocusCandidate :: Spec +testIsFocusCandidate = describe "isFocusCandidate" $ do + it "should return False if not backward candidate" $ do + isFocusCandidate (pathNode [0]) (path [0]) FocusBwd `shouldBe` False + isFocusCandidate (pathNode [0, 1]) (path [0, 0]) FocusBwd `shouldBe` False + + it "should return True if backward candidate" $ do + isFocusCandidate (pathNode []) (path []) FocusBwd `shouldBe` True + isFocusCandidate (pathNode []) (path [0]) FocusBwd `shouldBe` True + isFocusCandidate (pathNode [0]) (path [1]) FocusBwd `shouldBe` True + isFocusCandidate (pathNode [0, 0]) (path [0, 1]) FocusBwd `shouldBe` True + isFocusCandidate (pathNode [0, 0]) (path [0, 0, 1]) FocusBwd `shouldBe` True + isFocusCandidate (pathNode [0, 1, 1]) (path [0, 2]) FocusBwd `shouldBe` True + + it "should return False if not forward candidate" $ do + isFocusCandidate (pathNode []) (path []) FocusFwd `shouldBe` False + isFocusCandidate (pathNode []) (path [0]) FocusFwd `shouldBe` False + isFocusCandidate (pathNode [0]) (path [1]) FocusFwd `shouldBe` False + isFocusCandidate (pathNode [0, 0]) (path [0, 1]) FocusFwd `shouldBe` False + + it "should return True if forward candidate" $ do + isFocusCandidate (pathNode [0]) (path []) FocusFwd `shouldBe` True + isFocusCandidate (pathNode [1]) (path [0]) FocusFwd `shouldBe` True + isFocusCandidate (pathNode [0, 1]) (path [0, 0]) FocusFwd `shouldBe` True + isFocusCandidate (pathNode [0, 2]) (path [0, 1, 1]) FocusFwd `shouldBe` True + +path :: [PathStep] -> Path +path p = Seq.fromList p + +pathNode :: [PathStep] -> WidgetNode s e +pathNode path = pathNode_ path 0 + +pathNode_ :: [PathStep] -> Int -> WidgetNode s e +pathNode_ path childCount = newNode where + mkChild idx = pathNode_ (path ++ [idx]) 0 + newNode = label "Test" + & L.info . L.path .~ Seq.fromList path + & L.info . L.visible .~ True + & L.info . L.enabled .~ True + & L.info . L.focusable .~ True + & L.children .~ Seq.fromList (fmap mkChild [0..childCount - 1]) diff --git a/test/unit/Monomer/Widgets/Util/StyleSpec.hs b/test/unit/Monomer/Widgets/Util/StyleSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Util/StyleSpec.hs @@ -0,0 +1,149 @@ +{-| +Module : Monomer.Widgets.Util.StyleSpec +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 Style handling. +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Util.StyleSpec (spec) where + +import Control.Lens ((&), (^.), (^?), (^?!), (.~), (?~), _Just, at, ix, non) +import Data.Default +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Event +import Monomer.Graphics +import Monomer.Graphics.ColorTable +import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Util.Style +import Monomer.TestEventUtil +import Monomer.TestUtil + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Style" $ do + testCurrentStyle + testHandleSizeChange + +testCurrentStyle :: Spec +testCurrentStyle = describe "currentStyle" $ do + it "should return basic style" $ + currentStyle wenvBasic nodeNormal ^. L.bgColor `shouldBe` Just white + + it "should return hover style" $ + currentStyle wenvHover nodeNormal ^. L.bgColor `shouldBe` Just green + + it "should return hover style" $ + currentStyle wenvFocus nodeNormal ^. L.bgColor `shouldBe` Just blue + + it "should return focusHover style" $ + currentStyle wenvHoverFocus nodeNormal ^. L.bgColor `shouldBe` Just orange + + it "should return active style" $ + currentStyle wenvActive nodeNormal ^. L.bgColor `shouldBe` Just pink + + it "should return disabled style" $ do + currentStyle wenvBasic nodeDisabled ^. L.bgColor `shouldBe` Just gray + currentStyle wenvHover nodeDisabled ^. L.bgColor `shouldBe` Just gray + currentStyle wenvFocus nodeDisabled ^. L.bgColor `shouldBe` Just gray + currentStyle wenvHoverFocus nodeDisabled ^. L.bgColor `shouldBe` Just gray + + where + wenvBasic = mockWenv () & L.inputStatus . L.mousePos .~ Point 0 0 + wenvFocus = wenvBasic & L.focusedPath .~ Seq.fromList [0] + wenvHover = mockWenv () & L.inputStatus . L.mousePos .~ Point 200 200 + wenvHoverFocus = wenvHover + & L.inputStatus . L.mousePos .~ Point 200 200 + & L.focusedPath .~ Seq.fromList [0] + wenvActive = mockWenv () + & L.inputStatus . L.mousePos .~ Point 200 200 + & L.mainBtnPress ?~ (Seq.fromList [0], Point 200 200) + nodeNormal = createNode True + nodeDisabled = createNode False + +testHandleSizeChange :: Spec +testHandleSizeChange = describe "handleSizeChange" $ do + it "should request Resize widgets if sizeReq changed" $ do + resHover ^? _Just . L.requests `shouldSatisfy` (==3) . maybeLength + resHover ^? _Just . L.requests . ix 0 `shouldSatisfy` isMSetCursorIcon + resHover ^? _Just . L.requests . ix 1 `shouldSatisfy` isMResizeWidgets + resHover ^? _Just . L.requests . ix 2 `shouldSatisfy` isMRenderOnce + + it "should not request Resize widgets if sizeReq has not changed" $ + resFocus ^? _Just . L.requests `shouldSatisfy` (==0) . maybeLength + + where + wenv = mockWenv () + style = createStyle + & L.hover ?~ padding 10 + & L.hover . non def . L.cursorIcon ?~ CursorHand + hoverStyle = style ^?! L.hover . _Just + focusStyle = style ^?! L.focus . _Just + baseNode = createNode True + & L.info . L.style .~ style + node = nodeInit wenv baseNode + modNode = node & L.info . L.sizeReqW .~ fixedSize 100 + res1 = Just $ WidgetResult modNode Empty + res2 = Just $ WidgetResult node Empty + point = Point 200 200 + path = Seq.fromList [0] + wenvHover = mockWenv () & L.inputStatus . L.mousePos .~ point + wenvFocus = mockWenv () & L.focusedPath .~ path + evEnter = Enter point + resHover = handleStyleChange wenvHover path hoverStyle True node evEnter res1 + resFocus = handleStyleChange wenvFocus path focusStyle True node evtFocus res2 + +isMResizeWidgets :: Maybe (WidgetRequest s e) -> Bool +isMResizeWidgets (Just ResizeWidgets{}) = True +isMResizeWidgets _ = False + +isMRenderOnce :: Maybe (WidgetRequest s e) -> Bool +isMRenderOnce (Just RenderOnce{}) = True +isMRenderOnce _ = False + +isMSetCursorIcon :: Maybe (WidgetRequest s e) -> Bool +isMSetCursorIcon (Just SetCursorIcon{}) = True +isMSetCursorIcon _ = False + +maybeLength :: Maybe (Seq a) -> Int +maybeLength Nothing = 0 +maybeLength (Just s) = Seq.length s + +createStyle :: Style +createStyle = newStyle where + basic = createStyleState 10 white + hover = createStyleState 20 green + focus = createStyleState 30 blue + focusHover = createStyleState 30 orange + active = createStyleState 30 pink + disabled = createStyleState 40 gray + newStyle = Style basic hover focus focusHover active disabled + +createStyleState :: Double -> Color -> Maybe StyleState +createStyleState size col = Just newState where + newState = textSize size <> bgColor col + +createNode :: Bool -> WidgetNode s e +createNode enabled = newNode where + viewport = Rect 100 100 200 200 + newNode = label "Test" + & L.info . L.path .~ Seq.fromList [0] + & L.info . L.viewport .~ viewport + & L.info . L.style .~ createStyle + & L.info . L.visible .~ True + & L.info . L.enabled .~ enabled + & L.info . L.focusable .~ True diff --git a/test/unit/Monomer/Widgets/Util/TextSpec.hs b/test/unit/Monomer/Widgets/Util/TextSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Util/TextSpec.hs @@ -0,0 +1,194 @@ +{-| +Module : Monomer.Widgets.Util.TextSpec +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 Text handling. +-} +module Monomer.Widgets.Util.TextSpec (spec) where + +import Control.Lens ((^.), ix) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Core.Combinators +import Monomer.Graphics +import Monomer.Widgets.Util.Text +import Monomer.TestUtil + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Text" $ do + fitTextSingle + fitTextMulti + fitTextSpace + +fitTextSingle :: Spec +fitTextSingle = describe "fitTextToSize single line" $ do + it "should return the same empty text, trimmed (ellipsis)" $ + elpsTrim "" ^. ix 0 . L.text `shouldBe` "" + + it "should return the same empty text, untrimmed (ellipsis)" $ + elpsKeep "" ^. ix 0 . L.text `shouldBe` "" + + it "should return the same empty text, trimmed (clip)" $ + clipTrim "" ^. ix 0 . L.text `shouldBe` "" + + it "should return the same empty text, untrimmed (clip)" $ + clipKeep "" ^. ix 0 . L.text `shouldBe` "" + + it "should return the same text, trimmed, if it fits (ellipsis)" $ + elpsTrim "Text " ^. ix 0 . L.text `shouldBe` "Text" + + it "should return the same text, untrimmed, if it fits (ellipsis)" $ + elpsKeep "Text " ^. ix 0 . L.text `shouldBe` "Text " + + it "should return the same text, trimmed, if it fits (clip)" $ + clipTrim "Text " ^. ix 0 . L.text `shouldBe` "Text" + + it "should return the same text, untrimmed, if it fits (clip)" $ + clipKeep "Text " ^. ix 0 . L.text `shouldBe` "Text " + + it "should return text with ellipsis, trimmed, if it does not fit" $ do + elpsTrim "This is longer\nMore" `shouldSatisfy` singleElement + elpsTrim "This is longer\nMore" ^. ix 0 . L.text `shouldBe` "This is l..." + elpsTrim "This is a bit longer\nMore" `shouldSatisfy` singleElement + elpsTrim "This is a bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is a..." + + it "should return text with ellipsis, untrimmed, if it does not fit" $ do + elpsKeep "This is longer\nMore" `shouldSatisfy` singleElement + elpsKeep "This is longer\nMore" ^. ix 0 . L.text `shouldBe` "This is l..." + elpsKeep "This is a bit longer\nMore" `shouldSatisfy` singleElement + elpsKeep "This is a bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is a..." + + it "should return text clipped, trimmed, if it does not fit" $ do + clipTrim "This is longer\nMore" `shouldSatisfy` singleElement + clipTrim "This is longer\nMore" ^. ix 0 . L.text `shouldBe` "This is long" + clipTrim "This is not a bit longer\nMore" `shouldSatisfy` singleElement + clipTrim "This is not a bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is not" + + it "should return text clipped, untrimmed, if it does not fit" $ do + clipKeep "This is longer\nMore" `shouldSatisfy` singleElement + clipKeep "This is longer\nMore" ^. ix 0 . L.text `shouldBe` "This is long" + clipKeep "This is not a bit longer\nMore" `shouldSatisfy` singleElement + clipKeep "This is not a bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is not " + + where + wenv = mockWenv () + fontMgr = wenv ^. L.fontManager + style = def + sizeE = Size 120 20 + sizeC = Size 120 10 + elpsTrim text = fitTextToSize fontMgr style Ellipsis SingleLine TrimSpaces Nothing sizeE text + elpsKeep text = fitTextToSize fontMgr style Ellipsis SingleLine KeepSpaces Nothing sizeE text + clipTrim text = fitTextToSize fontMgr style ClipText SingleLine TrimSpaces Nothing sizeC text + clipKeep text = fitTextToSize fontMgr style ClipText SingleLine KeepSpaces Nothing sizeC text + singleElement sq = Seq.length sq == 1 + +fitTextMulti :: Spec +fitTextMulti = describe "fitTextToSize multi line" $ do + it "should return the same text, trimmed, if it fits" $ do + elpsTrim "Text " `shouldSatisfy` elementCount 1 + elpsTrim "Text " ^. ix 0 . L.text `shouldBe` "Text" + + it "should return the same text, untrimmed, if it fits" $ do + elpsKeep "Text " `shouldSatisfy` elementCount 1 + elpsKeep "Text " ^. ix 0 . L.text `shouldBe` "Text " + + -- Text.lines does not return an extra line if the last element is \n + it "should return several empty lines" $ do + elpsTrim_ sizeTall "Text\n\n\n\n" `shouldSatisfy` elementCount 4 + elpsKeep_ sizeTall "Text\n\n\n\n" `shouldSatisfy` elementCount 4 + clipTrim_ sizeTall "Text\n\n\n\n" `shouldSatisfy` elementCount 4 + clipKeep_ sizeTall "Text\n\n\n\n" `shouldSatisfy` elementCount 4 + + it "should return several empty lines and one with text" $ do + elpsTrim_ sizeTall "Text\n\n\n\nend" `shouldSatisfy` elementCount 5 + elpsKeep_ sizeTall "Text\n\n\n\nend" `shouldSatisfy` elementCount 5 + clipTrim_ sizeTall "Text\n\n\n\nend" `shouldSatisfy` elementCount 5 + clipKeep_ sizeTall "Text\n\n\n\nend" `shouldSatisfy` elementCount 5 + + it "should return text with ellipsis, trimmed, if it does not fit" $ do + elpsTrim "This is really-long\nMore" `shouldSatisfy` elementCount 2 + elpsTrim "This is really-long\nMore" ^. ix 0 . L.text `shouldBe` "This is" + elpsTrim "This is really-long\nMore" ^. ix 1 . L.text `shouldBe` "reall..." + elpsTrim "This is a tad bit longer\nMore" `shouldSatisfy` elementCount 2 + elpsTrim "This is a tad bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is" + elpsTrim "This is a tad bit longer\nMore" ^. ix 1 . L.text `shouldBe` "a tad..." + + it "should return text with ellipsis, untrimmed, if it does not fit" $ do + elpsKeep "This is really-long\nMore" `shouldSatisfy` elementCount 2 + elpsKeep "This is really-long\nMore" ^. ix 0 . L.text `shouldBe` "This is " + elpsKeep "This is really-long\nMore" ^. ix 1 . L.text `shouldBe` " ..." + elpsKeep "This is a tad bit longer\nMore" `shouldSatisfy` elementCount 2 + elpsKeep "This is a tad bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is " + elpsKeep "This is a tad bit longer\nMore" ^. ix 1 . L.text `shouldBe` " a ..." + + it "should return text clipped, trimmed, if it does not fit" $ do + clipTrim "This is really-long\nMore" `shouldSatisfy` elementCount 3 + clipTrim "This is really-long\nMore" ^. ix 0 . L.text `shouldBe` "This is" + clipTrim "This is really-long\nMore" ^. ix 1 . L.text `shouldBe` "really-long" + clipTrim "This is really-long\nMore" ^. ix 2 . L.text `shouldBe` "More" + clipTrim "This is a tad bit longer\nMore" `shouldSatisfy` elementCount 3 + clipTrim "This is a tad bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is" + clipTrim "This is a tad bit longer\nMore" ^. ix 1 . L.text `shouldBe` "a tad" + clipTrim "This is a tad bit longer\nMore" ^. ix 2 . L.text `shouldBe` "bit" + + it "should return text clipped, untrimmed, if it does not fit" $ do + clipKeep "This is really-long\nMore" `shouldSatisfy` elementCount 3 + clipKeep "This is really-long\nMore" ^. ix 0 . L.text `shouldBe` "This is " + clipKeep "This is really-long\nMore" ^. ix 1 . L.text `shouldBe` " " + clipKeep "This is really-long\nMore" ^. ix 2 . L.text `shouldBe` "really-long" + clipKeep "This is a tad bit longer\nMore" `shouldSatisfy` elementCount 3 + clipKeep "This is a tad bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is " + 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 " + + where + wenv = mockWenv () + fontMgr = wenv ^. L.fontManager + style = def + sizeE = Size 80 40 + sizeC = Size 80 50 + sizeTall = Size 80 200 + elpsTrim text = elpsTrim_ sizeE text + elpsKeep text = elpsKeep_ sizeE text + clipTrim text = clipTrim_ sizeC text + clipKeep text = clipKeep_ sizeC text + elpsTrim_ size text = fitTextToSize fontMgr style Ellipsis MultiLine TrimSpaces Nothing size text + 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 + elementCount count sq = Seq.length sq == count + +fitTextSpace :: Spec +fitTextSpace = describe "fitTextToWidth with spacing" $ do + it "should fit text in (100, 80)" $ + textSize style longText `shouldBe` Size 100 80 + + it "should fit text in (96, 120)" $ + textSize styleH longText `shouldBe` Size 96 120 + + it "should fit text in (100, 95)" $ + textSize styleV longText `shouldBe` Size 100 95 + + it "should fit text in (96, 145)" $ + textSize styleHV longText `shouldBe` Size 96 145 + + where + wenv = mockWenv () + fontMgr = wenv ^. L.fontManager + style = def + styleH = textSpaceH 2 + styleV = textSpaceV 5 + styleHV = textSpaceH 2 <> textSpaceV 5 + longText = "This is a long piece of text to test space" + textSize style text = getTextLinesSize (fitTextToWidth fontMgr style 100 TrimSpaces text) diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Spec.hs @@ -0,0 +1,135 @@ +-- {-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +import Test.Hspec + +import qualified SDL +import qualified SDL.Raw as Raw + +import qualified Monomer.Common.CursorIconSpec as CursorIconSpec +import qualified Monomer.Graphics.UtilSpec as GraphicsUtilSpec + +import qualified Monomer.Widgets.CompositeSpec as CompositeSpec +import qualified Monomer.Widgets.ContainerSpec as ContainerSpec + +import qualified Monomer.Widgets.Animation.FadeSpec as AnimationFadeSpec +import qualified Monomer.Widgets.Animation.SlideSpec as AnimationSlideSpec + +import qualified Monomer.Widgets.Containers.AlertSpec as AlertSpec +import qualified Monomer.Widgets.Containers.BoxSpec as BoxSpec +import qualified Monomer.Widgets.Containers.ConfirmSpec as ConfirmSpec +import qualified Monomer.Widgets.Containers.DragDropSpec as DragDropSpec +import qualified Monomer.Widgets.Containers.DropdownSpec as DropdownSpec +import qualified Monomer.Widgets.Containers.GridSpec as GridSpec +import qualified Monomer.Widgets.Containers.KeystrokeSpec as KeystrokeSpec +import qualified Monomer.Widgets.Containers.ScrollSpec as ScrollSpec +import qualified Monomer.Widgets.Containers.SelectListSpec as SelectListSpec +import qualified Monomer.Widgets.Containers.SplitSpec as SplitSpec +import qualified Monomer.Widgets.Containers.StackSpec as StackSpec +import qualified Monomer.Widgets.Containers.ThemeSwitchSpec as ThemeSwitchSpec +import qualified Monomer.Widgets.Containers.TooltipSpec as TooltipSpec +import qualified Monomer.Widgets.Containers.ZStackSpec as ZStackSpec + +import qualified Monomer.Widgets.Singles.ButtonSpec as ButtonSpec +import qualified Monomer.Widgets.Singles.CheckboxSpec as CheckboxSpec +import qualified Monomer.Widgets.Singles.ColorPickerSpec as ColorPickerSpec +import qualified Monomer.Widgets.Singles.DateFieldSpec as DateFieldSpec +import qualified Monomer.Widgets.Singles.DialSpec as DialSpec +import qualified Monomer.Widgets.Singles.ExternalLinkSpec as ExternalLinkSpec +import qualified Monomer.Widgets.Singles.ImageSpec as ImageSpec +import qualified Monomer.Widgets.Singles.LabeledCheckboxSpec as LabeledCheckboxSpec +import qualified Monomer.Widgets.Singles.LabeledRadioSpec as LabeledRadioSpec +import qualified Monomer.Widgets.Singles.LabelSpec as LabelSpec +import qualified Monomer.Widgets.Singles.NumericFieldSpec as NumericFieldSpec +import qualified Monomer.Widgets.Singles.RadioSpec as RadioSpec +import qualified Monomer.Widgets.Singles.SeparatorLineSpec as SeparatorLineSpec +import qualified Monomer.Widgets.Singles.SliderSpec as SliderSpec +import qualified Monomer.Widgets.Singles.SpacerSpec as SpacerSpec +import qualified Monomer.Widgets.Singles.TextFieldSpec as TextFieldSpec +import qualified Monomer.Widgets.Singles.TextAreaSpec as TextAreaSpec +import qualified Monomer.Widgets.Singles.TimeFieldSpec as TimeFieldSpec + +import qualified Monomer.Widgets.Util.FocusSpec as FocusSpec +import qualified Monomer.Widgets.Util.StyleSpec as StyleSpec +import qualified Monomer.Widgets.Util.TextSpec as TextSpec + +main :: IO () +main = do + -- Initialize SDL + SDL.initialize [SDL.InitVideo] + -- Run tests + hspec spec + -- Shutdown SDL + Raw.quitSubSystem Raw.SDL_INIT_VIDEO + SDL.quit + +spec :: Spec +spec = do + common + graphics + widgets + widgetsUtil + +common :: Spec +common = describe "Common" $ do + CursorIconSpec.spec + +graphics :: Spec +graphics = describe "Graphics" $ do + GraphicsUtilSpec.spec + +widgets :: Spec +widgets = describe "Widgets" $ do + CompositeSpec.spec + ContainerSpec.spec + animation + containers + singles + +animation :: Spec +animation = describe "Animation" $ do + AnimationFadeSpec.spec + AnimationSlideSpec.spec + +containers :: Spec +containers = describe "Containers" $ do + AlertSpec.spec + BoxSpec.spec + ConfirmSpec.spec + DragDropSpec.spec + DropdownSpec.spec + GridSpec.spec + KeystrokeSpec.spec + ScrollSpec.spec + SelectListSpec.spec + SplitSpec.spec + StackSpec.spec + ThemeSwitchSpec.spec + TooltipSpec.spec + ZStackSpec.spec + +singles :: Spec +singles = describe "Singles" $ do + ButtonSpec.spec + CheckboxSpec.spec + ColorPickerSpec.spec + DateFieldSpec.spec + DialSpec.spec + ExternalLinkSpec.spec + ImageSpec.spec + LabelSpec.spec + LabeledCheckboxSpec.spec + LabeledRadioSpec.spec + NumericFieldSpec.spec + RadioSpec.spec + SeparatorLineSpec.spec + SliderSpec.spec + SpacerSpec.spec + TextAreaSpec.spec + TextFieldSpec.spec + TimeFieldSpec.spec + +widgetsUtil :: Spec +widgetsUtil = describe "Widgets Util" $ do + FocusSpec.spec + StyleSpec.spec + TextSpec.spec