mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
add stroke layer view
This commit is contained in:
sheaf
parent
0eb0724dde
commit
24f182feec
|
|
@ -149,7 +149,7 @@ common gtk
|
|||
, gi-cairo-connector
|
||||
^>= 0.1.0
|
||||
, gi-gdk
|
||||
>= 4.0.2 && < 4.1
|
||||
>= 4.0.9 && < 4.1
|
||||
, gi-gio
|
||||
>= 2.0.34 && < 2.1
|
||||
, gi-glib
|
||||
|
|
@ -161,7 +161,7 @@ common gtk
|
|||
, haskell-gi
|
||||
>= 0.26.10 && < 0.27
|
||||
, haskell-gi-base
|
||||
>= 0.26.6 && < 0.27
|
||||
>= 0.26.8 && < 0.27
|
||||
|
||||
-- Workaround for https://github.com/haskell/cabal/issues/4237
|
||||
-- See https://github.com/commercialhaskell/stack/issues/2197
|
||||
|
|
@ -246,6 +246,7 @@ executable MetaBrush
|
|||
, MetaBrush.UI.InfoBar
|
||||
, MetaBrush.UI.Menu
|
||||
, MetaBrush.UI.Panels
|
||||
, MetaBrush.UI.StrokeTreeView
|
||||
, MetaBrush.UI.ToolBar
|
||||
, MetaBrush.UI.Viewport
|
||||
|
||||
|
|
|
|||
121
assets/theme.css
121
assets/theme.css
|
|
@ -1,7 +1,32 @@
|
|||
|
||||
/*
|
||||
.metabrush * {
|
||||
all: unset;
|
||||
}
|
||||
*/
|
||||
|
||||
.toggle, .dialogButton, .titleBar, .windowIcon, .fileBarCloseButton,
|
||||
.newFileButton, .header, .paned, .panel, .tabs, .frame {
|
||||
all: unset;
|
||||
}
|
||||
|
||||
.reorderable-page {
|
||||
all: unset;
|
||||
}
|
||||
|
||||
.menu * {
|
||||
all: unset;
|
||||
}
|
||||
|
||||
.frame > * {
|
||||
all: unset;
|
||||
}
|
||||
|
||||
|
||||
.notebook {
|
||||
all: unset;
|
||||
}
|
||||
|
||||
|
||||
@import url("colours.css");
|
||||
|
||||
|
|
@ -471,3 +496,99 @@ To specify it in CSS, set the box-shadow of the contents node."
|
|||
margin-left: -4px;
|
||||
padding-right: 16px;
|
||||
}
|
||||
|
||||
/* Stroke hierarchy layers */
|
||||
|
||||
row {
|
||||
border-top: 0px;
|
||||
border-bottom: 0px;
|
||||
margin-top: -2px;
|
||||
margin-bottom: -2px;
|
||||
}
|
||||
|
||||
/* Slightly hacky way to align layers and groups */
|
||||
indent {
|
||||
margin-left: 4px;
|
||||
margin-right: 4px;
|
||||
}
|
||||
|
||||
:selected {
|
||||
background-color: rgba(255,255,255,0);
|
||||
font-weight: bold;
|
||||
color: black;
|
||||
}
|
||||
|
||||
.layer-item {
|
||||
color: @plain;
|
||||
background-color: @active;
|
||||
border: 0px solid @bg;
|
||||
transition:
|
||||
border-color 0.3s ease-out,
|
||||
border-color 0.2s ease-in,
|
||||
background-color 0.6s ease-out,
|
||||
background-color 0.4s ease-in,
|
||||
box-shadow 0.6s ease-out,
|
||||
box-shadow 0.4s ease-in;
|
||||
|
||||
padding-top: 4px;
|
||||
padding-bottom: 4px;
|
||||
border-top: 1px solid @active;
|
||||
border-bottom: 1px solid @active;
|
||||
margin-top: -1px;
|
||||
margin-bottom: -1px;
|
||||
padding-left: 3px;
|
||||
}
|
||||
|
||||
:selected .layer-item {
|
||||
color: black;
|
||||
background-color: @contrast;
|
||||
border: 0px solid @contrast;
|
||||
}
|
||||
|
||||
/* Add "drop here" areas when a drag has been initiated */
|
||||
.dragging-item .layer-item {
|
||||
}
|
||||
|
||||
/* Style when dragging over an item */
|
||||
.drag-over.layer-item {
|
||||
}
|
||||
|
||||
/* Style when dragging over the top part of an item */
|
||||
.drag-top.layer-item {
|
||||
border-top: 2px solid @highlight;
|
||||
margin-top: -2px;
|
||||
box-shadow:
|
||||
0 -1px 6px 1px @highlight,
|
||||
inset 0 8px 6px -6px @highlight;
|
||||
}
|
||||
|
||||
/* Style when dragging over the bottom part of an item */
|
||||
.drag-bot.layer-item {
|
||||
border-bottom: 2px solid @highlight;
|
||||
margin-bottom: -2px;
|
||||
box-shadow:
|
||||
inset 0 -8px 6px -6px @highlight;
|
||||
}
|
||||
|
||||
/* Style for item being dragged */
|
||||
.dragged.layer-item {
|
||||
background-color: @bg;
|
||||
transition:
|
||||
background-color 0.4s ease-in-out;
|
||||
}
|
||||
|
||||
/* Wide separator styling */
|
||||
.metabrush .wide {
|
||||
background-color: @bg;
|
||||
background-size: 0px;
|
||||
background-image: none;
|
||||
min-width: 2px;
|
||||
min-height: 2px;
|
||||
}
|
||||
|
||||
/* List view */
|
||||
.metabrush .view {
|
||||
margin-top: 3px;
|
||||
border: 0px;
|
||||
background-color: @bg;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -25,8 +25,6 @@ import Data.Map.Strict
|
|||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- directory
|
||||
|
|
@ -61,9 +59,6 @@ import Control.Lens
|
|||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically, retry )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( newTVarIO, readTVar, writeTVar )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Reader
|
||||
|
|
@ -71,7 +66,7 @@ import Control.Monad.Trans.Reader
|
|||
|
||||
-- brush-strokes
|
||||
import Math.Root.Isolation
|
||||
( RootIsolationOptions(..), defaultRootIsolationOptions )
|
||||
( defaultRootIsolationOptions )
|
||||
import Math.Bezier.Cubic.Fit
|
||||
( FitParameters(..) )
|
||||
import Math.Bezier.Spline
|
||||
|
|
@ -86,16 +81,14 @@ import Math.Linear
|
|||
-- MetaBrush
|
||||
import MetaBrush.Application.Action
|
||||
( ActionOrigin(..) )
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
|
||||
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
|
||||
import MetaBrush.Asset.Colours
|
||||
( getColours )
|
||||
import MetaBrush.Asset.Logo
|
||||
( drawLogo )
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..)
|
||||
, HoldAction(..), PartialPath(..)
|
||||
)
|
||||
import MetaBrush.Application.UpdateDocument
|
||||
( activeDocument, withActiveDocument )
|
||||
import MetaBrush.Document
|
||||
|
|
@ -113,15 +106,14 @@ import MetaBrush.Render.Rulers
|
|||
( renderRuler )
|
||||
import MetaBrush.Stroke
|
||||
import MetaBrush.UI.FileBar
|
||||
( FileBar(..), FileBarTab, createFileBar )
|
||||
( FileBar(..), createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar(..), createInfoBar, updateInfoBar )
|
||||
import MetaBrush.UI.Menu
|
||||
( createMenuBar, createMenuActions )
|
||||
import MetaBrush.UI.Panels
|
||||
( createPanelBar )
|
||||
--import MetaBrush.UI.StrokeTreeView
|
||||
-- ( newStrokeView )
|
||||
import MetaBrush.UI.StrokeTreeView
|
||||
( newLayerView )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..), createToolBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
|
|
@ -147,7 +139,6 @@ runApplication application = do
|
|||
uniqueSupply <- newUniqueSupply
|
||||
|
||||
docUnique <- runReaderT freshUnique uniqueSupply
|
||||
strokeUnique <- runReaderT freshUnique uniqueSupply
|
||||
|
||||
let
|
||||
testStroke =
|
||||
|
|
@ -175,17 +166,30 @@ runApplication application = do
|
|||
|
||||
testLayers :: Layers
|
||||
testLayers =
|
||||
[ GroupLayer
|
||||
{ layerName = "Group 1"
|
||||
, layerVisible = True
|
||||
, layerLocked = False
|
||||
, groupChildren =
|
||||
[ StrokeLayer
|
||||
{ layerUnique = strokeUnique
|
||||
, layerName = "Stroke 1"
|
||||
{ layerName = "Stroke 1"
|
||||
, layerVisible = True
|
||||
, layerLocked = False
|
||||
, layerStroke = testStroke
|
||||
}
|
||||
]
|
||||
}
|
||||
, GroupLayer
|
||||
{ layerName = "Group 2"
|
||||
, layerVisible = True
|
||||
, layerLocked = False
|
||||
, groupChildren = []
|
||||
}
|
||||
]
|
||||
|
||||
( layerMeta, testStrokes ) = layersStrokeHierarchy testLayers
|
||||
( layerMeta, testStrokes ) <- ( `runReaderT` uniqueSupply ) $ layersStrokeHierarchy testLayers
|
||||
|
||||
let
|
||||
testDoc :: Document
|
||||
testDoc
|
||||
= emptyDocument "Test"
|
||||
|
|
@ -196,21 +200,24 @@ runApplication application = do
|
|||
testDocuments = newHistory <$> Map.fromList
|
||||
[ ( docUnique, testDoc ) ]
|
||||
|
||||
recomputeStrokesTVar <- STM.newTVarIO @Bool False
|
||||
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
|
||||
mousePosTVar <- STM.newTVarIO @( Maybe ( ℝ 2 ) ) Nothing
|
||||
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
|
||||
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
|
||||
toolTVar <- STM.newTVarIO @Tool Selection
|
||||
modeTVar <- STM.newTVarIO @Mode PathMode
|
||||
debugTVar <- STM.newTVarIO @Bool False
|
||||
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
|
||||
fileBarTabsTVar <- STM.newTVarIO @( Map Unique FileBarTab ) Map.empty
|
||||
showGuidesTVar <- STM.newTVarIO @Bool True
|
||||
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
||||
fitParametersTVar <- STM.newTVarIO @FitParameters $
|
||||
recomputeStrokesTVar <- STM.newTVarIO False
|
||||
documentRenderTVar <- STM.newTVarIO ( const $ pure () )
|
||||
activeDocumentTVar <- STM.newTVarIO Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO testDocuments
|
||||
strokeListModelsTVar <- STM.newTVarIO Map.empty
|
||||
parStoresTVar <- STM.newTVarIO Map.empty
|
||||
listModelUpToDateTMVar <- STM.newTMVarIO ()
|
||||
mousePosTVar <- STM.newTVarIO Nothing
|
||||
mouseHoldTVar <- STM.newTVarIO Nothing
|
||||
modifiersTVar <- STM.newTVarIO Set.empty
|
||||
toolTVar <- STM.newTVarIO Selection
|
||||
modeTVar <- STM.newTVarIO PathMode
|
||||
debugTVar <- STM.newTVarIO False
|
||||
partialPathTVar <- STM.newTVarIO Nothing
|
||||
fileBarTabsTVar <- STM.newTVarIO Map.empty
|
||||
showGuidesTVar <- STM.newTVarIO True
|
||||
maxHistorySizeTVar <- STM.newTVarIO 1000
|
||||
fitParametersTVar <- STM.newTVarIO $
|
||||
FitParameters
|
||||
{ maxSubdiv = 2 --5 --2 --3 -- 6
|
||||
, nbSegments = 3
|
||||
|
|
@ -218,17 +225,13 @@ runApplication application = do
|
|||
, t_tol = 1e-4
|
||||
, maxIters = 20
|
||||
}
|
||||
rootsAlgoTVar <- STM.newTVarIO @RootSolvingAlgorithm $
|
||||
rootsAlgoTVar <- STM.newTVarIO $
|
||||
--HalleyM2
|
||||
NewtonRaphson
|
||||
{ maxIters = 20, precision = 8 }
|
||||
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
|
||||
cuspFindingOptionsTVar <- STM.newTVarIO $
|
||||
Just defaultRootIsolationOptions
|
||||
|
||||
--testDocsStrokeListModels <-
|
||||
-- for testDocuments ( newStrokeView . strokes . documentContent . present )
|
||||
strokeListModelsTVar <- STM.newTVarIO @( Map Unique GTK.SelectionModel ) Map.empty --testDocsStrokeListModels
|
||||
|
||||
-- Put all these stateful variables in a record for conciseness.
|
||||
let
|
||||
variables :: Variables
|
||||
|
|
@ -274,6 +277,7 @@ runApplication application = do
|
|||
|
||||
toolBar <- GTK.boxNew GTK.OrientationVertical 0
|
||||
mainPane <- GTK.panedNew GTK.OrientationHorizontal
|
||||
GTK.panedSetWideHandle mainPane True
|
||||
panelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
GTK.gridAttach uiGrid toolBar 0 0 2 1
|
||||
|
|
@ -428,11 +432,6 @@ runApplication application = do
|
|||
|
||||
_ <- createToolBar variables colours toolBar
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels bar
|
||||
|
||||
panelsBar <- createPanelBar panelBox
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Info bar
|
||||
|
||||
|
|
@ -440,6 +439,11 @@ runApplication application = do
|
|||
|
||||
menuActions <- createMenuActions
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels bar
|
||||
|
||||
panelsBar <- createPanelBar panelBox
|
||||
|
||||
rec
|
||||
|
||||
---------------------------------------------------------
|
||||
|
|
@ -450,7 +454,7 @@ runApplication application = do
|
|||
colours variables
|
||||
application window windowKeys titleBar titleLabel viewport infoBar
|
||||
menuBar menuActions
|
||||
panelsBar
|
||||
panelsBar strokesListView
|
||||
|
||||
let
|
||||
uiElements :: UIElements
|
||||
|
|
@ -461,6 +465,15 @@ runApplication application = do
|
|||
|
||||
menuBar <- createMenuBar uiElements variables colours
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Strokes view
|
||||
|
||||
strokesListView <- newLayerView uiElements variables
|
||||
|
||||
GTK.scrolledWindowSetChild
|
||||
( layersScrolledWindow panelsBar )
|
||||
( Just strokesListView )
|
||||
|
||||
GTK.boxAppend mainView fileBarBox
|
||||
GTK.boxAppend mainView viewportGrid
|
||||
GTK.boxAppend mainView infoBarArea
|
||||
|
|
|
|||
|
|
@ -20,8 +20,6 @@ import Data.Traversable
|
|||
( for )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -66,10 +64,6 @@ import qualified GI.Gtk as GTK
|
|||
-- haskell-gi-base
|
||||
import qualified Data.GI.Base as GI
|
||||
|
||||
-- hashable
|
||||
import Data.Hashable
|
||||
( Hashable )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( over, set )
|
||||
|
|
@ -103,10 +97,6 @@ import Math.Linear
|
|||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..), modifierKey
|
||||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..), DocumentMetadata(..)
|
||||
, Zoom(..)
|
||||
|
|
@ -142,10 +132,8 @@ import MetaBrush.UI.Coordinates
|
|||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( updateInfoBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( FileBarTab(..), TabLocation(..), newFileTab, removeFileTab )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..) )
|
||||
import MetaBrush.UI.FileBar
|
||||
( newFileTab, removeFileTab )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
|
|
@ -157,12 +145,6 @@ import MetaBrush.GTK.Util
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data ActionName
|
||||
= AppAction { actionSimpleName :: !Text }
|
||||
| WinAction { actionSimpleName :: !Text }
|
||||
deriving stock ( Eq, Ord, Show, Generic )
|
||||
deriving anyclass Hashable
|
||||
|
||||
actionPrefix :: ActionName -> Text
|
||||
actionPrefix ( AppAction _ ) = "app."
|
||||
actionPrefix ( WinAction _ ) = "win."
|
||||
|
|
@ -664,10 +646,9 @@ instance HandleAction Delete where
|
|||
Nothing ->
|
||||
pure Don'tModifyDoc
|
||||
Just ( doc', affectedPoints, delStrokes ) -> do
|
||||
-- TODO: this would also be a hierarchy diff...
|
||||
-- but for now we will just have emtpy strokes in the
|
||||
-- layers view.
|
||||
let diff = HistoryDiff $ ContentDiff $
|
||||
-- TODO: only a hierarchy diff if there are
|
||||
-- any deleted strokes.
|
||||
let diff = HistoryDiff $ HierarchyDiff $
|
||||
DeletePoints
|
||||
{ deletedPoints = affectedPoints
|
||||
, deletedStrokes = delStrokes
|
||||
|
|
@ -968,6 +949,7 @@ instance HandleAction MouseClick where
|
|||
, newPosition = WithinParent Root 0
|
||||
-- TODO: add the stroke above the selected layer
|
||||
-- or something of the sort.
|
||||
, newIsGroup = False
|
||||
}
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
else
|
||||
|
|
|
|||
|
|
@ -7,21 +7,10 @@ import Data.Word
|
|||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- hashable
|
||||
import Data.Hashable
|
||||
( Hashable )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
import {-# SOURCE #-} MetaBrush.Application.Context
|
||||
( UIElements, Variables )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( TabLocation(..) )
|
||||
import MetaBrush.Application.Context
|
||||
import MetaBrush.UI.Viewport
|
||||
( Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
|
|
@ -29,15 +18,6 @@ import MetaBrush.Unique
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data ActionName
|
||||
= AppAction { actionSimpleName :: !Text }
|
||||
| WinAction { actionSimpleName :: !Text }
|
||||
|
||||
instance Eq ActionName
|
||||
instance Ord ActionName
|
||||
instance Show ActionName
|
||||
instance Hashable ActionName
|
||||
|
||||
class HandleAction action where
|
||||
handleAction :: UIElements -> Variables -> action -> IO ()
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,12 @@
|
|||
module MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, LR(..), Modifier(..), modifierKey
|
||||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||||
)
|
||||
where
|
||||
module MetaBrush.Application.Context where
|
||||
|
||||
-- base
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Set
|
||||
|
|
@ -30,9 +27,17 @@ import qualified GI.Gio as GIO
|
|||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- hashable
|
||||
import Data.Hashable
|
||||
( Hashable )
|
||||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar )
|
||||
import qualified Control.Concurrent.STM.TMVar as STM
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- unordered-containers
|
||||
import Data.HashMap.Strict
|
||||
|
|
@ -51,8 +56,6 @@ import Math.Root.Isolation
|
|||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
( BrushWidgetActionState )
|
||||
import {-# SOURCE #-} MetaBrush.Application.Action
|
||||
( ActionName )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Document.Diff
|
||||
|
|
@ -61,14 +64,10 @@ import MetaBrush.Draw
|
|||
( DrawAnchor )
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..) )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( FileBar, FileBarTab )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import MetaBrush.Layer
|
||||
( Parent )
|
||||
import MetaBrush.UI.Panels
|
||||
( PanelsBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.ToolBar
|
||||
( Tool, Mode )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
|
|
@ -90,6 +89,7 @@ data UIElements
|
|||
, menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
|
||||
, menuActions :: !( HashMap ActionName GIO.SimpleAction )
|
||||
, panelsBar :: !PanelsBar
|
||||
, strokesListView :: GTK.ListView
|
||||
, colours :: !Colours
|
||||
}
|
||||
|
||||
|
|
@ -100,7 +100,19 @@ data Variables
|
|||
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
|
||||
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
|
||||
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
|
||||
, strokeListModelsTVar :: !( STM.TVar ( Map Unique GTK.SelectionModel ) )
|
||||
, strokeListModelsTVar :: !( STM.TVar ( Map Unique GTK.SingleSelection ) )
|
||||
|
||||
-- | This TVar allows us to look up which 'GIO.ListStore' is used
|
||||
-- for the children of a given parent.
|
||||
--
|
||||
-- This allows us to know, given a parent and a child index,
|
||||
-- how to insert/delete from the 'GTK.TreeListModel'.
|
||||
, parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) )
|
||||
|
||||
-- | This TMVar is used to ensure that the layer hierarchy data
|
||||
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
|
||||
, listModelUpToDateTMVar :: !( STM.TMVar () )
|
||||
|
||||
, mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) )
|
||||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||||
|
|
@ -176,3 +188,62 @@ data PartialPath
|
|||
, firstPoint :: !Bool
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Tool
|
||||
= Selection
|
||||
| Pen
|
||||
deriving stock ( Show, Eq )
|
||||
|
||||
data Mode
|
||||
= PathMode
|
||||
| BrushMode
|
||||
| MetaMode
|
||||
deriving stock ( Show, Eq )
|
||||
|
||||
data ToolBar
|
||||
= ToolBar
|
||||
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
|
||||
:: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data FileBar
|
||||
= FileBar
|
||||
{ fileBarBox :: !GTK.Box
|
||||
, fileTabsBox :: !GTK.Box
|
||||
, fileBarPhantomToggleButton :: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
data FileBarTab
|
||||
= FileBarTab
|
||||
{ fileBarTab :: !GTK.Box
|
||||
, fileBarTabButton :: !GTK.ToggleButton
|
||||
, fileBarTabCloseArea :: !GTK.DrawingArea
|
||||
}
|
||||
|
||||
data TabLocation
|
||||
= AfterCurrentTab
|
||||
| LastTab
|
||||
deriving stock Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data InfoBar
|
||||
= InfoBar
|
||||
{ infoBarArea :: !GTK.Box
|
||||
, zoomText :: !GTK.Label -- make this editable
|
||||
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data ActionName
|
||||
= AppAction { actionSimpleName :: !Text }
|
||||
| WinAction { actionSimpleName :: !Text }
|
||||
deriving stock ( Eq, Show, Generic )
|
||||
deriving anyclass Hashable
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -1,17 +0,0 @@
|
|||
module MetaBrush.Application.Context
|
||||
( UIElements, Variables
|
||||
, Modifier(..), LR(..) )
|
||||
where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data UIElements
|
||||
|
||||
data Variables
|
||||
|
||||
data LR = L | R
|
||||
|
||||
data Modifier
|
||||
= Control LR
|
||||
| Alt LR
|
||||
| Shift LR
|
||||
|
|
@ -18,12 +18,14 @@ import Data.Traversable
|
|||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
( adjust, delete, lookup )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- gi-glib
|
||||
import qualified GI.GLib as GLib
|
||||
|
||||
-- gi-gio
|
||||
import qualified GI.Gio as GIO
|
||||
|
||||
|
|
@ -40,9 +42,6 @@ import Control.Lens.Fold
|
|||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( readTVar, readTVar, modifyTVar', writeTVar )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
|
|
@ -59,24 +58,23 @@ import qualified Data.HashMap.Lazy as HashMap
|
|||
( lookup )
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Application.Action
|
||||
( ActionName(..) )
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..), DocumentMetadata(..)
|
||||
)
|
||||
import MetaBrush.Document.Diff
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), atStart, atEnd
|
||||
, newFutureStep, affirmPresent
|
||||
, newFutureStep, affirmPresentSaved
|
||||
)
|
||||
import MetaBrush.GTK.Util
|
||||
( (>>?=) )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( FileBarTab(..), removeFileTab )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( removeFileTab )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( updateInfoBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.StrokeTreeView
|
||||
( switchStrokeView )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
|
|
@ -152,12 +150,12 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables
|
|||
let change = ActiveDocChange { mbOldDocUnique = Just unique }
|
||||
coerce ( updateUIAction change uiElts vars )
|
||||
SaveDocument Nothing -> do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique )
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresentSaved unique )
|
||||
coerce ( updateUIAction NoActiveDocChange uiElts vars )
|
||||
SaveDocument ( Just newFilePath ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust
|
||||
( affirmPresent
|
||||
( affirmPresentSaved
|
||||
. set ( field' @"present" . field' @"documentMetadata" . field' @"documentFilePath" )
|
||||
( Just newFilePath )
|
||||
)
|
||||
|
|
@ -175,7 +173,7 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables
|
|||
-- Content change.
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust
|
||||
( newFutureStep maxHistSize
|
||||
( newFutureStep maxHistSize histDiff
|
||||
. set ( field' @"documentContent" . field' @"unsavedChanges" ) True
|
||||
$ newDocument
|
||||
)
|
||||
|
|
@ -216,11 +214,12 @@ updateUIAction _docChange uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
|||
mbActiveTabDoc <- fmap join $ for mbDoc \ ( docUnique, _doc ) -> do
|
||||
mbActiveTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||
pure ( (,) <$> mbActiveTab <*> mbDoc )
|
||||
--strokeModels <- STM.readTVar strokeListModelsTVar
|
||||
pure do
|
||||
updateTitle window titleLabel mbTitleText
|
||||
updateInfoBar viewportDrawingArea infoBar vars ( fmap ( documentMetadata . snd ) mbDoc )
|
||||
--switchStrokeView (strokesListView $ panelsBar) strokeModels (fst <$> mbDoc)
|
||||
_ <- GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do
|
||||
switchStrokeView strokesListView vars ( fst <$> mbDoc )
|
||||
return False
|
||||
for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, ( _, activeDoc ) ) -> do
|
||||
GTK.buttonSetLabel fileBarTabButton ( documentName $ documentMetadata activeDoc )
|
||||
GTK.widgetQueueDraw fileBarTab
|
||||
|
|
|
|||
|
|
@ -251,7 +251,6 @@ getDocumentRender
|
|||
|
||||
getVisibleStrokes :: Document -> [ ( Maybe Unique, Stroke ) ]
|
||||
getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
|
||||
let res =
|
||||
Writer.execWriter $
|
||||
forStrokeHierarchy
|
||||
( layerMetadata documentMetadata )
|
||||
|
|
@ -261,7 +260,6 @@ getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
|
|||
Writer.tell [ ( Just uniq, stroke ) ]
|
||||
return PreserveStroke
|
||||
)
|
||||
in if null res then error ( show $ strokeHierarchy documentContent ) else res
|
||||
|
||||
-- | Utility type to gather information needed to render a stroke.
|
||||
-- - No outline: just the underlying spline.
|
||||
|
|
|
|||
|
|
@ -44,20 +44,17 @@ import Data.HashMap.Lazy
|
|||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Application.Action
|
||||
( ActionName, SwitchFromTo(..), Close(..), handleAction )
|
||||
( SwitchFromTo(..), Close(..), handleAction )
|
||||
import MetaBrush.Application.Context
|
||||
import MetaBrush.Asset.CloseTabButton
|
||||
( drawCloseTabButton )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Document
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), newHistory )
|
||||
import MetaBrush.Application.UpdateDocument
|
||||
( updateUIAction, ActiveDocChange (..) )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import MetaBrush.UI.Panels
|
||||
( PanelsBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
|
|
@ -69,25 +66,6 @@ import MetaBrush.GTK.Util
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data FileBar
|
||||
= FileBar
|
||||
{ fileBarBox :: !GTK.Box
|
||||
, fileTabsBox :: !GTK.Box
|
||||
, fileBarPhantomToggleButton :: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
data FileBarTab
|
||||
= FileBarTab
|
||||
{ fileBarTab :: !GTK.Box
|
||||
, fileBarTabButton :: !GTK.ToggleButton
|
||||
, fileBarTabCloseArea :: !GTK.DrawingArea
|
||||
}
|
||||
|
||||
data TabLocation
|
||||
= AfterCurrentTab
|
||||
| LastTab
|
||||
deriving stock Show
|
||||
|
||||
newFileTab
|
||||
:: UIElements
|
||||
-> Variables
|
||||
|
|
@ -212,11 +190,13 @@ createFileBar
|
|||
-> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar
|
||||
-> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction
|
||||
-> PanelsBar
|
||||
-> GTK.ListView
|
||||
-> IO FileBar
|
||||
createFileBar
|
||||
colours
|
||||
vars@( Variables { openDocumentsTVar } )
|
||||
application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions panelsBar
|
||||
application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions
|
||||
panelsBar strokesListView
|
||||
= do
|
||||
|
||||
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
|
||||
|
|
|
|||
|
|
@ -4,12 +4,8 @@ module MetaBrush.UI.FileBar
|
|||
)
|
||||
where
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Application.Context
|
||||
( Variables, UIElements )
|
||||
import MetaBrush.Application.Context
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory )
|
||||
import MetaBrush.Unique
|
||||
|
|
@ -17,25 +13,5 @@ import MetaBrush.Unique
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data FileBar
|
||||
= FileBar
|
||||
{ fileBarBox :: !GTK.Box
|
||||
, fileTabsBox :: !GTK.Box
|
||||
, fileBarPhantomToggleButton :: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
data FileBarTab
|
||||
= FileBarTab
|
||||
{ fileBarTab :: !GTK.Box
|
||||
, fileBarTabButton :: !GTK.ToggleButton
|
||||
, fileBarTabCloseArea :: !GTK.DrawingArea
|
||||
}
|
||||
|
||||
data TabLocation
|
||||
= AfterCurrentTab
|
||||
| LastTab
|
||||
|
||||
instance Show TabLocation
|
||||
|
||||
newFileTab :: UIElements -> Variables -> Maybe ( Unique, DocumentHistory ) -> TabLocation -> IO ()
|
||||
removeFileTab :: UIElements -> Variables -> Unique -> IO ()
|
||||
|
|
|
|||
|
|
@ -34,17 +34,18 @@ import qualified Control.Concurrent.STM.TVar as STM
|
|||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- MetaBrush
|
||||
-- brush-strokes
|
||||
import Math.Linear
|
||||
( ℝ(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Application.Context
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Asset.Cursor
|
||||
( drawCursorIcon )
|
||||
import MetaBrush.Asset.InfoBar
|
||||
( drawMagnifier, drawTopLeftCornerRect )
|
||||
import MetaBrush.Application.Context
|
||||
( Variables(..) )
|
||||
import MetaBrush.Document
|
||||
( DocumentMetadata(..), Zoom(..) )
|
||||
import MetaBrush.UI.Coordinates
|
||||
|
|
@ -54,13 +55,6 @@ import MetaBrush.GTK.Util
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data InfoBar
|
||||
= InfoBar
|
||||
{ infoBarArea :: !GTK.Box
|
||||
, zoomText :: !GTK.Label -- make this editable
|
||||
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
|
||||
}
|
||||
|
||||
-- | Add the UI elements for the info bar:
|
||||
--
|
||||
-- * current zoom level,
|
||||
|
|
|
|||
|
|
@ -1,24 +0,0 @@
|
|||
module MetaBrush.UI.InfoBar
|
||||
( InfoBar(..), updateInfoBar )
|
||||
where
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Application.Context
|
||||
( Variables )
|
||||
import MetaBrush.Document
|
||||
( DocumentMetadata )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data InfoBar
|
||||
= InfoBar
|
||||
{ infoBarArea :: !GTK.Box
|
||||
, zoomText :: !GTK.Label
|
||||
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
|
||||
}
|
||||
|
||||
updateInfoBar
|
||||
:: GTK.DrawingArea -> InfoBar -> Variables -> Maybe DocumentMetadata -> IO ()
|
||||
|
|
@ -42,13 +42,10 @@ import qualified Data.HashSet as HashSet
|
|||
import MetaBrush.Application.Action
|
||||
hiding ( save, saveAs )
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Asset.WindowIcons
|
||||
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
||||
import MetaBrush.UI.FileBar
|
||||
( TabLocation(..) )
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
|
|
|
|||
|
|
@ -25,10 +25,10 @@ import MetaBrush.GTK.Util
|
|||
|
||||
data PanelsBar
|
||||
= PanelsBar
|
||||
{ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox
|
||||
:: GTK.Box
|
||||
, strokesListView
|
||||
:: GTK.ListView
|
||||
{ layersScrolledWindow
|
||||
:: !GTK.ScrolledWindow
|
||||
, brushesPanelBox, transformPanelBox, historyPanelBox
|
||||
:: !GTK.Box
|
||||
}
|
||||
|
||||
-- | Creates the right hand side panel UI.
|
||||
|
|
@ -38,6 +38,7 @@ createPanelBar panelBox = do
|
|||
widgetAddClass panelBox "panels"
|
||||
|
||||
pane1 <- GTK.panedNew GTK.OrientationVertical
|
||||
GTK.panedSetWideHandle pane1 True
|
||||
GTK.widgetSetVexpand pane1 True
|
||||
GTK.boxAppend panelBox pane1
|
||||
|
||||
|
|
@ -50,7 +51,9 @@ createPanelBar panelBox = do
|
|||
GTK.panedSetStartChild pane1 ( Just panels1 )
|
||||
GTK.panedSetEndChild pane1 ( Just panels2 )
|
||||
|
||||
strokesPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
layersScrolledWindow <- GTK.scrolledWindowNew
|
||||
GTK.scrolledWindowSetPolicy layersScrolledWindow GTK.PolicyTypeNever GTK.PolicyTypeAutomatic
|
||||
|
||||
brushesPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
transformPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
historyPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
|
@ -63,17 +66,18 @@ createPanelBar panelBox = do
|
|||
for_ [ strokesTab, brushesTab, transformTab, historyTab ] \ tab -> do
|
||||
widgetAddClasses tab [ "plain", "text", "panelTab" ]
|
||||
|
||||
for_ [ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do
|
||||
widgetAddClass layersScrolledWindow "panel"
|
||||
for_ [ brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do
|
||||
widgetAddClass panel "panel"
|
||||
|
||||
void $ GTK.notebookAppendPage panels1 strokesPanelBox ( Just strokesTab )
|
||||
void $ GTK.notebookAppendPage panels1 layersScrolledWindow ( Just strokesTab )
|
||||
void $ GTK.notebookAppendPage panels1 brushesPanelBox ( Just brushesTab )
|
||||
|
||||
void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab )
|
||||
void $ GTK.notebookAppendPage panels2 historyPanelBox ( Just historyTab )
|
||||
|
||||
GTK.notebookSetTabReorderable panels1 strokesPanelBox True
|
||||
GTK.notebookSetTabDetachable panels1 strokesPanelBox True
|
||||
GTK.notebookSetTabReorderable panels1 layersScrolledWindow True
|
||||
GTK.notebookSetTabDetachable panels1 layersScrolledWindow True
|
||||
GTK.notebookSetTabReorderable panels1 brushesPanelBox True
|
||||
GTK.notebookSetTabDetachable panels1 brushesPanelBox True
|
||||
|
||||
|
|
@ -90,8 +94,7 @@ createPanelBar panelBox = do
|
|||
GTK.boxAppend transformPanelBox transformContent
|
||||
GTK.boxAppend historyPanelBox historyContent
|
||||
|
||||
--GTK.boxAppend strokesPanelBox strokesListView
|
||||
|
||||
return $
|
||||
PanelsBar { strokesPanelBox, strokesListView = error "todo"
|
||||
, brushesPanelBox, transformPanelBox, historyPanelBox }
|
||||
PanelsBar { layersScrolledWindow
|
||||
, brushesPanelBox, transformPanelBox, historyPanelBox
|
||||
}
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
16
src/app/MetaBrush/UI/StrokeTreeView.hs-boot
Normal file
16
src/app/MetaBrush/UI/StrokeTreeView.hs-boot
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
module MetaBrush.UI.StrokeTreeView where
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Application.Context
|
||||
import MetaBrush.Unique
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newLayersListModel :: Variables -> Unique -> IO GTK.SingleSelection
|
||||
|
||||
switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO ()
|
||||
|
||||
newLayerView :: UIElements -> Variables -> IO GTK.ListView
|
||||
|
|
@ -28,36 +28,18 @@ import qualified Control.Concurrent.STM.TVar as STM
|
|||
( writeTVar )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Application.Context
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Asset.Cursor
|
||||
( drawCursorIcon )
|
||||
import MetaBrush.Asset.Tools
|
||||
( drawBug, drawBrush, drawMeta, drawPath, drawPen )
|
||||
import MetaBrush.Application.Context
|
||||
( Variables(..) )
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Tool
|
||||
= Selection
|
||||
| Pen
|
||||
deriving stock ( Show, Eq )
|
||||
|
||||
data Mode
|
||||
= PathMode
|
||||
| BrushMode
|
||||
| MetaMode
|
||||
deriving stock ( Show, Eq )
|
||||
|
||||
data ToolBar
|
||||
= ToolBar
|
||||
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
|
||||
:: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar
|
||||
createToolBar ( Variables {..} ) colours toolBar = do
|
||||
|
||||
|
|
|
|||
|
|
@ -1,29 +0,0 @@
|
|||
module MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..)
|
||||
, ToolBar(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Tool
|
||||
= Selection
|
||||
| Pen
|
||||
|
||||
instance Show Tool
|
||||
|
||||
data Mode
|
||||
= PathMode
|
||||
| BrushMode
|
||||
| MetaMode
|
||||
|
||||
instance Show Mode
|
||||
|
||||
data ToolBar
|
||||
= ToolBar
|
||||
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
|
||||
:: !GTK.ToggleButton
|
||||
}
|
||||
|
|
@ -56,12 +56,18 @@ data DocumentDiff
|
|||
data HierarchyDiff
|
||||
= NewLayer
|
||||
{ newUnique :: !Unique
|
||||
, newIsGroup :: !Bool
|
||||
, newPosition :: !ChildLayerPosition
|
||||
}
|
||||
| DeleteLayer
|
||||
{ delUnique :: !Unique
|
||||
, delIsGroup :: !Bool
|
||||
, delPosition :: !ChildLayerPosition
|
||||
}
|
||||
| DeletePoints
|
||||
{ deletedPoints :: !StrokePoints
|
||||
, deletedStrokes :: !( Set Unique )
|
||||
}
|
||||
| MoveLayer
|
||||
{ moveUnique :: !Unique
|
||||
, srcPos :: !ChildLayerPosition
|
||||
|
|
@ -113,10 +119,6 @@ data ContentDiff
|
|||
{ continuedStroke :: !Unique
|
||||
, newSegment :: !( Spline Open () () )
|
||||
}
|
||||
| DeletePoints
|
||||
{ deletedPoints :: !StrokePoints
|
||||
, deletedStrokes :: !( Set Unique)
|
||||
}
|
||||
| UpdateBrushParameters
|
||||
{ updateBrushStroke :: !Unique
|
||||
, updateBrushPoint :: !PointIndex
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ module MetaBrush.Document.History
|
|||
( DocumentHistory(..)
|
||||
, back, fwd, newHistory, newFutureStep
|
||||
, atStart, atEnd
|
||||
, affirmPresent
|
||||
, affirmPresentSaved
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -27,18 +27,22 @@ import Data.Generics.Product.Fields
|
|||
-- lens
|
||||
import Control.Lens
|
||||
( set )
|
||||
import Control.Lens.Tuple
|
||||
( _1, _2 )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..) )
|
||||
import MetaBrush.Document.Diff
|
||||
( HistoryDiff )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data DocumentHistory
|
||||
= History
|
||||
{ past :: !( Seq DocumentContent )
|
||||
{ past :: !( Seq ( DocumentContent, HistoryDiff ) )
|
||||
, present :: !Document
|
||||
, future :: ![ DocumentContent ]
|
||||
, future :: ![ ( HistoryDiff, DocumentContent ) ]
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
instance NFData DocumentHistory where
|
||||
|
|
@ -47,21 +51,29 @@ instance NFData DocumentHistory where
|
|||
|
||||
back :: DocumentHistory -> DocumentHistory
|
||||
back hist@( History { past = ps, present = c, future = fs } ) = case ps of
|
||||
Empty -> hist
|
||||
qs :|> q -> History { past = qs, present = c { documentContent = q }, future = documentContent c : fs }
|
||||
Empty
|
||||
-> hist
|
||||
qs :|> ( q, diff )
|
||||
-> History { past = qs
|
||||
, present = c { documentContent = q }
|
||||
, future = ( diff, documentContent c ) : fs }
|
||||
|
||||
fwd :: DocumentHistory -> DocumentHistory
|
||||
fwd hist@( History { past = ps, present = c, future = fs } ) = case fs of
|
||||
[] -> hist
|
||||
g : gs -> History { past = ps :|> documentContent c, present = c { documentContent = g }, future = gs }
|
||||
[]
|
||||
-> hist
|
||||
( diff, g ) : gs
|
||||
-> History { past = ps :|> ( documentContent c, diff )
|
||||
, present = c { documentContent = g }
|
||||
, future = gs }
|
||||
|
||||
newHistory :: Document -> DocumentHistory
|
||||
newHistory a = History { past = Empty, present = a, future = [] }
|
||||
|
||||
newFutureStep :: Int -> Document -> DocumentHistory -> DocumentHistory
|
||||
newFutureStep maxPastDocs a ( History { past = ps, present = c } ) =
|
||||
newFutureStep :: Int -> HistoryDiff -> Document -> DocumentHistory -> DocumentHistory
|
||||
newFutureStep maxPastDocs diff a ( History { past = ps, present = c } ) =
|
||||
History
|
||||
{ past = Seq.drop ( n - maxPastDocs ) ( ps :|> documentContent c )
|
||||
{ past = Seq.drop ( n - maxPastDocs ) ( ps :|> ( documentContent c, diff ) )
|
||||
, present = a
|
||||
, future = []
|
||||
}
|
||||
|
|
@ -77,11 +89,11 @@ atEnd hist = null ( future hist )
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
affirmPresent :: DocumentHistory -> DocumentHistory
|
||||
affirmPresent
|
||||
= set ( field' @"past" . traverse . field' @"unsavedChanges" )
|
||||
affirmPresentSaved :: DocumentHistory -> DocumentHistory
|
||||
affirmPresentSaved
|
||||
= set ( field' @"past" . traverse . _1 . field' @"unsavedChanges" )
|
||||
True
|
||||
. set ( field' @"present" . field' @"documentContent" . field' @"unsavedChanges" )
|
||||
False
|
||||
. set ( field' @"future" . traverse . field' @"unsavedChanges" )
|
||||
. set ( field' @"future" . traverse . _2 . field' @"unsavedChanges" )
|
||||
True
|
||||
|
|
|
|||
|
|
@ -305,9 +305,8 @@ encodeLayer =
|
|||
. JSON.Encoder.atOptKey' "locked" JSON.Encoder.bool ( if layerLocked layer then Just True else Nothing )
|
||||
. encodeLayerData
|
||||
|
||||
decodeLayer :: MonadIO m => UniqueSupply -> JSON.Decoder m Layer
|
||||
decodeLayer uniqueSupply = do
|
||||
layerUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply )
|
||||
decodeLayer :: MonadIO m => JSON.Decoder m Layer
|
||||
decodeLayer = do
|
||||
mbLayerName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text
|
||||
mbLayerVisible <- JSON.Decoder.atKeyOptional "visible" JSON.Decoder.bool
|
||||
mbLayerLocked <- JSON.Decoder.atKeyOptional "locked" JSON.Decoder.bool
|
||||
|
|
@ -317,11 +316,11 @@ decodeLayer uniqueSupply = do
|
|||
case mbLayerStroke of
|
||||
Nothing -> do
|
||||
let layerName = fromMaybe "Group" mbLayerName
|
||||
groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list ( decodeLayer uniqueSupply ) )
|
||||
pure ( GroupLayer { layerUnique, layerName, layerVisible, layerLocked, groupChildren } )
|
||||
groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list decodeLayer )
|
||||
pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } )
|
||||
Just layerStroke -> do
|
||||
let layerName = fromMaybe "Stroke" mbLayerName
|
||||
pure ( StrokeLayer { layerUnique, layerName, layerVisible, layerLocked, layerStroke } )
|
||||
pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } )
|
||||
|
||||
encodeGuide :: Applicative f => JSON.Encoder f Guide
|
||||
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
|
||||
|
|
@ -335,31 +334,6 @@ decodeGuide uniqueSupply = do
|
|||
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) )
|
||||
pure ( guideUnique, Guide { guidePoint, guideNormal } )
|
||||
|
||||
encodeDocumentContent :: Applicative f => JSON.Encoder f ( LayerMetadata, DocumentContent )
|
||||
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( layerMetadata, Content { strokeHierarchy } ) ->
|
||||
JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) $
|
||||
strokeHierarchyLayers layerMetadata strokeHierarchy
|
||||
|
||||
decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m ( LayerMetadata, DocumentContent )
|
||||
decodeDocumentContent uniqueSupply = do
|
||||
let
|
||||
unsavedChanges :: Bool
|
||||
unsavedChanges = False
|
||||
layers <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list $ decodeLayer uniqueSupply )
|
||||
let ( layerMetadata, strokeHierarchy ) = layersStrokeHierarchy layers
|
||||
pure ( layerMetadata, Content { unsavedChanges, strokeHierarchy } )
|
||||
|
||||
|
||||
encodeDocumentMetadata :: Applicative f => JSON.Encoder f DocumentMetadata
|
||||
encodeDocumentMetadata =
|
||||
JSON.Encoder.mapLikeObj
|
||||
\ ( Metadata { documentName, viewportCenter, documentZoom, documentGuides } ) ->
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text documentName
|
||||
. JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor documentZoom )
|
||||
. JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems documentGuides )
|
||||
|
||||
|
||||
decodeDocumentMetadata
|
||||
:: MonadIO m
|
||||
=> UniqueSupply
|
||||
|
|
@ -367,31 +341,41 @@ decodeDocumentMetadata
|
|||
-> LayerMetadata
|
||||
-> JSON.Decoder m DocumentMetadata
|
||||
decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do
|
||||
documentName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) )
|
||||
zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
|
||||
guides <- JSON.Decoder.atKey "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply )
|
||||
documentName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text
|
||||
viewportCenter <- JSON.Decoder.atKeyOptional "center" ( decoder @( ℝ 2 ) )
|
||||
zoomFactor <- JSON.Decoder.atKeyOptional "zoom" ( decoder @Double )
|
||||
guides <- JSON.Decoder.atKeyOptional "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply )
|
||||
pure $
|
||||
Metadata
|
||||
{ documentName
|
||||
{ documentName = fromMaybe "Document" documentName
|
||||
, documentFilePath = mbFilePath
|
||||
, viewportCenter
|
||||
, documentZoom = Zoom { zoomFactor }
|
||||
, documentGuides = Map.fromList guides
|
||||
, viewportCenter = fromMaybe ( ℝ2 0 0 ) viewportCenter
|
||||
, documentZoom = maybe ( Zoom 1 ) Zoom zoomFactor
|
||||
, documentGuides = Map.fromList $ fromMaybe [] guides
|
||||
, layerMetadata
|
||||
, selectedPoints = mempty
|
||||
}
|
||||
|
||||
encodeDocument :: Applicative f => JSON.Encoder f Document
|
||||
encodeDocument = JSON.Encoder.mapLikeObj
|
||||
\ ( Document { documentMetadata, documentContent } ) ->
|
||||
\ ( Document { documentMetadata = meta, documentContent } ) ->
|
||||
JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version )
|
||||
. JSON.Encoder.atKey' "metadata" encodeDocumentMetadata documentMetadata
|
||||
. JSON.Encoder.atKey' "content" encodeDocumentContent ( layerMetadata documentMetadata, documentContent )
|
||||
. JSON.Encoder.atKey' "name" JSON.Encoder.text ( documentName meta )
|
||||
. JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) ( viewportCenter meta )
|
||||
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor $ documentZoom meta )
|
||||
. JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems $ documentGuides meta )
|
||||
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) )
|
||||
|
||||
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
|
||||
decodeDocument uniqueSupply mbFilePath = do
|
||||
( layerMetadata, documentContent ) <-
|
||||
JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
|
||||
documentMetadata <- JSON.Decoder.atKey "metadata" $ decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
|
||||
let
|
||||
unsavedChanges :: Bool
|
||||
unsavedChanges = False
|
||||
mbLayers1 <- JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer )
|
||||
-- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes').
|
||||
mbLayers2 <- JSON.Decoder.atKeyOptional "content" ( JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) )
|
||||
let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 )
|
||||
( layerMetadata, strokeHierarchy ) <- lift $ ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers
|
||||
let documentContent = Content { unsavedChanges, strokeHierarchy }
|
||||
documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
|
||||
pure ( Document { documentMetadata, documentContent } )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
module MetaBrush.Layer where
|
||||
|
||||
-- base
|
||||
import Data.Maybe
|
||||
( fromJust )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
|
|
@ -86,3 +88,24 @@ emptyHierarchy =
|
|||
, groups = Map.empty
|
||||
, content = Map.empty
|
||||
}
|
||||
|
||||
lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ]
|
||||
lookupChildren p h = fromJust $ lookupChildren_maybe p h
|
||||
|
||||
lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
|
||||
lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel
|
||||
lookupChildren_maybe ( Parent u ) ( Hierarchy { groups } ) = groups Map.!? u
|
||||
|
||||
insertGroup :: Parent Unique -> [ Unique ] -> Hierarchy a -> Hierarchy a
|
||||
insertGroup Root us h = h { topLevel = us }
|
||||
insertGroup ( Parent u ) us h = h { groups = Map.insert u us ( groups h ) }
|
||||
|
||||
-- | Delete the key of a layer in a 'Hierarchy'.
|
||||
--
|
||||
-- Does not remove it from any child lists, just from the "keys" of the maps.
|
||||
deleteLayerKey :: Unique -> Hierarchy a -> ( Hierarchy a, Maybe [ Unique ] )
|
||||
deleteLayerKey u ( Hierarchy tl gs cs ) =
|
||||
case Map.updateLookupWithKey ( \ _ _ -> Nothing ) u gs of
|
||||
( mbChildren, gs' ) ->
|
||||
let cs' = Map.delete u cs
|
||||
in ( Hierarchy tl gs' cs', mbChildren )
|
||||
|
|
|
|||
|
|
@ -4,6 +4,8 @@
|
|||
module MetaBrush.Stroke where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( (***) )
|
||||
import Control.Monad.ST
|
||||
( RealWorld )
|
||||
import Data.Coerce
|
||||
|
|
@ -52,9 +54,13 @@ import Data.Text
|
|||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.State.Strict
|
||||
( State )
|
||||
import qualified Control.Monad.State.Strict as State
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO )
|
||||
import Control.Monad.Trans.Reader
|
||||
( ReaderT )
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( StateT )
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
|
||||
-- brush-strokes
|
||||
import Math.Bezier.Spline
|
||||
|
|
@ -73,10 +79,13 @@ import Math.Linear
|
|||
-- MetaBrush
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush, PointFields )
|
||||
import MetaBrush.Layer hiding ( Layer(..) )
|
||||
import MetaBrush.Layer
|
||||
( Hierarchy(..), LayerMetadata(..), emptyHierarchy )
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
( Unique, UniqueSupply, freshUnique )
|
||||
import MetaBrush.Util
|
||||
( (!) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -273,12 +282,12 @@ forStrokeHierarchy
|
|||
let
|
||||
meta =
|
||||
StrokeMetadata
|
||||
{ strokeName = layerNames Map.! u
|
||||
{ strokeName = layerNames ! u
|
||||
, strokeVisible = vis'
|
||||
, strokeLocked = lock'
|
||||
}
|
||||
in
|
||||
insertMaybe par u <$> acc <*> f u ( content hierarchy0 Map.! u ) meta
|
||||
insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta
|
||||
Just ds ->
|
||||
foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
|
||||
|
||||
|
|
@ -294,15 +303,13 @@ type Layers = [ Layer ]
|
|||
-- Used for serialisation/deserialisation only.
|
||||
data Layer
|
||||
= StrokeLayer
|
||||
{ layerUnique :: !Unique
|
||||
, layerName :: !Text
|
||||
{ layerName :: !Text
|
||||
, layerVisible :: !Bool
|
||||
, layerLocked :: !Bool
|
||||
, layerStroke :: !Stroke
|
||||
}
|
||||
| GroupLayer
|
||||
{ layerUnique :: !Unique
|
||||
, layerName :: !Text
|
||||
{ layerName :: !Text
|
||||
, layerVisible :: !Bool
|
||||
, layerLocked :: !Bool
|
||||
, groupChildren :: !Layers
|
||||
|
|
@ -317,50 +324,44 @@ strokeHierarchyLayers
|
|||
go :: Unique -> Layer
|
||||
go layerUnique =
|
||||
let
|
||||
layerName = layerNames Map.! layerUnique
|
||||
layerName = layerNames ! layerUnique
|
||||
layerVisible = not $ layerUnique `Set.member` invisibleLayers
|
||||
layerLocked = layerUnique `Set.member` lockedLayers
|
||||
in
|
||||
case Map.lookup layerUnique hierarchy of
|
||||
Nothing ->
|
||||
StrokeLayer
|
||||
{ layerUnique, layerName, layerVisible, layerLocked
|
||||
, layerStroke = content Map.! layerUnique
|
||||
{ layerName, layerVisible, layerLocked
|
||||
, layerStroke = content ! layerUnique
|
||||
}
|
||||
Just cs ->
|
||||
GroupLayer
|
||||
{ layerUnique, layerName, layerVisible, layerLocked
|
||||
{ layerName, layerVisible, layerLocked
|
||||
, groupChildren = map go cs
|
||||
}
|
||||
|
||||
layersStrokeHierarchy :: Layers -> ( LayerMetadata, StrokeHierarchy )
|
||||
layersStrokeHierarchy lays = ( `State.execState` ( mempty, emptyHierarchy ) ) $ do
|
||||
{-# INLINEABLE layersStrokeHierarchy #-}
|
||||
layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )
|
||||
layersStrokeHierarchy lays = ( `State.execStateT` ( mempty, emptyHierarchy ) ) $ do
|
||||
us <- traverse go lays
|
||||
State.modify' ( \ ( meta, hierarchy ) -> ( meta, hierarchy { topLevel = us } ) )
|
||||
where
|
||||
go :: Layer -> State ( LayerMetadata, StrokeHierarchy ) Unique
|
||||
go :: Layer -> StateT ( LayerMetadata, StrokeHierarchy ) ( ReaderT UniqueSupply m ) Unique
|
||||
go l = do
|
||||
( LayerMetadata { layerNames = nms, invisibleLayers = invis, lockedLayers = locked }
|
||||
, oldHierarchy@( Hierarchy _topLevel oldGroups oldStrokes )
|
||||
) <- State.get
|
||||
let u = layerUnique l
|
||||
newMeta =
|
||||
u <- freshUnique
|
||||
let updMeta ( LayerMetadata nms invis locked ) =
|
||||
LayerMetadata
|
||||
{ layerNames = Map.insert u ( layerName l ) nms
|
||||
, invisibleLayers = if layerVisible l then invis else Set.insert u invis
|
||||
, lockedLayers = if layerLocked l then Set.insert u locked else locked
|
||||
}
|
||||
newHierarchy <-
|
||||
case l of
|
||||
updHierarchy <- case l of
|
||||
StrokeLayer { layerStroke } ->
|
||||
return $
|
||||
oldHierarchy
|
||||
{ content = Map.insert u layerStroke oldStrokes }
|
||||
return $ \ h -> h { content = Map.insert u layerStroke ( content h ) }
|
||||
GroupLayer { groupChildren } -> do
|
||||
us <- traverse go groupChildren
|
||||
return $
|
||||
oldHierarchy { groups = Map.insert u us oldGroups }
|
||||
State.put ( newMeta, newHierarchy )
|
||||
return $ \ h -> h { groups = Map.insert u us ( groups h ) }
|
||||
State.modify' ( updMeta *** updHierarchy )
|
||||
return u
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -46,9 +46,6 @@ import Control.Monad.Reader
|
|||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar, newTVarIO, readTVar, writeTVar )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
|
|
@ -96,15 +93,13 @@ class Monad m => MonadUnique m where
|
|||
instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where
|
||||
freshUnique = do
|
||||
UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply )
|
||||
liftIO $ STM.atomically do
|
||||
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
|
||||
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
|
||||
pure uniq
|
||||
liftIO $ STM.atomically $ STM.stateTVar uniqueSupplyTVar doSucc
|
||||
|
||||
instance MonadUnique ( ReaderT UniqueSupply STM ) where
|
||||
freshUnique = do
|
||||
UniqueSupply { uniqueSupplyTVar } <- ask
|
||||
lift do
|
||||
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
|
||||
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
|
||||
pure uniq
|
||||
lift $ STM.stateTVar uniqueSupplyTVar doSucc
|
||||
|
||||
doSucc :: Unique -> ( Unique, Unique )
|
||||
doSucc uniq@( Unique !i ) = ( uniq, Unique ( succ i ) )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,25 @@
|
|||
module MetaBrush.Util
|
||||
( Exists(..)
|
||||
, (!)
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import GHC.Stack
|
||||
( HasCallStack )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Exists c where
|
||||
Exists :: c a => a -> Exists c
|
||||
|
||||
infixl 9 !
|
||||
(!) :: ( Show k, Ord k, HasCallStack ) => Map k a -> k -> a
|
||||
m ! k = case Map.lookup k m of
|
||||
Nothing -> error $ "MetaBrush internal error: key not in map: " ++ show k
|
||||
Just a -> a
|
||||
Loading…
Reference in a new issue