mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
WIP 2
This commit is contained in:
sheaf
parent
e2e5296bd1
commit
dae99934ec
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue