metabrush/src/app/MetaBrush/UI/Menu.hs

{-# LANGUAGE BlockArguments         #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE DerivingStrategies     #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE NamedFieldPuns         #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}

module MetaBrush.UI.Menu
  ( newMenuBar
  , Menu(..)
  , FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..)
  , ResourceType(..)
  , MenuItem(..)
  , createMenuBar
  )
  where

-- base
import Control.Monad
  ( void, unless )
import Data.Foldable
  ( for_ )
import Data.Kind
  ( Type )
import GHC.Generics
  ( Generic )

-- generic-lens
import Data.Generics.Product.Constraints
  ( HasConstraints(constraints) )

-- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo
  ( renderWithContext )

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

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

-- text
import Data.Text
  ( Text )

-- transformers
import Control.Monad.IO.Class
  ( MonadIO(liftIO) )

-- MetaBrush
import MetaBrush.Asset.Colours
  ( Colours )
import MetaBrush.Asset.WindowIcons
  ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
import MetaBrush.Render.Util
  ( widgetAddClass, widgetAddClasses )

--------------------------------------------------------------------------------
-- Types for describing menu items.

data ResourceType
  = Description
  | Object

data family   MenuItem ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
data instance MenuItem submenu Description 
  = MenuItemDescription
    { menuItemLabel      :: !Text
    , menuItemClasses    :: ![ Text ]
    , menuItemAction     :: !( Maybe Text )
    , submenuDescription :: !( submenu Description )
    }
data instance MenuItem submenu Object 
  = MenuItem
  { menuItem        :: !GTK.MenuItem
  , menuItemSubmenu :: !( submenu Object )
  }

data family   Separator ( r :: ResourceType )
data instance Separator Description
  = SeparatorDescription
    { separatorClasses :: ![ Text ] }
data instance Separator Object
  = Separator
  { separatorItem :: !GTK.MenuItem }

data NoSubresource ( k :: ResourceType ) = NoSubresource

--------------------------------------------------------------------------------
-- Menu used in MetaBrush.

-- Types.

data Menu ( rt :: ResourceType )
  = Menu
  { file :: !( MenuItem FileMenu rt )
  , edit :: !( MenuItem EditMenu rt )
  , view :: !( MenuItem ViewMenu rt )
  , help :: !( MenuItem HelpMenu rt )
  }
  deriving stock Generic

data FileMenu ( rt :: ResourceType )
  = FileMenu
  { new    :: !( MenuItem NoSubresource rt )
  , open   :: !( MenuItem NoSubresource rt )
  , save   :: !( MenuItem NoSubresource rt )
  , saveAs :: !( MenuItem NoSubresource rt )
  , close  :: !( MenuItem NoSubresource rt )
  , quit   :: !( MenuItem NoSubresource rt )
  }
  deriving stock Generic

data EditMenu ( rt :: ResourceType )
  = EditMenu
  { undo        :: !( MenuItem  NoSubresource rt )
  , redo        :: !( MenuItem  NoSubresource rt )
  , history     :: !( MenuItem  NoSubresource rt )
  , editSep1    :: !( Separator rt )
  , cut         :: !( MenuItem  NoSubresource rt )
  , copy        :: !( MenuItem  NoSubresource rt )
  , paste       :: !( MenuItem  NoSubresource rt )
  , duplicate   :: !( MenuItem  NoSubresource rt )
  , delete      :: !( MenuItem  NoSubresource rt )
  , editSep2    :: !( Separator rt )
  , preferences :: !( MenuItem  NoSubresource rt )
  }
  deriving stock Generic

data ViewMenu ( rt :: ResourceType )
  = ViewMenu
  { navigator      :: !( MenuItem  NoSubresource rt )
  , viewSep1       :: !( Separator rt )
  , strokes        :: !( MenuItem  NoSubresource rt )
  , brushes        :: !( MenuItem  NoSubresource rt )
  , metaparameters :: !( MenuItem  NoSubresource rt )
  , viewSep2       :: !( Separator rt )
  , transform      :: !( MenuItem  NoSubresource rt )
  }
  deriving stock Generic

data HelpMenu ( rt :: ResourceType )
  = HelpMenu
  { about :: !( MenuItem NoSubresource rt ) }
  deriving stock Generic

-- Descriptions.

menuDescription :: Menu Description
menuDescription
  = Menu
  { file = MenuItemDescription "File" [ "menuItem", "file" ] Nothing fileMenuDescription
  , edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] Nothing editMenuDescription
  , view = MenuItemDescription "View" [ "menuItem", "view" ] Nothing viewMenuDescription
  , help = MenuItemDescription "Help" [ "menuItem", "help" ] Nothing helpMenuDescription
  }

fileMenuDescription :: FileMenu Description
fileMenuDescription
  = FileMenu
  { new    = MenuItemDescription "New"     [ "submenuItem" ] Nothing NoSubresource
  , open   = MenuItemDescription "Open"    [ "submenuItem" ] Nothing NoSubresource
  , save   = MenuItemDescription "Save"    [ "submenuItem" ] Nothing NoSubresource
  , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] Nothing NoSubresource
  , close  = MenuItemDescription "Close"   [ "submenuItem" ] Nothing NoSubresource
  , quit   = MenuItemDescription "Quit"    [ "submenuItem" ] Nothing NoSubresource
  }

editMenuDescription :: EditMenu Description
editMenuDescription
  = EditMenu
  { undo        = MenuItemDescription  "Undo"        [ "submenuItem" ] Nothing NoSubresource
  , redo        = MenuItemDescription  "Redo"        [ "submenuItem" ] Nothing NoSubresource
  , history     = MenuItemDescription  "History"     [ "submenuItem" ] Nothing NoSubresource
  , editSep1    = SeparatorDescription               [ "submenuSeparator" ]
  , cut         = MenuItemDescription  "Cut"         [ "submenuItem" ] Nothing NoSubresource
  , copy        = MenuItemDescription  "Copy"        [ "submenuItem" ] Nothing NoSubresource
  , paste       = MenuItemDescription  "Paste"       [ "submenuItem" ] Nothing NoSubresource
  , duplicate   = MenuItemDescription  "Duplicate"   [ "submenuItem" ] Nothing NoSubresource
  , delete      = MenuItemDescription  "Delete"      [ "submenuItem" ] Nothing NoSubresource
  , editSep2    = SeparatorDescription               [ "submenuSeparator" ]
  , preferences = MenuItemDescription  "Preferences" [ "submenuItem" ] Nothing NoSubresource
  }

viewMenuDescription :: ViewMenu Description
viewMenuDescription
  = ViewMenu
  { navigator      = MenuItemDescription  "Navigator"      [ "submenuItem" ] Nothing NoSubresource
  , viewSep1       = SeparatorDescription                  [ "submenuSeparator" ]
  , strokes        = MenuItemDescription  "Strokes"        [ "submenuItem" ] Nothing NoSubresource
  , brushes        = MenuItemDescription  "Brushes"        [ "submenuItem" ] Nothing NoSubresource
  , metaparameters = MenuItemDescription  "Metaparameters" [ "submenuItem" ] Nothing NoSubresource
  , viewSep2       = SeparatorDescription                  [ "submenuSeparator" ]
  , transform      = MenuItemDescription  "Transform"      [ "submenuItem" ] Nothing NoSubresource
  }

helpMenuDescription :: HelpMenu Description
helpMenuDescription
  = HelpMenu
  { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] Nothing NoSubresource }

--------------------------------------------------------------------------------
-- Creating a GTK menu bar from a menu description.

newMenuItem :: MonadIO m => MenuItem submenu Description -> m GTK.MenuItem
newMenuItem ( MenuItemDescription { .. } ) = do
  menuItem <- GTK.menuItemNewWithLabel menuItemLabel
  -- Could set accelerator labels...
  unless ( null menuItemClasses ) do
    widgetAddClasses menuItem menuItemClasses
  for_ menuItemAction \ actionName -> do
    GTK.actionableSetActionName menuItem ( Just actionName )
  pure menuItem

class CreateMenuItem desc res | desc -> res, res -> desc where
  createMenuItem :: MonadIO m => ( GTK.MenuItem -> m () ) -> desc -> m res
instance {-# OVERLAPPING #-} CreateMenuItem ( MenuItem NoSubresource Description ) ( MenuItem NoSubresource Object ) where
  createMenuItem attachToParent menuItemDescription = do
    menuItem <- newMenuItem menuItemDescription 
    attachToParent menuItem
    pure 
      MenuItem
      { menuItem        = menuItem
      , menuItemSubmenu = NoSubresource
      }
instance ( HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
      => CreateMenuItem ( MenuItem submenu Description ) ( MenuItem submenu Object )
      where
  createMenuItem attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
    menuItem <- newMenuItem menuItemDescription
    submenu <- GTK.menuNew
    submenuItems <-
      constraints @CreateMenuItem
        ( createMenuItem ( GTK.menuShellAppend submenu ) )
        submenuDescription
    GTK.menuItemSetSubmenu menuItem ( Just submenu )
    attachToParent menuItem
    pure
      MenuItem 
      { menuItem        = menuItem
      , menuItemSubmenu = submenuItems
      }
instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
  createMenuItem attachToParent ( SeparatorDescription { .. } ) = do
    separator <- GTK.separatorMenuItemNew
    unless ( null separatorClasses ) do
      widgetAddClasses separator separatorClasses
    sep <- liftIO ( GTK.unsafeCastTo GTK.MenuItem separator )
    attachToParent sep
    pure ( Separator { separatorItem = sep } )

newMenuBar :: MonadIO m => m ( GTK.MenuBar, Menu Object )
newMenuBar = do
  menuBar <- GTK.menuBarNew
  menu <-
    constraints @CreateMenuItem
      ( createMenuItem ( GTK.menuShellAppend menuBar ) )
      menuDescription
  pure ( menuBar, menu )

--------------------------------------------------------------------------------
-- Creating the menu bar from its declarative specification.

-- | Add the menu bar to the given box (title bar box).
createMenuBar :: Colours -> GTK.Window -> GTK.Box -> IO ( Menu Object )
createMenuBar colours window titleBar = do
  ( menuBar, menu ) <- newMenuBar
  widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
  GTK.boxPackStart titleBar menuBar False False 0

  -- TODO: this is a bit of a workaround to add hover highlight to top-level menu items.
  -- Activating a menu somehow sets the "hover" setting,
  -- so instead we use the "selected" setting for actual hover highlighting.
  topLevelMenuItems <- GTK.containerGetChildren menuBar
  for_ topLevelMenuItems \ topLevelMenuItem -> do
    void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
      flags <- GTK.widgetGetStateFlags topLevelMenuItem
      GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
      pure False
    void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
      flags <- GTK.widgetGetStateFlags topLevelMenuItem
      GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
      pure False

  windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0
  widgetAddClasses windowIcons [ "windowIcon" ]
  GTK.boxPackEnd titleBar windowIcons False False 0

  minimiseButton   <- GTK.buttonNew
  fullscreenButton <- GTK.buttonNew
  closeButton      <- GTK.buttonNew

  GTK.boxPackStart windowIcons   minimiseButton True True 0
  GTK.boxPackStart windowIcons fullscreenButton True True 0
  GTK.boxPackStart windowIcons      closeButton True True 0

  minimiseArea   <- GTK.drawingAreaNew
  fullscreenArea <- GTK.drawingAreaNew
  closeArea      <- GTK.drawingAreaNew

  GTK.containerAdd   minimiseButton   minimiseArea
  GTK.containerAdd fullscreenButton fullscreenArea
  GTK.containerAdd      closeButton      closeArea

  void $ GTK.onWidgetDraw minimiseArea
    $ Cairo.renderWithContext
      ( drawMinimise colours )

  void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do
    Just gdkWindow <- GTK.widgetGetWindow window
    windowState <- GDK.windowGetState gdkWindow
    if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState
    then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext
    else Cairo.renderWithContext ( drawMaximise    colours ) cairoContext

  void $ GTK.onWidgetDraw closeArea
    $ Cairo.renderWithContext
      ( drawClose colours )

  for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do
    widgetAddClass button "windowIcon"

  widgetAddClass closeButton "closeWindowIcon"

  ---------------------------------------------------------
  -- Actions

  _ <- GTK.onButtonClicked         closeButton    GTK.mainQuit
  _ <- GTK.onButtonClicked         minimiseButton ( GTK.windowIconify window )
  _ <- GTK.onButtonClicked         fullscreenButton do
    Just gdkWindow <- GTK.widgetGetWindow window
    windowState <- GDK.windowGetState gdkWindow
    if GDK.WindowStateFullscreen `elem` windowState
    then   GTK.windowUnfullscreen window
    else
      if GDK.WindowStateMaximized `elem` windowState
      then GTK.windowUnmaximize   window
      else GTK.windowMaximize     window

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

  pure menu