diff --git a/app/Main.hs b/app/Main.hs index a8eb2727..91f8a0b5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -32,6 +32,10 @@ main = do let config = [ --windowSize (1280, 960), --windowSize (320, 240), + --mainWindowState MainWindowFullScreen, + --mainWindowState MainWindowMaximized, + --mainWindowState $ MainWindowNormal (640, 480), + mainWindowTitle "This is my title", useHdpi True, appTheme theme, appInitEvent InitApp, @@ -75,9 +79,9 @@ handleAppEvent model evt = case evt of RunShortTask -> [Task $ do putStrLn "Running!" return $ Just (PrintMessage "Done!")] - ChangeTitle title -> [Request (UpdateWindow (WindowTitle title))] + ChangeTitle title -> [Request (UpdateWindow (WindowSetTitle title))] ExitApp -> [Request ExitApplication] - FullWindow -> [Request (UpdateWindow WindowFullScreen)] + FullWindow -> [Request (UpdateWindow WindowSetFullScreen)] MaxWindow -> [Request (UpdateWindow WindowMaximize)] MinWindow -> [Request (UpdateWindow WindowMinimize), Event RestoreWindowSchedule] RestoreWindowSchedule -> [Task $ do diff --git a/src/Monomer/Core/Combinators.hs b/src/Monomer/Core/Combinators.hs index 42a12918..0e4df779 100644 --- a/src/Monomer/Core/Combinators.hs +++ b/src/Monomer/Core/Combinators.hs @@ -10,10 +10,6 @@ import Monomer.Core.StyleTypes import Monomer.Core.WidgetTypes import Monomer.Graphics.Types --- Config -class WindowSize t s | t -> s where - windowSize :: s -> t - -- Input class ValidInput t s | t -> s where validInput :: ALens' s Bool -> t diff --git a/src/Monomer/Core/WidgetTypes.hs b/src/Monomer/Core/WidgetTypes.hs index 1b00f773..d0c876c6 100644 --- a/src/Monomer/Core/WidgetTypes.hs +++ b/src/Monomer/Core/WidgetTypes.hs @@ -30,8 +30,8 @@ data TextOverflow deriving (Eq, Show) data WindowRequest - = WindowTitle Text - | WindowFullScreen + = WindowSetTitle Text + | WindowSetFullScreen | WindowMaximize | WindowMinimize | WindowRestore diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs index 647523a2..e42427d8 100644 --- a/src/Monomer/Main/Core.hs +++ b/src/Monomer/Main/Core.hs @@ -70,17 +70,15 @@ simpleApp_ -> [AppConfig e] -> IO () simpleApp_ model eventHandler uiBuilder configs = do - window <- initSDLWindow config + (window, dpr) <- initSDLWindow config winSize <- getDrawableSize window - let dpr = _sW winSize / fromIntegral winW let monomerContext = initMonomerContext () window winSize useHdpi dpr runStateT (runApp window theme fonts appWidget) monomerContext detroySDLWindow window where config = mconcat configs - (winW, winH) = fromMaybe defaultWindowSize (_apcWindowSize config) useHdpi = fromMaybe defaultUseHdpi (_apcHdpi config) fonts = _apcFonts config theme = fromMaybe def (_apcTheme config) diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs index 1eb6844b..a59a40fe 100644 --- a/src/Monomer/Main/Handlers.hs +++ b/src/Monomer/Main/Handlers.hs @@ -242,8 +242,8 @@ handleUpdateWindow handleUpdateWindow windowRequest previousStep = do window <- use L.window case windowRequest of - WindowTitle title -> SDL.windowTitle window $= title - WindowFullScreen -> SDL.setWindowMode window SDL.FullscreenDesktop + WindowSetTitle title -> SDL.windowTitle window $= title + WindowSetFullScreen -> SDL.setWindowMode window SDL.FullscreenDesktop WindowMaximize -> SDL.setWindowMode window SDL.Maximized WindowMinimize -> SDL.setWindowMode window SDL.Minimized WindowRestore -> SDL.setWindowMode window SDL.Windowed diff --git a/src/Monomer/Main/Platform.hs b/src/Monomer/Main/Platform.hs index 2b0abe7a..861ac3c0 100644 --- a/src/Monomer/Main/Platform.hs +++ b/src/Monomer/Main/Platform.hs @@ -1,4 +1,5 @@ module Monomer.Main.Platform where +{- HLint Ignore: Use forM_ -} import Control.Monad.State import Data.Maybe @@ -29,7 +30,7 @@ defaultWindowSize = (640, 480) defaultUseHdpi :: Bool defaultUseHdpi = True -initSDLWindow :: AppConfig e -> IO SDL.Window +initSDLWindow :: AppConfig e -> IO (SDL.Window, Double) initSDLWindow config = do SDL.initialize [SDL.InitVideo] SDL.HintRenderScaleQuality $= SDL.ScaleLinear @@ -38,17 +39,6 @@ initSDLWindow config = do when (renderQuality /= SDL.ScaleLinear) $ putStrLn "Warning: Linear texture filtering not enabled!" - let customOpenGL = SDL.OpenGLConfig { - SDL.glColorPrecision = SDL.V4 8 8 8 0, - SDL.glDepthPrecision = 24, - SDL.glStencilPrecision = 8, - SDL.glProfile = SDL.Core SDL.Debug 3 2, - SDL.glMultisampleSamples = 1 - } - - let (winW, winH) = fromMaybe defaultWindowSize (_apcWindowSize config) - let windowHiDPI = fromMaybe defaultUseHdpi (_apcHdpi config) - window <- SDL.createWindow "SDL / OpenGL Example" @@ -59,6 +49,19 @@ initSDLWindow config = do SDL.windowGraphicsContext = SDL.OpenGLContext customOpenGL } + -- Get device pixel rate + SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window + let dpr = fromIntegral fbWidth / fromIntegral winW + + when (isJust (_apcWindowTitle config)) $ + SDL.windowTitle window $= fromJust (_apcWindowTitle config) + + when windowFullscreen $ + SDL.setWindowMode window SDL.FullscreenDesktop + + when windowMaximized $ + SDL.setWindowMode window SDL.Maximized + err <- SRE.getError err <- STR.peekCString err putStrLn err @@ -67,12 +70,32 @@ initSDLWindow config = do _ <- glewInit - return window + return (window, dpr) + where + customOpenGL = SDL.OpenGLConfig { + SDL.glColorPrecision = SDL.V4 8 8 8 0, + SDL.glDepthPrecision = 24, + SDL.glStencilPrecision = 8, + SDL.glProfile = SDL.Core SDL.Debug 3 2, + SDL.glMultisampleSamples = 1 + } + (winW, winH) = case _apcWindowState config of + Just (MainWindowNormal size) -> size + _ -> defaultWindowSize + windowHiDPI = fromMaybe defaultUseHdpi (_apcHdpi config) + windowFullscreen = case _apcWindowState config of + Just MainWindowFullScreen -> True + _ -> False + windowMaximized = case _apcWindowState config of + Just MainWindowMaximized -> True + _ -> False + detroySDLWindow :: SDL.Window -> IO () detroySDLWindow window = do putStrLn "About to destroyWindow" SDL.destroyWindow window + Raw.quitSubSystem Raw.SDL_INIT_VIDEO SDL.quit getCurrentMousePos :: (MonadIO m) => m Point diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs index 6719082d..a11bf534 100644 --- a/src/Monomer/Main/Types.hs +++ b/src/Monomer/Main/Types.hs @@ -48,8 +48,15 @@ data MonomerContext s = MonomerContext { _mcCursorIcons :: Map CursorIcon SDLR.Cursor } +data MainWindowState + = MainWindowNormal (Int, Int) + | MainWindowMaximized + | MainWindowFullScreen + deriving (Eq, Show) + data AppConfig e = AppConfig { - _apcWindowSize :: Maybe (Int, Int), + _apcWindowState :: Maybe MainWindowState, + _apcWindowTitle :: Maybe Text, _apcHdpi :: Maybe Bool, _apcFonts :: [FontDef], _apcTheme :: Maybe Theme, @@ -58,7 +65,8 @@ data AppConfig e = AppConfig { instance Default (AppConfig e) where def = AppConfig { - _apcWindowSize = Nothing, + _apcWindowState = Nothing, + _apcWindowTitle = Nothing, _apcHdpi = Nothing, _apcFonts = [], _apcTheme = Nothing, @@ -67,7 +75,8 @@ instance Default (AppConfig e) where instance Semigroup (AppConfig e) where (<>) a1 a2 = AppConfig { - _apcWindowSize = _apcWindowSize a2 <|> _apcWindowSize a1, + _apcWindowState = _apcWindowState a2 <|> _apcWindowState a1, + _apcWindowTitle = _apcWindowTitle a2 <|> _apcWindowTitle a1, _apcHdpi = _apcHdpi a2 <|> _apcHdpi a1, _apcFonts = _apcFonts a1 ++ _apcFonts a2, _apcTheme = _apcTheme a2 <|> _apcTheme a1, @@ -77,10 +86,15 @@ instance Semigroup (AppConfig e) where instance Monoid (AppConfig e) where mempty = def -instance WindowSize (AppConfig e) (Int, Int) where - windowSize size = def { - _apcWindowSize = Just size - } +mainWindowState :: MainWindowState -> AppConfig e +mainWindowState title = def { + _apcWindowState = Just title +} + +mainWindowTitle :: Text -> AppConfig e +mainWindowTitle title = def { + _apcWindowTitle = Just title +} useHdpi :: Bool -> AppConfig e useHdpi use = def {