packages feed

monomer (empty) → 1.0.0.0

raw patch · 174 files changed

+40432/−0 lines, 174 filesdep +HUnitdep +JuicyPixelsdep +OpenGLsetup-changed

Dependencies added: HUnit, JuicyPixels, OpenGL, aeson, async, attoparsec, base, bytestring, bytestring-to-vector, containers, data-default, directory, exceptions, extra, formatting, hspec, http-client, lens, monomer, mtl, nanovg, process, random, safe, scientific, sdl2, silently, stm, text, text-show, time, transformers, unordered-containers, vector, websockets, wreq, wuss

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+### 1.0.0.0++Initial public release++- Supports Windows, Linux and macOS
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/dpi.c view
@@ -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
+ cbits/fontmanager.c view
@@ -0,0 +1,171 @@+// Based on code from memononen's https://github.com/memononen/nanovg++#include <stdio.h>+#include <stdlib.h>+#include <memory.h>++#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;+}
+ cbits/fontmanager.h view
@@ -0,0 +1,57 @@+// Based on code from memononen's https://github.com/memononen/nanovg++#ifndef FONT_MANAGER_H+#define FONT_MANAGER_H++#include <stdio.h>+#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
+ cbits/glew.c view
@@ -0,0 +1,21 @@+// Based on code from cocreature's https://github.com/cocreature/nanovg-hs++#include <GL/glew.h>+#include <stdio.h>++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();+  }+}
+ examples/books/BookTypes.hs view
@@ -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
+ examples/books/Main.hs view
@@ -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/<id>-<size>.jpg"+  imgUrl i = T.replace "<size>" size $ T.replace "<id>" (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
+ examples/generative/GenerativeTypes.hs view
@@ -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)
+ examples/generative/Main.hs view
@@ -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"
+ examples/generative/Widgets/BoxesPalette.hs view
@@ -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)
+ examples/generative/Widgets/CirclesGrid.hs view
@@ -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
+ examples/ticker/BinanceTypes.hs view
@@ -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
+ examples/ticker/Main.hs view
@@ -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"]
+ examples/ticker/TickerTypes.hs view
@@ -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
+ examples/todo/Main.hs view
@@ -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
+ examples/todo/TodoTypes.hs view
@@ -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)
+ examples/tutorial/Main.hs view
@@ -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
+ examples/tutorial/Tutorial01_Basics.hs view
@@ -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
+ examples/tutorial/Tutorial02_Styling.hs view
@@ -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+    }
+ examples/tutorial/Tutorial03_LifeCycle.hs view
@@ -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 = []+    }
+ examples/tutorial/Tutorial04_Tasks.hs view
@@ -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+    }
+ examples/tutorial/Tutorial05_Producers.hs view
@@ -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+    }
+ examples/tutorial/Tutorial06_Composite.hs view
@@ -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+    }
+ examples/tutorial/Tutorial07_CustomWidget.hs view
@@ -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
+ examples/tutorial/Tutorial08_Themes.hs view
@@ -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
+ monomer.cabal view
@@ -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 <https://github.com/fjvallarino/monomer#readme>+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
+ src/Monomer.hs view
@@ -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+<https://github.com/fjvallarino/monomer#documentation tutorials>:++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
+ src/Monomer/Common.hs view
@@ -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
+ src/Monomer/Common/BasicTypes.hs view
@@ -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
+ src/Monomer/Common/Lens.hs view
@@ -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
+ src/Monomer/Core.hs view
@@ -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
+ src/Monomer/Core/Combinators.hs view
@@ -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
+ src/Monomer/Core/FromFractional.hs view
@@ -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
+ src/Monomer/Core/Lens.hs view
@@ -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
+ src/Monomer/Core/SizeReq.hs view
@@ -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
+ src/Monomer/Core/Style.hs view
@@ -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
+ src/Monomer/Core/StyleTypes.hs view
@@ -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
+ src/Monomer/Core/StyleUtil.hs view
@@ -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
+ src/Monomer/Core/ThemeTypes.hs view
@@ -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+  }
+ src/Monomer/Core/Themes/BaseTheme.hs view
@@ -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
+ src/Monomer/Core/Themes/SampleThemes.hs view
@@ -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"+-}
+ src/Monomer/Core/Util.hs view
@@ -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
+ src/Monomer/Core/WidgetTypes.hs view
@@ -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)+    ++ " }"
+ src/Monomer/Event.hs view
@@ -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
+ src/Monomer/Event/Core.hs view
@@ -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+}
+ src/Monomer/Event/Keyboard.hs view
@@ -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)
+ src/Monomer/Event/Lens.hs view
@@ -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
+ src/Monomer/Event/Types.hs view
@@ -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+  }
+ src/Monomer/Event/Util.hs view
@@ -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
+ src/Monomer/Graphics.hs view
@@ -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
+ src/Monomer/Graphics/ColorTable.hs view
@@ -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"
+ src/Monomer/Graphics/FFI.chs view
@@ -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)
+ src/Monomer/Graphics/FontManager.hs view
@@ -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
+ src/Monomer/Graphics/Lens.hs view
@@ -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
+ src/Monomer/Graphics/NanoVGRenderer.hs view
@@ -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
+ src/Monomer/Graphics/RemixIcon.hs view
@@ -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
+ src/Monomer/Graphics/Text.hs view
@@ -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 = (== ' ')
+ src/Monomer/Graphics/Types.hs view
@@ -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 ()+}
+ src/Monomer/Graphics/Util.hs view
@@ -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
+ src/Monomer/Helper.hs view
@@ -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
+ src/Monomer/Lens.hs view
@@ -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
+ src/Monomer/Main.hs view
@@ -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
+ src/Monomer/Main/Core.hs view
@@ -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 ]
+ src/Monomer/Main/Handlers.hs view
@@ -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
+ src/Monomer/Main/Lens.hs view
@@ -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
+ src/Monomer/Main/Platform.hs view
@@ -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)
+ src/Monomer/Main/Types.hs view
@@ -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+}
+ src/Monomer/Main/UserUtil.hs view
@@ -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)
+ src/Monomer/Main/Util.hs view
@@ -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
+ src/Monomer/Main/WidgetTask.hs view
@@ -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
+ src/Monomer/Widgets.hs view
@@ -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
+ src/Monomer/Widgets/Animation.hs view
@@ -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
+ src/Monomer/Widgets/Animation/Fade.hs view
@@ -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
+ src/Monomer/Widgets/Animation/Slide.hs view
@@ -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
+ src/Monomer/Widgets/Animation/Types.hs view
@@ -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)
+ src/Monomer/Widgets/Composite.hs view
@@ -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)
+ src/Monomer/Widgets/Container.hs view
@@ -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
+ src/Monomer/Widgets/Containers/Alert.hs view
@@ -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]
+ src/Monomer/Widgets/Containers/Base/LabeledItem.hs view
@@ -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)
+ src/Monomer/Widgets/Containers/Box.hs view
@@ -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)
+ src/Monomer/Widgets/Containers/Confirm.hs view
@@ -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]
+ src/Monomer/Widgets/Containers/Draggable.hs view
@@ -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)
+ src/Monomer/Widgets/Containers/DropTarget.hs view
@@ -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]+    _ -> []
+ src/Monomer/Widgets/Containers/Dropdown.hs view
@@ -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
+ src/Monomer/Widgets/Containers/Grid.hs view
@@ -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)
+ src/Monomer/Widgets/Containers/Keystroke.hs view
@@ -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+  ]
+ src/Monomer/Widgets/Containers/Scroll.hs view
@@ -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
+ src/Monomer/Widgets/Containers/SelectList.hs view
@@ -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
+ src/Monomer/Widgets/Containers/Split.hs view
@@ -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
+ src/Monomer/Widgets/Containers/Stack.hs view
@@ -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
+ src/Monomer/Widgets/Containers/ThemeSwitch.hs view
@@ -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
+ src/Monomer/Widgets/Containers/Tooltip.hs view
@@ -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
+ src/Monomer/Widgets/Containers/ZStack.hs view
@@ -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
+ src/Monomer/Widgets/Single.hs view
@@ -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
+ src/Monomer/Widgets/Singles/Base/InputField.hs view
@@ -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` [' ', '.', ',', '/', '-', ':']
+ src/Monomer/Widgets/Singles/Button.hs view
@@ -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)
+ src/Monomer/Widgets/Singles/Checkbox.hs view
@@ -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)
+ src/Monomer/Widgets/Singles/ColorPicker.hs view
@@ -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)
+ src/Monomer/Widgets/Singles/DateField.hs view
@@ -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 <https://hackage.haskell.org/package/time time>+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
+ src/Monomer/Widgets/Singles/Dial.hs view
@@ -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
+ src/Monomer/Widgets/Singles/ExternalLink.hs view
@@ -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
+ src/Monomer/Widgets/Singles/Icon.hs view
@@ -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
+ src/Monomer/Widgets/Singles/Image.hs view
@@ -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
+ src/Monomer/Widgets/Singles/Label.hs view
@@ -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)
+ src/Monomer/Widgets/Singles/LabeledCheckbox.hs view
@@ -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
+ src/Monomer/Widgets/Singles/LabeledRadio.hs view
@@ -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
+ src/Monomer/Widgets/Singles/NumericField.hs view
@@ -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
+ src/Monomer/Widgets/Singles/Radio.hs view
@@ -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
+ src/Monomer/Widgets/Singles/SeparatorLine.hs view
@@ -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
+ src/Monomer/Widgets/Singles/Slider.hs view
@@ -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)
+ src/Monomer/Widgets/Singles/Spacer.hs view
@@ -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)
+ src/Monomer/Widgets/Singles/TextArea.hs view
@@ -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` [' ', '.', ',', '/', '-', ':']
+ src/Monomer/Widgets/Singles/TextDropdown.hs view
@@ -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
+ src/Monomer/Widgets/Singles/TextField.hs view
@@ -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
+ src/Monomer/Widgets/Singles/TimeField.hs view
@@ -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 <https://hackage.haskell.org/package/time time>+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
+ src/Monomer/Widgets/Util.hs view
@@ -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
+ src/Monomer/Widgets/Util/Drawing.hs view
@@ -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)
+ src/Monomer/Widgets/Util/Focus.hs view
@@ -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
+ src/Monomer/Widgets/Util/Hover.hs view
@@ -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)
+ src/Monomer/Widgets/Util/Keyboard.hs view
@@ -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
+ src/Monomer/Widgets/Util/Lens.hs view
@@ -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
+ src/Monomer/Widgets/Util/Parser.hs view
@@ -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
+ src/Monomer/Widgets/Util/Style.hs view
@@ -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
+ src/Monomer/Widgets/Util/Text.hs view
@@ -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
+ src/Monomer/Widgets/Util/Theme.hs view
@@ -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
+ src/Monomer/Widgets/Util/Types.hs view
@@ -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+}
+ src/Monomer/Widgets/Util/Widget.hs view
@@ -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
+ test/unit/Monomer/Common/CursorIconSpec.hs view
@@ -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
+ test/unit/Monomer/Graphics/UtilSpec.hs view
@@ -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"
+ test/unit/Monomer/TestEventUtil.hs view
@@ -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
+ test/unit/Monomer/TestUtil.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Animation/FadeSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Animation/SlideSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/CompositeSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/ContainerSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/AlertSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/BoxSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/ConfirmSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/DragDropSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Containers/DropdownSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/GridSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Containers/ScrollSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/SelectListSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/SplitSpec.hs view
@@ -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))
+ test/unit/Monomer/Widgets/Containers/StackSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Containers/ThemeSwitchSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Containers/TooltipSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Containers/ZStackSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Singles/ButtonSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Singles/CheckboxSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Singles/DialSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/ExternalLinkSpec.hs view
@@ -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")
+ test/unit/Monomer/Widgets/Singles/ImageSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Singles/LabelSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Singles/LabeledCheckboxSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/LabeledRadioSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Singles/RadioSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/SeparatorLineSpec.hs view
@@ -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]])
+ test/unit/Monomer/Widgets/Singles/SliderSpec.hs view
@@ -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])
+ test/unit/Monomer/Widgets/Singles/SpacerSpec.hs view
@@ -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])
+ test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs view
@@ -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)
+ test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Util/FocusSpec.hs view
@@ -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])
+ test/unit/Monomer/Widgets/Util/StyleSpec.hs view
@@ -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
+ test/unit/Monomer/Widgets/Util/TextSpec.hs view
@@ -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)
+ test/unit/Spec.hs view
@@ -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