mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 12:05:35 +03:00
Improve development time application reload (#239)
* Consider SDL.TextEditingEvent as an action event
* When a frame requires rendering, make sure the next one is also rendered to avoid artifacts. It still does not render every frame
* Fix lint
* Fix typo
* Add foreign-store dependency
* Reuse window and avoid reinitializing SDL when running on ghci and code is reloaded
* Restore previous model and widget root on code changes
* Attempt to check if model's type changed (failed, since fingerprinting is not reliable)
* Add Show instances to various widgets
* Add configuration for fingerprint functions
* Merge new root with stored root, to account for code changes in new root and data in old
* Store the complete MonomerCtx type for app reload
* Use recover-rtti for model change detection
* Process WidgetResult when merging reloaded widget root
* Validate model changes in Composite
* Fix lint
* Fix unit tests
* Force hpack version in monomer.cabal
* Add appDisableModelReuse configuration option to always ignore previous model version
* Minor setup docs update
* Revert to AppConfig only being parameterized by e
* Restore recover-rtti dependency
* Revert "Revert to AppConfig only being parameterized by e"
This reverts commit 0a66513807
.
* Revert to previous version without restore-rtti dependency
* Try to overcome build issue by enforcing ubuntu-20.04
* Do not commit .dylib files
* For hpack version
* Fix docs
* Fix missing imports
* Fix typo
This commit is contained in:
parent
e88d5d916e
commit
5b90aebae9
@ -56,6 +56,7 @@ main = do
|
||||
appWindowIcon "./assets/images/icon.png",
|
||||
appTheme darkTheme,
|
||||
appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",
|
||||
appInitEvent AppInit
|
||||
appInitEvent AppInit,
|
||||
appModelFingerprint show
|
||||
]
|
||||
model = AppModel 0
|
||||
|
@ -195,7 +195,7 @@ non-threaded modes.
|
||||
|
||||
## Development mode
|
||||
|
||||
Since compilation times can be annoying, I personally prefer to rely on
|
||||
Since compilation times can be annoying, I prefer to rely on
|
||||
[ghcid](https://github.com/ndmitchell/ghcid) for a nicer development experience.
|
||||
First, you need to install it:
|
||||
|
||||
@ -209,19 +209,30 @@ Then, inside your project's directory:
|
||||
ghcid
|
||||
```
|
||||
|
||||
With this you will be running your application in interpreted mode (`ghcid`
|
||||
under the hood uses `ghci`), allowing you to make changes and test them almost
|
||||
immediately.
|
||||
|
||||
If the `appModelFingerprint` setting is provided, Monomer will attempt to reuse
|
||||
the active model when the application is reloaded. This allows for faster
|
||||
iteration since the application will return to the previous state but with all
|
||||
the code and style changes that triggered the reload. Closing the window causes
|
||||
the old model to be discarded, and the application will start from scratch when
|
||||
reloaded.
|
||||
|
||||
In general, this will work fine, but in some cases modifying data types can
|
||||
cause ghci to crash. Restarting ghcid/ghci will solve the issue. You can read
|
||||
more details
|
||||
[here](https://hackage.haskell.org/package/monomer/docs/Monomer-Main-Types.html#v:appModelFingerprint).
|
||||
|
||||
### VS Code
|
||||
|
||||
If you use Visual Studio Code, you can also use this [very nice
|
||||
extension](https://marketplace.visualstudio.com/items?itemName=ndmitchell.haskell-ghcid).
|
||||
|
||||
Once installed, pressing `Ctrl-Shift-P` will allow you to invoke the
|
||||
`Start Ghcid` command. You can also run `ghcid` on the command line directly.
|
||||
|
||||
With this you will be running your application in interpreted mode (`ghcid`
|
||||
under the hood uses `ghci`), allowing you to make changes and test them almost
|
||||
immediately.
|
||||
|
||||
Note: when a file is saved, a new instance of the application will be in a new
|
||||
window. The previous window needs to be closed manually.
|
||||
|
||||
## Notes for Intel Mac users
|
||||
|
||||
If you have a discrete GPU, and you'd rather have your application use the
|
||||
@ -257,7 +268,7 @@ Reference: http://supermegaultragroovy.com/2016/12/10/auto-graphics-switching
|
||||
### ghcid
|
||||
|
||||
The sample project includes custom .ghci and .ghcid files. The most important
|
||||
change in .ghci is for Mac users, since macOS does not allow graphics setup to
|
||||
change in .ghci is for Mac users since macOS does not allow graphics setup to
|
||||
happen outside the main thread (by default `ghci` spawns a thread for user
|
||||
code). If you create your custom GHCi config and run into issues, check if you
|
||||
are providing the necessary flags.
|
||||
|
@ -175,6 +175,7 @@ library
|
||||
, 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
|
||||
@ -220,6 +221,7 @@ executable books
|
||||
, 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
|
||||
@ -262,6 +264,7 @@ executable dev-test-app
|
||||
, 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
|
||||
@ -303,6 +306,7 @@ executable generative
|
||||
, 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
|
||||
@ -347,6 +351,7 @@ executable opengl
|
||||
, 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
|
||||
@ -393,6 +398,7 @@ executable ticker
|
||||
, 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
|
||||
@ -438,6 +444,7 @@ executable todo
|
||||
, 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
|
||||
@ -488,6 +495,7 @@ executable tutorial
|
||||
, 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
|
||||
@ -581,6 +589,7 @@ test-suite monomer-test
|
||||
, 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
|
||||
|
@ -35,6 +35,7 @@ dependencies:
|
||||
- data-default >= 0.5 && < 0.8
|
||||
- exceptions >= 0.10 && < 0.11
|
||||
- extra >= 1.6 && < 1.9
|
||||
- foreign-store >= 0.2 && < 1.0
|
||||
- formatting >= 6.0 && < 8.0
|
||||
- http-client >= 0.6 && < 0.9
|
||||
- JuicyPixels >= 3.2.9 && < 3.5
|
||||
|
@ -16,7 +16,6 @@ module Monomer.Core.Lens where
|
||||
|
||||
import Control.Lens.TH (abbreviatedFields, makeLensesWith, makePrisms)
|
||||
|
||||
import Monomer.Common.Lens
|
||||
import Monomer.Core.StyleTypes
|
||||
import Monomer.Core.ThemeTypes
|
||||
import Monomer.Core.WidgetTypes
|
||||
|
@ -311,6 +311,8 @@ data WidgetEnv s e = WidgetEnv {
|
||||
_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.
|
||||
|
@ -15,10 +15,12 @@ module Monomer.Helper where
|
||||
|
||||
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 :: [a] -> Maybe a
|
||||
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 <&> (== "<interactive>")
|
||||
|
@ -9,6 +9,7 @@ Portability : non-portable
|
||||
Core glue for running an application.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
|
||||
@ -22,25 +23,27 @@ module Monomer.Main.Core (
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan)
|
||||
import Control.Exception
|
||||
import Control.Lens ((&), (^.), (.=), (.~), use)
|
||||
import Control.Lens ((&), (^.), (.=), (.~), _2, use)
|
||||
import Control.Monad (unless, void, when)
|
||||
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.Text as T
|
||||
import qualified SDL
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Text as T
|
||||
import qualified Foreign.Store as FS
|
||||
import qualified SDL
|
||||
|
||||
import Monomer.Core
|
||||
import Monomer.Core.Combinators
|
||||
@ -51,7 +54,7 @@ import Monomer.Main.Types
|
||||
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 +63,7 @@ import qualified Monomer.Lens as L
|
||||
Type of response an App event handler can return, with __s__ being the model and
|
||||
__e__ the user's event type.
|
||||
-}
|
||||
type AppEventResponse s e = EventResponse s e s ()
|
||||
type AppEventResponse s e = EventResponse s e s e
|
||||
|
||||
-- | Type of an App event handler.
|
||||
type AppEventHandler s e
|
||||
@ -73,7 +76,9 @@ type AppEventHandler s e
|
||||
-- | 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,12 +92,32 @@ data MainLoopArgs sp e ep = MainLoopArgs {
|
||||
_mlWidgetShared :: MVar (Map Text WidgetShared)
|
||||
}
|
||||
|
||||
-- | State information for the rendering thread.
|
||||
data RenderState s e = RenderState {
|
||||
_rstDpr :: Double,
|
||||
_rstWidgetEnv :: WidgetEnv s e,
|
||||
_rstRootNode :: WidgetNode s e
|
||||
}
|
||||
|
||||
{-|
|
||||
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 +130,45 @@ startApp
|
||||
=> 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 +186,16 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
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 +206,10 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
_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 +220,13 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
_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 +238,10 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
|
||||
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,7 +258,10 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
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
|
||||
@ -221,13 +270,14 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
-}
|
||||
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 +287,7 @@ runAppLoop window glCtx channel widgetRoot config = do
|
||||
_mlFrameAccumTs = 0,
|
||||
_mlFrameCount = 0,
|
||||
_mlExitEvents = exitEvents,
|
||||
_mlWidgetRoot = newRoot,
|
||||
_mlWidgetRoot = newAppRoot,
|
||||
_mlWidgetShared = widgetSharedMVar
|
||||
}
|
||||
|
||||
@ -249,7 +299,7 @@ mainLoop
|
||||
:: (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 +351,7 @@ mainLoop window fontManager config loopArgs = do
|
||||
let wenv = WidgetEnv {
|
||||
_weOs = _mlOS,
|
||||
_weDpr = dpr,
|
||||
_weIsGhci = _mlIsGhci,
|
||||
_weAppStartTs = _mlAppStartTs,
|
||||
_weFontManager = fontManager,
|
||||
_weFindBranchByPath = findChildBranchByPath wenv _mlWidgetRoot,
|
||||
@ -379,6 +430,7 @@ mainLoop window fontManager config loopArgs = do
|
||||
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 +439,10 @@ mainLoop window fontManager config loopArgs = do
|
||||
_mlWidgetRoot = newRoot
|
||||
}
|
||||
|
||||
when _mlIsGhci $ do
|
||||
ctx <- get
|
||||
liftIO $ updateReloadData ctx newRoot
|
||||
|
||||
liftIO $ threadDelay nextFrameDelay
|
||||
|
||||
shouldQuit <- use L.exitApplication
|
||||
@ -595,3 +651,66 @@ getElapsedTimestampSince :: MonadIO m => Millisecond -> m Millisecond
|
||||
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
|
||||
|
@ -57,7 +57,7 @@ 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 +156,7 @@ initSDLWindow config = do
|
||||
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
|
||||
|
@ -35,7 +35,6 @@ 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 +152,7 @@ data MainWindowState
|
||||
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 +207,13 @@ data AppConfig e = AppConfig {
|
||||
-- | 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 +235,11 @@ instance Default (AppConfig e) where
|
||||
_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 +261,39 @@ instance Semigroup (AppConfig e) where
|
||||
_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 +318,7 @@ This flag is no longer necessary for those cases, since the library will:
|
||||
-}
|
||||
{-# 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 +328,7 @@ Max number of FPS the application will run on. It does not necessarily mean
|
||||
rendering will happen every frame, but events and schedules will be checked at
|
||||
this rate and may cause it.
|
||||
-}
|
||||
appMaxFps :: Int -> AppConfig e
|
||||
appMaxFps :: Int -> AppConfig s e
|
||||
appMaxFps fps = def {
|
||||
_apcMaxFps = Just fps
|
||||
}
|
||||
@ -334,7 +338,7 @@ Scale factor to apply to the viewport. This factor only affects the content, not
|
||||
the size of the window. It is applied in addition to the detected display scale
|
||||
factor, and can be useful if the detected value is not the desired.
|
||||
-}
|
||||
appScaleFactor :: Double -> AppConfig e
|
||||
appScaleFactor :: Double -> AppConfig s e
|
||||
appScaleFactor factor = def {
|
||||
_apcScaleFactor = Just factor
|
||||
}
|
||||
@ -377,22 +381,22 @@ Considering the above, when SDL_GetDisplayDPI fails, the library assumes that a
|
||||
screen width larger than 1920 belongs to an HiDPI display and uses a scale
|
||||
factor of 2. This factor is used to scale the window size and the content.
|
||||
-}
|
||||
appDisableAutoScale :: Bool -> AppConfig e
|
||||
appDisableAutoScale :: 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 +405,49 @@ The [file-embed](https://hackage.haskell.org/package/file-embed-0.0.15.0/docs/Da
|
||||
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 +456,7 @@ appContextButton btn = def {
|
||||
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 +465,7 @@ appInvertWheelX invert = def {
|
||||
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 +475,10 @@ Whether compositing should be disabled. Linux only, ignored in other platforms.
|
||||
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 +488,56 @@ Whether the screensaver should be disabled. Defaults to False.
|
||||
|
||||
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 <https://hackage.haskell.org/package/recover-rtti
|
||||
recover-rtti>'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
|
||||
}
|
||||
|
@ -245,6 +245,7 @@ data CompositeCfg s e sp ep = CompositeCfg {
|
||||
_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 +256,10 @@ data CompositeCfg s e sp ep = CompositeCfg {
|
||||
|
||||
instance Default (CompositeCfg s e sp ep) where
|
||||
def = CompositeCfg {
|
||||
_cmcMergeModel = Nothing,
|
||||
_cmcMergeRequired = Nothing,
|
||||
_cmcMergeReqs = [],
|
||||
_cmcMergeModel = Nothing,
|
||||
_cmcModelFingerprintFn = Nothing,
|
||||
_cmcOnInitReq = [],
|
||||
_cmcOnDisposeReq = [],
|
||||
_cmcOnResize = [],
|
||||
@ -268,9 +270,10 @@ instance Default (CompositeCfg s e sp ep) where
|
||||
|
||||
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,
|
||||
@ -342,6 +345,16 @@ compositeMergeReqs fn = def {
|
||||
_cmcMergeReqs = [fn]
|
||||
}
|
||||
|
||||
{-|
|
||||
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.
|
||||
|
||||
@ -361,7 +374,7 @@ Allows updating the composite model with information from the parent model.
|
||||
Useful when the composite needs a more complex model than what the user is
|
||||
binding.
|
||||
|
||||
For example, a database record may be binded as the model from the parent, but
|
||||
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 +393,7 @@ data Composite s e sp ep = Composite {
|
||||
_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 +403,11 @@ data Composite s e sp ep = Composite {
|
||||
}
|
||||
|
||||
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 +498,7 @@ compositeD_ wType wData uiBuilder evtHandler configs = newNode where
|
||||
_cmpMergeRequired = mergeReq,
|
||||
_cmpMergeReqs = _cmcMergeReqs config,
|
||||
_cmpMergeModel = _cmcMergeModel config,
|
||||
_cmpModelFingerprintFn = _cmcModelFingerprintFn config,
|
||||
_cmpOnInitReq = _cmcOnInitReq config,
|
||||
_cmpOnDisposeReq = _cmcOnDisposeReq config,
|
||||
_cmpOnResize = _cmcOnResize config,
|
||||
@ -490,7 +506,7 @@ compositeD_ wType wData uiBuilder evtHandler configs = newNode where
|
||||
_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 +558,8 @@ compositeInit comp state wenv widgetComp = newResult where
|
||||
|
||||
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 +585,19 @@ compositeMerge comp state wenv newComp oldComp = newResult where
|
||||
widgetId = oldComp ^. L.info . L.widgetId
|
||||
oldState = widgetGetState (oldComp ^. L.widget) wenv oldComp
|
||||
validState = fromMaybe state (useState oldState)
|
||||
CompositeState oldModel oldRoot oldWidgetKeys = validState
|
||||
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 +612,11 @@ compositeMerge comp state wenv newComp oldComp = newResult where
|
||||
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 +624,7 @@ compositeMerge comp state wenv newComp oldComp = newResult where
|
||||
| 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 +644,10 @@ compositeMerge comp state wenv newComp oldComp = newResult where
|
||||
| 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 +1099,7 @@ convertWidgetEnv :: WidgetEnv sp ep -> WidgetKeyMap s e -> s -> WidgetEnv s e
|
||||
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 +1146,10 @@ lookupNode widgetKeys desc key = case M.lookup key widgetKeys of
|
||||
|
||||
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 = "<ignored>"
|
||||
where
|
||||
fingerprintFn = _cmpModelFingerprintFn comp
|
||||
|
@ -652,8 +652,9 @@ mergeWrapper container wenv newNode oldNode = newResult where
|
||||
|
||||
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
|
||||
|
@ -323,7 +323,7 @@ boxFilterEvent handler = def {
|
||||
|
||||
newtype BoxState s = BoxState {
|
||||
_bxsModel :: Maybe s
|
||||
}
|
||||
} deriving (Show)
|
||||
|
||||
-- | Creates a box widget with a single node as child.
|
||||
box
|
||||
@ -357,7 +357,7 @@ makeBox config state = widget where
|
||||
containerIgnoreEmptyArea = ignoreEmptyArea && emptyHandlersCount == 0,
|
||||
containerGetCurrentStyle = getCurrentStyle,
|
||||
containerInit = init,
|
||||
containerMergeChildrenReq = mergeRequired,
|
||||
containerMergeChildrenReq = mergeChildrenReq,
|
||||
containerMerge = merge,
|
||||
containerFilterEvent = filterEvent,
|
||||
containerHandleEvent = handleEvent,
|
||||
@ -373,10 +373,12 @@ makeBox config state = widget where
|
||||
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
|
||||
|
@ -152,7 +152,10 @@ instance Default KeyStroke where
|
||||
|
||||
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
|
||||
|
@ -315,8 +315,9 @@ makeSelectList widgetData items makeRow config state = widget where
|
||||
|
||||
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
|
||||
|
@ -88,7 +88,7 @@ themeClearBg_ clear = def {
|
||||
data ThemeSwitchState = ThemeSwitchState {
|
||||
_tssPrevTheme :: Maybe Theme,
|
||||
_tssChanged :: Bool
|
||||
}
|
||||
} deriving (Show)
|
||||
|
||||
-- | Switches to a new theme starting from its child node.
|
||||
themeSwitch
|
||||
|
@ -499,7 +499,7 @@ handleFocusRequest wenv oldNode evt mResult = newResult where
|
||||
|
||||
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
|
||||
|
||||
|
@ -34,7 +34,8 @@ module Monomer.Widgets.Util.Widget (
|
||||
nodeMatches,
|
||||
handleWidgetIdChange,
|
||||
delayedMessage,
|
||||
delayedMessage_
|
||||
delayedMessage_,
|
||||
isWidgetReload
|
||||
) where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
@ -213,3 +214,6 @@ delayedMessage_
|
||||
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
|
||||
|
@ -177,6 +177,7 @@ mockWenv :: s -> WidgetEnv s e
|
||||
mockWenv model = WidgetEnv {
|
||||
_weOs = "Mac OS X",
|
||||
_weDpr = 2,
|
||||
_weIsGhci = False,
|
||||
_weAppStartTs = 0,
|
||||
_weFontManager = mockFontManager,
|
||||
_weFindBranchByPath = const Seq.empty,
|
||||
|
Loading…
Reference in New Issue
Block a user