mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
Refactor module hierarchy, use internal records
This commit is contained in:
sheaf
parent
8333f69dc2
commit
64e45f126b
173
MetaBrush.cabal
173
MetaBrush.cabal
|
|
@ -36,15 +36,15 @@ 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
|
||||
>= 0.8.0.0 && < 0.10
|
||||
, generic-lens
|
||||
>= 1.2.0.1 && < 2.0
|
||||
>= 2.2 && < 2.3
|
||||
, groups
|
||||
>= 0.4.1.0 && < 0.6
|
||||
^>= 0.5.3
|
||||
, groups-generic
|
||||
^>= 0.2
|
||||
, primitive
|
||||
^>= 0.7.1.0
|
||||
, transformers
|
||||
|
|
@ -61,8 +61,6 @@ common common
|
|||
-fspecialise-aggressively
|
||||
-optc-O3
|
||||
-optc-ffast-math
|
||||
-- work around a laziness bug involving runRW# in GHC 9.0.1
|
||||
-fno-full-laziness
|
||||
-Wall
|
||||
-Wcompat
|
||||
-fwarn-missing-local-signatures
|
||||
|
|
@ -70,15 +68,59 @@ common common
|
|||
-fwarn-incomplete-uni-patterns
|
||||
-fwarn-missing-deriving-strategies
|
||||
-fno-warn-unticked-promoted-constructors
|
||||
-fno-show-valid-hole-fits
|
||||
|
||||
library
|
||||
common extras
|
||||
|
||||
build-depends:
|
||||
hashable
|
||||
>= 1.3.0.0 && < 1.5
|
||||
, lens
|
||||
>= 4.19.2 && < 5.2
|
||||
, mtl
|
||||
^>= 2.2.2
|
||||
, scientific
|
||||
^>= 0.3.6.2
|
||||
, stm
|
||||
^>= 2.5.0.0
|
||||
, text
|
||||
>= 1.2.3.1 && < 2.1
|
||||
, unordered-containers
|
||||
>= 0.2.11 && < 0.2.16
|
||||
, waargonaut
|
||||
^>= 0.8.0.2
|
||||
|
||||
common gtk
|
||||
|
||||
build-depends:
|
||||
gi-cairo-render
|
||||
^>= 0.1.0
|
||||
, gi-cairo-connector
|
||||
^>= 0.1.0
|
||||
, gi-gdk
|
||||
>= 4.0.2 && < 4.1
|
||||
, gi-gio
|
||||
>= 2.0.27 && < 2.1
|
||||
, gi-glib
|
||||
>= 2.0.23 && < 2.1
|
||||
, gi-gobject
|
||||
^>= 2.0.24
|
||||
, gi-gtk
|
||||
>= 4.0.3 && < 4.1
|
||||
--, gi-gtksource
|
||||
-- >= 3.0.23 && < 3.1
|
||||
, haskell-gi
|
||||
>= 0.25 && < 0.26
|
||||
, haskell-gi-base
|
||||
>= 0.25 && < 0.26
|
||||
|
||||
|
||||
library splines
|
||||
|
||||
import:
|
||||
common
|
||||
|
||||
hs-source-dirs:
|
||||
src/lib
|
||||
src/splines
|
||||
|
||||
exposed-modules:
|
||||
Math.Bezier.Cubic
|
||||
|
|
@ -97,8 +139,6 @@ library
|
|||
build-depends:
|
||||
bifunctors
|
||||
>= 5.5.4 && < 5.6
|
||||
, groups-generic
|
||||
>= 0.1.0.0 && < 0.3
|
||||
, hmatrix
|
||||
^>= 0.20.0.0
|
||||
, parallel
|
||||
|
|
@ -108,14 +148,53 @@ library
|
|||
, vector
|
||||
>= 0.12.1.2 && < 0.13
|
||||
|
||||
library metabrushes
|
||||
|
||||
import:
|
||||
common, extras
|
||||
|
||||
hs-source-dirs:
|
||||
src/metabrushes
|
||||
|
||||
exposed-modules:
|
||||
MetaBrush.Assert
|
||||
, MetaBrush.Brush
|
||||
, MetaBrush.DSL.AST
|
||||
, MetaBrush.DSL.Driver
|
||||
, MetaBrush.DSL.Eval
|
||||
, MetaBrush.DSL.Interpolation
|
||||
, MetaBrush.DSL.Parse
|
||||
, MetaBrush.DSL.PrimOp
|
||||
, MetaBrush.DSL.Rename
|
||||
, MetaBrush.DSL.TypeCheck
|
||||
, MetaBrush.DSL.Types
|
||||
, MetaBrush.Records
|
||||
, MetaBrush.Serialisable
|
||||
, MetaBrush.Unique
|
||||
, MetaBrush.Util
|
||||
|
||||
if flag(asserts)
|
||||
cpp-options:
|
||||
-DASSERTS
|
||||
|
||||
build-depends:
|
||||
splines
|
||||
, dlist
|
||||
^>= 1.0
|
||||
, Earley
|
||||
^>= 0.13.0.1
|
||||
, tree-view
|
||||
^>= 0.5
|
||||
|
||||
|
||||
executable MetaBrush
|
||||
|
||||
import:
|
||||
common
|
||||
common, extras, gtk
|
||||
|
||||
hs-source-dirs:
|
||||
src/app
|
||||
, app
|
||||
src/app,
|
||||
app
|
||||
|
||||
main-is:
|
||||
Main.hs
|
||||
|
|
@ -132,8 +211,6 @@ executable MetaBrush
|
|||
, MetaBrush.Asset.TickBox
|
||||
, MetaBrush.Asset.Tools
|
||||
, MetaBrush.Asset.WindowIcons
|
||||
, MetaBrush.Assert
|
||||
, MetaBrush.Brush
|
||||
, MetaBrush.Context
|
||||
, MetaBrush.Document
|
||||
, MetaBrush.Document.Draw
|
||||
|
|
@ -143,17 +220,9 @@ 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.GTK.Util
|
||||
, MetaBrush.Render.Document
|
||||
, MetaBrush.Render.Rulers
|
||||
, MetaBrush.Time
|
||||
, MetaBrush.UI.Coordinates
|
||||
, MetaBrush.UI.FileBar
|
||||
, MetaBrush.UI.InfoBar
|
||||
|
|
@ -161,8 +230,7 @@ executable MetaBrush
|
|||
, MetaBrush.UI.Panels
|
||||
, MetaBrush.UI.ToolBar
|
||||
, MetaBrush.UI.Viewport
|
||||
, MetaBrush.Unique
|
||||
, MetaBrush.Util
|
||||
, MetaBrush.Time
|
||||
, Paths_MetaBrush
|
||||
|
||||
autogen-modules:
|
||||
|
|
@ -176,60 +244,15 @@ executable MetaBrush
|
|||
-DASSERTS
|
||||
|
||||
build-depends:
|
||||
MetaBrush
|
||||
splines
|
||||
, metabrushes
|
||||
, atomic-file-ops
|
||||
^>= 0.3.0.0
|
||||
, bytestring
|
||||
>= 0.10.10.0 && < 0.12
|
||||
, directory
|
||||
>= 1.3.4.0 && < 1.4
|
||||
, dlist
|
||||
^>= 1.0
|
||||
, Earley
|
||||
^>= 0.13.0.1
|
||||
, filepath
|
||||
^>= 1.4.2.1
|
||||
, ghc-typelits-knownnat
|
||||
>= 0.7.3 && < 0.8
|
||||
, gi-cairo-render
|
||||
^>= 0.1.0
|
||||
, gi-cairo-connector
|
||||
^>= 0.1.0
|
||||
, gi-gdk
|
||||
>= 4.0.2 && < 4.1
|
||||
, gi-gio
|
||||
>= 2.0.27 && < 2.1
|
||||
, gi-glib
|
||||
>= 2.0.23 && < 2.1
|
||||
, gi-gobject
|
||||
^>= 2.0.24
|
||||
, gi-gtk
|
||||
>= 4.0.3 && < 4.1
|
||||
--, gi-gtksource
|
||||
-- >= 3.0.23 && < 3.1
|
||||
, hashable
|
||||
^>= 1.3.0.0
|
||||
, haskell-gi
|
||||
>= 0.25 && < 0.26
|
||||
, haskell-gi-base
|
||||
>= 0.25 && < 0.26
|
||||
, lens
|
||||
>= 4.19.2 && < 5.1
|
||||
, mtl
|
||||
^>= 2.2.2
|
||||
, scientific
|
||||
^>= 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
|
||||
, tree-view
|
||||
^>= 0.5
|
||||
, unordered-containers
|
||||
>= 0.2.11 && < 0.2.14
|
||||
, waargonaut
|
||||
^>= 0.8.0.2
|
||||
|
|
|
|||
|
|
@ -5,7 +5,12 @@ constraints:
|
|||
|
||||
allow-newer:
|
||||
waargonaut:*,
|
||||
*:haskell-gi-base, *:haskell-gi
|
||||
*:haskell-gi-base, *:haskell-gi,
|
||||
*:base, *:template-haskell, *:text,
|
||||
ghc-typelits-natnormalise:ghc-bignum,
|
||||
integer-logarithms:ghc-bignum,
|
||||
hashable:ghc-bignum,
|
||||
lens:hashable, aeson:hashable
|
||||
|
||||
-- various fixes for 'hmatrix'
|
||||
source-repository-package
|
||||
|
|
@ -18,31 +23,9 @@ package hmatrix
|
|||
ghc-options: "-w"
|
||||
flags: +openblas
|
||||
|
||||
---- instances for CPS Writer / CPS RWST
|
||||
--source-repository-package
|
||||
-- type: git
|
||||
-- location: https://github.com/haskell/mtl
|
||||
-- tag: c8af65eb8437aebefd7f3ff1664316a0240f2157
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/haskell-gi/haskell-gi
|
||||
tag: fad0097a80b942137b7c423f6d9698fff4abeb28
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/haskell-gi/haskell-gi
|
||||
tag: fad0097a80b942137b7c423f6d9698fff4abeb28
|
||||
subdir: base
|
||||
|
||||
-- GHC 9.0 compatibility for 'generics-lens' version 1.2
|
||||
source-repository-package
|
||||
type: git
|
||||
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
|
||||
large-anon
|
||||
tag: acb837a9a4c22cea1abf552b47f9d3bf5af2fbdf
|
||||
|
|
|
|||
|
|
@ -151,7 +151,7 @@ import MetaBrush.UI.Viewport
|
|||
( Viewport(..), Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( (>=?=>), (>>?=)
|
||||
, widgetAddClass, widgetAddClasses
|
||||
)
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module MetaBrush.Application
|
||||
( runApplication )
|
||||
|
|
@ -76,12 +75,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 +100,6 @@ import MetaBrush.Asset.Colours
|
|||
( getColours )
|
||||
import MetaBrush.Asset.Logo
|
||||
( drawLogo )
|
||||
import MetaBrush.Brush
|
||||
( adaptBrush )
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..)
|
||||
|
|
@ -125,6 +116,10 @@ import MetaBrush.Document.Update
|
|||
( activeDocument, withActiveDocument )
|
||||
import MetaBrush.Event
|
||||
( handleEvents )
|
||||
import MetaBrush.Records
|
||||
( Rec, I(..) )
|
||||
import qualified MetaBrush.Records as Rec
|
||||
( empty, insert )
|
||||
import MetaBrush.Render.Document
|
||||
( blankRender, getDocumentRender )
|
||||
import MetaBrush.Render.Rulers
|
||||
|
|
@ -149,7 +144,7 @@ import MetaBrush.Unique
|
|||
, Unique, freshUnique
|
||||
, uniqueMapFromList
|
||||
)
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
( getDataDir, getDataFileName )
|
||||
|
|
@ -171,7 +166,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 +174,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 +189,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 +455,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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import qualified GI.Gtk as GTK
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -10,12 +10,12 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Minimise window icon.
|
||||
-- | Minimise window icon.
|
||||
drawMinimise :: Colours -> Cairo.Render Bool
|
||||
drawMinimise ( Colours { plain } ) = do
|
||||
|
||||
|
|
|
|||
|
|
@ -1,376 +0,0 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
|
||||
|
||||
module MetaBrush.Brush
|
||||
( Brush(..), SomeBrush(..)
|
||||
, BrushAdaptedTo(..), adaptBrush
|
||||
, SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Kind
|
||||
( Type )
|
||||
import Data.List
|
||||
( intersect )
|
||||
import Data.Proxy
|
||||
( Proxy )
|
||||
import Data.Type.Equality
|
||||
( (:~:)(Refl) )
|
||||
import GHC.Exts
|
||||
( Proxy#, proxy# )
|
||||
import GHC.TypeLits
|
||||
( KnownSymbol, SomeSymbol(..)
|
||||
, someSymbolVal, symbolVal'
|
||||
)
|
||||
import GHC.TypeNats
|
||||
( KnownNat, SomeNat(..), someNatVal, type (-) )
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce )
|
||||
|
||||
-- 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 )
|
||||
|
||||
-- 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 )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( Module )
|
||||
import Math.Vector2D
|
||||
( Point2D )
|
||||
import {-# SOURCE #-} MetaBrush.Document.Serialise
|
||||
( Serialisable, Workaround(..), workaround )
|
||||
import MetaBrush.MetaParameter.AST
|
||||
( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes
|
||||
, Adapted, BrushFunction
|
||||
, MapFields, UniqueField, UseFieldsInBrush
|
||||
)
|
||||
import MetaBrush.MetaParameter.Interpolation
|
||||
( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
whatever :: Int
|
||||
whatever = case workaround Workaround of
|
||||
Workaround -> 0
|
||||
|
||||
data Brush brushFields where
|
||||
BrushData
|
||||
:: forall brushFields
|
||||
. ( STypesI brushFields )
|
||||
=>
|
||||
{ brushName :: !Text
|
||||
, brushCode :: !Text
|
||||
, brushFunction :: !( BrushFunction brushFields )
|
||||
}
|
||||
-> Brush brushFields
|
||||
|
||||
data SomeBrush where
|
||||
SomeBrush :: !( Brush brushFields ) -> SomeBrush
|
||||
|
||||
instance Show ( Brush brushFields ) where
|
||||
show ( BrushData { brushName, brushCode } ) =
|
||||
"BrushData\n\
|
||||
\ { brushName = " <> Text.unpack brushName <> "\n\
|
||||
\ , brushCode =\n" <> Text.unpack brushCode <> "\n\
|
||||
\ }"
|
||||
instance NFData ( Brush brushFields ) where
|
||||
rnf ( BrushData { brushName, brushCode } )
|
||||
= deepseq brushCode
|
||||
$ rnf brushName
|
||||
instance Eq ( Brush brushFields ) where
|
||||
BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2
|
||||
instance Ord ( Brush brushFields ) where
|
||||
compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 )
|
||||
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 )
|
||||
=> Proxy# a -> SomeFieldSType
|
||||
|
||||
-- | Existential type for allowed fields of a brush record.
|
||||
data SomeBrushFields where
|
||||
SomeBrushFields
|
||||
:: forall kvs rec
|
||||
. ( STypesI kvs
|
||||
, rec ~ Super.Rec kvs
|
||||
, Show rec, NFData rec
|
||||
, Interpolatable rec
|
||||
, Serialisable rec
|
||||
)
|
||||
=> 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
|
||||
|
|
@ -30,7 +30,7 @@ module MetaBrush.Document
|
|||
, StrokeSpline, _strokeSpline, overStrokeSpline
|
||||
, PointData(..), BrushPointData(..), DiffPointData(..)
|
||||
, FocusState(..), Hoverable(..), HoverContext(..)
|
||||
, Guide(..)
|
||||
, Guide(..), Ruler(..)
|
||||
, _selection, _coords, coords
|
||||
, addGuide, selectedGuide
|
||||
)
|
||||
|
|
@ -84,10 +84,6 @@ import Control.Lens
|
|||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
|
@ -110,15 +106,15 @@ import Math.Module
|
|||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Brush
|
||||
( BrushAdaptedTo )
|
||||
import {-# SOURCE #-} MetaBrush.Document.Serialise
|
||||
( Brush )
|
||||
import MetaBrush.Serialisable
|
||||
( Serialisable(..) )
|
||||
import MetaBrush.MetaParameter.AST
|
||||
import MetaBrush.DSL.Types
|
||||
( STypesI(..) )
|
||||
import MetaBrush.MetaParameter.Interpolation
|
||||
( Interpolatable(..) ) -- + orphan instances
|
||||
import MetaBrush.UI.Viewport
|
||||
( Ruler(..) )
|
||||
import MetaBrush.DSL.Interpolation
|
||||
( Interpolatable(..) )
|
||||
import MetaBrush.Records
|
||||
( Rec, AllFields )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, Unique, freshUnique )
|
||||
|
||||
|
|
@ -166,7 +162,7 @@ data DocumentContent
|
|||
|
||||
-- | Hierarchy for groups of strokes.
|
||||
data StrokeHierarchy
|
||||
= StrokeGroup
|
||||
= StrokeGroup
|
||||
{ groupName :: !Text
|
||||
, groupVisible :: !Bool
|
||||
, groupContents :: !( Seq StrokeHierarchy )
|
||||
|
|
@ -194,16 +190,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
|
||||
, AllFields Interpolatable pointFields
|
||||
, Serialisable pointParams
|
||||
)
|
||||
=>
|
||||
{ strokeName :: !Text
|
||||
, strokeVisible :: !Bool
|
||||
, strokeUnique :: Unique
|
||||
, strokeBrush :: !( Maybe ( BrushAdaptedTo pointFields ) )
|
||||
, strokeBrush :: !( Maybe ( Brush brushFields ) )
|
||||
, strokeSpline :: !( StrokeSpline clo pointParams )
|
||||
}
|
||||
-> Stroke
|
||||
|
|
@ -222,8 +219,8 @@ _strokeSpline
|
|||
=> ( forall clo pointParams pointFields
|
||||
. ( KnownSplineType clo
|
||||
, Show pointParams, NFData pointParams
|
||||
, pointParams ~ Super.Rec pointFields, STypesI pointFields
|
||||
, Interpolatable pointParams
|
||||
, AllFields Interpolatable pointFields
|
||||
, pointParams ~ Rec pointFields, STypesI pointFields
|
||||
, Serialisable pointParams
|
||||
)
|
||||
=> StrokeSpline clo pointParams
|
||||
|
|
@ -237,8 +234,8 @@ overStrokeSpline
|
|||
:: ( forall clo pointParams pointFields
|
||||
. ( KnownSplineType clo
|
||||
, Show pointParams, NFData pointParams
|
||||
, pointParams ~ Super.Rec pointFields, STypesI pointFields
|
||||
, Interpolatable pointParams
|
||||
, AllFields Interpolatable pointFields
|
||||
, pointParams ~ Rec pointFields, STypesI pointFields
|
||||
, Serialisable pointParams
|
||||
)
|
||||
=> StrokeSpline clo pointParams
|
||||
|
|
@ -408,6 +405,12 @@ data Guide
|
|||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
data Ruler
|
||||
= RulerCorner
|
||||
| LeftRuler
|
||||
| TopRuler
|
||||
deriving stock Show
|
||||
|
||||
-- | Try to select a guide at the given document coordinates.
|
||||
selectedGuide :: Point2D Double -> Document -> Maybe Guide
|
||||
selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -22,7 +23,7 @@ import Data.Coerce
|
|||
import Data.Functor
|
||||
( ($>) )
|
||||
import Data.Semigroup
|
||||
( First(..) )
|
||||
( First(..) )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -45,15 +46,9 @@ 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 +74,7 @@ import Math.Vector2D
|
|||
import MetaBrush.Assert
|
||||
( assert )
|
||||
import MetaBrush.Brush
|
||||
( BrushAdaptedTo )
|
||||
( Brush(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..)
|
||||
, Stroke(..), StrokeHierarchy(..), StrokeSpline
|
||||
|
|
@ -87,12 +82,16 @@ import MetaBrush.Document
|
|||
, _selection, _strokeSpline
|
||||
, coords, overStrokeSpline
|
||||
)
|
||||
import MetaBrush.Document.Serialise
|
||||
import MetaBrush.Serialisable
|
||||
( Serialisable )
|
||||
import MetaBrush.MetaParameter.AST
|
||||
import MetaBrush.DSL.Types
|
||||
( STypesI(..) )
|
||||
import MetaBrush.MetaParameter.Interpolation
|
||||
( Interpolatable )
|
||||
import MetaBrush.DSL.Interpolation
|
||||
( Interpolatable )
|
||||
import MetaBrush.Records
|
||||
( Rec, AllFields )
|
||||
import qualified MetaBrush.Records as Rec
|
||||
( empty )
|
||||
import MetaBrush.Unique
|
||||
( Unique, UniqueSupply, freshUnique, uniqueText )
|
||||
|
||||
|
|
@ -132,9 +131,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 +143,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
|
|||
, strokeVisible = True
|
||||
, strokeUnique = uniq
|
||||
, strokeSpline = newSpline
|
||||
, strokeBrush = Nothing
|
||||
, strokeBrush = Nothing :: Maybe ( Brush '[] )
|
||||
}
|
||||
newDoc' :: Document
|
||||
newDoc'
|
||||
|
|
@ -222,8 +221,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 +234,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 +242,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 +250,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
|
||||
, AllFields Interpolatable pointFields
|
||||
)
|
||||
=> Maybe ( BrushAdaptedTo pointFields )
|
||||
=> Maybe (Brush brushFields)
|
||||
-> pointParams
|
||||
-> r
|
||||
)
|
||||
|
|
@ -284,4 +282,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
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ import Data.Semigroup
|
|||
import GHC.Exts
|
||||
( dataToTag#, (>#), (<#), isTrue# )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
( Generic, Generically(..) )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -57,10 +57,6 @@ import Data.Set
|
|||
import qualified Data.Set as Set
|
||||
( insert )
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( Generically(..) )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
|
@ -126,7 +122,7 @@ import MetaBrush.Document
|
|||
)
|
||||
import {-# SOURCE #-} MetaBrush.Document.Update
|
||||
( DocChange(..) )
|
||||
import MetaBrush.MetaParameter.Interpolation
|
||||
import MetaBrush.DSL.Interpolation
|
||||
( Interpolatable(Diff) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
|
@ -14,40 +15,22 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.Document.Serialise
|
||||
( Workaround(..), workaround
|
||||
, Serialisable(..)
|
||||
, documentToJSON, documentFromJSON
|
||||
( documentToJSON, documentFromJSON
|
||||
, saveDocument, loadDocument
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( (&&&) )
|
||||
import Control.Monad
|
||||
( unless )
|
||||
import Control.Monad.ST
|
||||
( RealWorld, stToIO )
|
||||
import qualified Data.Bifunctor as Bifunctor
|
||||
( first )
|
||||
import Data.Foldable
|
||||
( toList )
|
||||
import Data.Functor.Contravariant
|
||||
( contramap )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.STRef
|
||||
( newSTRef )
|
||||
import Data.Type.Equality
|
||||
( (:~:)(Refl) )
|
||||
import Data.Version
|
||||
( Version(versionBranch) )
|
||||
import GHC.Exts
|
||||
( Proxy#, proxy# )
|
||||
import GHC.TypeLits
|
||||
( symbolVal', KnownSymbol )
|
||||
import GHC.TypeNats
|
||||
( KnownNat )
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce ) -- Tony Morris special
|
||||
|
||||
|
|
@ -65,16 +48,6 @@ import qualified Data.ByteString.Lazy as Lazy
|
|||
import qualified Data.ByteString.Builder as Lazy.ByteString.Builder
|
||||
( toLazyByteString )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( elems, fromList )
|
||||
import Data.Sequence
|
||||
( Seq )
|
||||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
|
||||
-- directory
|
||||
import System.Directory
|
||||
( canonicalizePath, createDirectoryIfMissing, doesFileExist )
|
||||
|
|
@ -83,37 +56,14 @@ import System.Directory
|
|||
import System.FilePath
|
||||
( takeDirectory )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
|
||||
-- mtl
|
||||
import Control.Monad.Except
|
||||
( MonadError(throwError) )
|
||||
|
||||
-- scientific
|
||||
import qualified Data.Scientific as Scientific
|
||||
( fromFloatDigits, toRealFloat )
|
||||
|
||||
-- stm
|
||||
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 )
|
||||
|
|
@ -136,12 +86,12 @@ import qualified Waargonaut.Decode as JSON
|
|||
import qualified Waargonaut.Decode.Error as JSON
|
||||
( DecodeError(ParseFailed) )
|
||||
import qualified Waargonaut.Decode as JSON.Decoder
|
||||
( atKey, atKeyOptional, bool, list, objectAsKeyValues, scientific, text )
|
||||
( atKey, atKeyOptional, bool, objectAsKeyValues, text )
|
||||
import qualified Waargonaut.Encode as JSON
|
||||
( Encoder )
|
||||
import qualified Waargonaut.Encode as JSON.Encoder
|
||||
( runEncoder, runPureEncoder
|
||||
, atKey', bool, int, json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
|
||||
( runEncoder
|
||||
, atKey', bool, int, keyValueTupleFoldable, list, mapLikeObj, text
|
||||
)
|
||||
import qualified Waargonaut.Encode.Builder as JSON.Builder
|
||||
( waargonautBuilder, bsBuilder )
|
||||
|
|
@ -162,49 +112,49 @@ import Waargonaut.Types.Json
|
|||
import qualified Waargonaut.Types.Whitespace as JSON
|
||||
( WS )
|
||||
|
||||
-- MetaBrush
|
||||
-- metabrushes
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier )
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..)
|
||||
, Curves(..), Curve(..), NextPoint(..)
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..) )
|
||||
( SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..) )
|
||||
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.Serialisable
|
||||
( Serialisable(..)
|
||||
, encodeSequence, decodeSequence
|
||||
, encodeUniqueMap, decodeUniqueMap
|
||||
, encodeSpline, decodeSpline
|
||||
)
|
||||
import MetaBrush.Records
|
||||
( Rec, WithParams )
|
||||
import MetaBrush.Unique
|
||||
( Unique, UniqueSupply, freshUnique )
|
||||
( UniqueSupply, freshUnique )
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
( version )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | 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
|
||||
|
|
@ -256,200 +206,6 @@ loadDocument uniqueSupply fp = do
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
class Serialisable a where
|
||||
encoder :: Monad f => JSON.Encoder f a
|
||||
decoder :: Monad m => JSON.Decoder m a
|
||||
|
||||
instance Serialisable Double where
|
||||
encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
|
||||
decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific
|
||||
|
||||
instance Serialisable a => Serialisable ( Point2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
instance Serialisable a => Serialisable ( Vector2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. 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 )
|
||||
|
||||
decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds )
|
||||
decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{-
|
||||
encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
|
||||
encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
|
||||
JSON.Encoder.atKey' "m00" enc m00
|
||||
. JSON.Encoder.atKey' "m01" enc m01
|
||||
. JSON.Encoder.atKey' "m10" enc m10
|
||||
. JSON.Encoder.atKey' "m11" enc m11
|
||||
|
||||
decodeMat22 :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Mat22 a )
|
||||
decodeMat22 dec =
|
||||
Mat22 <$> JSON.Decoder.atKey "m00" dec
|
||||
<*> JSON.Decoder.atKey "m01" dec
|
||||
<*> JSON.Decoder.atKey "m10" dec
|
||||
<*> JSON.Decoder.atKey "m11" dec
|
||||
|
||||
|
||||
|
||||
encodeAABB :: Applicative f => JSON.Encoder f AABB
|
||||
encodeAABB = JSON.Encoder.mapLikeObj \ ( AABB { topLeft, botRight } ) ->
|
||||
JSON.Encoder.atKey' "topLeft" enc topLeft
|
||||
. JSON.Encoder.atKey' "botRight" enc botRight
|
||||
where
|
||||
enc :: JSON.Encoder' ( Point2D Double )
|
||||
enc = encodePoint2D encodeDouble
|
||||
|
||||
decodeAABB :: forall m. Monad m => JSON.Decoder m AABB
|
||||
decodeAABB = do
|
||||
topLeft <- JSON.Decoder.atKey "topLeft" dec
|
||||
botRight <- JSON.Decoder.atKey "botRight" dec
|
||||
pure ( AABB { topLeft, botRight } )
|
||||
where
|
||||
dec :: JSON.Decoder m ( Point2D Double )
|
||||
dec = decodePoint2D decodeDouble
|
||||
-}
|
||||
|
||||
|
||||
encodeCurve
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Curve clo crvData ptData )
|
||||
encodeCurve encodePtData = case ssplineType @clo of
|
||||
SOpen -> JSON.Encoder.mapLikeObj \case
|
||||
LineTo ( NextPoint p1 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
Bezier2To p1 ( NextPoint p2 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
Bezier3To p1 p2 ( NextPoint p3 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
. JSON.Encoder.atKey' "p3" encodePtData p3
|
||||
SClosed -> JSON.Encoder.mapLikeObj \case
|
||||
LineTo BackToStart _ -> id
|
||||
Bezier2To p1 BackToStart _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
Bezier3To p1 p2 BackToStart _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
|
||||
decodeCurve
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeCurve decodePtData = do
|
||||
noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
|
||||
case ssplineType @clo of
|
||||
SOpen -> do
|
||||
p1 <- JSON.Decoder.atKey "p1" decodePtData
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing ->
|
||||
pure ( LineTo ( NextPoint p1 ) noCache )
|
||||
Just p2 -> do
|
||||
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
|
||||
case mb_p3 of
|
||||
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) noCache )
|
||||
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
|
||||
SClosed -> do
|
||||
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
|
||||
case mb_p1 of
|
||||
Nothing ->
|
||||
pure ( LineTo BackToStart noCache )
|
||||
Just p1 -> do
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing -> pure ( Bezier2To p1 BackToStart noCache )
|
||||
Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
|
||||
|
||||
|
||||
|
||||
encodeCurves
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Curves clo crvData ptData )
|
||||
encodeCurves encodePtData = case ssplineType @clo of
|
||||
SOpen -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData )
|
||||
SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR )
|
||||
where
|
||||
encodeL :: JSON.Encoder f ()
|
||||
encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text
|
||||
encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData )
|
||||
encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) ->
|
||||
JSON.Encoder.atKey' "prevOpenCurves" ( encodeSequence $ encodeCurve @Open encodePtData ) openCurves
|
||||
. JSON.Encoder.atKey' "lastClosedCurve" ( encodeCurve @Closed encodePtData ) closedCurve
|
||||
|
||||
decodeCurves
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curves clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeCurves decodePtData = case ssplineType @clo of
|
||||
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
|
||||
SClosed -> do
|
||||
mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
|
||||
case mbNoCurves of
|
||||
Just _ -> pure NoCurves
|
||||
Nothing -> do
|
||||
prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData )
|
||||
lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData )
|
||||
pure ( ClosedCurves prevCurves lastCurve )
|
||||
|
||||
|
||||
|
||||
encodeSpline
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Spline clo crvData ptData )
|
||||
encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) ->
|
||||
JSON.Encoder.atKey' "splineStart" encodePtData splineStart
|
||||
. JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
|
||||
|
||||
decodeSpline
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeSpline decodePtData = do
|
||||
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
|
||||
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
|
||||
pure ( Spline { splineStart, splineCurves } )
|
||||
|
||||
|
||||
{-
|
||||
encodeFocusState :: Applicative f => JSON.Encoder f FocusState
|
||||
encodeFocusState = contramap focusText JSON.Encoder.text
|
||||
|
|
@ -479,38 +235,24 @@ decodeBrushPointData = do
|
|||
-}
|
||||
|
||||
|
||||
encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
|
||||
encodeSequence enc = contramap toList ( JSON.Encoder.list enc )
|
||||
|
||||
decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a )
|
||||
decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
|
||||
|
||||
|
||||
|
||||
encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
|
||||
encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
|
||||
|
||||
decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
|
||||
decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
|
||||
|
||||
|
||||
|
||||
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,41 +260,41 @@ 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 } )
|
||||
|
||||
|
||||
|
||||
encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
|
||||
encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) ->
|
||||
encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType @ty ) ->
|
||||
case sTypeI @ty of
|
||||
sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun"
|
||||
. JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# b ) )
|
||||
. JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType @a )
|
||||
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType @b )
|
||||
STyBool
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bool"
|
||||
STyDouble
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
|
||||
sTyPoint@STyPoint | ( _ :: SType ( Point2D a ) ) <- sTyPoint
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "point"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType @a )
|
||||
sTyLine@STyLine | ( _ :: SType ( Segment a ) ) <- sTyLine
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "line"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType @a )
|
||||
sTyBez2@STyBez2 | ( _ :: SType ( Quadratic.Bezier a ) ) <- sTyBez2
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez2"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType @a )
|
||||
sTyBez3@STyBez3 | ( _ :: SType ( Cubic.Bezier a ) ) <- sTyBez3
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez3"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType @a)
|
||||
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 ) )
|
||||
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType @res )
|
||||
|
||||
{-
|
||||
decodeSomeSType :: Monad m => JSON.Decoder m SomeSType
|
||||
|
|
@ -560,32 +302,32 @@ decodeSomeSType = do
|
|||
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
|
||||
case tag of
|
||||
"fun" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "arg" decodeSomeSType
|
||||
( SomeSType ( _ :: Proxy# b ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( a -> b ) ) )
|
||||
"bool" -> pure ( SomeSType ( proxy# :: Proxy# Bool ) )
|
||||
"double" -> pure ( SomeSType ( proxy# :: Proxy# Double ) )
|
||||
( SomeSType @a ) <- JSON.Decoder.atKey "arg" decodeSomeSType
|
||||
( SomeSType @b ) <- JSON.Decoder.atKey "res" decodeSomeSType
|
||||
pure ( SomeSType @(a -> b) )
|
||||
"bool" -> pure ( SomeSType @Bool )
|
||||
"double" -> pure ( SomeSType @ Double )
|
||||
"point" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Point2D a ) ) )
|
||||
( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType @( Point2D a ) )
|
||||
"line" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Segment a ) ) )
|
||||
( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType @( Segment a ) )
|
||||
"bez2" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Quadratic.Bezier a ) ) )
|
||||
( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType @( Quadratic.Bezier a ) )
|
||||
"bez3" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Cubic.Bezier a ) ) )
|
||||
( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType @( Cubic.Bezier a ) )
|
||||
"spline" -> do
|
||||
closed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
|
||||
case closed of
|
||||
True -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Closed ) ) )
|
||||
False -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Open ) ) )
|
||||
True -> pure ( SomeSType @( SplinePts Closed ) )
|
||||
False -> pure ( SomeSType @( SplinePts Open ) )
|
||||
"adaptableFun" -> do
|
||||
( SomeBrushFields ( _ :: Proxy# kvs ) ) <- JSON.Decoder.atKey "fields" decodeFieldTypes
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( AdaptableFunction kvs a ) ) )
|
||||
( SomeBrushFields @kvs ) <- JSON.Decoder.atKey "fields" decodeFieldTypes
|
||||
( SomeSType @a ) <- JSON.Decoder.atKey "res" decodeSomeSType
|
||||
pure ( SomeSType @( AdaptableFunction kvs a ) )
|
||||
_ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
|
||||
-}
|
||||
|
||||
|
|
@ -593,11 +335,11 @@ decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType
|
|||
decodeSomeFieldSType = do
|
||||
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
|
||||
case tag of
|
||||
"double" -> pure ( SomeFieldSType ( proxy# :: Proxy# Double ) )
|
||||
"double" -> pure ( SomeFieldSType @Double )
|
||||
"point" -> do
|
||||
( SomeFieldSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
|
||||
SomeFieldSType @a <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
|
||||
case eqTy @a @Double of
|
||||
Just Refl -> pure ( SomeFieldSType ( proxy# :: Proxy# ( Point2D Double ) ) )
|
||||
Just Refl -> pure ( SomeFieldSType @( Point2D Double ) )
|
||||
Nothing -> throwError ( JSON.ParseFailed "Point2D: non-Double coordinate type" )
|
||||
_ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
|
||||
|
||||
|
|
@ -626,7 +368,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 +391,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
|
|||
\ ( Stroke
|
||||
{ strokeName
|
||||
, strokeVisible
|
||||
, strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
|
||||
, strokeSpline = strokeSpline :: StrokeSpline clo ( Rec pointFields )
|
||||
, strokeBrush
|
||||
}
|
||||
) ->
|
||||
|
|
@ -662,7 +404,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
|
||||
|
|
@ -678,23 +420,23 @@ decodeStroke uniqueSupply = do
|
|||
strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
|
||||
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
|
||||
SomeBrushFields @pointFields <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,50 +0,0 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.Document.Serialise
|
||||
( Workaround(..), workaround, Serialisable(..) )
|
||||
where
|
||||
|
||||
-- base
|
||||
import GHC.TypeNats
|
||||
( KnownNat )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( RecApply, RecSize, UnsafeRecBuild )
|
||||
import SuperRecord
|
||||
( ConstC )
|
||||
|
||||
-- waargonaut
|
||||
import qualified Waargonaut.Decode as JSON
|
||||
( Decoder )
|
||||
import qualified Waargonaut.Encode as JSON
|
||||
( Encoder )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D, 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
|
||||
|
||||
instance Serialisable Double
|
||||
|
||||
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 )
|
||||
|
|
@ -64,7 +64,7 @@ import MetaBrush.Document
|
|||
, PointData(..), DiffPointData(..)
|
||||
, coords, _strokeSpline
|
||||
)
|
||||
import MetaBrush.MetaParameter.Interpolation
|
||||
import MetaBrush.DSL.Interpolation
|
||||
( Interpolatable(Diff) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
|||
( updateInfoBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( (>>?=) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -167,8 +167,8 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables
|
|||
coerce ( updateUIAction uiElts vars )
|
||||
SaveDocument ( Just newFilePath ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust
|
||||
( affirmPresent
|
||||
( Map.adjust
|
||||
( affirmPresent
|
||||
. set ( field' @"present" . field' @"mbFilePath" )
|
||||
( Just newFilePath )
|
||||
)
|
||||
|
|
|
|||
|
|
@ -6,12 +6,10 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Util
|
||||
module MetaBrush.GTK.Util
|
||||
( withRGBA, showRGBA
|
||||
, widgetAddClasses, widgetAddClass
|
||||
, (>=?=>), (>>?=)
|
||||
, traverseMaybe
|
||||
, Exists(..)
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -25,10 +23,6 @@ import Data.Foldable
|
|||
import GHC.Stack
|
||||
( HasCallStack )
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
|
|
@ -76,14 +70,3 @@ infixr 1 >=?=>
|
|||
infixl 1 >>?=
|
||||
(>>?=) :: forall m a b. Monad m => m ( Maybe a ) -> ( a -> m ( Maybe b ) ) -> m ( Maybe b )
|
||||
(>>?=) = coerce ( (>>=) @( MaybeT m ) @a @b )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
traverseMaybe :: Applicative f => ( a -> f ( Maybe b ) ) -> Seq a -> f ( Seq b )
|
||||
traverseMaybe _ Empty = pure Empty
|
||||
traverseMaybe f ( a :<| as ) = ( \ case { Nothing -> id; Just b -> ( b :<| ) } ) <$> f a <*> traverseMaybe f as
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Exists c where
|
||||
Exists :: c a => a -> Exists c
|
||||
|
|
@ -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
|
||||
|
|
@ -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 #-}
|
||||
|
|
@ -35,10 +35,8 @@ import Data.Functor.Compose
|
|||
( Compose(..) )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import GHC.Exts
|
||||
( Proxy#, proxy# )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1 )
|
||||
( Generic, Generic1, Generically1(..) )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -58,10 +56,6 @@ import Data.Set
|
|||
import Control.DeepSeq
|
||||
( NFData(..), deepseq )
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( Generically1(..) )
|
||||
|
||||
-- gi-cairo-render
|
||||
import qualified GI.Cairo.Render as Cairo
|
||||
|
||||
|
|
@ -69,12 +63,6 @@ import qualified GI.Cairo.Render as Cairo
|
|||
import Control.Lens
|
||||
( view )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( Intersect )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Class
|
||||
( lift )
|
||||
|
|
@ -104,7 +92,7 @@ import Math.Vector2D
|
|||
import MetaBrush.Asset.Colours
|
||||
( Colours, ColourRecord(..) )
|
||||
import MetaBrush.Brush
|
||||
( Brush(..), BrushAdaptedTo(..) )
|
||||
( Brush(..) )
|
||||
import MetaBrush.Context
|
||||
( Modifier(..)
|
||||
, HoldAction(..), PartialPath(..)
|
||||
|
|
@ -128,16 +116,23 @@ 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
|
||||
( Record, Rec, WithParams(..)
|
||||
, I(..), (:*:)(..)
|
||||
, MyIntersection (..), myIntersect
|
||||
)
|
||||
import qualified MetaBrush.Records as Rec
|
||||
( map )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Mode(..) )
|
||||
import MetaBrush.Unique
|
||||
( unsafeUnique )
|
||||
import MetaBrush.Util
|
||||
( traverseMaybe, withRGBA )
|
||||
( traverseMaybe )
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -172,10 +167,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 +205,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 +254,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 +295,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 :*: I) usedFields
|
||||
, myInject } -> do
|
||||
let
|
||||
toUsedParams :: Rec pointFields -> Rec usedFields
|
||||
toUsedParams given = Rec.map ( \ (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 +339,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
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ import MetaBrush.UI.Viewport
|
|||
( Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
( unsafeUnique )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ import MetaBrush.UI.Viewport
|
|||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique, freshUnique, uniqueText )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
module MetaBrush.UI.FileBar
|
||||
( FileBar(..), FileBarTab(..), TabLocation(..)
|
||||
, removeFileTab
|
||||
, newFileTab, removeFileTab
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -10,6 +10,8 @@ import qualified GI.Gtk as GTK
|
|||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
( Variables, UIElements )
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
|
@ -35,4 +37,5 @@ data TabLocation
|
|||
|
||||
instance Show TabLocation
|
||||
|
||||
newFileTab :: UIElements -> Variables -> Maybe DocumentHistory -> TabLocation -> IO ()
|
||||
removeFileTab :: UIElements -> Variables -> Unique -> IO ()
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ import MetaBrush.Document
|
|||
( Document(..) )
|
||||
import MetaBrush.UI.Coordinates
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ import MetaBrush.Asset.WindowIcons
|
|||
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
||||
import MetaBrush.UI.FileBar
|
||||
( TabLocation(..) )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -15,15 +15,15 @@ import Data.Foldable
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Creates the right hand side panel UI.
|
||||
createPanelBar :: GTK.Box -> IO ()
|
||||
createPanelBar panelBox = do
|
||||
|
||||
createPanelBar panelBox = do
|
||||
|
||||
widgetAddClass panelBox "panels"
|
||||
|
||||
pane1 <- GTK.panedNew GTK.OrientationVertical
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ import MetaBrush.Asset.Tools
|
|||
( drawBug, drawBrush, drawMeta, drawPath, drawPen )
|
||||
import MetaBrush.Context
|
||||
( Variables(..) )
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -18,8 +18,10 @@ import Data.Foldable
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Util
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import MetaBrush.Document
|
||||
( Ruler(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -46,9 +48,9 @@ data Viewport
|
|||
|
||||
createViewport :: GTK.Grid -> IO Viewport
|
||||
createViewport viewportGrid = do
|
||||
|
||||
|
||||
widgetAddClass viewportGrid "viewport"
|
||||
|
||||
|
||||
rvRulerCorner <- GTK.revealerNew
|
||||
rvLeftRuler <- GTK.revealerNew
|
||||
rvTopRuler <- GTK.revealerNew
|
||||
|
|
@ -87,7 +89,7 @@ createViewport viewportGrid = do
|
|||
|
||||
leftRulerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxAppend leftRuler leftRulerDrawingArea
|
||||
|
||||
|
||||
topRulerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxAppend topRuler topRulerDrawingArea
|
||||
|
||||
|
|
@ -167,11 +169,3 @@ createViewport viewportGrid = do
|
|||
-}
|
||||
|
||||
pure ( Viewport {..} )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Ruler
|
||||
= RulerCorner
|
||||
| LeftRuler
|
||||
| TopRuler
|
||||
deriving stock Show
|
||||
|
|
|
|||
167
src/metabrushes/MetaBrush/Brush.hs
Normal file
167
src/metabrushes/MetaBrush/Brush.hs
Normal file
|
|
@ -0,0 +1,167 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QuantifiedConstraints#-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module MetaBrush.Brush
|
||||
( Brush(..), SomeBrush(..)
|
||||
, BrushFunction
|
||||
, SomeFieldSType(..), SomeBrushFields(..)
|
||||
, reflectBrushFieldsNoDups
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( second )
|
||||
import GHC.Exts
|
||||
( Proxy#, Any )
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..), deepseq )
|
||||
|
||||
-- hashable
|
||||
import Data.Hashable
|
||||
( Hashable(..) )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( unpack )
|
||||
|
||||
-- unordered-containers
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
( fromList )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
( SplineType(Closed), SplinePts)
|
||||
import MetaBrush.Serialisable
|
||||
( Serialisable )
|
||||
import MetaBrush.DSL.Types
|
||||
( STypeI, STypesI(sTypesI)
|
||||
, SomeSType(..), proveSomeSTypes
|
||||
)
|
||||
import MetaBrush.DSL.Interpolation
|
||||
( Interpolatable(..) )
|
||||
import MetaBrush.Records
|
||||
( Record(MkR), Rec, AllFields
|
||||
, WithParams(..)
|
||||
, Dict(..)
|
||||
, proveRecordDicts
|
||||
)
|
||||
import qualified MetaBrush.Records as Rec
|
||||
( map )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type BrushFunction brushFields = WithParams brushFields (SplinePts Closed)
|
||||
|
||||
data Brush brushFields where
|
||||
BrushData
|
||||
:: forall brushFields
|
||||
. ( STypesI brushFields )
|
||||
=>
|
||||
{ brushName :: !Text
|
||||
, brushCode :: !Text
|
||||
, brushFunction :: BrushFunction brushFields
|
||||
}
|
||||
-> Brush brushFields
|
||||
|
||||
data SomeBrush where
|
||||
SomeBrush
|
||||
:: STypesI brushFields
|
||||
=> { someBrush :: !( Brush brushFields ) }
|
||||
-> SomeBrush
|
||||
|
||||
instance Show ( Brush brushFields ) where
|
||||
show ( BrushData { brushName, brushCode } ) =
|
||||
"BrushData\n\
|
||||
\ { brushName = " <> Text.unpack brushName <> "\n\
|
||||
\ , brushCode =\n" <> Text.unpack brushCode <> "\n\
|
||||
\ }"
|
||||
instance NFData ( Brush brushFields ) where
|
||||
rnf ( BrushData { brushName, brushCode } )
|
||||
= deepseq brushCode
|
||||
$ rnf brushName
|
||||
instance Eq ( Brush brushFields ) where
|
||||
BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2
|
||||
instance Ord ( Brush brushFields ) where
|
||||
compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 )
|
||||
instance Hashable ( Brush brushFields ) where
|
||||
hashWithSalt salt ( BrushData { brushName, brushCode } ) =
|
||||
hashWithSalt ( hashWithSalt salt brushName ) brushCode
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Instance dictionary passing machinery.
|
||||
|
||||
-- | 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, Interpolatable a, Serialisable a )
|
||||
=> SomeFieldSType
|
||||
|
||||
data FieldSType a where
|
||||
FieldSType
|
||||
:: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a )
|
||||
=> FieldSType a
|
||||
|
||||
-- | Existential type for allowed fields of a brush record.
|
||||
data SomeBrushFields where
|
||||
SomeBrushFields
|
||||
:: forall kvs rec
|
||||
. ( STypesI kvs
|
||||
, rec ~ Rec kvs
|
||||
, Show rec, NFData rec
|
||||
, Serialisable rec
|
||||
, AllFields Interpolatable kvs
|
||||
)
|
||||
=> SomeBrushFields
|
||||
|
||||
instance Show SomeBrushFields where
|
||||
show ( SomeBrushFields @kvs ) = show ( sTypesI @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 elts =
|
||||
let
|
||||
mkSomeSType :: SomeFieldSType -> SomeSType
|
||||
mkSomeSType (SomeFieldSType @a) = SomeSType @a
|
||||
mkField :: SomeFieldSType -> FieldSType Any
|
||||
mkField (SomeFieldSType @a) = unsafeCoerce $ FieldSType @a
|
||||
in
|
||||
proveSomeSTypes (map (second mkSomeSType) elts) \ ( _ :: Proxy# kvs ) ->
|
||||
let
|
||||
dictsRec :: Record FieldSType kvs
|
||||
dictsRec = MkR (HashMap.fromList $ map (second mkField) elts)
|
||||
showDicts :: Record (Dict Show) kvs
|
||||
showDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Show @a ) dictsRec
|
||||
nfDataDicts :: Record (Dict NFData) kvs
|
||||
nfDataDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @NFData @a ) dictsRec
|
||||
serialisableDicts :: Record (Dict Serialisable) kvs
|
||||
serialisableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Serialisable @a ) dictsRec
|
||||
interpolatableDicts :: Record (Dict Interpolatable) kvs
|
||||
interpolatableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Interpolatable @a ) dictsRec
|
||||
in
|
||||
proveRecordDicts @Show showDicts $
|
||||
proveRecordDicts @NFData nfDataDicts $
|
||||
proveRecordDicts @Serialisable serialisableDicts $
|
||||
proveRecordDicts @Interpolatable interpolatableDicts $
|
||||
SomeBrushFields @kvs
|
||||
|
|
@ -15,53 +15,37 @@
|
|||
{-# 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 +55,9 @@ 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
|
||||
)
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
|
|
@ -93,10 +67,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
|
||||
( Record, WithParams, foldRec )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
|
@ -137,148 +115,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 +122,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 +178,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 +229,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 +275,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 +288,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 +355,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 +371,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 +384,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 +394,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 +408,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
|
||||
|
|
@ -12,11 +12,7 @@
|
|||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module MetaBrush.MetaParameter.Driver where
|
||||
|
||||
-- base
|
||||
import GHC.Exts
|
||||
( Proxy#, proxy# )
|
||||
module MetaBrush.DSL.Driver where
|
||||
|
||||
-- dlist
|
||||
import qualified Data.DList as DList
|
||||
|
|
@ -43,22 +39,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 +134,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
|
||||
|
|
@ -147,4 +148,4 @@ interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser gr
|
|||
val = ( `evalState` initEvalState ) $ eval term
|
||||
pure ( Right ( SomeBrushFunction @kvs val ), messages )
|
||||
| otherwise
|
||||
-> pure ( Left ( NonBrushType ( SomeSType ( proxy# :: Proxy# v ) ) ), messages )
|
||||
-> pure ( Left ( NonBrushType ( SomeSType @v ) ), messages )
|
||||
|
|
@ -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
|
||||
|
|
@ -47,12 +45,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 +64,25 @@ 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
|
||||
( Record, Rec, I(..), WithParams(..)
|
||||
, foldRec
|
||||
)
|
||||
import qualified MetaBrush.Records as Rec
|
||||
( map, mapM, zipWith )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
|
@ -109,40 +109,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 +235,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
|
||||
100
src/metabrushes/MetaBrush/DSL/Interpolation.hs
Normal file
100
src/metabrushes/MetaBrush/DSL/Interpolation.hs
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
{-# 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 GHC.TypeLits
|
||||
( Symbol )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act(..), Torsor(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( Module(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D, Vector2D )
|
||||
import MetaBrush.Records
|
||||
( Record, AllFields, I(..) )
|
||||
import qualified MetaBrush.Records as Rec
|
||||
( cpure, cmap, czipWith )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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 AllFields Interpolatable kvs
|
||||
=> Semigroup (Record D kvs) where
|
||||
(<>) = Rec.czipWith @Interpolatable (<>)
|
||||
instance AllFields Interpolatable kvs
|
||||
=> Monoid (Record D kvs) where
|
||||
mempty = Rec.cpure @Interpolatable mempty
|
||||
instance AllFields Interpolatable kvs
|
||||
=> Group (Record D kvs) where
|
||||
invert = Rec.cmap @Interpolatable invert
|
||||
|
||||
instance AllFields Interpolatable kvs
|
||||
=> Act (Record D kvs) (Record I kvs) where
|
||||
act = Rec.czipWith @Interpolatable act
|
||||
instance AllFields Interpolatable kvs
|
||||
=> Torsor (Record D kvs) (Record I kvs) where
|
||||
(-->) = Rec.czipWith @Interpolatable (-->)
|
||||
instance AllFields Interpolatable kvs
|
||||
=> Module Double (Record D kvs) where
|
||||
origin = Rec.cpure @Interpolatable origin
|
||||
(^+^) = Rec.czipWith @Interpolatable (^+^)
|
||||
d *^ r = Rec.cmap @Interpolatable (d *^) r
|
||||
|
||||
instance AllFields Interpolatable kvs
|
||||
=> Interpolatable (Record I kvs) where
|
||||
type Diff (Record I kvs) = Record D kvs
|
||||
|
|
@ -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
|
||||
|
|
@ -33,7 +33,7 @@ import Data.Foldable
|
|||
( for_ )
|
||||
|
||||
-- containers
|
||||
import Data.Set
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
( member, fromList )
|
||||
|
|
@ -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
|
||||
|
|
@ -82,7 +82,7 @@ import MetaBrush.MetaParameter.PrimOp
|
|||
, translate_by
|
||||
, map_over
|
||||
)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Parsing using the language grammar.
|
||||
|
||||
|
|
@ -125,8 +125,8 @@ grammar = mdo
|
|||
l r
|
||||
<?> "pair"
|
||||
atom <- Earley.rule
|
||||
( identifier
|
||||
<|> pair
|
||||
( identifier
|
||||
<|> pair
|
||||
<|> ( special '(' *> expr <* anyWhitespace <* special ')' )
|
||||
<|> spline
|
||||
)
|
||||
|
|
@ -153,8 +153,8 @@ grammar = mdo
|
|||
)
|
||||
|
||||
basicPattern <- Earley.rule
|
||||
( wildcard
|
||||
<|> ( PName <$> alphabeticName
|
||||
( wildcard
|
||||
<|> ( PName <$> alphabeticName
|
||||
<?> "pattern name"
|
||||
)
|
||||
<|> pairPattern
|
||||
|
|
@ -226,7 +226,7 @@ grammar = mdo
|
|||
, Location ( location loc_in ) ]
|
||||
decls
|
||||
e
|
||||
<?> "let statement"
|
||||
<?> "let statement"
|
||||
)
|
||||
|
||||
moreProperties <- Earley.rule
|
||||
|
|
@ -281,7 +281,7 @@ grammar = mdo
|
|||
)
|
||||
|
||||
spline <-
|
||||
Earley.rule
|
||||
Earley.rule
|
||||
( do
|
||||
start <- special '['
|
||||
p0 <- expr <?> "first point of spline"
|
||||
|
|
@ -290,7 +290,7 @@ grammar = mdo
|
|||
anyWhitespace
|
||||
end <- special ']'
|
||||
pure $
|
||||
( \ opens -> \ case
|
||||
( \ opens -> \ case
|
||||
Nothing ->
|
||||
PolyBez
|
||||
[ Location ( location start ), Location ( location end ) ]
|
||||
|
|
@ -300,7 +300,7 @@ grammar = mdo
|
|||
[ Location ( location start ), Location ( location end ) ]
|
||||
( Spline p0 ( ClosedCurves opens closed ) )
|
||||
) ( Seq.fromList openCurves ) mbClosed
|
||||
<?> "spline" )
|
||||
<?> "spline" )
|
||||
|
||||
simpleExpr <- Earley.rule do
|
||||
anyWhitespace
|
||||
|
|
@ -408,10 +408,10 @@ curveTo expr = do
|
|||
pure ( mkCurve cps ( location locTo3 ) )
|
||||
|
||||
mixfixTable
|
||||
:: [ [
|
||||
:: [ [
|
||||
( Earley.Holey ( Earley.Prod r Text ( Located Token ) ( Located Token ) )
|
||||
, Earley.Associativity
|
||||
, Earley.Holey ( Located Token ) -> [ Expr ] -> Expr
|
||||
, Earley.Holey ( Located Token ) -> [ Expr ] -> Expr
|
||||
)
|
||||
] ]
|
||||
mixfixTable
|
||||
|
|
@ -621,7 +621,7 @@ separator =
|
|||
|
||||
alphabeticName :: Earley.Prod r Text ( Located Token ) ( Located Text )
|
||||
alphabeticName =
|
||||
Earley.terminal \case
|
||||
Earley.terminal \case
|
||||
Located l ( TokAlphabetic x )
|
||||
| not ( x `Set.member` reserved )
|
||||
-> Just ( Located l x )
|
||||
|
|
@ -745,7 +745,7 @@ tokenizeNumeric sr sc t = case Text.span Char.isDigit t of
|
|||
-- Fraction.
|
||||
| c == '.'
|
||||
->
|
||||
-- Fractional part of the mantissa.
|
||||
-- Fractional part of the mantissa.
|
||||
let ( frac, rest'' ) = Text.span Char.isDigit rest'
|
||||
in case Text.uncons rest'' of
|
||||
Just ( c', rest''' )
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
||||
module MetaBrush.MetaParameter.PrimOp where
|
||||
module MetaBrush.DSL.PrimOp where
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
|
|
@ -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)
|
||||
|
|
@ -13,42 +13,28 @@
|
|||
{-# 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
|
||||
( 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# )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
import GHC.TypeLits
|
||||
( someSymbolVal, SomeSymbol(..) )
|
||||
import GHC.TypeNats
|
||||
( KnownNat )
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce )
|
||||
|
||||
|
|
@ -78,21 +64,9 @@ 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 )
|
||||
import qualified Data.Text as Text
|
||||
( unpack )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.RWS.CPS
|
||||
|
|
@ -100,6 +74,10 @@ import Control.Monad.Trans.RWS.CPS
|
|||
import Control.Monad.Trans.Except
|
||||
( ExceptT )
|
||||
|
||||
-- unordered-containers
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
( fromList )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), Curve(..), Curves(..)
|
||||
|
|
@ -109,19 +87,24 @@ 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.Records
|
||||
( Record(MkR) )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, MonadUnique, Unique )
|
||||
|
||||
|
|
@ -140,8 +123,8 @@ typeCheckAt mismatchMessage term = do
|
|||
tcError $
|
||||
UnexpectedType
|
||||
mismatchMessage
|
||||
( "Expected: ", SomeSType ( proxy# :: Proxy# a ) )
|
||||
( " Actual: ", Located ( termSpan term ) $ SomeSType ( proxy# :: Proxy# x ) )
|
||||
( "Expected: ", SomeSType @a )
|
||||
( " Actual: ", Located ( termSpan term ) $ SomeSType @x )
|
||||
|
||||
typeCheck :: forall m. MonadTc m => Term Rn '() -> m TypedTerm
|
||||
typeCheck ( uf :$ ua ) = do
|
||||
|
|
@ -155,16 +138,16 @@ typeCheck ( uf :$ ua ) = do
|
|||
Nothing -> tcError $
|
||||
UnexpectedType
|
||||
"Unexpected function argument type"
|
||||
( "Expected: ", SomeSType ( proxy# :: Proxy# b ) )
|
||||
( " Actual: ", Located ( termSpan ua ) $ SomeSType ( proxy# :: Proxy# a ) )
|
||||
( "Expected: ", SomeSType @b )
|
||||
( " Actual: ", Located ( termSpan ua ) $ SomeSType @a )
|
||||
_ -> tcError $
|
||||
OverSaturatedFunctionApplication
|
||||
( Located ( termSpan uf ) ( SomeSType ( proxy# :: Proxy# f ) ) )
|
||||
( Located ( termSpan uf ) ( SomeSType @f ) )
|
||||
( termSpan ua )
|
||||
typeCheck ( Var locVar@( Located _ ( UniqueName _ uniq ) ) ) = do
|
||||
mbType <- use ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq )
|
||||
case mbType of
|
||||
Just ( SomeSType ( _ :: Proxy# a ) ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) )
|
||||
Just ( SomeSType @a ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) )
|
||||
Nothing -> tcError ( OutOfScope locVar )
|
||||
typeCheck ( Let loc decls body ) = do
|
||||
decls' <- typeCheckDecls decls
|
||||
|
|
@ -174,12 +157,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
|
||||
|
|
@ -191,8 +170,8 @@ typeCheck ( Point locs a b ) = do
|
|||
tcError $
|
||||
MismatchedTypes
|
||||
"Components of a point with different types."
|
||||
( "1st component: ", Located ( termSpan a ) ( SomeSType ( proxy# :: Proxy# a ) ) )
|
||||
( "2nd component: ", Located ( termSpan b ) ( SomeSType ( proxy# :: Proxy# b ) ) )
|
||||
( "1st component: ", Located ( termSpan a ) ( SomeSType @a ) )
|
||||
( "2nd component: ", Located ( termSpan b ) ( SomeSType @b ) )
|
||||
typeCheck ( Line {} ) = error "typeCheck: error, unexpected 'line'"
|
||||
typeCheck ( Bez2 {} ) = error "typeCheck: error, unexpected 'bez2'"
|
||||
typeCheck ( Bez3 {} ) = error "typeCheck: error, unexpected 'bez3'"
|
||||
|
|
@ -234,13 +213,13 @@ typeCheck ( PolyBez locs spline@( Spline { splineStart, splineCurves } :: Spline
|
|||
tcError $
|
||||
UnexpectedType
|
||||
"Unexpected Bézier spline coordinate type"
|
||||
( "Expected: ", SomeSType ( proxy# :: Proxy# Double ) )
|
||||
( " Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# a ) )
|
||||
( "Expected: ", SomeSType @Double )
|
||||
( " Actual: ", Located ( termSpan splineStart ) $ SomeSType @a )
|
||||
_ -> tcError $
|
||||
UnexpectedType
|
||||
"Unexpected Bézier spline point type"
|
||||
( "Expected: ", SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
|
||||
( " Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# pt ) )
|
||||
( "Expected: ", SomeSType @( Point2D Double ) )
|
||||
( " Actual: ", Located ( termSpan splineStart ) $ SomeSType @pt )
|
||||
|
||||
typeCheckDecls :: forall m. MonadTc m => [ Decl Rn ] -> m [ Decl Tc ]
|
||||
typeCheckDecls = go []
|
||||
|
|
@ -275,12 +254,12 @@ typeCheckDecl ( FunDecl funName@( Located _ ( UniqueName _ uniq ) ) argPat eqLoc
|
|||
rhs' <- typeCheckAt @( Point2D Double ) "Expected function of type `Point2D Double -> Point2D Double'" rhs
|
||||
assign
|
||||
( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq )
|
||||
( Just $ SomeSType ( proxy# :: Proxy# ( Point2D Double -> Point2D Double ) ) )
|
||||
( Just $ SomeSType @( Point2D Double -> Point2D Double ) )
|
||||
pure ( FunDecl funName argPat' eqLoc rhs' )
|
||||
|
||||
typeCheckPatAt :: forall ( a :: Type ) m. ( STypeI a, MonadTc m ) => Pat Rn '() -> m ( Pat Tc a )
|
||||
typeCheckPatAt ( PName nm@( Located _ ( UniqueName _ uniq ) ) ) = do
|
||||
assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
|
||||
assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType @a )
|
||||
pure ( PName nm )
|
||||
typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of
|
||||
sTyPair@STyPoint | ( _ :: SType ( Point2D c ) ) <- sTyPair
|
||||
|
|
@ -291,88 +270,38 @@ typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of
|
|||
_ -> tcError $
|
||||
UnexpectedPatType
|
||||
"RHS of let binding does not have the expected type"
|
||||
( "Expected type: ", Located ( foldMap location locs ) $ SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
|
||||
( " Actual type: ", SomeSType ( proxy# :: Proxy# a ) )
|
||||
( "Expected type: ", Located ( foldMap location locs ) $ SomeSType @( Point2D Double ) )
|
||||
( " Actual type: ", SomeSType @a )
|
||||
typeCheckPatAt ( PWild nm ) = pure ( PWild nm )
|
||||
typeCheckPatAt ( AsPat symbLoc nm@( Located _ ( UniqueName _ uniq ) ) pat ) = do
|
||||
pat' <- typeCheckPatAt @a pat
|
||||
assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
|
||||
assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType @a )
|
||||
pure ( AsPat symbLoc nm pat' )
|
||||
|
||||
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
|
||||
proveSomeSTypes (map (second mkSomeSType) names) \ ( _ :: Proxy# kvs ) -> do
|
||||
let
|
||||
declsRecord :: Record UniqueTerm kvs
|
||||
declsRecord = MkR (HashMap.fromList 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.
|
||||
221
src/metabrushes/MetaBrush/DSL/Types.hs
Normal file
221
src/metabrushes/MetaBrush/DSL/Types.hs
Normal file
|
|
@ -0,0 +1,221 @@
|
|||
{-# 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 :: forall a. STypeI a => SomeSType
|
||||
instance Show SomeSType where
|
||||
show ( SomeSType @a ) = show ( sTypeI @a )
|
||||
instance Eq SomeSType where
|
||||
( SomeSType @a ) == ( SomeSType @b ) =
|
||||
case eqTy @a @b of
|
||||
Just _ -> True
|
||||
_ -> False
|
||||
|
||||
data SomeSTypes where
|
||||
SomeSTypes :: forall kvs. STypesI 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 @v )
|
||||
: go ( sTypesI @lvs' )
|
||||
|
||||
proveSomeSTypes :: [ ( Text, SomeSType ) ] -> ( forall kvs. STypesI kvs => Proxy# kvs -> r ) -> r
|
||||
proveSomeSTypes rs f = case go rs of { SomeSTypes @kvs -> f @kvs proxy# }
|
||||
where
|
||||
go :: [ ( Text, SomeSType ) ] -> SomeSTypes
|
||||
go [] = SomeSTypes @'[]
|
||||
go ( ( s, SomeSType @v ) :rest )
|
||||
= case go rest of
|
||||
SomeSTypes @kvs
|
||||
| SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack s )
|
||||
-> SomeSTypes @( '( k, v ) ': kvs )
|
||||
307
src/metabrushes/MetaBrush/Records.hs
Normal file
307
src/metabrushes/MetaBrush/Records.hs
Normal file
|
|
@ -0,0 +1,307 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module MetaBrush.Records
|
||||
( Record(..), Rec, AllFields(..)
|
||||
|
||||
, empty, insert
|
||||
|
||||
, map, mapM
|
||||
, mapMWithKey
|
||||
, zipWith
|
||||
, cpure, cmap, czipWith
|
||||
, cpureM, cpureMWithKey
|
||||
, cmapWithKey
|
||||
, collapse, foldRec
|
||||
, proveRecordDicts
|
||||
, describeRecord
|
||||
, MyIntersection(..), myIntersect
|
||||
|
||||
, WithParams(..)
|
||||
|
||||
-- * Functors
|
||||
, I(..), K(..), (:*:)(..), Dict(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Prelude
|
||||
hiding ( map, mapM, zipWith )
|
||||
import Data.Coerce
|
||||
( coerce )
|
||||
import Data.Functor.Const
|
||||
( Const(..) )
|
||||
import Data.Kind
|
||||
( Type, Constraint )
|
||||
import Data.List
|
||||
( intersperse )
|
||||
import Data.Monoid
|
||||
( Endo(..) )
|
||||
import Data.Proxy
|
||||
( Proxy(..) )
|
||||
import Data.Typeable
|
||||
( Typeable, TypeRep, typeRep )
|
||||
import GHC.TypeLits
|
||||
( Symbol, KnownSymbol, symbolVal' )
|
||||
import GHC.Exts
|
||||
( Any, Proxy#, proxy#, withDict )
|
||||
import GHC.Show
|
||||
( showCommaSpace )
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group(..) )
|
||||
|
||||
-- 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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type Record :: (Type -> Type) -> [(Symbol, Type)] -> Type
|
||||
newtype Record f kvs = MkR { recordKeyVals :: HashMap Text (f Any) }
|
||||
|
||||
empty :: Record f '[]
|
||||
empty = MkR HashMap.empty
|
||||
|
||||
insert :: forall k v kvs f
|
||||
. KnownSymbol k
|
||||
=> f v
|
||||
-> Record f kvs
|
||||
-> Record f ( '(k,v) ': kvs )
|
||||
insert v (MkR r) = MkR $ HashMap.insert k v' r
|
||||
where
|
||||
k :: Text
|
||||
k = Text.pack (symbolVal' (proxy# :: Proxy# k))
|
||||
v' :: f Any
|
||||
v' = unsafeCoerce v
|
||||
|
||||
type Rec :: [(Symbol, Type)] -> Type
|
||||
type Rec kvs = Record I kvs
|
||||
|
||||
type I :: Type -> Type
|
||||
newtype I a = I { unI :: a }
|
||||
deriving newtype ( Semigroup, Monoid, Group, NFData )
|
||||
|
||||
type K :: Type -> Type -> Type
|
||||
newtype K a b = K { unK :: a }
|
||||
deriving newtype ( Semigroup, Monoid, Group, NFData )
|
||||
|
||||
type (:*:) :: (Type -> Type) -> (Type -> Type) -> Type -> Type
|
||||
data (f :*: g) a = f a :*: g a
|
||||
|
||||
type Dict :: (Type -> Constraint) -> Type -> Type
|
||||
data Dict c a where
|
||||
Dict :: c a => Dict c a
|
||||
|
||||
type AllFields :: (Type -> Constraint) -> [(Symbol, Type)] -> Constraint
|
||||
class AllFields c kvs where
|
||||
recordDicts :: Record (Dict c) kvs
|
||||
|
||||
instance AllFields c '[] where
|
||||
recordDicts = MkR HashMap.empty
|
||||
|
||||
instance ( c v, KnownSymbol k, AllFields c kvs ) => AllFields c ( '(k, v) ': kvs ) where
|
||||
recordDicts = case recordDicts @c @kvs of
|
||||
MkR kvs -> MkR $ HashMap.insert k dict kvs
|
||||
where
|
||||
k :: Text
|
||||
k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
|
||||
dict :: Dict c Any
|
||||
dict = unsafeCoerce ( Dict :: Dict c v )
|
||||
|
||||
instance AllFields Show kvs => Show (Record I kvs) where
|
||||
showsPrec d = aux . collapse . cmapWithKey @Show showField
|
||||
where
|
||||
showField :: Show x => Text -> I x -> K ShowS x
|
||||
showField k (I x) = K $ showString (Text.unpack 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
|
||||
}
|
||||
|
||||
instance AllFields Semigroup kvs
|
||||
=> Semigroup (Record I kvs) where
|
||||
(<>) = czipWith @Semigroup (<>)
|
||||
|
||||
instance ( AllFields Semigroup kvs
|
||||
, AllFields Monoid kvs )
|
||||
=> Monoid (Record I kvs) where
|
||||
mempty = cpure @Monoid mempty
|
||||
|
||||
instance ( AllFields Semigroup kvs
|
||||
, AllFields Monoid kvs
|
||||
, AllFields Group kvs )
|
||||
=> Group (Record I kvs) where
|
||||
invert = cmap @Group ( \ (I g) -> I (invert g) )
|
||||
|
||||
instance AllFields NFData kvs
|
||||
=> NFData ( Record I kvs ) where
|
||||
rnf (MkR !_) = () -- todo
|
||||
|
||||
data MyIntersection r1 g r2 c where
|
||||
MyIntersection
|
||||
:: forall i r1 g r2 c
|
||||
. ( AllFields c i )
|
||||
=> { myProject :: forall f. Record f r1 -> Record (f :*: g) i
|
||||
, myInject :: Record g i -> Record g r2
|
||||
}
|
||||
-> MyIntersection r1 g r2 c
|
||||
|
||||
myIntersect
|
||||
:: forall c r1 g r2
|
||||
. ( AllFields c r1 )
|
||||
=> 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 :*: g) Any
|
||||
myProject (MkR r1) = MkR (HashMap.intersectionWith (:*:) r1 r2)
|
||||
myInject :: Record g Any -> Record g r2
|
||||
myInject (MkR i) = MkR (HashMap.union i r2)
|
||||
intersectionDict :: Record (Dict c) Any
|
||||
intersectionDict =
|
||||
case recordDicts @c @r1 of
|
||||
MkR d -> MkR (HashMap.intersection d r2)
|
||||
|
||||
proveRecordDicts :: forall c r x. Record (Dict c) r -> (AllFields c r => x) -> x
|
||||
proveRecordDicts = withDict
|
||||
|
||||
describeRecord :: forall kvs. AllFields Typeable kvs => [ ( Text, TypeRep ) ]
|
||||
describeRecord = collapse $ cmapWithKey @Typeable describeField (recordDicts @Typeable @kvs)
|
||||
where
|
||||
describeField :: forall a. Text -> Dict Typeable a -> K ( Text, TypeRep ) a
|
||||
describeField k Dict = K ( k, typeRep ( Proxy :: Proxy a ) )
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Record combinators.
|
||||
|
||||
map :: ( forall x. f x -> g x )
|
||||
-> Record f kvs -> Record g kvs
|
||||
map f (MkR r) = MkR $ fmap f r
|
||||
|
||||
mapM :: Applicative m
|
||||
=> ( forall x. f x -> m ( g x ) )
|
||||
-> Record f kvs -> m (Record g kvs)
|
||||
mapM f (MkR r) =
|
||||
MkR <$> traverse f r
|
||||
|
||||
mapMWithKey :: forall m kvs f g
|
||||
. Applicative m
|
||||
=> ( forall x. Text -> f x -> m ( g x ) )
|
||||
-> Record f kvs -> m (Record g kvs)
|
||||
mapMWithKey f (MkR r) =
|
||||
MkR <$> HashMap.traverseWithKey f r
|
||||
|
||||
cpure :: forall c kvs f
|
||||
. AllFields c kvs
|
||||
=> ( forall x. c x => f x )
|
||||
-> Record f kvs
|
||||
cpure f =
|
||||
MkR $ fmap (\ Dict -> f) (recordKeyVals $ recordDicts @c @kvs)
|
||||
|
||||
cmap :: forall c kvs f g
|
||||
. AllFields c kvs
|
||||
=> ( forall x. c x => f x -> g x )
|
||||
-> Record f kvs
|
||||
-> Record g kvs
|
||||
cmap f (MkR r) =
|
||||
MkR $ HashMap.intersectionWith (\ Dict x -> f x) (recordKeyVals $ recordDicts @c @kvs) r
|
||||
|
||||
zipWith :: forall kvs f g h
|
||||
. ( forall x. f x -> g x -> h x )
|
||||
-> Record f kvs
|
||||
-> Record g kvs
|
||||
-> Record h kvs
|
||||
zipWith f (MkR r1) (MkR r2) =
|
||||
MkR $ HashMap.intersectionWith (\ x y -> f x y) r1 r2
|
||||
|
||||
czipWith :: forall c kvs f g h
|
||||
. AllFields c kvs
|
||||
=> ( forall x. c x => f x -> g x -> h x )
|
||||
-> Record f kvs
|
||||
-> Record g kvs
|
||||
-> Record h kvs
|
||||
czipWith f (MkR r1) (MkR r2) =
|
||||
MkR $ HashMap.intersectionWith (\ Dict (x :*: y) -> f x y) (recordKeyVals $ recordDicts @c @kvs) pairs
|
||||
where
|
||||
pairs :: HashMap Text ((f :*: g) Any)
|
||||
pairs = HashMap.intersectionWith (\ x y -> x :*: y) r1 r2
|
||||
|
||||
cpureM :: forall c m kvs f
|
||||
. ( Applicative m, AllFields c kvs)
|
||||
=> ( forall x. c x => m (f x) )
|
||||
-> m ( Record f kvs )
|
||||
cpureM f = mapM (\Dict -> f) (recordDicts @c @kvs)
|
||||
|
||||
cpureMWithKey :: forall c m kvs f
|
||||
. ( Applicative m, AllFields c kvs)
|
||||
=> ( forall x. c x => Text-> m (f x) )
|
||||
-> m ( Record f kvs )
|
||||
cpureMWithKey f = mapMWithKey (\k Dict -> f k) (recordDicts @c @kvs)
|
||||
|
||||
cmapWithKey :: forall c kvs f g
|
||||
. AllFields c kvs
|
||||
=> (forall x. c x => Text -> f x -> g x)
|
||||
-> Record f kvs
|
||||
-> Record g kvs
|
||||
cmapWithKey f = zipWithKey ( \ k Dict x -> f k x ) (recordDicts @c @kvs)
|
||||
|
||||
zipWithKey :: forall r f g h
|
||||
. ( forall x. Text -> f x -> g x -> h x )
|
||||
-> Record f r -> Record g r -> Record h r
|
||||
zipWithKey f (MkR a) (MkR b) = MkR $
|
||||
HashMap.intersectionWithKey f a b
|
||||
|
||||
foldRec :: forall y f r. ( forall x . f x -> y -> y ) -> Record f r -> y -> y
|
||||
foldRec f r = coerce $ mapM g r
|
||||
where
|
||||
g :: ( forall x. f x -> Const (Endo y) (I x) )
|
||||
g x = coerce (f x)
|
||||
|
||||
collapse :: Record (K a) r -> [a]
|
||||
collapse (MkR a) = coerce $ HashMap.elems a
|
||||
310
src/metabrushes/MetaBrush/Serialisable.hs
Normal file
310
src/metabrushes/MetaBrush/Serialisable.hs
Normal file
|
|
@ -0,0 +1,310 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.Serialisable
|
||||
( Serialisable(..)
|
||||
, encodeSequence, decodeSequence
|
||||
, encodeUniqueMap, decodeUniqueMap
|
||||
, encodeCurve, decodeCurve
|
||||
, encodeCurves, decodeCurves
|
||||
, encodeSpline, decodeSpline
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( (&&&) )
|
||||
import Control.Monad.ST
|
||||
( RealWorld, stToIO )
|
||||
import Data.Foldable
|
||||
( toList )
|
||||
import Data.Functor.Contravariant
|
||||
( contramap )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.STRef
|
||||
( newSTRef )
|
||||
import GHC.Exts
|
||||
( Proxy# )
|
||||
import GHC.TypeLits
|
||||
( symbolVal', KnownSymbol )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( elems, fromList )
|
||||
import Data.Sequence
|
||||
( Seq )
|
||||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
|
||||
-- scientific
|
||||
import qualified Data.Scientific as Scientific
|
||||
( fromFloatDigits, toRealFloat )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO(liftIO) )
|
||||
import Control.Monad.Trans.Class
|
||||
( MonadTrans(lift) )
|
||||
|
||||
-- waargonaut
|
||||
import qualified Waargonaut.Decode as JSON
|
||||
( Decoder )
|
||||
import qualified Waargonaut.Decode as JSON.Decoder
|
||||
( atKey, atKeyOptional, list, scientific, text )
|
||||
import qualified Waargonaut.Encode as JSON
|
||||
( Encoder )
|
||||
import qualified Waargonaut.Encode as JSON.Encoder
|
||||
( runPureEncoder
|
||||
, atKey', json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
|
||||
)
|
||||
import Waargonaut.Types.Json
|
||||
( Json )
|
||||
|
||||
-- meta-brushes
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplineType(..), SSplineType(..), SplineTypeI(..)
|
||||
, Curves(..), Curve(..), NextPoint(..)
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..) )
|
||||
import MetaBrush.Records
|
||||
( Record, Rec, AllFields
|
||||
, I(..), K(..)
|
||||
, collapse, cmapWithKey, cpureMWithKey
|
||||
)
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
class Serialisable a where
|
||||
encoder :: Monad f => JSON.Encoder f a
|
||||
decoder :: Monad m => JSON.Decoder m a
|
||||
|
||||
instance Serialisable Double where
|
||||
encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
|
||||
decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific
|
||||
|
||||
instance Serialisable a => Serialisable ( Point2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
instance Serialisable a => Serialisable ( Vector2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
instance Serialisable a => Serialisable (I a) where
|
||||
encoder = contramap unI encoder
|
||||
decoder = fmap I decoder
|
||||
|
||||
instance ( AllFields Serialisable kvs )
|
||||
=> Serialisable ( Record I kvs ) where
|
||||
encoder :: forall f. Monad f => JSON.Encoder f ( Rec kvs )
|
||||
encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
|
||||
where
|
||||
encodeFields :: Record I kvs -> [ ( Text, Json ) ]
|
||||
encodeFields = collapse . cmapWithKey @Serialisable keyVal
|
||||
keyVal :: Serialisable x => Text -> I x -> K (Text, Json) x
|
||||
keyVal k (I x) = K ( k, JSON.Encoder.runPureEncoder encoder x )
|
||||
|
||||
decoder :: forall m. Monad m => JSON.Decoder m ( Rec kvs )
|
||||
decoder = cpureMWithKey @Serialisable ( \ k -> JSON.Decoder.atKey k decoder )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
|
||||
encodeSequence enc = contramap toList ( JSON.Encoder.list enc )
|
||||
|
||||
decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a )
|
||||
decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
|
||||
|
||||
|
||||
|
||||
encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
|
||||
encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
|
||||
|
||||
decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
|
||||
decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
|
||||
|
||||
|
||||
|
||||
{-
|
||||
encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
|
||||
encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
|
||||
JSON.Encoder.atKey' "m00" enc m00
|
||||
. JSON.Encoder.atKey' "m01" enc m01
|
||||
. JSON.Encoder.atKey' "m10" enc m10
|
||||
. JSON.Encoder.atKey' "m11" enc m11
|
||||
|
||||
decodeMat22 :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Mat22 a )
|
||||
decodeMat22 dec =
|
||||
Mat22 <$> JSON.Decoder.atKey "m00" dec
|
||||
<*> JSON.Decoder.atKey "m01" dec
|
||||
<*> JSON.Decoder.atKey "m10" dec
|
||||
<*> JSON.Decoder.atKey "m11" dec
|
||||
|
||||
|
||||
|
||||
encodeAABB :: Applicative f => JSON.Encoder f AABB
|
||||
encodeAABB = JSON.Encoder.mapLikeObj \ ( AABB { topLeft, botRight } ) ->
|
||||
JSON.Encoder.atKey' "topLeft" enc topLeft
|
||||
. JSON.Encoder.atKey' "botRight" enc botRight
|
||||
where
|
||||
enc :: JSON.Encoder' ( Point2D Double )
|
||||
enc = encodePoint2D encodeDouble
|
||||
|
||||
decodeAABB :: forall m. Monad m => JSON.Decoder m AABB
|
||||
decodeAABB = do
|
||||
topLeft <- JSON.Decoder.atKey "topLeft" dec
|
||||
botRight <- JSON.Decoder.atKey "botRight" dec
|
||||
pure ( AABB { topLeft, botRight } )
|
||||
where
|
||||
dec :: JSON.Decoder m ( Point2D Double )
|
||||
dec = decodePoint2D decodeDouble
|
||||
-}
|
||||
|
||||
|
||||
encodeCurve
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Curve clo crvData ptData )
|
||||
encodeCurve encodePtData = case ssplineType @clo of
|
||||
SOpen -> JSON.Encoder.mapLikeObj \case
|
||||
LineTo ( NextPoint p1 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
Bezier2To p1 ( NextPoint p2 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
Bezier3To p1 p2 ( NextPoint p3 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
. JSON.Encoder.atKey' "p3" encodePtData p3
|
||||
SClosed -> JSON.Encoder.mapLikeObj \case
|
||||
LineTo BackToStart _ -> id
|
||||
Bezier2To p1 BackToStart _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
Bezier3To p1 p2 BackToStart _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
|
||||
decodeCurve
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeCurve decodePtData = do
|
||||
noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
|
||||
case ssplineType @clo of
|
||||
SOpen -> do
|
||||
p1 <- JSON.Decoder.atKey "p1" decodePtData
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing ->
|
||||
pure ( LineTo ( NextPoint p1 ) noCache )
|
||||
Just p2 -> do
|
||||
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
|
||||
case mb_p3 of
|
||||
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) noCache )
|
||||
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
|
||||
SClosed -> do
|
||||
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
|
||||
case mb_p1 of
|
||||
Nothing ->
|
||||
pure ( LineTo BackToStart noCache )
|
||||
Just p1 -> do
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing -> pure ( Bezier2To p1 BackToStart noCache )
|
||||
Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
|
||||
|
||||
|
||||
|
||||
encodeCurves
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Curves clo crvData ptData )
|
||||
encodeCurves encodePtData = case ssplineType @clo of
|
||||
SOpen -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData )
|
||||
SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR )
|
||||
where
|
||||
encodeL :: JSON.Encoder f ()
|
||||
encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text
|
||||
encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData )
|
||||
encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) ->
|
||||
JSON.Encoder.atKey' "prevOpenCurves" ( encodeSequence $ encodeCurve @Open encodePtData ) openCurves
|
||||
. JSON.Encoder.atKey' "lastClosedCurve" ( encodeCurve @Closed encodePtData ) closedCurve
|
||||
|
||||
decodeCurves
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curves clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeCurves decodePtData = case ssplineType @clo of
|
||||
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
|
||||
SClosed -> do
|
||||
mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
|
||||
case mbNoCurves of
|
||||
Just _ -> pure NoCurves
|
||||
Nothing -> do
|
||||
prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData )
|
||||
lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData )
|
||||
pure ( ClosedCurves prevCurves lastCurve )
|
||||
|
||||
|
||||
|
||||
encodeSpline
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Spline clo crvData ptData )
|
||||
encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) ->
|
||||
JSON.Encoder.atKey' "splineStart" encodePtData splineStart
|
||||
. JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
|
||||
|
||||
decodeSpline
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeSpline decodePtData = do
|
||||
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
|
||||
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
|
||||
pure ( Spline { splineStart, splineCurves } )
|
||||
28
src/metabrushes/MetaBrush/Util.hs
Normal file
28
src/metabrushes/MetaBrush/Util.hs
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Util
|
||||
( traverseMaybe
|
||||
, Exists(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
traverseMaybe :: Applicative f => ( a -> f ( Maybe b ) ) -> Seq a -> f ( Seq b )
|
||||
traverseMaybe _ Empty = pure Empty
|
||||
traverseMaybe f ( a :<| as ) = ( \ case { Nothing -> id; Just b -> ( b :<| ) } ) <$> f a <*> traverseMaybe f as
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Exists c where
|
||||
Exists :: c a => a -> Exists c
|
||||
|
|
@ -33,7 +33,9 @@ import Data.Monoid
|
|||
import Data.Semigroup
|
||||
( ArgMin, Min(..), Arg(..) )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1 )
|
||||
( Generic, Generic1
|
||||
, Generically(..), Generically1(..)
|
||||
)
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -46,10 +48,6 @@ import Data.Act
|
|||
import Control.DeepSeq
|
||||
( NFData, NFData1 )
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( GenericProduct(..), Generically1(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group )
|
||||
|
|
@ -88,7 +86,7 @@ data Bezier p
|
|||
{ p0, p1, p2, p3 :: !p }
|
||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via GenericProduct ( Bezier p )
|
||||
via Generically ( Bezier p )
|
||||
deriving Applicative
|
||||
via Generically1 Bezier
|
||||
deriving anyclass ( NFData, NFData1 )
|
||||
|
|
@ -30,7 +30,9 @@ import Data.Monoid
|
|||
import Data.Semigroup
|
||||
( ArgMin, Min(..), Arg(..) )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1 )
|
||||
( Generic, Generic1
|
||||
, Generically(..), Generically1(..)
|
||||
)
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -43,10 +45,6 @@ import Data.Act
|
|||
import Control.DeepSeq
|
||||
( NFData, NFData1 )
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( GenericProduct(..), Generically1(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group )
|
||||
|
|
@ -83,7 +81,7 @@ data Bezier p
|
|||
{ p0, p1, p2 :: !p }
|
||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via GenericProduct ( Bezier p )
|
||||
via Generically ( Bezier p )
|
||||
deriving Applicative
|
||||
via Generically1 Bezier
|
||||
deriving anyclass ( NFData, NFData1 )
|
||||
|
|
@ -61,7 +61,7 @@ import Control.DeepSeq
|
|||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field )
|
||||
import Data.GenericLens.Internal
|
||||
import Data.Generics.Internal.VL
|
||||
( set )
|
||||
|
||||
-- transformers
|
||||
|
|
@ -371,7 +371,7 @@ class SplineTypeI clo => KnownSplineType clo where
|
|||
|
||||
-- | Indexed traversal of a spline.
|
||||
ibitraverseSpline
|
||||
:: forall f crvData ptData crvData' ptData'
|
||||
:: forall f crvData ptData crvData' ptData'
|
||||
. Applicative f
|
||||
=> ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
|
||||
=> Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
|
||||
|
|
@ -393,7 +393,7 @@ class SplineTypeI clo => KnownSplineType clo where
|
|||
|
||||
-- | Traversal of a spline.
|
||||
bitraverseSpline
|
||||
:: forall f crvData ptData crvData' ptData'
|
||||
:: forall f crvData ptData crvData' ptData'
|
||||
. Applicative f
|
||||
=> ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
|
||||
=> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
|
||||
|
|
@ -434,7 +434,7 @@ class SplineTypeI clo => KnownSplineType clo where
|
|||
|
||||
-- | Bifunctor fmap of a spline.
|
||||
bimapSpline
|
||||
:: forall crvData ptData crvData' ptData'
|
||||
:: forall crvData ptData crvData' ptData'
|
||||
. ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
|
||||
=> ptData -> Curve clo' crvData ptData -> Curve clo' crvData' ptData'
|
||||
)
|
||||
|
|
@ -442,7 +442,7 @@ class SplineTypeI clo => KnownSplineType clo where
|
|||
-> Spline clo crvData ptData
|
||||
-> Spline clo crvData' ptData'
|
||||
bimapSpline fc fp
|
||||
= runIdentity
|
||||
= runIdentity
|
||||
. bitraverseSpline @clo @Identity ( coerce fc ) ( coerce fp )
|
||||
|
||||
|
||||
|
|
@ -455,7 +455,7 @@ instance KnownSplineType Open where
|
|||
case curves of
|
||||
Empty -> splineStart
|
||||
_ :|> lastCurve -> openCurveEnd lastCurve
|
||||
|
||||
|
||||
adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Open crvData ptData
|
||||
adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of
|
||||
SOpen -> spline
|
||||
|
|
@ -518,7 +518,7 @@ instance KnownSplineType Closed where
|
|||
OpenCurves ( prev :|> lst ) -> Spline { splineStart, splineCurves = ClosedCurves prev ( set ( field @"curveEnd" ) BackToStart lst ) }
|
||||
|
||||
ibitraverseSpline
|
||||
:: forall f crvData ptData crvData' ptData'
|
||||
:: forall f crvData ptData crvData' ptData'
|
||||
. Applicative f
|
||||
=> ( forall clo'. ( (), SplineTypeI clo' )
|
||||
=> Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
|
||||
|
|
@ -70,7 +70,7 @@ import Control.DeepSeq
|
|||
-- generic-lens
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
import Data.GenericLens.Internal
|
||||
import Data.Generics.Internal.VL
|
||||
( set, view )
|
||||
|
||||
-- groups
|
||||
|
|
@ -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
|
||||
1
src/splines/Math/MPoly.hs
Normal file
1
src/splines/Math/MPoly.hs
Normal file
|
|
@ -0,0 +1 @@
|
|||
module Math.MPoly where
|
||||
|
|
@ -30,7 +30,7 @@ import Data.Sequence
|
|||
-- generic-lens
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
import Data.GenericLens.Internal
|
||||
import Data.Generics.Internal.VL
|
||||
( view )
|
||||
|
||||
-- MetaBrush
|
||||
|
|
@ -17,7 +17,7 @@ module Math.Vector2D
|
|||
import Data.Monoid
|
||||
( Sum(..) )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1 )
|
||||
( Generic, Generic1, Generically(..), Generically1(..) )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -27,10 +27,6 @@ import Data.Act
|
|||
import Control.DeepSeq
|
||||
( NFData, NFData1 )
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( Generically1(..), GenericProduct(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group )
|
||||
|
|
@ -53,7 +49,7 @@ newtype Vector2D a = MkVector2D { tip :: Point2D a }
|
|||
deriving stock ( Show, Generic, Generic1, Foldable, Traversable )
|
||||
deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via GenericProduct ( Point2D ( Sum a ) )
|
||||
via Generically ( Point2D ( Sum a ) )
|
||||
|
||||
{-# COMPLETE Vector2D #-}
|
||||
pattern Vector2D :: a -> a -> Vector2D a
|
||||
|
|
@ -73,7 +69,7 @@ data Segment p =
|
|||
}
|
||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via GenericProduct ( Segment p )
|
||||
via Generically ( Segment p )
|
||||
deriving Applicative
|
||||
via Generically1 Segment
|
||||
deriving anyclass ( NFData, NFData1 )
|
||||
Loading…
Reference in a new issue