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 )
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 )

-- generic-lens
import Data.Generics.Product.Fields
  ( field' )

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

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

-- lens
import Control.Lens
  ( over, set )
import Control.Lens.At
  ( ix, at )

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

-- text
import Data.Text
  ( Text )

-- MetaBrush
import Math.Bezier.Stroke
  ( StrokePoint(..) )
import Math.Module
  ( Module((*^)) )
import Math.Vector2D
  ( Point2D(..), Vector2D(..) )
import MetaBrush.Context
  ( UIElements(..), Variables(..)
  , Modifier(..), modifierKey
  , HoldAction(..), GuideAction(..), PartialPath(..)
  , currentDocument, withCurrentDocument
  , PureDocModification(..), DocModification(..)
  , modifyingCurrentDocument
  , updateTitle
  )
import MetaBrush.Document
  ( Document(..), Guide(..)
  , PointData(..), FocusState(..)
  )
import MetaBrush.Document.Draw
  ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document.Guide
  ( selectGuide, addGuide )
import MetaBrush.Document.Selection
  ( SelectionMode(..), selectionMode
  , selectAt, selectRectangle
  , dragMoveSelect
  , translateSelection
  , deleteSelected
  )
import MetaBrush.Document.Serialise
  ( saveDocument, loadDocument )
import MetaBrush.Document.SubdivideStroke
  ( subdivide )
import MetaBrush.UI.Coordinates
  ( toViewportCoordinates )
import MetaBrush.UI.InfoBar
  ( updateInfoBar )
import {-# SOURCE #-} MetaBrush.UI.FileBar
  ( TabLocation(..), newFileTab, removeFileTab )
import MetaBrush.UI.Menu
  ( MenuItem(..), Menu(..), ViewMenu(..) )
import MetaBrush.UI.ToolBar
  ( Tool(..) )
import MetaBrush.UI.Viewport
  ( Viewport(..), Ruler(..) )
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 uiElts vars 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 uiElts vars ( 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 uiElts vars ( Just doc ) tabLoc
    pure ()

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

data Save = Save
  deriving stock Show

instance HandleAction Save where
  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ =
    save uiElts vars True

save :: UIElements -> Variables -> Bool -> IO ()
save uiElts vars keepOpen = do
  mbDoc <- STM.atomically $ currentDocument vars
  for_ mbDoc \case
    doc@( Document { mbFilePath, unsavedChanges } )
      | Nothing <- mbFilePath
      -> saveAs uiElts vars keepOpen
      | False <- unsavedChanges
      -> pure ()
      | Just filePath <- mbFilePath
      -> modifyingCurrentDocument uiElts vars \ _ -> do
        let
          doc' :: Document
          doc' = doc { unsavedChanges = False }
        if keepOpen
        then
          pure $ UpdateDocToAndThen
            ( Just doc' )
            ( saveDocument filePath doc' )
        else
          pure $ UpdateDocToAndThen Nothing ( saveDocument filePath doc' )

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

data SaveAs = SaveAs
  deriving stock Show

instance HandleAction SaveAs where
  handleAction uiElts vars _ = saveAs uiElts vars True

saveAs :: UIElements -> Variables -> Bool -> IO ()
saveAs uiElts vars keepOpen = do
  mbSavePath <- askForSavePath uiElts
  for_ mbSavePath \ savePath -> do
    modifyingCurrentDocument uiElts vars \ doc -> do
      let
        doc' :: Document
        doc' = doc { mbFilePath = Just savePath, unsavedChanges = False }
      if keepOpen
      then
        pure $ UpdateDocToAndThen
          ( Just doc' )
          ( saveDocument savePath doc' )
      else
        pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' )

askForSavePath :: UIElements -> IO ( Maybe FilePath )
askForSavePath ( UIElements {..} ) = 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
  fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
    where
      fullFilePath :: FilePath -> FilePath
      fullFilePath fp
        | ".mb" <- takeExtension fp
        = fp
        | otherwise
        = fp <.> "mb"

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

data Close
  = CloseActive -- ^ Close active document.
  | CloseThis   -- ^ Close a specific tab.
    { docToClose :: Unique }
  deriving stock Show

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

instance HandleAction Close where
  handleAction
    uiElts@( UIElements { viewport = Viewport {..}, .. } )
    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 ( Document { displayName, documentUnique, unsavedChanges } )
          | unsavedChanges
          -> 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.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    -> closeDocument documentUnique
              SaveAndClose -> save uiElts vars False
              _            -> pure ()
          | otherwise
          -> closeDocument documentUnique

      where
        closeDocument :: Unique -> IO ()
        closeDocument unique = do
          removeFileTab vars unique
          updateTitle window title Nothing
          updateInfoBar viewportDrawingArea infoBar vars
          GTK.widgetQueueDraw viewportDrawingArea

---------------------
-- Switch document --
---------------------

data SwitchTo = SwitchTo Unique
  deriving stock Show

instance HandleAction SwitchTo where
  handleAction
    ( UIElements { viewport = Viewport {..}, .. } )
    vars@( Variables {..} )
    ( SwitchTo newUnique ) = do
      mbNewDocAndTab <- STM.atomically do
        STM.writeTVar activeDocumentTVar ( Just newUnique )
        newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
        newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
        pure ( (,) <$> newDoc <*> newTab )
      case mbNewDocAndTab of
        Nothing -> updateTitle window title Nothing
        Just ( Document {..}, tab ) -> do
          updateTitle window title ( Just ( displayName, unsavedChanges ) )
          updateInfoBar viewportDrawingArea infoBar vars
          GTK.widgetQueueDraw tab
      GTK.widgetQueueDraw viewportDrawingArea

--------------
-- 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 ()

---------------------
-- Discard changes --
---------------------

data DiscardChanges = DiscardChanges
  deriving stock Show

-- TODO
instance HandleAction DiscardChanges 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
    uiElts
    vars@( Variables { toolTVar, modeTVar } )
    _
    = do
        tool <- STM.readTVarIO toolTVar
        mode <- STM.readTVarIO modeTVar
        case tool of
          -- Delete selected points on pressing 'Delete'.
          Selection
            -> modifyingCurrentDocument uiElts vars \ doc ->
                pure ( UpdateDocTo $ Just ( deleteSelected mode doc ) )
          _ -> pure ()

-------------------
-- Toggle guides --
-------------------

data ToggleGuides = ToggleGuides
  deriving stock Show

instance HandleAction ToggleGuides where
  handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { showGuidesTVar } ) _ = do
    guidesWereShown <- STM.atomically do
      guidesWereShown <- STM.readTVar showGuidesTVar
      STM.writeTVar showGuidesTVar ( not guidesWereShown )
      pure guidesWereShown
    let
      newText :: Text
      newText
        | guidesWereShown = "Show guides"
        | otherwise       = "Hide guides"
    GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText
    GTK.widgetQueueDraw viewportDrawingArea
    for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
      GTK.widgetQueueDraw drawingArea

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

data Confirm = Confirm
  deriving stock Show

instance HandleAction Confirm where
  handleAction
    ( UIElements { viewport = Viewport {..} } )
    ( 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 { viewport = Viewport {..}, .. } )
    vars@( Variables {..} )
    ( 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
      for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
        GTK.widgetQueueDraw drawingArea

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

data ActionOrigin
  = ViewportOrigin
  | RulerOrigin Ruler
  deriving stock Show

data MouseClickType
  = SingleClick
  | DoubleClick
  deriving stock Show

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

instance HandleAction MouseClick where
  handleAction
    uiElts@( UIElements { viewport = Viewport {..} } )
    vars@( Variables {..} )
    ( MouseClick actionOrigin ty button mouseClickCoords )
    = case button of

      -- Left mouse button.
      1 -> do
        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
        modifyingCurrentDocument uiElts 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 )
          case actionOrigin of

            ViewportOrigin -> case ty of

              SingleClick -> do
                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 ( UpdateDocTo $ Just newDoc )
                      -- Rectangular selection.
                      _ -> do
                          STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
                          pure Don'tModifyDoc

                  -- 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 ( UpdateDocTo $ Just newDoc )
                      -- Path already started: indicate that we are continuing a path.
                      Just pp -> do
                        STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
                        pure Don'tModifyDoc
              
              DoubleClick -> do
                tool <- STM.readTVar toolTVar
                mode <- STM.readTVar modeTVar
                modifs <- STM.readTVar modifiersTVar
                case tool of
                  Selection
                    | null modifs
                    -> do
                      STM.writeTVar mouseHoldTVar Nothing
                      let
                        mbSubdivide :: Maybe Document
                        mbSubdivide = subdivide mode pos doc
                      case mbSubdivide of
                        Nothing     -> pure Don'tModifyDoc
                        Just newDoc -> pure ( UpdateDocTo $ Just newDoc )

                  -- Ignore double click event otherwise.
                  _ -> pure Don'tModifyDoc

            RulerOrigin ruler -> do
              showGuides <- STM.readTVar showGuidesTVar
              when showGuides do
                let
                  mbGuide :: Maybe Guide
                  mbGuide = selectGuide pos doc
                  guideAction :: GuideAction
                  guideAction
                    | Just guide <- mbGuide
                    = MoveGuide ( guideUnique guide )
                    | otherwise
                    = CreateGuide ruler
                STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
              pure Don'tModifyDoc

      -- 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 
    uiElts@( UIElements { viewport = Viewport {..} } )
    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
        modifyingCurrentDocument uiElts 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

          case mbHoldPos of
            Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do
              newDoc <- case guideAction of
                CreateGuide ruler
                  | createGuide
                  -> addGuide uniqueSupply ruler pos doc
                  | otherwise
                  -> pure doc
                  where
                    createGuide :: Bool
                    createGuide
                      =  x >= 0
                      && y >= 0
                      && x <= viewportWidth
                      && y <= viewportHeight
                MoveGuide guideUnique
                  | keepGuide
                  -> pure $
                        over
                          ( field' @"guides" . ix guideUnique . field' @"guidePoint" )
                          ( ( holdStartPos --> pos :: Vector2D Double ) • )
                          doc
                  | otherwise
                  -> pure $ set ( field' @"guides" . at guideUnique ) Nothing doc
                  where
                    l, t :: Double
                    Point2D l t = toViewport ( Point2D 0 0 )
                    keepGuide :: Bool
                    keepGuide
                      =  ( x >= 0 || hx < l ) -- mouse hold position (hx,hy) is in document coordinates,
                      && ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0)
                      && x <= viewportWidth
                      && y <= viewportHeight
              pure ( UpdateDocTo ( Just newDoc ) )

            _ -> do
              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 ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc )
                      | SelectionHold pos0 <- hold
                      , pos0 /= pos
                      -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc )
                    _ -> pure ( UpdateDocTo $ 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 Don'tModifyDoc
                    -- 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 ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
                      else
                        if firstPoint
                        -- Continue current partial path.
                        then do
                          STM.writeTVar partialPathTVar ( Just $ PartialPath p1        partialControlPoint anchor False )
                          pure Don'tModifyDoc
                        -- 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 ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )

      -- 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
    uiElts@( UIElements { viewport = Viewport {..}, .. } )
    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
        modifyingCurrentDocument uiElts 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 ( UpdateDocTo $ Just newDoc )
        updateInfoBar viewportDrawingArea infoBar vars

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

data KeyboardPress = KeyboardPress Word32
  deriving stock Show

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

      for_ ( modifierKey keyCode ) \ modifier ->
        STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.insert modifier )

      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 )