brillo 2.0.0 → 3.0.0

raw patch · 15 files changed

+545/−151 lines, 15 filesdep ~brillo-renderingPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: brillo-rendering

API changes (from Hackage documentation)

Files

• Brillo/Data/Bitmap.hs +22/−0
• Brillo/Data/Picture.hs +6/−0
• Brillo/Data/ViewState.hs +186/−93
• Brillo/Interface/Environment.hs +15/−0
• Brillo/Interface/IO/MessageBox.hs +29/−0
• Brillo/Internals/Interface/Animate.hs +4/−1
• Brillo/Internals/Interface/Backend/GLFW.hs +146/−50
• Brillo/Internals/Interface/Backend/Types.hs +26/−2
• Brillo/Internals/Interface/Display.hs +1/−0
• Brillo/Internals/Interface/Event.hs +30/−2
• Brillo/Internals/Interface/Game.hs +24/−0
• Brillo/Internals/Interface/Interact.hs +25/−0
• Brillo/Internals/Interface/Simulate.hs +1/−0
• Brillo/Internals/Interface/ViewState/KeyMouse.hs +27/−1
• brillo.cabal +3/−2

@@ -5,12 +5,34 @@   BitmapFormat (..),   RowOrder (..),   PixelFormat (..),+  CompressedFormat (..),   bitmapOfForeignPtr,   bitmapDataOfForeignPtr,   bitmapOfByteString,   bitmapDataOfByteString,   bitmapOfBMP,   bitmapDataOfBMP,+  compressedBitmapOfForeignPtr,+  compressedBitmapDataOfForeignPtr,+  compressedBitmapOfByteString,+  compressedBitmapDataOfByteString,+  -- Common compressed texture format constants+  compressedRGB_S3TC_DXT1,+  compressedRGBA_S3TC_DXT1,+  compressedRGBA_S3TC_DXT3,+  compressedRGBA_S3TC_DXT5,+  compressedSRGB_S3TC_DXT1,+  compressedSRGB_ALPHA_S3TC_DXT1,+  compressedSRGB_ALPHA_S3TC_DXT3,+  compressedSRGB_ALPHA_S3TC_DXT5,+  compressedRED_RGTC1,+  compressedSIGNED_RED_RGTC1,+  compressedRG_RGTC2,+  compressedSIGNED_RG_RGTC2,+  compressedRGBA_BPTC_UNORM,+  compressedSRGB_ALPHA_BPTC_UNORM,+  compressedRGB_BPTC_SIGNED_FLOAT,+  compressedRGB_BPTC_UNSIGNED_FLOAT,   loadBMP, ) where

@@ -4,6 +4,12 @@   Vector,   Path, +  -- * Shaders+  UniformValue (..),+  ShaderData (..),+  defaultShaderVertex,+  shader,+   -- * Compound shapes   lineLoop,   lineLoopAliased,

@@ -2,6 +2,8 @@  module Brillo.Data.ViewState (   Command (..),+  CommandKey (..),+  WheelDirection (..),   CommandConfig,   defaultCommandConfig,   ViewState (..),@@ -44,9 +46,39 @@   deriving (Show, Eq, Ord)  -type CommandConfig = [(Command, [(Key, Maybe Modifiers)])]+-- | An input that can trigger a viewport command.+data CommandKey+  = -- | A key or mouse button press.+    CKey Key+  | {-| Scrolling with a mouse wheel or a trackpad.+    Only instant commands (i.e. not 'CTranslate', 'CRotate', and 'CScale')+    can be triggered by scrolling.+    They are applied proportionally to the scroll offset,+    and zooming keeps the point under the cursor fixed.+    -}+    CMouseWheel WheelDirection+  deriving (Show, Eq, Ord)  +{-| Direction of a scroll.+  The direction is the one reported by the operating system,+  so it is reversed if \"natural scrolling\" is enabled.+-}+data WheelDirection+  = -- | Scrolling up.+    WheelUp+  | -- | Scrolling down.+    WheelDown+  | -- | Scrolling left.+    WheelLeft+  | -- | Scrolling right.+    WheelRight+  deriving (Show, Eq, Ord)+++type CommandConfig = [(Command, [(CommandKey, Maybe Modifiers)])]++ {-| The default commands.  Left click pans, wheel zooms, right click   rotates, "r" key resets. -}@@ -54,13 +86,13 @@ defaultCommandConfig =   [     ( CRestore-    , [(Char 'r', Nothing)]+    , [(CKey $ Char 'r', Nothing)]     )   ,     ( CTranslate     ,       [-        ( MouseButton LeftButton+        ( CKey $ MouseButton LeftButton         , Just (Modifiers{shift = Up, ctrl = Up, alt = Up})         )       ]@@ -69,11 +101,11 @@     ( CScale     ,       [-        ( MouseButton LeftButton+        ( CKey $ MouseButton LeftButton         , Just (Modifiers{shift = Up, ctrl = Down, alt = Up})         )       ,-        ( MouseButton RightButton+        ( CKey $ MouseButton RightButton         , Just (Modifiers{shift = Up, ctrl = Up, alt = Up})         )       ]@@ -82,11 +114,11 @@     ( CRotate     ,       [-        ( MouseButton LeftButton+        ( CKey $ MouseButton LeftButton         , Just (Modifiers{shift = Up, ctrl = Up, alt = Down})         )       ,-        ( MouseButton RightButton+        ( CKey $ MouseButton RightButton         , Just (Modifiers{shift = Up, ctrl = Down, alt = Up})         )       ]@@ -95,51 +127,51 @@      ( CBumpZoomOut     ,-      [ (MouseButton WheelDown, Nothing)-      , (SpecialKey KeyPageDown, Nothing)+      [ (CMouseWheel WheelDown, Nothing)+      , (CKey $ SpecialKey KeyPageDown, Nothing)       ]     )   ,     ( CBumpZoomIn     ,-      [ (MouseButton WheelUp, Nothing)-      , (SpecialKey KeyPageUp, Nothing)+      [ (CMouseWheel WheelUp, Nothing)+      , (CKey $ SpecialKey KeyPageUp, Nothing)       ]     )   , -- bump translate      ( CBumpLeft-    , [(SpecialKey KeyLeft, Nothing)]+    , [(CKey $ SpecialKey KeyLeft, Nothing)]     )   ,     ( CBumpRight-    , [(SpecialKey KeyRight, Nothing)]+    , [(CKey $ SpecialKey KeyRight, Nothing)]     )   ,     ( CBumpUp-    , [(SpecialKey KeyUp, Nothing)]+    , [(CKey $ SpecialKey KeyUp, Nothing)]     )   ,     ( CBumpDown-    , [(SpecialKey KeyDown, Nothing)]+    , [(CKey $ SpecialKey KeyDown, Nothing)]     )   , -- bump rotate      ( CBumpClockwise-    , [(SpecialKey KeyHome, Nothing)]+    , [(CKey $ SpecialKey KeyHome, Nothing)]     )   ,     ( CBumpCClockwise-    , [(SpecialKey KeyEnd, Nothing)]+    , [(CKey $ SpecialKey KeyEnd, Nothing)]     )   ]   -- | Check if the provided key combination is some brillo viewport command. isCommand ::-  Map Command [(Key, Maybe Modifiers)] ->+  Map Command [(CommandKey, Maybe Modifiers)] ->   Command ->-  Key ->+  CommandKey ->   Modifiers ->   Bool isCommand commands c key keyMods@@ -150,7 +182,8 @@   -- | Check if the provided key combination is some brillo viewport command.-isCommand2 :: Command -> Key -> Modifiers -> (Key, Maybe Modifiers) -> Bool+isCommand2 ::+  Command -> CommandKey -> Modifiers -> (CommandKey, Maybe Modifiers) -> Bool isCommand2 _ key keyMods cMatch   | (keyC, mModsC) <- cMatch   , keyC == key@@ -169,14 +202,17 @@ -} data ViewState   = ViewState-  { viewStateCommands :: !(Map Command [(Key, Maybe Modifiers)])+  { viewStateCommands :: !(Map Command [(CommandKey, Maybe Modifiers)])   {- ^ The command list for the viewport controller.      These can be safely overwridden at any time by deleting      or adding entries to the list.      Entries at the front of the list take precedence.   -}   , viewStateScaleStep :: !Float-  -- ^ How much to scale the world by for each step of the mouse wheel.+  {- ^ How much to scale the world by for each step of the mouse wheel.+     Fractional scroll offsets (e.g. from trackpads) scale the world+     by the corresponding power of this value.+  -}   , viewStateRotateFactor :: !Float   -- ^ How many degrees to rotate the world by for each pixel of x motion.   , viewStateScaleFactor :: !Float@@ -229,54 +265,42 @@   was needed. -} updateViewStateWithEventMaybe :: Event -> ViewState -> Maybe ViewState-updateViewStateWithEventMaybe (EventKey key keyState keyMods pos) viewState-  | isCommand commands CRestore key keyMods-  , keyState == Down =-      Just $ viewState{viewStateViewPort = viewPortInit}-  | isCommand commands CBumpZoomOut key keyMods-  , keyState == Down =-      Just $ controlZoomIn viewState-  | isCommand commands CBumpZoomIn key keyMods-  , keyState == Down =-      Just $ controlZoomOut viewState-  | isCommand commands CBumpLeft key keyMods-  , keyState == Down =-      Just $ viewState{viewStateViewPort = motionBump port (20, 0)}-  | isCommand commands CBumpRight key keyMods-  , keyState == Down =-      Just $ viewState{viewStateViewPort = motionBump port (-20, 0)}-  | isCommand commands CBumpUp key keyMods-  , keyState == Down =-      Just $ viewState{viewStateViewPort = motionBump port (0, -20)}-  | isCommand commands CBumpDown key keyMods-  , keyState == Down =-      Just $ viewState{viewStateViewPort = motionBump port (0, 20)}-  | isCommand commands CBumpClockwise key keyMods-  , keyState == Down =-      Just $-        viewState-          { viewStateViewPort =-              port{viewPortRotate = viewPortRotate port + 5}-          }-  | isCommand commands CBumpCClockwise key keyMods-  , keyState == Down =-      Just $-        viewState-          { viewStateViewPort =-              port{viewPortRotate = viewPortRotate port - 5}-          }+updateViewStateWithEventMaybe ev viewState =+  case ev of+    EventKey key keyState keyMods pos ->+      updateViewStateWithKeyMaybe key keyState keyMods pos viewState+    EventScroll offset keyMods pos ->+      updateViewStateWithScrollMaybe offset keyMods pos viewState+    -- Note that only a translation or rotation applies,+    -- not both at the same time.+    EventMotion pos ->+      motionScale (viewStateScaleMark viewState) pos viewState+        `mplus` motionTranslate (viewStateTranslateMark viewState) pos viewState+        `mplus` motionRotate (viewStateRotateMark viewState) pos viewState+    EventResize _ -> Nothing+    EventDrop _ -> Nothing+    EventPick _ -> Nothing+++updateViewStateWithKeyMaybe ::+  Key -> KeyState -> Modifiers -> (Float, Float) -> ViewState -> Maybe ViewState+updateViewStateWithKeyMaybe key keyState keyMods pos viewState+  -- Instant commands, zooming around the center of the window.+  | keyState == Down+  , Just viewState' <- runInstantCommands (CKey key) keyMods 1 Nothing viewState =+      Just viewState'   -- Start Translation.-  | isCommand commands CTranslate key keyMods+  | isCommand' CTranslate   , keyState == Down   , not $ currentlyRotating || currentlyScaling =       Just $ viewState{viewStateTranslateMark = Just pos}   -- Start Rotation.-  | isCommand commands CRotate key keyMods+  | isCommand' CRotate   , keyState == Down   , not $ currentlyTranslating || currentlyScaling =       Just $ viewState{viewStateRotateMark = Just pos}   -- Start Scale.-  | isCommand commands CScale key keyMods+  | isCommand' CScale   , keyState == Down   , not $ currentlyTranslating || currentlyRotating =       Just $ viewState{viewStateScaleMark = Just pos}@@ -294,46 +318,115 @@   | otherwise =       Nothing   where-    commands = viewStateCommands viewState-    port = viewStateViewPort viewState+    isCommand' c = isCommand (viewStateCommands viewState) c (CKey key) keyMods     currentlyTranslating = isJust $ viewStateTranslateMark viewState     currentlyRotating = isJust $ viewStateRotateMark viewState     currentlyScaling = isJust $ viewStateScaleMark viewState --- Note that only a translation or rotation applies, not both at the same time.-updateViewStateWithEventMaybe (EventMotion pos) viewState =-  motionScale (viewStateScaleMark viewState) pos viewState-    `mplus` motionTranslate (viewStateTranslateMark viewState) pos viewState-    `mplus` motionRotate (viewStateRotateMark viewState) pos viewState-updateViewStateWithEventMaybe (EventDrop _) _ = Nothing-updateViewStateWithEventMaybe (EventPick _) _ = Nothing-updateViewStateWithEventMaybe (EventResize _) _ = Nothing +{-| Run the instant commands bound to the scroll directions of the offset.+  Each axis is handled separately and runs its command+  as many times as the absolute offset says,+  so that fractional trackpad offsets result in fractional steps.+  Zooming keeps the point under the cursor fixed.+-}+updateViewStateWithScrollMaybe ::+  (Float, Float) -> Modifiers -> (Float, Float) -> ViewState -> Maybe ViewState+updateViewStateWithScrollMaybe (offsetX, offsetY) keyMods pos viewState =+  case scrollAxis offsetX WheelLeft WheelRight viewState of+    Nothing -> scrollAxis offsetY WheelUp WheelDown viewState+    Just viewState' ->+      Just $ fromMaybe viewState' $ scrollAxis offsetY WheelUp WheelDown viewState'+  where+    scrollAxis offset positiveDir negativeDir vs+      | offset == 0 = Nothing+      | otherwise =+          runInstantCommands+            (CMouseWheel $ if offset > 0 then positiveDir else negativeDir)+            keyMods+            (abs offset)+            (Just pos)+            vs --- | Zoom in a `ViewState` by the scale step.-controlZoomIn :: ViewState -> ViewState-controlZoomIn-  viewState@ViewState-    { viewStateViewPort = port-    , viewStateScaleStep = scaleStep-    } =-    viewState-      { viewStateViewPort =-          port{viewPortScale = viewPortScale port / scaleStep}-      } +{-| Run the first instant (i.e. non-dragging) command+  that is bound to the given key and modifiers.+-}+runInstantCommands ::+  CommandKey ->+  Modifiers ->+  -- | Number of steps to apply the command for.+  Float ->+  -- | Point to zoom around. The center of the window if 'Nothing'.+  Maybe (Float, Float) ->+  ViewState ->+  Maybe ViewState+runInstantCommands key keyMods steps zoomCenter viewState =+  case filter isBound instantCommands of+    [] -> Nothing+    command : _ -> Just $ runInstantCommand command steps zoomCenter viewState+  where+    isBound c = isCommand (viewStateCommands viewState) c key keyMods --- | Zoom out a `ViewState` by the scale step.-controlZoomOut :: ViewState -> ViewState-controlZoomOut-  viewState@ViewState-    { viewStateViewPort = port-    , viewStateScaleStep = scaleStep-    } =-    viewState-      { viewStateViewPort =-          port{viewPortScale = viewPortScale port * scaleStep}-      }++{-| The commands which take effect immediately,+  in contrast to translating, rotating and scaling by dragging the mouse.+  If an input is bound to several of them, the first one wins.+-}+instantCommands :: [Command]+instantCommands =+  [ CRestore+  , CBumpZoomOut+  , CBumpZoomIn+  , CBumpLeft+  , CBumpRight+  , CBumpUp+  , CBumpDown+  , CBumpClockwise+  , CBumpCClockwise+  ]+++-- | Apply an instant command for the given number of steps.+runInstantCommand ::+  Command -> Float -> Maybe (Float, Float) -> ViewState -> ViewState+runInstantCommand command steps zoomCenter viewState =+  case command of+    CRestore -> withPort $ const viewPortInit+    CBumpZoomOut -> withPort $ zoomBy (scaleStep ** steps)+    CBumpZoomIn -> withPort $ zoomBy (1 / scaleStep ** steps)+    CBumpLeft -> withPort $ \port -> motionBump port (20 * steps, 0)+    CBumpRight -> withPort $ \port -> motionBump port (-20 * steps, 0)+    CBumpUp -> withPort $ \port -> motionBump port (0, -20 * steps)+    CBumpDown -> withPort $ \port -> motionBump port (0, 20 * steps)+    CBumpClockwise -> withPort $ rotateBy (5 * steps)+    CBumpCClockwise -> withPort $ rotateBy (-5 * steps)+    CTranslate -> viewState+    CRotate -> viewState+    CScale -> viewState+  where+    scaleStep = viewStateScaleStep viewState+    withPort f = viewState{viewStateViewPort = f (viewStateViewPort viewState)}+    rotateBy degrees port = port{viewPortRotate = viewPortRotate port + degrees}+    zoomBy factor port =+      let port' = port{viewPortScale = viewPortScale port * factor}+      in  case zoomCenter of+            Nothing -> port'+            Just center -> keepPointFixed center port port'+++{-| Adjust the translation of the new viewport+  so that the picture point under the given screen point+  is the same as with the old viewport.+-}+keepPointFixed :: (Float, Float) -> ViewPort -> ViewPort -> ViewPort+keepPointFixed screenPoint oldPort newPort =+  newPort+    { viewPortTranslate =+        viewPortTranslate newPort+          Pt.+ invertViewPort newPort screenPoint+          Pt.- invertViewPort oldPort screenPoint+    }   -- | Offset a viewport.

@@ -21,6 +21,21 @@   Backend.Types.getScreenSize backendStateRef  +{-| Get the scale factor between window coordinates and logical UI units,+  e.g. @1.5@ for a display configured to 150 % scaling.++  Multiply window sizes and drawing coordinates with it+  to keep an interface at a constant physical size across displays.+  It is always 1 on platforms whose window coordinates+  already are logical units (e.g. macOS).+-}+getDpiScale :: IO Float+getDpiScale = do+  backendStateRef <- newIORef defaultBackendState+  Backend.Types.initializeBackend backendStateRef False+  Backend.Types.getDpiScale backendStateRef++ {-| Open a file dialog to select files/directories.    Returns a list of paths, or `Nothing` if the dialog was cancelled.

@@ -0,0 +1,29 @@+-- | Native message boxes, notification popups, and system beeps.+module Brillo.Interface.IO.MessageBox (+  -- * Functions+  messageBox,+  notifyPopup,+  beep,++  -- * Message box options+  IconType (..),+  MessageBox,+  OK (..),+  OKCancel (..),+  YesNo (..),+  YesNoCancel (..),+)+where++import Brillo.Internals.TinyFileDialogs (+  IconType (..),+  MessageBox,+  OK (..),+  OKCancel (..),+  YesNo (..),+  YesNoCancel (..),+  beep,+  messageBox,+  notifyPopup,+ )+

@@ -86,7 +86,10 @@             , callback_viewState_reshape             ]               ++ ( if pannable-                     then [callback_viewState_keyMouse viewSR]+                     then+                       [ callback_viewState_keyMouse viewSR+                       , callback_viewState_scroll viewSR+                       ]                      else []                  ) 

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_HADDOCK hide #-} @@ -16,6 +15,9 @@ import Graphics.Rendering.OpenGL (($=)) import Graphics.Rendering.OpenGL qualified as GL import Graphics.UI.GLFW qualified as GLFW+import System.Exit (ExitCode)+import System.IO (hPutStrLn, stderr)+import System.Info (os)  import Brillo.Data.Cursor (CursorShape (..)) import Brillo.Data.FileDialog (FileDialog (..), SelectionMode (..))@@ -42,8 +44,6 @@   -- ^ Status of Ctrl, Alt or Shift (Up or Down?)   , mousePosition :: (Int, Int)   -- ^ Latest mouse position-  , mouseWheelPos :: Int-  -- ^ Latest mousewheel position   , dirtyScreen :: Bool   -- ^ Does the screen need to be redrawn?   , display :: IO ()@@ -63,7 +63,6 @@   GLFWState     { modifiers = Modifiers Up Up Up     , mousePosition = (0, 0)-    , mouseWheelPos = 0     , dirtyScreen = True     , display = return ()     , idle = return ()@@ -98,6 +97,7 @@   postRedisplay = postRedisplayGLFW   getWindowDimensions ref = windowHandle ref >>= \win -> GLFW.getWindowSize win   getScreenSize = getScreenSizeGLFW+  getDpiScale = getDpiScaleGLFW   openFileDialog = openFileDialogGLFW   elapsedTime _ =     GLFW.getTime >>= \mt -> case mt of@@ -114,7 +114,7 @@ initializeGLFW _ debug =   do     let simpleErrorCallback e s =-          putStrLn $ unwords ["GLFW backend: ", show e, show s]+          hPutStrLn stderr $ unwords ["GLFW backend: ", show e, show s]     GLFW.setErrorCallback (Just simpleErrorCallback)      _ <- GLFW.init@@ -178,6 +178,80 @@  -- Open Window ---------------------------------------------------------------- +{-| Request an OpenGL 2.1 context.++Brillo's anti-aliased shapes are rendered with @#version 120@ GLSL shaders+that rely on compatibility built-ins (e.g. @gl_ModelViewProjectionMatrix@,+@gl_MultiTexCoord0@, @gl_FragColor@) mixed with immediate-mode drawing.+Without a version hint the context is driver-dependent, and some drivers+(notably on Windows) hand out a context that rejects that mixed path with+@GL_INVALID_OPERATION@. Asking for 2.1 yields a context that is required to+be backwards compatible with it, which avoids that.++No @WindowHint'OpenGLProfile@ is set on purpose:+context profiles are only defined for OpenGL 3.2 and above and GLFW aborts+window creation with @GLFW_INVALID_VALUE@ if one is combined with a lower+version, no matter which platform or driver is used.+-}+setWindowHints :: IO ()+setWindowHints = do+  GLFW.windowHint (GLFW.WindowHint'ContextVersionMajor 2)+  GLFW.windowHint (GLFW.WindowHint'ContextVersionMinor 1)+++-- | Describe the last GLFW error, if there was one.+lastGlfwError :: IO String+lastGlfwError = do+  optError <- GLFW.getError+  pure $ case optError of+    Nothing -> ""+    Just (err, msg) -> " (" <> show err <> ": " <> msg <> ")"+++{-| Create a window with Brillo's preferred context hints.++If the driver can't provide such a context, 'GLFW.createWindow' returns+'Nothing' instead of falling back on its own.+Retry with GLFW's default hints in that case,+as a suboptimal context is still better than no window at all.+-}+createWindowWithHints ::+  Int ->+  Int ->+  String ->+  Maybe GLFW.Monitor ->+  IO (Maybe GLFW.Window)+createWindowWithHints sizeX sizeY title monitor = do+  GLFW.defaultWindowHints+  setWindowHints+  winWithHints <- GLFW.createWindow sizeX sizeY title monitor Nothing++  case winWithHints of+    Just _ -> pure winWithHints+    Nothing -> do+      errorMsg <- lastGlfwError+      hPutStrLn stderr $+        "Warning: Could not create an OpenGL 2.1 context"+          <> errorMsg+          <> ". Retrying with the driver's default context …"+      GLFW.defaultWindowHints+      GLFW.createWindow sizeX sizeY title monitor Nothing+++{-| Move the window, keeping its title bar reachable.++The given position is the upper left corner of the content area,+so a window at @(0, 0)@ would have its title bar above the top edge+of the screen and couldn't be moved by the user anymore.+Push the window down by the height of the title bar in that case.+-}+setWindowPosOnScreen :: GLFW.Window -> Int -> Int -> IO ()+setWindowPosOnScreen win posX posY = do+  -- Left, top, right, and bottom edge of the window's frame+  (_, titleBarHeight, _, _) <- GLFW.getWindowFrameSize win+  GLFW.setWindowPos win posX (max titleBarHeight posY)++ -- | Open a new window. openWindowGLFW ::   IORef GLFWState ->@@ -186,25 +260,26 @@ openWindowGLFW ref (InWindow title (sizeX, sizeY) pos) =   do     win <--      GLFW.createWindow+      createWindowWithHints         sizeX         sizeY         (T.unpack title)         Nothing-        Nothing      case win of-      Nothing ->+      Nothing -> do+        errorMsg <- lastGlfwError         error $           "GLFW.createWindow failed to create a "             ++ show sizeX             ++ "x"             ++ show sizeY-            ++ " window."-            ++ " Check that your GPU drivers support OpenGL."+            ++ " window"+            ++ errorMsg+            ++ ". Check that your GPU drivers support OpenGL."       Just w -> do         modifyIORef' ref (\s -> s{optWinHdl = win})-        uncurry (GLFW.setWindowPos w) pos+        uncurry (setWindowPosOnScreen w) pos         GLFW.makeContextCurrent win          -- Try to enable sync-to-vertical-refresh by setting the number@@ -226,16 +301,19 @@             let sizeY = GLFW.videoModeHeight vm              win <--              GLFW.createWindow+              createWindowWithHints                 sizeX                 sizeY                 ""                 mon-                Nothing              case win of-              Nothing ->-                error "GLFW.createWindow failed to create a fullscreen window."+              Nothing -> do+                errorMsg <- lastGlfwError+                error $+                  "GLFW.createWindow failed to create a fullscreen window"+                    ++ errorMsg+                    ++ ". Check that your GPU drivers support OpenGL."               Just w -> do                 modifyIORef' ref (\s -> s{optWinHdl = win})                 GLFW.makeContextCurrent win@@ -270,6 +348,30 @@           pure (sizeX, sizeY)  +{-| The scale factor between window coordinates and logical UI units,+e.g. @1.5@ for a display configured to 150 % scaling.++On macOS window coordinates already are logical points+(only the framebuffer is the high resolution one),+so the factor is always 1 there.+On Windows and X11 window coordinates are physical pixels,+which makes the factor the content scale of the primary monitor.+-}+getDpiScaleGLFW :: IORef GLFWState -> IO Float+getDpiScaleGLFW _state =+  if os == "darwin"+    then pure 1+    else do+      monitorMb <- GLFW.getPrimaryMonitor+      case monitorMb of+        Nothing -> pure 1+        Just monitor -> do+          (scaleX, scaleY) <- GLFW.getMonitorContentScale monitor+          let scale = max scaleX scaleY+          -- Guard against drivers reporting a nonsensical scale+          pure $ if scale > 0 then scale else 1++ -- | Open a file dialog. Return `Nothing` if the user cancels the dialog. openFileDialogGLFW :: IORef GLFWState -> FileDialog -> IO (Maybe [FilePath]) openFileDialogGLFW _state fileDialog = do@@ -473,7 +575,7 @@     GLFW.setKeyCallback win (Just $ callbackKeyboard stateRef callbacks)     GLFW.setCharCallback win (Just $ callbackChar stateRef callbacks)     GLFW.setMouseButtonCallback win (Just $ callbackMouseButton stateRef callbacks)-    GLFW.setScrollCallback win (Just $ callbackMouseWheel stateRef callbacks)+    GLFW.setScrollCallback win (Just $ callbackScroll stateRef callbacks)     GLFW.setDropCallback win (Just $ callbackDrop stateRef callbacks)  @@ -489,7 +591,7 @@ callbackKeyboard stateRef callbacks _win key _scancode keystateglfw _modifiers =   do     let keystate = keystateglfw == GLFW.KeyState'Pressed-    (modsSet, GLFWState mods pos _ _ _ _ _ _) <-+    (modsSet, GLFWState{modifiers = mods, mousePosition = pos}) <-       setModifiers stateRef key keystate     let key' = fromGLFW key     let keystate' = if keystate then Down else Up@@ -602,7 +704,7 @@ callbackChar stateRef callbacks _win char -- keystate   =   do-    (GLFWState mods pos _ _ _ _ _ _) <- readIORef stateRef+    GLFWState{modifiers = mods, mousePosition = pos} <- readIORef stateRef     let key' = charToSpecial char     -- TODO: is this correct? GLFW does not provide the keystate     -- in a character callback, here we asume that its pressed@@ -629,7 +731,7 @@   GLFW.MouseButtonCallback -- = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO () callbackMouseButton stateRef callbacks _win key keystate _modifier =   do-    (GLFWState mods pos _ _ _ _ _ _) <- readIORef stateRef+    GLFWState{modifiers = mods, mousePosition = pos} <- readIORef stateRef     let key' = fromGLFW key     let keystate' = if keystate == GLFW.MouseButtonState'Pressed then Down else Up @@ -639,37 +741,21 @@       ([f stateRef | KeyMouse f <- callbacks])  --- GLFW calls on this when the user moves the mouse wheel.-callbackMouseWheel ::+{-| GLFW calls this when the user scrolls with a mouse wheel or a trackpad.+  The offsets are relative to the last scroll event and are passed on as is.+-}+callbackScroll ::   IORef GLFWState ->   [Callback] ->-  GLFW.ScrollCallback--- -> Int--- -> IO ()--- ScrollCallback = Window -> Double -> Double -> IO ()-callbackMouseWheel stateRef callbacks _win x _y =+  GLFW.ScrollCallback -- = Window -> Double -> Double -> IO ()+callbackScroll stateRef callbacks _win x y =   do-    (key, keystate) <- setMouseWheel stateRef (floor x)-    (GLFWState mods pos _ _ _ _ _ _) <- readIORef stateRef+    GLFWState{modifiers = mods, mousePosition = pos} <- readIORef stateRef -    -- Call all the Brillo KeyMouse actions with the new state.+    -- Call all the Brillo Scroll actions with the new state.     mapM_-      (\f -> f key keystate mods pos)-      ([f stateRef | KeyMouse f <- callbacks])---setMouseWheel ::-  IORef GLFWState ->-  Int ->-  IO (Key, KeyState)-setMouseWheel stateRef w =-  do-    glfwState <- readIORef stateRef-    writeIORef stateRef $ glfwState{mouseWheelPos = w}-    case compare w (mouseWheelPos glfwState) of-      LT -> return (MouseButton WheelDown, Down)-      GT -> return (MouseButton WheelUp, Down)-      EQ -> return (SpecialKey KeyUnknown, Up)+      (\f -> f (x, y) mods pos)+      ([f stateRef | Scroll f <- callbacks])   -- | GLFW calls this when the user drops files/directories onto the window@@ -769,13 +855,23 @@ -- Main Loop ------------------------------------------------------------------  runMainLoopGLFW :: IORef GLFWState -> IO ()-runMainLoopGLFW stateRef = do-  X.catch go handleException-  GLFW.destroyWindow =<< windowHandle stateRef-  GLFW.terminate+runMainLoopGLFW stateRef =+  (go `X.catch` handleException) `X.finally` cleanup   where+    cleanup :: IO ()+    cleanup = do+      GLFW.destroyWindow =<< windowHandle stateRef+      GLFW.terminate++    -- Report unexpected errors to stderr, but re-throw `ExitCode` so that+    -- `exitSuccess` / `exitFailure` from user code reach GHC's top-level+    -- handler and terminate the program with the intended status. Without+    -- this, those exits were silently swallowed, and since GHC 9.10 the+    -- printed `SomeException` also carried a noisy HasCallStack backtrace.     handleException :: X.SomeException -> IO ()-    handleException = print+    handleException exc+      | Just (ec :: ExitCode) <- X.fromException exc = X.throwIO ec+      | otherwise = hPutStrLn stderr (X.displayException exc)      clearDirtyFlag :: IO ()     clearDirtyFlag =

@@ -97,6 +97,12 @@   getScreenSize :: IORef a -> IO (Int, Int)  +  {-| Function that returns the scale factor+  between window coordinates and logical UI units.+  -}+  getDpiScale :: IORef a -> IO Float++   -- | Open a file dialog to pick files/directories.   openFileDialog :: IORef a -> FileDialog -> IO (Maybe [FilePath]) @@ -136,6 +142,25 @@   IO ()  +{-| Arguments: Scroll offset (x, y), Ctrl \/ Alt \/ Shift pressed,+  latest mouse location.+  A positive y offset means scrolling up,+  a positive x offset means scrolling left.+  The directions are the ones reported by the operating system,+  so they are reversed if \"natural scrolling\" is enabled.+  A notch of a regular mouse wheel corresponds to an offset of 1,+  while trackpads also report fractional offsets.+-}+type ScrollCallback =+  forall a.+  (Backend a) =>+  IORef a ->+  (Double, Double) ->+  Modifiers ->+  (Int, Int) ->+  IO ()++ -- | No arguments. type IdleCallback =   forall a. (Backend a) => IORef a -> IO ()@@ -160,6 +185,7 @@ data Callback   = Display DisplayCallback   | KeyMouse KeyboardMouseCallback+  | Scroll ScrollCallback   | Idle IdleCallback   | Motion MotionCallback   | Drop DropCallback@@ -190,8 +216,6 @@   = LeftButton   | MiddleButton   | RightButton-  | WheelUp-  | WheelDown   | AdditionalButton Int   deriving (Show, Eq, Ord) 

@@ -64,6 +64,7 @@               callback_exit ()             , -- Viewport control with mouse               callback_viewState_keyMouse viewSR+            , callback_viewState_scroll viewSR             , callback_viewState_motion viewSR             , callback_viewState_reshape             ]

@@ -3,6 +3,7 @@ module Brillo.Internals.Interface.Event (   Event (..),   keyMouseEvent,+  scrollEvent,   motionEvent,   dropEvent,   pickEvent,@@ -15,8 +16,22 @@  -- | Possible input events. data Event-  = EventKey Key KeyState Modifiers (Float, Float)-  | EventMotion (Float, Float)+  = {-| A key or mouse button was pressed or released.+    Arguments: key, key state, modifiers, mouse position.+    -}+    EventKey Key KeyState Modifiers (Float, Float)+  | {-| The user scrolled with a mouse wheel or a trackpad.+    Arguments: scroll offset @(x, y)@, modifiers, mouse position.+    A positive y offset means scrolling up,+    a positive x offset means scrolling left.+    The directions are the ones reported by the operating system,+    so they are reversed if \"natural scrolling\" is enabled.+    One notch of a regular mouse wheel corresponds to an offset of @1@,+    while trackpads also report fractional offsets.+    -}+    EventScroll (Float, Float) Modifiers (Float, Float)+  | -- | The mouse was moved. Argument: mouse position.+    EventMotion (Float, Float)   | EventResize (Int, Int)   | EventDrop [FilePath]   | EventPick [FilePath]@@ -34,6 +49,19 @@   IO Event keyMouseEvent backendRef key keyState modifiers pos =   EventKey key keyState modifiers <$> convertPoint backendRef pos+++scrollEvent ::+  forall a.+  (Backend a) =>+  IORef a ->+  (Double, Double) ->+  Modifiers ->+  (Int, Int) ->+  IO Event+scrollEvent backendRef (offsetX, offsetY) modifiers pos =+  EventScroll (realToFrac offsetX, realToFrac offsetY) modifiers+    <$> convertPoint backendRef pos   motionEvent ::

@@ -114,6 +114,7 @@                     singleStepTime                 )             , callback_keyMouse worldSR viewSR worldHandleEvent+            , callback_scroll worldSR worldHandleEvent             , callback_motion worldSR worldHandleEvent             , callback_drop worldSR worldHandleEvent             , callback_reshape worldSR worldHandleEvent@@ -150,6 +151,29 @@ handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos =   do     ev <- keyMouseEvent backendRef key keyState keyMods pos+    world <- readIORef worldRef+    world' <- eventFn ev world+    writeIORef worldRef world'+++-- | Callback for Scroll events.+callback_scroll ::+  -- | ref to world state+  IORef world ->+  -- | fn to handle input events+  (Event -> world -> IO world) ->+  Callback+callback_scroll worldRef eventFn =+  Scroll (handle_scroll worldRef eventFn)+++handle_scroll ::+  IORef a ->+  (Event -> a -> IO a) ->+  ScrollCallback+handle_scroll worldRef eventFn backendRef offset keyMods pos =+  do+    ev <- scrollEvent backendRef offset keyMods pos     world <- readIORef worldRef     world' <- eventFn ev world     writeIORef worldRef world'

@@ -76,6 +76,7 @@             [ Callback.Display displayFun             , -- Viewport control with mouse               callback_keyMouse worldSR viewSR worldHandleEvent+            , callback_scroll worldSR worldHandleEvent             , callback_motion worldSR worldHandleEvent             , callback_drop worldSR worldHandleEvent             , callback_reshape worldSR worldHandleEvent@@ -124,6 +125,30 @@ handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos =   do     ev <- keyMouseEvent backendRef key keyState keyMods pos+    world <- readIORef worldRef+    world' <- eventFn ev world+    writeIORef worldRef world'+    postRedisplay backendRef+++-- | Callback for Scroll events.+callback_scroll ::+  -- | ref to world state+  IORef world ->+  -- | fn to handle input events+  (Event -> world -> IO world) ->+  Callback+callback_scroll worldRef eventFn =+  Scroll (handle_scroll worldRef eventFn)+++handle_scroll ::+  IORef a ->+  (Event -> a -> IO a) ->+  ScrollCallback+handle_scroll worldRef eventFn backendRef offset keyMods pos =+  do+    ev <- scrollEvent backendRef offset keyMods pos     world <- readIORef worldRef     world' <- eventFn ev world     writeIORef worldRef world'

@@ -106,6 +106,7 @@                 )             , callback_exit ()             , callback_viewState_keyMouse viewSR+            , callback_viewState_scroll viewSR             , callback_viewState_motion viewSR             , callback_viewState_reshape             ]

@@ -1,7 +1,10 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -module Brillo.Internals.Interface.ViewState.KeyMouse (callback_viewState_keyMouse)+module Brillo.Internals.Interface.ViewState.KeyMouse (+  callback_viewState_keyMouse,+  callback_viewState_scroll,+) where  import Brillo.Data.ViewState@@ -25,6 +28,29 @@   do     viewState <- readIORef viewStateRef     ev <- keyMouseEvent stateRef key keyState keyMods pos+    case updateViewStateWithEventMaybe ev viewState of+      Nothing -> return ()+      Just viewState' ->+        do+          viewStateRef `writeIORef` viewState'+          postRedisplay stateRef+++{-| Callback to handle scroll events (mouse wheel, trackpad)+     for controlling the 'ViewState'.+-}+callback_viewState_scroll ::+  IORef ViewState ->+  Callback+callback_viewState_scroll viewStateRef =+  Scroll (viewState_scroll viewStateRef)+++viewState_scroll :: IORef ViewState -> ScrollCallback+viewState_scroll viewStateRef stateRef offset keyMods pos =+  do+    viewState <- readIORef viewStateRef+    ev <- scrollEvent stateRef offset keyMods pos     case updateViewStateWithEventMaybe ev viewState of       Nothing -> return ()       Just viewState' ->

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               brillo-version:            2.0.0+version:            3.0.0 license:            MIT license-file:       LICENSE author:             Ben Lippmeier, Adrian Sieber@@ -32,7 +32,7 @@   default-language:   GHC2021   build-depends:     , base              >=4.8  && <5-    , brillo-rendering  >=2.0  && <3.0+    , brillo-rendering  >=3.0  && <4.0     , containers        >=0.5  && <0.9     , GLFW-b            >=3.3  && <4     , OpenGL            >=2.12 && <3.1@@ -73,6 +73,7 @@     Brillo.Interface.IO.Display     Brillo.Interface.IO.Game     Brillo.Interface.IO.Interact+    Brillo.Interface.IO.MessageBox     Brillo.Interface.IO.Simulate     Brillo.Interface.Pure.Animate     Brillo.Interface.Pure.Display