hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

WIP: large-anon & cleanups

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

38
MetaBrush.cabal
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

6
cabal.project
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

29
src/app/MetaBrush/Application.hs
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

19
src/app/MetaBrush/Asset/Brushes.hs
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 )

357
src/app/MetaBrush/Brush.hs
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

356
src/app/MetaBrush/MetaParameter/AST.hs → src/app/MetaBrush/DSL/AST.hs
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

25
src/app/MetaBrush/MetaParameter/Driver.hs → src/app/MetaBrush/DSL/Driver.hs
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

114
src/app/MetaBrush/MetaParameter/Eval.hs → src/app/MetaBrush/DSL/Eval.hs
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

104
src/app/MetaBrush/DSL/Interpolation.hs Normal file
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

6
src/app/MetaBrush/MetaParameter/Parse.hs → src/app/MetaBrush/DSL/Parse.hs
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

2
src/app/MetaBrush/MetaParameter/PrimOp.hs → src/app/MetaBrush/DSL/PrimOp.hs
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

6
src/app/MetaBrush/MetaParameter/Rename.hs → src/app/MetaBrush/DSL/Rename.hs
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)

152
src/app/MetaBrush/MetaParameter/TypeCheck.hs → src/app/MetaBrush/DSL/TypeCheck.hs
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.

225
src/app/MetaBrush/DSL/Types.hs Normal file
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#

35
src/app/MetaBrush/Document.hs
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

54
src/app/MetaBrush/Document/Draw.hs
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

2
src/app/MetaBrush/Document/Selection.hs
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 )

130
src/app/MetaBrush/Document/Serialise.hs
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

28
src/app/MetaBrush/Document/Serialise.hs-boot
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

2
src/app/MetaBrush/Document/SubdivideStroke.hs
View file

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

142
src/app/MetaBrush/MetaParameter/Interpolation.hs
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

192
src/app/MetaBrush/Records.hs Normal file
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

97
src/app/MetaBrush/Render/Document.hs
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

2
src/app/MetaBrush/UI/Menu.hs
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.

5
src/lib/Math/Bezier/Stroke.hs
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