metabrush/src/app/MetaBrush/Action.hs

{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE UndecidableInstances  #-}

module MetaBrush.Action where

-- base
import Control.Monad
  ( guard, when, unless, void )
import Data.Foldable
  ( for_ )
import Data.Int
  ( Int32 )
import Data.Maybe
  ( catMaybes, listToMaybe )
import Data.Word
  ( Word32 )

-- acts
import Data.Act
  ( Act
    ( (•) )
  , Torsor
    ( (-->) )
  )

-- containers
import qualified Data.Map as Map
  ( lookup, insert, delete )
import Data.Sequence
  ( Seq(..) )
import qualified Data.Sequence as Seq
  ( fromList )
import qualified Data.Set as Set
  ( insert, delete )

-- directory
import System.Directory
  ( doesDirectoryExist, listDirectory )

-- filepath
import System.FilePath
  ( (</>), (<.>), takeExtension )

-- gi-gdk
import qualified GI.Gdk as GDK

-- gi-gtk
import qualified GI.Gtk as GTK

-- stm
import qualified Control.Concurrent.STM as STM
  ( atomically )
import qualified Control.Concurrent.STM.TVar as STM
  ( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )

-- MetaBrush
import Math.Bezier.Stroke
  ( StrokePoint(..) )
import Math.Module
  ( Module((*^)) )
import Math.Vector2D
  ( Point2D(..), Vector2D(..) )
import MetaBrush.Context
  ( UIElements(..), Variables(..)
  , Modifier(..), modifierKey
  , HoldAction(..), PartialPath(..)
  , currentDocument, withCurrentDocument, modifyingCurrentDocument
  )
import MetaBrush.Document
  ( Document(..)
  , PointData(..), FocusState(..)
  )
import MetaBrush.Document.Draw
  ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document.Selection
  ( SelectionMode(..), selectionMode
  , selectAt, selectRectangle
  , dragMoveSelect
  , translateSelection
  , deleteSelected
  )
import MetaBrush.Document.Serialise
  ( saveDocument, loadDocument )
import MetaBrush.UI.Coordinates
  ( toViewportCoordinates )
import MetaBrush.UI.InfoBar
  ( updateInfoBar )
import {-# SOURCE #-} MetaBrush.UI.FileBar
  ( TabLocation(..), newFileTab, removeFileTab )
import MetaBrush.UI.ToolBar
  ( Tool(..) )
import MetaBrush.Unique
  ( Unique )
import MetaBrush.Util
  ( widgetAddClass, widgetAddClasses )

--------------------------------------------------------------------------------

class HandleAction action where
  handleAction :: UIElements -> Variables -> action -> IO ()

--------------------------------------------------------------------------------
-- General actions

instance HandleAction () where
  handleAction _ _ _ = pure ()

--------------
-- New file --
--------------

data NewFile = NewFile TabLocation
  deriving stock Show

instance HandleAction NewFile where
  handleAction uiElts vars ( NewFile tabLoc ) =
    newFileTab vars uiElts Nothing tabLoc

---------------
-- Open file --
---------------

data OpenFile = OpenFile TabLocation
  deriving stock Show

instance HandleAction OpenFile where
  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFile tabLoc ) = do
    fileChooser <-
      GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window )
        GTK.FileChooserActionOpen
        ( Just "Open" )
        ( Just "Cancel" )
    GTK.fileChooserSetSelectMultiple fileChooser True
    GTK.nativeDialogSetModal fileChooser True
    fileFilter <- GTK.fileFilterNew
    GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
    GTK.fileFilterAddPattern fileFilter "*.mb"
    GTK.fileChooserAddFilter fileChooser fileFilter
    void $ GTK.nativeDialogRun fileChooser
    filePaths <- GTK.fileChooserGetFilenames fileChooser
    for_ filePaths \ filePath -> do
      mbDoc <- loadDocument uniqueSupply filePath
      case mbDoc of
        Left _errMessage -> pure () -- TODO: show warning dialog?
        Right doc -> do
          newFileTab vars uiElts ( Just doc ) tabLoc

-----------------
-- Open folder --
-----------------

data OpenFolder = OpenFolder TabLocation
  deriving stock Show

instance HandleAction OpenFolder where
  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFolder tabLoc ) = do
    fileChooser <-
      GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window )
        GTK.FileChooserActionSelectFolder
        ( Just "Select Folder" )
        ( Just "Cancel" )
    GTK.fileChooserSetSelectMultiple fileChooser True
    GTK.nativeDialogSetModal fileChooser True
    void $ GTK.nativeDialogRun fileChooser
    folderPaths <- GTK.fileChooserGetFilenames fileChooser
    for_ folderPaths \ folderPath -> do
      exists <- doesDirectoryExist folderPath
      when exists do
        filePaths <- listDirectory folderPath
        for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
          mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
          case mbDoc of
            Left _errMessage -> pure () -- TODO: show warning dialog?
            Right doc -> do
              newFileTab vars uiElts ( Just doc ) tabLoc
    pure ()

---------------
-- Save file --
---------------

data Save = Save
  deriving stock Show

instance HandleAction Save where
  handleAction uiElts vars@( Variables { .. } ) _ = do
    mbDoc <- STM.atomically $ currentDocument vars
    case mbDoc of
      Nothing  -> pure () -- could show a warning message
      Just doc@( Document { mbFilePath, unsavedChanges } )
        | Nothing <- mbFilePath
        -> saveAs uiElts vars True doc
        | False <- unsavedChanges
        -> pure ()
        | Just filePath <- mbFilePath
        -> do
          saveDocument filePath doc
          STM.atomically $
            STM.modifyTVar' openDocumentsTVar
              ( Map.insert ( documentUnique doc )
                ( doc { unsavedChanges = False } )
              )

-------------
-- Save as --
-------------

data SaveAs = SaveAs
  deriving stock Show

instance HandleAction SaveAs where
  handleAction uiElts vars _ = do
    mbDoc <- STM.atomically $ currentDocument vars
    case mbDoc of
      Nothing  -> pure () -- could show a warning message
      Just doc -> saveAs uiElts vars True doc

saveAs :: UIElements -> Variables -> Bool -> Document -> IO ()
saveAs ( UIElements { window, fileBar } ) vars@( Variables { openDocumentsTVar } ) keepOpen doc = do
  fileChooser <-
    GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
      GTK.FileChooserActionSave
      ( Just "Save" )
      ( Just "Cancel" )
  GTK.nativeDialogSetModal fileChooser True
  GTK.fileChooserSetDoOverwriteConfirmation fileChooser True
  fileFilter <- GTK.fileFilterNew
  GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
  GTK.fileFilterAddPattern fileFilter "*.mb"
  GTK.fileChooserAddFilter fileChooser fileFilter
  void $ GTK.nativeDialogRun fileChooser
  mbFilePath <- listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
  for_ mbFilePath \ filePath -> do
    -- set the document's new file path, and modify to indicate "no unsaved changes"
    let
      fullFilePath :: FilePath
      fullFilePath
        | ".mb" <- takeExtension filePath
        = filePath
        | otherwise
        = filePath <.> "mb"
    saveDocument fullFilePath doc
    if keepOpen
    then
      STM.atomically $
        STM.modifyTVar' openDocumentsTVar
          ( Map.insert ( documentUnique doc )
            ( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } )
          )
    else removeFileTab fileBar vars ( documentUnique doc )

-----------
-- Close --
-----------

data Close
  = CloseActive -- ^ Close active document.
  | CloseThis   -- ^ Close a specific tab (action to destroy tab is directly given).
    { docToClose       :: Unique
    , destroyTabAction :: IO ()
    }

instance Show Close where
  show CloseActive = "CloseActive"
  show ( CloseThis docToClose _ ) = "CloseThis " <> show docToClose

pattern JustClose, SaveAndClose, CancelClose :: Int32
pattern JustClose    = 1
pattern SaveAndClose = 2
pattern CancelClose  = 3

instance HandleAction Close where
  handleAction uiElts@( UIElements { window, fileBar } ) vars@( Variables { .. } ) close = do
    mbDoc <- case close of
      CloseActive      -> STM.atomically $ currentDocument vars
      CloseThis unique _ -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
    case mbDoc of
      Nothing  -> pure () -- could show a warning message
      Just doc@( Document { displayName, documentUnique } ) -> do
        dialog <- GTK.new GTK.MessageDialog []
        GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
        GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
        GTK.setWindowResizable dialog False
        GTK.setWindowDecorated dialog False
        GTK.widgetAddEvents dialog
          [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
        GTK.windowSetTransientFor dialog ( Just window )
        GTK.windowSetModal dialog True
        widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
        closeButton  <- GTK.dialogAddButton dialog "Close"          JustClose
        saveButton   <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
        cancelButton <- GTK.dialogAddButton dialog "Cancel"         CancelClose
        GTK.dialogSetDefaultResponse dialog 1
        for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
        choice <- GTK.dialogRun dialog
        GTK.widgetDestroy dialog
        case choice of
          JustClose    -> case close of
            CloseActive -> removeFileTab fileBar vars documentUnique
            CloseThis _ destroyTab -> do
              destroyTab
              STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete documentUnique )
          SaveAndClose -> saveAs uiElts vars False doc
          _            -> pure ()

--------------
-- Quitting --
--------------

data Quit = Quit
  deriving stock Show

instance HandleAction Quit where
  handleAction ( UIElements { window } ) _ _ = quitEverything window

quitEverything :: GTK.Window -> IO ()
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit

----------
-- Undo --
----------

data Undo = Undo
  deriving stock Show

-- TODO
instance HandleAction Undo where
  handleAction _ _ _ = pure ()

----------
-- Redo --
----------

data Redo = Redo
  deriving stock Show

-- TODO
instance HandleAction Redo where
  handleAction _ _ _ = pure ()

---------
-- Cut --
---------

data Cut = Cut
  deriving stock Show

-- TODO
instance HandleAction Cut where
  handleAction _ _ _ = pure ()

----------
-- Copy --
----------

data Copy = Copy
  deriving stock Show

-- TODO
instance HandleAction Copy where
  handleAction _ _ _ = pure ()

-----------
-- Paste --
-----------

data Paste = Paste
  deriving stock Show

-- TODO
instance HandleAction Paste where
  handleAction _ _ _ = pure ()

---------------
-- Duplicate --
---------------

data Duplicate = Duplicate
  deriving stock Show

-- TODO
instance HandleAction Duplicate where
  handleAction _ _ _ = pure ()

------------
-- Delete --
------------

data Delete = Delete
  deriving stock Show

instance HandleAction Delete where
  handleAction
    ( UIElements { viewportDrawingArea } )
    vars@( Variables { toolTVar, modeTVar } )
    _
    = do
        tool <- STM.readTVarIO toolTVar
        mode <- STM.readTVarIO modeTVar
        case tool of
          -- Delete selected points on pressing 'Delete'.
          Selection -> do
            STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
            GTK.widgetQueueDraw viewportDrawingArea
          _ -> pure ()

------------
-- Confirm --
------------

data Confirm = Confirm
  deriving stock Show

instance HandleAction Confirm where
  handleAction
    ( UIElements { viewportDrawingArea } )
    ( Variables { .. } )
    _
    = do
        tool <- STM.readTVarIO toolTVar
        case tool of
          -- End ongoing drawing on pressing enter key.
          Pen -> do
            STM.atomically $ STM.writeTVar partialPathTVar Nothing
            GTK.widgetQueueDraw viewportDrawingArea
          _ -> pure ()

----------------
-- About page --
----------------

data About = About
  deriving stock Show

-- TODO
instance HandleAction About where
  handleAction _ _ _ = pure ()

--------------------------------------------------------------------------------
-- Input actions

--------------------
-- Mouse movement --
--------------------

data MouseMove = MouseMove ( Point2D Double )
  deriving stock Show

instance HandleAction MouseMove where
  handleAction
    ( UIElements { viewportDrawingArea, infoBar } )
    vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } )
    ( MouseMove ( Point2D x y ) )
    = do
      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
      void . STM.atomically $ withCurrentDocument vars \ ( Document { .. } ) -> do
        modifiers <- STM.readTVar modifiersTVar
        let
          toViewport :: Point2D Double -> Point2D Double
          toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
          pos :: Point2D Double
          pos = toViewport ( Point2D x y )
        STM.writeTVar mousePosTVar ( Just pos )
        ----------------------------------------------------------
        -- With the pen tool, keeping control pressed while moving the mouse
        -- moves the partial control point (if one exists).
        tool <- STM.readTVar toolTVar
        mbPartialPath <- STM.readTVar partialPathTVar
        case tool of
          Pen
            | any ( \ case { Control _ -> True; _ -> False } ) modifiers
            , Just pp <- mbPartialPath
            -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
          _ -> pure ()

      updateInfoBar viewportDrawingArea infoBar vars
      GTK.widgetQueueDraw viewportDrawingArea

-----------------
-- Mouse click --
-----------------

data MouseClick = MouseClick Word32 ( Point2D Double )
  deriving stock Show

instance HandleAction MouseClick where
  handleAction
    ( UIElements { viewportDrawingArea } )
    vars@( Variables { .. } )
    ( MouseClick button mouseClickCoords )
    = case button of

      -- Left mouse button.
      1 -> do
        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
        STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
          let
            toViewport :: Point2D Double -> Point2D Double
            toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
            pos :: Point2D Double
            pos = toViewport mouseClickCoords
          STM.writeTVar mousePosTVar ( Just pos )
          modifiers <- STM.readTVar modifiersTVar
          tool <- STM.readTVar toolTVar
          mode <- STM.readTVar modeTVar
          case tool of
            -- Selection mode mouse hold:
            --
            --   - If holding shift or alt, mouse hold initiates a rectangular selection.
            --   - If not holding shift or alt:
            --      - if mouse click selected an object, initiate a drag move,
            --      - otherwise, initiate a rectangular selection.
            Selection ->
              case selectionMode modifiers of
                -- Drag move: not holding shift or alt, click has selected something.
                New
                  | Just newDoc <- dragMoveSelect mode pos doc
                  -> do
                    STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
                    pure ( Just newDoc )
                -- Rectangular selection.
                _ -> do
                    STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
                    pure Nothing

            -- Pen tool: start or continue a drawing operation.
            Pen -> do
              mbPartialPath <- STM.readTVar partialPathTVar
              STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
              case mbPartialPath of
                -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
                Nothing -> do
                  ( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
                  STM.writeTVar partialPathTVar
                    ( Just $ PartialPath
                      { partialStartPos     = anchorPt
                      , partialControlPoint = Nothing
                      , partialPathAnchor   = drawAnchor
                      , firstPoint          = True
                      }
                    )
                  pure ( Just newDoc )
                -- Path already started: indicate that we are continuing a path.
                Just pp -> do
                  STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
                  pure Nothing
        GTK.widgetQueueDraw viewportDrawingArea

      -- Right mouse button: end partial path.
      3 -> do
        STM.atomically $ STM.writeTVar partialPathTVar Nothing
        GTK.widgetQueueDraw viewportDrawingArea

      -- Other mouse buttons: ignored (for the moment at least).
      _ -> pure ()


-------------------
-- Mouse release --
-------------------

data MouseRelease = MouseRelease Word32 ( Point2D Double )
  deriving stock Show

instance HandleAction MouseRelease where
  handleAction 
    ( UIElements { viewportDrawingArea } )
    vars@( Variables { .. } )
    ( MouseRelease button ( Point2D x y ) )
    = case button of

      -- Left mouse button.
      1 -> do
        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
        STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } )  -> do
          let
            toViewport :: Point2D Double -> Point2D Double
            toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
            pos :: Point2D Double
            pos = toViewport ( Point2D x y )
          STM.writeTVar mousePosTVar  ( Just pos )
          modifiers <- STM.readTVar modifiersTVar
          mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
          tool      <- STM.readTVar toolTVar
          mode      <- STM.readTVar modeTVar

          case tool of

            Selection -> do
              let
                selMode :: SelectionMode
                selMode = selectionMode modifiers
              case mbHoldPos of
                Just hold
                  | DragMoveHold  pos0 <- hold
                  , pos0 /= pos
                  -> pure . Just $ translateSelection mode ( pos0 --> pos ) doc
                  | SelectionHold pos0 <- hold
                  , pos0 /= pos
                  -> pure . Just $ selectRectangle mode selMode pos0 pos doc
                _ -> pure . Just $ selectAt mode selMode pos doc

            Pen -> do
              mbPartialPath <- STM.readTVar partialPathTVar
              case mbPartialPath of
                -- Normal pen mode mouse click should have created an anchor.
                -- If no anchor exists, then just ignore the mouse release event.
                Nothing -> pure Nothing
                -- Mouse click release possibilities:
                --
                --  - click was on complementary draw stroke draw anchor to close the path,
                --  - release at same point as click: finish current segment,
                --  - release at different point as click: finish current segment, adding a control point.
                Just
                  ( PartialPath
                    { partialStartPos     = p1
                    , partialControlPoint = mbCp2
                    , partialPathAnchor   = anchor
                    , firstPoint
                    }
                  ) -> do
                  let
                    pathPoint :: Point2D Double
                    mbControlPoint :: Maybe ( Point2D Double )
                    partialControlPoint :: Maybe ( Point2D Double )
                    ( pathPoint, mbControlPoint, partialControlPoint )
                      | Just ( DrawHold holdPos ) <- mbHoldPos
                      = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
                      | otherwise
                      = ( pos, Nothing, Nothing )
                  ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
                  if not firstPoint && anchorsAreComplementary anchor otherAnchor
                  -- Close path.
                  then do
                    STM.writeTVar partialPathTVar Nothing
                    let 
                      newSegment :: Seq ( StrokePoint PointData )
                      newSegment
                        = Seq.fromList
                        $ catMaybes
                        [ Just ( PathPoint p1 ( PointData Normal Empty ) )
                        , do
                            cp <- mbCp2
                            guard ( cp /= p1 )
                            pure $ ControlPoint cp ( PointData Normal Empty )
                        , do
                            cp <- mbControlPoint
                            guard ( cp /= otherAnchorPt )
                            pure $ ControlPoint cp ( PointData Normal Empty )
                        , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
                        ]
                    pure ( Just $ addToAnchor anchor newSegment doc )
                  else
                    if firstPoint
                    -- Continue current partial path.
                    then do
                      STM.writeTVar partialPathTVar ( Just $ PartialPath p1        partialControlPoint anchor False )
                      pure Nothing
                    -- Finish current partial path.
                    else do
                      STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
                      let 
                        newSegment :: Seq ( StrokePoint PointData )
                        newSegment
                          = Seq.fromList
                          $ catMaybes
                          [ Just ( PathPoint p1 ( PointData Normal Empty ) )
                          , do
                              cp <- mbCp2
                              guard ( cp /= p1 )
                              pure $ ControlPoint cp ( PointData Normal Empty )
                          , do
                              cp <- mbControlPoint
                              guard ( cp /= pathPoint )
                              pure $ ControlPoint cp ( PointData Normal Empty )
                          , Just ( PathPoint pathPoint ( PointData Normal Empty ) )
                          ]
                      pure ( Just $ addToAnchor anchor newSegment doc )

        GTK.widgetQueueDraw viewportDrawingArea

      -- Other mouse buttons: ignored (for the moment at least).
      _ -> pure ()

---------------
-- Scrolling --
---------------

data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
  deriving stock Show

instance HandleAction Scroll where
  handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do

    viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea

    unless ( dx == 0 && dy == 0 ) do
      STM.atomically $ modifyingCurrentDocument vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
        modifiers <- STM.readTVar modifiersTVar
        let
          toViewport :: Point2D Double -> Point2D Double
          toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
          -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
          mousePos :: Point2D Double
          mousePos = toViewport ( Point2D x y )
          newDoc :: Document
          newDoc
            -- Zooming using 'Control'.
            | any ( \ case { Control _ -> True; _ -> False } ) modifiers
            = let
                newZoomFactor :: Double
                newZoomFactor
                  | dy > 0
                  = max 0.0078125 ( oldZoomFactor / sqrt 2 )
                  | otherwise
                  = min 256 ( oldZoomFactor * sqrt 2 )
                newCenter :: Point2D Double
                newCenter
                  = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
                  • oldCenter
              in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
            -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
            | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
            = let
                newCenter :: Point2D Double
                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
              in doc { viewportCenter = newCenter }
            -- Vertical scrolling.
            | otherwise
            = let
                newCenter :: Point2D Double
                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
              in doc { viewportCenter = newCenter }
          finalZoomFactor :: Double
          finalZoomFactor = zoomFactor     newDoc
          finalCenter :: Point2D Double
          finalCenter     = viewportCenter newDoc
          toFinalViewport :: Point2D Double -> Point2D Double
          toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
          finalMousePos :: Point2D Double
          finalMousePos = toFinalViewport ( Point2D x y )
        STM.writeTVar mousePosTVar ( Just finalMousePos )
        pure ( Just newDoc )
      updateInfoBar viewportDrawingArea infoBar vars
      GTK.widgetQueueDraw viewportDrawingArea

--------------------
-- Keyboard press --
--------------------

data KeyboardPress = KeyboardPress Word32
  deriving stock Show

instance HandleAction KeyboardPress where
  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do

    _modifiers <- STM.atomically do
      !modifiers <- STM.readTVar modifiersTVar
      for_ ( modifierKey keyCode ) \ modifier ->
        ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
      pure modifiers

    case keyCode of

      GDK.KEY_Escape -> handleAction uiElts vars Quit

      GDK.KEY_Return -> handleAction uiElts vars Confirm

      ctrl
        | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
        -> do
          ----------------------------------------------------------
          -- With the pen tool, pressing control moves
          -- the partial point control point to the mouse position.
          tool <- STM.readTVarIO toolTVar
          mbMousePos <- STM.readTVarIO mousePosTVar
          mbPartialPath <- STM.readTVarIO partialPathTVar
          case tool of
            Pen
              | Just mp <- mbMousePos
              , Just pp <- mbPartialPath
              -> do
                  STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
                  GTK.widgetQueueDraw viewportDrawingArea
            _ -> pure ()

      _ -> pure ()

----------------------
-- Keyboard release --
----------------------

data KeyboardRelease = KeyboardRelease Word32
  deriving stock Show

instance HandleAction KeyboardRelease where
  handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) =
    for_ ( modifierKey keyCode ) \ modifier -> do
      STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier )