diff --git a/MetaBrush.cabal b/MetaBrush.cabal index aab8a28..13ed9c0 100644 --- a/MetaBrush.cabal +++ b/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: diff --git a/app/Main.hs b/app/Main.hs index dcd6085..d56be15 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -22,10 +22,8 @@ import System.Exit ( exitSuccess ) -- containers -import Data.IntMap.Strict - ( IntMap ) -import qualified Data.IntMap.Strict as IntMap - ( fromList ) +import Data.Map.Strict + ( Map ) 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,64 +87,65 @@ 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 = IntMap.fromList - $ 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 - , strokes = [ Stroke - { strokeName = "Ellipse" - , strokeVisible = True - , strokeUnique = unsafeUnique 10 - , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) - } - ] - } - , Document - { displayName = "Line" - , mbFilePath = Nothing - , unsavedChanges = True - , bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) - , viewportCenter = Point2D 0 0 - , zoomFactor = 1 - , documentUnique = unsafeUnique 1 - , strokes = [ Stroke - { strokeName = "Line" - , strokeVisible = True - , strokeUnique = unsafeUnique 11 - , strokePoints = linePts - } - ] - } - , Document - { displayName = "Short line" - , mbFilePath = Nothing - , unsavedChanges = False - , bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) - , viewportCenter = Point2D 0 0 - , zoomFactor = 1 - , documentUnique = unsafeUnique 2 - , strokes = [ Stroke - { strokeName = "ShortLine" - , strokeVisible = True - , strokeUnique = unsafeUnique 12 - , strokePoints = linePts2 - } - ] - } - ] +testDocuments :: Map Unique Document +testDocuments = uniqueMapFromList + [ Document + { displayName = "Closed" + , mbFilePath = Nothing + , unsavedChanges = False + , viewportCenter = Point2D 50 50 + , zoomFactor = 1 + , documentUnique = unsafeUnique 0 + , strokes = [ Stroke + { strokeName = "Ellipse" + , strokeVisible = True + , strokeUnique = unsafeUnique 10 + , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) + } + ] + } + , Document + { displayName = "Line" + , mbFilePath = Nothing + , unsavedChanges = True + , viewportCenter = Point2D 0 0 + , zoomFactor = 1 + , documentUnique = unsafeUnique 1 + , strokes = [ Stroke + { strokeName = "Line" + , strokeVisible = True + , strokeUnique = unsafeUnique 11 + , strokePoints = linePts + } + ] + } + , Document + { displayName = "Short line" + , mbFilePath = Nothing + , unsavedChanges = False + , viewportCenter = Point2D 0 0 + , zoomFactor = 1 + , documentUnique = unsafeUnique 2 + , strokes = [ Stroke + { strokeName = "ShortLine" + , strokeVisible = True + , strokeUnique = unsafeUnique 12 + , strokePoints = linePts2 + } + ] + } + ] where linePts :: Seq ( StrokePoint PointData ) linePts = Seq.fromList @@ -176,8 +173,8 @@ main = do -- Initialise state uniqueSupply <- newUniqueSupply - activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing - openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments + activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing + 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 - openDocumentsTVar - window - title - viewportDrawingArea - infoBarElements - fileBar + uniqueSupply activeDocumentTVar openDocumentsTVar + window title viewportDrawingArea infoBarElements + + GTK.boxPackStart mainView fileBar False False 0 + GTK.boxPackStart mainView viewportGrid True True 0 + GTK.boxPackStart mainView infoBar False False 0 --------------------------------------------------------- -- Panels diff --git a/assets/theme.css b/assets/theme.css index 58acf1c..32c678f 100644 --- a/assets/theme.css +++ b/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; diff --git a/src/app/MetaBrush/Asset/Cursor.hs b/src/app/MetaBrush/Asset/Cursor.hs index 65b90a2..6174c3a 100644 --- a/src/app/MetaBrush/Asset/Cursor.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/InfoBar.hs b/src/app/MetaBrush/Asset/InfoBar.hs index 833e880..e72fa8d 100644 --- a/src/app/MetaBrush/Asset/InfoBar.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/Logo.hs b/src/app/MetaBrush/Asset/Logo.hs index ab0ca98..235c804 100644 --- a/src/app/MetaBrush/Asset/Logo.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/TickBox.hs b/src/app/MetaBrush/Asset/TickBox.hs index 42e4206..a842a2c 100644 --- a/src/app/MetaBrush/Asset/TickBox.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/Tools.hs b/src/app/MetaBrush/Asset/Tools.hs index f26a064..5267172 100644 --- a/src/app/MetaBrush/Asset/Tools.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/WindowIcons.hs b/src/app/MetaBrush/Asset/WindowIcons.hs index e6c2c2b..16160c7 100644 --- a/src/app/MetaBrush/Asset/WindowIcons.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 4b66828..fe3ab00 100644 --- a/src/app/MetaBrush/Document.hs +++ b/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 - ( IntMap ) -import qualified Data.IntMap.Strict as IntMap +import Data.Map.Strict + ( Map ) +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 = [] + } diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index dd3a34a..5e35149 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/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,11 +95,11 @@ instance Monoid SelectionMode where selectionMode :: [ Word32 ] -> SelectionMode selectionMode = foldMap \case - Alt_L -> Subtract - Alt_R -> Subtract - Shift_L -> Add - Shift_R -> Add - _ -> New + GDK.KEY_Alt_L -> Subtract + GDK.KEY_Alt_R -> Subtract + GDK.KEY_Shift_L -> Add + GDK.KEY_Shift_R -> Add + _ -> New -- | Updates the selected objects on a single click selection event. selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index c0deedf..7249a49 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/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 } ) diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 5df023f..ff37e83 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -30,9 +30,9 @@ import Data.Act ) -- containers -import Data.IntMap.Strict - ( IntMap ) -import qualified Data.IntMap.Strict as IntMap +import Data.Map.Strict + ( Map ) +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' = IntMap.insert i newDoc docs + docs' :: Map Unique Document + 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 = IntMap.insert i newDoc docs + newDocs :: Map Unique Document + 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 = IntMap.insert i newDoc docs + newDocs :: Map Unique Document + 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 = IntMap.insert i newDoc docs + newDocs :: Map Unique Document + 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 - Return -> do + GDK.KEY_Escape -> GTK.mainQuit + 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 = IntMap.insert i newDoc docs + newDocs :: Map Unique Document + 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 diff --git a/src/app/MetaBrush/Event/KeyCodes.hs b/src/app/MetaBrush/Event/KeyCodes.hs deleted file mode 100644 index 4d4e4d2..0000000 --- a/src/app/MetaBrush/Event/KeyCodes.hs +++ /dev/null @@ -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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index fce5371..42456e4 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 244e9cd..b0e2eff 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module MetaBrush.UI.FileBar ( createFileBar ) @@ -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 - ( IntMap ) -import qualified Data.IntMap.Strict as IntMap - ( lookup, traverseWithKey ) +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( 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(..) ) -import MetaBrush.Render.Util - ( widgetAddClass, widgetAddClasses ) + ( Document(..), emptyDocument ) 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. --- --- Updates the active document when buttons are clicked. -createFileBar - :: 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" +data TabLocation + = AfterCurrentTab + | LastTab + deriving stock Show - fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0 - GTK.containerAdd fileBar fileTabs - widgetAddClasses fileTabs [ "fileBar", "plain", "text" ] +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 - fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) + newDoc <- case mbDoc of + -- Use the provided document (e.g. document read from a file). + Just doc -> do + pure doc + -- Create a new empty document. + Nothing -> do + newDocUniq <- STM.atomically $ freshUnique uniqueSupply + pure ( emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq ) - -- 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 tab pgButton True True 0 - GTK.boxPackStart tab closeFileButton 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 - -- (e.g. hovering over the close file button should highlight the whole tab). + GTK.widgetShowAll 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 + flags <- GTK.widgetGetStateFlags tab if isActive then do GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True - STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) ) - GTK.widgetQueueDraw viewportArea - mbActiveDoc <- IntMap.lookup i <$> STM.readTVarIO openDocumentsTVar + STM.atomically ( STM.writeTVar activeDocumentTVar ( Just newUnique ) ) + mbActiveDoc <- Map.lookup newUnique <$> 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 do - closeFileDialog ... --} + --void $ GTK.onButtonClicked closeFileButton ... ... ... - 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 + GTK.toggleButtonSetActive pgButton True - 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 - GTK.scrolledWindowSetOverlayScrolling fileBar True + -- Create file bar: box containing scrollable tabs, and a "+" button after it. + 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 ---------------------------------------------------------- --- Util. + newFileButton <- GTK.buttonNewWithLabel "+" + widgetAddClasses newFileButton [ "newFileButton" ] -data Exists c where - Exists :: c a => a -> Exists c + GTK.boxPackStart fileBar fileTabsScroll True True 0 + 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 diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 2cef6c5..6a25abd 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 9bf4fe6..d102d52 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 5bf11db..19ad7f1 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index f520bac..280feee 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 4af2758..60f22b6 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Unique.hs b/src/app/MetaBrush/Unique.hs index 6617bc3..e4dec0b 100644 --- a/src/app/MetaBrush/Unique.hs +++ b/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 ) diff --git a/src/app/MetaBrush/Render/Util.hs b/src/app/MetaBrush/Util.hs similarity index 57% rename from src/app/MetaBrush/Render/Util.hs rename to src/app/MetaBrush/Util.hs index 3ee75a7..9a91d71 100644 --- a/src/app/MetaBrush/Render/Util.hs +++ b/src/app/MetaBrush/Util.hs @@ -1,13 +1,23 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# 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