WIP 2

MetaBrush.cabal

@@ -233,6 +233,8 @@ executable MetaBrush
           ^>= 0.5
       , unordered-containers
            >= 0.2.11     && < 0.2.14
+      , vector
+           >= 0.12       && < 0.13
       , waargonaut
           ^>= 0.8.0.2
 

src/app/MetaBrush/Application.hs

@@ -9,8 +9,6 @@
 {-# LANGUAGE RecursiveDo       #-}
 {-# LANGUAGE TypeApplications  #-}
 
-{-# OPTIONS_GHC -fplugin=Data.Record.Anonymous.Plugin #-}
-
 module MetaBrush.Application
   ( runApplication )
   where
@@ -67,12 +65,6 @@ import qualified GI.GLib as GLib
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
--- large-anon
-import Data.Record.Anonymous
-  ( I(..) )
-import qualified Data.Record.Anonymous as Rec
-  ( empty, insert )
-
 -- lens
 import Control.Lens
   ( (.~) )
@@ -125,7 +117,9 @@ import MetaBrush.Document.Update
 import MetaBrush.Event
   ( handleEvents )
 import MetaBrush.Records
-  ( Rec )
+  ( Rec, I(..) )
+import qualified MetaBrush.Records as Rec
+  ( empty, insert )
 import MetaBrush.Render.Document
   ( blankRender, getDocumentRender )
 import MetaBrush.Render.Rulers

src/app/MetaBrush/Brush.hs

@@ -13,8 +13,6 @@
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
 
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
-
 module MetaBrush.Brush
   ( Brush(..), SomeBrush(..)
   , BrushFunction
@@ -31,10 +29,6 @@ import GHC.Exts
 import Unsafe.Coerce
   ( unsafeCoerce )
 
--- containers
-import qualified Data.Map.Strict as Map
-  ( fromList )
-
 -- deepseq
 import Control.DeepSeq
   ( NFData(..), deepseq )
@@ -43,14 +37,6 @@ import Control.DeepSeq
 import Data.Hashable
   ( Hashable(..) )
 
--- large-anon
-import Data.Record.Anonymous
-  ( RecordDicts, Dict(..) )
-import qualified Data.Record.Anonymous as Rec
-  ( map )
-import Data.Record.Anonymous.Internal
-  ( Record(MkR) )
-
 -- text
 import Data.Text
   ( Text )
@@ -69,9 +55,12 @@ import MetaBrush.DSL.Types
 import MetaBrush.DSL.Interpolation
   ( Interpolatable(..) )
 import MetaBrush.Records
-  ( Rec, WithParams(..)
+  ( Rec, Record, WithParams(..)
-  , proveRecordDicts
+  , AllFields, KnownFields, Dict(..)
+  , recordFromList, proveRecordDicts
   )
+import qualified MetaBrush.Records as Rec
+  ( map )
 
 --------------------------------------------------------------------------------
 
@@ -134,7 +123,8 @@ data SomeBrushFields where
       , rec ~ Rec kvs
       , Show rec, NFData rec
       , Serialisable rec
-      , RecordDicts kvs Interpolatable
+      , KnownFields kvs
+      , AllFields kvs Interpolatable
       )
     => Proxy# kvs -> SomeBrushFields
 
@@ -154,17 +144,16 @@ reflectBrushFieldsNoDups elts =
     mkField (SomeFieldSType px) = unsafeCoerce $ FieldSType px
   in
   proveSomeSTypes (map (second mkSomeSType) elts) \ ( px :: Proxy# kvs ) ->
+    recordFromList @FieldSType @kvs (map (Text.unpack *** mkField) elts) \ dictsRec ->
     let
-      dictsRec :: Record FieldSType kvs
-      dictsRec = MkR (Map.fromList $ map (Text.unpack *** mkField) elts)
       showDicts :: Record (Dict Show) kvs
-      showDicts = Rec.map ( \ ( ( FieldSType ( _ :: Proxy# a ) ) ) -> Dict @Show @a ) dictsRec
+      showDicts = Rec.map ( \ ( FieldSType ( _ :: Proxy# a ) ) -> Dict @Show @a ) dictsRec
       nfDataDicts :: Record (Dict NFData) kvs
-      nfDataDicts = Rec.map ( \ ( ( FieldSType ( _ :: Proxy# a ) ) ) -> Dict @NFData @a ) dictsRec
+      nfDataDicts = Rec.map ( \ ( FieldSType ( _ :: Proxy# a ) ) -> Dict @NFData @a ) dictsRec
       serialisableDicts :: Record (Dict Serialisable) kvs
-      serialisableDicts = Rec.map ( \ ( ( FieldSType ( _ :: Proxy# a ) ) ) -> Dict @Serialisable @a ) dictsRec
+      serialisableDicts = Rec.map ( \ ( FieldSType ( _ :: Proxy# a ) ) -> Dict @Serialisable @a ) dictsRec
       interpolatableDicts :: Record (Dict Interpolatable) kvs
-      interpolatableDicts = Rec.map ( \ ( ( FieldSType ( _ :: Proxy# a ) ) ) -> Dict @Interpolatable @a ) dictsRec
+      interpolatableDicts = Rec.map ( \ ( FieldSType ( _ :: Proxy# a ) ) -> Dict @Interpolatable @a ) dictsRec
     in
       proveRecordDicts @Show           showDicts $
       proveRecordDicts @NFData         nfDataDicts $

src/app/MetaBrush/DSL/AST.hs

@@ -21,7 +21,6 @@
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
 
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 module MetaBrush.DSL.AST
@@ -56,10 +55,6 @@ import Data.Tree
 import Control.DeepSeq
   ( NFData(..) )
 
--- large-anon
-import Data.Record.Anonymous
-  ( Record )
-
 -- text
 import Data.Text
   ( Text )
@@ -79,7 +74,7 @@ import Math.Bezier.Spline
 import MetaBrush.DSL.Types
   ( STypeI(..) )
 import MetaBrush.Records
-  ( WithParams, foldRec )
+  ( Record, WithParams, foldRec )
 import MetaBrush.Unique
   ( Unique )
 

src/app/MetaBrush/DSL/Eval.hs

@@ -37,11 +37,6 @@ import qualified Data.Map.Strict as Map
 import Data.Generics.Product.Fields
   ( field' )
 
--- large-anon
-import Data.Record.Anonymous
-  ( Record, I(..) )
-import qualified Data.Record.Anonymous as Rec
-
 -- lens
 import Control.Lens
   ( assign, modifying, use )
@@ -83,9 +78,12 @@ import MetaBrush.DSL.Types
 import MetaBrush.DSL.Rename
   ( UniqueName(..) )
 import MetaBrush.Records
-  ( Rec, WithParams(..)
+  ( Record, Rec, WithParams(..)
+  , I(..)
   , foldRec
   )
+import qualified MetaBrush.Records as Rec
+  ( map, zipWith, mapM )
 import MetaBrush.Unique
   ( Unique )
 

src/app/MetaBrush/DSL/Interpolation.hs

@@ -35,17 +35,15 @@ import Data.Act
 import Data.Group
   ( Group(..) )
 
--- large-anon
-import Data.Record.Anonymous
-  ( Record, RecordDicts, I(..) )
-import qualified Data.Record.Anonymous as Rec
-  ( cpure, cmap, czipWith )
-
 -- MetaBrush
 import Math.Module
   ( Module(..) )
 import Math.Vector2D
   ( Point2D, Vector2D )
+import MetaBrush.Records
+  ( Record, KnownFields, AllFields, I(..) )
+import qualified MetaBrush.Records as Rec
+  ( cpure, cmap, czipWith )
 
 --------------------------------------------------------------------------------
 
@@ -77,28 +75,28 @@ instance Interpolatable a => Module Double (D a) where
   D a ^+^ D b = D (a ^+^ b)
   d *^ D a = D (d *^ a)
 
-instance RecordDicts kvs Interpolatable
+instance AllFields kvs Interpolatable
       => Semigroup (Record D kvs) where
   (<>) = Rec.czipWith (Proxy @Interpolatable) (<>)
-instance RecordDicts kvs Interpolatable
+instance (KnownFields kvs, AllFields kvs Interpolatable)
       => Monoid    (Record D kvs) where
   mempty = Rec.cpure (Proxy @Interpolatable) mempty
-instance RecordDicts kvs Interpolatable
+instance (KnownFields kvs, AllFields kvs Interpolatable)
       => Group     (Record D kvs) where
   invert = Rec.cmap (Proxy @Interpolatable) invert
 
-instance RecordDicts kvs Interpolatable
+instance AllFields kvs Interpolatable
       => Act (Record D kvs) (Record I kvs) where
   act = Rec.czipWith (Proxy @Interpolatable) act
-instance RecordDicts kvs Interpolatable
+instance (KnownFields kvs, AllFields kvs Interpolatable)
       => Torsor (Record D kvs) (Record I kvs) where
   (-->) = Rec.czipWith (Proxy @Interpolatable) (-->)
-instance RecordDicts kvs Interpolatable
+instance (KnownFields kvs, AllFields kvs Interpolatable)
       => Module Double (Record D kvs) where
   origin = Rec.cpure (Proxy @Interpolatable) origin
   (^+^)  = Rec.czipWith (Proxy @Interpolatable) (^+^)
   d *^ r = Rec.cmap (Proxy @Interpolatable) (d *^) r
 
-instance RecordDicts kvs Interpolatable
+instance (KnownFields kvs, AllFields kvs Interpolatable)
       => Interpolatable (Record I kvs) where
   type Diff (Record I kvs) = Record D kvs

src/app/MetaBrush/DSL/TypeCheck.hs

@@ -15,8 +15,6 @@
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances   #-}
 
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
-
 module MetaBrush.DSL.TypeCheck
   ( typeCheck, MonadTc, TcM
   , TcMessage, TcError
@@ -43,8 +41,6 @@ import Unsafe.Coerce
 -- containers
 import Data.Map.Strict
   ( Map )
-import qualified Data.Map.Strict as Map
-  ( fromList )
 import Data.Sequence
   ( Seq(..) )
 
@@ -56,13 +52,6 @@ import Data.DList
 import Data.Generics.Product.Fields
   ( field' )
 
--- large-anon
-import Data.Record.Anonymous
-  ( Record
-   )
-import Data.Record.Anonymous.Internal
-  ( Record(MkR) )
-
 -- lens
 import Control.Lens
   ( assign, at, use )
@@ -112,6 +101,8 @@ import MetaBrush.DSL.Types
   )
 import MetaBrush.DSL.Rename
   ( Env(..), UniqueName(..) )
+import MetaBrush.Records
+  ( Record, recordFromList )
 import MetaBrush.Unique
   ( UniqueSupply, MonadUnique, Unique )
 
@@ -297,11 +288,13 @@ withDeclsRecord decls f = do
   let
     mkSomeSType :: forall a. UniqueTerm a -> SomeSType
     mkSomeSType ( UniqueTerm {} ) = SomeSType @a proxy#
-  proveSomeSTypes (map (second mkSomeSType) names) \ ( _ :: Proxy# kvs ) -> do
+  return $
-    let
+    proveSomeSTypes (map (second mkSomeSType) names) \ ( _ :: Proxy# kvs ) ->
-      declsRecord :: Record UniqueTerm kvs
+      let
-      declsRecord = MkR (Map.fromList . map (first Text.unpack) $ names)
+        terms = map (first Text.unpack) $ names
-    return $ f declsRecord
+      in
+        recordFromList @UniqueTerm @kvs terms \ declsRecord ->
+          f declsRecord
 
 getDeclName :: MonadTc m => Decl Tc -> m ( Text, UniqueTerm Any )
 getDeclName ( ValDecl pat ( Located eqLoc _ ) term ) = case pat of

src/app/MetaBrush/Document.hs

@@ -74,10 +74,6 @@ import Data.Generics.Product.Fields
 import Data.Group
   ( Group(..) )
 
--- large-anon
-import Data.Record.Anonymous
-  ( RecordDicts )
-
 -- lens
 import Control.Lens
   ( Lens'
@@ -118,7 +114,7 @@ import MetaBrush.DSL.Types
 import MetaBrush.DSL.Interpolation
   ( Interpolatable(..) )
 import MetaBrush.Records
-  ( Rec )
+  ( Rec, KnownFields, AllFields )
 import MetaBrush.UI.Viewport
   ( Ruler(..) )
 import MetaBrush.Unique
@@ -199,7 +195,8 @@ data Stroke where
        , pointParams ~ Rec pointFields
        , STypesI pointFields, STypesI brushFields
        , Show pointParams, NFData pointParams
-       , RecordDicts pointFields Interpolatable
+       , KnownFields pointFields
+       ,  AllFields pointFields Interpolatable
        , Serialisable pointParams
        )
     =>
@@ -225,7 +222,8 @@ _strokeSpline
   => (  forall clo pointParams pointFields
      .  ( KnownSplineType clo
         , Show pointParams, NFData pointParams
-        , RecordDicts pointFields Interpolatable
+        , KnownFields pointFields
+        , AllFields pointFields Interpolatable
         , pointParams ~ Rec pointFields, STypesI pointFields
         , Serialisable pointParams
         )
@@ -240,7 +238,8 @@ overStrokeSpline
   :: (  forall clo pointParams pointFields
      .  ( KnownSplineType clo
         , Show pointParams, NFData pointParams
-        , RecordDicts pointFields Interpolatable
+        , KnownFields pointFields
+        , AllFields pointFields Interpolatable
         , pointParams ~ Rec pointFields, STypesI pointFields
         , Serialisable pointParams
         )

src/app/MetaBrush/Document/Draw.hs

@@ -10,8 +10,6 @@
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
 
-{-# OPTIONS_GHC -fplugin=Data.Record.Anonymous.Plugin #-}
-
 module MetaBrush.Document.Draw
   ( DrawAnchor(..), anchorsAreComplementary
   , getOrCreateDrawAnchor, addToAnchor
@@ -43,12 +41,6 @@ import Control.DeepSeq
 import Data.Generics.Product.Fields
   ( field, field' )
 
--- large-anon
-import Data.Record.Anonymous
-  ( RecordDicts )
-import qualified Data.Record.Anonymous as Rec
-  ( empty )
-
 -- lens
 import Control.Lens
   ( set, over, mapped )
@@ -97,7 +89,11 @@ import MetaBrush.DSL.Types
 import MetaBrush.DSL.Interpolation
   ( Interpolatable )
 import MetaBrush.Records
-  ( Rec )
+  ( Rec
+  , KnownFields, AllFields
+  )
+import qualified MetaBrush.Records as Rec
+  ( empty )
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique, uniqueText )
 
@@ -261,7 +257,8 @@ withAnchorBrushData
        , STypesI pointFields, STypesI brushFields
        , Show pointParams, NFData pointParams
        , Serialisable pointParams
-       , RecordDicts pointFields Interpolatable
+       , KnownFields pointFields
+       , AllFields pointFields Interpolatable
        )
      => Maybe (Brush brushFields)
      -> pointParams

src/app/MetaBrush/Document/Serialise.hs

@@ -87,14 +87,6 @@ import System.FilePath
 import Data.Generics.Product.Typed
   ( HasType(typed) )
 
--- large-anon
-import Data.Record.Anonymous
-  ( Record, RecordDicts(..)
-  , K(..), I(..), unI
-  )
-import qualified Data.Record.Anonymous as Rec
-  ( collapse )
-
 -- lens
 import Control.Lens
   ( view )
@@ -190,9 +182,11 @@ import MetaBrush.DSL.Types
 import MetaBrush.DSL.Driver
   ( SomeBrushFunction(..), interpretBrush )
 import MetaBrush.Records
-  ( Rec, WithParams
+  ( Record, Rec, WithParams
-  , cpureM, cmapWithKey
+  , KnownFields, AllFields, K(..), I(..), unI
+  , cpureM, cmapWithKey, collapse
   )
+
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique )
 import qualified Paths_MetaBrush as Cabal
@@ -275,13 +269,13 @@ instance Serialisable a => Serialisable (I a) where
   encoder = contramap unI encoder
   decoder = fmap I decoder
 
-instance ( RecordDicts kvs Serialisable )
+instance ( KnownFields kvs, AllFields kvs Serialisable )
       => 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 = Rec.collapse . cmapWithKey (Proxy @Serialisable) keyVal
+      encodeFields = collapse . cmapWithKey (Proxy @Serialisable) keyVal
       keyVal :: (Serialisable x, KnownSymbol k) => Proxy k -> I x -> K (Text, Json) x
       keyVal k (I x) = K ( Text.pack $ symbolVal k, JSON.Encoder.runPureEncoder encoder x )
 

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

@@ -6,10 +6,6 @@ module MetaBrush.Document.Serialise
   ( Serialisable(..) )
   where
 
--- large-anon
-import Data.Record.Anonymous
-  ( Record, RecordDicts, I )
-
 -- waargonaut
 import qualified Waargonaut.Decode as JSON
   ( Decoder )
@@ -19,6 +15,8 @@ import qualified Waargonaut.Encode as JSON
 -- MetaBrush
 import Math.Vector2D
   ( Point2D, Vector2D )
+import MetaBrush.Records
+  ( Record, KnownFields, AllFields, I )
 
 --------------------------------------------------------------------------------
 
@@ -32,5 +30,5 @@ instance Serialisable a => Serialisable ( Point2D a )
 
 instance Serialisable a => Serialisable ( Vector2D a )
 
-instance ( RecordDicts kvs Serialisable )
+instance ( KnownFields kvs, AllFields kvs Serialisable )
       => Serialisable ( Record I kvs ) where

src/app/MetaBrush/Records.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleContexts         #-}
 {-# LANGUAGE FlexibleInstances        #-}
 {-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE MagicHash                #-}
 {-# LANGUAGE MultiParamTypeClasses    #-}
 {-# LANGUAGE NamedFieldPuns           #-}
 {-# LANGUAGE PolyKinds                #-}
@@ -18,11 +19,29 @@
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module MetaBrush.Records where
+module MetaBrush.Records
+  ( Rec, WithParams(..)
+  , cpureM, cmapWithKey, foldRec
+  , recordFromList
+  , proveRecordDicts
+  , MyIntersection(..), myIntersect
+
+    -- * Re-exports
+  , Record, KnownFields, AllFields
+  , I(..), unI, K(..), Dict(..)
+  , Rec.empty
+  , Rec.map, Rec.mapM, Rec.zipWith, Rec.collapse
+  , Rec.cpure, Rec.cmap, Rec.czipWith
+  )
+  where
 
 -- base
+import Control.Monad.ST
+  ( runST )
 import Data.Coerce
   ( coerce )
+import Data.Foldable
+  ( for_ )
 import Data.Functor.Const
   ( Const(..) )
 import Data.Functor.Product
@@ -60,19 +79,88 @@ import Data.Group
   ( Group(..) )
 
 -- large-anon
-import Data.Record.Anonymous
+import Data.Record.Anonymous.Advanced
-   ( Record , RecordDicts(..)
+  ( Record )
-   , Dict(..), I(..), K(..)
+import qualified Data.Record.Anonymous.Advanced as Rec
-   )
+  ( empty, insert
-import Data.Record.Anonymous.Internal
+  , map, mapM, zipWith
-  ( Record(MkR) )
+  , cpure, cmap, czipWith, collapse
-import qualified Data.Record.Anonymous as Rec
+  )
-  ( mapM, cpure, cmap, czipWith, collapse )
+import Data.Record.Anonymous.Internal.Canonical
+  ( Canonical(..), withShapeOf )
+import qualified Data.Record.Anonymous.Internal.Combinators.Simple as Simple
+import Data.Record.Anonymous.Internal.Constraints
+  ( Constrained(..), constrain )
+import Data.Record.Anonymous.Internal.Record
+  ( canonicalize, unsafeFromCanonical )
+import Data.Record.Anonymous.Internal.Row
+  ( AllFields(fieldDicts), KnownFields )
+
+-- large-generics
+import Data.Record.Generic
+  ( Dict(..), I(..), unI, K(..) )
+
+-- vector
+import qualified Data.Vector as Boxed
+  ( Vector )
+import qualified Data.Vector.Mutable as Boxed.MVector
+import qualified Data.Vector as Boxed.Vector
 
 --------------------------------------------------------------------------------
 
--- This instance only uses RecordDicts and not generic metadata.
+data NextOffsets = NextOffsets { nextOffsetsArray :: ByteArray# }
-instance {-# OVERLAPPING #-} RecordDicts kvs Show => Show (Record I kvs) where
+
+type KnownFields :: [(Symbol, Type)] -> Constraint
+class KnownFields kvs where
+  fieldNames  :: Array ShortText
+  nextOffsets :: NextOffsets
+
+type AllFields :: (Type -> Constraint) -> [(Symbol, Type)] -> Constraint
+class AllFields kvs c where
+  allFieldsDict :: Array (Dict (c Any))
+
+type Record :: (Type -> Type) -> [(Symbol, Type)] -> Type
+data Record f kvs = UnsafeMkRecord { recordArray :: ByteArray }
+
+
+nextOffset :: NextOffsets -> Int# -> Int#
+nextOffset ( NextOffsets { nextOffsetsArray = ba } ) i
+  = indexIntArray# ba i
+
+lastIndex :: NextOffsets -> Int#
+lastIndex ( NextOffsets { nextOffsetsArray = PrimArray ba } ) =
+  ((sizeofByteArray# ba) `div#` sizeOf# (undefined :: Int)) -# 1#
+
+cpureM
+  :: forall c m f kvs
+  .  ( PrimMonad m, KnownFields kvs, AllFields c kvs )
+  => ( forall x. c x => m (f x) )
+  -> m ( Record f kvs )
+cpureM f = do
+  let !nxts   = nextOffsets @nxt
+      !last_i = lastIndex nxt
+      !sz     = nextOffset nxts last_i
+      !dicts  = allFieldsDict @kvs @c
+  mba <- newByteArray sz
+  let
+    go :: Int# -> Int# -> m ()
+    go i off
+      | isTrue# (i ># last_i)
+      = return ()
+      | otherwise
+      = do
+          case indexArray dicts (I# i) of
+            (Dict :: Dict (c x)) -> do
+              v <- f @x
+              writeByteArray mba v
+          go (i +# 1) (nextOffset nxts i)
+  go 0# 0#
+  ba <- freezeByteArray mba
+  pure $ UnsafeMkRecord { recordArray = ba }
+
+
+-- This instance only uses AllFields and not generic metadata.
+instance {-# OVERLAPPING #-} (KnownFields kvs, AllFields kvs Show) => Show (Record I kvs) where
   showsPrec d =
       aux
     . Rec.collapse
@@ -103,29 +191,31 @@ foldRec f r = coerce $ Rec.mapM g r
     g :: ( forall x. f x -> Const (Endo y) (I x) )
     g x = coerce (f x)
 
-instance RecordDicts kvs Semigroup
+instance AllFields kvs Semigroup
       => Semigroup (Record I kvs) where
   (<>) = Rec.czipWith (Proxy @Semigroup) (<>)
 
-instance ( RecordDicts kvs Semigroup
+instance ( KnownFields kvs
-         , RecordDicts kvs Monoid )
+         , AllFields kvs Semigroup
+         , AllFields kvs Monoid )
       => Monoid    (Record I kvs) where
   mempty = Rec.cpure (Proxy @Monoid) mempty
 
-instance ( RecordDicts kvs Semigroup
+instance ( KnownFields kvs
-         , RecordDicts kvs Monoid
+         , AllFields kvs Semigroup
-         , RecordDicts kvs Group )
+         , AllFields kvs Monoid
+         , AllFields kvs Group )
       => Group     (Record I kvs) where
   invert = Rec.cmap (Proxy @Group) ( \ (I g) -> I (invert g) )
 
-instance RecordDicts kvs NFData
+instance AllFields kvs NFData
       => NFData ( Record I kvs ) where
   rnf _ = () -- TODO
 
 data MyIntersection r1 g r2 c where
   MyIntersection
     :: forall i r1 g r2 c
-    .  ( RecordDicts i c )
+    .  ( KnownFields i, AllFields i c )
     => { myProject :: forall f. Record f r1 -> Record (f `Product` g) i
        , myInject  :: Record g i -> Record g r2
        }
@@ -133,9 +223,11 @@ data MyIntersection r1 g r2 c where
 
 myIntersect
   :: forall c r1 g r2
-  .  ( RecordDicts r1 c )
+  .  ( AllFields r1 c )
   => Record g r2
   -> MyIntersection r1 g r2 c
+myIntersect = undefined -- TODO
+{-
 myIntersect (MkR r2) =
   proveRecordDicts @c @Any intersectionDict
     ( MyIntersection { myProject, myInject } )
@@ -148,45 +240,64 @@ myIntersect (MkR r2) =
     intersectionDict =
       case recordDicts @r1 @c Proxy of
         MkR d -> MkR (Map.intersection d r2)
+-}
 
-cpureM ::
+cpureM
-     (Applicative m, RecordDicts r c)
+  :: forall c m f r
+  .   (Applicative m, KnownFields r, AllFields r c)
   => Proxy c
   -> (forall x. c x => m (f x))
   -> m (Record f r)
-cpureM p f = Rec.mapM (\Dict -> f) (recordDicts p)
+cpureM p f = Simple.mapM aux (constrain p (Simple.pure (K ())))
+  where
+    aux :: Constrained c (K ()) x -> m (f x)
+    aux (Constrained _) = f
 
 cmapWithKey ::
      forall c r f g
-  .  RecordDicts r c
+  .  (KnownFields r, AllFields r c)
   => Proxy c
   -> (forall k x. (c x, KnownSymbol k) => Proxy k -> f x -> g x)
   -> Record f r
   -> Record g r
 cmapWithKey p f =
-  zipWithKey ( \ px Dict x -> f px x ) (recordDicts p)
+  zipWithKey ( \ px (Constrained _) x -> f px x ) (constrain p (Simple.pure (K ())))
 
 zipWithKey ::
   forall r f g h
   .  ( forall k x. KnownSymbol k => Proxy k -> f x -> g x -> h x )
   -> Record f r -> Record g r -> Record h r
-zipWithKey f (MkR a) (MkR b) = MkR $
+zipWithKey f r1 r2
-    Map.intersectionWithKey g a b
+  | Canonical { canonFields = flds, canonValues = vals1 } <- canonicalize r1
-  where
+  , c2@( Canonical { canonValues = vals2 } ) <- canonicalize r2
-    g :: String -> f x -> g x -> h x
+  = let
-    g s = case someSymbolVal s of
+      vec :: Boxed.Vector (h Any)
-      SomeSymbol px -> f px
+      vec = runST do
+        mvec <- Boxed.MVector.unsafeNew (Boxed.Vector.length vals2)
+        for_ flds \ (fld, i) ->
+          let v1 = vals1 Boxed.Vector.! i
+              v2 = vals2 Boxed.Vector.! i
+          in
+            case someSymbolVal fld of
+              SomeSymbol px ->
+                Boxed.MVector.unsafeWrite mvec i (f px v1 v2)
+        Boxed.Vector.unsafeFreeze mvec
+    in unsafeFromCanonical (withShapeOf c2 vec)
 
-proveRecordDicts :: forall c r x. Record (Dict c) r -> (RecordDicts r c => x) -> x
+proveRecordDicts :: forall c r x. Record (Dict c) r -> (AllFields r c => x) -> x
 proveRecordDicts r f = case myDict of { MyDict -> f }
   where
     myDict :: MyDict r c
-    myDict = unsafeCoerce ( MyDict' $ RecordDictsDict ( const $ unsafeCoerce r ) )
+    myDict = unsafeCoerce ( MyDict' $ RecordDictsDict ( \ _ _ -> unsafeCoerce r ) )
 
 -- Dictionary passing nonsense.
 newtype RecordDictsDict r c
-  = RecordDictsDict (Proxy c -> Record (Dict c) r)
+  = RecordDictsDict (Proxy r -> Proxy c -> Record (Dict c) r)
 data MyDict r c where
-  MyDict :: RecordDicts r c => MyDict r c
+  MyDict :: AllFields r c => MyDict r c
 data MyDict' r c where
   MyDict' :: RecordDictsDict r c -> MyDict' r c
+
+
+recordFromList :: forall f kvs r. [(String, f Any)] -> ( KnownFields kvs => Record f kvs -> r ) -> r
+recordFromList _ _ = undefined

src/app/MetaBrush/Render/Document.hs

@@ -65,15 +65,6 @@ import Generic.Data
 -- gi-cairo-render
 import qualified GI.Cairo.Render as Cairo
 
--- large-anon
-import Data.Record.Anonymous
-  ( Record
-  
-  , I
-  )
-import qualified Data.Record.Anonymous as Rec
-  ( map )
-
 -- lens
 import Control.Lens
   ( view )
@@ -134,9 +125,12 @@ import MetaBrush.Document.Update
 import MetaBrush.DSL.Interpolation
   ( Interpolatable, DRec )
 import MetaBrush.Records
-  ( Rec, WithParams(..)
+  ( Record, Rec, WithParams(..)
   , MyIntersection (..), myIntersect
+  , I(..)
   )
+import qualified MetaBrush.Records as Rec
+  ( map )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
 import MetaBrush.Unique