update file tabs dynamically

MetaBrush.cabal

@@ -109,9 +109,7 @@ executable MetaBrush
       , MetaBrush.Document.Selection
       , MetaBrush.Document.Serialise
       , MetaBrush.Event
-      , MetaBrush.Event.KeyCodes
       , MetaBrush.Render.Document
-      , MetaBrush.Render.Util
       , MetaBrush.Time
       , MetaBrush.UI.Coordinates
       , MetaBrush.UI.FileBar
@@ -121,6 +119,7 @@ executable MetaBrush
       , MetaBrush.UI.ToolBar
       , MetaBrush.UI.Viewport
       , MetaBrush.Unique
+      , MetaBrush.Util
       , Paths_MetaBrush
 
     autogen-modules:

app/Main.hs

@@ -22,10 +22,8 @@ import System.Exit
   ( exitSuccess )
 
 -- containers
-import Data.IntMap.Strict
+import Data.Map.Strict
-  ( IntMap )
+  ( Map )
-import qualified Data.IntMap.Strict as IntMap
-  ( fromList )
 import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
@@ -65,7 +63,7 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Asset.Logo
   ( drawLogo )
 import MetaBrush.Document
-  ( Document(..), AABB(..), Stroke(..)
+  ( Document(..), Stroke(..)
   , FocusState(..)
   , PointData(..), BrushPointData(..)
   , currentDocument
@@ -76,8 +74,6 @@ import MetaBrush.Event
   )
 import MetaBrush.Render.Document
   ( renderDocument )
-import MetaBrush.Render.Util
-  ( widgetAddClass, widgetAddClasses )
 import MetaBrush.UI.FileBar
   ( createFileBar )
 import MetaBrush.UI.InfoBar
@@ -91,20 +87,23 @@ import MetaBrush.UI.ToolBar
 import MetaBrush.UI.Viewport
   ( Viewport(..), createViewport )
 import MetaBrush.Unique
-  ( newUniqueSupply, unsafeUnique )
+  ( newUniqueSupply
+  , Unique, unsafeUnique
+  , uniqueMapFromList
+  )
+import MetaBrush.Util
+  ( widgetAddClass, widgetAddClasses )
 import qualified Paths_MetaBrush as Cabal
   ( getDataFileName )
 
 --------------------------------------------------------------------------------
 
-testDocuments :: IntMap Document
+testDocuments :: Map Unique Document
-testDocuments = IntMap.fromList
+testDocuments = uniqueMapFromList
-  $ zip [0..]
   [ Document
     { displayName    = "Closed"
     , mbFilePath     = Nothing
     , unsavedChanges = False
-      , bounds         = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
     , viewportCenter = Point2D 50 50
     , zoomFactor     = 1
     , documentUnique = unsafeUnique 0
@@ -120,7 +119,6 @@ testDocuments = IntMap.fromList
     { displayName    = "Line"
     , mbFilePath     = Nothing
     , unsavedChanges = True
-      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
     , viewportCenter = Point2D 0 0
     , zoomFactor     = 1
     , documentUnique = unsafeUnique 1
@@ -136,7 +134,6 @@ testDocuments = IntMap.fromList
     { displayName    = "Short line"
     , mbFilePath     = Nothing
     , unsavedChanges = False
-      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
     , viewportCenter = Point2D 0 0
     , zoomFactor     = 1
     , documentUnique = unsafeUnique 2
@@ -176,8 +173,8 @@ main = do
   -- Initialise state
 
   uniqueSupply       <- newUniqueSupply
-  activeDocumentTVar <- STM.newTVarIO @( Maybe Int       )          Nothing
+  activeDocumentTVar <- STM.newTVarIO @( Maybe Unique      )        Nothing
-  openDocumentsTVar  <- STM.newTVarIO @( IntMap Document )          testDocuments
+  openDocumentsTVar  <- STM.newTVarIO @( Map Unique Document )      testDocuments
   mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
   mouseHoldTVar      <- STM.newTVarIO @( Maybe HoldEvent )          Nothing
   pressedKeysTVar    <- STM.newTVarIO @[ Word32 ]                   []
@@ -248,14 +245,9 @@ main = do
   GTK.panedPack1 mainPane mainView True  False
   GTK.panedPack2 mainPane panelBox False False
 
-  fileBar      <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
   viewportGrid <- GTK.gridNew
   infoBar      <- GTK.boxNew GTK.OrientationHorizontal 0
 
-  GTK.boxPackStart mainView fileBar      False False 0
-  GTK.boxPackStart mainView viewportGrid True  True  0
-  GTK.boxPackStart mainView infoBar      False False 0
-
   ---------------------------------------------------------
   -- Background
 
@@ -327,15 +319,14 @@ main = do
   ---------------------------------------------------------
   -- File bar
 
-  _ <-
+  fileBar <-
     createFileBar
-      activeDocumentTVar
+      uniqueSupply activeDocumentTVar openDocumentsTVar
-      openDocumentsTVar
+      window title viewportDrawingArea infoBarElements
-      window
+
-      title
+  GTK.boxPackStart mainView fileBar      False False 0
-      viewportDrawingArea
+  GTK.boxPackStart mainView viewportGrid True  True  0
-      infoBarElements
+  GTK.boxPackStart mainView infoBar      False False 0
-      fileBar
 
   ---------------------------------------------------------
   -- Panels

assets/theme.css

@@ -320,7 +320,7 @@ tooltip {
 }
 
 .fileBarCloseButton {
-  padding-left: 5px;
+  padding-left: 1px;
   padding-right: 5px;
   margin: 0px;
   color: rgba(212, 190, 152,0.2);
@@ -330,6 +330,25 @@ tooltip {
   color: rgba(213,19,36,0.9);
 }
 
+.newFileButton {
+  color: rgb(72,70,61);
+  font-size: 16px;
+  font-weight: bold;
+  font-family: "Sans";
+  padding: 0px 5px 0px 4px;
+  margin: 3px 0px 3px 0px;
+  border-left: 1px solid rgb(41, 40, 40);
+}
+
+.newFileButton:hover, .newFileButton:active, .newFileButton:checked {
+  color: rgb(160,225,54);
+}
+
+.newFileButton:active, .newFileButton:checked {
+  border-color: rgb(160,225,54);
+}
+
+
 /* Panels */
 .panels {
   min-width: 120px;

src/app/MetaBrush/Asset/Cursor.hs

@@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( ColourRecord(..), Colours )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Asset/InfoBar.hs

@@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( ColourRecord(..), Colours )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Asset/Logo.hs

@@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( ColourRecord(..), Colours )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Asset/TickBox.hs

@@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( ColourRecord(..), Colours )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Asset/Tools.hs

@@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( ColourRecord(..), Colours )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Asset/WindowIcons.hs

@@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( ColourRecord(..), Colours )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Document.hs

@@ -8,7 +8,7 @@
 
 module MetaBrush.Document
   ( AABB(..)
-  , Document(..), currentDocument
+  , Document(..), emptyDocument, currentDocument
   , Stroke(..)
   , PointData(..), BrushPointData(..)
   , FocusState(..)
@@ -16,15 +16,17 @@ module MetaBrush.Document
   )
   where
 
+-- base
+import GHC.Generics
+  ( Generic )
+
 -- containers
-import Data.IntMap.Strict
+import Data.Map.Strict
-  ( IntMap )
+  ( Map )
-import qualified Data.IntMap.Strict as IntMap
+import qualified Data.Map.Strict as Map
   ( lookup )
 import Data.Sequence
   ( Seq )
-import GHC.Generics
-  ( Generic )
 
 -- generic-lens
 import Data.Generics.Product.Fields
@@ -50,7 +52,7 @@ import qualified Control.Concurrent.STM.TVar as STM
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Vector2D
-  ( Point2D )
+  ( Point2D(..) )
 import MetaBrush.Unique
   ( Unique )
 
@@ -66,7 +68,6 @@ data Document
     { displayName    :: !Text
     , mbFilePath     :: !( Maybe FilePath )
     , unsavedChanges :: !Bool
-    , bounds         :: !AABB
     , viewportCenter :: !( Point2D Double )
     , zoomFactor     :: !Double
     , documentUnique :: Unique
@@ -107,11 +108,23 @@ _selection = field' @"pointData" . typed @FocusState
 _brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
 _brush = field' @"pointData" . field' @"brushShape"
 
-currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
+currentDocument :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) -> IO ( Maybe Document )
 currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
   mbActive <- STM.readTVar activeDocumentTVar
   case mbActive of
     Nothing -> pure Nothing
-    Just i  -> do
+    Just unique -> do
       docs <- STM.readTVar openDocumentsTVar
-      pure ( IntMap.lookup i docs )
+      pure ( Map.lookup unique docs )
+
+emptyDocument :: Text -> Unique -> Document
+emptyDocument docName unique =
+  Document
+    { displayName    = docName
+    , mbFilePath     = Nothing
+    , unsavedChanges = False
+    , viewportCenter = Point2D 0 0
+    , zoomFactor     = 1
+    , documentUnique = unique
+    , strokes        = []
+    }

src/app/MetaBrush/Document/Selection.hs

@@ -42,6 +42,9 @@ import Data.Generics.Product.Fields
 import Data.Generics.Product.Typed
   ( HasType )
 
+-- gi-gdk
+import qualified GI.Gdk.Constants as GDK
+
 -- lens
 import Control.Lens
   ( view, set, over, mapped )
@@ -69,10 +72,6 @@ import MetaBrush.Document
   ( Document(..), Stroke(..)
   , FocusState(..), _selection
   )
-import MetaBrush.Event.KeyCodes
-  ( pattern Alt_L  , pattern Alt_R
-  , pattern Shift_L, pattern Shift_R
-  )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
 
@@ -96,10 +95,10 @@ instance Monoid SelectionMode where
 
 selectionMode :: [ Word32 ] -> SelectionMode
 selectionMode = foldMap \case
-  Alt_L   -> Subtract
+  GDK.KEY_Alt_L   -> Subtract
-  Alt_R   -> Subtract
+  GDK.KEY_Alt_R   -> Subtract
-  Shift_L -> Add
+  GDK.KEY_Shift_L -> Add
-  Shift_R -> Add
+  GDK.KEY_Shift_R -> Add
   _               -> New
 
 -- | Updates the selected objects on a single click selection event.

src/app/MetaBrush/Document/Serialise.hs

@@ -15,12 +15,18 @@ import Data.Foldable
   ( toList )
 import Data.Functor.Contravariant
   ( contramap )
+import Data.Functor.Identity
+  ( Identity(..) )
+import Unsafe.Coerce
+  ( unsafeCoerce ) -- Tony Morris special
 
 -- bytestring
 import qualified Data.ByteString as Strict
   ( ByteString )
 import qualified Data.ByteString.Lazy as Lazy
   ( ByteString )
+import qualified Data.ByteString.Lazy.Builder as Lazy.ByteString.Builder
+  ( toLazyByteString )
 
 -- containers
 import Data.Sequence
@@ -58,18 +64,29 @@ import qualified Waargonaut.Decode as JSON.Decoder
 import qualified Waargonaut.Encode as JSON
   ( Encoder, Encoder' )
 import qualified Waargonaut.Encode as JSON.Encoder
-  ( simplePureEncodeByteString
+  ( runEncoder
   , atKey', bool, list, mapLikeObj, scientific, text
   )
+import qualified Waargonaut.Encode.Builder as JSON.Builder
+  ( waargonautBuilder, bsBuilder )
+import qualified Waargonaut.Encode.Builder.Whitespace as JSON.Builder
+  ( wsBuilder )
+import Waargonaut.Prettier
+  ( NumSpaces(..), IndentStep(..) )
+import qualified Waargonaut.Prettier as Inline
+  ( InlineOption(..) )
+import qualified Waargonaut.Prettier as JSON
+  ( prettyJson )
+import qualified Waargonaut.Prettier as TonyMorris
+  ( Natural )
 
 -- MetaBrush
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Vector2D
-  ( Point2D(..) ) --, Vector2D(..), Mat22(..) )
+  ( Point2D(..) )
 import MetaBrush.Document
   ( Document(..)
-  , AABB(..)
   , Stroke(..)
   , PointData(..)
   , BrushPointData(..)
@@ -80,9 +97,21 @@ import MetaBrush.Unique
 
 --------------------------------------------------------------------------------
 
+-- | Serialise a document to JSON (in the form of a lazy bytestring).
 documentToJSON :: Document -> Lazy.ByteString
-documentToJSON = JSON.Encoder.simplePureEncodeByteString encodeDocument
+documentToJSON
+  = runIdentity
+  . fmap
+    ( Lazy.ByteString.Builder.toLazyByteString
+    . JSON.Builder.waargonautBuilder JSON.Builder.wsBuilder JSON.Builder.bsBuilder
+    . JSON.prettyJson Inline.Neither ( IndentStep four ) ( NumSpaces four )
+    )
+  . JSON.Encoder.runEncoder encodeDocument
+    where
+      four :: TonyMorris.Natural
+      four = unsafeCoerce ( 4 :: Integer )
 
+-- | Parse a document from JSON (given by a strict bytestring).
 documentFromJSON :: UniqueSupply -> Maybe FilePath -> Strict.ByteString -> IO ( Either JSON.DecodeError Document )
 documentFromJSON uniqueSupply mfp
   = fmap ( Bifunctor.first fst )
@@ -130,7 +159,7 @@ decodeMat22 dec =
         <*> JSON.Decoder.atKey "m01" dec
         <*> JSON.Decoder.atKey "m10" dec
         <*> JSON.Decoder.atKey "m11" dec
--}
+
 
 
 encodeAABB :: Applicative f => JSON.Encoder f AABB
@@ -149,7 +178,7 @@ decodeAABB = do
   where
     dec :: JSON.Decoder m ( Point2D Double )
     dec = decodePoint2D decodeDouble
-
+-}
 
 
 encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d )
@@ -242,9 +271,8 @@ decodeStroke uniqueSupply = do
 
 
 encodeDocument :: Applicative f => JSON.Encoder f Document
-encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, bounds, viewportCenter, zoomFactor, strokes } ) ->
+encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes } ) ->
     JSON.Encoder.atKey' "name"     JSON.Encoder.text                  displayName
-  . JSON.Encoder.atKey' "bounds"   encodeAABB                         bounds
   . JSON.Encoder.atKey' "center"   ( encodePoint2D encodeDouble )     viewportCenter
   . JSON.Encoder.atKey' "zoom"     encodeDouble                       zoomFactor
   . JSON.Encoder.atKey' "strokes"  ( JSON.Encoder.list encodeStroke ) strokes
@@ -255,9 +283,8 @@ decodeDocument uniqueSupply mbFilePath = do
   let
     unsavedChanges :: Bool
     unsavedChanges = False
-  bounds         <- JSON.Decoder.atKey "bounds" decodeAABB
   viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
   zoomFactor     <- JSON.Decoder.atKey "zoom"   decodeDouble
   documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
   strokes        <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
-  pure ( Document { displayName, mbFilePath, unsavedChanges, bounds, viewportCenter, zoomFactor, documentUnique, strokes } )
+  pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes } )

src/app/MetaBrush/Event.hs

@@ -30,9 +30,9 @@ import Data.Act
   )
 
 -- containers
-import Data.IntMap.Strict
+import Data.Map.Strict
-  ( IntMap )
+  ( Map )
-import qualified Data.IntMap.Strict as IntMap
+import qualified Data.Map.Strict as Map
   ( insert, lookup )
 import Data.Sequence
   ( Seq(..) )
@@ -68,12 +68,6 @@ import MetaBrush.Document.Selection
   , dragMoveSelect, translateSelection
   , deleteSelected
   )
-import MetaBrush.Event.KeyCodes
-  ( pattern Escape, pattern Return, pattern Delete
-  , pattern Control_L, pattern Control_R
-  , pattern Shift_L  , pattern Shift_R
-  , pattern F1
-  )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
@@ -81,13 +75,13 @@ import MetaBrush.UI.InfoBar
 import MetaBrush.UI.ToolBar
   ( Tool(..), Mode )
 import MetaBrush.Unique
-  ( UniqueSupply )
+  ( UniqueSupply, Unique )
 
 --------------------------------------------------------------------------------
 
 handleEvents
   :: UniqueSupply
-  -> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
   -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
   -> GTK.Window -> GTK.DrawingArea -> InfoBar
@@ -143,7 +137,7 @@ data PartialPath
 -- Mouse events.
 
 handleMotionEvent
-  :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
   -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool
   -> STM.TVar ( Maybe PartialPath )
@@ -162,7 +156,7 @@ handleMotionEvent
     mbActiveDoc <- STM.readTVarIO activeDocumentTVar
     for_ mbActiveDoc \ i -> do
       docs <- STM.readTVarIO openDocumentsTVar
-      for_ ( IntMap.lookup i docs ) \ ( Document { .. } ) -> do
+      for_ ( Map.lookup i docs ) \ ( Document { .. } ) -> do
 
         ----------------------------------------------------------
         -- Update mouse position in info bar on mouse move event.
@@ -195,7 +189,7 @@ handleMotionEvent
           mbPartialPath <- STM.readTVar partialPathTVar
           case tool of
             Pen
-              | any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
+              | any ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys
               , Just pp <- mbPartialPath
               -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
             _ -> pure ()
@@ -204,7 +198,7 @@ handleMotionEvent
     pure True
 
 handleScrollEvent
-  :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
   -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool
   -> GTK.DrawingArea -> InfoBar
@@ -229,7 +223,7 @@ handleScrollEvent
       mbActiveDoc <- STM.readTVarIO activeDocumentTVar
       for_ mbActiveDoc \ i -> do
         docs <- STM.readTVarIO openDocumentsTVar
-        for_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
+        for_ ( Map.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
           pressedKeys <- STM.readTVarIO pressedKeysTVar
           let
             toViewport :: Point2D Double -> Point2D Double
@@ -240,7 +234,7 @@ handleScrollEvent
             newDoc :: Document
             newDoc
               -- Zooming using 'Control'.
-              | any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
+              | any ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys
               = let
                   newZoomFactor :: Double
                   newZoomFactor
@@ -254,7 +248,7 @@ handleScrollEvent
                     • oldCenter
                 in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
               -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
-              | dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys
+              | dx == 0 && any ( \ key -> key == GDK.KEY_Shift_L || key == GDK.KEY_Shift_R ) pressedKeys
               = let
                   newCenter :: Point2D Double
                   newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
@@ -265,8 +259,8 @@ handleScrollEvent
                   newCenter :: Point2D Double
                   newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
                 in doc { viewportCenter = newCenter }
-            docs' :: IntMap Document
+            docs' :: Map Unique Document
-            docs' = IntMap.insert i newDoc docs
+            docs' = Map.insert i newDoc docs
             finalZoomFactor :: Double
             finalZoomFactor = zoomFactor     newDoc
             finalCenter :: Point2D Double
@@ -292,7 +286,7 @@ handleScrollEvent
 
 handleMouseButtonEvent
   :: UniqueSupply
-  -> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
   -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
   -> GTK.DrawingArea
@@ -315,7 +309,7 @@ handleMouseButtonEvent
         mbActiveDoc <- STM.readTVarIO activeDocumentTVar
         for_ mbActiveDoc \ i -> do
           docs <- STM.readTVarIO openDocumentsTVar
-          for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
+          for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
             x <- GDK.getEventButtonX mouseClickEvent
             y <- GDK.getEventButtonY mouseClickEvent
             viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
@@ -346,8 +340,8 @@ handleMouseButtonEvent
                       | Just newDoc <- dragMoveSelect mode pos doc
                       -> do
                         let
-                          newDocs :: IntMap Document
+                          newDocs :: Map Unique Document
-                          newDocs = IntMap.insert i newDoc docs
+                          newDocs = Map.insert i newDoc docs
                         STM.writeTVar openDocumentsTVar newDocs
                         STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
                     -- Rectangular selection.
@@ -370,8 +364,8 @@ handleMouseButtonEvent
                           }
                         )
                       let
-                        newDocs :: IntMap Document
+                        newDocs :: Map Unique Document
-                        newDocs = IntMap.insert i newDoc docs
+                        newDocs = Map.insert i newDoc docs
                       STM.writeTVar openDocumentsTVar newDocs
                     -- Path already started: indicate that we are continuing a path.
                     Just pp ->
@@ -391,7 +385,7 @@ handleMouseButtonEvent
 
 handleMouseButtonRelease
   :: UniqueSupply
-  -> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
   -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
   -> GTK.DrawingArea
@@ -414,7 +408,7 @@ handleMouseButtonRelease
         mbActiveDoc <- STM.readTVarIO activeDocumentTVar
         for_ mbActiveDoc \ i -> do
           docs <- STM.readTVarIO openDocumentsTVar
-          for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
+          for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
             x <- GDK.getEventButtonX mouseReleaseEvent
             y <- GDK.getEventButtonY mouseReleaseEvent
             viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
@@ -524,8 +518,8 @@ handleMouseButtonRelease
                           pure ( addToAnchor anchor newSegment doc )
 
               let
-                newDocs :: IntMap Document
+                newDocs :: Map Unique Document
-                newDocs = IntMap.insert i newDoc docs
+                newDocs = Map.insert i newDoc docs
               STM.writeTVar openDocumentsTVar newDocs
             GTK.widgetQueueDraw viewportDrawingArea
 
@@ -538,7 +532,7 @@ handleMouseButtonRelease
 -- Keyboard events.
 
 handleKeyboardPressEvent
-  :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
   -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
   -> GTK.DrawingArea
@@ -555,8 +549,8 @@ handleKeyboardPressEvent
       pressedKeys <- STM.readTVar pressedKeysTVar
       STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
     case keyCode of
-      Escape -> GTK.mainQuit
+      GDK.KEY_Escape -> GTK.mainQuit
-      Return -> do
+      GDK.KEY_Return -> do
         tool <- STM.readTVarIO toolTVar
         case tool of
           -- End ongoing drawing on pressing enter key.
@@ -564,7 +558,7 @@ handleKeyboardPressEvent
             STM.atomically $ STM.writeTVar partialPathTVar Nothing
             GTK.widgetQueueDraw viewportDrawingArea
           _ -> pure ()
-      Delete -> do
+      GDK.KEY_Delete -> do
         tool <- STM.readTVarIO toolTVar
         mode <- STM.readTVarIO modeTVar
         case tool of
@@ -573,17 +567,17 @@ handleKeyboardPressEvent
             mbActiveDoc <- STM.readTVarIO activeDocumentTVar
             for_ mbActiveDoc \ i -> do
               docs <- STM.readTVarIO openDocumentsTVar
-              for_ ( IntMap.lookup i docs ) \ doc -> do
+              for_ ( Map.lookup i docs ) \ doc -> do
                 let
                   newDoc :: Document
                   newDoc = deleteSelected mode doc
-                  newDocs :: IntMap Document
+                  newDocs :: Map Unique Document
-                  newDocs = IntMap.insert i newDoc docs
+                  newDocs = Map.insert i newDoc docs
                 STM.atomically $ STM.writeTVar openDocumentsTVar newDocs
                 GTK.widgetQueueDraw viewportDrawingArea
           _ -> pure ()
       ctrl
-        | ctrl == Control_L || ctrl == Control_R
+        | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
         -> do
           ----------------------------------------------------------
           -- With the pen tool, pressing control moves
@@ -599,11 +593,11 @@ handleKeyboardPressEvent
                   STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
                   GTK.widgetQueueDraw viewportDrawingArea
             _ -> pure ()
-      F1 -> do
+      GDK.KEY_F1 -> do
         mbActiveDoc <- STM.readTVarIO activeDocumentTVar
         for_ mbActiveDoc \ i -> do
           docs <- STM.readTVarIO openDocumentsTVar
-          for_ ( IntMap.lookup i docs ) \ doc -> do
+          for_ ( Map.lookup i docs ) \ doc -> do
             writeFile "log.txt" ( show doc <> "\n\n" )
       _ -> pure ()
     pure True

src/app/MetaBrush/Event/KeyCodes.hs

@@ -1,75 +0,0 @@
-{-# LANGUAGE PatternSynonyms #-}
-
-module MetaBrush.Event.KeyCodes where
-
--- base
-import Data.Word
-  ( Word32 )
-
---------------------------------------------------------------------------------
--- GDK keycodes.
-
-pattern Escape    :: Word32
-pattern Escape    = 0xff1b
-pattern Delete    :: Word32
-pattern Delete    = 0xffff
-pattern BackSpace :: Word32
-pattern BackSpace = 0xff08
-pattern Tab       :: Word32
-pattern Tab       = 0xff09
-pattern Return    :: Word32
-pattern Return    = 0xff0d
-pattern Pause     :: Word32
-pattern Pause     = 0xff13
-pattern Left      :: Word32
-pattern Left      = 0xff51
-pattern Up        :: Word32
-pattern Up        = 0xff52
-pattern Right     :: Word32
-pattern Right     = 0xff53
-pattern Down      :: Word32
-pattern Down      = 0xff54
-pattern PageUp    :: Word32
-pattern PageUp    = 0xff55
-pattern Next      :: Word32
-pattern Next      = 0xff56
-pattern PageDown  :: Word32
-pattern PageDown  = 0xff56
-pattern End       :: Word32
-pattern End       = 0xff57
-pattern Shift_L   :: Word32
-pattern Shift_L   = 0xffe1
-pattern Shift_R   :: Word32
-pattern Shift_R   = 0xffe2
-pattern Control_L :: Word32
-pattern Control_L = 0xffe3
-pattern Control_R :: Word32
-pattern Control_R = 0xffe4
-pattern Alt_L     :: Word32
-pattern Alt_L     = 0xffe9
-pattern Alt_R     :: Word32
-pattern Alt_R     = 0xffea
-pattern F1        :: Word32 
-pattern F1        = 0xffbe
-pattern F2        :: Word32 
-pattern F2        = 0xffbf
-pattern F3        :: Word32 
-pattern F3        = 0xffc0
-pattern F4        :: Word32 
-pattern F4        = 0xffc1
-pattern F5        :: Word32 
-pattern F5        = 0xffc2
-pattern F6        :: Word32 
-pattern F6        = 0xffc3
-pattern F7        :: Word32 
-pattern F7        = 0xffc4
-pattern F8        :: Word32 
-pattern F8        = 0xffc5
-pattern F9        :: Word32 
-pattern F9        = 0xffc6
-pattern F10       :: Word32 
-pattern F10       =  0xffc7
-pattern F11       :: Word32 
-pattern F11       =  0xffc8
-pattern F12       :: Word32 
-pattern F12       =  0xffc9

src/app/MetaBrush/Render/Document.hs

@@ -77,10 +77,10 @@ import MetaBrush.Document.Selection
   ( translateSelection )
 import MetaBrush.Event
   ( HoldEvent(..), PartialPath(..) )
-import MetaBrush.Render.Util
-  ( withRGBA )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
+import MetaBrush.Util
+  ( withRGBA )
 
 --------------------------------------------------------------------------------
 

src/app/MetaBrush/UI/FileBar.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE BlockArguments     #-}
-{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeApplications   #-}
@@ -12,14 +11,16 @@ module MetaBrush.UI.FileBar
 -- base
 import Control.Monad
   ( void )
+import Data.Maybe
+  ( listToMaybe )
 import Data.Foldable
   ( for_ )
 
 -- containers
-import Data.IntMap.Strict
+import Data.Map.Strict
-  ( IntMap )
+  ( Map )
-import qualified Data.IntMap.Strict as IntMap
+import qualified Data.Map.Strict as Map
-  ( lookup, traverseWithKey )
+  ( lookup, insert )
 
 -- gi-gtk
 import qualified GI.Gtk as GTK
@@ -28,7 +29,7 @@ import qualified GI.Gtk as GTK
 import qualified Control.Concurrent.STM      as STM
   ( atomically )
 import qualified Control.Concurrent.STM.TVar as STM
-  ( TVar, writeTVar, readTVarIO )
+  ( TVar, writeTVar, readTVarIO, modifyTVar' )
 
 -- text
 import Data.Text
@@ -38,68 +39,111 @@ import Data.Text
 import Math.Vector2D
   ( Point2D(..) )
 import MetaBrush.Document
-  ( Document(..) )
+  ( Document(..), emptyDocument )
-import MetaBrush.Render.Util
-  ( widgetAddClass, widgetAddClasses )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
   ( InfoBar, InfoData(..), updateInfoBar )
+import MetaBrush.Unique
+  ( UniqueSupply, Unique, freshUnique, uniqueText )
+import MetaBrush.Util
+  ( widgetAddClass, widgetAddClasses
+  , (>>?=), Exists(..)
+  )
 
 --------------------------------------------------------------------------------
 
--- | Add the file bar: tabs allowing selection of the active document.
+data TabLocation
---
+  = AfterCurrentTab
--- Updates the active document when buttons are clicked.
+  | LastTab
-createFileBar
+  deriving stock Show
-  :: STM.TVar ( Maybe Int )
-  -> STM.TVar ( IntMap Document )
-  -> GTK.Window
-  -> GTK.Label
-  -> GTK.DrawingArea
-  -> InfoBar
-  -> GTK.ScrolledWindow
-  -> IO ( IntMap GTK.RadioButton )
-createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea infoBar fileBar = do
 
-  widgetAddClass fileBar "fileBar"
+newFileTab
+  :: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
+  -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> GTK.Box -> GTK.RadioButton -> InfoBar
+  -> Maybe Document
+  -> TabLocation
+  -> IO ()
+newFileTab
+  uniqueSupply activeDocumentTVar openDocumentsTVar
+  window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
+  mbDoc
+  newTabLoc
+  = do
 
-  fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
+    newDoc <- case mbDoc of
-  GTK.containerAdd fileBar fileTabs
+      -- Use the provided document (e.g. document read from a file).
-  widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
+      Just doc -> do
+        pure doc
+      -- Create a new empty document.
+      Nothing -> do
+        newDocUniq <- STM.atomically $ freshUnique uniqueSupply
+        pure ( emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
 
-  fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
-
-  -- TODO: currently using static list of documents.
-  -- Need to dynamically update this widget as the user opens/closes documents.
-  documents <- STM.readTVarIO openDocumentsTVar
-  fileButtons <- ( `IntMap.traverseWithKey` documents ) \ i ( Document { displayName = currDisplayName } ) -> do
     -- File tab elements.
-    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) currDisplayName
+    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName newDoc )
     GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
     closeFileButton <- GTK.buttonNewWithLabel "x"
 
     -- Create box for file tab elements.
     tab <- GTK.boxNew GTK.OrientationHorizontal 0
     widgetAddClasses tab [ "fileBarTab" ]
-    GTK.boxPackStart fileTabs tab               False False 0
+    GTK.boxPackStart fileTabsBox tab             False False 0
     GTK.boxPackStart tab         pgButton        True  True  0
     GTK.boxPackStart tab         closeFileButton False False 0
-
     widgetAddClasses pgButton        [ "fileBarTabButton" ]
     widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
 
-    -- Make both file tab elements activate styling on the whole tab
+    GTK.widgetShowAll tab
-    -- (e.g. hovering over the close file button should highlight the whole tab).
+
+    -- We've placed the new tab at the end. Now rearrange it if needed.
+    case newTabLoc of
+      LastTab -> pure ()
+      AfterCurrentTab -> do
+        children <- GTK.containerGetChildren fileTabsBox
+        for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do
+          mbBox <- GTK.castTo GTK.Box childWidget
+          for_ mbBox \ box -> do
+            mbButton
+              <-   ( listToMaybe <$> GTK.containerGetChildren box )
+              >>?= GTK.castTo GTK.RadioButton
+            for_ mbButton \ button -> do
+              isActive <- GTK.toggleButtonGetActive button
+              if isActive
+              then
+                GTK.boxReorderChild fileTabsBox tab ( activeTabIndex + 1 )
+              else
+                pure ()
+
+
+    -- Ensure consistency of hover/selection state between the two elements in the tab.
+    for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
+      void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
+        flags <- GTK.widgetGetStateFlags tab
+        GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
+        pure False
+      void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
+        flags <- GTK.widgetGetStateFlags tab
+        GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
+        pure False
+
+    -- Update the state: switch to this new document.
+    let
+      newUnique :: Unique
+      newUnique = documentUnique newDoc
+    STM.atomically do
+      STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
+      STM.writeTVar  activeDocumentTVar ( Just newUnique )
+    GTK.widgetQueueDraw viewportArea
+
     void $ GTK.onButtonClicked pgButton do
       isActive <- GTK.toggleButtonGetActive pgButton
       flags    <- GTK.widgetGetStateFlags tab
       if isActive
       then do
         GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
-        STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) )
+        STM.atomically ( STM.writeTVar activeDocumentTVar ( Just newUnique ) )
-        GTK.widgetQueueDraw viewportArea
+        mbActiveDoc <- Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
-        mbActiveDoc <- IntMap.lookup i <$> STM.readTVarIO openDocumentsTVar
         case mbActiveDoc of
           Nothing -> do
             GTK.labelSetText   title  "MetaBrush"
@@ -128,35 +172,62 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea inf
                   , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
                   }
             updateInfoBar infoBar infoData
+            GTK.widgetQueueDraw viewportArea
       else do
         GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
         GTK.labelSetText   title  "MetaBrush"
         GTK.setWindowTitle window "MetaBrush"
 
-{-
+    --void $ GTK.onButtonClicked closeFileButton ... ... ...
-    void $ GTK.onButtonClicked closeFileButton do
-      closeFileDialog ...
--}
 
-    for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
+    GTK.toggleButtonSetActive pgButton True
-      void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
-        flags <- GTK.widgetGetStateFlags tab
-        GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
-        pure False
-      void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
-        flags <- GTK.widgetGetStateFlags tab
-        GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
-        pure False
 
-    pure pgButton
+-- | Add the file bar: tabs allowing selection of the active document.
+--
+-- Updates the active document when buttons are clicked.
+createFileBar
+  :: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
+  -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
+  -> IO GTK.Box
+createFileBar
+  uniqueSupply activeDocumentTVar openDocumentsTVar
+  window title viewportArea infoBar
+  = do
 
-  GTK.scrolledWindowSetPolicy           fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
+    -- Create file bar: box containing scrollable tabs, and a "+" button after it.
-  GTK.scrolledWindowSetOverlayScrolling fileBar True
+    fileBar <- GTK.boxNew GTK.OrientationHorizontal 0
+    widgetAddClass fileBar "fileBar"
 
-  pure fileButtons
+    fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
+    GTK.scrolledWindowSetPolicy           fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
+    GTK.scrolledWindowSetOverlayScrolling fileTabsScroll True
 
----------------------------------------------------------
+    newFileButton <- GTK.buttonNewWithLabel "+"
--- Util.
+    widgetAddClasses newFileButton [ "newFileButton" ]
 
-data Exists c where
+    GTK.boxPackStart fileBar fileTabsScroll True  True  0
-  Exists :: c a => a -> Exists c
+    GTK.boxPackStart fileBar newFileButton  False False 0
+
+    fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0
+    GTK.containerAdd fileTabsScroll fileTabsBox
+    widgetAddClasses fileTabsBox [ "fileBar", "plain", "text" ]
+
+    -- Phantom radio button for when no page is selected (e.g. no documents opened yet).
+    fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
+
+    documents <- STM.readTVarIO openDocumentsTVar
+    for_ documents \ doc ->
+      newFileTab
+        uniqueSupply activeDocumentTVar openDocumentsTVar
+        window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
+        ( Just doc )
+        LastTab
+
+    void $ GTK.onButtonClicked newFileButton do
+      newFileTab
+        uniqueSupply activeDocumentTVar openDocumentsTVar
+        window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
+        Nothing
+        LastTab
+
+    pure fileBar

src/app/MetaBrush/UI/InfoBar.hs

@@ -44,7 +44,7 @@ import MetaBrush.Asset.Cursor
   ( drawCursorIcon )
 import MetaBrush.Asset.InfoBar
   ( drawMagnifier, drawTopLeftCornerRect )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( widgetAddClass, widgetAddClasses )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/Menu.hs

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

src/app/MetaBrush/UI/Panels.hs

@@ -15,7 +15,7 @@ import Data.Foldable
 import qualified GI.Gtk as GTK
 
 -- MetaBrush
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( widgetAddClass, widgetAddClasses )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/ToolBar.hs

@@ -36,7 +36,7 @@ import MetaBrush.Asset.Cursor
   ( drawCursorIcon )
 import MetaBrush.Asset.Tools
   ( drawBrush, drawMeta, drawPath, drawPen )
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( widgetAddClass )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/Viewport.hs

@@ -13,7 +13,7 @@ import qualified GI.Gdk as GDK
 import qualified GI.Gtk as GTK
 
 -- MetaBrush
-import MetaBrush.Render.Util
+import MetaBrush.Util
   ( widgetAddClass )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Unique.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE OverloadedStrings          #-}
@@ -7,14 +8,33 @@ module MetaBrush.Unique
   ( Unique, unsafeUnique
   , freshUnique, uniqueText
   , UniqueSupply, newUniqueSupply
+  , uniqueMapFromList
   )
   where
 
 -- base
+import Control.Arrow
+  ( (&&&) )
 import Data.Int
   ( Int64 )
 import Data.Word
   ( Word32 )
+import Foreign.Storable
+  ( Storable )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( fromList )
+
+-- generic-lens
+import Data.Generics.Product.Typed
+  ( HasType(typed) )
+
+-- lens
+import Control.Lens
+  ( view )
 
 -- stm
 import Control.Concurrent.STM
@@ -32,7 +52,7 @@ import qualified Data.Text as Text
 
 newtype Unique = Unique { unique :: Int64 }
   deriving stock   Show
-  deriving newtype ( Eq, Ord )
+  deriving newtype ( Eq, Ord, Storable )
 
 unsafeUnique :: Word32 -> Unique
 unsafeUnique i = Unique ( - fromIntegral i - 1 )
@@ -54,3 +74,6 @@ freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do
 
 newUniqueSupply :: IO UniqueSupply
 newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 )
+
+uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a
+uniqueMapFromList = Map.fromList . map ( view typed &&& id )

src/app/MetaBrush/Util.hs

@@ -1,13 +1,23 @@
 {-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE GADTs               #-}
 {-# LANGUAGE MonoLocalBinds      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 
-module MetaBrush.Render.Util
+module MetaBrush.Util
   ( withRGBA, showRGBA
   , widgetAddClasses, widgetAddClass
+  , (>=?=>), (>>?=)
+  , Exists(..)
   )
   where
 
 -- base
+import Control.Monad
+  ( (>=>) )
+import Data.Coerce
+  ( coerce )
 import Data.Foldable
   ( for_ )
 import GHC.Stack
@@ -26,6 +36,8 @@ import Data.Text
 -- transformers
 import Control.Monad.IO.Class
   ( MonadIO )
+import Control.Monad.Trans.Maybe
+  ( MaybeT(..) )
 
 --------------------------------------------------------------------------------
 
@@ -48,3 +60,18 @@ widgetAddClasses widget classNames = do
 
 widgetAddClass :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> Text -> m ()
 widgetAddClass widget className = GTK.widgetGetStyleContext widget >>= ( `GTK.styleContextAddClass` className )
+
+--------------------------------------------------------------------------------
+
+infixr 1 >=?=>
+(>=?=>) :: forall m a b c. Monad m => ( a -> m ( Maybe b ) ) -> ( b -> m ( Maybe c ) ) -> ( a -> m ( Maybe c ) )
+(>=?=>) = coerce ( (>=>) @( MaybeT m ) @a @b @c )
+
+infixl 1 >>?=
+(>>?=) :: forall m a b. Monad m => m ( Maybe a ) -> ( a -> m ( Maybe b ) ) -> m ( Maybe b )
+(>>?=) = coerce ( (>>=) @( MaybeT m ) @a @b )
+
+--------------------------------------------------------------------------------
+
+data Exists c where
+  Exists :: c a => a -> Exists c