From 64e45f126bb1a140a170218203ee45a813ebdf65 Mon Sep 17 00:00:00 2001 From: sheaf Date: Fri, 11 Feb 2022 22:05:13 +0100 Subject: [PATCH] Refactor module hierarchy, use internal records --- MetaBrush.cabal | 173 ++++---- cabal.project | 37 +- src/app/MetaBrush/Action.hs | 2 +- src/app/MetaBrush/Application.hs | 25 +- src/app/MetaBrush/Asset/Brushes.hs | 19 +- src/app/MetaBrush/Asset/CloseTabButton.hs | 2 +- src/app/MetaBrush/Asset/Cursor.hs | 2 +- src/app/MetaBrush/Asset/InfoBar.hs | 2 +- src/app/MetaBrush/Asset/Logo.hs | 2 +- src/app/MetaBrush/Asset/TickBox.hs | 2 +- src/app/MetaBrush/Asset/Tools.hs | 2 +- src/app/MetaBrush/Asset/WindowIcons.hs | 4 +- src/app/MetaBrush/Brush.hs | 376 ---------------- src/app/MetaBrush/Document.hs | 43 +- src/app/MetaBrush/Document/Draw.hs | 50 ++- src/app/MetaBrush/Document/Selection.hs | 8 +- src/app/MetaBrush/Document/Serialise.hs | 408 ++++-------------- src/app/MetaBrush/Document/Serialise.hs-boot | 50 --- src/app/MetaBrush/Document/SubdivideStroke.hs | 2 +- src/app/MetaBrush/Document/Update.hs | 6 +- src/app/MetaBrush/{ => GTK}/Util.hs | 19 +- .../MetaBrush/MetaParameter/Interpolation.hs | 142 ------ src/app/MetaBrush/Render/Document.hs | 99 +++-- src/app/MetaBrush/Render/Rulers.hs | 2 +- src/app/MetaBrush/UI/FileBar.hs | 2 +- src/app/MetaBrush/UI/FileBar.hs-boot | 5 +- src/app/MetaBrush/UI/InfoBar.hs | 2 +- src/app/MetaBrush/UI/Menu.hs | 4 +- src/app/MetaBrush/UI/Panels.hs | 6 +- src/app/MetaBrush/UI/ToolBar.hs | 2 +- src/app/MetaBrush/UI/Viewport.hs | 18 +- src/{app => metabrushes}/MetaBrush/Assert.hs | 0 src/metabrushes/MetaBrush/Brush.hs | 167 +++++++ .../MetaBrush/DSL}/AST.hs | 355 +++------------ .../MetaBrush/DSL}/Driver.hs | 31 +- .../MetaBrush/DSL}/Eval.hs | 111 ++--- .../MetaBrush/DSL/Interpolation.hs | 100 +++++ .../MetaBrush/DSL}/Parse.hs | 34 +- .../MetaBrush/DSL}/PrimOp.hs | 2 +- .../MetaBrush/DSL}/Rename.hs | 6 +- .../MetaBrush/DSL}/TypeCheck.hs | 187 +++----- src/metabrushes/MetaBrush/DSL/Types.hs | 221 ++++++++++ src/metabrushes/MetaBrush/Records.hs | 307 +++++++++++++ src/metabrushes/MetaBrush/Serialisable.hs | 310 +++++++++++++ src/{app => metabrushes}/MetaBrush/Unique.hs | 0 src/metabrushes/MetaBrush/Util.hs | 28 ++ src/{lib => splines}/Math/Bezier/Cubic.hs | 10 +- src/{lib => splines}/Math/Bezier/Cubic/Fit.hs | 0 src/{lib => splines}/Math/Bezier/Envelope.hs | 0 src/{lib => splines}/Math/Bezier/Quadratic.hs | 10 +- src/{lib => splines}/Math/Bezier/Spline.hs | 14 +- src/{lib => splines}/Math/Bezier/Stroke.hs | 7 +- src/{lib => splines}/Math/Epsilon.hs | 0 src/{lib => splines}/Math/Linear/Solve.hs | 0 src/splines/Math/MPoly.hs | 1 + src/{lib => splines}/Math/Module.hs | 0 src/{lib => splines}/Math/Orientation.hs | 2 +- src/{lib => splines}/Math/Roots.hs | 0 src/{lib => splines}/Math/Vector2D.hs | 10 +- 59 files changed, 1709 insertions(+), 1720 deletions(-) delete mode 100644 src/app/MetaBrush/Brush.hs delete mode 100644 src/app/MetaBrush/Document/Serialise.hs-boot rename src/app/MetaBrush/{ => GTK}/Util.hs (79%) delete mode 100644 src/app/MetaBrush/MetaParameter/Interpolation.hs rename src/{app => metabrushes}/MetaBrush/Assert.hs (100%) create mode 100644 src/metabrushes/MetaBrush/Brush.hs rename src/{app/MetaBrush/MetaParameter => metabrushes/MetaBrush/DSL}/AST.hs (51%) rename src/{app/MetaBrush/MetaParameter => metabrushes/MetaBrush/DSL}/Driver.hs (89%) rename src/{app/MetaBrush/MetaParameter => metabrushes/MetaBrush/DSL}/Eval.hs (72%) create mode 100644 src/metabrushes/MetaBrush/DSL/Interpolation.hs rename src/{app/MetaBrush/MetaParameter => metabrushes/MetaBrush/DSL}/Parse.hs (98%) rename src/{app/MetaBrush/MetaParameter => metabrushes/MetaBrush/DSL}/PrimOp.hs (97%) rename src/{app/MetaBrush/MetaParameter => metabrushes/MetaBrush/DSL}/Rename.hs (98%) rename src/{app/MetaBrush/MetaParameter => metabrushes/MetaBrush/DSL}/TypeCheck.hs (66%) create mode 100644 src/metabrushes/MetaBrush/DSL/Types.hs create mode 100644 src/metabrushes/MetaBrush/Records.hs create mode 100644 src/metabrushes/MetaBrush/Serialisable.hs rename src/{app => metabrushes}/MetaBrush/Unique.hs (100%) create mode 100644 src/metabrushes/MetaBrush/Util.hs rename src/{lib => splines}/Math/Bezier/Cubic.hs (98%) rename src/{lib => splines}/Math/Bezier/Cubic/Fit.hs (100%) rename src/{lib => splines}/Math/Bezier/Envelope.hs (100%) rename src/{lib => splines}/Math/Bezier/Quadratic.hs (97%) rename src/{lib => splines}/Math/Bezier/Spline.hs (99%) rename src/{lib => splines}/Math/Bezier/Stroke.hs (99%) rename src/{lib => splines}/Math/Epsilon.hs (100%) rename src/{lib => splines}/Math/Linear/Solve.hs (100%) create mode 100644 src/splines/Math/MPoly.hs rename src/{lib => splines}/Math/Module.hs (100%) rename src/{lib => splines}/Math/Orientation.hs (99%) rename src/{lib => splines}/Math/Roots.hs (100%) rename src/{lib => splines}/Math/Vector2D.hs (91%) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 2852902..2b60e0b 100644 --- a/MetaBrush.cabal +++ b/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 diff --git a/cabal.project b/cabal.project index 3d4541e..c44af15 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index afd775c..0302a5e 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -151,7 +151,7 @@ import MetaBrush.UI.Viewport ( Viewport(..), Ruler(..) ) import MetaBrush.Unique ( Unique ) -import MetaBrush.Util +import MetaBrush.GTK.Util ( (>=?=>), (>>?=) , widgetAddClass, widgetAddClasses ) diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 904a5e9..9e16e69 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -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 diff --git a/src/app/MetaBrush/Asset/Brushes.hs b/src/app/MetaBrush/Asset/Brushes.hs index 9927960..4c775a5 100644 --- a/src/app/MetaBrush/Asset/Brushes.hs +++ b/src/app/MetaBrush/Asset/Brushes.hs @@ -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 ) diff --git a/src/app/MetaBrush/Asset/CloseTabButton.hs b/src/app/MetaBrush/Asset/CloseTabButton.hs index 758db21..c267cbe 100644 --- a/src/app/MetaBrush/Asset/CloseTabButton.hs +++ b/src/app/MetaBrush/Asset/CloseTabButton.hs @@ -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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/Cursor.hs b/src/app/MetaBrush/Asset/Cursor.hs index 91fdeb0..d4c3ce3 100644 --- a/src/app/MetaBrush/Asset/Cursor.hs +++ b/src/app/MetaBrush/Asset/Cursor.hs @@ -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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/InfoBar.hs b/src/app/MetaBrush/Asset/InfoBar.hs index e72fa8d..45c92b1 100644 --- a/src/app/MetaBrush/Asset/InfoBar.hs +++ b/src/app/MetaBrush/Asset/InfoBar.hs @@ -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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/Logo.hs b/src/app/MetaBrush/Asset/Logo.hs index 235c804..5cfebb7 100644 --- a/src/app/MetaBrush/Asset/Logo.hs +++ b/src/app/MetaBrush/Asset/Logo.hs @@ -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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/TickBox.hs b/src/app/MetaBrush/Asset/TickBox.hs index a842a2c..ccbce0e 100644 --- a/src/app/MetaBrush/Asset/TickBox.hs +++ b/src/app/MetaBrush/Asset/TickBox.hs @@ -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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/Tools.hs b/src/app/MetaBrush/Asset/Tools.hs index bc06160..7efe8e5 100644 --- a/src/app/MetaBrush/Asset/Tools.hs +++ b/src/app/MetaBrush/Asset/Tools.hs @@ -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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Asset/WindowIcons.hs b/src/app/MetaBrush/Asset/WindowIcons.hs index f5ede9a..f5d46b8 100644 --- a/src/app/MetaBrush/Asset/WindowIcons.hs +++ b/src/app/MetaBrush/Asset/WindowIcons.hs @@ -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 diff --git a/src/app/MetaBrush/Brush.hs b/src/app/MetaBrush/Brush.hs deleted file mode 100644 index 7497978..0000000 --- a/src/app/MetaBrush/Brush.hs +++ /dev/null @@ -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 diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 4a990e0..417cae4 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 } } ) = diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index dd2aaef..6c8e6ef 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 1f4a848..d664144 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 ) diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 4a6f70b..a1f6b7a 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Serialise.hs-boot b/src/app/MetaBrush/Document/Serialise.hs-boot deleted file mode 100644 index 99a46b1..0000000 --- a/src/app/MetaBrush/Document/Serialise.hs-boot +++ /dev/null @@ -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 ) diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs index 6023d40..09549cd 100644 --- a/src/app/MetaBrush/Document/SubdivideStroke.hs +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -64,7 +64,7 @@ import MetaBrush.Document , PointData(..), DiffPointData(..) , coords, _strokeSpline ) -import MetaBrush.MetaParameter.Interpolation +import MetaBrush.DSL.Interpolation ( Interpolatable(Diff) ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs index 48e95c9..71c48e1 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/src/app/MetaBrush/Document/Update.hs @@ -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 ) ) diff --git a/src/app/MetaBrush/Util.hs b/src/app/MetaBrush/GTK/Util.hs similarity index 79% rename from src/app/MetaBrush/Util.hs rename to src/app/MetaBrush/GTK/Util.hs index 5cc8dea..952ec28 100644 --- a/src/app/MetaBrush/Util.hs +++ b/src/app/MetaBrush/GTK/Util.hs @@ -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 diff --git a/src/app/MetaBrush/MetaParameter/Interpolation.hs b/src/app/MetaBrush/MetaParameter/Interpolation.hs deleted file mode 100644 index 0c4b182..0000000 --- a/src/app/MetaBrush/MetaParameter/Interpolation.hs +++ /dev/null @@ -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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 221c8d7..9273439 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Render/Rulers.hs b/src/app/MetaBrush/Render/Rulers.hs index c745920..e0137f7 100644 --- a/src/app/MetaBrush/Render/Rulers.hs +++ b/src/app/MetaBrush/Render/Rulers.hs @@ -70,7 +70,7 @@ import MetaBrush.UI.Viewport ( Ruler(..) ) import MetaBrush.Unique ( unsafeUnique ) -import MetaBrush.Util +import MetaBrush.GTK.Util ( withRGBA ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index e059df1..e8b9f44 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -72,7 +72,7 @@ import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Unique ( Unique, freshUnique, uniqueText ) -import MetaBrush.Util +import MetaBrush.GTK.Util ( widgetAddClass, widgetAddClasses ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index c2c029e..62f4d18 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -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 () diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 25e56e9..37b503b 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -55,7 +55,7 @@ import MetaBrush.Document ( Document(..) ) import MetaBrush.UI.Coordinates ( toViewportCoordinates ) -import MetaBrush.Util +import MetaBrush.GTK.Util ( widgetAddClass, widgetAddClasses ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index fc60770..fe30e34 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -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. diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 6507f9c..1dea548 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -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 diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index 9307368..d469d04 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -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 ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 22cebc3..5ed587b 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -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 diff --git a/src/app/MetaBrush/Assert.hs b/src/metabrushes/MetaBrush/Assert.hs similarity index 100% rename from src/app/MetaBrush/Assert.hs rename to src/metabrushes/MetaBrush/Assert.hs diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs new file mode 100644 index 0000000..fabb338 --- /dev/null +++ b/src/metabrushes/MetaBrush/Brush.hs @@ -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 diff --git a/src/app/MetaBrush/MetaParameter/AST.hs b/src/metabrushes/MetaBrush/DSL/AST.hs similarity index 51% rename from src/app/MetaBrush/MetaParameter/AST.hs rename to src/metabrushes/MetaBrush/DSL/AST.hs index 9cd6c91..832fec5 100644 --- a/src/app/MetaBrush/MetaParameter/AST.hs +++ b/src/metabrushes/MetaBrush/DSL/AST.hs @@ -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 diff --git a/src/app/MetaBrush/MetaParameter/Driver.hs b/src/metabrushes/MetaBrush/DSL/Driver.hs similarity index 89% rename from src/app/MetaBrush/MetaParameter/Driver.hs rename to src/metabrushes/MetaBrush/DSL/Driver.hs index 18e29a8..56f49f6 100644 --- a/src/app/MetaBrush/MetaParameter/Driver.hs +++ b/src/metabrushes/MetaBrush/DSL/Driver.hs @@ -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 ) diff --git a/src/app/MetaBrush/MetaParameter/Eval.hs b/src/metabrushes/MetaBrush/DSL/Eval.hs similarity index 72% rename from src/app/MetaBrush/MetaParameter/Eval.hs rename to src/metabrushes/MetaBrush/DSL/Eval.hs index 5c49dbc..f97069f 100644 --- a/src/app/MetaBrush/MetaParameter/Eval.hs +++ b/src/metabrushes/MetaBrush/DSL/Eval.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/DSL/Interpolation.hs b/src/metabrushes/MetaBrush/DSL/Interpolation.hs new file mode 100644 index 0000000..10d6193 --- /dev/null +++ b/src/metabrushes/MetaBrush/DSL/Interpolation.hs @@ -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 diff --git a/src/app/MetaBrush/MetaParameter/Parse.hs b/src/metabrushes/MetaBrush/DSL/Parse.hs similarity index 98% rename from src/app/MetaBrush/MetaParameter/Parse.hs rename to src/metabrushes/MetaBrush/DSL/Parse.hs index d673ab2..3991fca 100644 --- a/src/app/MetaBrush/MetaParameter/Parse.hs +++ b/src/metabrushes/MetaBrush/DSL/Parse.hs @@ -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''' ) diff --git a/src/app/MetaBrush/MetaParameter/PrimOp.hs b/src/metabrushes/MetaBrush/DSL/PrimOp.hs similarity index 97% rename from src/app/MetaBrush/MetaParameter/PrimOp.hs rename to src/metabrushes/MetaBrush/DSL/PrimOp.hs index af0b983..a1f6cc6 100644 --- a/src/app/MetaBrush/MetaParameter/PrimOp.hs +++ b/src/metabrushes/MetaBrush/DSL/PrimOp.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -module MetaBrush.MetaParameter.PrimOp where +module MetaBrush.DSL.PrimOp where -- MetaBrush import Math.Bezier.Spline diff --git a/src/app/MetaBrush/MetaParameter/Rename.hs b/src/metabrushes/MetaBrush/DSL/Rename.hs similarity index 98% rename from src/app/MetaBrush/MetaParameter/Rename.hs rename to src/metabrushes/MetaBrush/DSL/Rename.hs index 3b2b26b..fcc5590 100644 --- a/src/app/MetaBrush/MetaParameter/Rename.hs +++ b/src/metabrushes/MetaBrush/DSL/Rename.hs @@ -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) diff --git a/src/app/MetaBrush/MetaParameter/TypeCheck.hs b/src/metabrushes/MetaBrush/DSL/TypeCheck.hs similarity index 66% rename from src/app/MetaBrush/MetaParameter/TypeCheck.hs rename to src/metabrushes/MetaBrush/DSL/TypeCheck.hs index 17e1400..b80eb8f 100644 --- a/src/app/MetaBrush/MetaParameter/TypeCheck.hs +++ b/src/metabrushes/MetaBrush/DSL/TypeCheck.hs @@ -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. diff --git a/src/metabrushes/MetaBrush/DSL/Types.hs b/src/metabrushes/MetaBrush/DSL/Types.hs new file mode 100644 index 0000000..ca8b8c8 --- /dev/null +++ b/src/metabrushes/MetaBrush/DSL/Types.hs @@ -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 ) diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs new file mode 100644 index 0000000..9af215b --- /dev/null +++ b/src/metabrushes/MetaBrush/Records.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Serialisable.hs b/src/metabrushes/MetaBrush/Serialisable.hs new file mode 100644 index 0000000..0056aaa --- /dev/null +++ b/src/metabrushes/MetaBrush/Serialisable.hs @@ -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 } ) diff --git a/src/app/MetaBrush/Unique.hs b/src/metabrushes/MetaBrush/Unique.hs similarity index 100% rename from src/app/MetaBrush/Unique.hs rename to src/metabrushes/MetaBrush/Unique.hs diff --git a/src/metabrushes/MetaBrush/Util.hs b/src/metabrushes/MetaBrush/Util.hs new file mode 100644 index 0000000..d143dd7 --- /dev/null +++ b/src/metabrushes/MetaBrush/Util.hs @@ -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 diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/splines/Math/Bezier/Cubic.hs similarity index 98% rename from src/lib/Math/Bezier/Cubic.hs rename to src/splines/Math/Bezier/Cubic.hs index 0f392a8..429c14a 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/splines/Math/Bezier/Cubic.hs @@ -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 ) diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/splines/Math/Bezier/Cubic/Fit.hs similarity index 100% rename from src/lib/Math/Bezier/Cubic/Fit.hs rename to src/splines/Math/Bezier/Cubic/Fit.hs diff --git a/src/lib/Math/Bezier/Envelope.hs b/src/splines/Math/Bezier/Envelope.hs similarity index 100% rename from src/lib/Math/Bezier/Envelope.hs rename to src/splines/Math/Bezier/Envelope.hs diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/splines/Math/Bezier/Quadratic.hs similarity index 97% rename from src/lib/Math/Bezier/Quadratic.hs rename to src/splines/Math/Bezier/Quadratic.hs index f3f7f76..f805b1b 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/splines/Math/Bezier/Quadratic.hs @@ -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 ) diff --git a/src/lib/Math/Bezier/Spline.hs b/src/splines/Math/Bezier/Spline.hs similarity index 99% rename from src/lib/Math/Bezier/Spline.hs rename to src/splines/Math/Bezier/Spline.hs index 07e6feb..2b4be12 100644 --- a/src/lib/Math/Bezier/Spline.hs +++ b/src/splines/Math/Bezier/Spline.hs @@ -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' ) diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/splines/Math/Bezier/Stroke.hs similarity index 99% rename from src/lib/Math/Bezier/Stroke.hs rename to src/splines/Math/Bezier/Stroke.hs index 0ea95e9..4ad5bcd 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/splines/Math/Bezier/Stroke.hs @@ -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 diff --git a/src/lib/Math/Epsilon.hs b/src/splines/Math/Epsilon.hs similarity index 100% rename from src/lib/Math/Epsilon.hs rename to src/splines/Math/Epsilon.hs diff --git a/src/lib/Math/Linear/Solve.hs b/src/splines/Math/Linear/Solve.hs similarity index 100% rename from src/lib/Math/Linear/Solve.hs rename to src/splines/Math/Linear/Solve.hs diff --git a/src/splines/Math/MPoly.hs b/src/splines/Math/MPoly.hs new file mode 100644 index 0000000..0efe206 --- /dev/null +++ b/src/splines/Math/MPoly.hs @@ -0,0 +1 @@ +module Math.MPoly where \ No newline at end of file diff --git a/src/lib/Math/Module.hs b/src/splines/Math/Module.hs similarity index 100% rename from src/lib/Math/Module.hs rename to src/splines/Math/Module.hs diff --git a/src/lib/Math/Orientation.hs b/src/splines/Math/Orientation.hs similarity index 99% rename from src/lib/Math/Orientation.hs rename to src/splines/Math/Orientation.hs index bab531e..031a8b7 100644 --- a/src/lib/Math/Orientation.hs +++ b/src/splines/Math/Orientation.hs @@ -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 diff --git a/src/lib/Math/Roots.hs b/src/splines/Math/Roots.hs similarity index 100% rename from src/lib/Math/Roots.hs rename to src/splines/Math/Roots.hs diff --git a/src/lib/Math/Vector2D.hs b/src/splines/Math/Vector2D.hs similarity index 91% rename from src/lib/Math/Vector2D.hs rename to src/splines/Math/Vector2D.hs index 555d435..5b7ddc6 100644 --- a/src/lib/Math/Vector2D.hs +++ b/src/splines/Math/Vector2D.hs @@ -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 )