mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
remove stroke from list stores when deleting all stroke points
This commit is contained in:
parent
d8c83140e7
commit
60b65a38e1
|
@ -14,6 +14,7 @@ import Data.Function
|
|||
( on )
|
||||
import Data.List
|
||||
( uncons )
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe
|
||||
( catMaybes, fromMaybe, isNothing )
|
||||
import Data.String
|
||||
|
@ -135,7 +136,7 @@ import MetaBrush.UI.InfoBar
|
|||
import MetaBrush.UI.FileBar
|
||||
( newFileTab, removeFileTab )
|
||||
import MetaBrush.UI.StrokeTreeView
|
||||
( applyDiffToListModel )
|
||||
( applyDeletionToStrokeHierarchy, applyDiffToListModel )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
|
@ -659,14 +660,29 @@ instance HandleAction Delete where
|
|||
Nothing ->
|
||||
pure Don'tModifyDoc
|
||||
Just ( doc', affectedPoints, delStrokes ) -> do
|
||||
-- TODO: only a hierarchy diff if there are
|
||||
-- any deleted strokes.
|
||||
let diff = HistoryDiff $ HierarchyDiff $
|
||||
DeletePoints
|
||||
{ deletedPoints = affectedPoints
|
||||
, deletedStrokes = delStrokes
|
||||
}
|
||||
let delStrokeList = Map.toList delStrokes
|
||||
diff = case NE.nonEmpty delStrokeList of
|
||||
Nothing ->
|
||||
HistoryDiff $ ContentDiff $ DeletePoints affectedPoints
|
||||
Just delStrokesNE ->
|
||||
let
|
||||
-- TODO: here we are re-doing the deletion, but using 'applyChangeToLayerHierarchy'
|
||||
-- as this gives us the child indices we need for the list model update.
|
||||
-- It would be better to refactor this to avoid going around the houses.
|
||||
( _hierarchy', deletedLayers ) =
|
||||
applyDeletionToStrokeHierarchy
|
||||
( strokeHierarchy $ documentContent doc )
|
||||
-- NB: original doc, not doc'!
|
||||
-- (we don't want to attempt to delete what has already been deleted)
|
||||
( fmap (uncurry $ flip WithinParent) delStrokesNE )
|
||||
in
|
||||
HistoryDiff $ HierarchyDiff $
|
||||
DeleteLayers
|
||||
{ deletedPoints = affectedPoints
|
||||
, deletedLayers
|
||||
}
|
||||
pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
|
||||
|
||||
-- TODO: handle deletion of layers by checking the current focus.
|
||||
_ -> pure ()
|
||||
|
||||
|
|
|
@ -113,6 +113,7 @@ import MetaBrush.Unique
|
|||
( Unique )
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
import MetaBrush.Layer (WithinParent(..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -253,7 +254,7 @@ getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
|
|||
forStrokeHierarchy
|
||||
( layerMetadata documentMetadata )
|
||||
( strokeHierarchy documentContent )
|
||||
( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
|
||||
( \ ( WithinParent _ uniq ) stroke ( StrokeMetadata { strokeVisible } ) -> do
|
||||
when strokeVisible $
|
||||
Writer.tell [ ( Just uniq, stroke ) ]
|
||||
return PreserveStroke
|
||||
|
|
|
@ -2,16 +2,30 @@
|
|||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module MetaBrush.UI.StrokeTreeView where
|
||||
module MetaBrush.UI.StrokeTreeView
|
||||
( newLayersListModel
|
||||
, newLayerView
|
||||
, switchStrokeView
|
||||
, applyDeletionToStrokeHierarchy
|
||||
, applyChangeToLayerHierarchy
|
||||
, applyDiffToListModel
|
||||
, getSelectedItem
|
||||
, DragSourceData(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( second )
|
||||
import Control.Monad
|
||||
( unless, void, when )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.List
|
||||
( elemIndex )
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe
|
||||
( fromJust, isJust, isNothing )
|
||||
import Data.Traversable
|
||||
|
@ -65,6 +79,8 @@ import Data.Text
|
|||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import Debug.Utils
|
||||
( trace )
|
||||
import MetaBrush.Application.Context
|
||||
import MetaBrush.Application.UpdateDocument
|
||||
import MetaBrush.Asset.Brushes
|
||||
|
@ -76,8 +92,6 @@ import MetaBrush.Document.History
|
|||
import MetaBrush.Layer
|
||||
import MetaBrush.Stroke hiding ( Layer(..) )
|
||||
import MetaBrush.Unique
|
||||
import MetaBrush.Util
|
||||
( (!) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -146,11 +160,12 @@ newLayersListModel ( Variables { .. } ) docUnique = do
|
|||
mbDocHist <- Map.lookup docUnique <$> STM.readTVar openDocumentsTVar
|
||||
mbDocStore <- Map.lookup docUnique <$> STM.readTVar parStoresTVar
|
||||
store <- case mbDocStore of
|
||||
Nothing -> do
|
||||
Just store
|
||||
| Just rootStore <- Map.lookup Root store
|
||||
-> return rootStore
|
||||
_ -> do
|
||||
STM.modifyTVar' parStoresTVar ( Map.insert docUnique ( Map.singleton Root store0 ) )
|
||||
return store0
|
||||
Just store ->
|
||||
return ( store ! Root )
|
||||
return ( store, mbDocHist )
|
||||
|
||||
for_ mbDocHist $ \ activeDocHist -> do
|
||||
|
@ -205,8 +220,9 @@ newLayersListModel ( Variables { .. } ) docUnique = do
|
|||
-- Try to re-use an existing list store, if there is one.
|
||||
mbOldChildStore <-
|
||||
STM.atomically $ do
|
||||
mbOldStore <-
|
||||
Map.lookup ( Parent groupUnique ) . ( ! docUnique ) <$> STM.readTVar parStoresTVar
|
||||
parStores <- STM.readTVar parStoresTVar
|
||||
let mbOldStore =
|
||||
Map.lookup ( Parent groupUnique ) =<< Map.lookup docUnique parStores
|
||||
when ( isNothing mbOldStore ) $
|
||||
-- Take a lock to avoid creating multiple child stores
|
||||
-- for the same group.
|
||||
|
@ -759,7 +775,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
|||
|
||||
-- All we do is set the name and visibility of this layer/group.
|
||||
|
||||
let layerText = layerNames meta ! layerUnique layer
|
||||
let mbLayerText = Map.lookup ( layerUnique layer ) ( layerNames meta )
|
||||
layerVisible = not $ Set.member ( layerUnique layer ) ( invisibleLayers meta )
|
||||
|
||||
mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
|
||||
|
@ -770,7 +786,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
|||
|
||||
GTK.widgetSetVisible checkButton True
|
||||
GTK.checkButtonSetActive checkButton layerVisible
|
||||
GTK.editableSetText layerLabel layerText
|
||||
for_ mbLayerText $ GTK.editableSetText layerLabel
|
||||
|
||||
listView <- GTK.listViewNew ( Nothing @GTK.SingleSelection ) ( Just layersListFactory )
|
||||
return listView
|
||||
|
@ -906,8 +922,8 @@ data LayerChange
|
|||
, newIsGroup :: !Bool
|
||||
, newSelected :: !( Maybe ChildLayer )
|
||||
}
|
||||
| Delete
|
||||
{ deleteItem :: !ChildLayer
|
||||
| DeleteItems
|
||||
{ deleteItems :: !( NE.NonEmpty ChildLayer )
|
||||
}
|
||||
| SetBrush
|
||||
{ setBrushStroke :: !ChildLayer
|
||||
|
@ -1112,45 +1128,63 @@ applyChangeToLayerHierarchy change hierarchy =
|
|||
, newIsGroup
|
||||
}
|
||||
)
|
||||
Delete { deleteItem = WithinParent parUniq delUniq } ->
|
||||
let !( !hierarchy', childIx ) = removeLayerFromParent hierarchy ( parUniq, delUniq )
|
||||
!( !hierarchy'', mbHadChildren ) =
|
||||
deleteLayerKey delUniq hierarchy'
|
||||
in
|
||||
( hierarchy''
|
||||
, Map.empty
|
||||
, Just $
|
||||
DeleteLayer
|
||||
{ delPosition = WithinParent parUniq childIx
|
||||
, delUnique = delUniq
|
||||
, delIsGroup = isJust mbHadChildren
|
||||
}
|
||||
)
|
||||
SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
|
||||
DeleteItems { deleteItems } ->
|
||||
let
|
||||
oldStroke, newStroke :: Stroke
|
||||
oldStroke = content hierarchy ! strokeUnique
|
||||
newStroke = case setBrushName of
|
||||
Just brushNm
|
||||
| Just ( SomeBrush brush ) <- lookupBrush brushNm
|
||||
-> setStrokeBrush ( Just brush ) oldStroke
|
||||
_ -> setStrokeBrush Nothing oldStroke
|
||||
|
||||
strokeIx :: Word32
|
||||
strokeIx =
|
||||
let oldPar_cs = lookupChildren parUniq hierarchy
|
||||
in fromIntegral $ fromJust $ elemIndex strokeUnique oldPar_cs
|
||||
|
||||
hierarchy' = hierarchy { content = Map.insert strokeUnique newStroke ( content hierarchy ) }
|
||||
!( !hierarchy', delLayers ) = applyDeletionToStrokeHierarchy hierarchy deleteItems
|
||||
in
|
||||
( hierarchy'
|
||||
, Map.empty
|
||||
, Just $
|
||||
StrokeSetBrush
|
||||
{ changedBrushStroke = WithinParent parUniq strokeIx
|
||||
, newBrushName = setBrushName
|
||||
}
|
||||
, Just $ DeleteLayers mempty delLayers
|
||||
)
|
||||
SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
|
||||
case Map.lookup strokeUnique ( content hierarchy ) of
|
||||
Just oldStroke
|
||||
| Just oldPar_cs <- lookupChildren_maybe parUniq hierarchy
|
||||
, Just strokeIx <- elemIndex strokeUnique oldPar_cs
|
||||
->
|
||||
let
|
||||
newStroke :: Stroke
|
||||
newStroke =
|
||||
case setBrushName of
|
||||
Just brushNm
|
||||
| Just ( SomeBrush brush ) <- lookupBrush brushNm
|
||||
-> setStrokeBrush ( Just brush ) oldStroke
|
||||
_ -> setStrokeBrush Nothing oldStroke
|
||||
hierarchy' = hierarchy { content = Map.insert strokeUnique newStroke ( content hierarchy ) }
|
||||
in
|
||||
( hierarchy'
|
||||
, Map.empty
|
||||
, Just $
|
||||
StrokeSetBrush
|
||||
{ changedBrushStroke = WithinParent parUniq ( fromIntegral strokeIx )
|
||||
, newBrushName = setBrushName
|
||||
}
|
||||
)
|
||||
| otherwise
|
||||
-> trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
|
||||
, "could not find index within parent of stroke " ++ show strokeUnique
|
||||
, "parent: " ++ show parUniq ])
|
||||
( hierarchy, Map.empty, Nothing )
|
||||
Nothing ->
|
||||
trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
|
||||
, "no content for stroke with unique " ++ show strokeUnique ])
|
||||
( hierarchy, Map.empty, Nothing )
|
||||
|
||||
|
||||
applyDeletionToStrokeHierarchy :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
|
||||
applyDeletionToStrokeHierarchy hierarchy0 = go hierarchy0
|
||||
where
|
||||
go :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
|
||||
go h (WithinParent parUniq delUniq NE.:| items) =
|
||||
let !( !h', _ ) = removeLayerFromParent h ( parUniq, delUniq )
|
||||
!( _, !childIx ) = removeLayerFromParent hierarchy0 ( parUniq, delUniq )
|
||||
!( !h'', !mbChildren ) = deleteLayerKey delUniq h'
|
||||
in second ( Map.insertWith (++) parUniq
|
||||
[DeleteLayer { delPosition = childIx
|
||||
, delUnique = delUniq
|
||||
, delIsGroup = isJust mbChildren
|
||||
}] ) $ ( case items of { [] -> ( h'', Map.empty )
|
||||
; (i:is) -> ( go h'' (i NE.:| is) ) } )
|
||||
|
||||
-- | Apply a change to the 'ListModel' underlying the UI
|
||||
-- representation of the layer hierarchy.
|
||||
|
@ -1172,44 +1206,122 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
|
|||
-- parent --> list store used to hold its children
|
||||
--
|
||||
-- and use that child list store to perform updates.
|
||||
parStoreFromUniq <- ( ! docUnique ) <$> STM.readTVarIO parStoreTVar
|
||||
case diff of
|
||||
MoveLayer { srcPos = WithinParent srcPar srcIx
|
||||
, dstPos = WithinParent dstPar dstIx } -> do
|
||||
let srcStore = parStoreFromUniq ! srcPar
|
||||
dstStore = parStoreFromUniq ! dstPar
|
||||
case doOrUndo of
|
||||
Do -> do
|
||||
item <- fromJust <$> GIO.listModelGetItem srcStore srcIx
|
||||
GIO.listStoreRemove srcStore srcIx
|
||||
GIO.listStoreInsert dstStore dstIx item
|
||||
Undo -> do
|
||||
item <- fromJust <$> GIO.listModelGetItem dstStore dstIx
|
||||
GIO.listStoreRemove dstStore dstIx
|
||||
GIO.listStoreInsert srcStore srcIx item
|
||||
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> do
|
||||
let dstStore = parStoreFromUniq ! dstPar
|
||||
case doOrUndo of
|
||||
Do -> do
|
||||
item <- GI.new LayerItem []
|
||||
GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
|
||||
GIO.listStoreInsert dstStore dstIx item
|
||||
Undo ->
|
||||
GIO.listStoreRemove dstStore dstIx
|
||||
DeleteLayer { delPosition = WithinParent srcPar srcIx, delUnique, delIsGroup } -> do
|
||||
let srcStore = parStoreFromUniq ! srcPar
|
||||
case doOrUndo of
|
||||
Do -> GIO.listStoreRemove srcStore srcIx
|
||||
Undo -> do
|
||||
item <- GI.new LayerItem []
|
||||
GI.gobjectSetPrivateData item ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
|
||||
GIO.listStoreInsert srcStore srcIx item
|
||||
DeletePoints { deletedStrokes } ->
|
||||
unless ( null deletedStrokes ) $
|
||||
putStrLn "TODO: delete strokes"
|
||||
StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } -> do
|
||||
let changedStrokeStore = parStoreFromUniq ! changedPar
|
||||
GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
|
||||
|
||||
mbParStoreFromUniq <- Map.lookup docUnique <$> STM.readTVarIO parStoreTVar
|
||||
case mbParStoreFromUniq of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel'"
|
||||
, "failed to look up list store map for document with unique " ++ show docUnique ]
|
||||
Just parStoreFromUniq -> do
|
||||
case diff of
|
||||
MoveLayer { srcPos = WithinParent srcPar srcIx
|
||||
, dstPos = WithinParent dstPar dstIx } ->
|
||||
case Map.lookup srcPar parStoreFromUniq of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel' MoveLayer"
|
||||
, "failed to look up list store for source parent " ++ show srcPar ]
|
||||
Just srcStore ->
|
||||
case Map.lookup dstPar parStoreFromUniq of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel' MoveLayer"
|
||||
, "failed to look up list store for destination parent " ++ show dstPar ]
|
||||
Just dstStore ->
|
||||
case doOrUndo of
|
||||
Do -> do
|
||||
mbItem <- GIO.listModelGetItem srcStore srcIx
|
||||
case mbItem of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel' Do MoveLayer"
|
||||
, "failed to get item at index " ++ show srcIx ]
|
||||
Just item -> do
|
||||
GIO.listStoreRemove srcStore srcIx
|
||||
GIO.listStoreInsert dstStore dstIx item
|
||||
Undo -> do
|
||||
mbItem <- GIO.listModelGetItem dstStore dstIx
|
||||
case mbItem of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel' Undo MoveLayer"
|
||||
, "failed to get item at index " ++ show dstIx ]
|
||||
Just item -> do
|
||||
GIO.listStoreRemove dstStore dstIx
|
||||
GIO.listStoreInsert srcStore srcIx item
|
||||
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } ->
|
||||
case Map.lookup dstPar parStoreFromUniq of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel' NewLayer"
|
||||
, "failed to look up list store for parent " ++ show dstPar ]
|
||||
Just dstStore ->
|
||||
case doOrUndo of
|
||||
Do -> do
|
||||
item <- GI.new LayerItem []
|
||||
GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
|
||||
GIO.listStoreInsert dstStore dstIx item
|
||||
Undo ->
|
||||
GIO.listStoreRemove dstStore dstIx
|
||||
DeleteLayers _delPts delLayers ->
|
||||
Map.foldMapWithKey deleteLayersInParent delLayers
|
||||
where
|
||||
deleteLayersInParent _ [] = return ()
|
||||
deleteLayersInParent srcPar (l:ls) =
|
||||
case Map.lookup srcPar parStoreFromUniq of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel' DeleteLayers"
|
||||
, "failed to look up list store for parent " ++ show srcPar ]
|
||||
Just srcStore ->
|
||||
let sortedLays = NE.sortOn delPosition (l NE.:| ls)
|
||||
in
|
||||
if sequentialOn delPosition sortedLays
|
||||
then do
|
||||
(remLays, addLays) <-
|
||||
case doOrUndo of
|
||||
Do -> return ( fromIntegral ( length sortedLays ) , [] )
|
||||
Undo -> do
|
||||
newLays <- for sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup } ) -> do
|
||||
item <- GI.new LayerItem []
|
||||
GI.gobjectSetPrivateData item
|
||||
( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
|
||||
GObject.toObject item
|
||||
return ( 0, NE.toList newLays )
|
||||
GIO.listStoreSplice srcStore ( delPosition $ NE.head sortedLays ) remLays addLays
|
||||
else case doOrUndo of
|
||||
Do ->
|
||||
-- Delete later items first, otherwise indexing is wrong.
|
||||
for_ ( NE.reverse sortedLays ) $ \ ( DeleteLayer { delPosition = srcIx } ) ->
|
||||
GIO.listStoreRemove srcStore srcIx
|
||||
Undo ->
|
||||
-- Insert earlier items first, otherwise indexing is wrong.
|
||||
for_ sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup, delPosition = srcIx } ) -> do
|
||||
item <- GI.new LayerItem []
|
||||
GI.gobjectSetPrivateData item
|
||||
( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
|
||||
GIO.listStoreInsert srcStore srcIx item
|
||||
StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } ->
|
||||
case Map.lookup changedPar parStoreFromUniq of
|
||||
Nothing ->
|
||||
putStrLn $ unlines
|
||||
[ "internal error in 'applyDiffToListModel' StrokeSetBrush"
|
||||
, "failed to look up list store for parent " ++ show changedPar ]
|
||||
Just changedStrokeStore ->
|
||||
GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
|
||||
|
||||
sequentialOn :: forall a i. ( Num i, Ord i ) => ( a -> i ) -> NE.NonEmpty a -> Bool
|
||||
sequentialOn f ( a NE.:| as ) = go ( f a ) as
|
||||
where
|
||||
go :: i -> [ a ] -> Bool
|
||||
go _ [] = True
|
||||
go i (b:bs)
|
||||
| let j = f b
|
||||
, j == i + 1
|
||||
= go j bs
|
||||
| otherwise
|
||||
= False
|
||||
|
||||
-- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
|
||||
-- moving one layer or group around.
|
||||
|
@ -1251,13 +1363,22 @@ moveLayerUpdate src@( srcPar, srcUniq ) dst@( dstPar, _ ) hierarchy =
|
|||
-- was found within its parent.
|
||||
--
|
||||
-- NB: does not delete the layer itself.
|
||||
removeLayerFromParent :: StrokeHierarchy
|
||||
removeLayerFromParent :: HasCallStack
|
||||
=> StrokeHierarchy
|
||||
-> ( Parent Unique, Unique )
|
||||
-> ( StrokeHierarchy, Word32 )
|
||||
removeLayerFromParent hierarchy ( parent, u ) =
|
||||
let oldPar_cs = lookupChildren parent hierarchy
|
||||
newChildren = filter ( /= u ) oldPar_cs
|
||||
oldChildPos = fromIntegral $ fromJust $ elemIndex u oldPar_cs
|
||||
oldChildPos = case elemIndex u oldPar_cs of
|
||||
Nothing -> error $ unlines
|
||||
[ "internal error in 'removeLayerFromParent': could not find index within parent"
|
||||
, "parent: " ++ show parent
|
||||
, "child: " ++ show u
|
||||
, "children of parent: " ++ show oldPar_cs
|
||||
, "hierarchy: " ++ show hierarchy
|
||||
]
|
||||
Just i -> fromIntegral i
|
||||
in ( insertGroup parent newChildren hierarchy, oldChildPos )
|
||||
|
||||
-- | Add a layer to a parent in the 'StrokeHierarchy', returning the updated
|
||||
|
|
|
@ -42,6 +42,8 @@ import Data.Act
|
|||
( Act((•)), Torsor((-->)) )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Sequence
|
||||
( Seq )
|
||||
|
@ -99,6 +101,7 @@ import MetaBrush.Records
|
|||
import MetaBrush.Stroke
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
import MetaBrush.Layer (Parent, WithinParent (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Subdivision.
|
||||
|
@ -127,11 +130,11 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
|
|||
stripData :: Curve Open crvData ( PointData ptData ) -> Curve Open () ()
|
||||
stripData = bimapCurve ( \ _ -> () ) ( \ _ _ -> () )
|
||||
|
||||
subdivideStroke :: Unique -> Stroke -> StrokeMetadata
|
||||
subdivideStroke :: WithinParent Unique -> Stroke -> StrokeMetadata
|
||||
-> State
|
||||
( Maybe Subdivision )
|
||||
UpdateStroke
|
||||
subdivideStroke u stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
subdivideStroke ( WithinParent _ u ) stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
mbPrevSubdivision <- State.get
|
||||
let ( curves', subdivs ) =
|
||||
Writer.runWriter $
|
||||
|
@ -264,8 +267,8 @@ selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
|
|||
where
|
||||
Zoom { zoomFactor } = documentZoom documentMetadata
|
||||
|
||||
computeSelected :: Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
|
||||
computeSelected strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
||||
computeSelected :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
|
||||
computeSelected ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
||||
when ( strokeVisible ) $
|
||||
Except.withExcept ( strokeUnique , ) $
|
||||
bifoldSpline
|
||||
|
@ -314,8 +317,8 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
|
|||
inSelectionRange p =
|
||||
squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
|
||||
dragSelect :: Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
|
||||
dragSelect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
dragSelect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
|
||||
dragSelect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
when ( strokeVisible && not strokeLocked ) $
|
||||
ibifoldSpline
|
||||
( dragSelectSplineCurve strokeUnique ( splineStart strokeSpline ) )
|
||||
|
@ -449,8 +452,8 @@ selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) doc@( Document { documentC
|
|||
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
|
||||
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
|
||||
|
||||
selectRect :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||
selectRect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
||||
selectRect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||
selectRect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
||||
when strokeVisible $
|
||||
Writer.mapWriter ( second $ \ is -> StrokePoints ( Map.singleton strokeUnique is ) ) $
|
||||
bifoldSpline
|
||||
|
@ -507,8 +510,8 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
|||
selPts :: StrokePoints
|
||||
selPts = selectedPoints documentMetadata
|
||||
|
||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||
updateStroke u stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||
updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
let strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
|
||||
firstPointSel = FirstPoint `Set.member` strokeSelPts
|
||||
( spline', ( modPts, _ ) ) =
|
||||
|
@ -600,7 +603,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
|||
--
|
||||
-- Returns the updated document, together with info about how many points
|
||||
-- and strokes were deleted.
|
||||
deleteSelected :: Document -> Maybe ( Document, StrokePoints, Set Unique )
|
||||
deleteSelected :: Document -> Maybe ( Document, StrokePoints, Map Unique ( Parent Unique ) )
|
||||
deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
||||
let
|
||||
( newStrokes, ( delPts, delStrokes ) ) =
|
||||
|
@ -620,8 +623,8 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
|||
)
|
||||
where
|
||||
|
||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Set Unique ) UpdateStroke
|
||||
updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Map Unique ( Parent Unique ) ) UpdateStroke
|
||||
updateStroke ( WithinParent par u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||
| not strokeVisible || strokeLocked
|
||||
= return PreserveStroke
|
||||
| otherwise
|
||||
|
@ -637,10 +640,10 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
|||
return PreserveStroke
|
||||
else case mbSpline of
|
||||
Nothing -> do
|
||||
Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.singleton u )
|
||||
Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.singleton u par )
|
||||
return DeleteStroke
|
||||
Just spline' -> do
|
||||
Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.empty )
|
||||
Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.empty )
|
||||
return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
|
||||
|
||||
where
|
||||
|
@ -776,8 +779,8 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
|
|||
)
|
||||
where
|
||||
|
||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||
updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||
updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||
| not strokeVisible || strokeLocked || u /= dragStrokeUnique
|
||||
= return PreserveStroke
|
||||
| otherwise
|
||||
|
@ -923,8 +926,8 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
|||
|
||||
zoom = documentZoom $ documentMetadata
|
||||
|
||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
|
||||
updateStroke u
|
||||
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
|
||||
updateStroke ( WithinParent _ u )
|
||||
( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
|
||||
( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||
| strokeVisible
|
||||
|
|
|
@ -1,13 +1,17 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
module MetaBrush.Document.Diff where
|
||||
|
||||
-- base
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Set
|
||||
( Set )
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
|
@ -63,15 +67,10 @@ data HierarchyDiff
|
|||
, newIsGroup :: !Bool
|
||||
, newPosition :: !ChildLayerPosition
|
||||
}
|
||||
| DeleteLayer
|
||||
{ delUnique :: !Unique
|
||||
, delIsGroup :: !Bool
|
||||
, delPosition :: !ChildLayerPosition
|
||||
}
|
||||
| DeletePoints
|
||||
{ deletedPoints :: !StrokePoints
|
||||
, deletedStrokes :: !( Set Unique )
|
||||
}
|
||||
| DeleteLayers
|
||||
{ deletedPoints :: !StrokePoints
|
||||
, deletedLayers :: !( Map ( Parent Unique ) [ DeleteLayer ] )
|
||||
}
|
||||
| MoveLayer
|
||||
{ moveUnique :: !Unique
|
||||
, srcPos :: !ChildLayerPosition
|
||||
|
@ -84,6 +83,15 @@ data HierarchyDiff
|
|||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
data DeleteLayer
|
||||
= DeleteLayer
|
||||
{ delUnique :: !Unique
|
||||
, delIsGroup :: !Bool
|
||||
, delPosition :: !Word32
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | A subdivision of a single stroke.
|
||||
data Subdivision
|
||||
= Subdivision
|
||||
|
@ -123,6 +131,8 @@ data ContentDiff
|
|||
}
|
||||
| CloseStroke
|
||||
{ closedStroke :: !Unique }
|
||||
| DeletePoints
|
||||
{ deletedPoints :: !StrokePoints }
|
||||
| ContinueStroke
|
||||
{ continuedStroke :: !Unique
|
||||
, newSegment :: !( Spline Open () ( PointData () ) )
|
||||
|
|
|
@ -177,8 +177,8 @@ getOrCreateDrawAnchor uniqueSupply mbBrush c doc@( Document { documentContent =
|
|||
where
|
||||
zoom = documentZoom documentMetadata
|
||||
|
||||
findAnchor :: Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
|
||||
findAnchor strokeUnique ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
findAnchor :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
|
||||
findAnchor ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
when ( strokeVisible && not strokeLocked ) $
|
||||
findAnchorSpline strokeSpline
|
||||
return PreserveStroke
|
||||
|
@ -243,8 +243,8 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent
|
|||
in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
|
||||
where
|
||||
|
||||
updateStroke :: forall s. Unique -> Stroke -> ST s UpdateStroke
|
||||
updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
|
||||
updateStroke :: forall s. WithinParent Unique -> Stroke -> ST s UpdateStroke
|
||||
updateStroke ( WithinParent _ strokeUnique ) stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
|
||||
| strokeUnique == anchorStroke anchor
|
||||
, SOpen <- ssplineType @clo
|
||||
, let prevSpline0 = coCache @RealWorld @s oldSpline
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
module MetaBrush.Layer where
|
||||
|
||||
-- base
|
||||
import Data.Maybe
|
||||
( fromJust )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
( Generically(..), Generic )
|
||||
import GHC.Stack
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
|
@ -24,6 +23,8 @@ import Data.Text
|
|||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import Debug.Utils
|
||||
( trace )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
@ -89,8 +90,15 @@ emptyHierarchy =
|
|||
, content = Map.empty
|
||||
}
|
||||
|
||||
lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ]
|
||||
lookupChildren p h = fromJust $ lookupChildren_maybe p h
|
||||
lookupChildren :: HasCallStack => Parent Unique -> Hierarchy a -> [ Unique ]
|
||||
lookupChildren p h = case lookupChildren_maybe p h of
|
||||
Nothing ->
|
||||
trace ( unlines [ "internal error in 'lookupChildren'"
|
||||
, "no data for parent " ++ show p
|
||||
, ""
|
||||
, "call stack: " ++ prettyCallStack callStack ]
|
||||
) []
|
||||
Just cs -> cs
|
||||
|
||||
lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
|
||||
lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel
|
||||
|
|
|
@ -14,10 +14,11 @@ import Data.Foldable
|
|||
( foldr' )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Maybe
|
||||
( mapMaybe )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1 )
|
||||
import GHC.Stack
|
||||
( HasCallStack )
|
||||
import GHC.TypeLits
|
||||
( Symbol )
|
||||
import Unsafe.Coerce
|
||||
|
@ -75,17 +76,17 @@ import Math.Module
|
|||
)
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
import Debug.Utils
|
||||
( trace )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush, PointFields )
|
||||
import MetaBrush.Layer
|
||||
( Hierarchy(..), LayerMetadata(..), emptyHierarchy )
|
||||
( Hierarchy(..), LayerMetadata(..), emptyHierarchy, WithinParent (..), Parent (..) )
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Unique
|
||||
( Unique, UniqueSupply, freshUnique )
|
||||
import MetaBrush.Util
|
||||
( (!) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -274,44 +275,56 @@ forStrokeHierarchy
|
|||
. ( HasCallStack, Applicative f )
|
||||
=> LayerMetadata
|
||||
-> StrokeHierarchy
|
||||
-> ( Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
|
||||
-> ( WithinParent Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
|
||||
-> f StrokeHierarchy
|
||||
forStrokeHierarchy
|
||||
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f =
|
||||
foldr' ( g Nothing ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
|
||||
foldr' ( g Root ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
|
||||
where
|
||||
|
||||
insertMaybe :: Maybe Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
|
||||
insertMaybe :: Parent Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
|
||||
insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
|
||||
PreserveStroke -> old
|
||||
UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
|
||||
DeleteStroke ->
|
||||
let newStrokes = Map.delete u oldStrokes
|
||||
in case mbPar of
|
||||
Nothing ->
|
||||
Root ->
|
||||
Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
|
||||
Just par ->
|
||||
Parent par ->
|
||||
Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes
|
||||
|
||||
|
||||
g :: Maybe Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
|
||||
g :: Parent Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
|
||||
g par ( vis, lock ) u acc =
|
||||
let vis' = vis && not ( u `Set.member` invisibleLayers )
|
||||
lock' = lock || u `Set.member` lockedLayers
|
||||
in
|
||||
case Map.lookup u ( groups hierarchy0 ) of
|
||||
Nothing ->
|
||||
let
|
||||
meta =
|
||||
StrokeMetadata
|
||||
{ strokeName = layerNames ! u
|
||||
, strokeVisible = vis'
|
||||
, strokeLocked = lock'
|
||||
}
|
||||
in
|
||||
insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta
|
||||
case ( Map.lookup u layerNames, Map.lookup u ( content hierarchy0 ) ) of
|
||||
( Just strokeName, Just oldStroke ) ->
|
||||
let
|
||||
meta =
|
||||
StrokeMetadata
|
||||
{ strokeName
|
||||
, strokeVisible = vis'
|
||||
, strokeLocked = lock'
|
||||
}
|
||||
in
|
||||
insertMaybe par u <$> acc <*> f ( WithinParent par u ) oldStroke meta
|
||||
_ ->
|
||||
trace
|
||||
( unlines
|
||||
[ "internal error in 'forStrokeHierarchy'"
|
||||
, "failed to look up stroke with unique " ++ show u
|
||||
, ""
|
||||
, "call stack: " ++ prettyCallStack callStack
|
||||
]
|
||||
) acc
|
||||
|
||||
Just ds ->
|
||||
foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
|
||||
foldr' ( g ( Parent u ) ( vis', lock' ) ) acc ds
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -338,29 +351,48 @@ data Layer
|
|||
}
|
||||
deriving stock Show
|
||||
|
||||
strokeHierarchyLayers :: LayerMetadata -> StrokeHierarchy -> Layers
|
||||
strokeHierarchyLayers :: HasCallStack => LayerMetadata -> StrokeHierarchy -> Layers
|
||||
strokeHierarchyLayers
|
||||
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
|
||||
( Hierarchy topLevel hierarchy content ) = map go topLevel
|
||||
( Hierarchy topLevel hierarchy content ) = mapMaybe go topLevel
|
||||
where
|
||||
go :: Unique -> Layer
|
||||
go :: Unique -> Maybe Layer
|
||||
go layerUnique =
|
||||
let
|
||||
layerName = layerNames ! layerUnique
|
||||
layerVisible = not $ layerUnique `Set.member` invisibleLayers
|
||||
layerLocked = layerUnique `Set.member` lockedLayers
|
||||
in
|
||||
case Map.lookup layerUnique hierarchy of
|
||||
Nothing ->
|
||||
StrokeLayer
|
||||
{ layerName, layerVisible, layerLocked
|
||||
, layerStroke = content ! layerUnique
|
||||
}
|
||||
Just cs ->
|
||||
GroupLayer
|
||||
{ layerName, layerVisible, layerLocked
|
||||
, groupChildren = map go cs
|
||||
}
|
||||
Nothing
|
||||
| Just layerName <- Map.lookup layerUnique layerNames
|
||||
, Just layerStroke <- Map.lookup layerUnique content
|
||||
->
|
||||
Just $
|
||||
StrokeLayer
|
||||
{ layerName, layerVisible, layerLocked, layerStroke }
|
||||
| otherwise
|
||||
-> trace
|
||||
( unlines [ "internal error in 'strokeHierarchyLayers"
|
||||
, "could not retrieve data for layer with unique: " ++ show layerUnique
|
||||
, ""
|
||||
, "call stack: " ++ prettyCallStack callStack
|
||||
]
|
||||
) Nothing
|
||||
Just cs
|
||||
| Just layerName <- Map.lookup layerUnique layerNames
|
||||
-> Just $
|
||||
GroupLayer
|
||||
{ layerName, layerVisible, layerLocked
|
||||
, groupChildren = mapMaybe go cs
|
||||
}
|
||||
| otherwise
|
||||
-> trace
|
||||
( unlines [ "internal error in 'strokeHierarchyLayers"
|
||||
, "could not retrieve data for group with unique: " ++ show layerUnique
|
||||
, ""
|
||||
, "call stack: " ++ prettyCallStack callStack
|
||||
]
|
||||
) Nothing
|
||||
|
||||
{-# INLINEABLE layersStrokeHierarchy #-}
|
||||
layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )
|
||||
|
|
|
@ -1,25 +1,8 @@
|
|||
module MetaBrush.Util
|
||||
( Exists(..)
|
||||
, (!)
|
||||
)
|
||||
( 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