diff --git a/app/Main.hs b/app/Main.hs index d7ab520..58486f2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -91,9 +92,7 @@ import MetaBrush.UI.FileBar import MetaBrush.UI.InfoBar ( InfoBar(..), createInfoBar, updateInfoBar ) import MetaBrush.UI.Menu - ( createMenuBar ---, MenuItem(..), Menu(..), FileMenu(..), EditMenu(..), ViewMenu(..) - ) + ( createMenuBar ) import MetaBrush.UI.Panels ( createPanelBar ) import MetaBrush.UI.ToolBar @@ -348,30 +347,30 @@ main = do infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours - --------------------------------------------------------- - -- File bar - - fileBar@( FileBar { fileBarBox } ) <- - createFileBar - colours - variables - window titleBar title viewport infoBar + rec + + --------------------------------------------------------- + -- File bar + + fileBar@( FileBar { fileBarBox } ) <- + createFileBar + colours + variables + window titleBar title viewport infoBar menu + + ------------ + -- Menu bar + + let + uiElements :: UIElements + uiElements = UIElements { menu, fileBar, .. } + + menu <- createMenuBar uiElements variables colours GTK.boxPackStart mainView fileBarBox False False 0 GTK.boxPackStart mainView viewportGrid True True 0 GTK.boxPackStart mainView infoBarArea False False 0 - let - uiElements :: UIElements - uiElements = UIElements {..} - - ------------ - -- Menu bar - - _menu <- createMenuBar uiElements variables colours - - --GTK.widgetSetSensitive ( menuItem $ close $ menuItemSubmenu $ file menu ) False - --------------------------------------------------------- -- Panels diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 5547a6b..4cf9386 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -74,6 +74,10 @@ import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM.TVar as STM ( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar ) +-- text +import Data.Text + ( Text ) + -- MetaBrush import Math.Bezier.Stroke ( StrokePoint(..) ) @@ -115,6 +119,8 @@ 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 @@ -490,8 +496,17 @@ data ToggleGuides = ToggleGuides deriving stock Show instance HandleAction ToggleGuides where - handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { showGuidesTVar } ) _ = do - STM.atomically $ STM.modifyTVar' showGuidesTVar not + 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 diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Action.hs-boot new file mode 100644 index 0000000..cfea934 --- /dev/null +++ b/src/app/MetaBrush/Action.hs-boot @@ -0,0 +1,112 @@ +module MetaBrush.Action where + +-- base +import Data.Word + ( Word32 ) + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- MetaBrush +import Math.Vector2D + ( Point2D, Vector2D ) +import {-# SOURCE #-} MetaBrush.Context + ( UIElements, Variables ) +import {-# SOURCE #-} MetaBrush.UI.FileBar + ( TabLocation(..) ) +import MetaBrush.UI.Viewport + ( Ruler(..) ) +import MetaBrush.Unique + ( Unique ) + +-------------------------------------------------------------------------------- + +class HandleAction action where + handleAction :: UIElements -> Variables -> action -> IO () + +instance HandleAction () + +data NewFile = NewFile TabLocation +instance HandleAction NewFile + +data OpenFile = OpenFile TabLocation +instance HandleAction OpenFile + +data OpenFolder = OpenFolder TabLocation +instance HandleAction OpenFolder + +data Save = Save +instance HandleAction Save + +data SaveAs = SaveAs +instance HandleAction SaveAs + +data Close + = CloseActive + | CloseThis + { docToClose :: Unique } +instance HandleAction Close + +data SwitchTo = SwitchTo Unique +instance HandleAction SwitchTo + +data Quit = Quit +instance HandleAction Quit +quitEverything :: GTK.Window -> IO () + +data Undo = Undo +instance HandleAction Undo + +data Redo = Redo +instance HandleAction Redo + +data DiscardChanges = DiscardChanges +instance HandleAction DiscardChanges + +data Cut = Cut +instance HandleAction Cut + +data Copy = Copy +instance HandleAction Copy + +data Paste = Paste +instance HandleAction Paste + +data Duplicate = Duplicate +instance HandleAction Duplicate + +data Delete = Delete +instance HandleAction Delete + +data ToggleGuides = ToggleGuides +instance HandleAction ToggleGuides + +data Confirm = Confirm +instance HandleAction Confirm + +data About = About +instance HandleAction About + +data MouseMove = MouseMove ( Point2D Double ) +instance HandleAction MouseMove + +data ActionOrigin + = ViewportOrigin + | RulerOrigin Ruler +data MouseClickType + = SingleClick + | DoubleClick +data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double ) +instance HandleAction MouseClick + +data MouseRelease = MouseRelease Word32 ( Point2D Double ) +instance HandleAction MouseRelease + +data Scroll = Scroll ( Point2D Double ) ( Vector2D Double ) +instance HandleAction Scroll + +data KeyboardPress = KeyboardPress Word32 +instance HandleAction KeyboardPress + +data KeyboardRelease = KeyboardRelease Word32 +instance HandleAction KeyboardRelease diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index b475183..f5880bd 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -1,12 +1,12 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} module MetaBrush.Context ( UIElements(..), Variables(..) @@ -74,6 +74,8 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar ( FileBar, removeFileTab ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar, updateInfoBar ) +import {-# SOURCE #-} MetaBrush.UI.Menu + ( Menu, ResourceType(Object) ) import MetaBrush.UI.ToolBar ( Tool, Mode ) import MetaBrush.UI.Viewport @@ -93,6 +95,7 @@ data UIElements , fileBar :: !FileBar , viewport :: !Viewport , infoBar :: !InfoBar + , menu :: Menu Object -- needs to be lazy for "recursive do" , colours :: !Colours } diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 1d4da41..6bb34ba 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -50,6 +51,8 @@ import MetaBrush.Document ( Document(..), emptyDocument ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar, updateInfoBar ) +import {-# SOURCE #-} MetaBrush.UI.Menu + ( Menu, ResourceType(Object) ) import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Unique @@ -184,12 +187,12 @@ newFileTab -- Updates the active document when buttons are clicked. createFileBar :: Colours -> Variables - -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar + -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object -> IO FileBar createFileBar colours vars@( Variables { openDocumentsTVar } ) - window titleBar title viewport infoBar + window titleBar title viewport infoBar menu = do -- Create file bar: box containing scrollable tabs, and a "+" button after it. diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index 89451af..11fd76f 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} + module MetaBrush.UI.FileBar ( FileBar(..) , createFileBar, newFileTab, removeFileTab @@ -17,6 +19,8 @@ import MetaBrush.Document ( Document ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar ) +import {-# SOURCE #-} MetaBrush.UI.Menu + ( Menu, ResourceType(Object) ) import MetaBrush.UI.Viewport ( Viewport ) import MetaBrush.Unique @@ -39,7 +43,7 @@ instance Show TabLocation createFileBar :: Colours -> Variables - -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar + -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object -> IO FileBar newFileTab diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index fd22e8f..28275f9 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -60,7 +60,7 @@ import Control.Monad.IO.Class ( MonadIO(liftIO) ) -- MetaBrush -import MetaBrush.Action +import {-# SOURCE #-} MetaBrush.Action import MetaBrush.Context ( UIElements(..), Variables(..) , LR(..), Modifier(..), modifierType @@ -69,7 +69,7 @@ import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Asset.WindowIcons ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) -import MetaBrush.UI.FileBar +import {-# SOURCE #-} MetaBrush.UI.FileBar ( TabLocation(..) ) import MetaBrush.Util ( widgetAddClass, widgetAddClasses ) @@ -159,7 +159,7 @@ data ViewMenu ( rt :: ResourceType ) , viewSep2 :: !( Separator rt ) , transform :: !( MenuItem () NoSubresource rt ) , viewSep3 :: !( Separator rt ) - , guides :: !( MenuItem ToggleGuides NoSubresource rt ) + , toggleGuides :: !( MenuItem ToggleGuides NoSubresource rt ) } deriving stock Generic @@ -219,7 +219,7 @@ viewMenuDescription , viewSep2 = SeparatorDescription [ "submenuSeparator" ] , transform = MenuItemDescription "Transform" [ "submenuItem" ] () Nothing NoSubresource , viewSep3 = SeparatorDescription [ "submenuSeparator" ] - , guides = MenuItemDescription "Guides" [ "submenuItem" ] ToggleGuides ( Just ( GDK.KEY_G, [] ) ) NoSubresource + , toggleGuides = MenuItemDescription "Hide guides" [ "submenuItem" ] ToggleGuides ( Just ( GDK.KEY_G, [] ) ) NoSubresource } helpMenuDescription :: HelpMenu Description @@ -305,7 +305,7 @@ newMenuBar uiElts vars accelGroup = do -- | Add the menu bar to the given box (title bar box). createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object ) -createMenuBar uiElts@( UIElements { titleBar, window } ) vars colours = do +createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do accelGroup <- GTK.accelGroupNew GTK.windowAddAccelGroup window accelGroup ( menuBar, menu ) <- newMenuBar uiElts vars accelGroup diff --git a/src/app/MetaBrush/UI/Menu.hs-boot b/src/app/MetaBrush/UI/Menu.hs-boot new file mode 100644 index 0000000..b633a34 --- /dev/null +++ b/src/app/MetaBrush/UI/Menu.hs-boot @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +module MetaBrush.UI.Menu + ( ResourceType(..), MenuItem + , Menu + , FileMenu, EditMenu, ViewMenu, HelpMenu + , newMenuBar, createMenuBar + ) where + +-- base +import Data.Kind + ( Type ) + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- transformers +import Control.Monad.IO.Class + ( MonadIO ) +import MetaBrush.Asset.Colours + ( Colours ) +import {-# SOURCE #-} MetaBrush.Context + ( UIElements, Variables ) + +-------------------------------------------------------------------------------- + +data ResourceType + = Description + | Object + +data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType ) + +data Menu ( rt :: ResourceType ) +type role Menu nominal + +data FileMenu ( rt :: ResourceType ) +type role FileMenu nominal + +data EditMenu ( rt :: ResourceType ) +type role EditMenu nominal + +data ViewMenu ( rt :: ResourceType ) +type role ViewMenu nominal + +data HelpMenu ( rt :: ResourceType ) +type role HelpMenu nominal + +newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object ) + +createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object ) diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 849c7b2..97aac60 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} module MetaBrush.UI.Viewport ( Viewport(..), createViewport