From dae99934ec174ba3414a4c6700cf49ff32a6d8f2 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 6 Feb 2022 14:35:51 +0100 Subject: [PATCH] WIP 2 --- MetaBrush.cabal | 2 + src/app/MetaBrush/Application.hs | 12 +- src/app/MetaBrush/Brush.hs | 35 ++-- src/app/MetaBrush/DSL/AST.hs | 7 +- src/app/MetaBrush/DSL/Eval.hs | 10 +- src/app/MetaBrush/DSL/Interpolation.hs | 24 ++- src/app/MetaBrush/DSL/TypeCheck.hs | 25 +-- src/app/MetaBrush/Document.hs | 15 +- src/app/MetaBrush/Document/Draw.hs | 17 +- src/app/MetaBrush/Document/Serialise.hs | 18 +- src/app/MetaBrush/Document/Serialise.hs-boot | 8 +- src/app/MetaBrush/Records.hs | 181 +++++++++++++++---- src/app/MetaBrush/Render/Document.hs | 14 +- 13 files changed, 215 insertions(+), 153 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index b610147..7cd4ee9 100644 --- a/MetaBrush.cabal +++ b/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 diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index cb7945d..f3d268e 100644 --- a/src/app/MetaBrush/Application.hs +++ b/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 diff --git a/src/app/MetaBrush/Brush.hs b/src/app/MetaBrush/Brush.hs index 9b6ff97..2e05294 100644 --- a/src/app/MetaBrush/Brush.hs +++ b/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(..) - , 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 $ diff --git a/src/app/MetaBrush/DSL/AST.hs b/src/app/MetaBrush/DSL/AST.hs index f5620d8..832fec5 100644 --- a/src/app/MetaBrush/DSL/AST.hs +++ b/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 ) diff --git a/src/app/MetaBrush/DSL/Eval.hs b/src/app/MetaBrush/DSL/Eval.hs index 0a01855..6192289 100644 --- a/src/app/MetaBrush/DSL/Eval.hs +++ b/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 ) diff --git a/src/app/MetaBrush/DSL/Interpolation.hs b/src/app/MetaBrush/DSL/Interpolation.hs index ab7a207..2970853 100644 --- a/src/app/MetaBrush/DSL/Interpolation.hs +++ b/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 diff --git a/src/app/MetaBrush/DSL/TypeCheck.hs b/src/app/MetaBrush/DSL/TypeCheck.hs index b6f1cec..9f9dd47 100644 --- a/src/app/MetaBrush/DSL/TypeCheck.hs +++ b/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 - let - declsRecord :: Record UniqueTerm kvs - declsRecord = MkR (Map.fromList . map (first Text.unpack) $ names) - return $ f declsRecord + return $ + proveSomeSTypes (map (second mkSomeSType) names) \ ( _ :: Proxy# kvs ) -> + let + 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 diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 588b9ee..18bc5f0 100644 --- a/src/app/MetaBrush/Document.hs +++ b/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 ) diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 5b02674..6bee5dc 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/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 diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 0743d3a..0b9a49c 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/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 - , 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 ) diff --git a/src/app/MetaBrush/Document/Serialise.hs-boot b/src/app/MetaBrush/Document/Serialise.hs-boot index 77f59b5..c15e15c 100644 --- a/src/app/MetaBrush/Document/Serialise.hs-boot +++ b/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 diff --git a/src/app/MetaBrush/Records.hs b/src/app/MetaBrush/Records.hs index ebe82d2..c2b7e5e 100644 --- a/src/app/MetaBrush/Records.hs +++ b/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 - ( Record , RecordDicts(..) - , Dict(..), I(..), K(..) - ) -import Data.Record.Anonymous.Internal - ( Record(MkR) ) -import qualified Data.Record.Anonymous as Rec - ( mapM, cpure, cmap, czipWith, collapse ) +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.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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 728bc0c..dd8283c 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/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