WIP: large-anon & cleanups

This commit is contained in:
sheaf 2022-01-30 22:40:59 +01:00
parent 8333f69dc2
commit e2e5296bd1
25 changed files with 1017 additions and 1111 deletions

View file

@ -36,7 +36,7 @@ common common
, acts
^>= 0.3.1.0
, containers
>= 0.6.0.1 && < 0.6.5
>= 0.6.0.1 && < 0.7
, deepseq
>= 1.4.4.0 && < 1.5
, generic-data
@ -143,14 +143,16 @@ executable MetaBrush
, MetaBrush.Document.SubdivideStroke
, MetaBrush.Document.Update
, MetaBrush.Event
, MetaBrush.MetaParameter.AST
, MetaBrush.MetaParameter.Driver
, MetaBrush.MetaParameter.Eval
, MetaBrush.MetaParameter.Interpolation
, MetaBrush.MetaParameter.Parse
, MetaBrush.MetaParameter.PrimOp
, MetaBrush.MetaParameter.Rename
, MetaBrush.MetaParameter.TypeCheck
, MetaBrush.DSL.AST
, MetaBrush.DSL.Driver
, MetaBrush.DSL.Eval
, MetaBrush.DSL.Interpolation
, MetaBrush.DSL.Parse
, MetaBrush.DSL.PrimOp
, MetaBrush.DSL.Rename
, MetaBrush.DSL.Types
, MetaBrush.DSL.TypeCheck
, MetaBrush.Records
, MetaBrush.Render.Document
, MetaBrush.Render.Rulers
, MetaBrush.Time
@ -210,9 +212,11 @@ executable MetaBrush
, hashable
^>= 1.3.0.0
, haskell-gi
>= 0.25 && < 0.26
>= 0.25 && < 0.27
, haskell-gi-base
>= 0.25 && < 0.26
>= 0.25 && < 0.27
, large-anon
>= 0.1.0.0 && < 0.2
, lens
>= 4.19.2 && < 5.1
, mtl
@ -221,15 +225,21 @@ executable MetaBrush
^>= 0.3.6.2
, stm
^>= 2.5.0.0
, superrecord
^>= 0.5.1.0
, tardis
>= 0.4.2.0 && < 0.5
, text
>= 1.2.3.1 && < 1.2.5
>= 1.2.3.1 && < 1.3
, tree-view
^>= 0.5
, unordered-containers
>= 0.2.11 && < 0.2.14
, waargonaut
^>= 0.8.0.2
-- Because of large-anon:
, large-generics
>= 0.1.0.0 && < 0.2
, record-hasfield
^>= 1.0
, sop-core
^>= 0.5.0.2

View file

@ -41,8 +41,8 @@ source-repository-package
location: https://github.com/sheaf/generic-lens
tag: 8d3f0b405894ecade5821c99dcde6efb4a637363
-- superrecord API improvements
source-repository-package
type: git
location: https://github.com/agrafix/superrecord
tag: f1c8cf87fd25243e715fd9585e595a90fff34050
location: https://github.com/well-typed/large-records
subdir: large-generics
tag: acb837a9a4c22cea1abf552b47f9d3bf5af2fbdf

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -13,48 +13,38 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
module MetaBrush.MetaParameter.TypeCheck
module MetaBrush.DSL.TypeCheck
( typeCheck, MonadTc, TcM
, TcMessage, TcError
, TcState, emptyTcState
)
where
import Data.Kind
( Type )
-- base
import Control.Arrow
( first, second )
import Data.Either
( partitionEithers )
import Data.Functor.Compose
( Compose(..) )
import Data.List
( sortOn )
import Data.Ord
( Down(..) )
import Data.Proxy
( Proxy )
import Data.Kind
( Type )
import Data.Type.Equality
( (:~:)(Refl) )
import GHC.Exts
( Proxy#, proxy# )
( Any, Proxy#, proxy# )
import GHC.Generics
( Generic )
import GHC.TypeLits
( someSymbolVal, SomeSymbol(..) )
import GHC.TypeNats
( KnownNat )
import Unsafe.Coerce
( unsafeCoerce )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( fromList )
import Data.Sequence
( Seq(..) )
@ -66,6 +56,13 @@ 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 )
@ -78,16 +75,6 @@ import Control.Monad.State
import Control.Monad.Writer
( MonadWriter(..) )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( (:=)(..), FldProxy(..), RecSize, RecApply
, RecTy, RemoveAccessTo, RecVecIdxPos
, TraversalCHelper
, unsafeRNil, unsafeRCons
)
-- text
import Data.Text
( Text )
@ -109,18 +96,21 @@ import Math.Bezier.Spline
)
import Math.Vector2D
( Point2D(..) )
import MetaBrush.MetaParameter.AST
import MetaBrush.DSL.AST
( Span(..), Located(..)
, Pass(Rn,Tc)
, Pat(..), Decl(..)
, X_With(..), MapFields
, UniqueTerm, UniqueField(..), IsUniqueTerm, IsUniqueTerm2
, SType(..), STypeI(sTypeI), SomeSType(..)
, STypes(..), STypesI(..)
, Term(..), TypedTerm(..), eqTy
, X_With(..)
, UniqueTerm(..)
, Term(..), TypedTerm(..)
, termSpan
)
import MetaBrush.MetaParameter.Rename
import MetaBrush.DSL.Types
( SType(..), STypeI(sTypeI), SomeSType(..)
, STypesI(..)
, eqTy, proveSomeSTypes
)
import MetaBrush.DSL.Rename
( Env(..), UniqueName(..) )
import MetaBrush.Unique
( UniqueSupply, MonadUnique, Unique )
@ -174,12 +164,8 @@ typeCheck ( With locs ( Rn_With decls ) conds body ) = do
decls' <- typeCheckDecls decls
conds' <- traverse ( typeCheckAt @Bool "Expected Boolean condition, but expression has the wrong type." ) conds
TypedTerm body' <- typeCheck body
withDeclsRecord decls' \ ( decls'Record :: Super.Rec ( MapFields UniqueTerm kvs ) ) -> do
case unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueTerm kvs ) :~: SuperRecord.RecSize kvs of
Refl ->
case treeArgsDict @kvs @kvs of
RecTreeArgsDict ->
TypedTerm $ With locs ( Tc_With decls'Record ) conds' body'
withDeclsRecord decls' \ ( decls'Record :: Record UniqueTerm kvs ) ->
TypedTerm $ With locs ( Tc_With decls'Record ) conds' body'
typeCheck ( Lit loc a ) = pure ( TypedTerm $ Lit loc a )
typeCheck ( Op locs nm op ) = pure ( TypedTerm $ Op locs nm op )
typeCheck ( Point locs a b ) = do
@ -303,76 +289,26 @@ withDeclsRecord
:: forall r m
. ( MonadTc m )
=> [ Decl Tc ]
-> ( forall kvs. STypesI kvs => Super.Rec ( MapFields UniqueTerm kvs ) -> r )
-> ( forall kvs. STypesI kvs => Record UniqueTerm kvs -> r )
-> m r
withDeclsRecord decls f = do
TypedTermsRecord record <- go ( TypedTermsRecord $ SuperRecord.unsafeRNil lg ) <$> ( revSortDecls decls )
pure ( f record )
where
lg :: Int
lg = length decls
-- This list cannot have duplicate names,
-- as these would have been caught by the renamer.
-- Sort in reverse order as we must add elements in decreasing label order.
revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ]
revSortDecls = fmap ( sortOn ( Down . fst ) ) . traverse getDeclName
getDeclName :: Decl Tc -> m ( Text, ( UniqueName, TypedTerm ) )
getDeclName ( ValDecl pat ( Located eqLoc _ ) term ) = case pat of
PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, ( uniq, TypedTerm term ) )
AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, ( uniq, TypedTerm term ) )
_ -> tcError $ NoPatternName eqLoc
getDeclName ( FunDecl funName _ _ _ ) = tcError $ UnexpectedFunDecl funName
go :: TypedTermsRecord -> [ ( Text, ( UniqueName, TypedTerm ) ) ] -> TypedTermsRecord
go record [] = record
go ( TypedTermsRecord ( record :: Super.Rec ( MapFields UniqueTerm kvs ) ) )
( ( nm, ( uniq, TypedTerm ( t :: Term Tc a ) ) ) : ps )
= case someSymbolVal ( Text.unpack nm ) of
SomeSymbol ( _ :: Proxy nm ) ->
go
( TypedTermsRecord @( ( nm SuperRecord.:= a ) ': kvs )
$ SuperRecord.unsafeRCons @nm @( UniqueTerm a ) @( MapFields UniqueTerm kvs )
( SuperRecord.FldProxy @nm SuperRecord.:= Compose ( UniqueField uniq t ) )
record
)
ps
data TypedTermsRecord where
TypedTermsRecord
:: ( STypesI kvs, ts ~ MapFields UniqueTerm kvs, KnownNat ( SuperRecord.RecSize ts ) )
=> Super.Rec ts -> TypedTermsRecord
data RecTreeArgsDict rts lts where
RecTreeArgsDict
:: forall rts lts trts tlts frts flts
. ( trts ~ MapFields UniqueTerm rts, tlts ~ MapFields UniqueTerm lts
, frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
, SuperRecord.RecApply trts tlts IsUniqueTerm
, SuperRecord.TraversalCHelper flts trts frts IsUniqueTerm2
)
=> RecTreeArgsDict rts lts
treeArgsDict
:: forall rts lts trts tlts frts flts
. ( trts ~ MapFields UniqueTerm rts, tlts ~ MapFields UniqueTerm lts
, frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
, STypesI lts
, KnownNat ( SuperRecord.RecSize rts )
)
=> RecTreeArgsDict rts lts
treeArgsDict = case sTypesI @lts of
STyNil
| Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize frts :~: SuperRecord.RecSize rts )
-> RecTreeArgsDict
sTyCons@STyCons
| ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs ) ) <- sTyCons
, Refl <- ( unsafeCoerce Refl :: MapFields UniqueTerm lvs :~: SuperRecord.RemoveAccessTo l ( MapFields UniqueTerm lvs ) )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy l trts :~: Just ( UniqueTerm v ) )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos l trts :~: SuperRecord.RecSize lvs )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize trts :~: SuperRecord.RecSize rts )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize lvs :~: SuperRecord.RecSize ( MapFields UniqueField lvs ) )
-> case treeArgsDict @rts @lvs of
RecTreeArgsDict -> RecTreeArgsDict
-- This list cannot have duplicate names, as these would have been caught by the renamer.
names <- traverse getDeclName decls
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
getDeclName :: MonadTc m => Decl Tc -> m ( Text, UniqueTerm Any )
getDeclName ( ValDecl pat ( Located eqLoc _ ) term ) = case pat of
PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, unsafeCoerce $ UniqueTerm uniq term )
AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, unsafeCoerce $ UniqueTerm uniq term )
_ -> tcError $ NoPatternName eqLoc
getDeclName ( FunDecl funName _ _ _ ) = tcError $ UnexpectedFunDecl funName
--------------------------------------------------------------------------------
-- Type-checker-specific data and instances.

View file

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

View file

@ -74,6 +74,10 @@ import Data.Generics.Product.Fields
import Data.Group
( Group(..) )
-- large-anon
import Data.Record.Anonymous
( RecordDicts )
-- lens
import Control.Lens
( Lens'
@ -84,10 +88,6 @@ import Control.Lens
import Control.Concurrent.STM
( STM )
-- superrecord
import qualified SuperRecord as Super
( Rec )
-- text
import Data.Text
( Text )
@ -110,13 +110,15 @@ import Math.Module
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Brush
( BrushAdaptedTo )
( Brush )
import {-# SOURCE #-} MetaBrush.Document.Serialise
( Serialisable(..) )
import MetaBrush.MetaParameter.AST
import MetaBrush.DSL.Types
( STypesI(..) )
import MetaBrush.MetaParameter.Interpolation
( Interpolatable(..) ) -- + orphan instances
import MetaBrush.DSL.Interpolation
( Interpolatable(..) )
import MetaBrush.Records
( Rec )
import MetaBrush.UI.Viewport
( Ruler(..) )
import MetaBrush.Unique
@ -166,7 +168,7 @@ data DocumentContent
-- | Hierarchy for groups of strokes.
data StrokeHierarchy
= StrokeGroup
= StrokeGroup
{ groupName :: !Text
, groupVisible :: !Bool
, groupContents :: !( Seq StrokeHierarchy )
@ -194,16 +196,17 @@ type StrokeSpline clo brushParams =
data Stroke where
Stroke
:: ( KnownSplineType clo
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, pointParams ~ Rec pointFields
, STypesI pointFields, STypesI brushFields
, Show pointParams, NFData pointParams
, Interpolatable pointParams
, RecordDicts pointFields Interpolatable
, Serialisable pointParams
)
=>
{ strokeName :: !Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
, strokeBrush :: !( Maybe ( BrushAdaptedTo pointFields ) )
, strokeBrush :: !( Maybe ( Brush brushFields ) )
, strokeSpline :: !( StrokeSpline clo pointParams )
}
-> Stroke
@ -222,8 +225,8 @@ _strokeSpline
=> ( forall clo pointParams pointFields
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, Interpolatable pointParams
, RecordDicts pointFields Interpolatable
, pointParams ~ Rec pointFields, STypesI pointFields
, Serialisable pointParams
)
=> StrokeSpline clo pointParams
@ -237,8 +240,8 @@ overStrokeSpline
:: ( forall clo pointParams pointFields
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, Interpolatable pointParams
, RecordDicts pointFields Interpolatable
, pointParams ~ Rec pointFields, STypesI pointFields
, Serialisable pointParams
)
=> StrokeSpline clo pointParams

View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@ -9,6 +10,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fplugin=Data.Record.Anonymous.Plugin #-}
module MetaBrush.Document.Draw
( DrawAnchor(..), anchorsAreComplementary
, getOrCreateDrawAnchor, addToAnchor
@ -22,7 +25,7 @@ import Data.Coerce
import Data.Functor
( ($>) )
import Data.Semigroup
( First(..) )
( First(..) )
-- acts
import Data.Act
@ -40,20 +43,20 @@ 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 )
-- stm
import Control.Concurrent.STM
import Control.Concurrent.STM
( STM )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( rnil )
-- text
import Data.Text
( Text )
@ -79,7 +82,7 @@ import Math.Vector2D
import MetaBrush.Assert
( assert )
import MetaBrush.Brush
( BrushAdaptedTo )
( Brush(..) )
import MetaBrush.Document
( Document(..), DocumentContent(..)
, Stroke(..), StrokeHierarchy(..), StrokeSpline
@ -89,10 +92,12 @@ import MetaBrush.Document
)
import MetaBrush.Document.Serialise
( Serialisable )
import MetaBrush.MetaParameter.AST
import MetaBrush.DSL.Types
( STypesI(..) )
import MetaBrush.MetaParameter.Interpolation
( Interpolatable )
import MetaBrush.DSL.Interpolation
( Interpolatable )
import MetaBrush.Records
( Rec )
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText )
@ -132,9 +137,9 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
( newDoc, Nothing ) -> do
uniq <- runReaderT freshUnique uniqueSupply
let
newSpline :: StrokeSpline Open ( Super.Rec '[] )
newSpline :: StrokeSpline Open ( Rec '[] )
newSpline =
Spline { splineStart = PointData c Normal ( SuperRecord.rnil )
Spline { splineStart = PointData c Normal Rec.empty
, splineCurves = OpenCurves Empty
}
newStroke :: Stroke
@ -144,7 +149,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
, strokeVisible = True
, strokeUnique = uniq
, strokeSpline = newSpline
, strokeBrush = Nothing
, strokeBrush = Nothing :: Maybe ( Brush '[] )
}
newDoc' :: Document
newDoc'
@ -222,8 +227,7 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok
updateStroke :: Stroke -> Stroke
updateStroke stroke@( Stroke { strokeUnique } )
| strokeUnique == anchorStrokeUnique anchor
=
let
, let
updateSpline
:: forall clo brushData
. SplineTypeI clo
@ -236,7 +240,7 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline
AnchorAtEnd _ ->
AnchorAtEnd _ ->
let
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
@ -244,8 +248,7 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok
| otherwise
= assert ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
prevSpline -- should never add to a closed spline
in
overStrokeSpline updateSpline stroke
= overStrokeSpline updateSpline stroke
| otherwise
= stroke
@ -253,13 +256,14 @@ withAnchorBrushData
:: forall r
. DrawAnchor
-> Document
-> ( forall pointParams pointFields
. ( pointParams ~ Super.Rec pointFields, STypesI pointFields
-> ( forall pointParams pointFields brushFields
. ( pointParams ~ Rec pointFields
, STypesI pointFields, STypesI brushFields
, Show pointParams, NFData pointParams
, Interpolatable pointParams
, Serialisable pointParams
, RecordDicts pointFields Interpolatable
)
=> Maybe ( BrushAdaptedTo pointFields )
=> Maybe (Brush brushFields)
-> pointParams
-> r
)
@ -284,4 +288,4 @@ withAnchorBrushData anchor ( Document { documentContent = Content { strokes } }
AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) )
AnchorAtEnd {} -> f strokeBrush ( brushParams ( splineEnd strokeSpline ) )
splineAnchor _
= f Nothing SuperRecord.rnil
= f (Nothing :: Maybe (Brush '[])) Rec.empty

View file

@ -126,7 +126,7 @@ import MetaBrush.Document
)
import {-# SOURCE #-} MetaBrush.Document.Update
( DocChange(..) )
import MetaBrush.MetaParameter.Interpolation
import MetaBrush.DSL.Interpolation
( Interpolatable(Diff) )
import MetaBrush.Unique
( Unique )

View file

@ -1,6 +1,7 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
@ -14,8 +15,7 @@
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise
( Workaround(..), workaround
, Serialisable(..)
( Serialisable(..)
, documentToJSON, documentFromJSON
, saveDocument, loadDocument
)
@ -36,6 +36,8 @@ import Data.Functor.Contravariant
( contramap )
import Data.Functor.Identity
( Identity(..) )
import Data.Proxy
( Proxy(..) )
import Data.STRef
( newSTRef )
import Data.Type.Equality
@ -45,9 +47,7 @@ import Data.Version
import GHC.Exts
( Proxy#, proxy# )
import GHC.TypeLits
( symbolVal', KnownSymbol )
import GHC.TypeNats
( KnownNat )
( KnownSymbol, symbolVal )
import Unsafe.Coerce
( unsafeCoerce ) -- Tony Morris special
@ -87,6 +87,14 @@ 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 )
@ -103,17 +111,6 @@ import qualified Data.Scientific as Scientific
import qualified Control.Concurrent.STM as STM
( atomically )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( FldProxy(..)
, RecSize, RecApply(..), UnsafeRecBuild(..)
, reflectRec
)
import SuperRecord
( ConstC )
-- text
import Data.Text
( Text )
@ -177,22 +174,25 @@ import Math.Vector2D
( Point2D(..), Vector2D(..), Segment )
import MetaBrush.Brush
( Brush(..), SomeBrush(..)
, BrushAdaptedTo(..), adaptBrush
, SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups
, SomeFieldSType(..), SomeBrushFields(..)
, reflectBrushFieldsNoDups
)
import MetaBrush.Document
( Document(..), DocumentContent(..), Guide(..)
, Stroke(..), StrokeHierarchy(..), StrokeSpline
, PointData(..), FocusState(..)
)
import MetaBrush.MetaParameter.AST
import MetaBrush.DSL.Types
( SType(..), STypeI(..)
, SomeSType(..), someSTypes
, AdaptableFunction(..)
, eqTy
)
import MetaBrush.MetaParameter.Driver
import MetaBrush.DSL.Driver
( SomeBrushFunction(..), interpretBrush )
import MetaBrush.Records
( Rec, WithParams
, cpureM, cmapWithKey
)
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique )
import qualified Paths_MetaBrush as Cabal
@ -200,11 +200,6 @@ import qualified Paths_MetaBrush as Cabal
--------------------------------------------------------------------------------
-- | Dummy data-type that helps workaround a GHC bug with hs-boot files.
data Workaround = Workaround
workaround :: Workaround -> Workaround
workaround Workaround = Workaround
-- | Serialise a document to JSON (in the form of a lazy bytestring).
documentToJSON :: Document -> Lazy.ByteString
documentToJSON
@ -276,31 +271,22 @@ instance Serialisable a => Serialisable ( Vector2D a ) where
. JSON.Encoder.atKey' "y" encoder y
decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
instance ( SuperRecord.RecApply flds flds ( ConstC Serialisable )
, SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
, KnownNat ( SuperRecord.RecSize flds )
)
=> Serialisable ( Super.Rec flds ) where
encoder :: forall f. Monad f => JSON.Encoder f ( Super.Rec flds )
encoder = contramap ( SuperRecord.reflectRec @( ConstC Serialisable ) keyVal ) ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
where
keyVal :: forall k v. ( KnownSymbol k, Serialisable v ) => SuperRecord.FldProxy k -> v -> ( Text, Json )
keyVal _ v = let k = symbolVal' ( proxy# :: Proxy# k ) in ( Text.pack k, JSON.Encoder.runPureEncoder ( encoder @v ) v )
instance Serialisable a => Serialisable (I a) where
encoder = contramap unI encoder
decoder = fmap I decoder
decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds )
decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite
instance ( RecordDicts 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
decodeAndWrite
:: forall k v
. ( KnownSymbol k, Serialisable v )
=> SuperRecord.FldProxy k -> Proxy# v
-> JSON.Decoder m v
decodeAndWrite _ _ = do
let
k :: Text
k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
val <- JSON.Decoder.atKey k ( decoder @v @m )
pure val
encodeFields :: Record I kvs -> [ ( Text, Json ) ]
encodeFields = Rec.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 )
decoder :: forall m. Monad m => JSON.Decoder m ( Rec kvs )
decoder = cpureM (Proxy @Serialisable) decoder
--------------------------------------------------------------------------------
@ -498,19 +484,19 @@ decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.
encodePointData
:: forall f flds brushParams
. ( Applicative f
, brushParams ~ Super.Rec flds
, Serialisable ( Super.Rec flds )
, brushParams ~ Rec flds
, Serialisable ( Rec flds )
)
=> JSON.Encoder f ( PointData brushParams )
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) ->
JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords
. JSON.Encoder.atKey' "brushParams" ( encoder @( Super.Rec flds ) ) brushParams
. JSON.Encoder.atKey' "brushParams" ( encoder @( Rec flds ) ) brushParams
decodePointData
:: forall m flds brushParams
. ( Monad m
, brushParams ~ Super.Rec flds
, Serialisable ( Super.Rec flds )
, brushParams ~ Rec flds
, Serialisable ( Rec flds )
)
=> JSON.Decoder m ( PointData brushParams )
decodePointData = do
@ -518,7 +504,7 @@ decodePointData = do
let
pointState :: FocusState
pointState = Normal
brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Super.Rec flds ) )
brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Rec flds ) )
pure ( PointData { pointCoords, pointState, brushParams } )
@ -549,7 +535,7 @@ encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) ->
sTySpline@STySpline | ( _ :: SType ( SplinePts clo ) ) <- sTySpline
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "spline"
. JSON.Encoder.atKey' "closed" JSON.Encoder.bool ( case ssplineType @clo of { SOpen -> False; SClosed -> True } )
sTyRecord@STyWithFn | ( _ :: SType ( AdaptableFunction kvs res ) ) <- sTyRecord
sTyRecord@STyWithFn | ( _ :: SType ( WithParams kvs res ) ) <- sTyRecord
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "adaptableFun"
. JSON.Encoder.atKey' "fields" encodeFieldTypes ( someSTypes @kvs )
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# res ) )
@ -626,7 +612,7 @@ decodeFieldTypes = do
encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushFields )
encodeBrush :: Applicative f => JSON.Encoder f (Brush brushFields)
encodeBrush = JSON.Encoder.mapLikeObj
\ ( BrushData { brushName, brushCode } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
@ -649,7 +635,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
\ ( Stroke
{ strokeName
, strokeVisible
, strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
, strokeSpline = strokeSpline :: StrokeSpline clo ( Rec pointFields )
, strokeBrush
}
) ->
@ -662,7 +648,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
mbEncodeBrush = case strokeBrush of
Nothing ->
id
Just ( AdaptedBrush brush ) ->
Just brush ->
JSON.Encoder.atKey' "brush" encodeBrush brush
in
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
@ -679,22 +665,22 @@ decodeStroke uniqueSupply = do
strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
SomeBrushFields ( _ :: Proxy# pointFields ) <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
mbBrush <- JSON.Decoder.atKeyOptional "brush" ( decodeBrush uniqueSupply )
let
strokeBrush :: Maybe ( BrushAdaptedTo pointFields )
strokeBrush = case mbBrush of
Nothing
-> Nothing
Just ( SomeBrush ( brush@( BrushData {} ) ) )
-> Just $ adaptBrush @pointFields brush
mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" ( decodeBrush uniqueSupply )
if strokeClosed
then do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData )
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Rec pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
else do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Super.Rec pointFields ) ) decodePointData )
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Rec pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
encodeStrokeHierarchy :: Monad f => JSON.Encoder f StrokeHierarchy

View file

@ -1,21 +1,14 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise
( Workaround(..), workaround, Serialisable(..) )
( Serialisable(..) )
where
-- base
import GHC.TypeNats
( KnownNat )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( RecApply, RecSize, UnsafeRecBuild )
import SuperRecord
( ConstC )
-- large-anon
import Data.Record.Anonymous
( Record, RecordDicts, I )
-- waargonaut
import qualified Waargonaut.Decode as JSON
@ -29,10 +22,6 @@ import Math.Vector2D
--------------------------------------------------------------------------------
data Workaround = Workaround
workaround :: Workaround -> Workaround
class Serialisable a where
encoder :: Monad f => JSON.Encoder f a
decoder :: Monad m => JSON.Decoder m a
@ -43,8 +32,5 @@ instance Serialisable a => Serialisable ( Point2D a )
instance Serialisable a => Serialisable ( Vector2D a )
instance ( SuperRecord.RecApply flds flds ( ConstC Serialisable )
, SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
, KnownNat ( SuperRecord.RecSize flds )
)
=> Serialisable ( Super.Rec flds )
instance ( RecordDicts kvs Serialisable )
=> Serialisable ( Record I kvs ) where

View file

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

View file

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

View file

@ -0,0 +1,192 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module MetaBrush.Records where
-- base
import Data.Coerce
( coerce )
import Data.Functor.Const
( Const(..) )
import Data.Functor.Product
( Product(Pair) )
import Data.Kind
( Type )
import Data.List
( intersperse )
import Data.Monoid
( Endo(..) )
import Data.Proxy
( Proxy(..) )
import GHC.TypeLits
( Symbol, KnownSymbol, symbolVal
, SomeSymbol(..), someSymbolVal )
import GHC.Exts
( Any )
import GHC.Show
( showCommaSpace )
import Unsafe.Coerce
( unsafeCoerce )
-- containers
import Data.Map.Lazy as Map
( intersection, intersectionWith, intersectionWithKey
, union
)
-- deepseq
import Control.DeepSeq
( NFData(..) )
-- groups
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 )
--------------------------------------------------------------------------------
-- This instance only uses RecordDicts and not generic metadata.
instance {-# OVERLAPPING #-} RecordDicts kvs Show => Show (Record I kvs) where
showsPrec d =
aux
. Rec.collapse
. cmapWithKey (Proxy @Show) showField
where
showField :: (KnownSymbol k, Show x) => Proxy k -> I x -> K ShowS x
showField k x = K $ showString (symbolVal k) . showString " = " . showsPrec 0 x
aux :: [ShowS] -> ShowS
aux fields = showParen (d >= 11) (
showString " {"
. foldr (.) id (intersperse showCommaSpace fields)
. showString "}"
)
data WithParams params a =
WithParams
{ defaultParams :: Rec params
, withParams :: Rec params -> a
}
type Rec :: [ ( Symbol, Type ) ] -> Type
type Rec = Record I
foldRec :: forall y f r. ( forall x . f x -> y -> y ) -> Record f r -> y -> y
foldRec f r = coerce $ Rec.mapM g r
where
g :: ( forall x. f x -> Const (Endo y) (I x) )
g x = coerce (f x)
instance RecordDicts kvs Semigroup
=> Semigroup (Record I kvs) where
(<>) = Rec.czipWith (Proxy @Semigroup) (<>)
instance ( RecordDicts kvs Semigroup
, RecordDicts kvs Monoid )
=> Monoid (Record I kvs) where
mempty = Rec.cpure (Proxy @Monoid) mempty
instance ( RecordDicts kvs Semigroup
, RecordDicts kvs Monoid
, RecordDicts kvs Group )
=> Group (Record I kvs) where
invert = Rec.cmap (Proxy @Group) ( \ (I g) -> I (invert g) )
instance RecordDicts 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 )
=> { myProject :: forall f. Record f r1 -> Record (f `Product` g) i
, myInject :: Record g i -> Record g r2
}
-> MyIntersection r1 g r2 c
myIntersect
:: forall c r1 g r2
. ( RecordDicts r1 c )
=> Record g r2
-> MyIntersection r1 g r2 c
myIntersect (MkR r2) =
proveRecordDicts @c @Any intersectionDict
( MyIntersection { myProject, myInject } )
where
myProject :: Record f r1 -> Record (f `Product` g) Any
myProject (MkR r1) = MkR (Map.intersectionWith Pair r1 r2)
myInject :: Record g Any -> Record g r2
myInject (MkR i) = MkR (Map.union i r2)
intersectionDict :: Record (Dict c) Any
intersectionDict =
case recordDicts @r1 @c Proxy of
MkR d -> MkR (Map.intersection d r2)
cpureM ::
(Applicative m, RecordDicts r c)
=> Proxy c
-> (forall x. c x => m (f x))
-> m (Record f r)
cpureM p f = Rec.mapM (\Dict -> f) (recordDicts p)
cmapWithKey ::
forall c r f g
. RecordDicts 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 ::
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
proveRecordDicts :: forall c r x. Record (Dict c) r -> (RecordDicts r c => x) -> x
proveRecordDicts r f = case myDict of { MyDict -> f }
where
myDict :: MyDict r c
myDict = unsafeCoerce ( MyDict' $ RecordDictsDict ( const $ unsafeCoerce r ) )
-- Dictionary passing nonsense.
newtype RecordDictsDict r c
= RecordDictsDict (Proxy c -> Record (Dict c) r)
data MyDict r c where
MyDict :: RecordDicts r c => MyDict r c
data MyDict' r c where
MyDict' :: RecordDictsDict r c -> MyDict' r c

View file

@ -8,11 +8,11 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -33,10 +33,10 @@ import Data.Foldable
( for_, sequenceA_, traverse_ )
import Data.Functor.Compose
( Compose(..) )
import Data.Functor.Product
( Product(..) )
import Data.Int
( Int32 )
import GHC.Exts
( Proxy#, proxy# )
import GHC.Generics
( Generic, Generic1 )
@ -65,16 +65,19 @@ 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 )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( Intersect )
-- transformers
import Control.Monad.Trans.Class
( lift )
@ -104,7 +107,7 @@ import Math.Vector2D
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Brush
( Brush(..), BrushAdaptedTo(..) )
( Brush(..) )
import MetaBrush.Context
( Modifier(..)
, HoldAction(..), PartialPath(..)
@ -128,10 +131,12 @@ import MetaBrush.Document.Serialise
( ) -- 'Serialisable' instances
import MetaBrush.Document.Update
( DocChange(..) )
import MetaBrush.MetaParameter.AST
( AdaptableFunction(..) )
import MetaBrush.MetaParameter.Interpolation
( MapDiff )
import MetaBrush.DSL.Interpolation
( Interpolatable, DRec )
import MetaBrush.Records
( Rec, WithParams(..)
, MyIntersection (..), myIntersect
)
import MetaBrush.UI.ToolBar
( Mode(..) )
import MetaBrush.Unique
@ -172,10 +177,10 @@ blankRender _ = pure ()
getDocumentRender
:: Colours -> FitParameters -> Mode -> Bool
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
-> Document
-> Document
-> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () )
getDocumentRender
cols fitParams mode debug
cols fitParams mode debug
modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
= do
@ -210,9 +215,9 @@ getDocumentRender
, Just finalPoint <- mbFinalPoint
, let
previewStroke :: Stroke
previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Super.Rec pointFields ) ->
previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Rec pointFields ) ->
let
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec pointFields ) )
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Rec pointFields ) )
previewSpline = catMaybesSpline ( invalidateCache undefined )
( PointData p0 Normal pointData )
( do
@ -259,7 +264,7 @@ getDocumentRender
( compositeRenders . getCompose . renderStroke cols mbHoverContext mode RenderingPath debug zoomFactor )
renderSelectionRect
Cairo.restore
strokesRenderData `deepseq` pure drawingInstructions
-- | Utility type to gather information needed to render a stroke.
@ -300,31 +305,43 @@ instance NFData StrokeRenderData where
strokeRenderData :: FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
strokeRenderData fitParams
( Stroke
{ strokeSpline = spline :: StrokeSpline clo pointParams
, strokeBrush = ( strokeBrush :: Maybe ( BrushAdaptedTo pointFields ) )
{ strokeSpline = spline :: StrokeSpline clo ( Rec pointFields )
, strokeBrush = ( strokeBrush :: Maybe ( Brush brushFields ) )
, ..
}
) | strokeVisible
= Just $ case strokeBrush of
Just ( AdaptedBrush ( brush :: Brush brushFields ) )
| ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
, let
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush
Just ( BrushData { brushFunction = fn } )
| WithParams
{ defaultParams = brush_defaults
, withParams = brushFn
} <- fn
-> do
-- Compute the outline using the brush function.
( outline, fitPts ) <-
computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
fitParams ( toUsedParams . brushParams ) brushShapeFn spline
pure $
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = brushShapeFn . toUsedParams
}
-- Use the handy 'intersect' function to do a computation
-- using only the relevant fields (which are the intersection
-- of the parameters along the stroke and the brush parameters).
--
-- See also MetaBrush.DSL.Eval.eval for how we interpret brush code
-- to obtain a brush function.
case myIntersect @Interpolatable @pointFields brush_defaults of
MyIntersection
{ myProject = project :: forall f. Record f pointFields -> Record (f `Product` I) usedFields
, myInject } -> do
let
toUsedParams :: Rec pointFields -> Rec usedFields
toUsedParams given = Rec.map ( \ (Pair x _ ) -> x ) $ project @I given
embedUsedParams :: Rec usedFields -> Rec brushFields
embedUsedParams = myInject
-- Compute the outline using the brush function.
( outline, fitPts ) <-
computeStrokeOutline @( DRec usedFields ) @clo @( Rec usedFields )
fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline
pure $
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = brushFn . embedUsedParams . toUsedParams
}
_ -> pure $
StrokeRenderData
{ strokeDataSpline = spline }
@ -332,7 +349,7 @@ strokeRenderData fitParams
= Nothing
renderStroke
:: Colours -> Maybe HoverContext -> Mode -> RenderMode -> Bool -> Double
:: Colours -> Maybe HoverContext -> Mode -> RenderMode -> Bool -> Double
-> StrokeRenderData
-> Compose Renders Cairo.Render ()
renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case

View file

@ -236,7 +236,7 @@ createMenuBar uiElts@( UIElements { application, window, titleBar } ) vars colou
menuBar <- GTK.popoverMenuBarNewFromModel ( Just menu )
widgetAddClasses menuBar [ "menu", "text", "plain" ]
GTK.headerBarPackStart titleBar menuBar
-- TODO: this is a bit of a workaround to add hover highlight to top-level menu items.
-- Activating a menu somehow sets the "hover" setting,
-- so instead we use the "selected" setting for actual hover highlighting.

View file

@ -178,7 +178,8 @@ coords = view typed
computeStrokeOutline ::
forall diffParams ( clo :: SplineType ) brushParams crvData ptData s
. ( KnownSplineType clo
, Group diffParams, Module Double diffParams
, Group diffParams
, Module Double diffParams
, Torsor diffParams brushParams
, HasType ( Point2D Double ) ptData
, HasType ( CachedStroke s ) crvData
@ -443,7 +444,7 @@ outlineFunctions ptParams brushFn sp0 crv =
p0 = coords sp0
brush :: Double -> SplinePts Closed
f :: Double -> Point2D Double
f' :: Double -> Vector2D Double
f' :: Double -> Vector2D Double
( brush, f, f' ) = case crv of
LineTo { curveEnd = NextPoint sp1 }
| let