add MenuBar

.gitignore

@@ -1,5 +1,9 @@
 dist-newstyle/
+cabal.project.local
+
 assets/*.svg
 assets/*/
+
 *.txt
-cabal.project.local
+*.md
+*.html

MetaBrush.cabal

@@ -3,11 +3,13 @@ name:           MetaBrush
 version:        0.1.0.0
 synopsis:       GUI for brush calligraphy.
 category:       Calligraphy, Font, Geometry, Graphics, GUI
-license:        BSD-3-Clause
+license:        NONE
 homepage:       https://gitlab.com/sheaf/MetaBrush
 build-type:     Simple
+data-dir:
+  assets
 data-files:
-  assets/theme.css
+  theme.css
 description:
 
   MetaBrush is a GUI for brush calligraphy based on Bézier curves.
@@ -39,6 +41,7 @@ common common
         -fwarn-incomplete-patterns
         -fwarn-incomplete-uni-patterns
         -fwarn-missing-deriving-strategies
+        -fno-warn-unticked-promoted-constructors
 
 library
 
@@ -68,6 +71,9 @@ library
 
 executable MetaBrush
 
+    import:
+        common
+
     hs-source-dirs:
         src/app
       , app
@@ -77,14 +83,17 @@ executable MetaBrush
 
     other-modules:
         MetaBrush.Asset.Brush
+      , MetaBrush.Asset.Colours
       , MetaBrush.Asset.Logo
       , MetaBrush.Asset.Magnifier
       , MetaBrush.Asset.Meta
       , MetaBrush.Asset.TickBox
       , MetaBrush.Asset.WindowIcons
       , MetaBrush.Document
+      , MetaBrush.Event
       , MetaBrush.Render.Util
       , MetaBrush.Stroke
+      , MetaBrush.UI.Menu
       , Paths_MetaBrush
 
     autogen-modules:
@@ -95,8 +104,14 @@ executable MetaBrush
 
     build-depends:
         MetaBrush
+      , directory
+          >= 1.3.4.0 && < 1.4
+      , generic-lens
+          >= 1.2.0.1 && < 2.0
       , gi-gdk
           >= 3.0.22 && < 3.1
+      , gi-gio
+          >= 2.0.27 && < 2.1
       , gi-glib
           >= 2.0.23 && < 2.1
       , gi-gtk

app/Main.hs

@@ -1,7 +1,22 @@
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TypeApplications  #-}
+
 module Main
   ( main )
   where
 
+-- base
+import Data.Int
+  ( Int32 )
+import System.Exit
+  ( exitSuccess )
+
+-- directory
+import qualified System.Directory as Directory
+  ( canonicalizePath )
+
 -- gi-cairo-connector
 import qualified GI.Cairo.Render.Connector as Cairo
   ( renderWithContext )
@@ -12,8 +27,22 @@ import qualified GI.Gdk as GDK
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- text
+import qualified Data.Text as Text
+  ( pack )
+
 -- MetaBrush
-import Paths_MetaBrush
+import MetaBrush.Asset.Colours
+  ( ColourRecord(..), colours )
+import MetaBrush.Asset.Logo
+  ( drawLogo )
+import MetaBrush.Event
+  ( handleKeyboardPressEvent, handleKeyboardReleaseEvent )
+import MetaBrush.Render.Util
+  ( widgetAddClass, widgetAddClasses )
+import MetaBrush.UI.Menu
+  ( newMenuBar )
+import qualified Paths_MetaBrush as Cabal
   ( getDataFileName )
 
 --------------------------------------------------------------------------------
@@ -27,7 +56,7 @@ main = do
   _ <- GTK.init Nothing
   Just screen <- GDK.screenGetDefault
 
-  themePath <- getDataFileName "theme.css"
+  themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
   cssProvider <- GTK.cssProviderNew
   GTK.cssProviderLoadFromPath cssProvider themePath
   GTK.styleContextAddProviderForScreen screen cssProvider 1000
@@ -36,13 +65,13 @@ main = do
   windowWidgetPath <- GTK.widgetGetPath window
   widgetAddClass window "window"
   GTK.setWindowResizable window True
-  GTK.setWindowDecorated window False
+  GTK.setWindowDecorated window True
   GTK.setWindowTitle window "MetaBrush"
   GTK.windowSetDefaultSize window 800 600
 
   let
     baseMinWidth, baseMinHeight :: Int32
-    baseMinWidth  = 320
+    baseMinWidth  = 480
     baseMinHeight = 240
 
   windowGeometry <- GDK.newZeroGeometry
@@ -52,14 +81,16 @@ main = do
     ( Just windowGeometry )
     [ GDK.WindowHintsMinSize ]
 
+  Colours { .. } <- colours windowWidgetPath
+
   ---------------------------------------------------------
   -- Create base UI elements
 
   baseOverlay <- GTK.overlayNew
-  GT.setContainerChild window baseOverlay
+  GTK.setContainerChild window baseOverlay
 
   uiGrid <- GTK.gridNew
-  GTK.overlaySetChild baseOverlay uiGrid
+  GTK.setContainerChild baseOverlay uiGrid
 
   logo      <- GTK.boxNew GTK.OrientationVertical   0
   titleBar  <- GTK.boxNew GTK.OrientationHorizontal 0
@@ -77,15 +108,124 @@ main = do
   GTK.gridAttach uiGrid panelGrid 3 2 1 2
   GTK.gridAttach uiGrid infoBar   2 3 1 1
 
-  --------------------------------------
+  ---------------------------------------------------------
+  -- Background
+
+  widgetAddClass uiGrid "bg"
+
+  ---------------------------------------------------------
+  -- Logo
+
+  widgetAddClass logo "logo"
+
+  logoArea <- GTK.drawingAreaNew
+  GTK.boxPackStart logo logoArea True True 0
+
+  _ <- GTK.onWidgetDraw logoArea
+    $ Cairo.renderWithContext
+      ( drawLogo logo_base logo_highlight logo_base ) 
+
+  ---------------------------------------------------------
+  -- Title bar
+
+  widgetAddClass titleBar "titleBar"
+
+  ( menuBar, _menu ) <- newMenuBar
+  widgetAddClasses menuBar [ "text", "plain" ]
+
+  GTK.boxPackStart titleBar menuBar False False 0
+
+  title <- GTK.labelNew ( Just "● New Document – MetaBrush" )
+  widgetAddClasses title [ "text", "title", "plain" ]
+  GTK.labelSetJustify title GTK.JustificationCenter
+  GTK.widgetSetHalign title GTK.AlignCenter
+  GTK.boxPackStart titleBar title True True 0
+
+  ---------------------------------------------------------
+  -- Tool bar
+
+  widgetAddClass toolBar "toolBar"
+
+  ---------------------------------------------------------
+  -- File bar
+
+  widgetAddClass fileBar "fileBar"
+
+  ---------------------------------------------------------
+  -- Main viewport
+
+  widgetAddClass mainView "viewport_bg"
+  
+  rvRulerCorner <- GTK.revealerNew
+  rvLeftRuler   <- GTK.revealerNew
+  rvTopRuler    <- GTK.revealerNew
+  viewport      <- GTK.drawingAreaNew
+
+  GTK.gridAttach mainView rvRulerCorner 0 0 1 1
+  GTK.gridAttach mainView rvLeftRuler   0 1 1 1
+  GTK.gridAttach mainView rvTopRuler    1 0 1 1
+  GTK.gridAttach mainView viewport      1 1 1 1
+
+  rulerCorner <- GTK.boxNew GTK.OrientationVertical   0
+  leftRuler   <- GTK.boxNew GTK.OrientationVertical   0
+  topRuler    <- GTK.boxNew GTK.OrientationHorizontal 0
+
+  GTK.containerAdd rvRulerCorner rulerCorner
+  GTK.containerAdd rvLeftRuler   leftRuler
+  GTK.containerAdd rvTopRuler    topRuler
+
+  widgetAddClass rulerCorner "ruler"
+  widgetAddClass leftRuler   "ruler"
+  widgetAddClass topRuler    "ruler"
+
+  GTK.revealerSetRevealChild rvRulerCorner True
+  GTK.revealerSetRevealChild rvLeftRuler   True
+  GTK.revealerSetRevealChild rvTopRuler    True
+
+  GTK.revealerSetTransitionType rvRulerCorner GTK.RevealerTransitionTypeSlideLeft
+  GTK.revealerSetTransitionType rvLeftRuler   GTK.RevealerTransitionTypeSlideLeft
+  GTK.revealerSetTransitionType rvTopRuler    GTK.RevealerTransitionTypeSlideUp
+
+  rulerCornerArea <- GTK.drawingAreaNew
+  GTK.boxPackStart rulerCorner rulerCornerArea True True 0
+
+  leftRulerArea   <- GTK.drawingAreaNew
+  GTK.boxPackStart leftRuler   leftRulerArea   True True 0
+  
+  topRulerArea    <- GTK.drawingAreaNew
+  GTK.boxPackStart topRuler    topRulerArea    True True 0
+
+  GTK.widgetSetHexpand rulerCorner False
+  GTK.widgetSetVexpand rulerCorner False
+  GTK.widgetSetHexpand leftRuler   False
+  GTK.widgetSetVexpand leftRuler   True
+  GTK.widgetSetHexpand topRuler    True
+  GTK.widgetSetVexpand topRuler    False
+  GTK.widgetSetHexpand viewport    True
+  GTK.widgetSetVexpand viewport    True
+
+  ---------------------------------------------------------
+  -- Panels
+
+  widgetAddClass panelGrid "panels"
+
+  ---------------------------------------------------------
+  -- Info bar
+
+  widgetAddClass infoBar "infoBar"
+
+  ---------------------------------------------------------
   -- Actions
 
-  GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask]
+  ---------------------------------------------------------
-  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   )
+  -- GTK main loop
-  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent )
 
-  _ <- GTK.onWidgetDestroy          window ( quitAll actionTVar )
+  GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask]
-  _ <- GTK.onButtonClicked  quitIconButton ( quitAll actionTVar )
+  _ <- GTK.onWidgetKeyPressEvent   window handleKeyboardPressEvent  
+  _ <- GTK.onWidgetKeyReleaseEvent window handleKeyboardReleaseEvent
+  _ <- GTK.onWidgetDestroy         window GTK.mainQuit
 
   GTK.widgetShowAll window
   GTK.main
+
+  exitSuccess

assets/theme.css

@@ -2,87 +2,182 @@
   all: unset;
 }
 
+.window {
+  -GtkWidget-window-dragging: true;
+}
+
 /* Window background colour */
 .bg {
-  color: #292828
+  background-color: rgb(41, 40, 40);
 }
 
 /* Viewport background colour */
 .viewport_bg {
-  color: #ecdfd2
+  background-color: rgb(236, 223, 210);
 }
 
 /* Basic text colour */
 .plain {
-  color: #d4be98
+  color: rgb(212, 190, 152);
 }
 
 /* Basic text font */
 .text {
-  font-family: "Lato", "Roboto", "Helvetica", sans-serif
+  font-family: "Lato", "Roboto", "Helvetica", sans-serif;
 }
 
 /* Monospace font */
 .monospace {
-  font-family: "Fira Code", "Inconsolata", "Courier", "Courier New", monospace
+  font-family: "Fira Code", "Inconsolata", "Courier", "Courier New", monospace;
 }
 
 /* High-constrast text colour */
 .contrast {
-  color: #f7f4ef
+  color: rgb(247, 244, 239);
 }
 
 /* Active (highlighting) colour */
 .highlight {
-  color: #eadfcc
+  color: #eadfcc;
+}
+
+/* Logo area */
+.logo {
+  padding-left: 2px;
+  padding-top: 0px;
 }
 
 /* Logo base colour */
 .logo_base {
-  color: #f7f4ef
+  color: rgb(234, 223, 204);
 }
 
 /* Logo highlight colour */
 .logo_highlight {
-  color: #f5881bff
+  color: rgb(245, 136, 27);
 }
 
 /* Viewport scrollbar colour */
 .viewport_scrollbar {
-  color: #28272793
+  color: rgba(40, 39, 39, 0.66);
 }
 
 /* Tab scrollbar colour */
 .tab_scrollbar {
-  color: #302d2693
+  color: rgba(48, 45, 38, 0.66);
 }
 
-/* Ruler colour */
+/* Rulers */
 .ruler {
-  color: #ede29a
+  background-color: rgb(237, 226, 154);
+  min-width:  16px;
+  min-height: 16px;
+  background-size: 16px 16px;  
 }
 
 /* Magnifying glass base colour */
 .magnifier {
-  color: #ecdfd2
+  color: rgb(236, 223, 210);
 }
 
 /* Magnifying glass glass colour */
 .glass {
-  color: #9ce7ff72
+  color: rgba(156, 231, 255, 0.5);
 }
 
 /* Cursor colour */
 .cursor {
-  color: #f7f4ef
+  color: rgb(247, 244, 239);
 }
 
 /* Bézier path point colour */
 .point {
-  color: #8183f1
+  color: rgb(129, 131, 241);
 }
 
 /* Bézier control point colour */
 .control {
-  color: #a1dde9
+  color: rgb(161, 221, 233);
+}
+
+/* Title bar */
+.titleBar {
+  min-height: 20px;
+  font-size: 11px;
+}
+
+/* Title bar */
+.titleBar > * :hover {
+  background-color: rgb(72,70,61);
+}
+
+.menuItem {
+  background-color: rgb(41, 40, 40);
+  margin-left: 2px;
+  padding-left: 8px;
+  padding-right: 8px;
+  margin-left: 0px;
+  border-top: 2px solid rgb(41, 40, 40);
+}
+
+.menuItem:hover {
+  border-top: 2px solid rgb(234,223,204);
+  background-color: rgb(72,70,61);
+}
+
+/* Menu drop shadow */
+.menuItem > * > * {
+  box-shadow: 2px 2px 4px 0px rgba(28,25,25,0.5);
+  border: 1px solid rgb(28,25,25);
+  border-top: 1px solid rgb(72,70,61);
+}
+
+.submenuItem {
+  padding-top: 4px;
+  padding-bottom: 4px;
+  padding-left: 8px;
+  padding-right: 8px;
+  background-color: rgb(41, 40, 40);
+  border-left: 2px solid rgb(41, 40, 40);
+}
+
+.submenuSeparator {
+  background-color: rgb(28,25,25);
+  padding-top: 1px;
+}
+
+.submenuItem:hover {
+  border-left: 2px solid rgb(234,223,204);
+}
+
+.title {
+  font-size: 12px;
+}
+
+/* Tool bar */
+.toolBar {
+  min-width: 60px;
+}
+
+/* File bar */
+.fileBar {
+  min-height: 25px;
+  font-size:  10px;
+}
+
+/* Panels */
+.panels {
+  min-width: 160px;
+  font-size: 12px;
+}
+
+/* Info bar */
+.infoBar {
+  min-height: 40px;
+  font-size:  10px;
+  -GtkWidget-window-dragging: true;
+}
+
+.submenuItem:disabled {
+  color: rgb(149,149,149);
 }

cabal.project

@@ -1,3 +1,5 @@
+packages: .
+
 constraints:
     acts -finitary
   , haskell-gi >= 0.24

img/MetaBrush_ui_mockup.svg

@@ -35,6 +35,7 @@
     </linearGradient>
   </defs>
   <sodipodi:namedview
+     inkscape:lockguides="false"
      inkscape:document-rotation="0"
      fit-margin-bottom="0"
      fit-margin-right="0"
@@ -46,7 +47,7 @@
      objecttolerance="1"
      inkscape:window-maximized="1"
      inkscape:window-y="115"
-     inkscape:window-x="2552"
+     inkscape:window-x="-8"
      inkscape:window-height="1377"
      inkscape:window-width="2560"
      inkscape:guide-bbox="true"
@@ -54,9 +55,9 @@
      showgrid="false"
      inkscape:current-layer="layer1"
      inkscape:document-units="mm"
-     inkscape:cy="849.74823"
+     inkscape:cy="421.74309"
-     inkscape:cx="768.55909"
+     inkscape:cx="750.76483"
-     inkscape:zoom="16"
+     inkscape:zoom="1"
      inkscape:pageshadow="2"
      inkscape:pageopacity="0.0"
      borderopacity="1.0"
@@ -5524,5 +5525,17 @@
        d="M 745.71289 847.36133 C 742.67337 847.25537 739.67408 848.77547 738.02148 851.58008 C 735.81903 855.31789 737.00422 860.22415 740.31836 862.83789 C 740.09434 863.25648 739.39877 864.56411 738.68359 864.1582 C 738.41428 864.00535 737.96229 864.29658 737.67188 864.80859 L 733.96289 871.19141 C 733.67359 871.70474 733.85258 872.35441 734.36328 872.64453 L 736.30078 873.74414 C 736.81328 874.03475 737.46322 873.85271 737.75391 873.3418 L 741.44922 866.78125 C 741.7402 866.26988 741.6576 865.91122 741.39258 865.75195 C 740.70108 865.33646 741.49263 864.19842 741.77148 863.70898 C 745.70555 865.47578 750.55309 864.08509 752.79297 860.2832 C 755.19674 856.20376 753.8392 850.94869 749.75977 848.54492 C 748.48506 847.79371 747.09449 847.40949 745.71289 847.36133 z M 745.40234 848.82227 A 7.1095623 7.1095623 0 0 1 752.29102 854.15234 A 7.1095623 7.1095623 0 0 1 747.18555 862.81445 A 7.1095623 7.1095623 0 0 1 738.52344 857.71094 A 7.1095623 7.1095623 0 0 1 743.62695 849.04688 A 7.1095623 7.1095623 0 0 1 745.40234 848.82227 z "
        style="fill:#ecdfd2;fill-opacity:1;stroke-width:0.0701341"
        id="path2" />
+    <path
+       sodipodi:nodetypes="ccc"
+       id="path4212"
+       d="m -137.37613,-191.90754 -0.92604,0.66146 0.95911,0.62838"
+       style="fill:none;stroke:#000000;stroke-width:0.264583px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" />
+    <path
+       inkscape:transform-center-y="0.080851403"
+       inkscape:transform-center-x="0.064642359"
+       style="display:inline;fill:none;stroke:#000000;stroke-width:0.264583px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+       d="m -135.45938,-192.29552 -0.66146,-0.92604 -0.62838,0.95911"
+       id="path4212-4"
+       sodipodi:nodetypes="ccc" />
   </g>
 </svg>

src/app/MetaBrush/Asset/Brush.hs

@@ -15,11 +15,11 @@ import MetaBrush.Render.Util
 --------------------------------------------------------------------------------
 
 -- | Calligraphy brush icon. Width = 29, height = 29.
-drawBrush :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render ()
+drawBrush :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool
 drawBrush brushColour bodyColour loopColour = do
 
   -- Loop
-  Cairo.setLineWidth 0.2
+  Cairo.setLineWidth 1
   withRGBA loopColour Cairo.setSourceRGBA
   Cairo.newPath
   Cairo.moveTo  23.144531 6.199219
@@ -58,3 +58,5 @@ drawBrush brushColour bodyColour loopColour = do
   Cairo.curveTo 10.339844 19.335938 10.339844 19.335938 10.339844 19.335938
   Cairo.closePath
   Cairo.fillPreserve
+
+  pure True

src/app/MetaBrush/Asset/Colours.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE DeriveFoldable     #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
+
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
+module MetaBrush.Asset.Colours
+  ( ColourRecord(..), ColourType
+  , colours
+  )
+  where
+
+-- base
+import Data.Traversable
+  ( for )
+
+-- gi-gdk
+import qualified GI.Gdk as GDK
+
+-- gi-gtk
+import qualified GI.Gtk as GTK
+
+-- text
+import Data.Text
+  ( Text )
+
+--------------------------------------------------------------------------------
+
+data ColourRecord a
+  = Colours
+    { bg                 :: !a
+    , viewport_bg        :: !a
+    , plain              :: !a
+    , contrast           :: !a
+    , highlight          :: !a
+    , logo_base          :: !a
+    , logo_highlight     :: !a
+    , viewport_scrollbar :: !a
+    , tab_scrollbar      :: !a
+    , ruler              :: !a
+    , magnifier          :: !a
+    , glass              :: !a
+    , cursor             :: !a
+    , point              :: !a
+    , control            :: !a
+    }
+  deriving stock ( Show, Functor, Foldable, Traversable )
+
+data ColourType
+  = Color
+  | BackgroundColor
+  deriving stock Show
+
+data ColourName
+  = ColourName
+    { colourName :: !Text
+    , colourType :: !ColourType
+    , stateFlags :: ![ GTK.StateFlags ]
+    }
+  deriving stock Show
+
+colourNames :: ColourRecord ColourName
+colourNames = Colours
+    { bg                 = ColourName "bg"                 BackgroundColor [ GTK.StateFlagsNormal ]
+    , viewport_bg        = ColourName "viewport_bg"        BackgroundColor [ GTK.StateFlagsNormal ]
+    , plain              = ColourName "plain"              Color           [ GTK.StateFlagsNormal ]
+    , contrast           = ColourName "contrast"           Color           [ GTK.StateFlagsNormal ]
+    , highlight          = ColourName "highlight"          Color           [ GTK.StateFlagsNormal ]
+    , logo_base          = ColourName "logo_base"          Color           [ GTK.StateFlagsNormal ]
+    , logo_highlight     = ColourName "logo_highlight"     Color           [ GTK.StateFlagsNormal ]
+    , viewport_scrollbar = ColourName "viewport_scrollbar" Color           [ GTK.StateFlagsNormal ]
+    , tab_scrollbar      = ColourName "tab_scrollbar"      Color           [ GTK.StateFlagsNormal ]
+    , ruler              = ColourName "ruler"              BackgroundColor [ GTK.StateFlagsNormal ]
+    , magnifier          = ColourName "magnifier"          Color           [ GTK.StateFlagsNormal ]
+    , glass              = ColourName "glass"              Color           [ GTK.StateFlagsNormal ]
+    , cursor             = ColourName "cursor"             Color           [ GTK.StateFlagsNormal ]
+    , point              = ColourName "point"              Color           [ GTK.StateFlagsNormal ]
+    , control            = ColourName "control"            Color           [ GTK.StateFlagsNormal ]
+    }
+
+type Colours = ColourRecord GDK.RGBA
+
+colours :: GTK.WidgetPath -> IO Colours
+colours windowWidgetPath = for colourNames \ ( ColourName { .. } ) -> do
+  style <- GTK.styleContextNew
+  GTK.styleContextSetPath  style windowWidgetPath
+  GTK.styleContextAddClass style colourName
+  case colourType of
+    BackgroundColor -> GTK.styleContextGetBackgroundColor style stateFlags
+    Color           -> GTK.styleContextGetColor           style stateFlags

src/app/MetaBrush/Asset/Logo.hs

@@ -15,11 +15,11 @@ import MetaBrush.Render.Util
 --------------------------------------------------------------------------------
 
 -- | MetaBrush logo. Width = 29, height = 29.
-drawLogo :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render ()
+drawLogo :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool
 drawLogo brushColour bodyColour loopColour = do
 
   -- Loop
-  Cairo.setLineWidth 0.2
+  Cairo.setLineWidth 1
   withRGBA loopColour Cairo.setSourceRGBA
   Cairo.newPath
   Cairo.moveTo  17.480469 7.847656
@@ -79,3 +79,5 @@ drawLogo brushColour bodyColour loopColour = do
   Cairo.curveTo 7.199219 18.394531 7.199219 18.394531 7.199219 18.394531
   Cairo.closePath
   Cairo.fillPreserve
+
+  pure True

src/app/MetaBrush/Asset/Magnifier.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE NegativeLiterals #-}
+
 module MetaBrush.Asset.Magnifier
   ( drawMagnifier )
   where
@@ -15,7 +17,7 @@ import MetaBrush.Render.Util
 --------------------------------------------------------------------------------
 
 -- | Magnifying glass icon. Width = 19, height = 25.
-drawMagnifier :: GDK.RGBA -> GDK.RGBA -> Cairo.Render ()
+drawMagnifier :: GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool
 drawMagnifier magnifierColour glassColour = do
 
   -- Magnifying glass.
@@ -58,3 +60,4 @@ drawMagnifier magnifierColour glassColour = do
   Cairo.setFillRule Cairo.FillRuleWinding
   Cairo.fillPreserve
 
+  pure True

src/app/MetaBrush/Asset/Meta.hs

@@ -15,7 +15,7 @@ import MetaBrush.Render.Util
 --------------------------------------------------------------------------------
 
 -- | MetaParameter icon. Width = 29, height = 29.
-drawMeta :: GDK.RGBA -> Cairo.Render ()
+drawMeta :: GDK.RGBA -> Cairo.Render Bool
 drawMeta metaColour = do
   withRGBA metaColour Cairo.setSourceRGBA
   Cairo.newPath
@@ -40,3 +40,5 @@ drawMeta metaColour = do
   Cairo.curveTo 16.140625 11.976563 16.140625 11.976563 16.140625 11.976563
   Cairo.closePath
   Cairo.fillPreserve
+
+  pure True

src/app/MetaBrush/Asset/TickBox.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE NegativeLiterals #-}
+
 module MetaBrush.Asset.TickBox
   ( drawBox, drawTickedBox )
   where
@@ -15,9 +17,9 @@ import MetaBrush.Render.Util
 --------------------------------------------------------------------------------
 
 -- | Non-ticked box. Width = 14, height = 12.
-drawBox :: GDK.RGBA -> Cairo.Render ()
+drawBox :: GDK.RGBA -> Cairo.Render Bool
 drawBox boxColour = do
-  withRGBA loopColour Cairo.setSourceRGBA
+  withRGBA boxColour Cairo.setSourceRGBA
 
   Cairo.newPath
   Cairo.moveTo   2.015625  0.769531
@@ -43,8 +45,11 @@ drawBox boxColour = do
   Cairo.setFillRule Cairo.FillRuleWinding
   Cairo.fillPreserve
 
+  pure True
+
+
 -- | Ticked box. Width = 14, height = 12.
-drawTickedBox :: GDK.RGBA -> GDK.RGBA -> Cairo.Render ()
+drawTickedBox :: GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool
 drawTickedBox boxColour tickColour = do
 
   -- Box
@@ -94,3 +99,5 @@ drawTickedBox boxColour tickColour = do
   Cairo.curveTo 13.835938 0.0351563 13.632813 -0.0195313 13.421875 0.0078125
   Cairo.closePath
   Cairo.fillPreserve
+
+  pure True

src/app/MetaBrush/Document.hs

@@ -2,6 +2,7 @@ module MetaBrush.Document where
 
 --------------------------------------------------------------------------------
 
+{-
 data Document
   = Document
     { displayName    :: !Text
@@ -10,3 +11,4 @@ data Document
     , viewport       :: !AABB
     , strokes        :: !(Set Stroke)
     }
+-}

src/app/MetaBrush/Event.hs

@@ -0,0 +1,23 @@
+module MetaBrush.Event
+  ( handleKeyboardPressEvent
+  , handleKeyboardReleaseEvent
+  )
+  where
+
+-- gi-gdk
+import qualified GI.Gdk as GDK
+
+-- gi-gtk
+import qualified GI.Gtk as GTK
+
+--------------------------------------------------------------------------------
+
+handleKeyboardPressEvent, handleKeyboardReleaseEvent :: GDK.EventKey -> IO Bool
+handleKeyboardPressEvent evt = do
+  keyCode <- GDK.getEventKeyKeyval evt
+  case keyCode of
+    -- escape
+    0xff1b -> GTK.mainQuit
+    _      -> pure ()
+  pure True
+handleKeyboardReleaseEvent _ = pure True

src/app/MetaBrush/Render/Util.hs

@@ -1,24 +1,31 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE MonoLocalBinds #-}
+
 module MetaBrush.Render.Util
   ( withRGBA, showRGBA
-  , widgetAddClasses, widgetAddClass )
+  , widgetAddClasses, widgetAddClass
+  )
   where
 
 -- base
+import Data.Foldable
+  ( for_ )
 import GHC.Stack
   ( HasCallStack )
 
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
+-- gi-gtk
+import qualified GI.Gtk as GTK
+
 -- text
 import Data.Text
   ( Text )
-import qualified Data.Text as Text
-  ( pack )
 
 -- transformers
 import Control.Monad.IO.Class
-  ( MonadIO(liftIO) )
+  ( MonadIO )
 
 --------------------------------------------------------------------------------
 

src/app/MetaBrush/Stroke.hs

@@ -2,10 +2,13 @@ module MetaBrush.Stroke where
 
 --------------------------------------------------------------------------------
 
+{-
 data StrokePoint
   = StrokePoint
     { center :: Point2D Double
     , 
 
 newtype Stroke =
-  Stroke { strokePoints :: Seq ( 
+  Stroke { strokePoints :: Seq ( 
+
+-}

src/app/MetaBrush/UI/Menu.hs

@@ -0,0 +1,252 @@
+{-# 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 )
+  , 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
+  , 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 )

src/lib/Math/Bezier/Cubic.hs

@@ -1,12 +1,15 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE DeriveFunctor         #-}
-{-# LANGUAGE DeriveFoldable      #-}
+{-# LANGUAGE DeriveFoldable        #-}
-{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE DeriveTraversable   #-}
+{-# LANGUAGE DeriveTraversable     #-}
-{-# LANGUAGE DerivingStrategies  #-}
+{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 module Math.Bezier.Cubic
   ( Bezier(..)
@@ -20,9 +23,7 @@ import GHC.Generics
 
 -- acts
 import Data.Act
-  ( Act
+  ( Torsor
-    ( (•) )
-  , Torsor
     ( (-->) )
   )
 
@@ -56,8 +57,8 @@ instance Module r p => Module r ( Bezier p ) where
 bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
 bezier ( Bezier { .. } ) t =
   lerp @v t
-    ( Quadratic.bezier ( Quadratic.Bezier p0 p1 p2 ) t )
+    ( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t )
-    ( Quadratic.bezier ( Quadratic.Bezier p1 p2 p3 ) t )
+    ( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t )
 
 -- | Derivative of cubic Bézier curve.
 bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v

src/lib/Math/Bezier/Quadratic.hs

@@ -1,12 +1,15 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE DeriveFunctor         #-}
-{-# LANGUAGE DeriveFoldable      #-}
+{-# LANGUAGE DeriveFoldable        #-}
-{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE DeriveTraversable   #-}
+{-# LANGUAGE DeriveTraversable     #-}
-{-# LANGUAGE DerivingStrategies  #-}
+{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 module Math.Bezier.Quadratic
   ( Bezier(..)
@@ -20,9 +23,7 @@ import GHC.Generics
 
 -- acts
 import Data.Act
-  ( Act
+  ( Torsor
-    ( (•) )
-  , Torsor
     ( (-->) )
   )
 

src/lib/Math/Module.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE AllowAmbiguousTypes    #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
 
 module Math.Module
   ( Module(..)
@@ -10,7 +11,9 @@ module Math.Module
 
 -- acts
 import Data.Act
-  ( Torsor
+  ( Act
+    ( (•) )
+  , Torsor
     ( (-->) )
   )
 
@@ -19,7 +22,7 @@ import Data.Act
 infixl 6 ^+^, ^-^
 infix  8 ^*, *^
 
-class Num r => Module r m where
+class Num r => Module r m | m -> r where
 
   {-# MINIMAL (^+^), ( (^*) | (*^) ) #-}
 
@@ -32,10 +35,5 @@ class Num r => Module r m where
   (^*) = flip (*^)
   m ^-^ n = m ^+^ (-1) *^ n
 
-instance Num a => Module a a where
+lerp :: forall v r p. ( Module r v, Torsor v p ) => r -> p -> p -> p
-  (^+^) = (+)
+lerp t p0 p1 = ( t *^ ( p0 --> p1 :: v ) ) • p0
-  (*^) = (*)
-  (^*) = (*)
-
-lerp :: forall v r p. ( Module r v , Torsor v p ) => r -> p -> p -> p
-lerp t p0 p1 = ( t *^ ( p0 --> p1 ) ) • p0

src/lib/Math/Vector2D.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 
@@ -11,6 +12,8 @@ module Math.Vector2D
   where
 
 -- base
+import Data.Monoid
+  ( Sum(..) )
 import GHC.Generics
   ( Generic )
 
@@ -19,13 +22,17 @@ import Data.Act
   ( Act, Torsor )
 
 -- generic-data
-import Data.Generic
+import Generic.Data
   ( GenericProduct(..) )
 
 -- groups
 import Data.Group
   ( Group ( invert ) )
 
+-- groups-generic
+import Data.Group.Generics
+  ( )
+
 -- MetaBrush
 import Math.Module
   ( Module (..) )
@@ -38,10 +45,9 @@ data Point2D a = Point2D !a !a
     via Vector2D a
 
 newtype Vector2D a = Vector2D { tip :: Point2D a }
-  deriving stock Show
+  deriving stock ( Show, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
     via GenericProduct ( Point2D ( Sum a ) )
-  deriving newtype ( Functor, Foldable, Traversable )
 
 instance Num a => Module a ( Vector2D a ) where
   (^+^) = (<>)