embed brushes inline into strokes

src/app/MetaBrush/Action.hs

@@ -219,9 +219,7 @@ instance HandleAction OpenFile where
             GIO.listModelGetItem files ( fromIntegral i ) >>?=
               ( GI.castTo GIO.File >=?=> GIO.fileGetPath )
         for_ fileNames \ filePath -> do
-          knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
+          mbDoc <- loadDocument uniqueSupply filePath
-          ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath
-          STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
           case mbDoc of
             Left errMessage -> warningDialog window filePath errMessage
             Right doc -> do
@@ -276,9 +274,7 @@ instance HandleAction OpenFolder where
           when exists do
             filePaths <- listDirectory folderPath
             for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
-              knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
+              mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
-              ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath </> filePath )
-              STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
               case mbDoc of
                 Left errMessage -> warningDialog window filePath errMessage
                 Right doc -> do

src/app/MetaBrush/Application.hs

@@ -69,8 +69,6 @@ import qualified GI.Gtk as GTK
 -- lens
 import Control.Lens
   ( (.~) )
-import Control.Lens.At
-  ( at )
 
 -- stm
 import qualified Control.Concurrent.STM as STM
@@ -92,12 +90,6 @@ import qualified Data.Text as Text
 import Control.Monad.Trans.Reader
   ( runReaderT )
 
--- unordered-containers
-import Data.HashMap.Strict
-  ( HashMap )
-import qualified Data.HashMap.Strict as HashMap
-  ( fromList )
-
 -- MetaBrush
 import Math.Bezier.Cubic.Fit
   ( FitParameters(..) )
@@ -116,7 +108,7 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Asset.Logo
   ( drawLogo )
 import MetaBrush.Brush
-  ( Brush, newBrushReference )
+  ( adaptBrush )
 import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , Modifier(..)
@@ -172,27 +164,22 @@ runApplication application = do
 
   uniqueSupply <- newUniqueSupply
 
-  circleBrush <- Asset.Brushes.circle uniqueSupply
+  circleBrush  <- Asset.Brushes.circle uniqueSupply
-  circleBrushUnique <- runReaderT freshUnique uniqueSupply
+  docUnique    <- runReaderT freshUnique uniqueSupply
-  docUnique         <- runReaderT freshUnique uniqueSupply
+  strokeUnique <- runReaderT freshUnique uniqueSupply
-  strokeUnique      <- runReaderT freshUnique uniqueSupply
 
   let
 
-    testBrushes :: HashMap Brush Unique
-    testBrushes = HashMap.fromList
-      [ ( circleBrush, circleBrushUnique ) ]
-
     testDocuments :: Map Unique DocumentHistory
     testDocuments = fmap newHistory $ uniqueMapFromList
       [ emptyDocument "Test" docUnique
       & ( field' @"documentContent" . field' @"strokes" ) .~
         [ Stroke
-          { strokeName     = "Stroke 1"
+          { strokeName    = "Stroke 1"
-          , strokeVisible  = True
+          , strokeVisible = True
-          , strokeUnique   = strokeUnique
+          , strokeUnique  = strokeUnique
-          , strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique
+          , strokeBrush   = Just $ adaptBrush @'[ "r" SuperRecord.:= Double ] circleBrush
-          , strokeSpline   =
+          , strokeSpline  =
             Spline
               { splineStart  = mkPoint ( Point2D 10 -20 ) 2
               , splineCurves = OpenCurves $ Seq.fromList
@@ -203,7 +190,6 @@ runApplication application = do
               }
           }
         ]
-      & ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush )
       ]
         where
           mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
@@ -213,7 +199,6 @@ runApplication application = do
   documentRenderTVar   <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
   activeDocumentTVar   <- STM.newTVarIO @( Maybe Unique )                        Nothing
   openDocumentsTVar    <- STM.newTVarIO @( Map Unique DocumentHistory )          testDocuments
-  brushesTVar          <- STM.newTVarIO @( HashMap Brush Unique )                testBrushes
   mousePosTVar         <- STM.newTVarIO @( Maybe ( Point2D Double ) )            Nothing
   mouseHoldTVar        <- STM.newTVarIO @( Maybe HoldAction )                    Nothing
   modifiersTVar        <- STM.newTVarIO @( Set Modifier )                        Set.empty

src/app/MetaBrush/Asset/Brushes.hs

@@ -4,9 +4,20 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module MetaBrush.Asset.Brushes where
 
+-- base
+import Data.Kind
+  ( Type )
+import Data.Type.Equality
+  ( (:~:)(Refl) )
+
+-- superrecord
+import qualified SuperRecord
+
 -- text
 import Data.Text
   ( Text )
@@ -16,15 +27,23 @@ import qualified Data.Text as Text
 -- MetaBrush
 import MetaBrush.Brush
   ( Brush(..) )
+import MetaBrush.MetaParameter.AST
+  ( BrushFunction, STypesI(..), eqTys
+  )
 import MetaBrush.MetaParameter.Driver
-  ( SomeBrushFunction(..), interpretBrush )
+  ( SomeBrushFunction(..)
+  , interpretBrush
+  )
 import MetaBrush.Unique
   ( UniqueSupply )
 
 --------------------------------------------------------------------------------
 
-circle :: UniqueSupply -> IO Brush
+circle
-circle uniqueSupply = mkBrush uniqueSupply name code
+  :: forall circleBrushFields
+  .  ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] )
+  => UniqueSupply -> IO ( Brush circleBrushFields )
+circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code
   where
     name, code :: Text
     name = "Circle"
@@ -40,8 +59,12 @@ circle uniqueSupply = mkBrush uniqueSupply name code
      \          -- (-r  ,-r*c) -- (-r*c,-r  ) -> ( 0,-r)\n\
      \          -- ( r*c,-r  ) -- ( r  ,-r*c) ->   .   ]"
 
-rounded :: UniqueSupply -> IO Brush
+{-
-rounded uniqueSupply = mkBrush uniqueSupply name code
+rounded
+  :: forall roundedBrushFields
+  .  ( roundedBrushFields ~ '[ ] ) -- TODO
+  => UniqueSupply -> IO ( Brush roundedBrushFields )
+rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code
   where
     name, code :: Text
     name = "Rounded quadrilateral"
@@ -65,14 +88,25 @@ rounded uniqueSupply = mkBrush uniqueSupply name code
      \                                                                                                   -> lt\n\
      \       -- lerp c lt ( project tl onto [ lb -> lt ] ) -- lerp c tl ( project lt onto [ tr -> tl ] ) -> tl\n\
      \                                                                                                   -> .]"
+-}
 
 --------------------------------------------------------------------------------
 
-mkBrush :: UniqueSupply -> Text -> Text -> IO Brush
+mkBrush
+  :: forall ( givenBrushFields :: [ Type ] )
+  .  STypesI givenBrushFields
+  => UniqueSupply -> Text -> Text
+  -> IO ( Brush givenBrushFields )
 mkBrush uniqSupply brushName brushCode = do
   ( mbBrush, _ ) <- interpretBrush uniqSupply brushCode
   case mbBrush of
-    Left err ->
+    Left err -> error ( "Could not interpret '" <> Text.unpack brushName <> "' brush:\n" <> show err )
-      error ( "Could not interpret '" <> Text.unpack brushName <> "' brush:\n" <> show err )
+    Right ( SomeBrushFunction ( brushFunction :: BrushFunction inferredBrushFields ) ) ->
-    Right ( SomeBrushFunction brushFunction ) ->
+      case eqTys @givenBrushFields @inferredBrushFields of
-      pure ( BrushData { brushName, brushCode, brushFunction } )
+        Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
+        Nothing   ->
+          error
+            ( "Incorrect record type for '" <> Text.unpack brushName <> "' brush:\n\
+              \Expected: " <> show ( sTypesI @givenBrushFields ) <> "\n\
+              \  Actual: " <> show ( sTypesI @inferredBrushFields )
+            )

src/app/MetaBrush/Brush.hs

@@ -14,7 +14,8 @@
 {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 
 module MetaBrush.Brush
-  ( Brush(..), BrushReference(..), newBrushReference
+  ( Brush(..), SomeBrush(..)
+  , BrushAdaptedTo(..), adaptBrush
   , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups
   )
   where
@@ -88,8 +89,6 @@ import MetaBrush.MetaParameter.AST
   )
 import MetaBrush.MetaParameter.Interpolation
   ( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
-import MetaBrush.Unique
-  ( Unique )
 
 --------------------------------------------------------------------------------
 
@@ -97,7 +96,7 @@ whatever :: Int
 whatever = case Workaround of
   Workaround -> 0
 
-data Brush where
+data Brush brushFields where
   BrushData
     :: forall brushFields
     .  ( STypesI brushFields )
@@ -106,50 +105,53 @@ data Brush where
       , brushCode     :: !Text
       , brushFunction :: !( BrushFunction brushFields )
       }
-    -> Brush
+    -> Brush brushFields
 
-instance Show Brush where
+data SomeBrush where
-  show ( BrushData { brushName } ) = Text.unpack brushName
+  SomeBrush :: !( Brush brushFields ) -> SomeBrush
-instance NFData Brush where
+
+instance Show ( Brush brushFields ) where
+  show ( BrushData { brushName, brushCode } ) = 
+    "BrushData\n\
+    \  { brushName = "  <> Text.unpack brushName <> "\n\
+    \  , brushCode =\n" <> Text.unpack brushCode <> "\n\
+    \  }"
+instance NFData ( Brush brushFields ) where
   rnf ( BrushData { brushName, brushCode } )
     = deepseq brushCode
     $ rnf brushName
-instance Eq Brush where
+instance Eq ( Brush brushFields ) where
   BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2
-instance Ord Brush where
+instance Ord ( Brush brushFields ) where
   compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 )
-instance Hashable Brush where
+instance Hashable ( Brush brushFields ) where
   hashWithSalt salt ( BrushData { brushName, brushCode } ) =
     hashWithSalt ( hashWithSalt salt brushName ) brushCode
 
-data BrushReference pointFields where
+data BrushAdaptedTo pointFields where
-  NoBrush :: BrushReference pointFields
+  AdaptedBrush
-  BrushReference
     :: forall brushFields pointFields usedFields brushParams usedParams
     .  ( brushParams ~ Super.Rec brushFields, STypesI brushFields
        , usedParams  ~ Super.Rec usedFields
        , Interpolatable usedParams
        , Adapted brushFields pointFields usedFields
        )
-    => Proxy# brushFields
+    => !( Brush brushFields )
-    -> Unique
+    -> BrushAdaptedTo pointFields
-    -> BrushReference pointFields
+instance Show ( BrushAdaptedTo pointFields ) where
-instance Show ( BrushReference pointFields ) where
+  show ( AdaptedBrush ( brush :: Brush brushFields ) ) =
-  show NoBrush = "NoBrush"
+    "AdaptedBrush @(" <> show ( sTypesI @brushFields ) <> ") " <> show brush
-  show ( BrushReference ( _ :: Proxy# brushFields ) uniq ) =
+instance NFData ( BrushAdaptedTo pointFields ) where
-    "BrushReference @(" <> show ( sTypesI @brushFields ) <> ") " <> show uniq
+  rnf ( AdaptedBrush brush ) = rnf brush
-instance NFData ( BrushReference pointFields ) where
-  rnf NoBrush = ()
-  rnf ( BrushReference _ unique ) = rnf unique
 
 
-newBrushReference
+adaptBrush
-  :: forall brushFields pointFields
+  :: forall pointFields brushFields
   .  ( STypesI brushFields, STypesI pointFields )
-  => Unique
+  => Brush brushFields
-  -> BrushReference pointFields
+  -> BrushAdaptedTo pointFields
-newBrushReference uniq = case proveAdapted @brushFields @pointFields of
+adaptBrush brush = case proveAdapted @brushFields @pointFields of
-  Dict -> BrushReference ( proxy# :: Proxy# brushFields ) uniq
+  Dict -> AdaptedBrush brush
 
 --------------------------------------------------------------------------------
 -- Instance dictionary passing machinery.

src/app/MetaBrush/Context.hs

@@ -50,8 +50,6 @@ import {-# SOURCE #-} MetaBrush.Action
   ( ActionName )
 import MetaBrush.Asset.Colours
   ( Colours )
-import MetaBrush.Brush
-  ( Brush )
 import MetaBrush.Document.Draw
   ( DrawAnchor )
 import MetaBrush.Document.History
@@ -93,7 +91,6 @@ data Variables
   , documentRenderTVar   :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
   , activeDocumentTVar   :: !( STM.TVar ( Maybe Unique )                        )
   , openDocumentsTVar    :: !( STM.TVar ( Map Unique DocumentHistory )          )
-  , brushesTVar          :: !( STM.TVar ( HashMap Brush Unique )                )
   , mousePosTVar         :: !( STM.TVar ( Maybe ( Point2D Double ) )            )
   , mouseHoldTVar        :: !( STM.TVar ( Maybe HoldAction )                    )
   , modifiersTVar        :: !( STM.TVar ( Set Modifier )                        )

src/app/MetaBrush/Document.hs

@@ -105,7 +105,7 @@ import Math.Module
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Brush
-  ( Brush, BrushReference )
+  ( BrushAdaptedTo )
 import {-# SOURCE #-} MetaBrush.Document.Serialise
   ( Serialisable(..) )
 import MetaBrush.MetaParameter.AST
@@ -144,7 +144,6 @@ data Document
   , zoomFactor      :: !Double
   , documentUnique  :: Unique
   , documentContent :: !DocumentContent
-  , documentBrushes :: !( Map Unique Brush )
   }
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
@@ -175,15 +174,15 @@ data Stroke where
       { strokeName     :: !Text
       , strokeVisible  :: !Bool
       , strokeUnique   :: Unique
-      , strokeBrushRef :: !( BrushReference pointFields )
+      , strokeBrush    :: !( Maybe ( BrushAdaptedTo pointFields ) )
       , strokeSpline   :: !( StrokeSpline clo pointParams )
       }
     -> Stroke
 deriving stock instance Show Stroke
 instance NFData Stroke where
-  rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeBrushRef, strokeSpline } )
+  rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeBrush, strokeSpline } )
     = deepseq strokeSpline
-    . deepseq strokeBrushRef
+    . deepseq strokeBrush
     . deepseq strokeUnique
     . deepseq strokeVisible
     $ rnf strokeName
@@ -266,7 +265,6 @@ emptyDocument docName unique =
       , strokes        = []
       , guides         = Map.empty
       }
-    , documentBrushes = Map.empty
     }
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Document/Draw.hs

@@ -76,7 +76,7 @@ import Math.Vector2D
 import MetaBrush.Assert
   ( assert )
 import MetaBrush.Brush
-  ( BrushReference(NoBrush) )
+  ( BrushAdaptedTo )
 import MetaBrush.Document
   ( Document(..), DocumentContent(..), Stroke(..), StrokeSpline
   , FocusState(..), PointData(..)
@@ -135,11 +135,11 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
         newStroke :: Stroke
         newStroke =
           Stroke
-            { strokeName     = "Stroke " <> uniqueText uniq
+            { strokeName    = "Stroke " <> uniqueText uniq
-            , strokeVisible  = True
+            , strokeVisible = True
-            , strokeUnique   = uniq
+            , strokeUnique  = uniq
-            , strokeSpline   = newSpline
+            , strokeSpline  = newSpline
-            , strokeBrushRef = NoBrush
+            , strokeBrush   = Nothing
             }
         newDoc' :: Document
         newDoc'
@@ -238,7 +238,7 @@ withAnchorBrushData
        , Interpolatable pointParams
        , Serialisable pointParams
        )
-     => BrushReference pointFields
+     => Maybe ( BrushAdaptedTo pointFields )
      -> pointParams
      -> r
      )
@@ -247,10 +247,10 @@ withAnchorBrushData anchor ( Document { documentContent = Content { strokes } }
   splineAnchor . listToMaybe $ filter ( \ Stroke { strokeUnique } -> strokeUnique == anchorStrokeUnique anchor ) strokes
   where
     splineAnchor :: Maybe Stroke -> r
-    splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrushRef } ) )
+    splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) )
       | SOpen <- ssplineType @clo
       = case anchor of
-        AnchorAtStart {} -> f strokeBrushRef ( brushParams ( splineStart strokeSpline ) )
+        AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) )
-        AnchorAtEnd   {} -> f strokeBrushRef ( brushParams ( splineEnd   strokeSpline ) )
+        AnchorAtEnd   {} -> f strokeBrush ( brushParams ( splineEnd   strokeSpline ) )
     splineAnchor _
-      = f NoBrush SuperRecord.rnil
+      = f Nothing SuperRecord.rnil

src/app/MetaBrush/Document/Serialise.hs

@@ -22,7 +22,7 @@ module MetaBrush.Document.Serialise
 
 -- base
 import Control.Arrow
-  ( (&&&), first )
+  ( (&&&) )
 import Control.Monad
   ( unless )
 import Control.Monad.ST
@@ -68,7 +68,7 @@ import qualified Data.ByteString.Builder as Lazy.ByteString.Builder
 import Data.Map.Strict
   ( Map )
 import qualified Data.Map.Strict as Map
-  ( elems, empty, fromList, insert, lookup )
+  ( elems, fromList )
 import Data.Sequence
   ( Seq )
 import qualified Data.Sequence as Seq
@@ -117,7 +117,7 @@ import SuperRecord
 import Data.Text
   ( Text )
 import qualified Data.Text as Text
-  ( pack, unpack, unwords )
+  ( pack, unwords )
 
 -- transformers
 import Control.Monad.IO.Class
@@ -126,14 +126,6 @@ import Control.Monad.Trans.Class
   ( MonadTrans(lift) )
 import Control.Monad.Trans.Reader
   ( runReaderT )
-import Control.Monad.Trans.State.Strict
-  ( StateT, runStateT, get, put )
-
--- unordered-containers
-import Data.HashMap.Strict
-  ( HashMap )
-import qualified Data.HashMap.Strict as HashMap
-  ( foldrWithKey', insert, lookup )
 
 -- waargonaut
 import qualified Waargonaut.Attoparsec as JSON.Decoder
@@ -182,10 +174,9 @@ import Math.Bezier.Stroke
   ( CachedStroke(..) )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..), Segment )
-import MetaBrush.Assert
-  ( assert )
 import MetaBrush.Brush
-  ( Brush(..), BrushReference(..), newBrushReference
+  ( Brush(..), SomeBrush(..)
+  , BrushAdaptedTo(..), adaptBrush
   , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups
   )
 import MetaBrush.Document
@@ -194,10 +185,10 @@ import MetaBrush.Document
   , PointData(..), FocusState(..)
   )
 import MetaBrush.MetaParameter.AST
-  ( SType(..), STypeI(..), STypesI(..)
+  ( SType(..), STypeI(..)
   , SomeSType(..), someSTypes
-  , AdaptableFunction(..), BrushFunction
+  , AdaptableFunction(..)
-  , eqTy, eqTys
+  , eqTy
   )
 import MetaBrush.MetaParameter.Driver
   ( SomeBrushFunction(..), interpretBrush )
@@ -229,13 +220,12 @@ documentToJSON
 --
 -- Updates the store of brushes by adding any new brushes contained in the document.
 documentFromJSON
-  :: UniqueSupply -> HashMap Brush Unique
+  :: UniqueSupply
   -> Maybe FilePath
   -> Strict.ByteString
-  -> IO ( Either JSON.DecodeError Document, HashMap Brush Unique )
+  -> IO ( Either JSON.DecodeError Document )
-documentFromJSON uniqueSupply brushUniques mfp
+documentFromJSON uniqueSupply mfp
-  = fmap ( first $ Bifunctor.first fst )
+  = fmap ( Bifunctor.first fst )
-  . ( `runStateT` brushUniques )
   . JSON.Decoder.decodeAttoparsecByteString ( decodeDocument uniqueSupply mfp )
 
 --------------------------------------------------------------------------------
@@ -254,14 +244,12 @@ saveDocument path doc = do
   atomicReplaceFile Nothing path' ( documentToJSON doc )
 
 -- | Load a MetaBrush document.
---
+loadDocument :: UniqueSupply -> FilePath -> IO ( Either String Document )
--- Updates the store of brushes by adding any new brushes contained in the document.
+loadDocument uniqueSupply fp = do
-loadDocument :: UniqueSupply -> HashMap Brush Unique -> FilePath -> IO ( Either String Document, HashMap Brush Unique )
-loadDocument uniqueSupply brushUniques fp = do
   exists <- doesFileExist fp
   if exists
-  then first ( Bifunctor.first show ) <$> ( documentFromJSON uniqueSupply brushUniques ( Just fp ) =<< Strict.ByteString.readFile fp )
+  then Bifunctor.first show <$> ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp )
-  else pure ( Left $ "No file at " <> fp, brushUniques )
+  else pure ( Left $ "No file at " <> fp )
 
 --------------------------------------------------------------------------------
 
@@ -635,13 +623,13 @@ decodeFieldTypes = do
 
 
 
-encodeBrush :: Applicative f => JSON.Encoder f Brush
+encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushFields )
 encodeBrush = JSON.Encoder.mapLikeObj
   \ ( BrushData { brushName, brushCode } ) ->
     JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
   . JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode
 
-decodeBrush :: MonadIO m => UniqueSupply -> JSON.Decoder m Brush
+decodeBrush :: MonadIO m => UniqueSupply -> JSON.Decoder m SomeBrush
 decodeBrush uniqSupply = do
   brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
   brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text
@@ -649,17 +637,17 @@ decodeBrush uniqSupply = do
   case mbBrush of
     Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) )
     Right ( SomeBrushFunction brushFunction ) ->
-      pure ( BrushData { brushName, brushCode, brushFunction } )
+      pure ( SomeBrush $ BrushData { brushName, brushCode, brushFunction } )
 
 
 
-encodeStroke :: Monad f => Map Unique Brush -> JSON.Encoder f Stroke
+encodeStroke :: Monad f => JSON.Encoder f Stroke
-encodeStroke brushes = JSON.Encoder.mapLikeObj
+encodeStroke = JSON.Encoder.mapLikeObj
   \ ( Stroke
       { strokeName
       , strokeVisible
       , strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
-      , strokeBrushRef
+      , strokeBrush
       }
     ) ->
     let
@@ -668,22 +656,11 @@ encodeStroke brushes = JSON.Encoder.mapLikeObj
         SClosed -> True
         SOpen   -> False
       mbEncodeBrush :: JSON.MapLikeObj JSON.WS Json -> JSON.MapLikeObj JSON.WS Json
-      mbEncodeBrush = case strokeBrushRef of
+      mbEncodeBrush = case strokeBrush of
-        BrushReference ( _ :: Proxy# brushFields1 ) unique ->
+        Nothing ->
-          case Map.lookup unique brushes of
+          id
-            Nothing ->
+        Just ( AdaptedBrush brush ) ->
-              assert ( "encodeStroke: no brush with unique " <> show unique <> "in environment" )
+          JSON.Encoder.atKey' "brush" encodeBrush brush
-                id
-            Just ( brush@BrushData { brushName, brushFunction = ( _ :: BrushFunction brushFields2 ) } ) ->
-              case eqTys @brushFields1 @brushFields2 of
-                Nothing ->
-                  assert ( "encodeStroke: brush '" <> Text.unpack brushName <> "' has unexpected field types.\n\
-                           \Expected: " <> show ( sTypesI @brushFields1 ) <> "\n\
-                           \  Actual: " <> show ( sTypesI @brushFields2 )
-                         )
-                    id
-                Just Refl -> JSON.Encoder.atKey' "brush" encodeBrush brush
-        NoBrush -> id
     in
       JSON.Encoder.atKey' "name"        JSON.Encoder.text                strokeName
     . JSON.Encoder.atKey' "visible"     JSON.Encoder.bool                strokeVisible
@@ -692,34 +669,28 @@ encodeStroke brushes = JSON.Encoder.mapLikeObj
     . mbEncodeBrush
     . JSON.Encoder.atKey' "spline"      ( encodeSpline encodePointData ) strokeSpline
 
-decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder ( StateT ( HashMap Brush Unique ) m ) Stroke
+decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
 decodeStroke uniqueSupply = do
-  brushHashMap  <- lift get
   strokeName    <- JSON.Decoder.atKey "name"    JSON.Decoder.text
   strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
   strokeUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
   strokeClosed  <- JSON.Decoder.atKey "closed"  JSON.Decoder.bool
   SomeBrushFields ( _ :: Proxy# pointFields ) <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
   mbBrush       <- JSON.Decoder.atKeyOptional "brush" ( decodeBrush uniqueSupply )
-  strokeBrushRef <-
+  let
-    case mbBrush of
+    strokeBrush :: Maybe ( BrushAdaptedTo pointFields )
-      Nothing -> pure NoBrush
+    strokeBrush = case mbBrush of
-      Just ( brush@BrushData { brushFunction = _ :: BrushFunction brushFields } ) -> do
+      Nothing
-        brushUnique <-
+        -> Nothing
-          case HashMap.lookup brush brushHashMap of
+      Just ( SomeBrush ( brush@( BrushData {} ) ) )
-            Nothing -> do
+        -> Just $ adaptBrush @pointFields brush
-              brushUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
-              lift $ put ( HashMap.insert brush brushUnique brushHashMap )
-              pure brushUnique
-            Just brushUnique -> pure brushUnique
-        pure ( newBrushReference @brushFields brushUnique )
   if strokeClosed
   then do
     strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData )
-    pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrushRef } )
+    pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
   else do
     strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open   @( PointData ( Super.Rec pointFields ) ) decodePointData )
-    pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrushRef } )
+    pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
 
 
 
@@ -740,15 +711,12 @@ decodeGuide uniqueSupply = do
 
 
 
-encodeDocumentContent :: Applicative f => Map Unique Brush -> JSON.Encoder f DocumentContent
+encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
-encodeDocumentContent brushes = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
+encodeDocumentContent  = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
-    JSON.Encoder.atKey' "guides"  ( encodeUniqueMap encodeGuide )              guides
+    JSON.Encoder.atKey' "guides"  ( encodeUniqueMap   encodeGuide  ) guides
-  . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list $ encodeStroke brushes ) strokes
+  . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes
 
-decodeDocumentContent
+decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent
-  :: MonadIO m
-  => UniqueSupply
-  -> JSON.Decoder ( StateT ( HashMap Brush Unique ) m ) DocumentContent
 decodeDocumentContent uniqueSupply = do
   let
     unsavedChanges :: Bool
@@ -763,22 +731,18 @@ decodeDocumentContent uniqueSupply = do
 
 encodeDocument :: Applicative f => JSON.Encoder f Document
 encodeDocument = JSON.Encoder.mapLikeObj
-  \ ( Document { displayName, viewportCenter, zoomFactor, documentContent, documentBrushes } ) ->
+  \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
-    JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int )    ( versionBranch Cabal.version )
+    JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version )
-  . JSON.Encoder.atKey' "name"    JSON.Encoder.text                         displayName
+  . JSON.Encoder.atKey' "name"    JSON.Encoder.text                      displayName
-  . JSON.Encoder.atKey' "center"  ( encoder @( Point2D Double ) )           viewportCenter
+  . JSON.Encoder.atKey' "center"  ( encoder @( Point2D Double ) )        viewportCenter
-  . JSON.Encoder.atKey' "zoom"    ( encoder @Double )                       zoomFactor
+  . JSON.Encoder.atKey' "zoom"    ( encoder @Double )                    zoomFactor
-  . JSON.Encoder.atKey' "content" ( encodeDocumentContent documentBrushes ) documentContent
+  . JSON.Encoder.atKey' "content" encodeDocumentContent                  documentContent
 
-decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder ( StateT ( HashMap Brush Unique ) m ) Document
+decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
 decodeDocument uniqueSupply mbFilePath = do
   displayName     <- JSON.Decoder.atKey "name" JSON.Decoder.text
   viewportCenter  <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) )
   zoomFactor      <- JSON.Decoder.atKey "zoom"   ( decoder @Double )
   documentUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
   documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
-  brushUniques    <- lift get
+  pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } )
-  let
-    documentBrushes :: Map Unique Brush
-    documentBrushes = HashMap.foldrWithKey' ( flip Map.insert ) Map.empty brushUniques
-  pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent, documentBrushes } )

src/app/MetaBrush/Render/Document.hs

@@ -37,8 +37,6 @@ import Data.Int
   ( Int32 )
 import Data.Maybe
   ( mapMaybe )
-import Data.Type.Equality
-  ( (:~:)(Refl) )
 import GHC.Exts
   ( Proxy#, proxy# )
 import GHC.Generics
@@ -53,10 +51,6 @@ import Data.Act
   )
 
 -- containers
-import Data.Map.Strict
-  ( Map )
-import qualified Data.Map.Strict as Map
-  ( lookup )
 import Data.Sequence
   ( Seq(..) )
 import Data.Set
@@ -112,7 +106,7 @@ import Math.Vector2D
 import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Brush
-  ( Brush(..), BrushReference(..) )
+  ( Brush(..), BrushAdaptedTo(..) )
 import MetaBrush.Context
   ( Modifier(..)
   , HoldAction(..), PartialPath(..)
@@ -136,13 +130,13 @@ import MetaBrush.Document.Serialise
 import MetaBrush.Document.Update
   ( DocChange(..) )
 import MetaBrush.MetaParameter.AST
-  ( AdaptableFunction(..), BrushFunction, eqTys )
+  ( AdaptableFunction(..) )
 import MetaBrush.MetaParameter.Interpolation
   ( MapDiff )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
 import MetaBrush.Unique
-  ( Unique, unsafeUnique )
+  ( unsafeUnique )
 import MetaBrush.Util
   ( withRGBA )
 
@@ -179,7 +173,7 @@ getDocumentRender
 getDocumentRender
   cols fitParams mode debug  
   modifiers mbMousePos mbHoldEvent mbPartialPath
-  doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } )
+  doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
     = do
 
       let
@@ -212,7 +206,7 @@ getDocumentRender
             , Just finalPoint <- mbFinalPoint
             , let
                 previewStroke :: Stroke
-                previewStroke = withAnchorBrushData anchor doc \ brushRef ( pointData :: Super.Rec pointFields ) ->
+                previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Super.Rec pointFields ) ->
                   let
                     previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec pointFields ) )
                     previewSpline = catMaybesSpline ( invalidateCache undefined )
@@ -234,12 +228,12 @@ getDocumentRender
                       , strokeVisible  = True
                       , strokeUnique   = unsafeUnique 987654321
                       , strokeName     = "Preview stroke (temporary)"
-                      , strokeBrushRef = brushRef
+                      , strokeBrush    = mbBrush
                       }
               -> previewStroke : strokes content
           _ -> strokes content
 
-      strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams documentBrushes ) modifiedStrokes
+      strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams ) modifiedStrokes
 
       let
         renderSelectionRect :: Cairo.Render ()
@@ -299,27 +293,23 @@ instance NFData StrokeRenderData where
 --    - the computed outline (using fitting algorithm),
 --    - the brush shape function.
 -- - Otherwise, this consists of the underlying spline path only.
-strokeRenderData :: FitParameters -> Map Unique Brush -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
+strokeRenderData :: FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
-strokeRenderData fitParams brushes
+strokeRenderData fitParams
   ( Stroke
-    { strokeSpline   = spline :: StrokeSpline clo pointParams
+    { strokeSpline = spline :: StrokeSpline clo pointParams
-    , strokeBrushRef = ( strokeBrushRef :: BrushReference pointFields )
+    , strokeBrush  = ( strokeBrush :: Maybe ( BrushAdaptedTo pointFields ) )
     , ..
     }
   ) | strokeVisible
-    = Just $ case strokeBrushRef of
+    = Just $ case strokeBrush of
-        BrushReference ( _ :: Proxy# brushFields ) brushUnique
+        Just ( AdaptedBrush ( brush :: Brush brushFields ) )
-          -- TODO: could emit a warning if the following lookup fails.
+          | ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
-          | Just ( BrushData { brushFunction = AdaptableFunction brushFn :: BrushFunction brushFields' } ) <- Map.lookup brushUnique brushes
-          -- TODO: the following check could be skipped if we are feeling confident.
-          , Just Refl <- eqTys @brushFields @brushFields' -- Refl <- ( unsafeCoerce Refl :: brushFields :~: brushFields' )
-          , ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
           , let
-              -- Get the adaptable brush shape (function),
-              -- specialising it to the type we are using.
               toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
               brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
-              ( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
+              AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush
+              -- Get the adaptable brush shape (function),
+              -- specialising it to the type we are using.
           -> do
             -- Compute the outline using the brush function.
             ( outline, fitPts ) <-