This commit is contained in:
sheaf 2022-02-06 14:35:51 +01:00
parent e2e5296bd1
commit dae99934ec
13 changed files with 215 additions and 153 deletions

View file

@ -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

View file

@ -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

View file

@ -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(..)
, proveRecordDicts
( Rec, Record, WithParams(..)
, 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 $

View file

@ -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 )

View file

@ -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 )

View file

@ -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

View file

@ -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 $
proveSomeSTypes (map (second mkSomeSType) names) \ ( _ :: Proxy# kvs ) ->
let
declsRecord :: Record UniqueTerm kvs
declsRecord = MkR (Map.fromList . map (first Text.unpack) $ names)
return $ f declsRecord
terms = map (first Text.unpack) $ names
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

View file

@ -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
)

View file

@ -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

View file

@ -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
, cpureM, cmapWithKey
( Record, Rec, WithParams
, 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 )

View file

@ -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

View file

@ -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
( Record , RecordDicts(..)
, Dict(..), I(..), K(..)
import Data.Record.Anonymous.Advanced
( Record )
import qualified Data.Record.Anonymous.Advanced as Rec
( empty, insert
, map, mapM, zipWith
, cpure, cmap, czipWith, collapse
)
import Data.Record.Anonymous.Internal
( Record(MkR) )
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.
instance {-# OVERLAPPING #-} RecordDicts kvs Show => Show (Record I kvs) where
data NextOffsets = NextOffsets { nextOffsetsArray :: ByteArray# }
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
, RecordDicts kvs Monoid )
instance ( KnownFields kvs
, AllFields kvs Semigroup
, AllFields kvs Monoid )
=> Monoid (Record I kvs) where
mempty = Rec.cpure (Proxy @Monoid) mempty
instance ( RecordDicts kvs Semigroup
, RecordDicts kvs Monoid
, RecordDicts kvs Group )
instance ( KnownFields kvs
, AllFields kvs Semigroup
, 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 ::
(Applicative m, RecordDicts r c)
cpureM
:: 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 $
Map.intersectionWithKey g a b
where
g :: String -> f x -> g x -> h x
g s = case someSymbolVal s of
SomeSymbol px -> f px
zipWithKey f r1 r2
| Canonical { canonFields = flds, canonValues = vals1 } <- canonicalize r1
, c2@( Canonical { canonValues = vals2 } ) <- canonicalize r2
= let
vec :: Boxed.Vector (h Any)
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

View file

@ -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