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

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

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

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

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

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

-- text
import Data.Text
  ( Text )

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

-- MetaBrush
import MetaBrush.Render.Util
  ( 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 )