metabrush/src/app/MetaBrush/Action.hs

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

module MetaBrush.Action where

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

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

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

-- 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 )
import qualified Data.Text as Text
  ( intercalate, pack )

-- MetaBrush
import Math.Bezier.Spline
  ( Spline(..), SplineType(Open)
  , catMaybesSpline
  )
import Math.Bezier.Stroke
  ( CachedStroke(..) )
import Math.Module
  ( Module((*^)) )
import Math.Vector2D
  ( Point2D(..), Vector2D(..) )
import MetaBrush.Context
  ( UIElements(..), Variables(..)
  , Modifier(..), modifierKey
  , HoldAction(..), GuideAction(..), PartialPath(..)
  )
import MetaBrush.Document
  ( Document(..), DocumentContent(..), PointData(..), FocusState(..)
  , Guide(..), selectedGuide, addGuide
  )
import MetaBrush.Document.Draw
  ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document.History
  ( DocumentHistory(..), newHistory
  , back, fwd
  )
import MetaBrush.Document.Selection
  ( SelectionMode(..), selectionMode
  , selectAt, selectRectangle
  , DragMoveSelect(..), dragMoveSelect
  , UpdateInfo(..)
  , deleteSelected
  , dragUpdate
  )
import MetaBrush.Document.Serialise
  ( saveDocument, loadDocument )
import MetaBrush.Document.SubdivideStroke
  ( subdivide )
import MetaBrush.Document.Update
  ( activeDocument, withActiveDocument
  , DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
  , modifyingCurrentDocument
  , updateUIAction, updateHistoryState
  )
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(..), Mode(..) )
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 False 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 -> warningDialog window filePath errMessage
        Right doc -> do
          let
            newDocHist :: DocumentHistory
            newDocHist = newHistory doc
          newFileTab False uiElts vars ( Just newDocHist ) tabLoc
          updateHistoryState uiElts ( Just newDocHist )

warningDialog :: Show errMess => GTK.Window -> FilePath -> errMess -> IO ()
warningDialog window filePath errMess = do
  dialog <- GTK.new GTK.MessageDialog []
  GTK.setMessageDialogText dialog
    ( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
  GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning
  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 "OK" 1
  widgetAddClass closeButton "dialogButton"
  _ <- GTK.dialogRun dialog
  GTK.widgetDestroy dialog

-----------------
-- 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 -> warningDialog window filePath errMessage
            Right doc -> do
              let
                newDocHist :: DocumentHistory
                newDocHist = newHistory doc
              newFileTab False uiElts vars ( Just newDocHist ) tabLoc
              updateHistoryState uiElts ( Just newDocHist )

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

data Save = Save
  deriving stock Show

instance HandleAction Save where
  handleAction uiElts vars _ =
    save uiElts vars True

save :: UIElements -> Variables -> Bool -> IO ()
save uiElts vars keepOpen = do
  mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
  for_ mbDoc \case
    doc@( Document { mbFilePath, documentContent } )
      | Nothing <- mbFilePath
      -> saveAs uiElts vars keepOpen
      | False <- unsavedChanges documentContent
      -> pure ()
      | Just filePath <- mbFilePath
      -> modifyingCurrentDocument uiElts vars \ _ -> do
        let
          modif :: DocumentUpdate
          modif = if keepOpen then SaveDocument Nothing else CloseDocument
        pure $ UpdateDocAndThen modif ( 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 ->
    modifyingCurrentDocument uiElts vars \ doc -> do
      let
        modif :: DocumentUpdate
        modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument
      pure $ UpdateDocAndThen modif ( 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 {..} )
    vars@( Variables {..} )
    close = do
      mbDoc <- case close of
        CloseActive      -> fmap ( ( , True ) . present ) <$> STM.atomically ( activeDocument vars )
        CloseThis unique -> do
          mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars )
          mbDoc        <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
          for mbDoc \ doc ->
            pure ( doc, maybe False ( ( == unique ) . documentUnique ) mbCurrentDoc )
      case mbDoc of
        Nothing -> pure () -- could show a warning message
        Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
          | unsavedChanges documentContent
          -> 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 isActiveDoc documentUnique
              SaveAndClose -> save uiElts vars False
              _            -> pure ()
          | otherwise
          -> closeDocument isActiveDoc documentUnique

      where
        closeDocument :: Bool -> Unique -> IO ()
        closeDocument isActiveDoc unique = do
          removeFileTab vars unique
          when isActiveDoc do
            uiUpdateAction <- STM.atomically do
              STM.writeTVar activeDocumentTVar Nothing
              uiUpdateAction <- updateUIAction uiElts vars
              pure do
                uiUpdateAction
                updateHistoryState uiElts Nothing
            uiUpdateAction

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

data SwitchTo = SwitchTo Unique
  deriving stock Show

instance HandleAction SwitchTo where
  handleAction
    uiElts
    vars@( Variables {..} )
    ( SwitchTo newUnique ) = do
      uiUpdateAction <- STM.atomically do
        STM.writeTVar activeDocumentTVar ( Just newUnique )
        mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
        uiUpdateAction <- updateUIAction uiElts vars
        pure do
          uiUpdateAction
          updateHistoryState uiElts mbHist
      uiUpdateAction

--------------
-- 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 & Redo --
----------------

data Undo = Undo
  deriving stock Show

instance HandleAction Undo where
  handleAction uiElts vars _ = updateHistory back uiElts vars


data Redo = Redo
  deriving stock Show

instance HandleAction Redo where
  handleAction uiElts vars _ = updateHistory fwd uiElts vars

updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO ()
updateHistory f uiElts vars@( Variables {..} ) = do
  uiUpdateAction <- STM.atomically do
    mbUnique <- STM.readTVar activeDocumentTVar
    case mbUnique of
      Nothing -> pure ( pure () )
      Just unique -> do
        mbDocHistory <- Map.lookup unique <$> STM.readTVar openDocumentsTVar
        case mbDocHistory of
          Nothing -> pure ( pure () )
          Just docHistory -> do
            let
              newDocHistory :: DocumentHistory
              newDocHistory = f docHistory
            STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDocHistory )
            uiUpdateAction <- updateUIAction uiElts vars
            pure do
              updateHistoryState uiElts ( Just newDocHistory )
              uiUpdateAction
  uiUpdateAction

---------
-- 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' in path mode.
          Selection
            | PathMode <- mode
            -> modifyingCurrentDocument uiElts vars \ doc -> do
                let
                  newDocument :: Document
                  updateInfo :: UpdateInfo
                  ( newDocument, updateInfo ) = deleteSelected doc
                case updateInfo of
                  UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
                    | null strokesAffected
                    -> pure Don'tModifyDoc
                    | let
                        ppDel, cpDel, changeText :: Text
                        ppDel
                          | pathPointsAffected == 0
                          = ""
                          | otherwise
                          = Text.pack ( show pathPointsAffected ) <> " path points"
                        cpDel
                          | controlPointsAffected == 0
                          = ""
                          | otherwise
                          = Text.pack ( show controlPointsAffected ) <> " control points"
                        changeText =
                          "Delete " <> Text.intercalate " and" [ ppDel, cpDel ]
                          <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
                    -> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} )
          _ -> 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
      uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( 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 ()
        pure do
          updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
          GTK.widgetQueueDraw viewportDrawingArea
          for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
            GTK.widgetQueueDraw drawingArea
      sequenceA_ uiUpdateAction

-----------------
-- 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 )
          mode <- STM.readTVar modeTVar
          case mode of
            BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
            _ ->
              case actionOrigin of

                ViewportOrigin -> case ty of

                  SingleClick -> do
                    modifiers <- STM.readTVar modifiersTVar
                    tool <- STM.readTVar toolTVar

                    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 ( dragMove, newDoc ) <- dragMoveSelect pos doc
                            -> do
                              STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
                              case dragMove of
                                ClickedOnSelected ->
                                  pure Don'tModifyDoc
                                ClickedOnUnselected ->
                                  pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
                                ClickedOnCurve {} ->
                                  pure Don'tModifyDoc
                          -- 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
                            ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
                              getOrCreateDrawAnchor uniqueSupply pos doc
                            STM.writeTVar partialPathTVar
                              ( Just $ PartialPath
                                { partialStartPos     = anchorPt
                                , partialControlPoint = Nothing
                                , partialPathAnchor   = drawAnchor
                                , firstPoint          = True
                                }
                              )
                            case mbExistingAnchorName of
                              Nothing ->
                                let 
                                  changeText :: Text
                                  changeText = "Begin new stroke"
                                in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                              Just _ ->
                                pure Don'tModifyDoc
                          -- 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
                    modifs <- STM.readTVar modifiersTVar
                    case tool of
                      Selection
                        | PathMode <- mode
                        , null modifs
                        -> do
                          STM.writeTVar mouseHoldTVar Nothing
                          case subdivide pos doc of
                            Nothing              ->
                              pure Don'tModifyDoc
                            Just ( newDocument, loc ) -> do
                              let
                                changeText :: Text
                                changeText = "Subdivide " <> loc
                              pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
    
                      -- Ignore double click event otherwise.
                      _ -> pure Don'tModifyDoc

                RulerOrigin ruler -> do
                  showGuides <- STM.readTVar showGuidesTVar
                  when showGuides do
                    let
                      mbGuide :: Maybe Guide
                      mbGuide = selectedGuide 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
              case guideAction of
                CreateGuide ruler
                  | createGuide
                  -> do
                    newDocument <- addGuide uniqueSupply ruler pos doc
                    let
                      changeText :: Text
                      changeText = "Create guide"
                    pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                  | otherwise
                  -> pure Don'tModifyDoc
                  where
                    createGuide :: Bool
                    createGuide
                      =  x >= 0
                      && y >= 0
                      && x <= viewportWidth
                      && y <= viewportHeight
                MoveGuide guideUnique
                  | keepGuide
                  -> let
                        newDocument :: Document
                        newDocument =
                          over
                            ( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
                            ( ( holdStartPos --> pos :: Vector2D Double ) • )
                            doc
                        changeText :: Text
                        changeText = "Move guide"
                      in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                  | otherwise
                  -> let
                        newDocument :: Document
                        newDocument =
                           set ( field' @"documentContent" . field' @"guides" . at guideUnique )
                            Nothing
                            doc
                        changeText :: Text
                        changeText = "Delete guide"
                      in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                  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

            _ -> do
              tool <- STM.readTVar toolTVar
              mode <- STM.readTVar modeTVar
              case mode of
                BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
                _ ->
                  case tool of

                    Selection -> do
                      let
                        selMode :: SelectionMode
                        selMode = selectionMode modifiers
                      case mbHoldPos of
                        Just hold
                          | DragMoveHold { holdStartPos = pos0, dragAction } <- hold
                          , pos0 /= pos
                          -> let
                                alternateMode :: Bool
                                alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
                              in case dragUpdate pos0 pos dragAction alternateMode doc of
                                Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
                                Nothing  -> pure Don'tModifyDoc
                          | SelectionHold pos0 <- hold
                          , pos0 /= pos
                          -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
                        _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt 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 :: Spline Open CachedStroke ( PointData () )
                              newSegment = catMaybesSpline ( CachedStroke Nothing )
                                ( PointData p1 Normal () )
                                ( do
                                    cp <- mbCp2
                                    guard ( cp /= p1 )
                                    pure ( PointData cp Normal () )
                                )
                                ( do
                                    cp <- mbControlPoint
                                    guard ( cp /= otherAnchorPt )
                                    pure ( PointData cp Normal () )
                                )
                                ( PointData otherAnchorPt Normal () )
                              newDocument :: Document
                              newDocument = addToAnchor anchor newSegment doc
                              changeText :: Text
                              changeText = "Close stroke"
                            pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                          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 :: Spline Open CachedStroke ( PointData () )
                                newSegment = catMaybesSpline ( CachedStroke Nothing )
                                  ( PointData p1 Normal () )
                                  ( do
                                      cp <- mbCp2
                                      guard ( cp /= p1 )
                                      pure ( PointData cp Normal () )
                                  )
                                  ( do
                                      cp <- mbControlPoint
                                      guard ( cp /= pathPoint )
                                      pure ( PointData cp Normal () )
                                  )
                                  ( PointData pathPoint Normal () )
                                newDocument :: Document
                                newDocument = addToAnchor anchor newSegment doc
                                changeText :: Text
                                changeText = "Continue stroke"
                              pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )

      -- 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 ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )

--------------------
-- 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 )
        ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )

      case keyCode of

        GDK.KEY_Escape -> handleAction uiElts vars Quit

        confirm
          |  confirm == GDK.KEY_Return
          || confirm == GDK.KEY_space
          -> 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 )
      ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.delete )