diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,30 @@ +## 1.6.0.0 + +### Added + +- Add renderBezierTo to Renderer for rendering cubic bezier curves ([PR #259](https://github.com/fjvallarino/monomer/pull/259)). Thanks @DarinM223! +- Improve development time application reload ([PR #239](https://github.com/fjvallarino/monomer/pull/239)). +- Draggable widget: allow to hide the original widget when dragging ([PR #259](https://github.com/fjvallarino/monomer/pull/259)). Thanks @Deltaspace0! +- Add more animation widgets ([PR #281](https://github.com/fjvallarino/monomer/pull/281)). Thanks @Deltaspace0! + +### Fixed + +- Avoid weird macOS 'command encoder is already encoding to this command buffer' error when resizing window ([PR #234](https://github.com/fjvallarino/monomer/pull/234)). +- Fix type error in examples ([PR #263](https://github.com/fjvallarino/monomer/pull/263)). +- Fix flake.nix definition to work with more recent nixpkgs snapshots ([PR #266](https://github.com/fjvallarino/monomer/pull/266)). Thanks @RubenAstudillo! +- Fix Semigroup instance for BoxShadowCfg ([PR #272](https://github.com/fjvallarino/monomer/pull/272)). Thanks @Deltaspace0! +- Fix typo in widgetDataSet description ([PR #273](https://github.com/fjvallarino/monomer/pull/273)). Thanks @Deltaspace0! +- Do not generate extra click events in box widget ([PR #267](https://github.com/fjvallarino/monomer/pull/267)). +- Remove redundant imports and fix typos ([PR #275](https://github.com/fjvallarino/monomer/pull/275)). Thanks @Deltaspace0! +- Fix typos in documentation ([PR #284](https://github.com/fjvallarino/monomer/pull/284)). Thanks @Deltaspace0! +- Fix build issues with GHC 9.6 ([PR #308](https://github.com/fjvallarino/monomer/pull/308)). + +### Changed + +- Better explain how the nodeKey function is related to WidgetKey ([PR #270](https://github.com/fjvallarino/monomer/pull/270)). Thanks @RubenAstudillo! +- Use parent model for Alert and Confirm modals ([PR #268](https://github.com/fjvallarino/monomer/pull/268)). +- Use latest nanovg-hs commit hash to apply relaxed text and vector upper bounds ([PR #285](https://github.com/fjvallarino/monomer/pull/285)). + ## 1.5.1.0 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -86,6 +86,12 @@ - Stability and performance. - Mobile support. +## Project status + +Although there has not been a lot of activity in the past year, the project is still active. + +I may take some time to respond to issues while I work on features I want to add to Monomer. + ## Useful extensions - [Hagrid](https://github.com/Dretch/monomer-hagrid), a flexible datagrid widget. diff --git a/dev-test-app/Main.hs b/dev-test-app/Main.hs --- a/dev-test-app/Main.hs +++ b/dev-test-app/Main.hs @@ -4,13 +4,9 @@ module Main where import Control.Lens -import Data.Maybe -import Data.Text (Text) import Monomer import TextShow -import qualified Monomer.Lens as L - newtype AppModel = AppModel { _clickCount :: Int } deriving (Eq, Show) @@ -56,6 +52,7 @@ appWindowIcon "./assets/images/icon.png", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", - appInitEvent AppInit + appInitEvent AppInit, + appModelFingerprint show ] model = AppModel 0 diff --git a/examples/books/Main.hs b/examples/books/Main.hs --- a/examples/books/Main.hs +++ b/examples/books/Main.hs @@ -140,7 +140,7 @@ -> WidgetNode BooksModel BooksEvt -> BooksModel -> BooksEvt - -> [EventResponse BooksModel BooksEvt BooksModel ()] + -> [EventResponse BooksModel BooksEvt BooksModel BooksEvt] handleEvent sess wenv node model evt = case evt of BooksInit -> [SetFocusOnKey "query"] BooksSearch -> [ diff --git a/examples/generative/Main.hs b/examples/generative/Main.hs --- a/examples/generative/Main.hs +++ b/examples/generative/Main.hs @@ -101,7 +101,7 @@ -> GenerativeNode -> GenerativeModel -> GenerativeEvt - -> [EventResponse GenerativeModel GenerativeEvt GenerativeModel ()] + -> [EventResponse GenerativeModel GenerativeEvt GenerativeModel GenerativeEvt] handleEvent wenv node model evt = case evt of GenerativeInit -> [SetFocusOnKey "activeType"] diff --git a/examples/ticker/Main.hs b/examples/ticker/Main.hs --- a/examples/ticker/Main.hs +++ b/examples/ticker/Main.hs @@ -123,7 +123,7 @@ -> TickerNode -> TickerModel -> TickerEvt - -> [EventResponse TickerModel TickerEvt TickerModel ()] + -> [EventResponse TickerModel TickerEvt TickerModel TickerEvt] handleEvent env wenv node model evt = case evt of TickerInit -> [ Model $ model diff --git a/examples/todo/Main.hs b/examples/todo/Main.hs --- a/examples/todo/Main.hs +++ b/examples/todo/Main.hs @@ -168,7 +168,7 @@ -> TodoNode -> TodoModel -> TodoEvt - -> [EventResponse TodoModel TodoEvt TodoModel ()] + -> [EventResponse TodoModel TodoEvt TodoModel TodoEvt] handleEvent wenv node model evt = case evt of TodoInit -> [SetFocusOnKey "todoNew"] diff --git a/monomer.cabal b/monomer.cabal --- a/monomer.cabal +++ b/monomer.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: monomer -version: 1.5.1.0 +version: 1.6.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. @@ -84,8 +84,12 @@ Monomer.Widgets Monomer.Widgets.Animation Monomer.Widgets.Animation.Fade + Monomer.Widgets.Animation.Shake Monomer.Widgets.Animation.Slide + Monomer.Widgets.Animation.Transform Monomer.Widgets.Animation.Types + Monomer.Widgets.Animation.Wipe + Monomer.Widgets.Animation.Zoom Monomer.Widgets.Composite Monomer.Widgets.Container Monomer.Widgets.Containers.Alert @@ -175,10 +179,11 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , sdl2 >=2.5.0 && <2.6 @@ -220,11 +225,12 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , sdl2 >=2.5.0 && <2.6 @@ -262,11 +268,12 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , sdl2 >=2.5.0 && <2.6 @@ -303,11 +310,12 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , random >=1.1 && <1.3 @@ -347,11 +355,12 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , random >=1.1 && <1.3 @@ -393,11 +402,12 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , sdl2 >=2.5.0 && <2.6 @@ -438,11 +448,12 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , sdl2 >=2.5.0 && <2.6 @@ -488,11 +499,12 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , random >=1.1 && <1.3 @@ -521,7 +533,11 @@ Monomer.TestEventUtil Monomer.TestUtil Monomer.Widgets.Animation.FadeSpec + Monomer.Widgets.Animation.ShakeSpec Monomer.Widgets.Animation.SlideSpec + Monomer.Widgets.Animation.TransformSpec + Monomer.Widgets.Animation.WipeSpec + Monomer.Widgets.Animation.ZoomSpec Monomer.Widgets.CompositeSpec Monomer.Widgets.Containers.AlertSpec Monomer.Widgets.Containers.BoxShadowSpec @@ -581,12 +597,13 @@ , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , hspec >=2.4 && <3.0 , http-client >=0.6 && <0.9 , lens >=4.16 && <6 , monomer - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , nanovg >=0.8.1 && <1.0 , process ==1.6.* , sdl2 >=2.5.0 && <2.6 diff --git a/src/Monomer/Common/Lens.hs b/src/Monomer/Common/Lens.hs --- a/src/Monomer/Common/Lens.hs +++ b/src/Monomer/Common/Lens.hs @@ -14,7 +14,7 @@ module Monomer.Common.Lens where -import Control.Lens.TH (abbreviatedFields, makeLensesWith, makePrisms) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Monomer.Common.BasicTypes diff --git a/src/Monomer/Core/Combinators.hs b/src/Monomer/Core/Combinators.hs --- a/src/Monomer/Core/Combinators.hs +++ b/src/Monomer/Core/Combinators.hs @@ -74,7 +74,7 @@ selectOnFocus_ :: Bool -> t {-| -Defines whether a widget prevents the user changing the value. Note that, in +Defines whether a widget prevents the user from changing the value. Note that, in contrast to a disabled widget, a read-only widget can still be focused and still allows selecting and copying the value. -} @@ -520,6 +520,10 @@ -- | On finished event. class CmbOnFinished t e | t -> e where onFinished :: e -> t + +-- | On finished WidgetRequest. +class CmbOnFinishedReq t s e | t -> s e where + onFinishedReq :: WidgetRequest s e -> t -- | Width combinator. class CmbWidth t where diff --git a/src/Monomer/Core/Lens.hs b/src/Monomer/Core/Lens.hs --- a/src/Monomer/Core/Lens.hs +++ b/src/Monomer/Core/Lens.hs @@ -16,7 +16,6 @@ import Control.Lens.TH (abbreviatedFields, makeLensesWith, makePrisms) -import Monomer.Common.Lens import Monomer.Core.StyleTypes import Monomer.Core.ThemeTypes import Monomer.Core.WidgetTypes diff --git a/src/Monomer/Core/SizeReq.hs b/src/Monomer/Core/SizeReq.hs --- a/src/Monomer/Core/SizeReq.hs +++ b/src/Monomer/Core/SizeReq.hs @@ -11,7 +11,7 @@ {-# LANGUAGE Strict #-} module Monomer.Core.SizeReq ( - SizeReqUpdater(..), + SizeReqUpdater, clearExtra, clearExtraW, clearExtraH, @@ -41,9 +41,8 @@ import Data.Maybe import Monomer.Common -import Monomer.Core.StyleTypes +import Monomer.Core.Style import Monomer.Core.StyleUtil -import Monomer.Core.Util import Monomer.Helper import qualified Monomer.Core.Lens as L diff --git a/src/Monomer/Core/StyleTypes.hs b/src/Monomer/Core/StyleTypes.hs --- a/src/Monomer/Core/StyleTypes.hs +++ b/src/Monomer/Core/StyleTypes.hs @@ -19,7 +19,6 @@ 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, diff --git a/src/Monomer/Core/ThemeTypes.hs b/src/Monomer/Core/ThemeTypes.hs --- a/src/Monomer/Core/ThemeTypes.hs +++ b/src/Monomer/Core/ThemeTypes.hs @@ -22,7 +22,6 @@ import Monomer.Core.StyleTypes import Monomer.Graphics.ColorTable import Monomer.Graphics.Types -import Monomer.Graphics.Util -- | Theme configuration for each state, plus clear/base color. data Theme = Theme { diff --git a/src/Monomer/Core/Themes/BaseTheme.hs b/src/Monomer/Core/Themes/BaseTheme.hs --- a/src/Monomer/Core/Themes/BaseTheme.hs +++ b/src/Monomer/Core/Themes/BaseTheme.hs @@ -16,7 +16,7 @@ baseTheme ) where -import Control.Lens ((&), (^.), (.~), (?~), non) +import Control.Lens ((&), (.~), (?~), non) import Data.Default import Monomer.Core.Combinators diff --git a/src/Monomer/Core/Themes/SampleThemes.hs b/src/Monomer/Core/Themes/SampleThemes.hs --- a/src/Monomer/Core/Themes/SampleThemes.hs +++ b/src/Monomer/Core/Themes/SampleThemes.hs @@ -15,7 +15,7 @@ darkThemeColors ) where -import Control.Lens ((&), (^.), (.~), (?~), non) +import Control.Lens ((&), (.~)) import Monomer.Core.ThemeTypes import Monomer.Core.Themes.BaseTheme diff --git a/src/Monomer/Core/Util.hs b/src/Monomer/Core/Util.hs --- a/src/Monomer/Core/Util.hs +++ b/src/Monomer/Core/Util.hs @@ -13,18 +13,15 @@ module Monomer.Core.Util where -import Control.Lens ((&), (^.), (^?), (.~), (?~), _Just) +import Control.Lens ((^.), (^?), _Just) 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 diff --git a/src/Monomer/Core/WidgetTypes.hs b/src/Monomer/Core/WidgetTypes.hs --- a/src/Monomer/Core/WidgetTypes.hs +++ b/src/Monomer/Core/WidgetTypes.hs @@ -12,7 +12,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} -{-# Language GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-} @@ -182,8 +182,7 @@ | StopTextInput -- | Sets a widget as the base target of future events. This is used by the -- dropdown component to handle list events; this list, acting as an - -- overlay, is displayed on top of all other widgets. Tooltip uses it too. - -- every other widget). + -- overlay, is displayed on top of all other widgets. Popup uses it too. | SetOverlay WidgetId Path -- | Removes the existing overlay. | ResetOverlay WidgetId @@ -311,6 +310,8 @@ _weOs :: Text, -- | Device pixel rate. _weDpr :: Double, + -- | Indicates whether the application is running on ghci. + _weIsGhci :: Bool, -- | The timestamp in milliseconds when the application started. _weAppStartTs :: Millisecond, -- | Provides helper functions for calculating text size. diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs --- a/src/Monomer/Event/Core.hs +++ b/src/Monomer/Event/Core.hs @@ -16,14 +16,12 @@ ) where import Control.Applicative ((<|>)) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes) import Data.Text (Text) -import qualified Data.Map.Strict as M import qualified SDL import Monomer.Common -import Monomer.Event.Keyboard import Monomer.Event.Types {-| diff --git a/src/Monomer/Event/Lens.hs b/src/Monomer/Event/Lens.hs --- a/src/Monomer/Event/Lens.hs +++ b/src/Monomer/Event/Lens.hs @@ -16,7 +16,6 @@ import Control.Lens.TH (abbreviatedFields, makeLensesWith) -import Monomer.Common.Lens import Monomer.Event.Types makeLensesWith abbreviatedFields ''InputStatus diff --git a/src/Monomer/Event/Util.hs b/src/Monomer/Event/Util.hs --- a/src/Monomer/Event/Util.hs +++ b/src/Monomer/Event/Util.hs @@ -29,12 +29,6 @@ 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 Windows/Cmd key is pressed. diff --git a/src/Monomer/Graphics/FontManager.hs b/src/Monomer/Graphics/FontManager.hs --- a/src/Monomer/Graphics/FontManager.hs +++ b/src/Monomer/Graphics/FontManager.hs @@ -19,7 +19,6 @@ import Control.Lens ((^.)) import Data.Default -import Data.Sequence (Seq) import Data.Text (Text) import System.IO.Unsafe diff --git a/src/Monomer/Graphics/NanoVGRenderer.hs b/src/Monomer/Graphics/NanoVGRenderer.hs --- a/src/Monomer/Graphics/NanoVGRenderer.hs +++ b/src/Monomer/Graphics/NanoVGRenderer.hs @@ -16,27 +16,22 @@ module Monomer.Graphics.NanoVGRenderer (makeRenderer) where -import Control.Lens ((&), (^.), (.~)) -import Control.Monad (foldM, forM_, unless, when) +import Control.Lens ((^.)) +import Control.Monad (foldM, forM_, 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.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 @@ -321,6 +316,13 @@ where CPoint x1 y1 = pointToCPoint p1 dpr CPoint x2 y2 = pointToCPoint p2 dpr + + renderBezierTo p1 p2 p3 = + VG.bezierTo c x1 y1 x2 y2 x3 y3 + where + CPoint x1 y1 = pointToCPoint p1 dpr + CPoint x2 y2 = pointToCPoint p2 dpr + CPoint x3 y3 = pointToCPoint p3 dpr renderEllipse !rect = VG.ellipse c cx cy rx ry diff --git a/src/Monomer/Graphics/Text.hs b/src/Monomer/Graphics/Text.hs --- a/src/Monomer/Graphics/Text.hs +++ b/src/Monomer/Graphics/Text.hs @@ -29,7 +29,7 @@ import Data.Default import Data.List (foldl') import Data.Maybe -import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Sequence (Seq(..), (<|)) import Data.Text (Text) import qualified Data.Sequence as Seq diff --git a/src/Monomer/Graphics/Types.hs b/src/Monomer/Graphics/Types.hs --- a/src/Monomer/Graphics/Types.hs +++ b/src/Monomer/Graphics/Types.hs @@ -382,6 +382,8 @@ renderArc :: Point -> Double -> Double -> Double -> Winding -> IO (), -- | Quadratic bezier segment from head via control point to target. renderQuadTo :: Point -> Point -> IO (), + -- | Cubic bezier segment from head via two control points to target. + renderBezierTo :: Point -> Point -> Point -> IO (), -- | Renders an ellipse. renderEllipse :: Rect -> IO (), {-| diff --git a/src/Monomer/Helper.hs b/src/Monomer/Helper.hs --- a/src/Monomer/Helper.hs +++ b/src/Monomer/Helper.hs @@ -15,10 +15,12 @@ import Control.Exception (SomeException, catch) import Control.Monad.IO.Class (MonadIO) +import Data.Functor ((<&>)) import Data.Sequence (Seq(..)) import System.IO (hPutStrLn, stderr) import qualified Data.Sequence as Seq +import qualified System.Environment as SE -- | Concats a list of Monoids or returns Nothing if empty. maybeConcat :: Monoid a => [a] -> Maybe a @@ -94,7 +96,12 @@ headMay [] = Nothing headMay (x : _) = Just x +-- | Attempts to print on stderr, with fallback to stdout on failure. putStrLnErr :: String -> IO () putStrLnErr msg = catchAny (hPutStrLn stderr msg) (const $ putStrLn msg) + +-- | Checks if the application is running in ghci. +isGhciRunning :: IO Bool +isGhciRunning = SE.getProgName <&> (== "") diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs --- a/src/Monomer/Main/Core.hs +++ b/src/Monomer/Main/Core.hs @@ -9,38 +9,39 @@ Core glue for running an application. -} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} module Monomer.Main.Core ( - AppEventResponse(..), - AppEventHandler(..), - AppUIBuilder(..), + AppEventResponse, + AppEventHandler, + AppUIBuilder, startApp ) where import Control.Concurrent import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan) import Control.Exception -import Control.Lens ((&), (^.), (.=), (.~), use) -import Control.Monad (unless, void, when) +import Control.Lens ((&), (^.), (.=), (.~), _2, use) import Control.Monad.Extra import Control.Monad.State import Control.Monad.STM (atomically) import Data.Default import Data.Either (isLeft) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, fromJust, isJust) import Data.Map (Map) -import Data.List (foldl') import Data.Text (Text) import Data.Time import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word32) import Graphics.GL import qualified Data.Map as Map +import qualified Data.Sequence as Seq import qualified Data.Text as T +import qualified Foreign.Store as FS import qualified SDL -import qualified Data.Sequence as Seq import Monomer.Core import Monomer.Core.Combinators @@ -51,7 +52,7 @@ import Monomer.Main.Util import Monomer.Main.WidgetTask import Monomer.Graphics -import Monomer.Helper (catchAny, putStrLnErr) +import Monomer.Helper (catchAny, putStrLnErr, isGhciRunning) import Monomer.Widgets.Composite import qualified Monomer.Lens as L @@ -60,7 +61,7 @@ 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 AppEventResponse s e = EventResponse s e s e -- | Type of an App event handler. type AppEventHandler s e @@ -73,7 +74,9 @@ -- | Type of the function responsible of creating the App UI. type AppUIBuilder s e = UIBuilder s e +-- | Updated information for the current step of the event loop. data MainLoopArgs sp e ep = MainLoopArgs { + _mlIsGhci :: Bool, _mlOS :: Text, _mlTheme :: Theme, _mlAppStartTs :: Millisecond, @@ -87,6 +90,7 @@ _mlWidgetShared :: MVar (Map Text WidgetShared) } +-- | State information for the rendering thread. data RenderState s e = RenderState { _rstDpr :: Double, _rstWidgetEnv :: WidgetEnv s e, @@ -94,6 +98,25 @@ } {-| +Information for hot reload of an application running on ghci. + +When running in interpreted mode, SDL initialization and window creation data +will be reused on further code updates. +-} +data MonomerReloadData s e = MonomerReloadData { + -- | The active window. + _mrdWindow :: !SDL.Window, + -- | The OpenGL context associated to the window. + _mrdGlContext :: !SDL.GLContext, + -- | The latest context. + _mrdMonomerCtx :: !(MonomerCtx s e), + -- | The fingerprint of the model. Used to detect changes in the data type. + _mrdModelFp :: !String, + -- | The latest widget tree. + _mrdRoot :: !(WidgetNode s e) +} + +{-| Runs an application, creating the UI with the provided function and initial model, handling future events with the event handler. @@ -105,34 +128,45 @@ => s -- ^ The initial model. -> AppEventHandler s e -- ^ The event handler. -> AppUIBuilder s e -- ^ The UI builder. - -> [AppConfig e] -- ^ The application config. + -> [AppConfig s e] -- ^ The application config. -> IO () -- ^ The application action. -startApp model eventHandler uiBuilder configs = do - (window, dpr, epr, glCtx) <- initSDLWindow config - vpSize <- getViewportSize window dpr +startApp newModel eventHandler uiBuilder configs = do + isGhci <- isGhciRunning channel <- newTChanIO - let monomerCtx = initMonomerCtx window channel vpSize dpr epr model + (model, oldRoot) <- retrieveModelAndRoot config newModel newRoot + (window, glCtx, ctx) <- retrieveSDLWindow config channel model - runStateT (runAppLoop window glCtx channel appWidget config) monomerCtx - destroySDLWindow window + when isGhci $ + setReloadData (MonomerReloadData window glCtx ctx modelFp newRoot) + + resp <- runStateT (runAppLoop window glCtx channel oldRoot newRoot config) ctx + + -- Even when running on ghci, if exitApplication == True it means the user + -- closed the window and it will need to be created again on reload. + when (not isGhci || resp ^. _2 . L.exitApplication) $ do + destroySDLWindow window + resetReloadData where config = mconcat configs compCfgs = (onInit <$> _apcInitEvent config) ++ (onDispose <$> _apcDisposeEvent config) ++ (onResize <$> _apcResizeEvent config) - appWidget = composite_ "app" id uiBuilder eventHandler compCfgs + ~modelFp = maybe "" ($ newModel) (_apcModelFingerprintFn config) + newRoot = 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) + -> Maybe (WidgetNode sp ep) -> WidgetNode sp ep - -> AppConfig e + -> AppConfig s e -> m () -runAppLoop window glCtx channel widgetRoot config = do +runAppLoop window glCtx channel mRootOld newRoot config = do + isGhci <- liftIO isGhciRunning dpr <- use L.dpr winSize <- use L.windowSize @@ -150,10 +184,16 @@ os <- liftIO getPlatform widgetSharedMVar <- liftIO $ newMVar Map.empty fontManager <- liftIO $ makeFontManager fonts dpr + -- Restore previous state + hovered <- getHoveredPath + focused <- getFocusedPath + overlay <- getOverlayPath + dragged <- getDraggedMsgInfo let wenv = WidgetEnv { _weOs = os, _weDpr = dpr, + _weIsGhci = isGhci, _weAppStartTs = appStartTs, _weFontManager = fontManager, _weFindBranchByPath = const Seq.empty, @@ -164,10 +204,10 @@ _weWidgetShared = widgetSharedMVar, _weWidgetKeyMap = Map.empty, _weCursor = Nothing, - _weHoveredPath = Nothing, - _weFocusedPath = emptyPath, - _weOverlayPath = Nothing, - _weDragStatus = Nothing, + _weHoveredPath = hovered, + _weFocusedPath = focused, + _weOverlayPath = overlay, + _weDragStatus = dragged, _weMainBtnPress = Nothing, _weModel = model, _weInputStatus = def, @@ -178,9 +218,13 @@ _weViewport = Rect 0 0 (winSize ^. L.w) (winSize ^. L.h), _weOffset = def } - let pathReadyRoot = widgetRoot + let tmpRoot = newRoot & L.info . L.path .~ rootPath & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) rootPath + let mergeNewRoot newRoot oldRoot = result where + result = widgetMerge (newRoot ^. L.widget) wenv newRoot oldRoot + let result = maybe (resultNode tmpRoot) (mergeNewRoot tmpRoot) mRootOld + let appRoot = result ^. L.node let makeMainThreadRenderer = do renderer <- liftIO $ makeRenderer fonts dpr L.renderMethod .= Left renderer @@ -192,10 +236,10 @@ liftIO . void . forkOS $ {- - The wenv and widgetRoot values are not used, since they are replaced + The wenv and appRoot values are not used, since they are replaced during MsgInit. Kept to avoid issues with the Strict pragma. -} - startRenderThread stpChan channel window glCtx fonts dpr wenv widgetRoot + startRenderThread stpChan channel window glCtx fonts dpr wenv appRoot setupRes <- liftIO . atomically $ readTChan stpChan @@ -212,8 +256,11 @@ makeMainThreadRenderer handleResourcesInit - (newWenv, newRoot, _) <- handleWidgetInit wenv pathReadyRoot + (newWenv, newAppRoot, _) <- if isJust mRootOld + then handleWidgetResult wenv True result + else handleWidgetInit wenv appRoot + {- Deferred initialization step to account for Widgets that rely on OpenGL. They need the Renderer to be setup before handleWidgetInit is called, and it is @@ -221,13 +268,14 @@ -} case setupRes of RenderSetupMulti -> do - liftIO . atomically $ writeTChan channel (MsgInit newWenv newRoot) + liftIO . atomically $ writeTChan channel (MsgInit newWenv newAppRoot) unless (isLinux newWenv) $ liftIO $ watchWindowResize channel _ -> return () let loopArgs = MainLoopArgs { + _mlIsGhci = isGhci, _mlOS = os, _mlTheme = theme, _mlMaxFps = maxFps, @@ -237,7 +285,7 @@ _mlFrameAccumTs = 0, _mlFrameCount = 0, _mlExitEvents = exitEvents, - _mlWidgetRoot = newRoot, + _mlWidgetRoot = newAppRoot, _mlWidgetShared = widgetSharedMVar } @@ -249,7 +297,7 @@ :: (MonomerM sp ep m, WidgetEvent e) => SDL.Window -> FontManager - -> AppConfig e + -> AppConfig s e -> MainLoopArgs sp e ep -> m () mainLoop window fontManager config loopArgs = do @@ -301,6 +349,7 @@ let wenv = WidgetEnv { _weOs = _mlOS, _weDpr = dpr, + _weIsGhci = _mlIsGhci, _weAppStartTs = _mlAppStartTs, _weFontManager = fontManager, _weFindBranchByPath = findChildBranchByPath wenv _mlWidgetRoot, @@ -379,6 +428,7 @@ let tempDelay = abs (frameLength - fromIntegral remainingMs * 1000) let nextFrameDelay = min frameLength tempDelay let latestRenderTs = if renderNeeded then startTs else _mlLatestRenderTs + let newModel = newWenv ^. L.model let newLoopArgs = loopArgs { _mlLatestRenderTs = latestRenderTs, _mlFrameStartTs = startTs, @@ -387,6 +437,10 @@ _mlWidgetRoot = newRoot } + when _mlIsGhci $ do + ctx <- get + liftIO $ updateReloadData ctx newRoot + liftIO $ threadDelay nextFrameDelay shouldQuit <- use L.exitApplication @@ -595,3 +649,66 @@ getElapsedTimestampSince start = do ts <- getCurrentTimestamp return (ts - start) + +-- Hot reload support + +reloadStoreId :: Word32 +reloadStoreId = 0 + +getReloadData :: IO (Maybe (MonomerReloadData s e)) +getReloadData = FS.lookupStore reloadStoreId >>= \case + Just{} -> Just <$> FS.readStore (FS.Store reloadStoreId) + _ -> return Nothing + +setReloadData :: MonomerReloadData s e -> IO () +setReloadData = FS.writeStore (FS.Store reloadStoreId) + +resetReloadData :: IO () +resetReloadData = FS.deleteStore (FS.Store reloadStoreId) + +updateReloadData :: MonomerCtx s e -> WidgetNode s e -> IO () +updateReloadData context widgetRoot = do + whenJustM getReloadData $ \rd -> + setReloadData rd { + _mrdMonomerCtx = context, + _mrdRoot = widgetRoot + } + +{-| +When running in GHCi, avoids reinitializing SDL, reuses the existing window and +restores the model and (merged) widget tree when code is reloaded. +-} +retrieveSDLWindow + :: AppConfig s e + -> TChan (RenderMsg s e) + -> s + -> IO (SDL.Window, SDL.GLContext, MonomerCtx s e) +retrieveSDLWindow config channel model = do + getReloadData >>= \case + Just rd -> return (_mrdWindow rd, _mrdGlContext rd, newCtx) where + ctx = _mrdMonomerCtx rd + newCtx = ctx { + _mcMainModel = model, + _mcRenderMethod = Right channel + } + Nothing -> do + (window, dpr, epr, ctxRender) <- initSDLWindow config + vpSize <- getViewportSize window dpr + let newCtx = initMonomerCtx window channel vpSize dpr epr model + return (window, ctxRender, newCtx) + +retrieveModelAndRoot + :: WidgetModel s + => AppConfig s e + -> s + -> WidgetNode s e + -> IO (s, Maybe (WidgetNode s e)) +retrieveModelAndRoot config newModel newRoot = getReloadData >>= \case + Just rd + | attemptModelReuse && fingerprint == _mrdModelFp rd -> + return (_mrdMonomerCtx rd ^. L.mainModel, Just (_mrdRoot rd)) + _ -> do + return (newModel, Nothing) + where + attemptModelReuse = isJust (_apcModelFingerprintFn config) + ~fingerprint = fromJust (_apcModelFingerprintFn config) newModel diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs --- a/src/Monomer/Main/Handlers.hs +++ b/src/Monomer/Main/Handlers.hs @@ -27,18 +27,18 @@ import Control.Concurrent.Async (async) import Control.Lens - ((&), (^.), (^?), (.~), (?~), (%~), (.=), (?=), (%=), (%%~), _Just, _1, _2, ix, at, use) + ((&), (^.), (.~), (?~), (%~), (.=), (?=), (%=), (%%~), _Just, _1, at, use) import Control.Monad.STM (atomically) import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan) import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.IO.Class import Data.Default -import Data.Foldable (fold, toList) +import Data.Foldable (toList) import Data.Maybe import Data.Sequence (Seq(..), (|>)) import Data.Text (Text) -import Data.Typeable (Typeable, typeOf) +import Data.Typeable (Typeable) import SDL (($=)) import qualified Data.Map as Map @@ -66,7 +66,7 @@ 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 +Processes a list of SystemEvents dispatching each 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". @@ -76,7 +76,7 @@ => 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." + -> m (HandlerStep s e) -- ^ The resulting "HandlerStep". handleSystemEvents wenv widgetRoot baseEvents = nextStep where mainBtn = wenv ^. L.mainButton reduceEvt curStep evt = do diff --git a/src/Monomer/Main/Platform.hs b/src/Monomer/Main/Platform.hs --- a/src/Monomer/Main/Platform.hs +++ b/src/Monomer/Main/Platform.hs @@ -23,12 +23,11 @@ ) where import Control.Exception (finally) -import Control.Monad (void) +import Control.Monad (when, void, forM_) import Control.Monad.Extra (whenJust) import Control.Monad.State import Data.Maybe import Data.Text (Text) -import Data.Word import Foreign (alloca, peek) import Foreign.C (peekCString, withCString) import Foreign.C.Types @@ -52,12 +51,12 @@ foreign import ccall unsafe "initGlew" glewInit :: IO CInt foreign import ccall unsafe "initDpiAwareness" initDpiAwareness :: IO CInt --- | Default window size if not is specified. +-- | Default window size if not 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 :: AppConfig s e -> IO (SDL.Window, Double, Double, SDL.GLContext) initSDLWindow config = do SDL.initialize [SDL.InitVideo] @@ -156,7 +155,7 @@ Just MainWindowMaximized -> True _ -> False -setWindowIcon :: SDL.Window -> AppConfig e -> IO () +setWindowIcon :: SDL.Window -> AppConfig s e -> IO () setWindowIcon (SIT.Window winPtr) config = forM_ (_apcWindowIcon config) $ \iconPath -> flip catchAny handleException $ do diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs --- a/src/Monomer/Main/Types.hs +++ b/src/Monomer/Main/Types.hs @@ -30,12 +30,10 @@ 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 @@ -153,7 +151,7 @@ deriving (Eq, Show) -- | Main application config. -data AppConfig e = AppConfig { +data AppConfig s e = AppConfig { -- | Initial size of the main window. _apcWindowState :: Maybe MainWindowState, -- | Title of the main window. @@ -208,10 +206,13 @@ -- | Whether compositing should be disabled. Defaults to False. _apcDisableCompositing :: Maybe Bool, -- | Whether the screensaver should be disabled. Defaults to False. - _apcDisableScreensaver :: Maybe Bool + _apcDisableScreensaver :: Maybe Bool, + -- | Extracts a String based fingerprint from the application's model. + -- See 'appFingerprint' for more details. + _apcModelFingerprintFn :: Maybe (s -> String) } -instance Default (AppConfig e) where +instance Default (AppConfig s e) where def = AppConfig { _apcWindowState = Nothing, _apcWindowTitle = Nothing, @@ -233,10 +234,11 @@ _apcInvertWheelX = Nothing, _apcInvertWheelY = Nothing, _apcDisableCompositing = Nothing, - _apcDisableScreensaver = Nothing + _apcDisableScreensaver = Nothing, + _apcModelFingerprintFn = Nothing } -instance Semigroup (AppConfig e) where +instance Semigroup (AppConfig s e) where (<>) a1 a2 = AppConfig { _apcWindowState = _apcWindowState a2 <|> _apcWindowState a1, _apcWindowTitle = _apcWindowTitle a2 <|> _apcWindowTitle a1, @@ -258,38 +260,39 @@ _apcInvertWheelX = _apcInvertWheelX a2 <|> _apcInvertWheelX a1, _apcInvertWheelY = _apcInvertWheelY a2 <|> _apcInvertWheelY a1, _apcDisableCompositing = _apcDisableCompositing a2 <|> _apcDisableCompositing a1, - _apcDisableScreensaver = _apcDisableScreensaver a2 <|> _apcDisableScreensaver a1 + _apcDisableScreensaver = _apcDisableScreensaver a2 <|> _apcDisableScreensaver a1, + _apcModelFingerprintFn = _apcModelFingerprintFn a2 <|> _apcModelFingerprintFn a1 } -instance Monoid (AppConfig e) where +instance Monoid (AppConfig s e) where mempty = def -- | Initial size of the main window. -appWindowState :: MainWindowState -> AppConfig e +appWindowState :: MainWindowState -> AppConfig s e appWindowState title = def { _apcWindowState = Just title } -- | Title of the main window. -appWindowTitle :: Text -> AppConfig e +appWindowTitle :: Text -> AppConfig s e appWindowTitle title = def { _apcWindowTitle = Just title } -- | Whether the main window is resizable. -appWindowResizable :: Bool -> AppConfig e +appWindowResizable :: Bool -> AppConfig s e appWindowResizable resizable = def { _apcWindowResizable = Just resizable } -- | Whether the main window has a border. -appWindowBorder :: Bool -> AppConfig e +appWindowBorder :: Bool -> AppConfig s e appWindowBorder border = def { _apcWindowBorder = Just border } -- | Path to an icon file in BMP format. -appWindowIcon :: Text -> AppConfig e +appWindowIcon :: Text -> AppConfig s e appWindowIcon path = def { _apcWindowIcon = Just path } @@ -314,7 +317,7 @@ -} {-# DEPRECATED appRenderOnMainThread "Should no longer be needed. Check appRenderOnMainThread's Haddock page." #-} -appRenderOnMainThread :: AppConfig e +appRenderOnMainThread :: AppConfig s e appRenderOnMainThread = def { _apcUseRenderThread = Just False } @@ -324,7 +327,7 @@ rendering will happen every frame, but events and schedules will be checked at this rate and may cause it. -} -appMaxFps :: Int -> AppConfig e +appMaxFps :: Int -> AppConfig s e appMaxFps fps = def { _apcMaxFps = Just fps } @@ -334,7 +337,7 @@ the size of the window. It is applied in addition to the detected display scale factor, and can be useful if the detected value is not the desired. -} -appScaleFactor :: Double -> AppConfig e +appScaleFactor :: Double -> AppConfig s e appScaleFactor factor = def { _apcScaleFactor = Just factor } @@ -377,22 +380,22 @@ screen width larger than 1920 belongs to an HiDPI display and uses a scale factor of 2. This factor is used to scale the window size and the content. -} -appDisableAutoScale :: Bool -> AppConfig e +appDisableAutoScale :: Bool -> AppConfig s e appDisableAutoScale disable = def { _apcDisableAutoScale = Just disable } {-| -Available fonts to the application, loaded from the specified path. +Available fonts to the application, loaded from the specified path. Specifying no fonts will make it impossible to render text. -} -appFontDef :: Text -> Text -> AppConfig e +appFontDef :: Text -> Text -> AppConfig s e appFontDef name path = def { _apcFonts = [ FontDefFile name path ] } {-| -Available fonts to the application, loaded from the bytes in memory. +Available fonts to the application, loaded from the bytes in memory. Specifying no fonts will make it impossible to render text. One use case for this function is to embed fonts in the application, without the need to distribute the font files. @@ -401,49 +404,49 @@ appFontDefMemory "memoryFont" $(embedFile "dirName/fileName") @ -} -appFontDefMem :: Text -> ByteString -> AppConfig e +appFontDefMem :: Text -> ByteString -> AppConfig s e appFontDefMem name bytes = def { _apcFonts = [ FontDefMem name bytes ] } -- | Initial theme. -appTheme :: Theme -> AppConfig e +appTheme :: Theme -> AppConfig s e appTheme t = def { _apcTheme = Just t } -- | Initial event, useful for loading resources. -appInitEvent :: e -> AppConfig e +appInitEvent :: e -> AppConfig s e appInitEvent evt = def { _apcInitEvent = [evt] } -- | Dispose event, useful for closing resources. -appDisposeEvent :: e -> AppConfig e +appDisposeEvent :: e -> AppConfig s e appDisposeEvent evt = def { _apcDisposeEvent = [evt] } -- | Exit event, useful for cancelling an application close event. -appExitEvent :: e -> AppConfig e +appExitEvent :: e -> AppConfig s e appExitEvent evt = def { _apcExitEvent = [evt] } -- | Resize event handler. -appResizeEvent :: (Rect -> e) -> AppConfig e +appResizeEvent :: (Rect -> e) -> AppConfig s e appResizeEvent evt = def { _apcResizeEvent = [evt] } -- | Defines which mouse button is considered main. -appMainButton :: Button -> AppConfig e +appMainButton :: Button -> AppConfig s e appMainButton btn = def { _apcMainButton = Just btn } -- | Defines which mouse button is considered secondary or context button. -appContextButton :: Button -> AppConfig e +appContextButton :: Button -> AppConfig s e appContextButton btn = def { _apcContextButton = Just btn } @@ -452,7 +455,7 @@ Whether the horizontal wheel/trackpad movement should be inverted. In general platform detection should do the right thing. -} -appInvertWheelX :: Bool -> AppConfig e +appInvertWheelX :: Bool -> AppConfig s e appInvertWheelX invert = def { _apcInvertWheelX = Just invert } @@ -461,7 +464,7 @@ Whether the vertical wheel/trackpad movement should be inverted. In general platform detection should do the right thing. -} -appInvertWheelY :: Bool -> AppConfig e +appInvertWheelY :: Bool -> AppConfig s e appInvertWheelY invert = def { _apcInvertWheelY = Just invert } @@ -471,10 +474,10 @@ Defaults to False. Desktop applications should leave compositing as is since disabling it may -cause visual glitches in other programs. When creating games or fullscreen +cause visual glitches in other programs. When creating games or full-screen applications, disabling compositing may improve performance. -} -appDisableCompositing :: Bool -> AppConfig e +appDisableCompositing :: Bool -> AppConfig s e appDisableCompositing disable = def { _apcDisableCompositing = Just disable } @@ -484,9 +487,56 @@ Desktop applications should leave the screensaver as is since disabling it also affects power saving features, including turning off the screen. When creating -games or fullscreen applications, disabling the screensaver may make sense. +games or full-screen applications, disabling the screensaver may make sense. -} -appDisableScreensaver :: Bool -> AppConfig e +appDisableScreensaver :: Bool -> AppConfig s e appDisableScreensaver disable = def { _apcDisableScreensaver = Just disable +} + +{-| +Generates a fingerprint from the application's model. This is used to identify +whether the application should attempt to reuse the model between reloads when +running in interpreted mode. Since Monomer uses the model to build the UI, +reusing the old model allows for quicker iteration as the application will be +restored to its previous state before being reloaded. By default, unless a +fingerprint function is provided, the model will not be reused and the +application will start from scratch. + +The fingerprint function is applied to the user provided model on application's +startup only, not on subsequent updates during the application's lifetime. When +a reload occurs, the original fingerprint of the model is compared against the +fingerprint of the newly provided version of the model; if they match, it is +assumed that the latest version of the original model can be reused. If the +fingerprint changed because its data or data type changed, the new model will be +used. The rationale is that, since the model is provided by the developer at +startup, if the fingerprints match then only changes to business logic/UI have +been made. + +A fingerprint function is used because trying to compare two different versions +of a data type using its 'Eq' instance will result in ghci crashing. Creating a +string based fingerprint as soon as the instance is available is a workaround +for this issue. Ideally, the fingerprint would incorporate enough information to +detect type and data changes. + +A simple approach is using the 'show' function to generate the fingerprint, +although in some cases it may not be possible, maybe because the type does not +implement it or it does not include enough information. + +An alternative to 'show' is 's __anythingToString__. This function returns a string +representation of the data, although it does not include the name of record +fields. In general this is not an issue, but changing a field's type from 'Int' +to 'Long' will go undetected and cause a crash. + +Ideally, we could use "GHC.Fingerprint.Fingerprint" to detect changes in the +model's type, but unfortunately this is not reliable since this fingerprint is +based on the type's name only. + +GHC issue with more details: https://gitlab.haskell.org/ghc/ghc/-/issues/7897. +Related Hint issue: https://github.com/haskell-hint/hint/issues/31. +-} +appModelFingerprint :: (s -> String) -> AppConfig s e +appModelFingerprint fn = def { + _apcModelFingerprintFn = Just fn } diff --git a/src/Monomer/Main/UserUtil.hs b/src/Monomer/Main/UserUtil.hs --- a/src/Monomer/Main/UserUtil.hs +++ b/src/Monomer/Main/UserUtil.hs @@ -13,17 +13,14 @@ 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 Monomer.Widgets.Singles.Spacer import qualified Monomer.Core.Lens as L -import qualified Monomer.Main.Lens as L {-# DEPRECATED setFocusOnKey "Use SetFocusOnKey instead (wenv argument should be removed)." #-} {-| diff --git a/src/Monomer/Main/Util.hs b/src/Monomer/Main/Util.hs --- a/src/Monomer/Main/Util.hs +++ b/src/Monomer/Main/Util.hs @@ -14,13 +14,9 @@ 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 Control.Lens ((^.), (.=), at, non, use) import Data.Default -import Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Map as Map @@ -29,9 +25,7 @@ import Monomer.Core import Monomer.Event import Monomer.Helper (headMay) -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 diff --git a/src/Monomer/Main/WidgetTask.hs b/src/Monomer/Main/WidgetTask.hs --- a/src/Monomer/Main/WidgetTask.hs +++ b/src/Monomer/Main/WidgetTask.hs @@ -17,7 +17,7 @@ import Control.Concurrent.Async (poll) import Control.Concurrent.STM.TChan (tryReadTChan) import Control.Exception.Base -import Control.Lens ((&), (^.), (.=), use) +import Control.Lens ((^.), (.=), use) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.STM (atomically) diff --git a/src/Monomer/Widgets.hs b/src/Monomer/Widgets.hs --- a/src/Monomer/Widgets.hs +++ b/src/Monomer/Widgets.hs @@ -12,9 +12,7 @@ -- * Composite widget module Monomer.Widgets.Composite, -- * Animation - module Monomer.Widgets.Animation.Fade, - module Monomer.Widgets.Animation.Slide, - module Monomer.Widgets.Animation.Types, + module Monomer.Widgets.Animation, -- * Containers module Monomer.Widgets.Containers.Alert, module Monomer.Widgets.Containers.Box, @@ -61,9 +59,7 @@ import Monomer.Widgets.Composite -import Monomer.Widgets.Animation.Fade -import Monomer.Widgets.Animation.Slide -import Monomer.Widgets.Animation.Types +import Monomer.Widgets.Animation import Monomer.Widgets.Containers.Alert import Monomer.Widgets.Containers.Box diff --git a/src/Monomer/Widgets/Animation.hs b/src/Monomer/Widgets/Animation.hs --- a/src/Monomer/Widgets/Animation.hs +++ b/src/Monomer/Widgets/Animation.hs @@ -10,10 +10,18 @@ -} module Monomer.Widgets.Animation ( module Monomer.Widgets.Animation.Fade, + module Monomer.Widgets.Animation.Shake, module Monomer.Widgets.Animation.Slide, - module Monomer.Widgets.Animation.Types + module Monomer.Widgets.Animation.Transform, + module Monomer.Widgets.Animation.Types, + module Monomer.Widgets.Animation.Wipe, + module Monomer.Widgets.Animation.Zoom ) where import Monomer.Widgets.Animation.Fade +import Monomer.Widgets.Animation.Shake import Monomer.Widgets.Animation.Slide +import Monomer.Widgets.Animation.Transform import Monomer.Widgets.Animation.Types +import Monomer.Widgets.Animation.Wipe +import Monomer.Widgets.Animation.Zoom diff --git a/src/Monomer/Widgets/Animation/Fade.hs b/src/Monomer/Widgets/Animation/Fade.hs --- a/src/Monomer/Widgets/Animation/Fade.hs +++ b/src/Monomer/Widgets/Animation/Fade.hs @@ -12,11 +12,9 @@ - Accepts an 'AnimationMsg', used to control the state of the animation. -} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} module Monomer.Widgets.Animation.Fade ( @@ -29,19 +27,12 @@ animFadeOut_ ) where -import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (.~), (%~), at) -import Control.Monad (when) +import Control.Lens ((&), (.~)) 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 Monomer.Widgets.Animation.Transform import qualified Monomer.Lens as L @@ -51,54 +42,43 @@ - '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. +- 'onFinishedReq': 'WidgetRequest' to generate when animation is complete. -} -data FadeCfg e = FadeCfg { - _fdcAutoStart :: Maybe Bool, - _fdcDuration :: Maybe Millisecond, - _fdcOnFinished :: [e] +newtype FadeCfg s e = FadeCfg { + _fdcTransformCfg :: TransformCfg s e } deriving (Eq, Show) -instance Default (FadeCfg e) where +instance Default (FadeCfg s e) where def = FadeCfg { - _fdcAutoStart = Nothing, - _fdcDuration = Nothing, - _fdcOnFinished = [] + _fdcTransformCfg = def } -instance Semigroup (FadeCfg e) where +instance Semigroup (FadeCfg s e) where (<>) fc1 fc2 = FadeCfg { - _fdcAutoStart = _fdcAutoStart fc2 <|> _fdcAutoStart fc1, - _fdcDuration = _fdcDuration fc2 <|> _fdcDuration fc1, - _fdcOnFinished = _fdcOnFinished fc1 <> _fdcOnFinished fc2 + _fdcTransformCfg = _fdcTransformCfg fc1 <> _fdcTransformCfg fc2 } -instance Monoid (FadeCfg e) where +instance Monoid (FadeCfg s e) where mempty = def -instance CmbAutoStart (FadeCfg e) where +instance CmbAutoStart (FadeCfg s e) where autoStart_ start = def { - _fdcAutoStart = Just start + _fdcTransformCfg = autoStart_ start } -instance CmbDuration (FadeCfg e) Millisecond where +instance CmbDuration (FadeCfg s e) Millisecond where duration dur = def { - _fdcDuration = Just dur + _fdcTransformCfg = duration dur } -instance CmbOnFinished (FadeCfg e) e where - onFinished fn = def { - _fdcOnFinished = [fn] +instance WidgetEvent e => CmbOnFinished (FadeCfg s e) e where + onFinished handler = def { + _fdcTransformCfg = onFinished handler } -data FadeState = FadeState { - _fdsRunning :: Bool, - _fdsStartTs :: Millisecond -} deriving (Eq, Show, Generic) - -instance Default FadeState where - def = FadeState { - _fdsRunning = False, - _fdsStartTs = 0 +instance CmbOnFinishedReq (FadeCfg s e) s e where + onFinishedReq req = def { + _fdcTransformCfg = onFinishedReq req } -- | Animates a widget from not visible state to fully visible. @@ -111,12 +91,11 @@ -- | Animates a widget from not visible state to fully visible. Accepts config. animFadeIn_ :: WidgetEvent e - => [FadeCfg e] -- ^ The config options. + => [FadeCfg s e] -- ^ The config options. -> WidgetNode s e -- ^ The child node. -> WidgetNode s e -- ^ The created animation container. -animFadeIn_ configs managed = makeNode "animFadeIn" widget managed where - config = mconcat configs - widget = makeFade True config def +animFadeIn_ configs managed = makeNode configs managed True + & L.info . L.widgetType .~ "animFadeIn" -- | Animates a widget from visible state to not visible. animFadeOut @@ -128,81 +107,25 @@ -- | Animates a widget from visible state to not visible. Accepts config. animFadeOut_ :: WidgetEvent e - => [FadeCfg e] -- ^ The config options. + => [FadeCfg s e] -- ^ The config options. -> WidgetNode s e -- ^ The child node. -> WidgetNode s e -- ^ The created animation container. -animFadeOut_ configs managed = makeNode "animFadeOut" widget managed where - config = mconcat configs - widget = makeFade False config def +animFadeOut_ configs managed = makeNode configs managed False + & L.info . L.widgetType .~ "animFadeOut" 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 = fromIntegral $ duration `div` period - - finishedReq node ts = delayedMessage node (AnimationFinished ts) 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 ts, 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 ts, 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 ts' - | isRelevant -> resultEvts node (_fdcOnFinished config) - | otherwise -> resultNode node - where isRelevant = _fdsRunning state && ts' == _fdsStartTs state - - 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 + :: WidgetEvent e + => [FadeCfg s e] + -> WidgetNode s e + -> Bool + -> WidgetNode s e +makeNode configs managed isFadeIn = node where + node = animTransform_ [_fdcTransformCfg] f managed + f t _ = [animGlobalAlpha $ alpha t] + alpha t = if isFadeIn + then (currStep t) + else 1-(currStep t) + currStep t = clampAlpha $ t/(fromIntegral dur) + dur = fromMaybe 500 _tfcDuration + TransformCfg{..} = _fdcTransformCfg + FadeCfg{..} = mconcat configs diff --git a/src/Monomer/Widgets/Animation/Shake.hs b/src/Monomer/Widgets/Animation/Shake.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation/Shake.hs @@ -0,0 +1,167 @@ +{-| +Module : Monomer.Widgets.Animation.Shake +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Shake animation widget. Wraps a child widget whose content will be animated. + +Messages: + +- Accepts a 'AnimationMsg', used to control the state of the animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +module Monomer.Widgets.Animation.Shake ( + -- * Configuration + ShakeCfg, + shakeH, + shakeV, + shakeR, + shakeS, + shakeAmplitude, + shakeFrequency, + -- * Constructors + animShake, + animShake_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (.~)) +import Data.Default +import Data.Maybe + +import Monomer.Helper +import Monomer.Widgets.Container +import Monomer.Widgets.Animation.Transform + +import qualified Monomer.Lens as L + +data ShakeDirection + = ShakeH + | ShakeV + | ShakeR + | ShakeS + deriving (Eq, Show) + +{-| +Configuration options for shake: + +- '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. +- 'onFinishedReq': 'WidgetRequest' to generate when animation is complete. +- 'shakeAmplitude': amplitude of the animation. Defaults to 0.1. +- 'shakeFrequency': frequency of the animation. Defaults to 2. +- Individual combinators for direction. +-} +data ShakeCfg s e = ShakeCfg { + _shcDirection :: Maybe ShakeDirection, + _shcAmplitude :: Maybe Double, + _shcFrequency :: Maybe Int, + _shcTransformCfg :: TransformCfg s e +} deriving (Eq, Show) + +instance Default (ShakeCfg s e) where + def = ShakeCfg { + _shcDirection = Nothing, + _shcAmplitude = Nothing, + _shcFrequency = Nothing, + _shcTransformCfg = def + } + +instance Semigroup (ShakeCfg s e) where + (<>) sc1 sc2 = ShakeCfg { + _shcDirection = _shcDirection sc2 <|> _shcDirection sc1, + _shcAmplitude = _shcAmplitude sc2 <|> _shcAmplitude sc1, + _shcFrequency = _shcFrequency sc2 <|> _shcFrequency sc1, + _shcTransformCfg = _shcTransformCfg sc1 <> _shcTransformCfg sc2 + } + +instance Monoid (ShakeCfg s e) where + mempty = def + +instance CmbAutoStart (ShakeCfg s e) where + autoStart_ start = def { + _shcTransformCfg = autoStart_ start + } + +instance CmbDuration (ShakeCfg s e) Millisecond where + duration dur = def { + _shcTransformCfg = duration dur + } + +instance WidgetEvent e => CmbOnFinished (ShakeCfg s e) e where + onFinished handler = def { + _shcTransformCfg = onFinished handler + } + +instance CmbOnFinishedReq (ShakeCfg s e) s e where + onFinishedReq req = def { + _shcTransformCfg = onFinishedReq req + } + +-- | Shake horizontally. +shakeH :: ShakeCfg s e +shakeH = def { _shcDirection = Just ShakeH } + +-- | Shake vertically. +shakeV :: ShakeCfg s e +shakeV = def { _shcDirection = Just ShakeV } + +-- | Shake by rotating. +shakeR :: ShakeCfg s e +shakeR = def { _shcDirection = Just ShakeR } + +-- | Shake by scaling. +shakeS :: ShakeCfg s e +shakeS = def { _shcDirection = Just ShakeS } + +-- | Amplitude of the animation. Defaults to 1. +shakeAmplitude :: Double -> ShakeCfg s e +shakeAmplitude amp = def { _shcAmplitude = Just amp } + +-- | Frequency of the animation. Defaults to 2. +shakeFrequency :: Int -> ShakeCfg s e +shakeFrequency freq = def { _shcFrequency = Just freq } + +-- | Shakes a widget. +animShake + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animShake managed = animShake_ def managed + +-- | Shakes a widget. Accepts config. +animShake_ + :: WidgetEvent e + => [ShakeCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animShake_ configs managed = node where + node = animTransform_ [_shcTransformCfg] f managed + & L.info . L.widgetType .~ "animShake" + f t vp@(Rect _ _ w h) = (noScissor vp) <> case dir of + ShakeH -> [animTranslation $ Point ((step t)*w) 0] + ShakeV -> [animTranslation $ Point 0 ((step t)*h)] + ShakeR -> [animRotation $ (step t)*180] + ShakeS -> + [ animTranslation $ Point ((1-(ss t))*w/2) ((1-(ss t))*h/2) + , animScale $ Point (ss t) (ss t) + ] + noScissor (Rect x y w h) = + [animScissor $ Rect (x-w*10) (y-h*10) (w*20) (h*20)] + step t = (sin $ (fs t)*freq*2*pi)*amp + ss t = 1-(amp/2)+(cos $ (fs t)*freq*2*pi)*amp/2 + fs t = clamp 0 1 $ t/(fromIntegral dur) + dir = fromMaybe ShakeH _shcDirection + amp = fromMaybe 0.1 _shcAmplitude + freq = fromIntegral $ fromMaybe 2 _shcFrequency + dur = fromMaybe 500 _tfcDuration + TransformCfg{..} = _shcTransformCfg + ShakeCfg{..} = mconcat configs diff --git a/src/Monomer/Widgets/Animation/Slide.hs b/src/Monomer/Widgets/Animation/Slide.hs --- a/src/Monomer/Widgets/Animation/Slide.hs +++ b/src/Monomer/Widgets/Animation/Slide.hs @@ -12,10 +12,9 @@ - Accepts a 'AnimationMsg', used to control the state of the animation. -} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} module Monomer.Widgets.Animation.Slide ( @@ -33,18 +32,13 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (.~), (%~), at) -import Control.Monad (when) +import Control.Lens ((&), (.~)) 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 Monomer.Widgets.Animation.Transform import qualified Monomer.Lens as L @@ -61,76 +55,65 @@ - '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. +- 'onFinishedReq': 'WidgetRequest' to generate when animation is complete. - Individual combinators for direction. -} -data SlideCfg e = SlideCfg { +data SlideCfg s e = SlideCfg { _slcDirection :: Maybe SlideDirection, - _slcAutoStart :: Maybe Bool, - _slcDuration :: Maybe Millisecond, - _slcOnFinished :: [e] + _slcTransformCfg :: TransformCfg s e } deriving (Eq, Show) -instance Default (SlideCfg e) where +instance Default (SlideCfg s e) where def = SlideCfg { _slcDirection = Nothing, - _slcAutoStart = Nothing, - _slcDuration = Nothing, - _slcOnFinished = [] + _slcTransformCfg = def } -instance Semigroup (SlideCfg e) where +instance Semigroup (SlideCfg s 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 + _slcTransformCfg = _slcTransformCfg fc1 <> _slcTransformCfg fc2 } -instance Monoid (SlideCfg e) where +instance Monoid (SlideCfg s e) where mempty = def -instance CmbAutoStart (SlideCfg e) where +instance CmbAutoStart (SlideCfg s e) where autoStart_ start = def { - _slcAutoStart = Just start + _slcTransformCfg = autoStart_ start } -instance CmbDuration (SlideCfg e) Millisecond where +instance CmbDuration (SlideCfg s e) Millisecond where duration dur = def { - _slcDuration = Just dur + _slcTransformCfg = duration dur } -instance CmbOnFinished (SlideCfg e) e where - onFinished fn = def { - _slcOnFinished = [fn] +instance WidgetEvent e => CmbOnFinished (SlideCfg s e) e where + onFinished handler = def { + _slcTransformCfg = onFinished handler } +instance CmbOnFinishedReq (SlideCfg s e) s e where + onFinishedReq req = def { + _slcTransformCfg = onFinishedReq req + } + -- | Slide from/to left. -slideLeft :: SlideCfg e +slideLeft :: SlideCfg s e slideLeft = def { _slcDirection = Just SlideLeft } -- | Slide from/to right. -slideRight :: SlideCfg e +slideRight :: SlideCfg s e slideRight = def { _slcDirection = Just SlideRight } -- | Slide from/to top. -slideTop :: SlideCfg e +slideTop :: SlideCfg s e slideTop = def { _slcDirection = Just SlideUp } -- | Slide from/to bottom. -slideBottom :: SlideCfg e +slideBottom :: SlideCfg s e slideBottom = def { _slcDirection = Just SlideDown } -data SlideState = SlideState { - _slsRunning :: Bool, - _slsStartTs :: Millisecond -} 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 @@ -142,12 +125,11 @@ -- to left). Accepts config. animSlideIn_ :: WidgetEvent e - => [SlideCfg e] -- ^ The config options. + => [SlideCfg s e] -- ^ The config options. -> WidgetNode s e -- ^ The child node. -> WidgetNode s e -- ^ The created animation container. -animSlideIn_ configs managed = makeNode "animSlideIn" widget managed where - config = mconcat configs - widget = makeSlide True config def +animSlideIn_ configs managed = makeNode configs managed True + & L.info . L.widgetType .~ "animSlideIn" -- | Animates a widget to the left from visible to not visible. animSlideOut @@ -156,100 +138,38 @@ -> WidgetNode s e -- ^ The created animation container. animSlideOut managed = animSlideOut_ def managed --- | Animates a widget to the the provided direction from visible to not +-- | Animates a widget to the provided direction from visible to not -- visible (defaults to left). Accepts config. animSlideOut_ :: WidgetEvent e - => [SlideCfg e] -- ^ The config options. + => [SlideCfg s e] -- ^ The config options. -> WidgetNode s e -- ^ The child node. -> WidgetNode s e -- ^ The created animation container. -animSlideOut_ configs managed = makeNode "animSlideOut" widget managed where - config = mconcat configs - widget = makeSlide False config def +animSlideOut_ configs managed = makeNode configs managed False + & L.info . L.widgetType .~ "animSlideOut" 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 = fromIntegral $ duration `div` period - - finishedReq node ts = delayedMessage node (AnimationFinished ts) 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 ts, 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 ts, 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 ts' - | isRelevant -> resultEvts node (_slcOnFinished config) - | otherwise -> resultNode node - where isRelevant = _slsRunning state && ts' == _slsStartTs state - - 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 + :: WidgetEvent e + => [SlideCfg s e] + -> WidgetNode s e + -> Bool + -> WidgetNode s e +makeNode configs managed isSlideIn = node where + node = animTransform_ [_slcTransformCfg] f managed + f t vp = [animTranslation $ Point (fx t vp) (fy t vp)] + fx t (Rect _ _ w _) = case dir of + SlideLeft -> -1*(step t)*w + SlideRight -> (step t)*w + _ -> 0 + fy t (Rect _ _ _ h) = case dir of + SlideUp -> -1*(step t)*h + SlideDown -> (step t)*h + _ -> 0 + step t = if isSlideIn + then 1-(fwdStep t) + else fwdStep t + fwdStep t = clamp 0 1 $ t/(fromIntegral dur) + dir = fromMaybe SlideLeft _slcDirection + dur = fromMaybe 500 _tfcDuration + TransformCfg{..} = _slcTransformCfg + SlideCfg{..} = mconcat configs diff --git a/src/Monomer/Widgets/Animation/Transform.hs b/src/Monomer/Widgets/Animation/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation/Transform.hs @@ -0,0 +1,309 @@ +{-| +Module : Monomer.Widgets.Animation.Transform +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Transform animation widget. Wraps a child widget whose content will be animated. +Acts as a base for most animation widgets. + +Messages: + +- Accepts an 'AnimationMsg', used to control the state of the animation. + +@ +transform t (Rect x y w h) = + [ animTranslation $ Point tx ty + , animScale $ Point sx sy + ] + +animTransform transform managed +@ + +With configuration options: + +@ +transform t (Rect x y w h) = + [ animTranslation $ Point tx ty + , animScale $ Point sx sy + ] + +animTransform_ [duration 2000, autoStart] transform managed +@ + +For usage examples, see: + +- "Monomer.Widgets.Animation.Shake" +- "Monomer.Widgets.Animation.Zoom" +-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +module Monomer.Widgets.Animation.Transform ( + -- * Configuration + TransformCfg(..), + -- * Render transformations + RenderTransform, + animTranslation, + animScale, + animRotation, + animGlobalAlpha, + animScissor, + -- * Constructors + animTransform, + animTransform_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~)) +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 + +{-| +Configuration options for transform: + +- '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. +- 'onFinishedReq': 'WidgetRequest' to generate when animation is complete. +-} +data TransformCfg s e = TransformCfg { + _tfcAutoStart :: Maybe Bool, + _tfcDuration :: Maybe Millisecond, + _tfcOnFinishedReq :: [WidgetRequest s e] +} deriving (Eq, Show) + +instance Default (TransformCfg s e) where + def = TransformCfg { + _tfcAutoStart = Nothing, + _tfcDuration = Nothing, + _tfcOnFinishedReq = [] + } + +instance Semigroup (TransformCfg s e) where + (<>) tc1 tc2 = TransformCfg { + _tfcAutoStart = _tfcAutoStart tc2 <|> _tfcAutoStart tc1, + _tfcDuration = _tfcDuration tc2 <|> _tfcDuration tc1, + _tfcOnFinishedReq = _tfcOnFinishedReq tc1 <> _tfcOnFinishedReq tc2 + } + +instance Monoid (TransformCfg s e) where + mempty = def + +instance CmbAutoStart (TransformCfg s e) where + autoStart_ start = def { + _tfcAutoStart = Just start + } + +instance CmbDuration (TransformCfg s e) Millisecond where + duration dur = def { + _tfcDuration = Just dur + } + +instance WidgetEvent e => CmbOnFinished (TransformCfg s e) e where + onFinished handler = def { + _tfcOnFinishedReq = [RaiseEvent handler] + } + +instance CmbOnFinishedReq (TransformCfg s e) s e where + onFinishedReq req = def { + _tfcOnFinishedReq = [req] + } + +data TransformState = TransformState { + _tfsRunning :: Bool, + _tfsStartTs :: Millisecond +} deriving (Eq, Show, Generic) + +instance Default TransformState where + def = TransformState { + _tfsRunning = False, + _tfsStartTs = 0 + } + +{-| +Possible render transformations: + +- 'animTranslation': translates by the given offset. +- 'animScale': scales by the given size. +- 'animRotation': rotates by the given angle. +- 'animGlobalAlpha': applies the given alpha. +- 'animScissor': scissors to the given viewport. +-} +data RenderTransform = RenderTransform { + _rtTranslation :: Maybe Point, + _rtScale :: Maybe Point, + _rtRotation :: Maybe Double, + _rtGlobalAlpha :: Maybe Double, + _rtScissor :: Maybe Rect +} + +instance Default RenderTransform where + def = RenderTransform { + _rtTranslation = Nothing, + _rtScale = Nothing, + _rtRotation = Nothing, + _rtGlobalAlpha = Nothing, + _rtScissor = Nothing + } + +instance Semigroup RenderTransform where + (<>) rt1 rt2 = RenderTransform { + _rtTranslation = _rtTranslation rt2 <|> _rtTranslation rt1, + _rtScale = _rtScale rt2 <|> _rtScale rt1, + _rtRotation = _rtRotation rt2 <|> _rtRotation rt1, + _rtGlobalAlpha = _rtGlobalAlpha rt2 <|> _rtGlobalAlpha rt1, + _rtScissor = _rtScissor rt2 <|> _rtScissor rt1 + } + +instance Monoid RenderTransform where + mempty = def + +-- | Translate by the given offset. +animTranslation :: Point -> RenderTransform +animTranslation p = def { _rtTranslation = Just p } + +-- | Scale by the given size. +animScale :: Point -> RenderTransform +animScale p = def { _rtScale = Just p } + +-- | Rotate by the given angle. +animRotation :: Double -> RenderTransform +animRotation r = def { _rtRotation = Just r } + +-- | Apply the given alpha. +animGlobalAlpha :: Double -> RenderTransform +animGlobalAlpha a = def { _rtGlobalAlpha = Just a } + +-- | Scissor to the given viewport. +animScissor :: Rect -> RenderTransform +animScissor vp = def { _rtScissor = Just vp } + +type Transformer = (Double -> Rect -> [RenderTransform]) + +-- | Animates a widget through translation, scaling, rotation, +-- transparency and scissor. +animTransform + :: WidgetEvent e + => Transformer -- ^ Transformations from time (in ms) and viewport. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animTransform f managed = animTransform_ def f managed + +-- | Animates a widget through translation, scaling, rotation, +-- transparency and scissor. Accepts config. +animTransform_ + :: WidgetEvent e + => [TransformCfg s e] -- ^ The config options. + -> Transformer -- ^ Transformations from time (in ms) and viewport. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animTransform_ configs f managed = node where + node = defaultWidgetNode widgetType widget + & L.info . L.focusable .~ False + & L.children .~ Seq.singleton managed + widgetType = WidgetType "animTransform" + widget = makeTransform f config def + config = mconcat configs + +makeTransform + :: WidgetEvent e + => Transformer + -> TransformCfg s e + -> TransformState + -> Widget s e +makeTransform f config state = widget where + baseWidget = createContainer state def { + containerInit = init, + containerMerge = merge, + containerHandleMessage = handleMessage + } + widget = baseWidget { + widgetRender = render + } + + TransformCfg{..} = config + TransformState{..} = state + autoStart = fromMaybe False _tfcAutoStart + duration = fromMaybe 500 _tfcDuration + period = 20 + steps = fromIntegral $ duration `div` period + + finishedReq node ts = delayedMessage node (AnimationFinished ts) 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 .~ makeTransform f config (TransformState True ts) + result + | autoStart = resultReqs newNode [finishedReq node ts, renderReq wenv node] + | otherwise = resultNode node + + merge wenv node oldNode oldState = resultNode newNode where + newNode = node + & L.widget .~ makeTransform f 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 = TransformState True ts + startReqs = [finishedReq node ts, renderReq wenv node] + + newNode newState = node + & L.widget .~ makeTransform f config newState + result = case msg of + AnimationStart -> resultReqs (newNode startState) startReqs + AnimationStop -> resultReqs (newNode def) [RenderStop widgetId] + AnimationFinished ts' + | isRelevant -> resultReqs node _tfcOnFinishedReq + | otherwise -> resultNode node + where isRelevant = _tfsRunning && ts' == _tfsStartTs + + render wenv node renderer = do + if _tfsRunning + then createOverlay renderer $ do + saveContext renderer + setTranslation renderer $ wenv ^. L.offset + intersectScissor renderer scissorViewport + setTranslation renderer $ Point (x+w/2) (y+h/2) + setRotation renderer rotation + setTranslation renderer $ Point (-x-w/2) (-y-h/2) + setTranslation renderer $ Point (tx+x*(1-sx)) (ty+y*(1-sy)) + setScale renderer scale + setGlobalAlpha renderer alpha + widgetRender (cnode ^. L.widget) wenv cnode renderer + restoreContext renderer + else widgetRender (cnode ^. L.widget) wenv cnode renderer + where + vp@(Rect x y w h) = node ^. L.info . L.viewport + t = clamp 0 duration $ (wenv ^. L.timestamp) - _tfsStartTs + RenderTransform{..} = mconcat $ f (fromIntegral t) vp + Point tx ty = fromMaybe (Point 0 0) _rtTranslation + scale@(Point sx sy) = fromMaybe (Point 1 1) _rtScale + rotation = fromMaybe 0 _rtRotation + alpha = fromMaybe 1 _rtGlobalAlpha + scissorViewport = fromMaybe vp _rtScissor + cnode = Seq.index (node ^. L.children) 0 diff --git a/src/Monomer/Widgets/Animation/Wipe.hs b/src/Monomer/Widgets/Animation/Wipe.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation/Wipe.hs @@ -0,0 +1,195 @@ +{-| +Module : Monomer.Widgets.Animation.Wipe +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Wipe animation widget. Wraps a child widget whose content will be animated. + +Messages: + +- Accepts a 'AnimationMsg', used to control the state of the animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +module Monomer.Widgets.Animation.Wipe ( + -- * Configuration + WipeCfg, + wipeLeft, + wipeRight, + wipeTop, + wipeBottom, + wipeDoorH, + wipeDoorV, + wipeRect, + -- * Constructors + animWipeIn, + animWipeIn_, + animWipeOut, + animWipeOut_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (.~)) +import Data.Default +import Data.Maybe + +import Monomer.Helper +import Monomer.Widgets.Container +import Monomer.Widgets.Animation.Transform + +import qualified Monomer.Lens as L + +data WipeDirection + = WipeLeft + | WipeRight + | WipeTop + | WipeBottom + | WipeDoorH + | WipeDoorV + | WipeRect + deriving (Eq, Show) + +{-| +Configuration options for wipe: + +- '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. +- 'onFinishedReq': 'WidgetRequest' to generate when animation is complete. +- Individual combinators for direction. +-} +data WipeCfg s e = WipeCfg { + _wpcDirection :: Maybe WipeDirection, + _wpcTransformCfg :: TransformCfg s e +} deriving (Eq, Show) + +instance Default (WipeCfg s e) where + def = WipeCfg { + _wpcDirection = Nothing, + _wpcTransformCfg = def + } + +instance Semigroup (WipeCfg s e) where + (<>) wc1 wc2 = WipeCfg { + _wpcDirection = _wpcDirection wc2 <|> _wpcDirection wc1, + _wpcTransformCfg = _wpcTransformCfg wc1 <> _wpcTransformCfg wc2 + } + +instance Monoid (WipeCfg s e) where + mempty = def + +instance CmbAutoStart (WipeCfg s e) where + autoStart_ start = def { + _wpcTransformCfg = autoStart_ start + } + +instance CmbDuration (WipeCfg s e) Millisecond where + duration dur = def { + _wpcTransformCfg = duration dur + } + +instance WidgetEvent e => CmbOnFinished (WipeCfg s e) e where + onFinished handler = def { + _wpcTransformCfg = onFinished handler + } + +instance CmbOnFinishedReq (WipeCfg s e) s e where + onFinishedReq req = def { + _wpcTransformCfg = onFinishedReq req + } + +-- | Wipe from/to left. +wipeLeft :: WipeCfg s e +wipeLeft = def { _wpcDirection = Just WipeLeft } + +-- | Wipe from/to right. +wipeRight :: WipeCfg s e +wipeRight = def { _wpcDirection = Just WipeRight } + +-- | Wipe from/to top. +wipeTop :: WipeCfg s e +wipeTop = def { _wpcDirection = Just WipeTop } + +-- | Wipe from/to bottom. +wipeBottom :: WipeCfg s e +wipeBottom = def { _wpcDirection = Just WipeBottom } + +-- | Wipe horizontally in a door shape. +wipeDoorH :: WipeCfg s e +wipeDoorH = def { _wpcDirection = Just WipeDoorH } + +-- | Wipe vertically in a door shape. +wipeDoorV :: WipeCfg s e +wipeDoorV = def { _wpcDirection = Just WipeDoorV } + +-- | Wipe in a rectangle shape. +wipeRect :: WipeCfg s e +wipeRect = def { _wpcDirection = Just WipeRect } + +-- | Animates a widget from the left to fully visible. +animWipeIn + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animWipeIn managed = animWipeIn_ def managed + +-- | Animates a widget from the provided direction to fully visible (defaults +-- to left). Accepts config. +animWipeIn_ + :: WidgetEvent e + => [WipeCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animWipeIn_ configs managed = makeNode configs managed True + & L.info . L.widgetType .~ "animWipeIn" + +-- | Animates a widget to the left from visible to not visible. +animWipeOut + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animWipeOut managed = animWipeOut_ def managed + +-- | Animates a widget to the provided direction from visible to not +-- visible (defaults to left). Accepts config. +animWipeOut_ + :: WidgetEvent e + => [WipeCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animWipeOut_ configs managed = makeNode configs managed False + & L.info . L.widgetType .~ "animWipeOut" + +makeNode + :: WidgetEvent e + => [WipeCfg s e] + -> WidgetNode s e + -> Bool + -> WidgetNode s e +makeNode configs managed isWipeIn = node where + node = animTransform_ [_wpcTransformCfg] f managed + f t (Rect x y w h) = [animScissor vp] where + vp = case dir of + WipeLeft -> Rect x y dw h + WipeRight -> Rect (x+(1-(step t))*w) y dw h + WipeTop -> Rect x y w dh + WipeBottom -> Rect x (y+(1-(step t))*h) w dh + WipeDoorH -> Rect dx y dw h + WipeDoorV -> Rect x dy w dh + WipeRect -> Rect dx dy dw dh + (dx, dy) = (x+(1-(step t))*w/2, y+(1-(step t))*h/2) + (dw, dh) = ((step t)*w, (step t)*h) + step t = if isWipeIn + then fwdStep t + else 1-(fwdStep t) + fwdStep t = clamp 0 1 $ t/(fromIntegral dur) + dir = fromMaybe WipeLeft _wpcDirection + dur = fromMaybe 500 _tfcDuration + TransformCfg{..} = _wpcTransformCfg + WipeCfg{..} = mconcat configs diff --git a/src/Monomer/Widgets/Animation/Zoom.hs b/src/Monomer/Widgets/Animation/Zoom.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Animation/Zoom.hs @@ -0,0 +1,136 @@ +{-| +Module : Monomer.Widgets.Animation.Zoom +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Zoom animation widget. Wraps a child widget whose content will be animated. + +Messages: + +- Accepts a 'AnimationMsg', used to control the state of the animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +module Monomer.Widgets.Animation.Zoom ( + -- * Configuration + ZoomCfg, + -- * Constructors + animZoomIn, + animZoomIn_, + animZoomOut, + animZoomOut_ +) where + +import Control.Lens ((&), (.~)) +import Data.Default +import Data.Maybe + +import Monomer.Helper +import Monomer.Widgets.Container +import Monomer.Widgets.Animation.Transform + +import qualified Monomer.Lens as L + +{-| +Configuration options for zoom: + +- '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. +- 'onFinishedReq': 'WidgetRequest' to generate when animation is complete. +-} +newtype ZoomCfg s e = ZoomCfg { + _zmcTransformCfg :: TransformCfg s e +} deriving (Eq, Show) + +instance Default (ZoomCfg s e) where + def = ZoomCfg { + _zmcTransformCfg = def + } + +instance Semigroup (ZoomCfg s e) where + (<>) zc1 zc2 = ZoomCfg { + _zmcTransformCfg = _zmcTransformCfg zc1 <> _zmcTransformCfg zc2 + } + +instance Monoid (ZoomCfg s e) where + mempty = def + +instance CmbAutoStart (ZoomCfg s e) where + autoStart_ start = def { + _zmcTransformCfg = autoStart_ start + } + +instance CmbDuration (ZoomCfg s e) Millisecond where + duration dur = def { + _zmcTransformCfg = duration dur + } + +instance WidgetEvent e => CmbOnFinished (ZoomCfg s e) e where + onFinished handler = def { + _zmcTransformCfg = onFinished handler + } + +instance CmbOnFinishedReq (ZoomCfg s e) s e where + onFinishedReq req = def { + _zmcTransformCfg = onFinishedReq req + } + +-- | Animates a widget to fully visible by increasing scale. +animZoomIn + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animZoomIn managed = animZoomIn_ def managed + +-- | Animates a widget to fully visible by increasing scale. Accepts config. +animZoomIn_ + :: WidgetEvent e + => [ZoomCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animZoomIn_ configs managed = makeNode configs managed True + & L.info . L.widgetType .~ "animZoomIn" + +-- | Animates a widget to not visible by decreasing scale. +animZoomOut + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animZoomOut managed = animZoomOut_ def managed + +-- | Animates a widget to not visible by decreasing scale. Accepts config. +animZoomOut_ + :: WidgetEvent e + => [ZoomCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. +animZoomOut_ configs managed = makeNode configs managed False + & L.info . L.widgetType .~ "animZoomOut" + +makeNode + :: WidgetEvent e + => [ZoomCfg s e] + -> WidgetNode s e + -> Bool + -> WidgetNode s e +makeNode configs managed isZoomIn = node where + node = animTransform_ [_zmcTransformCfg] f managed + f t (Rect _ _ w h) = + [ animTranslation $ Point (ft t w) (ft t h) + , animScale $ Point (fs t) (fs t) + ] + ft t s = (1-(fs t))*s/2 + fs t = if isZoomIn + then fwdStep t + else 1-(fwdStep t) + fwdStep t = clamp 0 1 $ t/(fromIntegral dur) + dur = fromMaybe 500 _tfcDuration + TransformCfg{..} = _zmcTransformCfg + ZoomCfg{..} = mconcat configs diff --git a/src/Monomer/Widgets/Composite.hs b/src/Monomer/Widgets/Composite.hs --- a/src/Monomer/Widgets/Composite.hs +++ b/src/Monomer/Widgets/Composite.hs @@ -66,14 +66,13 @@ import Debug.Trace import Control.Applicative ((<|>)) -import Control.Exception (AssertionFailed(..), throw) -import Control.Lens (ALens', (&), (^.), (^?), (.~), (%~), (<>~), at, ix, non) +import Control.Lens (ALens', (&), (^.), (.~), (%~), (<>~)) import Control.Monad (when) import Data.Default import Data.List (foldl') import Data.Map.Strict (Map) import Data.Maybe -import Data.Sequence (Seq(..), (|>), (<|), fromList) +import Data.Sequence (Seq(..), (|>), (<|)) import Data.Typeable (Typeable, cast, typeOf) import qualified Data.Map.Strict as M @@ -245,6 +244,7 @@ _cmcMergeRequired :: Maybe (MergeRequired s e), _cmcMergeReqs :: [MergeReqsHandler s e sp], _cmcMergeModel :: Maybe (MergeModelHandler s e sp), + _cmcModelFingerprintFn :: Maybe (s -> String), _cmcOnInitReq :: [WidgetRequest s e], _cmcOnDisposeReq :: [WidgetRequest s e], _cmcOnResize :: [Rect -> e], @@ -255,9 +255,10 @@ instance Default (CompositeCfg s e sp ep) where def = CompositeCfg { - _cmcMergeModel = Nothing, _cmcMergeRequired = Nothing, _cmcMergeReqs = [], + _cmcMergeModel = Nothing, + _cmcModelFingerprintFn = Nothing, _cmcOnInitReq = [], _cmcOnDisposeReq = [], _cmcOnResize = [], @@ -268,9 +269,10 @@ instance Semigroup (CompositeCfg s e sp ep) where (<>) c1 c2 = CompositeCfg { - _cmcMergeModel = _cmcMergeModel c2 <|> _cmcMergeModel c1, _cmcMergeRequired = _cmcMergeRequired c2 <|> _cmcMergeRequired c1, _cmcMergeReqs = _cmcMergeReqs c1 <> _cmcMergeReqs c2, + _cmcMergeModel = _cmcMergeModel c2 <|> _cmcMergeModel c1, + _cmcModelFingerprintFn = _cmcModelFingerprintFn c2 <|> _cmcModelFingerprintFn c1, _cmcOnInitReq = _cmcOnInitReq c1 <> _cmcOnInitReq c2, _cmcOnDisposeReq = _cmcOnDisposeReq c1 <> _cmcOnDisposeReq c2, _cmcOnResize = _cmcOnResize c1 <> _cmcOnResize c2, @@ -343,6 +345,16 @@ } {-| +Generates a fingerprint to detect if the model can be reused. + +See 'Monomer.Main.Types.appModelFingerprint' for details. +-} +compositeModelFingerprint :: (s -> String) -> CompositeCfg s e sp ep +compositeModelFingerprint fn = def { + _cmcModelFingerprintFn = Just fn +} + +{-| Generate events during the merge process. This function is not called during initialization; 'onInit' can be used. @@ -361,7 +373,7 @@ Useful when the composite needs a more complex model than what the user is binding. -For example, a database record may be binded as the model from the parent, but +For example, a database record may be bound as the model from the parent, but the composite needs its own boolean flags to toggle visibility on different sections. @@ -380,6 +392,7 @@ _cmpMergeRequired :: MergeRequired s e, _cmpMergeReqs :: [MergeReqsHandler s e sp], _cmpMergeModel :: Maybe (MergeModelHandler s e sp), + _cmpModelFingerprintFn :: Maybe (s -> String), _cmpOnInitReq :: [WidgetRequest s e], _cmpOnDisposeReq :: [WidgetRequest s e], _cmpOnResize :: [Rect -> e], @@ -389,10 +402,11 @@ } data CompositeState s e = CompositeState { + _cpsFingerprint :: !String, _cpsModel :: !(Maybe s), _cpsRoot :: !(WidgetNode s e), _cpsWidgetKeyMap :: WidgetKeyMap s e -} +} deriving Show data ReducedEvents s e sp ep = ReducedEvents { _reModel :: s, @@ -483,6 +497,7 @@ _cmpMergeRequired = mergeReq, _cmpMergeReqs = _cmcMergeReqs config, _cmpMergeModel = _cmcMergeModel config, + _cmpModelFingerprintFn = _cmcModelFingerprintFn config, _cmpOnInitReq = _cmcOnInitReq config, _cmpOnDisposeReq = _cmcOnDisposeReq config, _cmpOnResize = _cmcOnResize config, @@ -490,7 +505,7 @@ _cmpOnEnabledChange = _cmcOnEnabledChange config, _cmpOnVisibleChange = _cmcOnVisibleChange config } - state = CompositeState Nothing widgetRoot M.empty + state = CompositeState "" Nothing widgetRoot M.empty widget = createComposite composite state !newNode = defaultWidgetNode wType widget @@ -542,6 +557,8 @@ WidgetResult root reqs = widgetInit (tempRoot ^. L.widget) cwenv tempRoot !newState = state { + -- Using model could cause issues in merge if the model type changes + _cpsFingerprint = modelFingerprint comp cwenv userModel, _cpsModel = Just model, _cpsRoot = root, _cpsWidgetKeyMap = collectWidgetKeys M.empty root @@ -567,14 +584,19 @@ widgetId = oldComp ^. L.info . L.widgetId oldState = widgetGetState (oldComp ^. L.widget) wenv oldComp validState = fromMaybe state (useState oldState) - CompositeState oldModel oldRoot oldWidgetKeys = validState + CompositeState oldFingerprint oldModel oldRoot oldWidgetKeys = validState !mergeModel = _cmpMergeModel comp !parentModel = wenv ^. L.model !userModel = getUserModel comp wenv + !newFingerprint = modelFingerprint comp cwenv userModel + !discardModelReload = isReload && oldFingerprint /= newFingerprint + !model = case mergeModel of - Just merge -> merge cwenv parentModel (fromJust oldModel) userModel where - cwenv = convertWidgetEnv wenv oldWidgetKeys userModel + Just merge + | not discardModelReload -> mergedModel where + cwenv = convertWidgetEnv wenv oldWidgetKeys userModel + mergedModel = merge cwenv parentModel (fromJust oldModel) userModel _ -> userModel -- Creates new UI using provided function @@ -589,10 +611,11 @@ enabledChg = nodeEnabledChanged oldComp newComp flagsChanged = visibleChg || enabledChg themeChanged = wenv ^. L.themeChanged + isReload = isWidgetReload wenv mergeRequired - | isJust oldModel = modelChanged || flagsChanged || themeChanged + | isJust oldModel = modelChanged || flagsChanged || themeChanged || isReload | otherwise = True - initRequired = not (nodeMatches tempRoot oldRoot) + initRequired = not (nodeMatches tempRoot oldRoot) || discardModelReload useNewRoot = initRequired || mergeRequired WidgetResult !newRoot !tmpReqs @@ -600,6 +623,7 @@ | mergeRequired = widgetMerge tempWidget cwenv tempRoot oldRoot | otherwise = resultNode oldRoot !newState = validState { + _cpsFingerprint = newFingerprint, _cpsModel = Just model, _cpsRoot = newRoot, _cpsWidgetKeyMap = collectWidgetKeys M.empty newRoot @@ -619,9 +643,10 @@ | otherwise = [] evts = RaiseEvent <$> Seq.fromList (visibleEvts ++ enabledEvts) + resizeReqs = [ResizeWidgets widgetId | initRequired] mergeReqsFns = _cmpMergeReqs comp mergeHelper f = f cwenv newRoot oldRoot parentModel (fromJust oldModel) model - mergeReqs = concatMap mergeHelper mergeReqsFns + mergeReqs = resizeReqs ++ concatMap mergeHelper mergeReqsFns extraReqs = seqCatMaybes (toParentReq widgetId <$> Seq.fromList mergeReqs) tmpResult = WidgetResult newRoot (RenderOnce <| tmpReqs <> extraReqs <> evts) @@ -1073,6 +1098,7 @@ convertWidgetEnv wenv widgetKeyMap model = WidgetEnv { _weOs = _weOs wenv, _weDpr = _weDpr wenv, + _weIsGhci = _weIsGhci wenv, _weAppStartTs = _weAppStartTs wenv, _weFontManager = _weFontManager wenv, _weFindBranchByPath = _weFindBranchByPath wenv, @@ -1119,3 +1145,10 @@ sendMsgTo :: Typeable i => WidgetNode s e -> i -> WidgetRequest sp ep sendMsgTo node msg = SendMessage (node ^. L.info . L.widgetId) msg + +modelFingerprint :: Composite s e sp ep -> WidgetEnv s e -> s -> String +modelFingerprint comp wenv !model + | isWidgetReload wenv && isJust fingerprintFn = fromJust fingerprintFn model + | otherwise = "" + where + fingerprintFn = _cmpModelFingerprintFn comp diff --git a/src/Monomer/Widgets/Container.hs b/src/Monomer/Widgets/Container.hs --- a/src/Monomer/Widgets/Container.hs +++ b/src/Monomer/Widgets/Container.hs @@ -49,11 +49,10 @@ ) where import Control.Applicative ((<|>)) -import Control.Exception (AssertionFailed(..), throw) -import Control.Lens ((&), (^.), (^?), (.~), (%~), (<>~), _Just) +import Control.Lens ((&), (^.), (.~), (%~), (<>~)) import Control.Monad import Data.Default -import Data.Foldable (fold, foldl') +import Data.Foldable (foldl') import Data.Maybe import Data.Map.Strict (Map) import Data.Typeable (Typeable) @@ -652,8 +651,9 @@ flagsChanged = nodeFlagsChanged oldNode pNode themeChanged = wenv ^. L.themeChanged + isReload = isWidgetReload wenv mResult - | mergeRequired || flagsChanged || themeChanged = vResult + | isReload || mergeRequired || flagsChanged || themeChanged = vResult | otherwise = pResult & L.node . L.children .~ oldNode ^. L.children mNode = mResult ^. L.node diff --git a/src/Monomer/Widgets/Containers/Alert.hs b/src/Monomer/Widgets/Containers/Alert.hs --- a/src/Monomer/Widgets/Containers/Alert.hs +++ b/src/Monomer/Widgets/Containers/Alert.hs @@ -40,18 +40,15 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (.~), (%~)) +import Control.Lens ((&), (.~)) import Data.Default import Data.Maybe import Data.Text (Text) -import qualified Data.Sequence as Seq - import Monomer.Core import Monomer.Core.Combinators import Monomer.Widgets.Composite -import Monomer.Widgets.Container import Monomer.Widgets.Containers.Box import Monomer.Widgets.Containers.BoxShadow import Monomer.Widgets.Containers.Keystroke @@ -101,27 +98,27 @@ -- | Creates an alert dialog with the provided content. alert - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => e -- ^ The event to raise when the dialog is closed. - -> WidgetNode () e -- ^ The content to display in the dialog. + -> WidgetNode s e -- ^ The content to display in the dialog. -> WidgetNode s e -- ^ The created dialog. alert evt dialogBody = alert_ evt def dialogBody -- | Creates an alert dialog with the provided content. Accepts config. alert_ - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => e -- ^ The event to raise when the dialog is closed. -> [AlertCfg] -- ^ The config options for the dialog. - -> WidgetNode () e -- ^ The content to display in the dialog. + -> WidgetNode s e -- ^ The content to display in the dialog. -> WidgetNode s e -- ^ The created dialog. alert_ evt configs dialogBody = newNode where config = mconcat configs createUI = buildUI (const dialogBody) evt config - newNode = compositeD_ "alert" (WidgetValue ()) createUI handleEvent [] + newNode = compositeD_ "alert" (WidgetLens id) createUI handleEvent [] -- | Creates an alert dialog with a text message as content. alertMsg - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => Text -- ^ The message to display. -> e -- ^ The event to raise when the dialog is closed. -> WidgetNode s e -- ^ The created dialog. @@ -129,7 +126,7 @@ -- | Creates an alert dialog with a text message as content. Accepts config. alertMsg_ - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => Text -- ^ The message to display. -> e -- ^ The event to raise when the dialog is closed. -> [AlertCfg] -- ^ The config options for the dialog. @@ -142,7 +139,7 @@ newNode = compositeD_ "alert" (WidgetValue ()) createUI handleEvent [] buildUI - :: (WidgetModel s, WidgetEvent ep) + :: (CompositeModel s, WidgetEvent ep) => (WidgetEnv s ep -> WidgetNode s ep) -> ep -> AlertCfg diff --git a/src/Monomer/Widgets/Containers/Base/LabeledItem.hs b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs --- a/src/Monomer/Widgets/Containers/Base/LabeledItem.hs +++ b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs @@ -21,10 +21,8 @@ labeledItem ) where -import Control.Applicative ((<|>)) import Data.Default -import Control.Lens ((&), (^.), (^?), (^?!), (.~), (<>~), ix) -import Data.Maybe +import Control.Lens ((&), (^.), (^?!), (.~), (<>~), ix) import Data.Sequence ((|>)) import Data.Text (Text) @@ -36,7 +34,6 @@ 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 diff --git a/src/Monomer/Widgets/Containers/Box.hs b/src/Monomer/Widgets/Containers/Box.hs --- a/src/Monomer/Widgets/Containers/Box.hs +++ b/src/Monomer/Widgets/Containers/Box.hs @@ -323,7 +323,7 @@ newtype BoxState s = BoxState { _bxsModel :: Maybe s -} +} deriving (Show) -- | Creates a box widget with a single node as child. box @@ -357,7 +357,7 @@ containerIgnoreEmptyArea = ignoreEmptyArea && emptyHandlersCount == 0, containerGetCurrentStyle = getCurrentStyle, containerInit = init, - containerMergeChildrenReq = mergeRequired, + containerMergeChildrenReq = mergeChildrenReq, containerMerge = merge, containerFilterEvent = filterEvent, containerHandleEvent = handleEvent, @@ -373,10 +373,12 @@ newNode = node & L.widget .~ makeBox config newState - mergeRequired wenv node oldNode oldState = required where + mergeChildrenReq wenv node oldNode oldState = required where newModel = wenv ^. L.model + isReload = isWidgetReload wenv required = case (_boxMergeRequired config, _bxsModel oldState) of - (Just mergeReqFn, Just oldModel) -> mergeReqFn wenv oldModel newModel + (Just mergeReqFn, Just oldModel) + -> isReload || mergeReqFn wenv oldModel newModel _ -> True merge wenv node oldNode oldState = resultNode newNode where @@ -428,9 +430,7 @@ 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 + reqs = _boxOnBtnReleasedReq config <*> pure btn <*> pure clicks result = Just (resultReqs node reqs) ButtonAction point btn BtnReleased clicks diff --git a/src/Monomer/Widgets/Containers/BoxShadow.hs b/src/Monomer/Widgets/Containers/BoxShadow.hs --- a/src/Monomer/Widgets/Containers/BoxShadow.hs +++ b/src/Monomer/Widgets/Containers/BoxShadow.hs @@ -59,9 +59,9 @@ instance Semigroup BoxShadowCfg where (<>) c1 c2 = BoxShadowCfg { - _bscRadius = _bscRadius c1 <|> _bscRadius c2, - _bscAlignH = _bscAlignH c1 <|> _bscAlignH c2, - _bscAlignV = _bscAlignV c1 <|> _bscAlignV c2 + _bscRadius = _bscRadius c2 <|> _bscRadius c1, + _bscAlignH = _bscAlignH c2 <|> _bscAlignH c1, + _bscAlignV = _bscAlignV c2 <|> _bscAlignV c1 } instance Monoid BoxShadowCfg where diff --git a/src/Monomer/Widgets/Containers/Confirm.hs b/src/Monomer/Widgets/Containers/Confirm.hs --- a/src/Monomer/Widgets/Containers/Confirm.hs +++ b/src/Monomer/Widgets/Containers/Confirm.hs @@ -70,7 +70,7 @@ {-| Configuration options for confirm: -- 'titleCaption': the title of the alert dialog. +- 'titleCaption': the title of the confirm dialog. - 'acceptCaption': the caption of the accept button. - 'cancelCaption': the caption of the cancel button. -} @@ -124,31 +124,31 @@ -- | Creates a confirm dialog with the provided content. confirm - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => e -- ^ The accept button event. -> e -- ^ The cancel button event. - -> WidgetNode () (InnerConfirmEvt e) -- ^ Content to display in the dialog. + -> WidgetNode s (InnerConfirmEvt e) -- ^ Content to display in the dialog. -> WidgetNode s e -- ^ The created dialog. confirm acceptEvt cancelEvt dialogBody = newNode where newNode = confirm_ acceptEvt cancelEvt def dialogBody -- | Creates a confirm dialog with the provided content. Accepts config. confirm_ - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => e -- ^ The accept button event. -> e -- ^ The cancel button event. -> [ConfirmCfg] -- ^ The config options for the dialog. - -> WidgetNode () (InnerConfirmEvt e) -- ^ Content to display in the dialog. + -> WidgetNode s (InnerConfirmEvt e) -- ^ Content to display in the dialog. -> WidgetNode s e -- ^ The created dialog. confirm_ acceptEvt cancelEvt configs dialogBody = newNode where config = mconcat configs createUI = buildUI (const dialogBody) acceptEvt cancelEvt config compCfg = [compositeMergeReqs mergeReqs] - newNode = compositeD_ "confirm" (WidgetValue ()) createUI handleEvent compCfg + newNode = compositeD_ "confirm" (WidgetLens id) createUI handleEvent compCfg -- | Creates a confirm dialog with a text message as content. confirmMsg - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => Text -- ^ The message to display in the dialog. -> e -- ^ The accept button event. -> e -- ^ The cancel button event. @@ -157,7 +157,7 @@ -- | Creates a confirm dialog with a text message as content. Accepts config. confirmMsg_ - :: (WidgetModel s, WidgetEvent e) + :: (CompositeModel s, WidgetEvent e) => Text -- ^ The message to display in the dialog. -> e -- ^ The accept button event. -> e -- ^ The cancel button event. @@ -169,7 +169,7 @@ & L.info . L.style .~ collectTheme wenv L.dialogMsgBodyStyle createUI = buildUI dialogBody acceptEvt cancelEvt config compCfg = [compositeMergeReqs mergeReqs] - newNode = compositeD_ "confirm" (WidgetValue ()) createUI handleEvent compCfg + newNode = compositeD_ "confirm" (WidgetLens id) createUI handleEvent compCfg mergeReqs :: MergeReqsHandler s e sp mergeReqs wenv newNode oldNode parentModel oldModel model = reqs where @@ -180,7 +180,7 @@ | otherwise = [] buildUI - :: (WidgetModel s, WidgetEvent ep) + :: (CompositeModel s, WidgetEvent ep) => (WidgetEnv s (InnerConfirmEvt ep) -> WidgetNode s (InnerConfirmEvt ep)) -> ep -> ep diff --git a/src/Monomer/Widgets/Containers/Draggable.hs b/src/Monomer/Widgets/Containers/Draggable.hs --- a/src/Monomer/Widgets/Containers/Draggable.hs +++ b/src/Monomer/Widgets/Containers/Draggable.hs @@ -30,6 +30,8 @@ DraggableCfg, draggableMaxDim, draggableStyle, + draggableRenderSource, + draggableRenderSource_, draggableRender, -- * Constructors draggable, @@ -37,8 +39,8 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (^?!), (.~), _Just, _1, _2, at, ix) -import Control.Monad (when) +import Control.Lens ((&), (^.), (^?!), (.~), _Just, _2) +import Control.Monad (forM_, when) import Data.Default import Data.Maybe @@ -63,11 +65,12 @@ - 'draggableMaxDim': the maximum size of the largest axis when dragging. Keeps proportions. - 'draggableStyle': the style to use when the item is being dragged. +- 'draggableRenderSource': whether to render the source widget when dragging. - 'draggableRender': rendering function for the dragged state. Allows customizing this step without implementing a custom widget all the lifecycle steps. -The regular styling of this component apply only when the item is not being +The regular styling of this component applies only when the item is not being dragged. To style the dragged container, use draggableStyle. The transparency config only applies to the inner content. @@ -76,6 +79,7 @@ _dgcTransparency :: Maybe Double, _dgcMaxDim :: Maybe Double, _dgcDragStyle :: Maybe StyleState, + _dgcRenderSource :: Maybe Bool, _dgcCustomRender :: Maybe (DraggableRender s e) } @@ -84,6 +88,7 @@ _dgcTransparency = Nothing, _dgcMaxDim = Nothing, _dgcDragStyle = Nothing, + _dgcRenderSource = Nothing, _dgcCustomRender = Nothing } @@ -92,6 +97,7 @@ _dgcTransparency = _dgcTransparency t2 <|> _dgcTransparency t1, _dgcMaxDim = _dgcMaxDim t2 <|> _dgcMaxDim t1, _dgcDragStyle = _dgcDragStyle t2 <|> _dgcDragStyle t1, + _dgcRenderSource = _dgcRenderSource t2 <|> _dgcRenderSource t1, _dgcCustomRender = _dgcCustomRender t2 <|> _dgcCustomRender t1 } @@ -118,6 +124,16 @@ _dgcDragStyle = Just (mconcat styles) } +-- | Renders the source widget when dragging. +draggableRenderSource :: DraggableCfg s e +draggableRenderSource = draggableRenderSource_ True + +-- | Whether to render the source widget when dragging. +draggableRenderSource_ :: Bool -> DraggableCfg s e +draggableRenderSource_ hide = def { + _dgcRenderSource = Just hide +} + -- | Rendering function for the dragged state. draggableRender :: DraggableRender s e -> DraggableCfg s e draggableRender render = def { @@ -150,12 +166,14 @@ makeDraggable :: DragMsg a => a -> DraggableCfg s e -> Widget s e makeDraggable msg config = widget where - widget = createContainer () def { + baseWidget = createContainer () def { containerHandleEvent = handleEvent, containerGetSizeReq = getSizeReq, - containerResize = resize, - containerRender = render + containerResize = resize } + widget = baseWidget { + widgetRender = render + } handleEvent wenv node target evt = case evt of ButtonAction p btn BtnPressed 1 -> Just result where @@ -209,9 +227,13 @@ scOffset = wenv ^. L.offset render wenv node renderer = do + when (not dragged || renderSource) $ + forM_ (node ^. L.children) $ \child -> + widgetRender (child ^. L.widget) wenv child renderer when dragged $ createOverlay renderer $ do renderAction config wenv node renderer where dragged = isNodeDragged wenv node renderAction = fromMaybe defaultRender (_dgcCustomRender config) + renderSource = fromMaybe False (_dgcRenderSource config) diff --git a/src/Monomer/Widgets/Containers/DropTarget.hs b/src/Monomer/Widgets/Containers/DropTarget.hs --- a/src/Monomer/Widgets/Containers/DropTarget.hs +++ b/src/Monomer/Widgets/Containers/DropTarget.hs @@ -36,7 +36,6 @@ ) where import Control.Lens ((&), (^.), (.~)) -import Control.Monad (when) import Data.Default import Data.Maybe import Data.Typeable (cast) diff --git a/src/Monomer/Widgets/Containers/Dropdown.hs b/src/Monomer/Widgets/Containers/Dropdown.hs --- a/src/Monomer/Widgets/Containers/Dropdown.hs +++ b/src/Monomer/Widgets/Containers/Dropdown.hs @@ -51,14 +51,13 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens (ALens', (&), (^.), (^?), (^?!), (.~), (%~), (<>~), _Just, ix, non) +import Control.Lens (ALens', (&), (^.), (^?!), (.~), (%~), (<>~), 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 (Typeable, Proxy, cast, typeRep) +import Data.Sequence (Seq(..), (|>)) +import Data.Typeable (Proxy, cast, typeRep) import GHC.Generics import TextShow @@ -67,7 +66,6 @@ import Monomer.Helper import Monomer.Widgets.Container import Monomer.Widgets.Containers.SelectList -import Monomer.Widgets.Singles.Label import qualified Monomer.Lens as L @@ -83,7 +81,7 @@ - 'onBlurReq': 'WidgetRequest' 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, +- '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. diff --git a/src/Monomer/Widgets/Containers/Keystroke.hs b/src/Monomer/Widgets/Containers/Keystroke.hs --- a/src/Monomer/Widgets/Containers/Keystroke.hs +++ b/src/Monomer/Widgets/Containers/Keystroke.hs @@ -79,10 +79,10 @@ import Debug.Trace (traceShow) import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (^..), (.~), (%~), _1, at, folded) +import Control.Lens ((&), (^.), (^..), (.~), (%~), _1, folded) import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Data.Bifunctor (first) -import Data.Char (chr, isAscii, isPrint, ord) +import Data.Char (isAscii, isPrint, ord) import Data.Default import Data.List (foldl') import Data.Set (Set) @@ -152,7 +152,10 @@ newtype KeyStrokeState e = KeyStrokeState { _kssLatest :: [(KeyStroke, e)] -} deriving (Eq, Show) +} deriving (Eq) + +instance Show (KeyStrokeState e) where + show (KeyStrokeState keys) = show (map fst keys) data KeyEntry = KeyEntryCode KeyCode diff --git a/src/Monomer/Widgets/Containers/Scroll.hs b/src/Monomer/Widgets/Containers/Scroll.hs --- a/src/Monomer/Widgets/Containers/Scroll.hs +++ b/src/Monomer/Widgets/Containers/Scroll.hs @@ -52,7 +52,7 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens (ALens', (&), (^.), (.~), (^?), (^?!), (<>~), (%~), _Just, cloneLens, ix) +import Control.Lens (ALens', (&), (^.), (.~), (^?), (^?!), (<>~), _Just, cloneLens, ix) import Control.Monad import Data.Default import Data.Maybe diff --git a/src/Monomer/Widgets/Containers/SelectList.hs b/src/Monomer/Widgets/Containers/SelectList.hs --- a/src/Monomer/Widgets/Containers/SelectList.hs +++ b/src/Monomer/Widgets/Containers/SelectList.hs @@ -46,25 +46,20 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens (ALens', (&), (^.), (^?), (^?!), (.~), (%~), (?~), (<>~), at, ix, non, _Just) -import Control.Monad (when) +import Control.Lens (ALens', (&), (^.), (.~), (%~), at, ix) import Data.Default import Data.List (foldl') import Data.Maybe -import Data.Sequence (Seq(..), (<|), (|>)) -import Data.Text (Text) +import Data.Sequence (Seq(..), (|>)) import Data.Typeable (Typeable, Proxy, cast, typeRep) import TextShow -import qualified Data.Map as Map import qualified Data.Sequence as Seq 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 @@ -82,7 +77,7 @@ - 'onBlurReq': 'WidgetRequest' 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, +- '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 @@ -211,7 +206,7 @@ => ALens' s a -- ^ The lens into the model. -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. - -> WidgetNode s e -- ^ The created dropdown. + -> WidgetNode s e -- ^ The created select list. selectList field items makeRow = selectList_ field items makeRow def -- | Creates a select list using the given lens. Accepts config. @@ -221,7 +216,7 @@ -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. -> [SelectListCfg s e a] -- ^ The config options. - -> WidgetNode s e -- ^ The created dropdown. + -> WidgetNode s e -- ^ The created select list. selectList_ field items makeRow configs = newNode where newNode = selectListD_ (WidgetLens field) items makeRow configs @@ -232,7 +227,7 @@ -> (Int -> a -> e) -- ^ The event to raise on change. -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. - -> WidgetNode s e -- ^ The created dropdown. + -> WidgetNode s e -- ^ The created select list. selectListV value handler items makeRow = newNode where newNode = selectListV_ value handler items makeRow def @@ -245,20 +240,20 @@ -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. -> [SelectListCfg s e a] -- ^ The config options. - -> WidgetNode s e -- ^ The created dropdown. + -> WidgetNode s e -- ^ The created select list. 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. +-- | Creates a select list providing a 'WidgetData' instance and config. selectListD_ :: forall s e t a . (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. -> SelectListMakeRow s e a -- ^ Function to create the list items. -> [SelectListCfg s e a] -- ^ The config options. - -> WidgetNode s e -- ^ The created dropdown. + -> WidgetNode s e -- ^ The created select list. selectListD_ widgetData items makeRow configs = makeNode wtype widget where config = mconcat configs newItems = foldl' (|>) Empty items @@ -315,8 +310,9 @@ mergeChildrenReq wenv node oldNode oldState = result where oldItems = _prevItems oldState + isReload = isWidgetReload wenv mergeRequiredFn = fromMaybe (const (/=)) (_slcMergeRequired config) - result = mergeRequiredFn wenv oldItems items + result = isReload || mergeRequiredFn wenv oldItems items merge wenv node oldNode oldState = resultNode newNode where selected = currentValue wenv diff --git a/src/Monomer/Widgets/Containers/Split.hs b/src/Monomer/Widgets/Containers/Split.hs --- a/src/Monomer/Widgets/Containers/Split.hs +++ b/src/Monomer/Widgets/Containers/Split.hs @@ -45,7 +45,6 @@ import Control.Lens (ALens', (&), (^.), (.~), (<>~)) import Data.Default import Data.Maybe -import Data.Tuple (swap) import GHC.Generics import qualified Data.Sequence as Seq diff --git a/src/Monomer/Widgets/Containers/Stack.hs b/src/Monomer/Widgets/Containers/Stack.hs --- a/src/Monomer/Widgets/Containers/Stack.hs +++ b/src/Monomer/Widgets/Containers/Stack.hs @@ -51,12 +51,11 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (.~), (%~)) +import Control.Lens ((&), (.~), (%~)) import Data.Default -import Data.Foldable (toList) import Data.List (foldl') import Data.Maybe -import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Sequence (Seq(..), (|>)) import qualified Data.Sequence as Seq diff --git a/src/Monomer/Widgets/Containers/ThemeSwitch.hs b/src/Monomer/Widgets/Containers/ThemeSwitch.hs --- a/src/Monomer/Widgets/Containers/ThemeSwitch.hs +++ b/src/Monomer/Widgets/Containers/ThemeSwitch.hs @@ -40,10 +40,8 @@ ) where import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Lens ((&), (^.), (.~), (%~), at) +import Control.Lens ((&), (^.), (.~)) import Data.Default -import Data.Maybe import qualified Data.Sequence as Seq @@ -88,7 +86,7 @@ data ThemeSwitchState = ThemeSwitchState { _tssPrevTheme :: Maybe Theme, _tssChanged :: Bool -} +} deriving (Show) -- | Switches to a new theme starting from its child node. themeSwitch diff --git a/src/Monomer/Widgets/Containers/Tooltip.hs b/src/Monomer/Widgets/Containers/Tooltip.hs --- a/src/Monomer/Widgets/Containers/Tooltip.hs +++ b/src/Monomer/Widgets/Containers/Tooltip.hs @@ -34,7 +34,7 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (.~), (%~), at) +import Control.Lens ((&), (^.), (.~)) import Control.Monad (forM_, when) import Data.Default import Data.Maybe diff --git a/src/Monomer/Widgets/Containers/ZStack.hs b/src/Monomer/Widgets/Containers/ZStack.hs --- a/src/Monomer/Widgets/Containers/ZStack.hs +++ b/src/Monomer/Widgets/Containers/ZStack.hs @@ -38,12 +38,12 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (^?), (.~), (%~), (?~), at, ix) -import Control.Monad (forM_, void, when) +import Control.Lens ((&), (^.), (^?), (.~), (%~), at, ix) +import Control.Monad (void, when) import Data.Default import Data.Maybe -import Data.List (foldl', any) -import Data.Sequence (Seq(..), (<|), (|>)) +import Data.List (foldl') +import Data.Sequence (Seq(..), (|>)) import GHC.Generics import qualified Data.Map.Strict as M diff --git a/src/Monomer/Widgets/Single.hs b/src/Monomer/Widgets/Single.hs --- a/src/Monomer/Widgets/Single.hs +++ b/src/Monomer/Widgets/Single.hs @@ -39,13 +39,12 @@ createSingle ) where -import Control.Exception (AssertionFailed(..), throw) -import Control.Lens ((&), (^.), (^?), (.~), (%~), _Just) +import Control.Lens ((&), (^.), (.~), (%~)) import Control.Monad (when) import Data.Default import Data.Maybe import Data.Sequence (Seq(..), (|>)) -import Data.Typeable (Typeable, cast) +import Data.Typeable (Typeable) import qualified Data.Sequence as Seq @@ -499,7 +498,7 @@ newReq = SetFocus (node ^. L.info . L.widgetId) newResult - | isFocusReq && isJust mResult = (& L.requests %~ (|> newReq)) <$> mResult + | isFocusReq && isJust mResult = (L.requests %~ (|> newReq)) <$> mResult | isFocusReq = Just $ resultReqs node [newReq] | otherwise = mResult diff --git a/src/Monomer/Widgets/Singles/Button.hs b/src/Monomer/Widgets/Singles/Button.hs --- a/src/Monomer/Widgets/Singles/Button.hs +++ b/src/Monomer/Widgets/Singles/Button.hs @@ -60,9 +60,9 @@ - '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. +- 'resizeFactor': flexibility to have more or less space assigned. +- 'resizeFactorW': flexibility to have more or less horizontal space assigned. +- 'resizeFactorH': flexibility to have more or less vertical space assigned. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. diff --git a/src/Monomer/Widgets/Singles/Checkbox.hs b/src/Monomer/Widgets/Singles/Checkbox.hs --- a/src/Monomer/Widgets/Singles/Checkbox.hs +++ b/src/Monomer/Widgets/Singles/Checkbox.hs @@ -43,8 +43,6 @@ import Data.Default import Data.Maybe -import qualified Data.Sequence as Seq - import Monomer.Widgets.Single import qualified Monomer.Lens as L diff --git a/src/Monomer/Widgets/Singles/ColorPicker.hs b/src/Monomer/Widgets/Singles/ColorPicker.hs --- a/src/Monomer/Widgets/Singles/ColorPicker.hs +++ b/src/Monomer/Widgets/Singles/ColorPicker.hs @@ -39,12 +39,10 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (.~), ALens', abbreviatedFields, makeLensesWith) -import Data.ByteString (ByteString) +import Control.Lens (ALens') 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 diff --git a/src/Monomer/Widgets/Singles/ColorPopup.hs b/src/Monomer/Widgets/Singles/ColorPopup.hs --- a/src/Monomer/Widgets/Singles/ColorPopup.hs +++ b/src/Monomer/Widgets/Singles/ColorPopup.hs @@ -35,10 +35,8 @@ colorPopupV_ ) where -import Control.Applicative ((<|>)) import Control.Lens ((&), (^.), (.~), (?~), ALens', abbreviatedFields, makeLensesWith, non) import Data.Default -import Data.Text (Text) import Monomer.Core.Combinators import Monomer.Graphics.Types @@ -46,7 +44,6 @@ import Monomer.Widgets.Composite import Monomer.Widgets.Containers.BoxShadow import Monomer.Widgets.Containers.Popup -import Monomer.Widgets.Containers.Stack import Monomer.Widgets.Singles.ColorPicker import Monomer.Widgets.Singles.ToggleButton diff --git a/src/Monomer/Widgets/Singles/DateField.hs b/src/Monomer/Widgets/Singles/DateField.hs --- a/src/Monomer/Widgets/Singles/DateField.hs +++ b/src/Monomer/Widgets/Singles/DateField.hs @@ -86,7 +86,7 @@ defaultDateDelim = '/' {-| -Converter to and form the Day type of the time library. To use types other than +Converter to and from 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 @@ -151,7 +151,7 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes 'ResizeWidgets' requests. - 'selectOnFocus': Whether all input should be selected when focus is received. -- 'readOnly': Whether to prevent the user changing the input text. +- 'readOnly': Whether to prevent the user from changing the input text. - 'minValue': Minimum valid date. - 'maxValue': Maximum valid date. - 'wheelRate': The rate at which wheel movement affects the date. diff --git a/src/Monomer/Widgets/Singles/Dial.hs b/src/Monomer/Widgets/Singles/Dial.hs --- a/src/Monomer/Widgets/Singles/Dial.hs +++ b/src/Monomer/Widgets/Singles/Dial.hs @@ -39,10 +39,8 @@ import Control.Applicative ((<|>)) import Control.Lens (ALens', (&), (^.), (.~), (<>~)) -import Control.Monad import Data.Default import Data.Maybe -import Data.Text (Text) import Data.Typeable (Typeable, typeOf) import GHC.Generics import TextShow diff --git a/src/Monomer/Widgets/Singles/ExternalLink.hs b/src/Monomer/Widgets/Singles/ExternalLink.hs --- a/src/Monomer/Widgets/Singles/ExternalLink.hs +++ b/src/Monomer/Widgets/Singles/ExternalLink.hs @@ -27,10 +27,8 @@ externalLink_ ) where -import Control.Applicative ((<|>)) import Control.Lens ((&), (^.), (.~)) import Data.Default -import Data.Maybe import Data.Text (Text) import System.Process (callCommand) @@ -50,9 +48,9 @@ - '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. +- 'resizeFactor': flexibility to have more or less space assigned. +- 'resizeFactorW': flexibility to have more or less horizontal space assigned. +- 'resizeFactorH': flexibility to have more or less vertical space assigned. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. diff --git a/src/Monomer/Widgets/Singles/Image.hs b/src/Monomer/Widgets/Singles/Image.hs --- a/src/Monomer/Widgets/Singles/Image.hs +++ b/src/Monomer/Widgets/Singles/Image.hs @@ -43,14 +43,12 @@ import Control.Applicative ((<|>)) import Control.Concurrent import Control.Exception (try) -import Control.Lens ((&), (^.), (.~), (%~), (?~), at) +import Control.Lens ((&), (^.), (.~), (?~), at) import Control.Monad (when) import Data.ByteString (ByteString) -import Data.Char (toLower) import Data.Default import Data.Map.Strict (Map) import Data.Maybe -import Data.List (isPrefixOf) import Data.Text (Text) import Data.Typeable (cast) import Data.Vector.Storable.ByteString (vectorToByteString) diff --git a/src/Monomer/Widgets/Singles/Label.hs b/src/Monomer/Widgets/Singles/Label.hs --- a/src/Monomer/Widgets/Singles/Label.hs +++ b/src/Monomer/Widgets/Singles/Label.hs @@ -58,9 +58,9 @@ - '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. +- 'resizeFactor': flexibility to have more or less space assigned. +- 'resizeFactorW': flexibility to have more or less horizontal space assigned. +- 'resizeFactorH': flexibility to have more or less vertical space assigned. -} data LabelCfg s e = LabelCfg { _lscIgnoreTheme :: Maybe Bool, diff --git a/src/Monomer/Widgets/Singles/LabeledCheckbox.hs b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs --- a/src/Monomer/Widgets/Singles/LabeledCheckbox.hs +++ b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs @@ -35,21 +35,16 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens (ALens', (&), (^.), (.~)) -import Control.Monad +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.Checkbox import Monomer.Widgets.Singles.Label -import qualified Monomer.Lens as L - {-| Configuration options for labeledCheckbox: @@ -67,9 +62,9 @@ - '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 for more or less horizontal spaced assigned. - - 'resizeFactorH': flexibility for more or less vertical spaced assigned. + - 'resizeFactor': flexibility to have more or less space assigned. + - 'resizeFactorW': flexibility for more or less horizontal space assigned. + - 'resizeFactorH': flexibility for more or less vertical space assigned. - Checkbox related diff --git a/src/Monomer/Widgets/Singles/LabeledRadio.hs b/src/Monomer/Widgets/Singles/LabeledRadio.hs --- a/src/Monomer/Widgets/Singles/LabeledRadio.hs +++ b/src/Monomer/Widgets/Singles/LabeledRadio.hs @@ -37,22 +37,18 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens (ALens', (&), (^.), (.~)) +import Control.Lens (ALens') import Data.Default import Data.Maybe import Data.Text (Text) import Data.Typeable (typeOf) import TextShow -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 - {-| Configuration options for labeledRadio: @@ -70,9 +66,9 @@ - '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 for more or less horizontal spaced assigned. - - 'resizeFactorH': flexibility for more or less vertical spaced assigned. + - 'resizeFactor': flexibility to have more or less space assigned. + - 'resizeFactorW': flexibility for more or less horizontal space assigned. + - 'resizeFactorH': flexibility for more or less vertical space assigned. - Radio related diff --git a/src/Monomer/Widgets/Singles/NumericField.hs b/src/Monomer/Widgets/Singles/NumericField.hs --- a/src/Monomer/Widgets/Singles/NumericField.hs +++ b/src/Monomer/Widgets/Singles/NumericField.hs @@ -123,7 +123,7 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. - 'selectOnFocus': Whether all input should be selected when focus is received. -- 'readOnly': Whether to prevent the user changing the input text. +- 'readOnly': Whether to prevent the user from changing the input text. - 'minValue': Minimum valid number. - 'maxValue': Maximum valid number. - 'wheelRate': The rate at which wheel movement affects the number. diff --git a/src/Monomer/Widgets/Singles/OptionButton.hs b/src/Monomer/Widgets/Singles/OptionButton.hs --- a/src/Monomer/Widgets/Singles/OptionButton.hs +++ b/src/Monomer/Widgets/Singles/OptionButton.hs @@ -18,7 +18,7 @@ This widget, and the associated "Monomer.Widgets.Singles.ToggleButton", uses two separate styles for the On and Off states which can be modified individually for -the theme. If you use any of the the standard style functions (styleBasic, +the theme. If you use any of the standard style functions (styleBasic, styleHover, etc) in an optionButton/toggleButton these changes will apply to both On and Off states, except for the color related styles. The reason is that, in general, the font and padding will be the same for both states, but the @@ -59,8 +59,7 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens (ALens', Lens', (&), (^.), (^?), (.~), (?~), _Just) -import Control.Monad +import Control.Lens (ALens', Lens', (&), (^.), (.~), _Just) import Data.Default import Data.Maybe import Data.Text (Text) @@ -86,9 +85,9 @@ - '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. +- 'resizeFactor': flexibility to have more or less space assigned. +- 'resizeFactorW': flexibility to have more or less horizontal space assigned. +- 'resizeFactorH': flexibility to have more or less vertical space assigned. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. diff --git a/src/Monomer/Widgets/Singles/Radio.hs b/src/Monomer/Widgets/Singles/Radio.hs --- a/src/Monomer/Widgets/Singles/Radio.hs +++ b/src/Monomer/Widgets/Singles/Radio.hs @@ -43,7 +43,6 @@ import Control.Monad import Data.Default import Data.Maybe -import Data.Text (Text) import Data.Typeable (Typeable, typeOf) import TextShow diff --git a/src/Monomer/Widgets/Singles/SeparatorLine.hs b/src/Monomer/Widgets/Singles/SeparatorLine.hs --- a/src/Monomer/Widgets/Singles/SeparatorLine.hs +++ b/src/Monomer/Widgets/Singles/SeparatorLine.hs @@ -38,7 +38,6 @@ import Control.Lens ((^.)) import Data.Default import Data.Maybe -import Data.Tuple import Monomer.Widgets.Single @@ -48,7 +47,7 @@ Configuration options for separatorLine: - 'width': the max width of the line. -- 'resizeFactor': flexibility to have more or less spaced assigned. +- 'resizeFactor': flexibility to have more or less space assigned. -} data SeparatorLineCfg = SeparatorLineCfg { _slcWidth :: Maybe Double, diff --git a/src/Monomer/Widgets/Singles/Slider.hs b/src/Monomer/Widgets/Singles/Slider.hs --- a/src/Monomer/Widgets/Singles/Slider.hs +++ b/src/Monomer/Widgets/Singles/Slider.hs @@ -46,7 +46,6 @@ import Control.Monad import Data.Default import Data.Maybe -import Data.Text (Text) import Data.Typeable (Typeable, typeOf) import GHC.Generics import TextShow diff --git a/src/Monomer/Widgets/Singles/Spacer.hs b/src/Monomer/Widgets/Singles/Spacer.hs --- a/src/Monomer/Widgets/Singles/Spacer.hs +++ b/src/Monomer/Widgets/Singles/Spacer.hs @@ -45,7 +45,6 @@ import Control.Lens ((^.)) import Data.Default import Data.Maybe -import Data.Tuple import Monomer.Widgets.Single @@ -55,7 +54,7 @@ Configuration options for spacer widget: - 'width': the max width for spacer, the reference for filler. -- 'resizeFactor': flexibility to have more or less spaced assigned. +- 'resizeFactor': flexibility to have more or less space assigned. -} data SpacerCfg = SpacerCfg { _spcWidth :: Maybe Double, diff --git a/src/Monomer/Widgets/Singles/TextArea.hs b/src/Monomer/Widgets/Singles/TextArea.hs --- a/src/Monomer/Widgets/Singles/TextArea.hs +++ b/src/Monomer/Widgets/Singles/TextArea.hs @@ -74,7 +74,7 @@ - 'acceptTab': whether to handle tab and convert it to spaces (cancelling change of focus), or keep default behaviour and lose focus. - 'selectOnFocus': Whether all input should be selected when focus is received. -- 'readOnly': Whether to prevent the user changing the input text. +- 'readOnly': Whether to prevent the user from changing the input text. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. diff --git a/src/Monomer/Widgets/Singles/TextField.hs b/src/Monomer/Widgets/Singles/TextField.hs --- a/src/Monomer/Widgets/Singles/TextField.hs +++ b/src/Monomer/Widgets/Singles/TextField.hs @@ -62,7 +62,7 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. - 'selectOnFocus': Whether all input should be selected when focus is received. -- 'readOnly': Whether to prevent the user changing the input text. +- 'readOnly': Whether to prevent the user from changing the input text. - 'maxLength': the maximum length of input text. - 'textFieldDisplayChar': the character that will be displayed as replacement of the real text. Useful for password fields. diff --git a/src/Monomer/Widgets/Singles/TimeField.hs b/src/Monomer/Widgets/Singles/TimeField.hs --- a/src/Monomer/Widgets/Singles/TimeField.hs +++ b/src/Monomer/Widgets/Singles/TimeField.hs @@ -82,7 +82,7 @@ defaultTimeDelim = ':' {-| -Converter to and form the 'TimeOfDay' type of the time library. To use types +Converter to and from 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 @@ -147,7 +147,7 @@ warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. - 'selectOnFocus': Whether all input should be selected when focus is received. -- 'readOnly': Whether to prevent the user changing the input text. +- 'readOnly': Whether to prevent the user from changing the input text. - 'minValue': Minimum valid time. - 'maxValue': Maximum valid time. - 'wheelRate': The rate at which wheel movement affects the time. diff --git a/src/Monomer/Widgets/Singles/ToggleButton.hs b/src/Monomer/Widgets/Singles/ToggleButton.hs --- a/src/Monomer/Widgets/Singles/ToggleButton.hs +++ b/src/Monomer/Widgets/Singles/ToggleButton.hs @@ -34,13 +34,10 @@ toggleButtonD_ ) where -import Control.Applicative ((<|>)) -import Control.Lens (ALens', (&), (^.), (^?), (.~), (?~), _Just) +import Control.Lens (ALens', (&), (.~)) import Data.Default import Data.Text (Text) -import qualified Data.Sequence as Seq - import Monomer.Widgets.Single import Monomer.Widgets.Singles.OptionButton @@ -55,9 +52,9 @@ - '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. +- 'resizeFactor': flexibility to have more or less space assigned. +- 'resizeFactorW': flexibility to have more or less horizontal space assigned. +- 'resizeFactorH': flexibility to have more or less vertical space assigned. - 'onFocus': event to raise when focus is received. - 'onFocusReq': 'WidgetRequest' to generate when focus is received. - 'onBlur': event to raise when focus is lost. diff --git a/src/Monomer/Widgets/Util/Drawing.hs b/src/Monomer/Widgets/Util/Drawing.hs --- a/src/Monomer/Widgets/Util/Drawing.hs +++ b/src/Monomer/Widgets/Util/Drawing.hs @@ -39,18 +39,16 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens ((&), (^.), (^?), (^?!), (.~), non) -import Control.Monad (forM_, void, when) +import Control.Lens ((^.), (^?!), non) +import Control.Monad (forM_, when) 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. diff --git a/src/Monomer/Widgets/Util/Focus.hs b/src/Monomer/Widgets/Util/Focus.hs --- a/src/Monomer/Widgets/Util/Focus.hs +++ b/src/Monomer/Widgets/Util/Focus.hs @@ -26,10 +26,7 @@ handleFocusChange ) where -import Control.Lens ((&), (^.), (.~), (%~)) -import Data.Maybe -import Data.Sequence (Seq(..), (|>)) -import Data.Typeable (Typeable) +import Control.Lens ((^.)) import qualified Data.Sequence as Seq diff --git a/src/Monomer/Widgets/Util/Hover.hs b/src/Monomer/Widgets/Util/Hover.hs --- a/src/Monomer/Widgets/Util/Hover.hs +++ b/src/Monomer/Widgets/Util/Hover.hs @@ -30,7 +30,7 @@ isNodeInfoInOverlay ) where -import Control.Lens ((&), (^.), (^?), _1, _Just) +import Control.Lens ((^.), (^?), _1, _Just) import Data.Maybe import qualified Data.Sequence as Seq diff --git a/src/Monomer/Widgets/Util/Keyboard.hs b/src/Monomer/Widgets/Util/Keyboard.hs --- a/src/Monomer/Widgets/Util/Keyboard.hs +++ b/src/Monomer/Widgets/Util/Keyboard.hs @@ -19,10 +19,6 @@ isKeyboardRedo ) where -import Data.Maybe (fromMaybe) - -import qualified Data.Map as M - import Monomer.Core import Monomer.Event.Keyboard import Monomer.Event.Types diff --git a/src/Monomer/Widgets/Util/Style.hs b/src/Monomer/Widgets/Util/Style.hs --- a/src/Monomer/Widgets/Util/Style.hs +++ b/src/Monomer/Widgets/Util/Style.hs @@ -28,13 +28,11 @@ childOfFocusedStyle ) where -import Control.Applicative ((<|>)) import Control.Lens hiding ((<|), (|>)) -import Data.Bits (xor) import Data.Default import Data.Maybe -import Data.Sequence (Seq(..), (<|), (|>)) +import Data.Sequence ((<|), (|>)) import qualified Data.Sequence as Seq diff --git a/src/Monomer/Widgets/Util/Text.hs b/src/Monomer/Widgets/Util/Text.hs --- a/src/Monomer/Widgets/Util/Text.hs +++ b/src/Monomer/Widgets/Util/Text.hs @@ -18,9 +18,8 @@ getTextGlyphs ) where -import Control.Lens ((&), (^.), (+~)) -import Data.Default -import Data.Sequence (Seq(..), (<|), (|>)) +import Control.Lens ((^.)) +import Data.Sequence (Seq(..)) import Data.Text (Text) import Monomer.Core diff --git a/src/Monomer/Widgets/Util/Theme.hs b/src/Monomer/Widgets/Util/Theme.hs --- a/src/Monomer/Widgets/Util/Theme.hs +++ b/src/Monomer/Widgets/Util/Theme.hs @@ -14,9 +14,8 @@ module Monomer.Widgets.Util.Theme where -import Control.Lens (Lens', (&), (^.), (^?), (.~), (?~), (<>~), at, non) +import Control.Lens (Lens', (&), (^.), (.~), (<>~), at, non) import Data.Default -import Data.Maybe import Monomer.Core.StyleTypes import Monomer.Core.ThemeTypes diff --git a/src/Monomer/Widgets/Util/Widget.hs b/src/Monomer/Widgets/Util/Widget.hs --- a/src/Monomer/Widgets/Util/Widget.hs +++ b/src/Monomer/Widgets/Util/Widget.hs @@ -34,19 +34,16 @@ nodeMatches, handleWidgetIdChange, delayedMessage, - delayedMessage_ + delayedMessage_, + isWidgetReload ) where import Control.Concurrent (threadDelay) -import Control.Lens ((&), (^#), (#~), (^.), (^?), (.~), (%~), _Just) +import Control.Lens ((&), (^#), (#~), (^.), (.~), (%~)) import Data.Default -import Data.Maybe -import Data.Map.Strict (Map) -import Data.Sequence (Seq(..), (<|)) -import Data.Text (Text) +import Data.Sequence ((<|)) import Data.Typeable (Typeable, cast) -import qualified Data.Map.Strict as M import qualified Data.Sequence as Seq import Monomer.Common @@ -118,7 +115,7 @@ {-| Generates a model update request with the provided value when the WidgetData is -WidgetLens. For WidgetValue and onChange event should be used. +WidgetLens. For WidgetValue an onChange event should be used. -} widgetDataSet :: WidgetData s a -> a -> [WidgetRequest s e] widgetDataSet WidgetValue{} _ = [] @@ -213,3 +210,6 @@ delayedMessage_ widgetId path msg delay = RunTask widgetId path $ do threadDelay (fromIntegral delay * 1000) return msg + +isWidgetReload :: WidgetEnv s e -> Bool +isWidgetReload wenv = wenv ^. L.isGhci && wenv ^. L.timestamp == 0 diff --git a/test/unit/Monomer/TestUtil.hs b/test/unit/Monomer/TestUtil.hs --- a/test/unit/Monomer/TestUtil.hs +++ b/test/unit/Monomer/TestUtil.hs @@ -15,6 +15,7 @@ import Control.Concurrent (newMVar) import Control.Concurrent.STM.TChan (newTChanIO) import Control.Lens ((&), (^.), (.~), (.=), (+~)) +import Control.Monad (foldM) import Control.Monad.State import Data.Default import Data.Maybe @@ -151,6 +152,7 @@ renderRoundedRect = \rect r1 r2 r3 r4 -> return (), renderArc = \center radius angleStart angleEnd winding -> return (), renderQuadTo = \p1 p2 -> return (), + renderBezierTo = \p1 p2 p3 -> return (), renderEllipse = \rect -> return (), -- Text renderText = mockRenderText, @@ -176,6 +178,7 @@ mockWenv model = WidgetEnv { _weOs = "Mac OS X", _weDpr = 2, + _weIsGhci = False, _weAppStartTs = 0, _weFontManager = mockFontManager, _weFindBranchByPath = const Seq.empty, diff --git a/test/unit/Monomer/Widgets/Animation/ShakeSpec.hs b/test/unit/Monomer/Widgets/Animation/ShakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Animation/ShakeSpec.hs @@ -0,0 +1,98 @@ +{-| +Module : Monomer.Widgets.Animation.ShakeSpec +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Unit tests for Shake animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Animation.ShakeSpec (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.Shake +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 "Shake" $ 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 = animShake (label "Test") + nodeAuto = animShake_ [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 0) `shouldBe` Seq.singleton OnTestFinished + + where + wenv = mockWenv () + baseNode = animShake_ [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 (animShake lblNode) diff --git a/test/unit/Monomer/Widgets/Animation/TransformSpec.hs b/test/unit/Monomer/Widgets/Animation/TransformSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Animation/TransformSpec.hs @@ -0,0 +1,101 @@ +{-| +Module : Monomer.Widgets.Animation.TransformSpec +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Unit tests for Transform animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Animation.TransformSpec (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.Transform +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 "Transform" $ 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 () + f _ _ = [] + nodeNormal = animTransform f (label "Test") + nodeAuto = animTransform_ [autoStart, duration 100] f (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 0) `shouldBe` Seq.singleton OnTestFinished + + where + wenv = mockWenv () + f _ _ = [] + baseNode = animTransform_ [autoStart, duration 100, onFinished OnTestFinished] f (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" + f _ _ = [] + (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode + (tSizeReqW, tSizeReqH) = nodeGetSizeReq wenv (animTransform f lblNode) diff --git a/test/unit/Monomer/Widgets/Animation/WipeSpec.hs b/test/unit/Monomer/Widgets/Animation/WipeSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Animation/WipeSpec.hs @@ -0,0 +1,98 @@ +{-| +Module : Monomer.Widgets.Animation.WipeSpec +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Unit tests for Wipe animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Animation.WipeSpec (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.Wipe +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 "Wipe" $ 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 = animWipeIn (label "Test") + nodeAuto = animWipeIn_ [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 0) `shouldBe` Seq.singleton OnTestFinished + + where + wenv = mockWenv () + baseNode = animWipeIn_ [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 (animWipeIn lblNode) diff --git a/test/unit/Monomer/Widgets/Animation/ZoomSpec.hs b/test/unit/Monomer/Widgets/Animation/ZoomSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Animation/ZoomSpec.hs @@ -0,0 +1,98 @@ +{-| +Module : Monomer.Widgets.Animation.ZoomSpec +Copyright : (c) 2023 Ruslan Gadeev, Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Unit tests for Zoom animation. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Monomer.Widgets.Animation.ZoomSpec (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.Zoom +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 "Zoom" $ 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 = animZoomIn (label "Test") + nodeAuto = animZoomIn_ [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 0) `shouldBe` Seq.singleton OnTestFinished + + where + wenv = mockWenv () + baseNode = animZoomIn_ [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 (animZoomIn lblNode) diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs --- a/test/unit/Spec.hs +++ b/test/unit/Spec.hs @@ -18,7 +18,11 @@ import qualified Monomer.Widgets.ContainerSpec as ContainerSpec import qualified Monomer.Widgets.Animation.FadeSpec as AnimationFadeSpec +import qualified Monomer.Widgets.Animation.ShakeSpec as AnimationShakeSpec import qualified Monomer.Widgets.Animation.SlideSpec as AnimationSlideSpec +import qualified Monomer.Widgets.Animation.TransformSpec as AnimationTransformSpec +import qualified Monomer.Widgets.Animation.WipeSpec as AnimationWipeSpec +import qualified Monomer.Widgets.Animation.ZoomSpec as AnimationZoomSpec import qualified Monomer.Widgets.Containers.AlertSpec as AlertSpec import qualified Monomer.Widgets.Containers.BoxSpec as BoxSpec @@ -110,7 +114,11 @@ animation :: Spec animation = describe "Animation" $ do AnimationFadeSpec.spec + AnimationShakeSpec.spec AnimationSlideSpec.spec + AnimationTransformSpec.spec + AnimationWipeSpec.spec + AnimationZoomSpec.spec containers :: Spec containers = describe "Containers" $ do