Refactor module hierarchy, use internal records

MetaBrush.cabal

@@ -36,15 +36,15 @@ common common
       , acts
           ^>= 0.3.1.0
       , containers
-           >= 0.6.0.1 && < 0.6.5
+           >= 0.6.0.1 && < 0.7
       , deepseq
            >= 1.4.4.0 && < 1.5
-      , generic-data
-           >= 0.8.0.0 && < 0.10
       , generic-lens
-           >= 1.2.0.1 && < 2.0
+           >= 2.2     && < 2.3
       , groups
-           >= 0.4.1.0 && < 0.6
+           ^>= 0.5.3
+      , groups-generic
+           ^>= 0.2
       , primitive
           ^>= 0.7.1.0
       , transformers
@@ -61,8 +61,6 @@ common common
         -fspecialise-aggressively
         -optc-O3
         -optc-ffast-math
-        -- work around a laziness bug involving runRW# in GHC 9.0.1
-        -fno-full-laziness
         -Wall
         -Wcompat
         -fwarn-missing-local-signatures
@@ -70,15 +68,59 @@ common common
         -fwarn-incomplete-uni-patterns
         -fwarn-missing-deriving-strategies
         -fno-warn-unticked-promoted-constructors
-        -fno-show-valid-hole-fits
 
-library
+common extras
+
+    build-depends:
+        hashable
+           >= 1.3.0.0    && < 1.5
+      , lens
+           >= 4.19.2     && < 5.2
+      , mtl
+          ^>= 2.2.2
+      , scientific
+          ^>= 0.3.6.2
+      , stm
+          ^>= 2.5.0.0
+      , text
+           >= 1.2.3.1    && < 2.1
+      , unordered-containers
+           >= 0.2.11     && < 0.2.16
+      , waargonaut
+          ^>= 0.8.0.2
+
+common gtk
+
+    build-depends:
+        gi-cairo-render
+          ^>= 0.1.0
+      , gi-cairo-connector
+          ^>= 0.1.0
+      , gi-gdk
+           >= 4.0.2      && < 4.1
+      , gi-gio
+           >= 2.0.27     && < 2.1
+      , gi-glib
+           >= 2.0.23     && < 2.1
+      , gi-gobject
+          ^>= 2.0.24
+      , gi-gtk
+           >= 4.0.3      && < 4.1
+      --, gi-gtksource
+      --     >= 3.0.23     && < 3.1
+      , haskell-gi
+           >= 0.25       && < 0.26
+      , haskell-gi-base
+           >= 0.25       && < 0.26
+
+
+library splines
 
     import:
         common
 
     hs-source-dirs:
-        src/lib
+        src/splines
 
     exposed-modules:
         Math.Bezier.Cubic
@@ -97,8 +139,6 @@ library
     build-depends:
         bifunctors
            >= 5.5.4      && < 5.6
-      , groups-generic
-           >= 0.1.0.0    && < 0.3
       , hmatrix
           ^>= 0.20.0.0
       , parallel
@@ -108,14 +148,53 @@ library
       , vector
            >= 0.12.1.2   && < 0.13
 
+library metabrushes
+
+    import:
+        common, extras
+
+    hs-source-dirs:
+        src/metabrushes
+
+    exposed-modules:
+        MetaBrush.Assert
+      , MetaBrush.Brush
+      , MetaBrush.DSL.AST
+      , MetaBrush.DSL.Driver
+      , MetaBrush.DSL.Eval
+      , MetaBrush.DSL.Interpolation
+      , MetaBrush.DSL.Parse
+      , MetaBrush.DSL.PrimOp
+      , MetaBrush.DSL.Rename
+      , MetaBrush.DSL.TypeCheck
+      , MetaBrush.DSL.Types
+      , MetaBrush.Records
+      , MetaBrush.Serialisable
+      , MetaBrush.Unique
+      , MetaBrush.Util
+
+    if flag(asserts)
+      cpp-options:
+          -DASSERTS
+
+    build-depends:
+          splines
+        , dlist
+            ^>= 1.0
+        , Earley
+            ^>= 0.13.0.1
+        , tree-view
+            ^>= 0.5
+
+
 executable MetaBrush
 
     import:
-        common
+        common, extras, gtk
 
     hs-source-dirs:
-        src/app
+        src/app,
-      , app
+        app
 
     main-is:
         Main.hs
@@ -132,8 +211,6 @@ executable MetaBrush
       , MetaBrush.Asset.TickBox
       , MetaBrush.Asset.Tools
       , MetaBrush.Asset.WindowIcons
-      , MetaBrush.Assert
-      , MetaBrush.Brush
       , MetaBrush.Context
       , MetaBrush.Document
       , MetaBrush.Document.Draw
@@ -143,17 +220,9 @@ executable MetaBrush
       , MetaBrush.Document.SubdivideStroke
       , MetaBrush.Document.Update
       , MetaBrush.Event
-      , MetaBrush.MetaParameter.AST
+      , MetaBrush.GTK.Util
-      , MetaBrush.MetaParameter.Driver
-      , MetaBrush.MetaParameter.Eval
-      , MetaBrush.MetaParameter.Interpolation
-      , MetaBrush.MetaParameter.Parse
-      , MetaBrush.MetaParameter.PrimOp
-      , MetaBrush.MetaParameter.Rename
-      , MetaBrush.MetaParameter.TypeCheck
       , MetaBrush.Render.Document
       , MetaBrush.Render.Rulers
-      , MetaBrush.Time
       , MetaBrush.UI.Coordinates
       , MetaBrush.UI.FileBar
       , MetaBrush.UI.InfoBar
@@ -161,8 +230,7 @@ executable MetaBrush
       , MetaBrush.UI.Panels
       , MetaBrush.UI.ToolBar
       , MetaBrush.UI.Viewport
-      , MetaBrush.Unique
+      , MetaBrush.Time
-      , MetaBrush.Util
       , Paths_MetaBrush
 
     autogen-modules:
@@ -176,60 +244,15 @@ executable MetaBrush
           -DASSERTS
 
     build-depends:
-        MetaBrush
+        splines
+      , metabrushes
       , atomic-file-ops
           ^>= 0.3.0.0
       , bytestring
            >= 0.10.10.0  && < 0.12
       , directory
            >= 1.3.4.0    && < 1.4
-      , dlist
-          ^>= 1.0
-      , Earley
-          ^>= 0.13.0.1
       , filepath
           ^>= 1.4.2.1
-      , ghc-typelits-knownnat
-           >= 0.7.3      && < 0.8
-      , gi-cairo-render
-          ^>= 0.1.0
-      , gi-cairo-connector
-          ^>= 0.1.0
-      , gi-gdk
-           >= 4.0.2      && < 4.1
-      , gi-gio
-           >= 2.0.27     && < 2.1
-      , gi-glib
-           >= 2.0.23     && < 2.1
-      , gi-gobject
-          ^>= 2.0.24
-      , gi-gtk
-           >= 4.0.3      && < 4.1
-      --, gi-gtksource
-      --     >= 3.0.23     && < 3.1
-      , hashable
-          ^>= 1.3.0.0
-      , haskell-gi
-           >= 0.25       && < 0.26
-      , haskell-gi-base
-           >= 0.25       && < 0.26
-      , lens
-           >= 4.19.2     && < 5.1
-      , mtl
-          ^>= 2.2.2
-      , scientific
-          ^>= 0.3.6.2
-      , stm
-          ^>= 2.5.0.0
-      , superrecord
-          ^>= 0.5.1.0
       , tardis
            >= 0.4.2.0    && < 0.5
-      , text
-           >= 1.2.3.1    && < 1.2.5
-      , tree-view
-          ^>= 0.5
-      , unordered-containers
-           >= 0.2.11     && < 0.2.14
-      , waargonaut
-          ^>= 0.8.0.2

cabal.project

@@ -5,7 +5,12 @@ constraints:
 
 allow-newer:
     waargonaut:*,
-    *:haskell-gi-base, *:haskell-gi
+    *:haskell-gi-base, *:haskell-gi,
+    *:base, *:template-haskell, *:text,
+    ghc-typelits-natnormalise:ghc-bignum,
+    integer-logarithms:ghc-bignum,
+    hashable:ghc-bignum,
+    lens:hashable, aeson:hashable
 
 -- various fixes for 'hmatrix'
 source-repository-package
@@ -18,31 +23,9 @@ package hmatrix
   ghc-options: "-w"
   flags: +openblas
 
----- instances for CPS Writer / CPS RWST
---source-repository-package
---  type: git
---  location: https://github.com/haskell/mtl
---  tag: c8af65eb8437aebefd7f3ff1664316a0240f2157
-
 source-repository-package
   type: git
-  location: https://github.com/haskell-gi/haskell-gi
+  location: https://github.com/well-typed/large-records
-  tag: fad0097a80b942137b7c423f6d9698fff4abeb28
+  subdir: large-generics
-
+          large-anon
-source-repository-package
+  tag: acb837a9a4c22cea1abf552b47f9d3bf5af2fbdf
-  type: git
-  location: https://github.com/haskell-gi/haskell-gi
-  tag: fad0097a80b942137b7c423f6d9698fff4abeb28
-  subdir: base
-
--- GHC 9.0 compatibility for 'generics-lens' version 1.2
-source-repository-package
-  type: git
-  location: https://github.com/sheaf/generic-lens
-  tag: 8d3f0b405894ecade5821c99dcde6efb4a637363
-
--- superrecord API improvements
-source-repository-package
-  type: git
-  location: https://github.com/agrafix/superrecord
-  tag: f1c8cf87fd25243e715fd9585e595a90fff34050

src/app/MetaBrush/Action.hs

@@ -151,7 +151,7 @@ import MetaBrush.UI.Viewport
   ( Viewport(..), Ruler(..) )
 import MetaBrush.Unique
   ( Unique )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( (>=?=>), (>>?=)
   , widgetAddClass, widgetAddClasses
   )

src/app/MetaBrush/Application.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE RecursiveDo       #-}
 {-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE TypeOperators     #-}
 
 module MetaBrush.Application
   ( runApplication )
@@ -76,12 +75,6 @@ import qualified Control.Concurrent.STM as STM
 import qualified Control.Concurrent.STM.TVar as STM
   ( newTVarIO, readTVar, writeTVar )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( (:=)(..), (&), rnil )
-
 -- text
 import qualified Data.Text as Text
   ( pack )
@@ -107,8 +100,6 @@ import MetaBrush.Asset.Colours
   ( getColours )
 import MetaBrush.Asset.Logo
   ( drawLogo )
-import MetaBrush.Brush
-  ( adaptBrush )
 import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , Modifier(..)
@@ -125,6 +116,10 @@ import MetaBrush.Document.Update
   ( activeDocument, withActiveDocument )
 import MetaBrush.Event
   ( handleEvents )
+import MetaBrush.Records
+  ( Rec, I(..) )
+import qualified MetaBrush.Records as Rec
+  ( empty, insert )
 import MetaBrush.Render.Document
   ( blankRender, getDocumentRender )
 import MetaBrush.Render.Rulers
@@ -149,7 +144,7 @@ import MetaBrush.Unique
   , Unique, freshUnique
   , uniqueMapFromList
   )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
 import qualified Paths_MetaBrush as Cabal
   ( getDataDir, getDataFileName )
@@ -171,7 +166,7 @@ runApplication application = do
   let
 
     testDocuments :: Map Unique DocumentHistory
-    testDocuments = fmap newHistory $ uniqueMapFromList
+    testDocuments = newHistory <$> uniqueMapFromList
       [ emptyDocument "Test" docUnique
       & ( field' @"documentContent" . field' @"strokes" ) .~
         ( Seq.fromList
@@ -179,7 +174,7 @@ runApplication application = do
             { strokeName    = "Stroke 1"
             , strokeVisible = True
             , strokeUnique  = strokeUnique
-            , strokeBrush   = Just $ adaptBrush @Asset.Brushes.EllipseBrushFields ellipseBrush
+            , strokeBrush   = Just ellipseBrush
             , strokeSpline  =
               Spline
                 { splineStart  = mkPoint ( Point2D 10 -20 ) 2 1 0
@@ -194,9 +189,9 @@ runApplication application = do
         )
       ]
         where
-          mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Super.Rec Asset.Brushes.EllipseBrushFields )
+          mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Rec Asset.Brushes.EllipseBrushFields )
           mkPoint pt a b phi = PointData pt Normal
-            ( #a SuperRecord.:= a SuperRecord.& #b SuperRecord.:= b SuperRecord.& #phi SuperRecord.:= phi SuperRecord.&  SuperRecord.rnil )
+            ( Rec.insert @"a" (I a) $ Rec.insert @"b" (I b) $ Rec.insert @"phi" (I phi) $ Rec.empty )
 
   recomputeStrokesTVar <- STM.newTVarIO @Bool                                    False
   documentRenderTVar   <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
@@ -460,7 +455,7 @@ runApplication application = do
   ---------------------------------------------------------
   -- Finishing up
 
-  mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
+  mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
   updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
 
   GTK.widgetShow window

src/app/MetaBrush/Asset/Brushes.hs

@@ -14,9 +14,8 @@ import Data.Kind
   ( Type )
 import Data.Type.Equality
   ( (:~:)(Refl) )
-
+import GHC.TypeLits
--- superrecord
+  ( Symbol )
-import qualified SuperRecord
 
 -- text
 import Data.Text
@@ -26,11 +25,11 @@ import qualified Data.Text as Text
 
 -- MetaBrush
 import MetaBrush.Brush
-  ( Brush(..) )
+  ( Brush(..), BrushFunction )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.Types
-  ( BrushFunction, STypesI(..), eqTys
+  ( STypesI(..), eqTys
   )
-import MetaBrush.MetaParameter.Driver
+import MetaBrush.DSL.Driver
   ( SomeBrushFunction(..)
   , interpretBrush
   )
@@ -39,7 +38,7 @@ import MetaBrush.Unique
 
 --------------------------------------------------------------------------------
 
-type CircleBrushFields = '[ "r" SuperRecord.:= Double ]
+type CircleBrushFields = '[ '("r", Double) ]
 
 circle :: UniqueSupply -> IO ( Brush CircleBrushFields )
 circle uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code
@@ -75,7 +74,7 @@ circleCW uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code
      \          -- (-r  , r*c) -- (-r*c, r  ) -> ( 0, r)\n\
      \          -- ( r*c, r  ) -- ( r  , r*c) ->   .   ]"
 
-type EllipseBrushFields = '[ "a" SuperRecord.:= Double, "b" SuperRecord.:= Double, "phi" SuperRecord.:= Double ]
+type EllipseBrushFields = '[ '("a", Double), '("b", Double), '("phi", Double) ]
 
 ellipse :: UniqueSupply -> IO ( Brush EllipseBrushFields )
 ellipse uniqueSupply = mkBrush @EllipseBrushFields uniqueSupply name code
@@ -134,7 +133,7 @@ rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code
 --------------------------------------------------------------------------------
 
 mkBrush
-  :: forall ( givenBrushFields :: [ Type ] )
+  :: forall ( givenBrushFields :: [ ( Symbol, Type ) ] )
   .  STypesI givenBrushFields
   => UniqueSupply -> Text -> Text
   -> IO ( Brush givenBrushFields )

src/app/MetaBrush/Asset/CloseTabButton.hs

@@ -15,7 +15,7 @@ import qualified GI.Gtk as GTK
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( ColourRecord(..), Colours )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Asset/Cursor.hs

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

src/app/MetaBrush/Asset/InfoBar.hs

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

src/app/MetaBrush/Asset/Logo.hs

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

src/app/MetaBrush/Asset/TickBox.hs

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

src/app/MetaBrush/Asset/Tools.hs

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

src/app/MetaBrush/Asset/WindowIcons.hs

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

src/app/MetaBrush/Brush.hs

@@ -1,376 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds     #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE MagicHash           #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE PolyKinds           #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeOperators       #-}
-
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
-
-module MetaBrush.Brush
-  ( Brush(..), SomeBrush(..)
-  , BrushAdaptedTo(..), adaptBrush
-  , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups
-  )
-  where
-
--- base
-import Data.Kind
-  ( Type )
-import Data.List
-  ( intersect )
-import Data.Proxy
-  ( Proxy )
-import Data.Type.Equality
-  ( (:~:)(Refl) )
-import GHC.Exts
-  ( Proxy#, proxy# )
-import GHC.TypeLits
-  ( KnownSymbol, SomeSymbol(..)
-  , someSymbolVal, symbolVal'
-  )
-import GHC.TypeNats
-  ( KnownNat, SomeNat(..), someNatVal, type (-) )
-import Unsafe.Coerce
-  ( unsafeCoerce )
-
--- deepseq
-import Control.DeepSeq
-  ( NFData(..), deepseq )
-
--- groups
-import Data.Group
-  ( Group )
-
--- hashable
-import Data.Hashable
-  ( Hashable(..) )
-
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( Has, RecTy, (:=)
-  , RecSize, RecApply(..), RecVecIdxPos, UnsafeRecBuild(..)
-  , TraversalCHelper, RemoveAccessTo, Intersect
-  )
-import SuperRecord
-  ( ConstC, Tuple22C )
-
--- text
-import Data.Text
-  ( Text )
-import qualified Data.Text as Text
-  ( pack, unpack )
-
--- unordered-containers
-import Data.HashMap.Strict
-  ( HashMap )
-import qualified Data.HashMap.Strict as HashMap
-  ( fromList, lookup )
-
--- MetaBrush
-import Math.Module
-  ( Module )
-import Math.Vector2D
-  ( Point2D )
-import {-# SOURCE #-} MetaBrush.Document.Serialise
-  ( Serialisable, Workaround(..), workaround )
-import MetaBrush.MetaParameter.AST
-  ( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes
-  , Adapted, BrushFunction
-  , MapFields, UniqueField, UseFieldsInBrush
-  )
-import MetaBrush.MetaParameter.Interpolation
-  ( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
-
---------------------------------------------------------------------------------
-
-whatever :: Int
-whatever = case workaround Workaround of
-  Workaround -> 0
-
-data Brush brushFields where
-  BrushData
-    :: forall brushFields
-    .  ( STypesI brushFields )
-    =>
-      { brushName     :: !Text
-      , brushCode     :: !Text
-      , brushFunction :: !( BrushFunction brushFields )
-      }
-    -> Brush brushFields
-
-data SomeBrush where
-  SomeBrush :: !( Brush brushFields ) -> SomeBrush
-
-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 brushFields ) where
-  BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2
-instance Ord ( Brush brushFields ) where
-  compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 )
-instance Hashable ( Brush brushFields ) where
-  hashWithSalt salt ( BrushData { brushName, brushCode } ) =
-    hashWithSalt ( hashWithSalt salt brushName ) brushCode
-
-data BrushAdaptedTo pointFields where
-  AdaptedBrush
-    :: forall brushFields pointFields usedFields brushParams usedParams
-    .  ( brushParams ~ Super.Rec brushFields, STypesI brushFields
-       , usedParams  ~ Super.Rec usedFields
-       , Interpolatable usedParams
-       , Adapted brushFields pointFields usedFields
-       )
-    => !( Brush brushFields )
-    -> BrushAdaptedTo pointFields
-instance Show ( BrushAdaptedTo pointFields ) where
-  show ( AdaptedBrush ( brush :: Brush brushFields ) ) =
-    "AdaptedBrush @(" <> show ( sTypesI @brushFields ) <> ") " <> show brush
-instance NFData ( BrushAdaptedTo pointFields ) where
-  rnf ( AdaptedBrush brush ) = rnf brush
-
-
-adaptBrush
-  :: forall pointFields brushFields
-  .  ( STypesI brushFields, STypesI pointFields )
-  => Brush brushFields
-  -> BrushAdaptedTo pointFields
-adaptBrush brush = case proveAdapted @brushFields @pointFields of
-  Dict -> AdaptedBrush brush
-
---------------------------------------------------------------------------------
--- Instance dictionary passing machinery.
-
-data Dict c where
-  Dict :: c => Dict c
-
-proveAdapted
-  :: forall brushFields givenFields usedFields drts_used
-  .  ( STypesI brushFields, STypesI givenFields
-     , usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
-     , drts_used ~ MapDiff usedFields
-     )
-  => Dict ( Adapted brushFields givenFields usedFields
-          , Interpolatable ( Super.Rec usedFields )
-          )
-proveAdapted = case go ( sTypesI @brushFields ) of { Dict -> Dict }
-  where
-
-    brushFields, givenFields, usedFields :: [ ( Text, SomeSType ) ]
-    brushFields = someSTypes @brushFields
-    givenFields = someSTypes @givenFields
-    usedFields  = intersect brushFields givenFields
-
-    nbUsedFields :: Int
-    nbUsedFields = length usedFields
-
-    givenIxFieldsMap, usedIxFieldsMap :: HashMap Text Int
-    givenIxFieldsMap = listToEndIndexMap givenFields
-    usedIxFieldsMap  = listToEndIndexMap usedFields
-
-    go :: forall lts_brush lts_used dlts_used
-       .  ( lts_used ~ ( lts_brush `SuperRecord.Intersect` givenFields )
-          , dlts_used ~ MapDiff lts_used
-          )
-       => STypes lts_brush
-       -> Dict 
-            ( SuperRecord.UnsafeRecBuild usedFields lts_used ( SuperRecord.Has givenFields )
-            , SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField lts_brush ) ( UseFieldsInBrush usedFields )
-            , SuperRecord.UnsafeRecBuild drts_used dlts_used ( ConstC Monoid )
-            , SuperRecord.UnsafeRecBuild drts_used dlts_used ( ConstC ( Module Double ) )
-            , SuperRecord.RecApply drts_used dlts_used ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has drts_used ) )
-            , SuperRecord.RecApply drts_used dlts_used ( Tuple22C ( ConstC Semigroup )         ( SuperRecord.Has drts_used ) )
-            , SuperRecord.RecApply drts_used dlts_used ( Tuple22C ( ConstC Group )             ( SuperRecord.Has drts_used ) )
-            , SuperRecord.RecApply drts_used dlts_used ( HasDiff' usedFields )
-            , SuperRecord.TraversalCHelper dlts_used usedFields drts_used ( HasTorsor usedFields )
-            )
-    go STyNil
-      | SomeNat ( _ :: Proxy nbUsedFields ) <- someNatVal ( fromIntegral nbUsedFields )
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize usedFields :~: nbUsedFields )
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize drts_used  :~: nbUsedFields )
-      = Dict
-    go sTyCons@STyCons
-      | SomeNat ( _ :: Proxy nbUsedFields ) <- someNatVal ( fromIntegral nbUsedFields )
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize usedFields :~: nbUsedFields )
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize drts_used  :~: nbUsedFields )
-      , ( _ :: STypes ( ( k SuperRecord.:= v ) ': tail_lts_brush ) ) <- sTyCons
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize brushFields )
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapFields UniqueField brushFields ) :~: Just ( UniqueField v ) )
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapFields UniqueField tail_lts_brush ) :~: MapFields UniqueField tail_lts_brush )
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize tail_lts_brush )
-      , let
-          k :: Text
-          k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
-      = case HashMap.lookup k usedIxFieldsMap of
-          Just k_used_indexFromEnd
-            | SomeNat ( _ :: Proxy k_used_indexFromEnd ) <- someNatVal ( fromIntegral k_used_indexFromEnd )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k lts_used   :~: k_used_indexFromEnd )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k usedFields :~: k_used_indexFromEnd )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k drts_used  :~: k_used_indexFromEnd )
-            , Just k_given_indexFromEnd <- HashMap.lookup k givenIxFieldsMap
-            , SomeNat ( _ :: Proxy k_given_indexFromEnd ) <- someNatVal ( fromIntegral k_given_indexFromEnd )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k givenFields :~: k_given_indexFromEnd )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k lts_used    :~: Just v )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k usedFields  :~: Just v )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k givenFields :~: Just v )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k drts_used   :~: Just ( Diff v ) )
-            , ( _ :: Proxy# tail_lts_used  ) <- ( proxy# :: Proxy# ( tail_lts_brush `SuperRecord.Intersect` givenFields ) )
-            , ( _ :: Proxy# tail_dlts_used ) <- ( proxy# :: Proxy# ( MapDiff tail_lts_used ) )
-            , Refl <- ( unsafeCoerce Refl :: lts_used :~: ( ( k SuperRecord.:= v ) ': tail_lts_used ) )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize tail_lts_used :~: ( SuperRecord.RecSize lts_used - 1 ) )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize tail_dlts_used :~: SuperRecord.RecSize tail_lts_used )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k tail_dlts_used :~: tail_dlts_used )
-            , Just Dict <- interpolatableDict @v
-            -> case go ( sTypesI @tail_lts_brush ) of { Dict -> Dict }
-          _
-            | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k lts_used   :~: Nothing )
-            , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k usedFields :~: Nothing )
-            , Refl <- ( unsafeCoerce Refl :: lts_used :~: ( tail_lts_brush `SuperRecord.Intersect` givenFields ) )
-            -> case go ( sTypesI @tail_lts_brush ) of { Dict -> Dict }
-
-interpolatableDict :: forall t. STypeI t => Maybe ( Dict ( Interpolatable t ) )
-interpolatableDict =
-  case sTypeI @t of
-    STyDouble -> Just Dict
-    sTyPoint@STyPoint
-      | ( _ :: SType ( Point2D c ) ) <- sTyPoint
-      , STyDouble <- sTypeI @c
-      -> Just Dict
-    _ -> Nothing
-
-listToEndIndexMap :: ( Eq k, Hashable k ) => [ ( k, v ) ] -> HashMap k Int
-listToEndIndexMap kvs =
-  HashMap.fromList
-    $ zipWith ( \ ( fieldName, _ ) index -> ( fieldName, lg - index - 1 ) )
-        kvs
-        [ 0 .. ]
-  where
-    lg :: Int
-    lg = length kvs
-
--- | Reflects a list of brush fields to the type level.
---
--- Assumes the input list has no duplicate field names,
--- but they don't have to be sorted.
-reflectBrushFieldsNoDups :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
-reflectBrushFieldsNoDups = fromSomeBrushFieldsList . mkBrushFieldsList
-  where
-    mkBrushFieldsList :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFieldsList
-    mkBrushFieldsList [] = SomeBrushFieldsList NilFields
-    mkBrushFieldsList ( ( k, SomeFieldSType ( _ :: Proxy# v ) ) : kvs )
-      | SomeBrushFieldsList ( kvs_list :: BrushFieldsList kvs ) <- mkBrushFieldsList kvs
-      , SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack k )
-      -- deduce RecSize ( MapDiff kvs ) ~ RecSize kvs
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff kvs ) :~: SuperRecord.RecSize kvs )
-      -- compute indexing into record list (with SuperRecord, the index is the number of fields remaining)
-      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( ( k SuperRecord.:= v ) : kvs ) :~: SuperRecord.RecSize kvs )
-      = SomeBrushFieldsList ( ConsFields ( proxy# :: Proxy# k ) ( proxy# :: Proxy# v ) kvs_list )
-
-    fromSomeBrushFieldsList :: SomeBrushFieldsList -> SomeBrushFields
-    fromSomeBrushFieldsList ( SomeBrushFieldsList ( kvs :: BrushFieldsList kvs ) ) = case go @kvs kvs of
-      SomeClassyBrushFieldsList ( _ :: Proxy# kvs ) ( _ :: Proxy# kvs ) ->
-        SomeBrushFields ( proxy# :: Proxy# kvs )
-      where
-        go :: forall ( rts :: [ Type ] ) ( lts :: [ Type ] )
-           .  ( STypesI rts, KnownNat ( SuperRecord.RecSize rts ), KnownNat ( SuperRecord.RecSize ( MapDiff rts ) ) )
-           => BrushFieldsList lts -> SomeClassyBrushFieldsList rts lts
-        go NilFields =
-          SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# '[] )
-        go ( ConsFields ( _ :: Proxy# k ) ( _ :: Proxy# a ) kvs' )
-          | ( SomeClassyBrushFieldsList _ ( _ :: Proxy# lts' ) ) <- go @rts kvs'
-          -- Assert some facts that result from the field names being distinct:
-          --   - current field name does not re-occur later on
-          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k lts' :~: lts' )
-          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapDiff lts' ) :~: MapDiff lts' )
-          --   - looking up the type associated with the current field name returns the current type
-          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k rts :~: Just a )
-          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapDiff rts ) :~: Just ( Diff a ) )
-          --   - MapDiff preserves length
-          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff lts' ) :~: SuperRecord.RecSize lts' )
-          --   - compute the index (which is the number of fields remaining, i.e. the indexing starts counting from 0 from the right)
-          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k rts :~: SuperRecord.RecSize lts' )
-          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapDiff rts ) :~: SuperRecord.RecSize lts' )
-          = SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# ( ( k SuperRecord.:= a ) ': lts' ) )
-
-
--- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double.
-data SomeFieldSType where
-  SomeFieldSType
-    :: ( STypeI a, Show a, NFData a, Serialisable a, Interpolatable a )
-    => Proxy# a -> SomeFieldSType
-
--- | Existential type for allowed fields of a brush record.
-data SomeBrushFields where
-  SomeBrushFields
-    :: forall kvs rec
-    . ( STypesI kvs
-      , rec ~ Super.Rec kvs
-      , Show rec, NFData rec
-      , Interpolatable rec
-      , Serialisable rec
-      )
-    => Proxy# kvs -> SomeBrushFields
-
-instance Show SomeBrushFields where
-  show ( SomeBrushFields ( _ :: Proxy# kvs ) ) = show ( sTypesI @kvs )
-
--- | Auxiliary datatype used to create a proof that record fields have the required instances.
-data BrushFieldsList kvs where
-  NilFields  :: BrushFieldsList '[]
-  ConsFields
-    ::
-      ( KnownSymbol k
-      , Show a, NFData a, Serialisable a
-      , Interpolatable a
-      , STypesI kvs
-      , KnownNat ( SuperRecord.RecSize kvs )
-      , SuperRecord.Has ( k SuperRecord.:= a ': kvs ) k a
-      )
-    => Proxy# k -> Proxy# a -> BrushFieldsList kvs -> BrushFieldsList ( k SuperRecord.:= a ': kvs )
-
--- | Existential type used in the process of proving that record fields have the required instances.
-data SomeBrushFieldsList where
-  SomeBrushFieldsList
-    :: ( STypesI kvs
-       , KnownNat ( SuperRecord.RecSize kvs )
-       , KnownNat ( SuperRecord.RecSize ( MapDiff kvs ) )
-       )
-    => BrushFieldsList kvs -> SomeBrushFieldsList
-
--- | Type used to backtrack instance resolution in the SuperRecord library,
--- to witness the required typeclass instances by induction on the record fields.
-data SomeClassyBrushFieldsList rts lts where
-  SomeClassyBrushFieldsList
-    :: forall rts lts drts dlts
-    . ( drts ~ MapDiff rts
-      , dlts ~ MapDiff lts
-      , KnownNat ( SuperRecord.RecSize rts )
-      , KnownNat ( SuperRecord.RecSize drts )
-      , SuperRecord.UnsafeRecBuild rts lts ( ConstC Serialisable )
-      , SuperRecord.UnsafeRecBuild drts dlts ( ConstC ( Module Double ) )
-      , SuperRecord.UnsafeRecBuild drts dlts ( ConstC Monoid )
-      , SuperRecord.RecApply rts lts ( ConstC Show )
-      , SuperRecord.RecApply rts lts ( ConstC NFData )
-      , SuperRecord.RecApply rts lts ( ConstC Serialisable )
-      , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has drts ) )
-      , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Semigroup )         ( SuperRecord.Has drts ) )
-      , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Group )             ( SuperRecord.Has drts ) )
-      , SuperRecord.RecApply drts dlts ( HasDiff' rts )
-      , SuperRecord.TraversalCHelper dlts rts drts ( HasTorsor rts )
-      )
-    => Proxy# rts -> Proxy# lts -> SomeClassyBrushFieldsList rts lts

src/app/MetaBrush/Document.hs

@@ -30,7 +30,7 @@ module MetaBrush.Document
   , StrokeSpline, _strokeSpline, overStrokeSpline
   , PointData(..), BrushPointData(..), DiffPointData(..)
   , FocusState(..), Hoverable(..), HoverContext(..)
-  , Guide(..)
+  , Guide(..), Ruler(..)
   , _selection, _coords, coords
   , addGuide, selectedGuide
   )
@@ -84,10 +84,6 @@ import Control.Lens
 import Control.Concurrent.STM
   ( STM )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-
 -- text
 import Data.Text
   ( Text )
@@ -110,15 +106,15 @@ import Math.Module
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Brush
-  ( BrushAdaptedTo )
+  ( Brush )
-import {-# SOURCE #-} MetaBrush.Document.Serialise
+import MetaBrush.Serialisable
   ( Serialisable(..) )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.Types
   ( STypesI(..) )
-import MetaBrush.MetaParameter.Interpolation
+import MetaBrush.DSL.Interpolation
-  ( Interpolatable(..) ) -- + orphan instances
+  ( Interpolatable(..) )
-import MetaBrush.UI.Viewport
+import MetaBrush.Records
-  ( Ruler(..) )
+  ( Rec, AllFields )
 import MetaBrush.Unique
   ( UniqueSupply, Unique, freshUnique )
 
@@ -194,16 +190,17 @@ type StrokeSpline clo brushParams =
 data Stroke where
   Stroke
     :: ( KnownSplineType clo
-       , pointParams ~ Super.Rec pointFields, STypesI pointFields
+       , pointParams ~ Rec pointFields
+       , STypesI pointFields, STypesI brushFields
        , Show pointParams, NFData pointParams
-       , Interpolatable pointParams
+       , AllFields Interpolatable pointFields
        , Serialisable pointParams
        )
     =>
       { strokeName     :: !Text
       , strokeVisible  :: !Bool
       , strokeUnique   :: Unique
-      , strokeBrush    :: !( Maybe ( BrushAdaptedTo pointFields ) )
+      , strokeBrush    :: !( Maybe ( Brush brushFields ) )
       , strokeSpline   :: !( StrokeSpline clo pointParams )
       }
     -> Stroke
@@ -222,8 +219,8 @@ _strokeSpline
   => (  forall clo pointParams pointFields
      .  ( KnownSplineType clo
         , Show pointParams, NFData pointParams
-        , pointParams ~ Super.Rec pointFields, STypesI pointFields
+        , AllFields Interpolatable pointFields
-        , Interpolatable pointParams
+        , pointParams ~ Rec pointFields, STypesI pointFields
         , Serialisable pointParams
         )
      => StrokeSpline clo pointParams
@@ -237,8 +234,8 @@ overStrokeSpline
   :: (  forall clo pointParams pointFields
      .  ( KnownSplineType clo
         , Show pointParams, NFData pointParams
-        , pointParams ~ Super.Rec pointFields, STypesI pointFields
+        , AllFields Interpolatable pointFields
-        , Interpolatable pointParams
+        , pointParams ~ Rec pointFields, STypesI pointFields
         , Serialisable pointParams
         )
      => StrokeSpline clo pointParams
@@ -408,6 +405,12 @@ data Guide
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
 
+data Ruler
+  = RulerCorner
+  | LeftRuler
+  | TopRuler
+  deriving stock Show
+
 -- | Try to select a guide at the given document coordinates.
 selectedGuide :: Point2D Double -> Document -> Maybe Guide
 selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =

src/app/MetaBrush/Document/Draw.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -48,12 +49,6 @@ import Control.Lens
 import Control.Concurrent.STM
   ( STM )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( rnil )
-
 -- text
 import Data.Text
   ( Text )
@@ -79,7 +74,7 @@ import Math.Vector2D
 import MetaBrush.Assert
   ( assert )
 import MetaBrush.Brush
-  ( BrushAdaptedTo )
+  ( Brush(..) )
 import MetaBrush.Document
   ( Document(..), DocumentContent(..)
   , Stroke(..), StrokeHierarchy(..), StrokeSpline
@@ -87,12 +82,16 @@ import MetaBrush.Document
   , _selection, _strokeSpline
   , coords, overStrokeSpline
   )
-import MetaBrush.Document.Serialise
+import MetaBrush.Serialisable
   ( Serialisable )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.Types
   ( STypesI(..) )
-import MetaBrush.MetaParameter.Interpolation
+import MetaBrush.DSL.Interpolation
   ( Interpolatable )
+import MetaBrush.Records
+  ( Rec, AllFields )
+import qualified MetaBrush.Records as Rec
+  ( empty )
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique, uniqueText )
 
@@ -132,9 +131,9 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
     ( newDoc, Nothing ) -> do
       uniq <- runReaderT freshUnique uniqueSupply
       let
-        newSpline :: StrokeSpline Open ( Super.Rec '[] )
+        newSpline :: StrokeSpline Open ( Rec '[] )
         newSpline =
-          Spline { splineStart  = PointData c Normal ( SuperRecord.rnil )
+          Spline { splineStart  = PointData c Normal Rec.empty
                  , splineCurves = OpenCurves Empty
                  }
         newStroke :: Stroke
@@ -144,7 +143,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
             , strokeVisible = True
             , strokeUnique  = uniq
             , strokeSpline  = newSpline
-            , strokeBrush   = Nothing
+            , strokeBrush   = Nothing :: Maybe ( Brush '[] )
             }
         newDoc' :: Document
         newDoc'
@@ -222,8 +221,7 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok
     updateStroke :: Stroke -> Stroke
     updateStroke stroke@( Stroke { strokeUnique } )
       | strokeUnique == anchorStrokeUnique anchor
-      = 
+      , let
-        let
           updateSpline
             :: forall clo brushData
             .  SplineTypeI clo
@@ -244,8 +242,7 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok
             | otherwise
             = assert ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
                 prevSpline -- should never add to a closed spline
-        in
+      = overStrokeSpline updateSpline stroke
-          overStrokeSpline updateSpline stroke
       | otherwise
       = stroke
 
@@ -253,13 +250,14 @@ withAnchorBrushData
   :: forall r
   .  DrawAnchor
   -> Document
-  -> ( forall pointParams pointFields
+  -> ( forall pointParams pointFields brushFields
-     . ( pointParams ~ Super.Rec pointFields, STypesI pointFields
+     . ( pointParams ~ Rec pointFields
+       , STypesI pointFields, STypesI brushFields
        , Show pointParams, NFData pointParams
-       , Interpolatable pointParams
        , Serialisable pointParams
+       , AllFields Interpolatable pointFields
        )
-     => Maybe ( BrushAdaptedTo pointFields )
+     => Maybe (Brush brushFields)
      -> pointParams
      -> r
      )
@@ -284,4 +282,4 @@ withAnchorBrushData anchor ( Document { documentContent = Content { strokes } }
         AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) )
         AnchorAtEnd   {} -> f strokeBrush ( brushParams ( splineEnd   strokeSpline ) )
     splineAnchor _
-      = f Nothing SuperRecord.rnil
+      = f (Nothing :: Maybe (Brush '[])) Rec.empty

src/app/MetaBrush/Document/Selection.hs

@@ -43,7 +43,7 @@ import Data.Semigroup
 import GHC.Exts
   ( dataToTag#, (>#), (<#), isTrue# )
 import GHC.Generics
-  ( Generic )
+  ( Generic, Generically(..) )
 
 -- acts
 import Data.Act
@@ -57,10 +57,6 @@ import Data.Set
 import qualified Data.Set as Set
   ( insert )
 
--- generic-data
-import Generic.Data
-  ( Generically(..) )
-
 -- generic-lens
 import Data.Generics.Product.Fields
   ( field' )
@@ -126,7 +122,7 @@ import MetaBrush.Document
   )
 import {-# SOURCE #-} MetaBrush.Document.Update
   ( DocChange(..) )
-import MetaBrush.MetaParameter.Interpolation
+import MetaBrush.DSL.Interpolation
   ( Interpolatable(Diff) )
 import MetaBrush.Unique
   ( Unique )

src/app/MetaBrush/Document/Serialise.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BlockArguments       #-}
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE GADTs                #-}
 {-# LANGUAGE InstanceSigs         #-}
 {-# LANGUAGE LambdaCase           #-}
@@ -14,40 +15,22 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module MetaBrush.Document.Serialise
-  ( Workaround(..), workaround
+  ( documentToJSON, documentFromJSON
-  , Serialisable(..)
-  , documentToJSON, documentFromJSON
   , saveDocument, loadDocument
   )
   where
 
 -- base
-import Control.Arrow
-  ( (&&&) )
 import Control.Monad
   ( unless )
-import Control.Monad.ST
-  ( RealWorld, stToIO )
 import qualified Data.Bifunctor as Bifunctor
   ( first )
-import Data.Foldable
-  ( toList )
-import Data.Functor.Contravariant
-  ( contramap )
 import Data.Functor.Identity
   ( Identity(..) )
-import Data.STRef
-  ( newSTRef )
 import Data.Type.Equality
   ( (:~:)(Refl) )
 import Data.Version
   ( Version(versionBranch) )
-import GHC.Exts
-  ( Proxy#, proxy# )
-import GHC.TypeLits
-  ( symbolVal', KnownSymbol )
-import GHC.TypeNats
-  ( KnownNat )
 import Unsafe.Coerce
   ( unsafeCoerce ) -- Tony Morris special
 
@@ -65,16 +48,6 @@ import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Builder as Lazy.ByteString.Builder
   ( toLazyByteString )
 
--- containers
-import Data.Map.Strict
-  ( Map )
-import qualified Data.Map.Strict as Map
-  ( elems, fromList )
-import Data.Sequence
-  ( Seq )
-import qualified Data.Sequence as Seq
-  ( fromList )
-
 -- directory
 import System.Directory
   ( canonicalizePath, createDirectoryIfMissing, doesFileExist )
@@ -83,37 +56,14 @@ import System.Directory
 import System.FilePath
   ( takeDirectory )
 
--- generic-lens
-import Data.Generics.Product.Typed
-  ( HasType(typed) )
-
--- lens
-import Control.Lens
-  ( view )
-
 -- mtl
 import Control.Monad.Except
   ( MonadError(throwError) )
 
--- scientific
-import qualified Data.Scientific as Scientific
-  ( fromFloatDigits, toRealFloat )
-
 -- stm
 import qualified Control.Concurrent.STM as STM
   ( atomically )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( FldProxy(..)
-  , RecSize, RecApply(..), UnsafeRecBuild(..)
-  , reflectRec
-  )
-import SuperRecord
-  ( ConstC )
-
 -- text
 import Data.Text
   ( Text )
@@ -136,12 +86,12 @@ import qualified Waargonaut.Decode as JSON
 import qualified Waargonaut.Decode.Error as JSON
   ( DecodeError(ParseFailed) )
 import qualified Waargonaut.Decode as JSON.Decoder
-  ( atKey, atKeyOptional, bool, list, objectAsKeyValues, scientific, text )
+  ( atKey, atKeyOptional, bool, objectAsKeyValues, text )
 import qualified Waargonaut.Encode as JSON
   ( Encoder )
 import qualified Waargonaut.Encode as JSON.Encoder
-  ( runEncoder, runPureEncoder
+  ( runEncoder
-  , atKey', bool, int, json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
+  , atKey', bool, int, keyValueTupleFoldable, list, mapLikeObj, text
   )
 import qualified Waargonaut.Encode.Builder as JSON.Builder
   ( waargonautBuilder, bsBuilder )
@@ -162,49 +112,49 @@ import Waargonaut.Types.Json
 import qualified Waargonaut.Types.Whitespace as JSON
   ( WS )
 
--- MetaBrush
+-- metabrushes
 import qualified Math.Bezier.Cubic as Cubic
   ( Bezier )
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier )
 import Math.Bezier.Spline
-  ( Spline(..), SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..)
+  ( SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..) )
-  , Curves(..), Curve(..), NextPoint(..)
-  )
-import Math.Bezier.Stroke
-  ( CachedStroke(..) )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..), Segment )
 import MetaBrush.Brush
   ( Brush(..), SomeBrush(..)
-  , BrushAdaptedTo(..), adaptBrush
+  , SomeFieldSType(..), SomeBrushFields(..)
-  , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups
+  , reflectBrushFieldsNoDups
   )
 import MetaBrush.Document
   ( Document(..), DocumentContent(..), Guide(..)
   , Stroke(..), StrokeHierarchy(..), StrokeSpline
   , PointData(..), FocusState(..)
   )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.Types
   ( SType(..), STypeI(..)
   , SomeSType(..), someSTypes
-  , AdaptableFunction(..)
   , eqTy
   )
-import MetaBrush.MetaParameter.Driver
+import MetaBrush.DSL.Driver
   ( SomeBrushFunction(..), interpretBrush )
+import MetaBrush.Serialisable
+  ( Serialisable(..)
+  , encodeSequence, decodeSequence
+  , encodeUniqueMap, decodeUniqueMap
+  , encodeSpline, decodeSpline
+  )
+import MetaBrush.Records
+  ( Rec, WithParams )
 import MetaBrush.Unique
-  ( Unique, UniqueSupply, freshUnique )
+  ( UniqueSupply, freshUnique )
+
+-- MetaBrush
 import qualified Paths_MetaBrush as Cabal
   ( version )
 
 --------------------------------------------------------------------------------
 
--- | Dummy data-type that helps workaround a GHC bug with hs-boot files.
-data Workaround = Workaround
-workaround :: Workaround -> Workaround
-workaround Workaround = Workaround
-
 -- | Serialise a document to JSON (in the form of a lazy bytestring).
 documentToJSON :: Document -> Lazy.ByteString
 documentToJSON
@@ -256,200 +206,6 @@ loadDocument uniqueSupply fp = do
 
 --------------------------------------------------------------------------------
 
-class Serialisable a where
-  encoder :: Monad f => JSON.Encoder f a
-  decoder :: Monad m => JSON.Decoder m a
-
-instance Serialisable Double where
-  encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
-  decoder = fmap      Scientific.toRealFloat     JSON.Decoder.scientific
-
-instance Serialisable a => Serialisable ( Point2D a ) where
-  encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
-      JSON.Encoder.atKey' "x" encoder x
-    . JSON.Encoder.atKey' "y" encoder y
-  decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
-
-instance Serialisable a => Serialisable ( Vector2D a ) where
-  encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
-      JSON.Encoder.atKey' "x" encoder x
-    . JSON.Encoder.atKey' "y" encoder y
-  decoder =  Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
-
-instance ( SuperRecord.RecApply       flds flds ( ConstC Serialisable )
-         , SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
-         , KnownNat ( SuperRecord.RecSize flds )
-         )
-      => Serialisable ( Super.Rec flds ) where
-  encoder :: forall f. Monad f => JSON.Encoder f ( Super.Rec flds )
-  encoder = contramap ( SuperRecord.reflectRec @( ConstC Serialisable ) keyVal ) ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
-    where
-      keyVal :: forall k v. ( KnownSymbol k, Serialisable v ) => SuperRecord.FldProxy k -> v -> ( Text, Json )
-      keyVal _ v = let k = symbolVal' ( proxy# :: Proxy# k ) in ( Text.pack k, JSON.Encoder.runPureEncoder ( encoder @v ) v )
-
-  decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds )
-  decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite
-    where
-      decodeAndWrite
-        :: forall k v
-        .  ( KnownSymbol k, Serialisable v )
-        => SuperRecord.FldProxy k -> Proxy# v
-        -> JSON.Decoder m v
-      decodeAndWrite _ _ = do
-        let
-          k :: Text
-          k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
-        val <- JSON.Decoder.atKey k ( decoder @v @m )
-        pure val
-
---------------------------------------------------------------------------------
-
-{-
-encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
-encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
-    JSON.Encoder.atKey' "m00" enc m00
-  . JSON.Encoder.atKey' "m01" enc m01
-  . JSON.Encoder.atKey' "m10" enc m10
-  . JSON.Encoder.atKey' "m11" enc m11
-
-decodeMat22 :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Mat22 a )
-decodeMat22 dec =
-  Mat22 <$> JSON.Decoder.atKey "m00" dec
-        <*> JSON.Decoder.atKey "m01" dec
-        <*> JSON.Decoder.atKey "m10" dec
-        <*> JSON.Decoder.atKey "m11" dec
-
-
-
-encodeAABB :: Applicative f => JSON.Encoder f AABB
-encodeAABB = JSON.Encoder.mapLikeObj \ ( AABB { topLeft, botRight } ) ->
-    JSON.Encoder.atKey' "topLeft"  enc topLeft
-  . JSON.Encoder.atKey' "botRight" enc botRight
-  where
-    enc :: JSON.Encoder' ( Point2D Double )
-    enc = encodePoint2D encodeDouble
-
-decodeAABB :: forall m. Monad m => JSON.Decoder m AABB
-decodeAABB = do
-    topLeft  <- JSON.Decoder.atKey "topLeft"  dec
-    botRight <- JSON.Decoder.atKey "botRight" dec
-    pure ( AABB { topLeft, botRight } )
-  where
-    dec :: JSON.Decoder m ( Point2D Double )
-    dec = decodePoint2D decodeDouble
--}
-
-
-encodeCurve
-  :: forall clo crvData ptData f
-  .  ( SplineTypeI clo, Applicative f )
-  => JSON.Encoder Identity ptData
-  -> JSON.Encoder f ( Curve clo crvData ptData )
-encodeCurve  encodePtData = case ssplineType @clo of
-  SOpen   -> JSON.Encoder.mapLikeObj \case
-    LineTo          ( NextPoint p1 ) _ ->
-        JSON.Encoder.atKey' "p1" encodePtData p1
-    Bezier2To    p1 ( NextPoint p2 ) _ ->
-        JSON.Encoder.atKey' "p1" encodePtData p1
-      . JSON.Encoder.atKey' "p2" encodePtData p2
-    Bezier3To p1 p2 ( NextPoint p3 ) _ ->
-        JSON.Encoder.atKey' "p1" encodePtData p1
-      . JSON.Encoder.atKey' "p2" encodePtData p2
-      . JSON.Encoder.atKey' "p3" encodePtData p3
-  SClosed -> JSON.Encoder.mapLikeObj \case
-    LineTo          BackToStart _ -> id
-    Bezier2To    p1 BackToStart _ ->
-        JSON.Encoder.atKey' "p1" encodePtData p1
-    Bezier3To p1 p2 BackToStart _ ->
-        JSON.Encoder.atKey' "p1" encodePtData p1
-      . JSON.Encoder.atKey' "p2" encodePtData p2
-
-decodeCurve
-  :: forall clo ptData m
-  .  ( SplineTypeI clo, MonadIO m )
-  => JSON.Decoder m ptData
-  -> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
-decodeCurve decodePtData = do
-  noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
-  case ssplineType @clo of
-    SOpen   -> do
-      p1    <- JSON.Decoder.atKey         "p1" decodePtData
-      mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
-      case mb_p2 of
-        Nothing ->
-          pure ( LineTo ( NextPoint p1 ) noCache )
-        Just p2 -> do
-          mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
-          case mb_p3 of
-            Nothing -> pure ( Bezier2To    p1 ( NextPoint p2 ) noCache )
-            Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
-    SClosed -> do
-      mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
-      case mb_p1 of
-        Nothing ->
-          pure ( LineTo BackToStart noCache )
-        Just p1 -> do
-          mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
-          case mb_p2 of
-            Nothing -> pure ( Bezier2To    p1 BackToStart noCache )
-            Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
-
-
-
-encodeCurves
-  :: forall clo crvData ptData f
-  .  ( SplineTypeI clo, Applicative f )
-  => JSON.Encoder Identity ptData
-  -> JSON.Encoder f ( Curves clo crvData ptData )
-encodeCurves encodePtData = case ssplineType @clo of
-  SOpen   -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData )
-  SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR )
-    where
-      encodeL :: JSON.Encoder f ()
-      encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text
-      encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData )
-      encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) ->
-          JSON.Encoder.atKey' "prevOpenCurves"  ( encodeSequence $ encodeCurve @Open   encodePtData ) openCurves
-        . JSON.Encoder.atKey' "lastClosedCurve"                  ( encodeCurve @Closed encodePtData ) closedCurve
-
-decodeCurves
-  :: forall clo ptData m
-  .  ( SplineTypeI clo, MonadIO m )
-  => JSON.Decoder m ptData
-  -> JSON.Decoder m ( Curves clo ( CachedStroke RealWorld ) ptData )
-decodeCurves decodePtData = case ssplineType @clo of
-  SOpen   -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
-  SClosed -> do
-    mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
-    case mbNoCurves of
-      Just _ -> pure NoCurves
-      Nothing -> do
-        prevCurves <- JSON.Decoder.atKey "prevOpenCurves"  ( decodeSequence $ decodeCurve @Open   decodePtData )
-        lastCurve  <- JSON.Decoder.atKey "lastClosedCurve"                  ( decodeCurve @Closed decodePtData )
-        pure ( ClosedCurves prevCurves lastCurve )
-
-
-
-encodeSpline
-  :: forall clo crvData ptData f
-  .  ( SplineTypeI clo, Applicative f )
-  => JSON.Encoder Identity ptData
-  -> JSON.Encoder f ( Spline clo crvData ptData )
-encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) ->
-    JSON.Encoder.atKey' "splineStart"  encodePtData                       splineStart
-  . JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
-
-decodeSpline
-  :: forall clo ptData m
-  .  ( SplineTypeI clo, MonadIO m )
-  => JSON.Decoder m ptData
-  -> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
-decodeSpline decodePtData = do
-  splineStart  <- JSON.Decoder.atKey "splineStart"  decodePtData
-  splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
-  pure ( Spline { splineStart, splineCurves } )
-
-
 {-
 encodeFocusState :: Applicative f => JSON.Encoder f FocusState
 encodeFocusState = contramap focusText JSON.Encoder.text
@@ -479,38 +235,24 @@ decodeBrushPointData = do
 -}
 
 
-encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
-encodeSequence enc = contramap toList ( JSON.Encoder.list enc )
-
-decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a )
-decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
-
-
-
-encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
-encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
-
-decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
-decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
-
 
 
 encodePointData
   :: forall f flds brushParams
   . ( Applicative f
-    , brushParams ~ Super.Rec flds
+    , brushParams ~ Rec flds
-    , Serialisable ( Super.Rec flds )
+    , Serialisable ( Rec flds )
     )
   => JSON.Encoder f ( PointData brushParams )
 encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) ->
     JSON.Encoder.atKey' "coords"      ( encoder @( Point2D Double ) ) pointCoords
-  . JSON.Encoder.atKey' "brushParams" ( encoder @( Super.Rec flds ) ) brushParams
+  . JSON.Encoder.atKey' "brushParams" ( encoder @( Rec     flds   ) ) brushParams
 
 decodePointData
   :: forall m flds brushParams
   . ( Monad m
-    , brushParams ~ Super.Rec flds
+    , brushParams ~ Rec flds
-    , Serialisable ( Super.Rec flds )
+    , Serialisable ( Rec flds )
     )
   => JSON.Decoder m ( PointData brushParams )
 decodePointData = do
@@ -518,41 +260,41 @@ decodePointData = do
   let
     pointState :: FocusState
     pointState = Normal
-  brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Super.Rec flds ) )
+  brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Rec flds ) )
   pure ( PointData { pointCoords, pointState, brushParams } )
 
 
 
 encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
-encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) ->
+encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType @ty ) ->
   case sTypeI @ty of
     sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun"
-       . JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
+       . JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType @a )
-       . JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# b ) )
+       . JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType @b )
     STyBool
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bool"
     STyDouble
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
     sTyPoint@STyPoint | ( _ :: SType ( Point2D a ) ) <- sTyPoint
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "point"
-       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType @a )
     sTyLine@STyLine | ( _ :: SType ( Segment a ) ) <- sTyLine
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "line"
-       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType @a )
     sTyBez2@STyBez2 | ( _ :: SType ( Quadratic.Bezier a ) ) <- sTyBez2
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez2"
-       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType @a )
     sTyBez3@STyBez3 | ( _ :: SType ( Cubic.Bezier a ) ) <- sTyBez3
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez3"
-       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType @a)
     sTySpline@STySpline | ( _ :: SType ( SplinePts clo ) ) <- sTySpline
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "spline"
        . JSON.Encoder.atKey' "closed" JSON.Encoder.bool ( case ssplineType @clo of { SOpen -> False; SClosed -> True } )
-    sTyRecord@STyWithFn | ( _ :: SType ( AdaptableFunction kvs res ) ) <- sTyRecord
+    sTyRecord@STyWithFn | ( _ :: SType ( WithParams kvs res ) ) <- sTyRecord
       -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "adaptableFun"
        . JSON.Encoder.atKey' "fields" encodeFieldTypes ( someSTypes @kvs )
-       . JSON.Encoder.atKey' "res"    encodeSomeSType  ( SomeSType ( proxy# :: Proxy# res ) )
+       . JSON.Encoder.atKey' "res"    encodeSomeSType  ( SomeSType @res )
 
 {-
 decodeSomeSType :: Monad m => JSON.Decoder m SomeSType
@@ -560,32 +302,32 @@ decodeSomeSType = do
   tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
   case tag of
     "fun"    -> do
-      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "arg" decodeSomeSType
+      ( SomeSType @a ) <- JSON.Decoder.atKey "arg" decodeSomeSType
-      ( SomeSType ( _ :: Proxy# b ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
+      ( SomeSType @b ) <- JSON.Decoder.atKey "res" decodeSomeSType
-      pure ( SomeSType ( proxy# :: Proxy# ( a -> b ) ) )
+      pure ( SomeSType @(a -> b) )
-    "bool"   -> pure ( SomeSType ( proxy# :: Proxy# Bool ) )
+    "bool"   -> pure ( SomeSType @Bool )
-    "double" -> pure ( SomeSType ( proxy# :: Proxy# Double ) )
+    "double" -> pure ( SomeSType @ Double )
     "point"  -> do
-      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      ( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
-      pure ( SomeSType ( proxy# :: Proxy# ( Point2D a ) ) )
+      pure ( SomeSType @( Point2D a ) )
     "line"   -> do
-      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      ( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
-      pure ( SomeSType ( proxy# :: Proxy# ( Segment a ) ) )
+      pure ( SomeSType @( Segment a ) )
     "bez2"   -> do
-      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      ( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
-      pure ( SomeSType ( proxy# :: Proxy# ( Quadratic.Bezier a ) ) )
+      pure ( SomeSType @( Quadratic.Bezier a ) )
     "bez3"   -> do
-      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      ( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
-      pure ( SomeSType ( proxy# :: Proxy# ( Cubic.Bezier a ) ) )
+      pure ( SomeSType @( Cubic.Bezier a ) )
     "spline" -> do
       closed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
       case closed of
-        True  -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Closed ) ) )
+        True  -> pure ( SomeSType @( SplinePts Closed ) )
-        False -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Open   ) ) )
+        False -> pure ( SomeSType @( SplinePts Open   ) )
     "adaptableFun" -> do
-      ( SomeBrushFields ( _ :: Proxy# kvs ) ) <- JSON.Decoder.atKey "fields" decodeFieldTypes
+      ( SomeBrushFields @kvs ) <- JSON.Decoder.atKey "fields" decodeFieldTypes
-      ( SomeSType       ( _ :: Proxy# a   ) ) <- JSON.Decoder.atKey "res"    decodeSomeSType
+      ( SomeSType       @a   ) <- JSON.Decoder.atKey "res"    decodeSomeSType
-      pure ( SomeSType ( proxy# :: Proxy# ( AdaptableFunction kvs a ) ) )
+      pure ( SomeSType @( AdaptableFunction kvs a ) )
     _ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
 -}
 
@@ -593,11 +335,11 @@ decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType
 decodeSomeFieldSType = do
   tag   <- JSON.Decoder.atKey "tag" JSON.Decoder.text
   case tag of
-    "double" -> pure ( SomeFieldSType ( proxy# :: Proxy# Double ) )
+    "double" -> pure ( SomeFieldSType @Double )
     "point"  -> do
-      ( SomeFieldSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
+      SomeFieldSType @a <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
       case eqTy @a @Double of
-        Just Refl -> pure ( SomeFieldSType ( proxy# :: Proxy# ( Point2D Double ) ) )
+        Just Refl -> pure ( SomeFieldSType @( Point2D Double ) )
         Nothing   -> throwError ( JSON.ParseFailed "Point2D: non-Double coordinate type" )
     _ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
 
@@ -649,7 +391,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
   \ ( Stroke
       { strokeName
       , strokeVisible
-      , strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
+      , strokeSpline = strokeSpline :: StrokeSpline clo ( Rec pointFields )
       , strokeBrush
       }
     ) ->
@@ -662,7 +404,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
       mbEncodeBrush = case strokeBrush of
         Nothing ->
           id
-        Just ( AdaptedBrush brush ) ->
+        Just brush ->
           JSON.Encoder.atKey' "brush" encodeBrush brush
     in
       JSON.Encoder.atKey' "name"        JSON.Encoder.text                strokeName
@@ -678,23 +420,23 @@ decodeStroke uniqueSupply = do
   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
+  SomeBrushFields @pointFields <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
-  mbBrush       <- JSON.Decoder.atKeyOptional "brush" ( decodeBrush uniqueSupply )
+  mbSomeBrush   <- JSON.Decoder.atKeyOptional "brush" ( decodeBrush uniqueSupply )
-  let
-    strokeBrush :: Maybe ( BrushAdaptedTo pointFields )
-    strokeBrush = case mbBrush of
-      Nothing
-        -> Nothing
-      Just ( SomeBrush ( brush@( BrushData {} ) ) )
-        -> Just $ adaptBrush @pointFields brush
   if strokeClosed
   then do
-    strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData )
+    strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Rec pointFields ) ) decodePointData )
-    pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
+    pure $ case mbSomeBrush of
+      Nothing ->
+        Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
+      Just (SomeBrush brush) ->
+        Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
   else do
-    strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open   @( PointData ( Super.Rec pointFields ) ) decodePointData )
+    strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open   @( PointData ( Rec pointFields ) ) decodePointData )
-    pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
+    pure $ case mbSomeBrush of
-
+      Nothing ->
+        Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
+      Just (SomeBrush brush) ->
+        Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
 
 
 encodeStrokeHierarchy :: Monad f => JSON.Encoder f StrokeHierarchy

src/app/MetaBrush/Document/Serialise.hs-boot

@@ -1,50 +0,0 @@
-{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module MetaBrush.Document.Serialise
-  ( Workaround(..), workaround, Serialisable(..) )
-  where
-
--- base
-import GHC.TypeNats
-  ( KnownNat )
-
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( RecApply, RecSize, UnsafeRecBuild )
-import SuperRecord
-  ( ConstC )
-
--- waargonaut
-import qualified Waargonaut.Decode as JSON
-  ( Decoder )
-import qualified Waargonaut.Encode as JSON
-  ( Encoder )
-
--- MetaBrush
-import Math.Vector2D
-  ( Point2D, Vector2D )
-
---------------------------------------------------------------------------------
-
-data Workaround = Workaround
-
-workaround :: Workaround -> Workaround
-
-class Serialisable a where
-  encoder :: Monad f => JSON.Encoder f a
-  decoder :: Monad m => JSON.Decoder m a
-
-instance Serialisable Double
-
-instance Serialisable a => Serialisable ( Point2D a )
-
-instance Serialisable a => Serialisable ( Vector2D a )
-
-instance ( SuperRecord.RecApply       flds flds ( ConstC Serialisable )
-         , SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
-         , KnownNat ( SuperRecord.RecSize flds )
-         )
-      => Serialisable ( Super.Rec flds )

src/app/MetaBrush/Document/SubdivideStroke.hs

@@ -64,7 +64,7 @@ import MetaBrush.Document
   , PointData(..), DiffPointData(..)
   , coords, _strokeSpline
   )
-import MetaBrush.MetaParameter.Interpolation
+import MetaBrush.DSL.Interpolation
   ( Interpolatable(Diff) )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/Document/Update.hs

@@ -90,7 +90,7 @@ import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( updateInfoBar )
 import MetaBrush.UI.Viewport
   ( Viewport(..) )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( (>>?=) )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/GTK/Util.hs

@@ -6,12 +6,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 
-module MetaBrush.Util
+module MetaBrush.GTK.Util
   ( withRGBA, showRGBA
   , widgetAddClasses, widgetAddClass
   , (>=?=>), (>>?=)
-  , traverseMaybe
-  , Exists(..)
   )
   where
 
@@ -25,10 +23,6 @@ import Data.Foldable
 import GHC.Stack
   ( HasCallStack )
 
--- containers
-import Data.Sequence
-  ( Seq(..) )
-
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
@@ -76,14 +70,3 @@ infixr 1 >=?=>
 infixl 1 >>?=
 (>>?=) :: forall m a b. Monad m => m ( Maybe a ) -> ( a -> m ( Maybe b ) ) -> m ( Maybe b )
 (>>?=) = coerce ( (>>=) @( MaybeT m ) @a @b )
-
---------------------------------------------------------------------------------
-
-traverseMaybe :: Applicative f => ( a -> f ( Maybe b ) ) -> Seq a -> f ( Seq b )
-traverseMaybe _ Empty        = pure Empty
-traverseMaybe f ( a :<| as ) = ( \ case { Nothing -> id; Just b -> ( b :<| ) } ) <$> f a <*> traverseMaybe f as
-
---------------------------------------------------------------------------------
-
-data Exists c where
-  Exists :: c a => a -> Exists c

src/app/MetaBrush/MetaParameter/Interpolation.hs

@@ -1,142 +0,0 @@
-{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE GADTs                  #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE PolyKinds              #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE TypeApplications       #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE TypeOperators          #-}
-{-# LANGUAGE UndecidableInstances   #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module MetaBrush.MetaParameter.Interpolation
-  ( Interpolatable(..)
-  , MapDiff, HasDiff', HasTorsor
-  )
-  where
-
--- base
-import Data.Functor.Identity
-  ( Identity(..) )
-import Data.Kind
-  ( Type )
-import Data.Monoid
-  ( Sum )
-import GHC.TypeLits
-  ( Symbol )
-
--- acts
-import Data.Act
-  ( Act(..), Torsor(..) )
-
--- groups
-import Data.Group
-  ( Group(..) )
-
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( (:=), Has, RecTy, RecApply(..), UnsafeRecBuild(..), TraversalC, traverseC
-  , get, set, modify
-  )
-import SuperRecord
-  ( ConstC, Tuple22C )
-
--- MetaBrush
-import Math.Module
-  ( Module(..) )
-import Math.Vector2D
-  ( Point2D, Vector2D )
-
---------------------------------------------------------------------------------
-
-class ( Module Double ( Diff a ), Torsor ( Diff a ) a ) => Interpolatable a where
-  type Diff a = ( d :: Type ) | d -> a
-
-instance ( a ~ Double ) => Interpolatable ( Point2D a ) where
-  type Diff ( Point2D a ) = Vector2D a
-
-instance Interpolatable Double where
-  type Diff Double = Sum Double
-
-instance ( dvs ~ MapDiff kvs
-         , SuperRecord.UnsafeRecBuild dvs dvs ( ConstC Monoid )
-         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has dvs ) )
-         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup )         ( SuperRecord.Has dvs ) )
-         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Group )             ( SuperRecord.Has dvs ) )
-         , SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
-         , SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
-         , Module Double ( Super.Rec ( MapDiff kvs ) )
-         )
-      => Interpolatable ( Super.Rec kvs )
-      where
-  type Diff ( Super.Rec kvs ) = Super.Rec ( MapDiff kvs )
-
-type family MapDiff ( kvs :: [ Type ] ) = ( lvs :: [ Type ] ) | lvs -> kvs where
-  MapDiff '[] = '[]
-  MapDiff ( k SuperRecord.:= v ': kvs ) = ( k SuperRecord.:= Diff v ': MapDiff kvs )
-
-
-instance  ( Monoid ( Super.Rec kvs ) 
-          , SuperRecord.RecApply kvs kvs
-              ( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
-          )
-       => Group ( Super.Rec kvs )
-    where
-  invert r = SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
-    ( \ lbl v res -> SuperRecord.set lbl ( invert v ) res ) r r
-instance  ( SuperRecord.RecApply kvs kvs
-             ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
-          , SuperRecord.UnsafeRecBuild kvs kvs ( ConstC ( Module Double ) )
-          )
-       => Module Double ( Super.Rec kvs )
-    where
-  origin = runIdentity $ SuperRecord.unsafeRecBuild @kvs @kvs @( ConstC ( Module Double ) ) ( \ _ _ -> Identity origin )
-  r1 ^+^ r2 =
-    SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
-      ( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^+^ ) res ) r1 r2
-  r1 ^-^ r2 =
-    SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
-      ( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^-^ ) res ) r1 r2
-  k *^ r =
-    SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
-      ( \ lbl v1 res -> SuperRecord.set lbl ( k *^ v1 ) res ) r r
-
-class    ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
-      => HasDiff ( kvs :: [ Type ] ) ( t :: Type ) ( k :: Symbol ) ( d :: Type )
-instance ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
-      => HasDiff kvs t k d
-
-type family FromJust ( a :: Maybe k ) :: k where
-  FromJust ( Just a ) = a
-
-class    HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
-instance HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
-
-instance ( dvs ~ MapDiff kvs
-         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) )
-         , SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
-         )
-      => Act ( Super.Rec dvs ) ( Super.Rec kvs )
-      where
-  ds • as = SuperRecord.recApply @dvs @dvs @( HasDiff' kvs )
-              ( \ lbl d1 res -> SuperRecord.modify lbl ( d1 • ) res ) ds as
-
-
-class    ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor ( kvs :: [Type] ) ( k :: Symbol ) t d where
-instance ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor kvs k t d where
-
-instance ( dvs ~ MapDiff kvs
-         , SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
-         , Act ( Super.Rec dvs ) ( Super.Rec kvs )
-         , Group ( Super.Rec dvs )
-         )
-      => Torsor ( Super.Rec dvs ) ( Super.Rec kvs ) where
-  as <-- bs =
-    runIdentity $ SuperRecord.traverseC @( HasTorsor kvs ) @Identity @kvs @dvs 
-      ( \ lbl a -> Identity ( a <-- SuperRecord.get lbl bs ) )
-      as

src/app/MetaBrush/Render/Document.hs

@@ -8,11 +8,11 @@
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE MagicHash             #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE NegativeLiterals      #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
@@ -35,10 +35,8 @@ import Data.Functor.Compose
   ( Compose(..) )
 import Data.Int
   ( Int32 )
-import GHC.Exts
-  ( Proxy#, proxy# )
 import GHC.Generics
-  ( Generic, Generic1 )
+  ( Generic, Generic1, Generically1(..) )
 
 -- acts
 import Data.Act
@@ -58,10 +56,6 @@ import Data.Set
 import Control.DeepSeq
   ( NFData(..), deepseq )
 
--- generic-data
-import Generic.Data
-  ( Generically1(..) )
-
 -- gi-cairo-render
 import qualified GI.Cairo.Render as Cairo
 
@@ -69,12 +63,6 @@ import qualified GI.Cairo.Render as Cairo
 import Control.Lens
   ( view )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( Intersect )
-
 -- transformers
 import Control.Monad.Trans.Class
   ( lift )
@@ -104,7 +92,7 @@ import Math.Vector2D
 import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Brush
-  ( Brush(..), BrushAdaptedTo(..) )
+  ( Brush(..) )
 import MetaBrush.Context
   ( Modifier(..)
   , HoldAction(..), PartialPath(..)
@@ -128,16 +116,23 @@ import MetaBrush.Document.Serialise
   ( ) -- 'Serialisable' instances
 import MetaBrush.Document.Update
   ( DocChange(..) )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.Interpolation
-  ( AdaptableFunction(..) )
+  ( Interpolatable, DRec )
-import MetaBrush.MetaParameter.Interpolation
+import MetaBrush.Records
-  ( MapDiff )
+  ( Record, Rec, WithParams(..)
+  , I(..), (:*:)(..)
+  , MyIntersection (..), myIntersect
+  )
+import qualified MetaBrush.Records as Rec
+  ( map )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
 import MetaBrush.Unique
   ( unsafeUnique )
 import MetaBrush.Util
-  ( traverseMaybe, withRGBA )
+  ( traverseMaybe )
+import MetaBrush.GTK.Util
+  ( withRGBA )
 
 --------------------------------------------------------------------------------
 
@@ -210,9 +205,9 @@ getDocumentRender
             , Just finalPoint <- mbFinalPoint
             , let
                 previewStroke :: Stroke
-                previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Super.Rec pointFields ) ->
+                previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Rec pointFields ) ->
                   let
-                    previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec pointFields ) )
+                    previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Rec pointFields ) )
                     previewSpline = catMaybesSpline ( invalidateCache undefined )
                       ( PointData p0 Normal pointData )
                       ( do
@@ -300,30 +295,42 @@ instance NFData StrokeRenderData where
 strokeRenderData :: FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
 strokeRenderData fitParams
   ( Stroke
-    { strokeSpline = spline :: StrokeSpline clo pointParams
+    { strokeSpline = spline :: StrokeSpline clo ( Rec pointFields )
-    , strokeBrush  = ( strokeBrush :: Maybe ( BrushAdaptedTo pointFields ) )
+    , strokeBrush  = ( strokeBrush :: Maybe ( Brush brushFields ) )
     , ..
     }
   ) | strokeVisible
     = Just $ case strokeBrush of
-        Just ( AdaptedBrush ( brush :: Brush brushFields ) )
+        Just ( BrushData { brushFunction = fn } )
-          | ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
+          | WithParams
-          -- Get the adaptable brush shape (function),
+             { defaultParams = brush_defaults
-          -- specialising it to the type we are using.
+             , withParams    = brushFn
-          , let
+             } <- fn
-              toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
-              brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
-              AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush
           -> do
+            -- Use the handy 'intersect' function to do a computation
+            -- using only the relevant fields (which are the intersection
+            -- of the parameters along the stroke and the brush parameters).
+            --
+            -- See also MetaBrush.DSL.Eval.eval for how we interpret brush code
+            -- to obtain a brush function.
+            case myIntersect @Interpolatable @pointFields brush_defaults of
+              MyIntersection
+                { myProject = project :: forall f. Record f pointFields -> Record (f :*: I) usedFields
+                , myInject } -> do
+                let
+                  toUsedParams :: Rec pointFields -> Rec usedFields
+                  toUsedParams given = Rec.map ( \ (x :*: _) -> x ) $ project @I given
+                  embedUsedParams :: Rec usedFields -> Rec brushFields
+                  embedUsedParams = myInject
                 -- Compute the outline using the brush function.
                 ( outline, fitPts ) <-
-              computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
+                  computeStrokeOutline @( DRec usedFields ) @clo @( Rec usedFields )
-                fitParams ( toUsedParams . brushParams ) brushShapeFn spline
+                    fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline
                 pure $
                   StrokeWithOutlineRenderData
                     { strokeDataSpline    = spline
                     , strokeOutlineData   = ( outline, fitPts )
-                , strokeBrushFunction = brushShapeFn . toUsedParams
+                    , strokeBrushFunction = brushFn . embedUsedParams . toUsedParams
                     }
         _ -> pure $
                 StrokeRenderData

src/app/MetaBrush/Render/Rulers.hs

@@ -70,7 +70,7 @@ import MetaBrush.UI.Viewport
   ( Ruler(..) )
 import MetaBrush.Unique
   ( unsafeUnique )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/FileBar.hs

@@ -72,7 +72,7 @@ import MetaBrush.UI.Viewport
   ( Viewport(..) )
 import MetaBrush.Unique
   ( Unique, freshUnique, uniqueText )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/FileBar.hs-boot

@@ -1,6 +1,6 @@
 module MetaBrush.UI.FileBar
   ( FileBar(..), FileBarTab(..), TabLocation(..)
-  , removeFileTab
+  , newFileTab, removeFileTab
   )
   where
 
@@ -10,6 +10,8 @@ import qualified GI.Gtk as GTK
 -- MetaBrush
 import {-# SOURCE #-} MetaBrush.Context
   ( Variables, UIElements )
+import MetaBrush.Document.History
+  ( DocumentHistory )
 import MetaBrush.Unique
   ( Unique )
 
@@ -35,4 +37,5 @@ data TabLocation
 
 instance Show TabLocation
 
+newFileTab :: UIElements -> Variables -> Maybe DocumentHistory -> TabLocation -> IO ()
 removeFileTab :: UIElements -> Variables -> Unique -> IO ()

src/app/MetaBrush/UI/InfoBar.hs

@@ -55,7 +55,7 @@ import MetaBrush.Document
   ( Document(..) )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/Menu.hs

@@ -59,7 +59,7 @@ import MetaBrush.Asset.WindowIcons
   ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
 import MetaBrush.UI.FileBar
   ( TabLocation(..) )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/Panels.hs

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

src/app/MetaBrush/UI/ToolBar.hs

@@ -40,7 +40,7 @@ import MetaBrush.Asset.Tools
   ( drawBug, drawBrush, drawMeta, drawPath, drawPen )
 import MetaBrush.Context
   ( Variables(..) )
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( widgetAddClass )
 
 --------------------------------------------------------------------------------

src/app/MetaBrush/UI/Viewport.hs

@@ -18,8 +18,10 @@ import Data.Foldable
 import qualified GI.Gtk as GTK
 
 -- MetaBrush
-import MetaBrush.Util
+import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
+import MetaBrush.Document
+  ( Ruler(..) )
 
 --------------------------------------------------------------------------------
 
@@ -167,11 +169,3 @@ createViewport viewportGrid = do
   -}
 
   pure ( Viewport {..} )
-
---------------------------------------------------------------------------------
-
-data Ruler
-  = RulerCorner
-  | LeftRuler
-  | TopRuler
-  deriving stock Show

src/metabrushes/MetaBrush/Brush.hs

@@ -0,0 +1,167 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE MagicHash           #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE QuantifiedConstraints#-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module MetaBrush.Brush
+  ( Brush(..), SomeBrush(..)
+  , BrushFunction
+  , SomeFieldSType(..), SomeBrushFields(..)
+  , reflectBrushFieldsNoDups
+  )
+  where
+
+-- base
+import Control.Arrow
+  ( second )
+import GHC.Exts
+  ( Proxy#, Any )
+import Unsafe.Coerce
+  ( unsafeCoerce )
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..), deepseq )
+
+-- hashable
+import Data.Hashable
+  ( Hashable(..) )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( unpack )
+
+-- unordered-containers
+import qualified Data.HashMap.Strict as HashMap
+  ( fromList )
+
+-- MetaBrush
+import Math.Bezier.Spline
+  ( SplineType(Closed), SplinePts)
+import MetaBrush.Serialisable
+  ( Serialisable )
+import MetaBrush.DSL.Types
+  ( STypeI, STypesI(sTypesI)
+  , SomeSType(..), proveSomeSTypes
+  )
+import MetaBrush.DSL.Interpolation
+  ( Interpolatable(..) )
+import MetaBrush.Records
+  ( Record(MkR), Rec, AllFields
+  , WithParams(..)
+  , Dict(..)
+  , proveRecordDicts
+  )
+import qualified MetaBrush.Records as Rec
+  ( map )
+
+--------------------------------------------------------------------------------
+
+type BrushFunction brushFields = WithParams brushFields (SplinePts Closed)
+
+data Brush brushFields where
+  BrushData
+    :: forall brushFields
+    .  ( STypesI brushFields )
+    =>
+      { brushName     :: !Text
+      , brushCode     :: !Text
+      , brushFunction :: BrushFunction brushFields
+      }
+    -> Brush brushFields
+
+data SomeBrush where
+  SomeBrush
+    :: STypesI brushFields
+    => { someBrush :: !( Brush brushFields ) }
+    -> SomeBrush
+
+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 brushFields ) where
+  BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2
+instance Ord ( Brush brushFields ) where
+  compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 )
+instance Hashable ( Brush brushFields ) where
+  hashWithSalt salt ( BrushData { brushName, brushCode } ) =
+    hashWithSalt ( hashWithSalt salt brushName ) brushCode
+
+--------------------------------------------------------------------------------
+-- Instance dictionary passing machinery.
+
+-- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double.
+data SomeFieldSType where
+  SomeFieldSType
+    :: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a )
+    => SomeFieldSType
+
+data FieldSType a where
+  FieldSType
+    :: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a )
+    => FieldSType a
+
+-- | Existential type for allowed fields of a brush record.
+data SomeBrushFields where
+  SomeBrushFields
+    :: forall kvs rec
+    . ( STypesI kvs
+      , rec ~ Rec kvs
+      , Show rec, NFData rec
+      , Serialisable rec
+      , AllFields Interpolatable kvs
+      )
+    => SomeBrushFields
+
+instance Show SomeBrushFields where
+  show ( SomeBrushFields @kvs ) = show ( sTypesI @kvs )
+
+-- | Reflects a list of brush fields to the type level.
+--
+-- Assumes the input list has no duplicate field names,
+-- but they don't have to be sorted.
+reflectBrushFieldsNoDups :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
+reflectBrushFieldsNoDups elts =
+  let
+    mkSomeSType :: SomeFieldSType -> SomeSType
+    mkSomeSType (SomeFieldSType @a) = SomeSType @a
+    mkField :: SomeFieldSType -> FieldSType Any
+    mkField (SomeFieldSType @a) = unsafeCoerce $ FieldSType @a
+  in
+  proveSomeSTypes (map (second mkSomeSType) elts) \ ( _ :: Proxy# kvs ) ->
+    let
+      dictsRec :: Record FieldSType kvs
+      dictsRec = MkR (HashMap.fromList $ map (second mkField) elts)
+      showDicts :: Record (Dict Show) kvs
+      showDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Show @a ) dictsRec
+      nfDataDicts :: Record (Dict NFData) kvs
+      nfDataDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @NFData @a ) dictsRec
+      serialisableDicts :: Record (Dict Serialisable) kvs
+      serialisableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Serialisable @a ) dictsRec
+      interpolatableDicts :: Record (Dict Interpolatable) kvs
+      interpolatableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Interpolatable @a ) dictsRec
+    in
+      proveRecordDicts @Show           showDicts $
+      proveRecordDicts @NFData         nfDataDicts $
+      proveRecordDicts @Serialisable   serialisableDicts $
+      proveRecordDicts @Interpolatable interpolatableDicts $
+        SomeBrushFields @kvs

src/metabrushes/MetaBrush/DSL/AST.hs

@@ -15,53 +15,37 @@
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilyDependencies     #-}
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
 
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
-module MetaBrush.MetaParameter.AST
+module MetaBrush.DSL.AST
   ( Span(..), Located(.., Location)
   , Term(..), Pat(..), Decl(..)
   , toTreeArgsTerm, toTreeTerm, toTreePat, toTreeDecl
   , termSpan
   , TypedTerm(..), TypedPat(..)
-  , SType(..), STypeI(..), SomeSType(..)
-  , STypes(..), STypesI(..), someSTypes
-  , eqSTy, eqTy, eqSTys, eqTys
   , Pass(..), Name, UniqueName(..), Loc
   , Ext_With(..), X_With(..)
-  , MapFields, IsUniqueTerm, IsUniqueTerm2, UseFieldsInBrush
+  , UniqueField(..), UniqueTerm(..)
-  , UniqueField(..), GetUniqueField, UniqueTerm, GetUniqueTerm
-  , Adapted, AdaptableFunction(..), BrushFunction
   , X_Ext(..)
   , Expr, EPat, RnExpr, RnPat
   )
   where
 
 -- base
-import Data.Functor.Compose
-  ( Compose(..) )
 import Data.Functor.Identity
   ( Identity(..) )
 import Data.Kind
   ( Type, Constraint )
-import Data.List
-  ( intercalate )
-import Data.Proxy
-  ( Proxy(..) )
-import Data.Type.Equality
-  ( (:~:)(Refl) )
-import GHC.Exts
-  ( Proxy#, proxy# )
 import GHC.Generics
   ( Generic )
 import GHC.TypeLits
-  ( Symbol, KnownSymbol, symbolVal', sameSymbol )
+  ( Symbol )
-import GHC.TypeNats
-  ( KnownNat )
 
 -- containers
 import Data.Tree
@@ -71,19 +55,9 @@ import Data.Tree
 import Control.DeepSeq
   ( NFData(..) )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( (:=), RecApply, UnsafeRecBuild, Has, TraversalC
-  , Intersect, Lookup, RecTy, RecSize, reflectRec
-  )
-
 -- text
 import Data.Text
   ( Text )
-import qualified Data.Text as Text
-  ( pack )
 
 -- MetaBrush
 import Math.Vector2D
@@ -93,10 +67,14 @@ import qualified Math.Bezier.Cubic     as Cubic
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier(..) )
 import Math.Bezier.Spline
-  ( Spline(..), SplinePts, SplineType(..)
+  ( Spline(..), SplineType(..)
   , SSplineType(..), SplineTypeI(ssplineType), KnownSplineType(bifoldSpline)
   , Curve(..), NextPoint(..)
   )
+import MetaBrush.DSL.Types
+  ( STypeI(..) )
+import MetaBrush.Records
+  ( Record, WithParams, foldRec )
 import MetaBrush.Unique
   ( Unique )
 
@@ -137,148 +115,6 @@ data Located a =
 pattern Location :: Span -> Located ()
 pattern Location loc = Located loc ()
 
-----------
--- Types.
-
-data SType ( ty :: Type ) where
-  SFunTy    :: ( STypeI a, STypeI b ) => SType ( a -> b )
-  STyBool   :: SType Bool
-  STyDouble :: SType Double
-  STyPoint  :: STypeI a => SType ( Point2D a )
-  STyLine   :: STypeI a => SType ( Segment a )
-  STyBez2   :: STypeI a => SType ( Quadratic.Bezier a )
-  STyBez3   :: STypeI a => SType ( Cubic.Bezier a )
-  STySpline :: KnownSplineType clo => SType ( SplinePts clo )
-  STyWithFn :: ( STypesI kvs, STypeI a ) => SType ( AdaptableFunction kvs a )
-  -- reminder: update eqSTy when adding new constructors
-
-deriving stock instance Show ( SType ty )
-
-class STypeI ty where
-  sTypeI :: SType ty
-instance ( STypeI a, STypeI b ) => STypeI ( a -> b ) where
-  sTypeI = SFunTy
-instance STypeI Bool where
-  sTypeI = STyBool
-instance STypeI Double where
-  sTypeI = STyDouble
-instance STypeI a => STypeI ( Point2D a ) where
-  sTypeI = STyPoint
-instance STypeI a => STypeI ( Segment a ) where
-  sTypeI = STyLine
-instance STypeI a => STypeI ( Quadratic.Bezier a ) where
-  sTypeI = STyBez2
-instance STypeI a => STypeI ( Cubic.Bezier a ) where
-  sTypeI = STyBez3
-instance KnownSplineType clo => STypeI ( SplinePts clo ) where
-  sTypeI = STySpline
-instance ( STypesI kvs, STypeI a ) => STypeI ( AdaptableFunction kvs a ) where
-  sTypeI = STyWithFn
-
-data STypes ( kvs :: [ Type ] ) where
-  STyNil  :: STypes '[]
-  STyCons :: ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypes ( kv ': kvs )
-instance Show ( STypes kvs ) where
-  show sTypes = "'[" <> intercalate "," ( showSTypes sTypes ) <> "]"
-showSTypes :: STypes kvs -> [ String ]
-showSTypes STyNil = []
-showSTypes sTyCons@STyCons
-  | ( _ :: STypes ( ( k SuperRecord.:= v ) ': tail_kvs ) ) <- sTyCons
-  = ( symbolVal' ( proxy# :: Proxy# k ) <> " := " <> show ( sTypeI @v ) ) : showSTypes ( sTypesI @tail_kvs )
-
-class KnownNat ( SuperRecord.RecSize kvs ) => STypesI kvs where
-  sTypesI :: STypes kvs
-
-instance STypesI '[] where
-  sTypesI = STyNil
--- Warning: this instance is somewhat overly general as it doesn't check for lack of duplicates
-instance ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypesI ( kv ': kvs ) where
-  sTypesI = STyCons
-
-data SomeSType where
-  SomeSType :: STypeI a => Proxy# a -> SomeSType
-instance Show SomeSType where
-  show ( SomeSType ( _ :: Proxy# a ) ) = show ( sTypeI @a )
-instance Eq SomeSType where
-  ( SomeSType ( _ :: Proxy# a ) ) == ( SomeSType ( _ :: Proxy# b ) ) =
-    case eqTy @a @b of
-      Just _ -> True
-      _      -> False
-
-eqSTy :: SType a -> SType b -> Maybe ( a :~: b )
-eqSTy sTy_a@SFunTy sTy_b@SFunTy
-  | ( _ :: SType ( a1 -> b1 ) ) <- sTy_a
-  , ( _ :: SType ( a2 -> b2 ) ) <- sTy_b
-  , Just Refl <- eqTy @a1 @a2
-  , Just Refl <- eqTy @b1 @b2
-  = Just Refl
-eqSTy STyBool   STyBool   = Just Refl
-eqSTy STyDouble STyDouble = Just Refl
-eqSTy sTy_a@STyPoint sTy_b@STyPoint
-  | ( _ :: SType ( Point2D l ) ) <- sTy_a
-  , ( _ :: SType ( Point2D r ) ) <- sTy_b
-  , Just Refl <- eqTy @l @r
-  = Just Refl
-eqSTy sTy_a@STyLine sTy_b@STyLine
-  | ( _ :: SType ( Segment l ) ) <- sTy_a
-  , ( _ :: SType ( Segment r ) ) <- sTy_b
-  , Just Refl <- eqTy @l @r
-  = Just Refl
-eqSTy sTy_a@STyBez2 sTy_b@STyBez2
-  | ( _ :: SType ( Quadratic.Bezier l ) ) <- sTy_a
-  , ( _ :: SType ( Quadratic.Bezier r ) ) <- sTy_b
-  , Just Refl <- eqTy @l @r
-  = Just Refl
-eqSTy sTy_a@STyBez3 sTy_b@STyBez3
-  | ( _ :: SType ( Cubic.Bezier l ) ) <- sTy_a
-  , ( _ :: SType ( Cubic.Bezier r ) ) <- sTy_b
-  , Just Refl <- eqTy @l @r
-  = Just Refl
-eqSTy sTy_a@STySpline sTy_b@STySpline
-  | ( _ :: SType ( SplinePts clo1 ) ) <- sTy_a
-  , ( _ :: SType ( SplinePts clo2 ) ) <- sTy_b
-  = case ( ssplineType @clo1, ssplineType @clo2 ) of
-      ( SOpen  , SOpen   ) -> Just Refl
-      ( SClosed, SClosed ) -> Just Refl
-      _                    -> Nothing
-eqSTy sTy_a@STyWithFn sTy_b@STyWithFn
-  | ( _ :: SType ( AdaptableFunction kvs a ) ) <- sTy_a
-  , ( _ :: SType ( AdaptableFunction lvs b ) ) <- sTy_b
-  , Just Refl <- eqTys @kvs @lvs
-  , Just Refl <- eqTy  @a   @b
-  = Just Refl
-eqSTy _ _ = Nothing
-
-eqTy :: forall a b. ( STypeI a, STypeI b ) => Maybe ( a :~: b )
-eqTy = eqSTy ( sTypeI @a ) ( sTypeI @b )
-
-eqSTys :: STypes as -> STypes bs -> Maybe ( as :~: bs )
-eqSTys STyNil STyNil = Just Refl
-eqSTys sTyCons1@STyCons sTyCons2@STyCons
-  | ( _ :: STypes ( ( l1 SuperRecord.:= v1 ) ': as' ) ) <- sTyCons1
-  , ( _ :: STypes ( ( l2 SuperRecord.:= v2 ) ': bs' ) ) <- sTyCons2
-  , Just Refl <- sameSymbol ( Proxy :: Proxy l1 ) ( Proxy :: Proxy l2 )
-  , Just Refl <- eqTy @v1 @v2
-  , Just Refl <- eqTys @as' @bs'
-  = Just Refl
-eqSTys _ _ = Nothing
-
-eqTys :: forall as bs. ( STypesI as, STypesI bs ) => Maybe ( as :~: bs )
-eqTys = eqSTys ( sTypesI @as ) ( sTypesI @bs )
-
-someSTypes :: forall kvs. STypesI kvs => [ ( Text, SomeSType ) ]
-someSTypes = go ( sTypesI @kvs )
-  where
-    go :: forall lvs. STypes lvs -> [ ( Text, SomeSType ) ]
-    go STyNil = []
-    go sTyCons@STyCons
-      | ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs' ) ) <- sTyCons
-      , let
-          l :: Text
-          l = Text.pack $ symbolVal' ( proxy# :: Proxy# l )
-      = ( l, SomeSType ( proxy# :: Proxy# v ) )
-      : go ( sTypesI @lvs' )
-
 ------------------------------------------------
 -- AST. --
 ----------
@@ -286,42 +122,51 @@ someSTypes = go ( sTypesI @kvs )
 data Pass = P | Rn | Tc
   deriving stock Show
 
+-- | What kind should we use for the intrinsic typing of the AST?
+--
+-- Parsing and renaming: no intrinsic typing, so use the unit type.
+-- Typechecking: a term is typed with something of kind 'Type'.
 type family K ( p :: Pass ) :: Type where
   K P  = ()
   K Rn = ()
   K Tc = Type
 
-type family Ks ( p :: Pass ) :: Type where
+-- | What kind should we use for the intrinsic typing of rows?
-  Ks P  = ()
+--
-  Ks Rn = ()
+-- Parsing and renaming: no intrinsic typing, use the unit type.
-  Ks Tc = [Type]
+-- Typechecking: records use an association list @Symbol --> Type@.
+type family Kvs ( p :: Pass ) :: Type where
+  Kvs P = ()
+  Kvs Rn = ()
+  Kvs Tc = [ ( Symbol, Type ) ]
 
-type family T ( p :: Pass ) ( t :: Type ) :: K p where
+-- | Label a term with its type, depending on the pass.
+type T :: forall (p :: Pass) -> Type -> K p
+type family T p t where
   T P  _ = '()
   T Rn _ = '()
   T Tc a = a
 
-type family Ts ( p :: Pass ) ( as :: [ Type ] ) :: Ks p where
+-- | Label a record with its type, depending on the pass.
-  Ts P  _           = '()
+type R :: forall (p :: Pass) -> [ ( Symbol, Type ) ] -> Kvs p
-  Ts Rn _           = '()
+type family R p kvs where
-  Ts Tc '[]         = '[]
-  Ts Tc ( a ': as ) = T Tc a ': Ts Tc as
-
-type family R ( p :: Pass ) ( kvs :: [ Type ] ) :: Ks p where
   R P  _   = '()
   R Rn _   = '()
   R Tc kvs = kvs
 
+-- | We produce evidence for constraints at the constraint solving stage;
+-- before that, use the unit type to represent lack of any kind of evidence.
+--
+--  - @C p ct@: a constraint for which evidence is produced by the constraint solver.
+--  - @ct@: a constraint for which evidence is provided at the start.
 type family C ( p :: Pass ) ( ct :: Constraint ) :: Constraint where
   C P  _  = ()
   C Rn _  = ()
   C Tc ct = ct
 
--- C p ct: constraint for which evidence is generated at Tc stage
--- ct: constraint for which evidence is provided from the start
-
 infixl 9 :$
-data Term ( p :: Pass ) ( kind :: K p ) where
+type Term :: forall (p :: Pass) -> K p -> Type
+data Term p kind where
   (:$)  :: C p ( STypeI a )
         => Term p ( T p ( a -> b ) )
         -> Term p ( T p a )
@@ -333,13 +178,13 @@ data Term ( p :: Pass ) ( kind :: K p ) where
            , let_body  :: !( Term p ( T p a ) )
            }
         -> Term p ( T p a )
-  With  :: forall ( p :: Pass ) ( kvs :: [ Type ] ) ( a :: Type )
+  With  :: forall ( p :: Pass ) ( kvs :: [ ( Symbol, Type ) ] ) ( a :: Type )
         .  C p ( STypeI a )
         => ![ Loc p () ]
         -> !( X_With p ( R p kvs ) )
         -> ![ Term p ( T p Bool ) ]
         -> !( Term p ( T p a ) )
-        -> Term p ( T p ( AdaptableFunction kvs a ) )
+        -> Term p ( T p ( WithParams kvs a ) )
   Lit   :: ( Show a, STypeI a )
         => !( Loc p ( Maybe Text ) )
         -> !a
@@ -384,7 +229,8 @@ data Decl ( p :: Pass ) where
     -> !( Term p ( T p b ) )
     -> Decl p
 
-data Pat ( p :: Pass ) ( kind :: K p ) where
+type Pat :: forall (p :: Pass) -> K p -> Type
+data Pat p kind where
   PName :: { patName :: !( Loc p ( Name p ) ) }
         -> Pat p ( T p a )
   PPoint :: ![ Loc p () ]
@@ -429,9 +275,10 @@ type instance Name   Tc  = UniqueName
 type family   Loc  ( p :: Pass ) ( a :: Type ) :: Type
 type instance Loc p a = Located a
 
-class Ext_With ( p :: Pass ) ( kvs :: Ks p ) where
+type Ext_With :: forall (p :: Pass) -> Kvs p -> Constraint
+class Ext_With p kvs where
   data family X_With p kvs :: Type
-  toTreeWith :: forall ( lvs :: Ks p ). Ext_With p lvs => X_With p kvs -> [ Tree String ]
+  toTreeWith :: forall ( lvs :: Kvs p ). Ext_With p lvs => X_With p kvs -> [ Tree String ]
 
 instance Ext_With P kvs where
   newtype X_With P _ = P_With [ Decl P ]
@@ -441,99 +288,25 @@ instance Ext_With Rn kvs where
   newtype X_With Rn _ = Rn_With [ Decl Rn ]
   toTreeWith ( Rn_With decls ) = map toTreeDecl decls
 
-
 instance Ext_With Tc kvs where
   data X_With Tc kvs where
-    Tc_With
+    Tc_With :: Record UniqueTerm kvs -> X_With Tc kvs
-      :: ( ts ~ MapFields UniqueTerm  kvs
-         , fs ~ MapFields UniqueField kvs
-         , SuperRecord.RecApply ts ts IsUniqueTerm
-         , SuperRecord.TraversalC IsUniqueTerm2 ts fs
-         )
-      => Super.Rec ts -> X_With Tc kvs
   toTreeWith ( Tc_With decls ) =
-    SuperRecord.reflectRec @IsUniqueTerm
+    foldRec
-      ( \ _ ( Compose ( UniqueField { uniqueField = a } ) ) -> toTreeTerm @Tc a )
+      ( \ ( UniqueTerm { uniqueTerm = a } ) rest -> toTreeTerm @Tc a : rest )
       decls
+      []
 
-data UniqueField a =
+data UniqueField a where
-  UniqueField { uniqueFieldName :: !UniqueName, uniqueField :: !a }
+  UniqueField
-
+    :: STypeI a
-type UniqueTerm = Compose UniqueField ( Term Tc )
+    => { uniqueFieldName :: !UniqueName, uniqueField :: !a }
-
+    -> UniqueField a
-type family MapFields ( f :: Type -> Type ) ( kvs :: [ Type ] ) = ( r :: [ Type ] ) | r -> kvs where
+data UniqueTerm a where
-  MapFields _ '[] = '[]
+  UniqueTerm
-  MapFields f ( ( k SuperRecord.:= v ) ': kvs ) = ( k SuperRecord.:= f v ) ': MapFields f kvs
+    :: STypeI a
-
+    => { uniqueTermName :: !UniqueName, uniqueTerm :: !( Term Tc a ) }
-
+    -> UniqueTerm a
-type family GetUniqueField ( uniqueField :: Type ) :: Type where
-  GetUniqueField ( UniqueField a ) = a
-type family GetUniqueTerm ( uniqueTerm :: Type ) :: Type where
-  GetUniqueTerm ( Compose UniqueField ( Term Tc ) a ) = a
-
-class    ( STypeI ( GetUniqueTerm t )
-         , t ~ UniqueTerm ( GetUniqueTerm t )
-         )
-      => IsUniqueTerm ( k :: Symbol ) t
-  where
-instance ( STypeI ( GetUniqueTerm t )
-         , t ~ UniqueTerm ( GetUniqueTerm t )
-         )
-      => IsUniqueTerm ( k :: Symbol ) t
-  where
-
-class    ( IsUniqueTerm k t
-         , a ~ UniqueField ( GetUniqueField a )
-         , GetUniqueTerm t ~ GetUniqueField a
-         )
-      => IsUniqueTerm2 k t a
-  where
-instance ( IsUniqueTerm k t
-         , a ~ UniqueField ( GetUniqueField a )
-         , GetUniqueTerm t ~ GetUniqueField a
-         )
-      => IsUniqueTerm2 k t a
-  where
-
-class    ( STypeI ( GetUniqueField t )
-         , t ~ UniqueField ( GetUniqueField t )
-         , SuperRecord.Lookup kvs k ( GetUniqueField t )
-              ( SuperRecord.RecTy k kvs )
-         )
-      => UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
-instance ( STypeI ( GetUniqueField t )
-         , t ~ UniqueField ( GetUniqueField t )
-         , SuperRecord.Lookup kvs k ( GetUniqueField t )
-              ( SuperRecord.RecTy k kvs )
-         )
-      => UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
-
-class    ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
-         , SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
-         , SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
-              ( UseFieldsInBrush usedFields )
-         )
-      => Adapted brushFields givenFields usedFields | givenFields brushFields -> usedFields
-instance ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
-         , SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
-         , SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
-              ( UseFieldsInBrush usedFields )
-         )
-      => Adapted brushFields givenFields usedFields 
-
-type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Closed )
-newtype AdaptableFunction brushFields a
-  = AdaptableFunction
-      ( forall givenFields usedFields
-      .  ( Adapted brushFields givenFields usedFields
-         -- Debugging.
-         , Show ( Super.Rec givenFields )
-         )
-      => ( Super.Rec givenFields -> Super.Rec usedFields
-         , Super.Rec usedFields  -> a
-         )
-      )
-
 
 class Ext ( p :: Pass ) ( a :: K p ) where
   data family X_Ext ( p :: Pass ) a :: Type
@@ -582,7 +355,7 @@ toTreeTerm = toTreeArgsTerm @p @a []
 
 toTreeArgsTerm
   :: forall ( p :: Pass ) ( a :: K p )
-  .  ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
+  .  ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Kvs p). Ext_With p kvs )
   => [ Tree String ]
   -> Term p a
   -> Tree String
@@ -598,12 +371,10 @@ toTreeArgsTerm as ( Line    _ p0 p1       ) = Node "Line" ( toTreeTerm p0 : toTr
 toTreeArgsTerm as ( Bez2    _ p0 p1 p2    ) = Node "Bez2" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : as )
 toTreeArgsTerm as ( Bez3    _ p0 p1 p2 p3 ) = Node "Bez3" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : toTreeTerm p3 : as )
 toTreeArgsTerm as ( PolyBez _ spline      ) = Node "Spline"
-  ( ( runIdentity
+  ( runIdentity (( bifoldSpline @_ @Identity @[ Tree String ] @_ )
-    $ ( bifoldSpline @_ @Identity @[ Tree String ] @_ )
         ( const ( toTreeCurve @p ) )
         ( Identity . (:[]) . toTreeTerm )
-      spline
+      spline)
-    )
   <> as
   )
 toTreeArgsTerm as ( Let _ ds a ) =
@@ -623,7 +394,7 @@ toTreeArgsTerm as ( CExt ext ) = toTreeArgsExt as ext
 
 toTreeDecl
   :: forall ( p :: Pass )
-  .  ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
+  .  ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Kvs p). Ext_With p kvs )
   => Decl p
   -> Tree String
 toTreeDecl ( ValDecl lhs _ rhs ) = Node "(=)" [ toTreePat lhs, toTreeTerm rhs ]
@@ -637,7 +408,7 @@ toTreePat ( AsPat _ nm pat   ) = Node "(@)"       [ Node ( show nm ) [], toTreeP
 
 toTreeCurve
   :: forall ( p :: Pass ) ( clo :: SplineType ) ( crvData :: Type ) ( a :: K p )
-  .  ( SplineTypeI clo, Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
+  .  ( SplineTypeI clo, Show ( Name p ), forall x. Ext p x, forall (kvs :: Kvs p). Ext_With p kvs )
   => Curve clo crvData ( Term p a )
   -> Identity [ Tree String ]
 toTreeCurve curve = Identity . (:[]) $ case ssplineType @clo of

src/metabrushes/MetaBrush/DSL/Driver.hs

@@ -12,11 +12,7 @@
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module MetaBrush.MetaParameter.Driver where
+module MetaBrush.DSL.Driver where
-
--- base
-import GHC.Exts
-  ( Proxy#, proxy# )
 
 -- dlist
 import qualified Data.DList as DList
@@ -43,22 +39,27 @@ import Control.Monad.Trans.State.Strict
 -- MetaBrush
 import Math.Bezier.Spline
   ( SplinePts, SSplineType(SClosed), SplineTypeI(ssplineType) )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.Brush
+  ( BrushFunction )
+import MetaBrush.DSL.AST
   ( Located
   , Term, TypedTerm(..)
-  , SType(..), STypeI(sTypeI)
-  , SomeSType(..), STypesI
   , Pass(Tc)
-  , AdaptableFunction(..), BrushFunction
   )
-import MetaBrush.MetaParameter.Eval
+import MetaBrush.DSL.Types
+  ( SType(..), STypeI(sTypeI)
+  , SomeSType(..), STypesI
+  )
+import MetaBrush.DSL.Eval
   ( EvalState(..), eval )
-import MetaBrush.MetaParameter.Parse
+import MetaBrush.DSL.Parse
   ( grammar, Token, tokenize )
-import MetaBrush.MetaParameter.Rename
+import MetaBrush.DSL.Rename
   ( rename, RnM, RnMessage, RnError, emptyRnState )
-import MetaBrush.MetaParameter.TypeCheck
+import MetaBrush.DSL.TypeCheck
   ( typeCheck, TcM, TcMessage, TcError, emptyTcState )
+import MetaBrush.Records
+  ( WithParams )
 import MetaBrush.Unique
   ( UniqueSupply, MonadUnique(freshUnique) )
 
@@ -133,7 +134,7 @@ interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser gr
       -- a closed brush shape.
       Right ( TypedTerm ( term :: Term Tc v ) )
         | sTyWithFn@STyWithFn <- sTypeI @v
-        , ( _ :: SType ( AdaptableFunction kvs b ) ) <- sTyWithFn
+        , ( _ :: SType ( WithParams kvs b ) ) <- sTyWithFn
         , sTySpline@STySpline <- sTypeI @b
         , ( _ :: SType ( SplinePts clo ) ) <- sTySpline
         , SClosed <- ssplineType @clo
@@ -147,4 +148,4 @@ interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser gr
             val = ( `evalState` initEvalState ) $ eval term
           pure ( Right ( SomeBrushFunction @kvs val ), messages )
         | otherwise
-        -> pure ( Left ( NonBrushType ( SomeSType ( proxy# :: Proxy# v ) ) ), messages )
+        -> pure ( Left ( NonBrushType ( SomeSType @v ) ), messages )

src/metabrushes/MetaBrush/DSL/Eval.hs

@@ -15,15 +15,13 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
-module MetaBrush.MetaParameter.Eval
+module MetaBrush.DSL.Eval
   ( EvalState(..), eval )
   where
 
 -- base
 import Data.Foldable
   ( for_, traverse_ )
-import Data.Functor.Compose
-  ( Compose(..) )
 import Data.Type.Equality
   ( (:~:)(Refl) )
 import GHC.Generics
@@ -47,12 +45,6 @@ import Control.Lens
 import Control.Monad.State
   ( get )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( RecApply(..), Lookup(..), Has, UnsafeRecBuild, traverseC, project )
-
 -- text
 import Data.Text
   ( Text )
@@ -72,17 +64,25 @@ import Math.Bezier.Spline
   ( KnownSplineType(bitraverseSpline), bitraverseCurve )
 import Math.Vector2D
   ( Point2D(..), Segment(..) )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.AST
   ( Term(..), Pat(..), Decl(..)
-  , TypedTerm(..), STypeI(..), SType(..)
+  , TypedTerm(..)
   , Pass(Tc), X_Ext(..), X_With(..)
   , Span(..), Located(..)
-  , MapFields, AdaptableFunction(..)
+  , UniqueField(..), UniqueTerm(..)
-  , UniqueField(..), UniqueTerm, IsUniqueTerm2, UseFieldsInBrush
+  )
+import MetaBrush.DSL.Types
+  ( STypeI(..), SType(..)
   , eqTy
   )
-import MetaBrush.MetaParameter.Rename
+import MetaBrush.DSL.Rename
   ( UniqueName(..) )
+import MetaBrush.Records
+  ( Record, Rec, I(..), WithParams(..)
+  , foldRec
+  )
+import qualified MetaBrush.Records as Rec
+  ( map, mapM, zipWith )
 import MetaBrush.Unique
   ( Unique )
 
@@ -109,33 +109,45 @@ eval ( PolyBez _ spline ) =
     eval
     spline
 eval ( Let _ decls a ) = traverse_ declare decls *> eval a
-eval ( With _ ( Tc_With ( withDeclsRecord :: Super.Rec ( MapFields UniqueTerm brushFields ) ) ) _ ( body :: Term Tc r ) ) = do
+eval ( With _ ( Tc_With ( withDeclsRecord :: Record UniqueTerm brushFields ) ) _ ( body :: Term Tc r ) ) = do
-  defaultParamsRecord <-
+
-    SuperRecord.traverseC @IsUniqueTerm2 @( State EvalState ) @( MapFields UniqueTerm brushFields ) @( MapFields UniqueField brushFields )
+  -- Evaluate the default parameter values for the brush.
-      ( \ _ ( Compose ( UniqueField uniq term ) ) -> UniqueField uniq <$> eval term )
+  ( defaultParamsRecord :: Record UniqueField brushFields ) <-
+    Rec.mapM
+      ( \ ( UniqueTerm uniq term ) -> do
+        val <- eval term
+        return $ UniqueField uniq val
+        )
       withDeclsRecord
+
+  -- Interpretation: compute the brush function by binding
+  -- the provided values.
   EvalState { evalHeap, nextUnique } <- get
   let
-    toBrushParameters
+    brushFunction :: Rec brushFields -> r
-      :: forall givenFields usedFields
+    brushFunction brushParams =
-      .  ( SuperRecord.UnsafeRecBuild usedFields usedFields
+      -- We will receive a record of parameters that will
-             ( SuperRecord.Has givenFields )
+      -- have been obtained by an intersection followed by
-         )
+      -- an embedding:
-      => Super.Rec givenFields -> Super.Rec usedFields
+      --
-    toBrushParameters = SuperRecord.project
+      --  Rec (givenFields /\ brushFields) -> Rec brushFields
-    brushFunction
+      --
-      :: forall usedFields
+      -- (see MetaBrush.Render.Document.strokeRenderData).
-      .  ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
-            ( UseFieldsInBrush usedFields )
-          )
-      => Super.Rec usedFields -> r
-    brushFunction usedParamsRecord =
       let
+        brushUniqParams :: Record UniqueField brushFields
+        brushUniqParams =
+          Rec.zipWith ( \ ( UniqueField uniq _ ) ( I val ) -> UniqueField uniq val )
+          defaultParamsRecord brushParams
         updatedHeap :: Map Unique TypedTerm
-        updatedHeap = bindRecordValues @brushFields @usedFields defaultParamsRecord usedParamsRecord evalHeap
+        updatedHeap = bindRecordValues brushUniqParams evalHeap
       in
-        ( `evalState` ( EvalState { evalHeap = updatedHeap, nextUnique } ) ) $ eval body
+        ( `evalState` ( EvalState { evalHeap = updatedHeap, nextUnique } ) )
-  pure ( AdaptableFunction ( toBrushParameters, brushFunction ) )
+          $ eval body
+  pure $
+    WithParams
+      { defaultParams = Rec.map (I . uniqueField) defaultParamsRecord
+      , withParams    = brushFunction
+      }
 eval ( Var var@( Located _ ( UniqueName _ varUniq ) ) ) = do
   vars <- use ( field' @"evalHeap" )
   case Map.lookup varUniq vars of
@@ -223,26 +235,17 @@ declareFun uniq@( UniqueName { nameUnique = funUnique } ) argPat rhs = do
   pure uniq
 
 bindRecordValues
-  :: forall brushFields usedFields defaultFields
+  :: forall brushFields
-  .  ( defaultFields ~ MapFields UniqueField brushFields
+  .  Record UniqueField brushFields
-     , SuperRecord.RecApply defaultFields defaultFields ( UseFieldsInBrush usedFields )
-     )
-  => Super.Rec defaultFields
-  -> Super.Rec usedFields
   -> Map Unique TypedTerm
   -> Map Unique TypedTerm
-bindRecordValues defaultValues usedValues heap = do
+bindRecordValues params heap =
-  SuperRecord.recApply @defaultFields @defaultFields @( UseFieldsInBrush usedFields )
+  foldRec bind_val params heap
-    ( \ k ( UniqueField ( UniqueName _ uniq ) ( defaultVal :: a ) ) prevState ->
+
-      let
+  where
-        val :: a
+    bind_val :: UniqueField a -> Map Unique TypedTerm -> Map Unique TypedTerm
-        val = SuperRecord.lookupWithDefault k defaultVal usedValues
+    bind_val ( UniqueField ( UniqueName _ uniq ) val ) =
-        updatedHeap :: Map Unique TypedTerm
+      Map.insert uniq ( TypedTerm $ CExt ( Val val ) )
-        updatedHeap = Map.insert uniq ( TypedTerm $ CExt @Tc @a ( Val val ) ) prevState
-      in updatedHeap
-    )
-    defaultValues
-    heap
 
 noSpan :: Span
 noSpan = Span 0 0 0 0

src/metabrushes/MetaBrush/DSL/Interpolation.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilyDependencies     #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+module MetaBrush.DSL.Interpolation
+  ( Interpolatable(..)
+  , D(..), DRec
+  )
+  where
+
+-- base
+import Data.Kind
+  ( Type )
+import Data.Monoid
+  ( Sum )
+import GHC.TypeLits
+  ( Symbol )
+
+-- acts
+import Data.Act
+  ( Act(..), Torsor(..) )
+
+-- groups
+import Data.Group
+  ( Group(..) )
+
+-- MetaBrush
+import Math.Module
+  ( Module(..) )
+import Math.Vector2D
+  ( Point2D, Vector2D )
+import MetaBrush.Records
+  ( Record, AllFields, I(..) )
+import qualified MetaBrush.Records as Rec
+  ( cpure, cmap, czipWith )
+
+--------------------------------------------------------------------------------
+
+class ( Module Double ( Diff a ), Torsor ( Diff a ) a ) => Interpolatable a where
+  type Diff a = ( d :: Type ) | d -> a
+
+instance ( a ~ Double ) => Interpolatable ( Point2D a ) where
+  type Diff ( Point2D a ) = Vector2D a
+
+instance Interpolatable Double where
+  type Diff Double = Sum Double
+
+--------------------------------------------------------------------------------
+-- Linear/affine action for records.
+
+type DRec :: [ ( Symbol, Type ) ] -> Type
+type DRec = Record D
+
+newtype D a = D { getDiff :: Diff a }
+deriving newtype instance Semigroup (Diff a) => Semigroup (D a)
+deriving newtype instance Monoid    (Diff a) => Monoid    (D a)
+deriving newtype instance Group     (Diff a) => Group     (D a)
+instance Interpolatable a => Act (D a) (I a) where
+  act (D d) (I a) = I (act d a)
+instance Interpolatable a => Torsor (D a) (I a) where
+  I a --> I b = D (a --> b)
+instance Interpolatable a => Module Double (D a) where
+  origin = D origin
+  D a ^+^ D b = D (a ^+^ b)
+  d *^ D a = D (d *^ a)
+
+instance AllFields Interpolatable kvs
+      => Semigroup (Record D kvs) where
+  (<>) = Rec.czipWith @Interpolatable (<>)
+instance AllFields Interpolatable kvs
+      => Monoid    (Record D kvs) where
+  mempty = Rec.cpure @Interpolatable mempty
+instance AllFields Interpolatable kvs
+      => Group     (Record D kvs) where
+  invert = Rec.cmap @Interpolatable invert
+
+instance AllFields Interpolatable kvs
+      => Act (Record D kvs) (Record I kvs) where
+  act = Rec.czipWith  @Interpolatable act
+instance AllFields Interpolatable kvs
+      => Torsor (Record D kvs) (Record I kvs) where
+  (-->) = Rec.czipWith @Interpolatable (-->)
+instance AllFields Interpolatable kvs
+      => Module Double (Record D kvs) where
+  origin = Rec.cpure @Interpolatable origin
+  (^+^)  = Rec.czipWith @Interpolatable (^+^)
+  d *^ r = Rec.cmap @Interpolatable (d *^) r
+
+instance AllFields Interpolatable kvs
+      => Interpolatable (Record I kvs) where
+  type Diff (Record I kvs) = Record D kvs

src/metabrushes/MetaBrush/DSL/Parse.hs

@@ -15,7 +15,7 @@
 
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
-module MetaBrush.MetaParameter.Parse where
+module MetaBrush.DSL.Parse where
 
 -- base
 import Control.Applicative
@@ -67,14 +67,14 @@ import Math.Bezier.Spline
   ( SplineType(..), SSplineType(..), SplineTypeI(ssplineType)
   , Spline(..), Curves(..), Curve(..), NextPoint(..)
   )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.AST
   ( Span(..), Located(..)
   , Expr, EPat
   , Term(..), Pat(..), Decl(..)
   , X_With(..)
   , toTreeTerm
   )
-import MetaBrush.MetaParameter.PrimOp
+import MetaBrush.DSL.PrimOp
   ( Orientation(..), kappa
   , rotate_around_by, rotate_by
   , scale_around_by, scale_by

src/metabrushes/MetaBrush/DSL/PrimOp.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
 
-module MetaBrush.MetaParameter.PrimOp where
+module MetaBrush.DSL.PrimOp where
 
 -- MetaBrush
 import Math.Bezier.Spline

src/metabrushes/MetaBrush/DSL/Rename.hs

@@ -9,7 +9,7 @@
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
 
-module MetaBrush.MetaParameter.Rename
+module MetaBrush.DSL.Rename
   ( rename, MonadRn, RnM
   , RnMessage, RnError
   , RnState, emptyRnState
@@ -60,12 +60,12 @@ import Control.Monad.Trans.RWS.CPS
 -- MetaBrush
 import Math.Bezier.Spline
   ( KnownSplineType(bitraverseSpline), bitraverseCurve )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.AST
   ( Located(..)
   , Pass(P,Rn), Name, UniqueName(..), X_With(..)
   , Term(..), Decl(..), Pat(..)
   )
-import MetaBrush.MetaParameter.Parse
+import MetaBrush.DSL.Parse
   ( ) -- AST type family instances for parsing pass
 import MetaBrush.Unique
   ( UniqueSupply, MonadUnique(freshUnique)

src/metabrushes/MetaBrush/DSL/TypeCheck.hs

@@ -13,42 +13,28 @@
 {-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
 
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+module MetaBrush.DSL.TypeCheck
-
-module MetaBrush.MetaParameter.TypeCheck
   ( typeCheck, MonadTc, TcM
   , TcMessage, TcError
   , TcState, emptyTcState
   )
   where
 
-import Data.Kind
-  ( Type )
-
 -- base
+import Control.Arrow
+  ( second )
 import Data.Either
   ( partitionEithers )
-import Data.Functor.Compose
+import Data.Kind
-  ( Compose(..) )
+  ( Type )
-import Data.List
-  ( sortOn )
-import Data.Ord
-  ( Down(..) )
-import Data.Proxy
-  ( Proxy )
 import Data.Type.Equality
   ( (:~:)(Refl) )
 import GHC.Exts
-  ( Proxy#, proxy# )
+  ( Any, Proxy# )
 import GHC.Generics
   ( Generic )
-import GHC.TypeLits
-  ( someSymbolVal, SomeSymbol(..) )
-import GHC.TypeNats
-  ( KnownNat )
 import Unsafe.Coerce
   ( unsafeCoerce )
 
@@ -78,21 +64,9 @@ import Control.Monad.State
 import Control.Monad.Writer
   ( MonadWriter(..) )
 
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( (:=)(..), FldProxy(..), RecSize, RecApply
-  , RecTy, RemoveAccessTo, RecVecIdxPos
-  , TraversalCHelper
-  , unsafeRNil, unsafeRCons
-  )
-
 -- text
 import Data.Text
   ( Text )
-import qualified Data.Text as Text
-  ( unpack )
 
 -- transformers
 import Control.Monad.Trans.RWS.CPS
@@ -100,6 +74,10 @@ import Control.Monad.Trans.RWS.CPS
 import Control.Monad.Trans.Except
   ( ExceptT )
 
+-- unordered-containers
+import qualified Data.HashMap.Strict as HashMap
+  ( fromList )
+
 -- MetaBrush
 import Math.Bezier.Spline
   ( Spline(..), Curve(..), Curves(..)
@@ -109,19 +87,24 @@ import Math.Bezier.Spline
   )
 import Math.Vector2D
   ( Point2D(..) )
-import MetaBrush.MetaParameter.AST
+import MetaBrush.DSL.AST
   ( Span(..), Located(..)
   , Pass(Rn,Tc)
   , Pat(..), Decl(..)
-  , X_With(..), MapFields
+  , X_With(..)
-  , UniqueTerm, UniqueField(..), IsUniqueTerm, IsUniqueTerm2
+  , UniqueTerm(..)
-  , SType(..), STypeI(sTypeI), SomeSType(..)
+  , Term(..), TypedTerm(..)
-  , STypes(..), STypesI(..)
-  , Term(..), TypedTerm(..), eqTy
   , termSpan
   )
-import MetaBrush.MetaParameter.Rename
+import MetaBrush.DSL.Types
+  ( SType(..), STypeI(sTypeI), SomeSType(..)
+  , STypesI(..)
+  , eqTy, proveSomeSTypes
+  )
+import MetaBrush.DSL.Rename
   ( Env(..), UniqueName(..) )
+import MetaBrush.Records
+  ( Record(MkR) )
 import MetaBrush.Unique
   ( UniqueSupply, MonadUnique, Unique )
 
@@ -140,8 +123,8 @@ typeCheckAt mismatchMessage term = do
       tcError $
         UnexpectedType
           mismatchMessage
-          ( "Expected: ",                             SomeSType ( proxy# :: Proxy# a ) )
+          ( "Expected: ",                             SomeSType @a )
-          ( "  Actual: ", Located ( termSpan term ) $ SomeSType ( proxy# :: Proxy# x ) )
+          ( "  Actual: ", Located ( termSpan term ) $ SomeSType @x )
 
 typeCheck :: forall m. MonadTc m => Term Rn '() -> m TypedTerm
 typeCheck ( uf :$ ua ) = do
@@ -155,16 +138,16 @@ typeCheck ( uf :$ ua ) = do
           Nothing   -> tcError $
             UnexpectedType
               "Unexpected function argument type"
-              ( "Expected: ", SomeSType ( proxy# :: Proxy# b ) )
+              ( "Expected: ", SomeSType @b )
-              ( "  Actual: ", Located ( termSpan ua ) $ SomeSType ( proxy# :: Proxy# a ) )
+              ( "  Actual: ", Located ( termSpan ua ) $ SomeSType @a )
     _ -> tcError $
       OverSaturatedFunctionApplication
-        ( Located ( termSpan uf ) ( SomeSType ( proxy# :: Proxy# f ) ) )
+        ( Located ( termSpan uf ) ( SomeSType @f ) )
         ( termSpan ua )
 typeCheck ( Var locVar@( Located _ ( UniqueName _ uniq ) ) ) = do
   mbType <- use ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq )
   case mbType of
-    Just ( SomeSType ( _ :: Proxy# a ) ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) )
+    Just ( SomeSType @a ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) )
     Nothing -> tcError ( OutOfScope locVar )
 typeCheck ( Let loc decls body ) = do
   decls' <- typeCheckDecls decls
@@ -174,11 +157,7 @@ typeCheck ( With locs ( Rn_With decls ) conds body ) = do
   decls' <- typeCheckDecls decls
   conds' <- traverse ( typeCheckAt @Bool "Expected Boolean condition, but expression has the wrong type." ) conds
   TypedTerm body' <- typeCheck body
-  withDeclsRecord decls' \ ( decls'Record :: Super.Rec ( MapFields UniqueTerm kvs ) ) -> do
+  withDeclsRecord decls' \ ( decls'Record :: Record UniqueTerm kvs ) ->
-    case unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueTerm kvs ) :~: SuperRecord.RecSize kvs of
-      Refl ->
-        case treeArgsDict @kvs @kvs of
-          RecTreeArgsDict ->
     TypedTerm $ With locs ( Tc_With decls'Record ) conds' body'
 typeCheck ( Lit loc a ) = pure ( TypedTerm $ Lit loc a )
 typeCheck ( Op locs nm op ) = pure ( TypedTerm $ Op locs nm op )
@@ -191,8 +170,8 @@ typeCheck ( Point locs a b ) = do
       tcError $
         MismatchedTypes
           "Components of a point with different types."
-          ( "1st component: ", Located ( termSpan a ) ( SomeSType ( proxy# :: Proxy# a ) ) )
+          ( "1st component: ", Located ( termSpan a ) ( SomeSType @a ) )
-          ( "2nd component: ", Located ( termSpan b ) ( SomeSType ( proxy# :: Proxy# b ) ) )
+          ( "2nd component: ", Located ( termSpan b ) ( SomeSType @b ) )
 typeCheck ( Line {} ) = error "typeCheck: error, unexpected 'line'"
 typeCheck ( Bez2 {} ) = error "typeCheck: error, unexpected 'bez2'"
 typeCheck ( Bez3 {} ) = error "typeCheck: error, unexpected 'bez3'"
@@ -234,13 +213,13 @@ typeCheck ( PolyBez locs spline@( Spline { splineStart, splineCurves } :: Spline
           tcError $
             UnexpectedType
               "Unexpected Bézier spline coordinate type"
-              ( "Expected: ", SomeSType ( proxy# :: Proxy# Double ) )
+              ( "Expected: ", SomeSType @Double )
-              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# a ) )
+              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType @a )
     _ -> tcError $
             UnexpectedType
               "Unexpected Bézier spline point type"
-              ( "Expected: ", SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
+              ( "Expected: ", SomeSType @( Point2D Double ) )
-              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# pt ) )
+              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType @pt )
 
 typeCheckDecls :: forall m. MonadTc m => [ Decl Rn ] -> m [ Decl Tc ]
 typeCheckDecls = go []
@@ -275,12 +254,12 @@ typeCheckDecl ( FunDecl funName@( Located _ ( UniqueName _ uniq ) ) argPat eqLoc
   rhs'    <- typeCheckAt @( Point2D Double ) "Expected function of type `Point2D Double -> Point2D Double'"  rhs
   assign
     ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq )
-    ( Just $ SomeSType ( proxy# :: Proxy# ( Point2D Double -> Point2D Double ) ) )
+    ( Just $ SomeSType @( Point2D Double -> Point2D Double ) )
   pure ( FunDecl funName argPat' eqLoc rhs' )
 
 typeCheckPatAt :: forall ( a :: Type ) m. ( STypeI a, MonadTc m ) => Pat Rn '() -> m ( Pat Tc a )
 typeCheckPatAt ( PName nm@( Located _ ( UniqueName _ uniq ) ) ) = do
-  assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
+  assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType @a )
   pure ( PName nm )
 typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of
   sTyPair@STyPoint | ( _ :: SType ( Point2D c ) ) <- sTyPair
@@ -291,88 +270,38 @@ typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of
   _ -> tcError $
          UnexpectedPatType
          "RHS of let binding does not have the expected type"
-         ( "Expected type: ", Located ( foldMap location locs ) $ SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
+         ( "Expected type: ", Located ( foldMap location locs ) $ SomeSType @( Point2D Double ) )
-         ( "  Actual type: ", SomeSType ( proxy# :: Proxy# a ) )
+         ( "  Actual type: ", SomeSType @a )
 typeCheckPatAt ( PWild nm ) = pure ( PWild nm )
 typeCheckPatAt ( AsPat symbLoc nm@( Located _ ( UniqueName _ uniq ) ) pat ) = do
   pat' <- typeCheckPatAt @a pat
-  assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
+  assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType @a )
   pure ( AsPat symbLoc nm pat' )
 
 withDeclsRecord
   :: forall r m
   .  ( MonadTc m )
   => [ Decl Tc ]
-  -> ( forall kvs. STypesI kvs => Super.Rec ( MapFields UniqueTerm kvs ) -> r )
+  -> ( forall kvs. STypesI kvs => Record UniqueTerm kvs -> r )
   -> m r
 withDeclsRecord decls f = do
-  TypedTermsRecord record <- go ( TypedTermsRecord $ SuperRecord.unsafeRNil lg ) <$> ( revSortDecls decls )
+  -- This list cannot have duplicate names, as these would have been caught by the renamer.
-  pure ( f record )
+  names <- traverse getDeclName decls
-  where
+  let
-    lg :: Int
+    mkSomeSType :: forall a. UniqueTerm a -> SomeSType
-    lg = length decls
+    mkSomeSType ( UniqueTerm {} ) = SomeSType @a
-    -- This list cannot have duplicate names,
+  proveSomeSTypes (map (second mkSomeSType) names) \ ( _ :: Proxy# kvs ) -> do
-    -- as these would have been caught by the renamer.
+    let
-    -- Sort in reverse order as we must add elements in decreasing label order.
+      declsRecord :: Record UniqueTerm kvs
-    revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ]
+      declsRecord = MkR (HashMap.fromList names)
-    revSortDecls = fmap ( sortOn ( Down . fst ) ) . traverse getDeclName
+    return $ f declsRecord
-    getDeclName :: Decl Tc -> m ( Text, ( UniqueName, TypedTerm ) )
+
+getDeclName :: MonadTc m => Decl Tc -> m ( Text, UniqueTerm Any )
 getDeclName ( ValDecl pat ( Located eqLoc _ ) term ) = case pat of
-      PName   ( Located _ uniq@( UniqueName nm _ ) )   -> pure ( nm, ( uniq, TypedTerm term ) )
+  PName   ( Located _ uniq@( UniqueName nm _ ) )   -> pure ( nm, unsafeCoerce $ UniqueTerm uniq term )
-      AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, ( uniq, TypedTerm term ) )
+  AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, unsafeCoerce $ UniqueTerm uniq term )
   _                                                -> tcError $ NoPatternName eqLoc
 getDeclName ( FunDecl funName _ _ _ ) = tcError $ UnexpectedFunDecl funName
-    go :: TypedTermsRecord -> [ ( Text, ( UniqueName, TypedTerm ) ) ] -> TypedTermsRecord
-    go record [] = record
-    go  ( TypedTermsRecord ( record :: Super.Rec ( MapFields UniqueTerm kvs ) ) )
-        ( ( nm, ( uniq, TypedTerm ( t :: Term Tc a ) ) ) : ps )
-      = case someSymbolVal ( Text.unpack nm ) of
-          SomeSymbol ( _ :: Proxy nm ) ->
-            go
-              ( TypedTermsRecord @( ( nm SuperRecord.:= a ) ': kvs )
-              $ SuperRecord.unsafeRCons @nm @( UniqueTerm a ) @( MapFields UniqueTerm kvs )
-                ( SuperRecord.FldProxy @nm SuperRecord.:= Compose ( UniqueField uniq t ) )
-                record
-              )
-              ps
-
-data TypedTermsRecord where
-  TypedTermsRecord
-    :: ( STypesI kvs, ts ~ MapFields UniqueTerm kvs, KnownNat ( SuperRecord.RecSize ts ) )
-    => Super.Rec ts -> TypedTermsRecord
-
-data RecTreeArgsDict rts lts where
-  RecTreeArgsDict
-    :: forall rts lts trts tlts frts flts
-    .  ( trts ~ MapFields UniqueTerm  rts, tlts ~ MapFields UniqueTerm  lts
-       , frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
-       , SuperRecord.RecApply trts tlts IsUniqueTerm
-       , SuperRecord.TraversalCHelper flts trts frts IsUniqueTerm2
-       )
-    => RecTreeArgsDict rts lts
-
-treeArgsDict
-  :: forall rts lts trts tlts frts flts
-  .  ( trts ~ MapFields UniqueTerm  rts, tlts ~ MapFields UniqueTerm  lts
-     , frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
-     , STypesI lts
-     , KnownNat ( SuperRecord.RecSize rts )
-     )
-  => RecTreeArgsDict rts lts
-treeArgsDict = case sTypesI @lts of
-  STyNil
-    | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize frts :~: SuperRecord.RecSize rts )
-    -> RecTreeArgsDict
-  sTyCons@STyCons
-    | ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs ) ) <- sTyCons
-    , Refl <- ( unsafeCoerce Refl :: MapFields UniqueTerm lvs :~: SuperRecord.RemoveAccessTo l ( MapFields UniqueTerm lvs ) )
-    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy l trts :~: Just ( UniqueTerm v ) )
-    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos l trts :~: SuperRecord.RecSize lvs )
-    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize trts :~: SuperRecord.RecSize rts )
-    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize lvs :~: SuperRecord.RecSize ( MapFields UniqueField lvs ) )
-    -> case treeArgsDict @rts @lvs of
-          RecTreeArgsDict -> RecTreeArgsDict
-
 
 --------------------------------------------------------------------------------
 -- Type-checker-specific data and instances.

src/metabrushes/MetaBrush/DSL/Types.hs

@@ -0,0 +1,221 @@
+{-# LANGUAGE AllowAmbiguousTypes      #-}
+{-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE DerivingStrategies       #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE MagicHash                #-}
+{-# LANGUAGE PolyKinds                #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE StandaloneDeriving       #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications         #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE UndecidableInstances     #-}
+
+module MetaBrush.DSL.Types
+  ( SType(..), STypes(..)
+  , STypeI(..), STypesI(..)
+  , SomeSType(..)
+  , eqTy, eqTys
+  , someSTypes, proveSomeSTypes
+  ) where
+
+-- base
+import Data.Kind
+  ( Constraint, Type )
+import Data.List
+  ( intercalate )
+import Data.Proxy
+  ( Proxy(..) )
+import Data.Type.Equality
+  ( (:~:)(Refl) )
+import GHC.Exts
+  ( Proxy#, proxy# )
+import GHC.TypeLits
+  ( Symbol, KnownSymbol, SomeSymbol(..)
+  , symbolVal', sameSymbol, someSymbolVal )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( pack, unpack )
+
+-- MetaBrush
+import Math.Vector2D
+  ( Point2D(..), Segment(..) )
+import qualified Math.Bezier.Cubic     as Cubic
+  ( Bezier(..) )
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(..) )
+import Math.Bezier.Spline
+  ( SplinePts
+  , SSplineType(..), SplineTypeI(ssplineType)
+  , KnownSplineType
+  )
+import MetaBrush.Records
+  ( WithParams )
+
+--------------------------------------------------------------------------------
+-- Types.
+
+type SType :: Type -> Type
+data SType ty where
+  SFunTy    :: ( STypeI a, STypeI b ) => SType ( a -> b )
+  STyBool   :: SType Bool
+  STyDouble :: SType Double
+  STyPoint  :: STypeI a => SType ( Point2D a )
+  STyLine   :: STypeI a => SType ( Segment a )
+  STyBez2   :: STypeI a => SType ( Quadratic.Bezier a )
+  STyBez3   :: STypeI a => SType ( Cubic.Bezier a )
+  STySpline :: KnownSplineType clo => SType ( SplinePts clo )
+  STyWithFn :: ( STypesI kvs, STypeI a ) => SType ( WithParams kvs a )
+  -- reminder: update eqSTy when adding new constructors
+
+deriving stock instance Show ( SType ty )
+
+class STypeI ty where
+  sTypeI :: SType ty
+instance ( STypeI a, STypeI b ) => STypeI ( a -> b ) where
+  sTypeI = SFunTy
+instance STypeI Bool where
+  sTypeI = STyBool
+instance STypeI Double where
+  sTypeI = STyDouble
+instance STypeI a => STypeI ( Point2D a ) where
+  sTypeI = STyPoint
+instance STypeI a => STypeI ( Segment a ) where
+  sTypeI = STyLine
+instance STypeI a => STypeI ( Quadratic.Bezier a ) where
+  sTypeI = STyBez2
+instance STypeI a => STypeI ( Cubic.Bezier a ) where
+  sTypeI = STyBez3
+instance KnownSplineType clo => STypeI ( SplinePts clo ) where
+  sTypeI = STySpline
+instance ( STypesI kvs, STypeI a ) => STypeI ( WithParams kvs a ) where
+  sTypeI = STyWithFn
+
+type STypes :: [ (Symbol, Type) ] -> Type
+data STypes kvs where
+  STyNil  :: STypes '[]
+  STyCons :: ( kv ~ '( k, v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypes ( kv ': kvs )
+instance Show ( STypes kvs ) where
+  show sTypes = "'[" <> intercalate "," ( showSTypes sTypes ) <> "]"
+showSTypes :: STypes kvs -> [ String ]
+showSTypes STyNil = []
+showSTypes sTyCons@STyCons
+  | ( _ :: STypes ( '( k, v ) ': tail_kvs ) ) <- sTyCons
+  = ( symbolVal' ( proxy# :: Proxy# k ) <> " := " <> show ( sTypeI @v ) ) : showSTypes ( sTypesI @tail_kvs )
+
+type STypesI :: [ (Symbol, Type) ] -> Constraint
+class STypesI kvs where
+  sTypesI :: STypes kvs
+
+instance STypesI '[] where
+  sTypesI = STyNil
+-- Warning: this instance is somewhat overly general as it doesn't check for lack of duplicates
+instance ( kv ~ '( k, v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypesI ( kv ': kvs ) where
+  sTypesI = STyCons
+
+eqSTy :: SType a -> SType b -> Maybe ( a :~: b )
+eqSTy sTy_a@SFunTy sTy_b@SFunTy
+  | ( _ :: SType ( a1 -> b1 ) ) <- sTy_a
+  , ( _ :: SType ( a2 -> b2 ) ) <- sTy_b
+  , Just Refl <- eqTy @a1 @a2
+  , Just Refl <- eqTy @b1 @b2
+  = Just Refl
+eqSTy STyBool   STyBool   = Just Refl
+eqSTy STyDouble STyDouble = Just Refl
+eqSTy sTy_a@STyPoint sTy_b@STyPoint
+  | ( _ :: SType ( Point2D l ) ) <- sTy_a
+  , ( _ :: SType ( Point2D r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STyLine sTy_b@STyLine
+  | ( _ :: SType ( Segment l ) ) <- sTy_a
+  , ( _ :: SType ( Segment r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STyBez2 sTy_b@STyBez2
+  | ( _ :: SType ( Quadratic.Bezier l ) ) <- sTy_a
+  , ( _ :: SType ( Quadratic.Bezier r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STyBez3 sTy_b@STyBez3
+  | ( _ :: SType ( Cubic.Bezier l ) ) <- sTy_a
+  , ( _ :: SType ( Cubic.Bezier r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STySpline sTy_b@STySpline
+  | ( _ :: SType ( SplinePts clo1 ) ) <- sTy_a
+  , ( _ :: SType ( SplinePts clo2 ) ) <- sTy_b
+  = case ( ssplineType @clo1, ssplineType @clo2 ) of
+      ( SOpen  , SOpen   ) -> Just Refl
+      ( SClosed, SClosed ) -> Just Refl
+      _                    -> Nothing
+eqSTy sTy_a@STyWithFn sTy_b@STyWithFn
+  | ( _ :: SType ( WithParams kvs a ) ) <- sTy_a
+  , ( _ :: SType ( WithParams lvs b ) ) <- sTy_b
+  , Just Refl <- eqTys @kvs @lvs
+  , Just Refl <- eqTy  @a   @b
+  = Just Refl
+eqSTy _ _ = Nothing
+
+eqTy :: forall a b. ( STypeI a, STypeI b ) => Maybe ( a :~: b )
+eqTy = eqSTy ( sTypeI @a ) ( sTypeI @b )
+
+eqSTys :: STypes as -> STypes bs -> Maybe ( as :~: bs )
+eqSTys STyNil STyNil = Just Refl
+eqSTys sTyCons1@STyCons sTyCons2@STyCons
+  | ( _ :: STypes ( '( l1, v1 ) ': as' ) ) <- sTyCons1
+  , ( _ :: STypes ( '( l2, v2 ) ': bs' ) ) <- sTyCons2
+  , Just Refl <- sameSymbol ( Proxy :: Proxy l1 ) ( Proxy :: Proxy l2 )
+  , Just Refl <- eqTy @v1 @v2
+  , Just Refl <- eqTys @as' @bs'
+  = Just Refl
+eqSTys _ _ = Nothing
+
+eqTys :: forall as bs. ( STypesI as, STypesI bs ) => Maybe ( as :~: bs )
+eqTys = eqSTys ( sTypesI @as ) ( sTypesI @bs )
+
+
+
+data SomeSType where
+  SomeSType :: forall a. STypeI a => SomeSType
+instance Show SomeSType where
+  show ( SomeSType @a ) = show ( sTypeI @a )
+instance Eq SomeSType where
+  ( SomeSType @a ) == ( SomeSType @b ) =
+    case eqTy @a @b of
+      Just _ -> True
+      _      -> False
+
+data SomeSTypes where
+  SomeSTypes :: forall kvs. STypesI kvs => SomeSTypes
+
+
+someSTypes :: forall kvs. STypesI kvs => [ ( Text, SomeSType ) ]
+someSTypes = go ( sTypesI @kvs )
+  where
+    go :: forall lvs. STypes lvs -> [ ( Text, SomeSType ) ]
+    go STyNil = []
+    go sTyCons@STyCons
+      | ( _ :: STypes ( '( l, v ) ': lvs' ) ) <- sTyCons
+      , let
+          l :: Text
+          l = Text.pack $ symbolVal' ( proxy# :: Proxy# l )
+      = ( l, SomeSType @v )
+      : go ( sTypesI @lvs' )
+
+proveSomeSTypes :: [ ( Text, SomeSType ) ] -> ( forall kvs. STypesI kvs => Proxy# kvs -> r ) -> r
+proveSomeSTypes rs f = case go rs of { SomeSTypes @kvs -> f @kvs proxy# }
+  where
+    go :: [ ( Text, SomeSType ) ] -> SomeSTypes
+    go [] = SomeSTypes @'[]
+    go ( ( s, SomeSType @v ) :rest )
+      = case go rest of
+          SomeSTypes @kvs
+            | SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack s )
+            -> SomeSTypes @( '( k, v ) ': kvs )

src/metabrushes/MetaBrush/Records.hs

@@ -0,0 +1,307 @@
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module MetaBrush.Records
+  ( Record(..), Rec, AllFields(..)
+
+  , empty, insert
+
+  , map, mapM
+  , mapMWithKey
+  , zipWith
+  , cpure, cmap, czipWith
+  , cpureM, cpureMWithKey
+  , cmapWithKey
+  , collapse, foldRec
+  , proveRecordDicts
+  , describeRecord
+  , MyIntersection(..), myIntersect
+
+  , WithParams(..)
+
+    -- * Functors
+  , I(..), K(..), (:*:)(..), Dict(..)
+  )
+  where
+
+-- base
+import Prelude
+  hiding ( map, mapM, zipWith )
+import Data.Coerce
+  ( coerce )
+import Data.Functor.Const
+  ( Const(..) )
+import Data.Kind
+  ( Type, Constraint )
+import Data.List
+  ( intersperse )
+import Data.Monoid
+  ( Endo(..) )
+import Data.Proxy
+  ( Proxy(..) )
+import Data.Typeable
+  ( Typeable, TypeRep, typeRep )
+import GHC.TypeLits
+  ( Symbol, KnownSymbol, symbolVal' )
+import GHC.Exts
+  ( Any, Proxy#, proxy#, withDict )
+import GHC.Show
+  ( showCommaSpace )
+import Unsafe.Coerce
+  ( unsafeCoerce )
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..) )
+
+-- groups
+import Data.Group
+  ( Group(..) )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( pack, unpack )
+
+-- unordered-containers
+import Data.HashMap.Strict
+  ( HashMap )
+import qualified Data.HashMap.Strict as HashMap
+
+--------------------------------------------------------------------------------
+
+type Record :: (Type -> Type) -> [(Symbol, Type)] -> Type
+newtype Record f kvs = MkR { recordKeyVals :: HashMap Text (f Any) }
+
+empty :: Record f '[]
+empty = MkR HashMap.empty
+
+insert :: forall k v kvs f
+       .  KnownSymbol k
+       => f v
+       -> Record f kvs
+       -> Record f ( '(k,v) ': kvs )
+insert v (MkR r) = MkR $ HashMap.insert k v' r
+  where
+    k :: Text
+    k = Text.pack (symbolVal' (proxy# :: Proxy# k))
+    v' :: f Any
+    v' = unsafeCoerce v
+
+type Rec :: [(Symbol, Type)] -> Type
+type Rec kvs = Record I kvs
+
+type I :: Type -> Type
+newtype I a = I { unI :: a }
+  deriving newtype ( Semigroup, Monoid, Group, NFData )
+
+type K :: Type -> Type -> Type
+newtype K a b = K { unK :: a }
+  deriving newtype ( Semigroup, Monoid, Group, NFData )
+
+type (:*:) :: (Type -> Type) -> (Type -> Type) -> Type -> Type
+data (f :*: g) a = f a :*: g a
+
+type Dict :: (Type -> Constraint) -> Type -> Type
+data Dict c a where
+  Dict :: c a => Dict c a
+
+type AllFields :: (Type -> Constraint) -> [(Symbol, Type)] -> Constraint
+class AllFields c kvs where
+  recordDicts :: Record (Dict c) kvs
+
+instance AllFields c '[] where
+  recordDicts = MkR HashMap.empty
+
+instance ( c v, KnownSymbol k, AllFields c kvs ) => AllFields c ( '(k, v) ': kvs ) where
+  recordDicts = case recordDicts @c @kvs of
+    MkR kvs -> MkR $ HashMap.insert k dict kvs
+      where
+        k :: Text
+        k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
+        dict :: Dict c Any
+        dict = unsafeCoerce ( Dict :: Dict c v )
+
+instance AllFields Show kvs => Show (Record I kvs) where
+  showsPrec d = aux . collapse . cmapWithKey @Show showField
+    where
+      showField :: Show x => Text -> I x -> K ShowS x
+      showField k (I x) = K $ showString (Text.unpack k) . showString " = " . showsPrec 0 x
+
+      aux :: [ShowS] -> ShowS
+      aux fields = showParen (d >= 11)
+                 $ showString "{"
+                 . foldr (.) id (intersperse showCommaSpace fields)
+                 . showString "}"
+
+data WithParams params a =
+  WithParams
+    { defaultParams :: Rec params
+    , withParams    :: Rec params -> a
+    }
+
+instance AllFields Semigroup kvs
+      => Semigroup (Record I kvs) where
+  (<>) = czipWith @Semigroup (<>)
+
+instance ( AllFields Semigroup kvs
+         , AllFields Monoid    kvs )
+      => Monoid    (Record I kvs) where
+  mempty = cpure @Monoid mempty
+
+instance ( AllFields Semigroup kvs
+         , AllFields Monoid    kvs
+         , AllFields Group     kvs )
+      => Group     (Record I kvs) where
+  invert = cmap @Group ( \ (I g) -> I (invert g) )
+
+instance AllFields NFData kvs
+      => NFData ( Record I kvs ) where
+  rnf (MkR !_) = () -- todo
+
+data MyIntersection r1 g r2 c where
+  MyIntersection
+    :: forall i r1 g r2 c
+    .  ( AllFields c i )
+    => { myProject :: forall f. Record f r1 -> Record (f :*: g) i
+       , myInject  :: Record g i -> Record g r2
+       }
+    -> MyIntersection r1 g r2 c
+
+myIntersect
+  :: forall c r1 g r2
+  .  ( AllFields c r1 )
+  => Record g r2
+  -> MyIntersection r1 g r2 c
+myIntersect (MkR r2) =
+  proveRecordDicts @c @Any intersectionDict
+    ( MyIntersection { myProject, myInject } )
+  where
+    myProject :: Record f r1 -> Record (f :*: g) Any
+    myProject (MkR r1) = MkR (HashMap.intersectionWith (:*:) r1 r2)
+    myInject :: Record g Any -> Record g r2
+    myInject (MkR i) = MkR (HashMap.union i r2)
+    intersectionDict :: Record (Dict c) Any
+    intersectionDict =
+      case recordDicts @c @r1 of
+        MkR d -> MkR (HashMap.intersection d r2)
+
+proveRecordDicts :: forall c r x. Record (Dict c) r -> (AllFields c r => x) -> x
+proveRecordDicts = withDict
+
+describeRecord :: forall kvs. AllFields Typeable kvs => [ ( Text, TypeRep ) ]
+describeRecord = collapse $ cmapWithKey @Typeable describeField (recordDicts @Typeable @kvs)
+  where
+    describeField :: forall a. Text -> Dict Typeable a -> K ( Text, TypeRep ) a
+    describeField k Dict = K ( k, typeRep ( Proxy :: Proxy a ) )
+
+------------------------------------------------------------
+-- Record combinators.
+
+map :: ( forall x. f x -> g x )
+    -> Record f kvs -> Record g kvs
+map f (MkR r) = MkR $ fmap f r
+
+mapM :: Applicative m
+     => ( forall x. f x -> m ( g x ) )
+     -> Record f kvs -> m (Record g kvs)
+mapM f (MkR r) =
+  MkR <$> traverse f r
+
+mapMWithKey :: forall m kvs f g
+            .  Applicative m
+            => ( forall x. Text -> f x -> m ( g x ) )
+            -> Record f kvs -> m (Record g kvs)
+mapMWithKey f (MkR r) =
+  MkR <$> HashMap.traverseWithKey f r
+
+cpure :: forall c kvs f
+      .  AllFields c kvs
+      => ( forall x. c x => f x )
+      -> Record f kvs
+cpure f =
+  MkR $ fmap (\ Dict -> f) (recordKeyVals $ recordDicts @c @kvs)
+
+cmap :: forall c kvs f g
+     .  AllFields c kvs
+     => ( forall x. c x => f x -> g x )
+     -> Record f kvs
+     -> Record g kvs
+cmap f (MkR r) =
+  MkR $ HashMap.intersectionWith (\ Dict x -> f x) (recordKeyVals $ recordDicts @c @kvs) r
+
+zipWith :: forall kvs f g h
+        .  ( forall x. f x -> g x -> h x )
+        -> Record f kvs
+        -> Record g kvs
+        -> Record h kvs
+zipWith f (MkR r1) (MkR r2) =
+  MkR $ HashMap.intersectionWith (\ x y -> f x y) r1 r2
+
+czipWith :: forall c kvs f g h
+         .  AllFields c kvs
+         => ( forall x. c x => f x -> g x -> h x )
+         -> Record f kvs
+         -> Record g kvs
+         -> Record h kvs
+czipWith f (MkR r1) (MkR r2) =
+  MkR $ HashMap.intersectionWith (\ Dict (x :*: y) -> f x y) (recordKeyVals $ recordDicts @c @kvs) pairs
+    where
+      pairs :: HashMap Text ((f :*: g) Any)
+      pairs = HashMap.intersectionWith (\ x y -> x :*: y) r1 r2
+
+cpureM :: forall c m kvs f
+       .  ( Applicative m, AllFields c kvs)
+       => ( forall x. c x => m (f x) )
+       -> m ( Record f kvs )
+cpureM f = mapM (\Dict -> f) (recordDicts @c @kvs)
+
+cpureMWithKey :: forall c m kvs f
+              .  ( Applicative m, AllFields c kvs)
+              => ( forall x. c x => Text-> m (f x) )
+              -> m ( Record f kvs )
+cpureMWithKey f = mapMWithKey (\k Dict -> f k) (recordDicts @c @kvs)
+
+cmapWithKey :: forall c kvs f g
+            .  AllFields c kvs
+            => (forall x. c x => Text -> f x -> g x)
+            -> Record f kvs
+            -> Record g kvs
+cmapWithKey f = zipWithKey ( \ k Dict x -> f k x ) (recordDicts @c @kvs)
+
+zipWithKey :: forall r f g h
+           .  ( forall x. Text -> f x -> g x -> h x )
+           -> Record f r -> Record g r -> Record h r
+zipWithKey f (MkR a) (MkR b) = MkR $
+  HashMap.intersectionWithKey f a b
+
+foldRec :: forall y f r. ( forall x . f x -> y -> y ) -> Record f r -> y -> y
+foldRec f r = coerce $ mapM g r
+  where
+    g :: ( forall x. f x -> Const (Endo y) (I x) )
+    g x = coerce (f x)
+
+collapse :: Record (K a) r -> [a]
+collapse (MkR a) = coerce $ HashMap.elems a

src/metabrushes/MetaBrush/Serialisable.hs

@@ -0,0 +1,310 @@
+{-# LANGUAGE BlockArguments       #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE InstanceSigs         #-}
+{-# LANGUAGE LambdaCase           #-}
+{-# LANGUAGE MagicHash            #-}
+{-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module MetaBrush.Serialisable
+  ( Serialisable(..)
+  , encodeSequence, decodeSequence
+  , encodeUniqueMap, decodeUniqueMap
+  , encodeCurve, decodeCurve
+  , encodeCurves, decodeCurves
+  , encodeSpline, decodeSpline
+  )
+  where
+
+-- base
+import Control.Arrow
+  ( (&&&) )
+import Control.Monad.ST
+  ( RealWorld, stToIO )
+import Data.Foldable
+  ( toList )
+import Data.Functor.Contravariant
+  ( contramap )
+import Data.Functor.Identity
+  ( Identity(..) )
+import Data.STRef
+  ( newSTRef )
+import GHC.Exts
+  ( Proxy# )
+import GHC.TypeLits
+  ( symbolVal', KnownSymbol )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( elems, fromList )
+import Data.Sequence
+  ( Seq )
+import qualified Data.Sequence as Seq
+  ( fromList )
+
+-- generic-lens
+import Data.Generics.Product.Typed
+  ( HasType(typed) )
+
+-- lens
+import Control.Lens
+  ( view )
+
+-- scientific
+import qualified Data.Scientific as Scientific
+  ( fromFloatDigits, toRealFloat )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( pack )
+
+-- transformers
+import Control.Monad.IO.Class
+  ( MonadIO(liftIO) )
+import Control.Monad.Trans.Class
+  ( MonadTrans(lift) )
+
+-- waargonaut
+import qualified Waargonaut.Decode as JSON
+  ( Decoder )
+import qualified Waargonaut.Decode as JSON.Decoder
+  ( atKey, atKeyOptional, list, scientific, text )
+import qualified Waargonaut.Encode as JSON
+  ( Encoder )
+import qualified Waargonaut.Encode as JSON.Encoder
+  ( runPureEncoder
+  , atKey', json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
+  )
+import Waargonaut.Types.Json
+  ( Json )
+
+-- meta-brushes
+import Math.Bezier.Spline
+  ( Spline(..), SplineType(..), SSplineType(..), SplineTypeI(..)
+  , Curves(..), Curve(..), NextPoint(..)
+  )
+import Math.Bezier.Stroke
+  ( CachedStroke(..) )
+import MetaBrush.Records
+  ( Record, Rec, AllFields
+  , I(..), K(..)
+  , collapse, cmapWithKey, cpureMWithKey
+  )
+import Math.Vector2D
+  ( Point2D(..), Vector2D(..) )
+import MetaBrush.Unique
+  ( Unique )
+
+--------------------------------------------------------------------------------
+
+class Serialisable a where
+  encoder :: Monad f => JSON.Encoder f a
+  decoder :: Monad m => JSON.Decoder m a
+
+instance Serialisable Double where
+  encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
+  decoder = fmap      Scientific.toRealFloat     JSON.Decoder.scientific
+
+instance Serialisable a => Serialisable ( Point2D a ) where
+  encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
+      JSON.Encoder.atKey' "x" encoder x
+    . JSON.Encoder.atKey' "y" encoder y
+  decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
+
+instance Serialisable a => Serialisable ( Vector2D a ) where
+  encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
+      JSON.Encoder.atKey' "x" encoder x
+    . JSON.Encoder.atKey' "y" encoder y
+  decoder =  Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
+
+instance Serialisable a => Serialisable (I a) where
+  encoder = contramap unI encoder
+  decoder = fmap I decoder
+
+instance ( AllFields Serialisable kvs )
+      => Serialisable ( Record I kvs ) where
+  encoder :: forall f. Monad f => JSON.Encoder f ( Rec kvs )
+  encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
+    where
+      encodeFields :: Record I kvs -> [ ( Text, Json ) ]
+      encodeFields = collapse . cmapWithKey @Serialisable keyVal
+      keyVal :: Serialisable x => Text -> I x -> K (Text, Json) x
+      keyVal k (I x) = K ( k, JSON.Encoder.runPureEncoder encoder x )
+
+  decoder :: forall m. Monad m => JSON.Decoder m ( Rec kvs )
+  decoder = cpureMWithKey @Serialisable ( \ k -> JSON.Decoder.atKey k decoder )
+
+--------------------------------------------------------------------------------
+
+encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
+encodeSequence enc = contramap toList ( JSON.Encoder.list enc )
+
+decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a )
+decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
+
+
+
+encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
+encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
+
+decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
+decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
+
+
+
+{-
+encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
+encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
+    JSON.Encoder.atKey' "m00" enc m00
+  . JSON.Encoder.atKey' "m01" enc m01
+  . JSON.Encoder.atKey' "m10" enc m10
+  . JSON.Encoder.atKey' "m11" enc m11
+
+decodeMat22 :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Mat22 a )
+decodeMat22 dec =
+  Mat22 <$> JSON.Decoder.atKey "m00" dec
+        <*> JSON.Decoder.atKey "m01" dec
+        <*> JSON.Decoder.atKey "m10" dec
+        <*> JSON.Decoder.atKey "m11" dec
+
+
+
+encodeAABB :: Applicative f => JSON.Encoder f AABB
+encodeAABB = JSON.Encoder.mapLikeObj \ ( AABB { topLeft, botRight } ) ->
+    JSON.Encoder.atKey' "topLeft"  enc topLeft
+  . JSON.Encoder.atKey' "botRight" enc botRight
+  where
+    enc :: JSON.Encoder' ( Point2D Double )
+    enc = encodePoint2D encodeDouble
+
+decodeAABB :: forall m. Monad m => JSON.Decoder m AABB
+decodeAABB = do
+    topLeft  <- JSON.Decoder.atKey "topLeft"  dec
+    botRight <- JSON.Decoder.atKey "botRight" dec
+    pure ( AABB { topLeft, botRight } )
+  where
+    dec :: JSON.Decoder m ( Point2D Double )
+    dec = decodePoint2D decodeDouble
+-}
+
+
+encodeCurve
+  :: forall clo crvData ptData f
+  .  ( SplineTypeI clo, Applicative f )
+  => JSON.Encoder Identity ptData
+  -> JSON.Encoder f ( Curve clo crvData ptData )
+encodeCurve  encodePtData = case ssplineType @clo of
+  SOpen   -> JSON.Encoder.mapLikeObj \case
+    LineTo          ( NextPoint p1 ) _ ->
+        JSON.Encoder.atKey' "p1" encodePtData p1
+    Bezier2To    p1 ( NextPoint p2 ) _ ->
+        JSON.Encoder.atKey' "p1" encodePtData p1
+      . JSON.Encoder.atKey' "p2" encodePtData p2
+    Bezier3To p1 p2 ( NextPoint p3 ) _ ->
+        JSON.Encoder.atKey' "p1" encodePtData p1
+      . JSON.Encoder.atKey' "p2" encodePtData p2
+      . JSON.Encoder.atKey' "p3" encodePtData p3
+  SClosed -> JSON.Encoder.mapLikeObj \case
+    LineTo          BackToStart _ -> id
+    Bezier2To    p1 BackToStart _ ->
+        JSON.Encoder.atKey' "p1" encodePtData p1
+    Bezier3To p1 p2 BackToStart _ ->
+        JSON.Encoder.atKey' "p1" encodePtData p1
+      . JSON.Encoder.atKey' "p2" encodePtData p2
+
+decodeCurve
+  :: forall clo ptData m
+  .  ( SplineTypeI clo, MonadIO m )
+  => JSON.Decoder m ptData
+  -> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
+decodeCurve decodePtData = do
+  noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
+  case ssplineType @clo of
+    SOpen   -> do
+      p1    <- JSON.Decoder.atKey         "p1" decodePtData
+      mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
+      case mb_p2 of
+        Nothing ->
+          pure ( LineTo ( NextPoint p1 ) noCache )
+        Just p2 -> do
+          mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
+          case mb_p3 of
+            Nothing -> pure ( Bezier2To    p1 ( NextPoint p2 ) noCache )
+            Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
+    SClosed -> do
+      mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
+      case mb_p1 of
+        Nothing ->
+          pure ( LineTo BackToStart noCache )
+        Just p1 -> do
+          mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
+          case mb_p2 of
+            Nothing -> pure ( Bezier2To    p1 BackToStart noCache )
+            Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
+
+
+
+encodeCurves
+  :: forall clo crvData ptData f
+  .  ( SplineTypeI clo, Applicative f )
+  => JSON.Encoder Identity ptData
+  -> JSON.Encoder f ( Curves clo crvData ptData )
+encodeCurves encodePtData = case ssplineType @clo of
+  SOpen   -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData )
+  SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR )
+    where
+      encodeL :: JSON.Encoder f ()
+      encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text
+      encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData )
+      encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) ->
+          JSON.Encoder.atKey' "prevOpenCurves"  ( encodeSequence $ encodeCurve @Open   encodePtData ) openCurves
+        . JSON.Encoder.atKey' "lastClosedCurve"                  ( encodeCurve @Closed encodePtData ) closedCurve
+
+decodeCurves
+  :: forall clo ptData m
+  .  ( SplineTypeI clo, MonadIO m )
+  => JSON.Decoder m ptData
+  -> JSON.Decoder m ( Curves clo ( CachedStroke RealWorld ) ptData )
+decodeCurves decodePtData = case ssplineType @clo of
+  SOpen   -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
+  SClosed -> do
+    mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
+    case mbNoCurves of
+      Just _ -> pure NoCurves
+      Nothing -> do
+        prevCurves <- JSON.Decoder.atKey "prevOpenCurves"  ( decodeSequence $ decodeCurve @Open   decodePtData )
+        lastCurve  <- JSON.Decoder.atKey "lastClosedCurve"                  ( decodeCurve @Closed decodePtData )
+        pure ( ClosedCurves prevCurves lastCurve )
+
+
+
+encodeSpline
+  :: forall clo crvData ptData f
+  .  ( SplineTypeI clo, Applicative f )
+  => JSON.Encoder Identity ptData
+  -> JSON.Encoder f ( Spline clo crvData ptData )
+encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) ->
+    JSON.Encoder.atKey' "splineStart"  encodePtData                       splineStart
+  . JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
+
+decodeSpline
+  :: forall clo ptData m
+  .  ( SplineTypeI clo, MonadIO m )
+  => JSON.Decoder m ptData
+  -> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
+decodeSpline decodePtData = do
+  splineStart  <- JSON.Decoder.atKey "splineStart"  decodePtData
+  splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
+  pure ( Spline { splineStart, splineCurves } )

src/metabrushes/MetaBrush/Util.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE MonoLocalBinds      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module MetaBrush.Util
+  ( traverseMaybe
+  , Exists(..)
+  )
+  where
+
+-- containers
+import Data.Sequence
+  ( Seq(..) )
+
+--------------------------------------------------------------------------------
+
+traverseMaybe :: Applicative f => ( a -> f ( Maybe b ) ) -> Seq a -> f ( Seq b )
+traverseMaybe _ Empty        = pure Empty
+traverseMaybe f ( a :<| as ) = ( \ case { Nothing -> id; Just b -> ( b :<| ) } ) <$> f a <*> traverseMaybe f as
+
+--------------------------------------------------------------------------------
+
+data Exists c where
+  Exists :: c a => a -> Exists c

src/splines/Math/Bezier/Cubic.hs

@@ -33,7 +33,9 @@ import Data.Monoid
 import Data.Semigroup
   ( ArgMin, Min(..), Arg(..) )
 import GHC.Generics
-  ( Generic, Generic1 )
+  ( Generic, Generic1
+  , Generically(..), Generically1(..)
+  )
 
 -- acts
 import Data.Act
@@ -46,10 +48,6 @@ import Data.Act
 import Control.DeepSeq
   ( NFData, NFData1 )
 
--- generic-data
-import Generic.Data
-  ( GenericProduct(..), Generically1(..) )
-
 -- groups
 import Data.Group
   ( Group )
@@ -88,7 +86,7 @@ data Bezier p
     { p0, p1, p2, p3 :: !p }
   deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
-    via GenericProduct ( Bezier p )
+    via Generically ( Bezier p )
   deriving Applicative
     via Generically1 Bezier
   deriving anyclass ( NFData, NFData1 )

src/splines/Math/Bezier/Quadratic.hs

@@ -30,7 +30,9 @@ import Data.Monoid
 import Data.Semigroup
   ( ArgMin, Min(..), Arg(..) )
 import GHC.Generics
-  ( Generic, Generic1 )
+  ( Generic, Generic1
+  , Generically(..), Generically1(..)
+  )
 
 -- acts
 import Data.Act
@@ -43,10 +45,6 @@ import Data.Act
 import Control.DeepSeq
   ( NFData, NFData1 )
 
--- generic-data
-import Generic.Data
-  ( GenericProduct(..), Generically1(..) )
-
 -- groups
 import Data.Group
   ( Group )
@@ -83,7 +81,7 @@ data Bezier p
     { p0, p1, p2 :: !p }
   deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
-    via GenericProduct ( Bezier p )
+    via Generically ( Bezier p )
   deriving Applicative
     via Generically1 Bezier
   deriving anyclass ( NFData, NFData1 )

src/splines/Math/Bezier/Spline.hs

@@ -61,7 +61,7 @@ import Control.DeepSeq
 -- generic-lens
 import Data.Generics.Product.Fields
   ( field )
-import Data.GenericLens.Internal
+import Data.Generics.Internal.VL
   ( set )
 
 -- transformers

src/splines/Math/Bezier/Stroke.hs

@@ -70,7 +70,7 @@ import Control.DeepSeq
 -- generic-lens
 import Data.Generics.Product.Typed
   ( HasType(typed) )
-import Data.GenericLens.Internal
+import Data.Generics.Internal.VL
   ( set, view )
 
 -- groups
@@ -178,7 +178,8 @@ coords = view typed
 computeStrokeOutline ::
   forall diffParams ( clo :: SplineType ) brushParams crvData ptData s
   .  ( KnownSplineType clo
-     , Group  diffParams, Module Double diffParams
+     , Group  diffParams
+     , Module Double diffParams
      , Torsor diffParams brushParams
      , HasType ( Point2D Double ) ptData
      , HasType ( CachedStroke s ) crvData

src/splines/Math/MPoly.hs

@@ -0,0 +1 @@
+module Math.MPoly where

src/splines/Math/Orientation.hs

@@ -30,7 +30,7 @@ import Data.Sequence
 -- generic-lens
 import Data.Generics.Product.Typed
   ( HasType(typed) )
-import Data.GenericLens.Internal
+import Data.Generics.Internal.VL
   ( view )
 
 -- MetaBrush

src/splines/Math/Vector2D.hs

@@ -17,7 +17,7 @@ module Math.Vector2D
 import Data.Monoid
   ( Sum(..) )
 import GHC.Generics
-  ( Generic, Generic1 )
+  ( Generic, Generic1, Generically(..), Generically1(..) )
 
 -- acts
 import Data.Act
@@ -27,10 +27,6 @@ import Data.Act
 import Control.DeepSeq
   ( NFData, NFData1 )
 
--- generic-data
-import Generic.Data
-  ( Generically1(..), GenericProduct(..) )
-
 -- groups
 import Data.Group
   ( Group )
@@ -53,7 +49,7 @@ newtype Vector2D a = MkVector2D { tip :: Point2D a }
   deriving stock   ( Show, Generic, Generic1, Foldable, Traversable )
   deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 )
   deriving ( Semigroup, Monoid, Group )
-    via GenericProduct ( Point2D ( Sum a ) )
+    via Generically ( Point2D ( Sum a ) )
 
 {-# COMPLETE Vector2D #-}
 pattern Vector2D :: a -> a -> Vector2D a
@@ -73,7 +69,7 @@ data Segment p =
     }
   deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
-    via GenericProduct ( Segment p )
+    via Generically ( Segment p )
   deriving Applicative
     via Generically1 Segment
   deriving anyclass ( NFData, NFData1 )