kill off brush EDSL

MetaBrush.cabal

@@ -170,14 +170,7 @@ library metabrushes
       , MetaBrush.Document.History
       , MetaBrush.Document.Serialise
       , MetaBrush.Document.SubdivideStroke
-      , 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

src/app/MetaBrush/Application.hs

@@ -155,7 +155,6 @@ runApplication application = do
 
   uniqueSupply <- newUniqueSupply
 
-  ellipseBrush <- Asset.Brushes.ellipse uniqueSupply
   docUnique    <- runReaderT freshUnique uniqueSupply
   strokeUnique <- runReaderT freshUnique uniqueSupply
 
@@ -170,7 +169,7 @@ runApplication application = do
             { strokeName    = "Stroke 1"
             , strokeVisible = True
             , strokeUnique  = strokeUnique
-            , strokeBrush   = Just ellipseBrush
+            , strokeBrush   = Just Asset.Brushes.ellipse
             , strokeSpline  =
               Spline
                 { splineStart  = mkPoint ( Point2D 10 -20 ) 2 1 0
@@ -189,6 +188,7 @@ runApplication application = do
           mkPoint pt a b phi = PointData pt Normal
             ( 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 () )
   activeDocumentTVar   <- STM.newTVarIO @( Maybe Unique )                        Nothing

src/metabrushes/MetaBrush/Asset/Brushes.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE NamedFieldPuns      #-}
@@ -9,144 +10,88 @@
 
 module MetaBrush.Asset.Brushes where
 
--- base
+-- containers
-import Data.Kind
+import qualified Data.Sequence as Seq
-  ( Type )
+  ( fromList )
-import Data.Type.Equality
-  ( (:~:)(Refl) )
-import GHC.TypeLits
-  ( Symbol )
 
 -- text
 import Data.Text
   ( Text )
-import qualified Data.Text as Text
+
-  ( unpack )
+-- unordered-containers
+import Data.HashMap.Strict
+  ( HashMap )
+import qualified Data.HashMap.Strict as HashMap
+  ( fromList, lookup )
 
 -- MetaBrush
+import Math.Bezier.Spline
+import Math.Vector2D
 import MetaBrush.Brush
-  ( Brush(..), BrushFunction )
+  ( Brush(..), SomeBrush(..) )
-import MetaBrush.DSL.Types
+import MetaBrush.Records
-  ( STypesI(..), eqTys
+  ( Rec, WithParams(..), I(..) )
-  )
+import qualified MetaBrush.Records as Rec
-import MetaBrush.DSL.Driver
-  ( SomeBrushFunction(..)
-  , interpretBrush
-  )
-import MetaBrush.Unique
-  ( UniqueSupply )
 
 --------------------------------------------------------------------------------
 
 type CircleBrushFields = '[ '("r", Double) ]
 
-circle :: UniqueSupply -> IO ( Brush CircleBrushFields )
+lookupBrush :: Text -> Maybe SomeBrush
-circle uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code
+lookupBrush nm = HashMap.lookup nm brushes
-  where
-    name, code :: Text
-    name = "Circle"
-    code =
-     "with\n\
-     \  r = 1\n\
-     \satisfying\n\
-     \  r > 0\n\
-     \define\n\
-     \  let c = kappa in\n\
-     \  [ (r,0) -- ( r  , r*c) -- ( r*c, r  ) -> ( 0, r)\n\
-     \          -- (-r*c, r  ) -- (-r  , r*c) -> (-r, 0)\n\
-     \          -- (-r  ,-r*c) -- (-r*c,-r  ) -> ( 0,-r)\n\
-     \          -- ( r*c,-r  ) -- ( r  ,-r*c) ->   .   ]"
 
-circleCW :: UniqueSupply -> IO ( Brush CircleBrushFields )
+-- | All brushes supported by this application.
-circleCW uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code
+brushes :: HashMap Text SomeBrush
+brushes = HashMap.fromList
+  [ ( nm, b )
+  | b@( SomeBrush ( BrushData { brushName = nm } ) )
+    <- [ SomeBrush circle, SomeBrush ellipse ]
+  ]
+
+-- | Root of @(Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]@.
+--
+-- Used to approximate circles and ellipses with Bézier curves.
+c :: Double
+c = 0.5519150244935105707435627227925
+
+circleSpline :: (Double -> Double -> ptData) -> Spline 'Closed () ptData
+circleSpline p =
+  Spline { splineStart  = p 1 0
+         , splineCurves = ClosedCurves crvs lastCrv }
   where
-    name, code :: Text
+    crvs = Seq.fromList
-    name = "Circle CW"
+      [ Bezier3To (p   1    c)  (p   c    1 ) (NextPoint (p   0    1 )) ()
-    code =
+      , Bezier3To (p (-c)   1)  (p (-1)   c ) (NextPoint (p (-1)   0 )) ()
-     "with\n\
+      , Bezier3To (p (-1) (-c)) (p (-c) (-1)) (NextPoint (p   0  (-1))) ()
-     \  r = 1\n\
+      ]
-     \satisfying\n\
+    lastCrv =
-     \  r > 0\n\
+        Bezier3To (p   c  (-1)) (p   1  (-c)) BackToStart ()
-     \define\n\
+
-     \  let c = kappa in\n\
+circle :: Brush CircleBrushFields
-     \  [ (r,0) -- ( r  ,-r*c) -- ( r*c,-r  ) -> ( 0,-r)\n\
+circle = BrushData "circle" (WithParams deflts shape)
-     \          -- (-r*c,-r  ) -- (-r  ,-r*c) -> (-r, 0)\n\
+  where
-     \          -- (-r  , r*c) -- (-r*c, r  ) -> ( 0, r)\n\
+    deflts :: Rec CircleBrushFields
-     \          -- ( r*c, r  ) -- ( r  , r*c) ->   .   ]"
+    deflts = Rec.insert @"r" (I 1) Rec.empty
+    shape :: Rec CircleBrushFields -> SplinePts 'Closed
+    shape params =
+      let !(I !r) = Rec.lookup @"r" params
+      in circleSpline ( \ x y -> Point2D (r * x) (r * y) )
 
 type EllipseBrushFields = '[ '("a", Double), '("b", Double), '("phi", Double) ]
 
-ellipse :: UniqueSupply -> IO ( Brush EllipseBrushFields )
+ellipse :: Brush EllipseBrushFields
-ellipse uniqueSupply = mkBrush @EllipseBrushFields uniqueSupply name code
+ellipse = BrushData "ellipse" (WithParams deflts shape)
   where
-    name, code :: Text
+    deflts :: Rec EllipseBrushFields
-    name = "Ellipse"
+    deflts = Rec.insert @"a"   (I 1)
-    code =
+           $ Rec.insert @"b"   (I 1)
-     "with\n\
+           $ Rec.insert @"phi" (I 0)
-     \  a = 1\n\
+           $ Rec.empty
-     \  b = 1\n\
+    shape :: Rec EllipseBrushFields -> SplinePts 'Closed
-     \  phi = 0\n\
+    shape params =
-     \satisfying\n\
+      let
-     \  a > 0 && b > 0\n\
+        !(I !a  ) = Rec.lookup @"a"   params
-     \define\n\
+        !(I !b  ) = Rec.lookup @"b"   params
-     \  let\n\
+        !(I !phi) = Rec.lookup @"phi" params
-     \    c = kappa\n\
+      in circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi)
-     \    applyRotation pt = rotate pt CCW by phi\n\
+                                         (b * y * cos phi + a * x * sin phi) )
-     \  in\n\
-     \    map applyRotation over\n\
-     \      [ (a,0) -- ( a  , b*c) -- ( a*c, b  ) -> ( 0, b)\n\
-     \              -- (-a*c, b  ) -- (-a  , b*c) -> (-a, 0)\n\
-     \              -- (-a  ,-b*c) -- (-a*c,-b  ) -> ( 0,-b)\n\
-     \              -- ( a*c,-b  ) -- ( a  ,-b*c) ->   .   ]"
-
-{-
-rounded
-  :: forall roundedBrushFields
-  .  ( roundedBrushFields ~ '[ ] ) -- TODO
-  => UniqueSupply -> IO ( Brush roundedBrushFields )
-rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code
-  where
-    name, code :: Text
-    name = "Rounded quadrilateral"
-    code =
-     "with\n\
-     \  tr = (1,-2)\n\
-     \  rt = (2,-1)\n\
-     \  br = (1,2)\n\
-     \  rb = (2,1)\n\
-     \  bl = (-1,2)\n\
-     \  lb = (-2,1)\n\
-     \  tl = (-1,-2)\n\
-     \  lt = (-2,-1)\n\
-     \define\n\
-     \  let c = kappa in\n\
-     \  [ tr -- lerp c tr ( project rt onto [ tl -> tr ] ) -- lerp c rt ( project tr onto [ rb -> rt ] ) -> rt\n\
-     \                                                                                                   -> rb\n\
-     \       -- lerp c rb ( project br onto [ rt -> rb ] ) -- lerp c br ( project rb onto [ bl -> br ] ) -> br\n\
-     \                                                                                                   -> bl\n\
-     \       -- lerp c bl ( project lb onto [ br -> bl ] ) -- lerp c lb ( project bl onto [ lt -> lb ] ) -> lb\n\
-     \                                                                                                   -> lt\n\
-     \       -- lerp c lt ( project tl onto [ lb -> lt ] ) -- lerp c tl ( project lt onto [ tr -> tl ] ) -> tl\n\
-     \                                                                                                   -> .]"
--}
-
---------------------------------------------------------------------------------
-
-mkBrush
-  :: forall ( givenBrushFields :: [ ( Symbol, Type ) ] )
-  .  STypesI givenBrushFields
-  => UniqueSupply -> Text -> Text
-  -> IO ( Brush givenBrushFields )
-mkBrush uniqSupply brushName brushCode = do
-  ( mbBrush, _ ) <- interpretBrush uniqSupply brushCode
-  case mbBrush of
-    Left err -> error ( "Could not interpret '" <> Text.unpack brushName <> "' brush:\n" <> show err )
-    Right ( SomeBrushFunction ( brushFunction :: BrushFunction inferredBrushFields ) ) ->
-      case eqTys @givenBrushFields @inferredBrushFields of
-        Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
-        Nothing   ->
-          error
-            ( "Incorrect record type for '" <> Text.unpack brushName <> "' brush:\n\
-              \Expected: " <> show ( sTypesI @givenBrushFields ) <> "\n\
-              \  Actual: " <> show ( sTypesI @inferredBrushFields )
-            )

src/metabrushes/MetaBrush/Brush.hs

@@ -24,6 +24,8 @@ module MetaBrush.Brush
 -- base
 import Control.Arrow
   ( second )
+import Data.Proxy
+  ( Proxy(..) )
 import GHC.Exts
   ( Proxy#, Any )
 import Unsafe.Coerce
@@ -31,7 +33,7 @@ import Unsafe.Coerce
 
 -- deepseq
 import Control.DeepSeq
-  ( NFData(..), deepseq )
+  ( NFData(..) )
 
 -- hashable
 import Data.Hashable
@@ -53,7 +55,7 @@ import Math.Bezier.Spline
 import MetaBrush.Serialisable
   ( Serialisable )
 import MetaBrush.DSL.Types
-  ( STypeI, STypesI(sTypesI)
+  ( STypeI, STypesI
   , SomeSType(..), proveSomeSTypes
   )
 import MetaBrush.DSL.Interpolation
@@ -69,6 +71,7 @@ import qualified MetaBrush.Records as Rec
 
 --------------------------------------------------------------------------------
 
+-- | A brush function: a function from a record of parameters to a closed spline.
 type BrushFunction brushFields = WithParams brushFields (SplinePts Closed)
 
 data Brush brushFields where
@@ -77,7 +80,6 @@ data Brush brushFields where
     .  ( STypesI brushFields )
     =>
       { brushName     :: !Text
-      , brushCode     :: !Text
       , brushFunction :: BrushFunction brushFields
       }
     -> Brush brushFields
@@ -89,22 +91,21 @@ data SomeBrush where
     -> SomeBrush
 
 instance Show ( Brush brushFields ) where
-  show ( BrushData { brushName, brushCode } ) =
+  show ( BrushData { brushName } ) =
     "BrushData\n\
     \  { brushName = "  <> Text.unpack brushName <> "\n\
-    \  , brushCode =\n" <> Text.unpack brushCode <> "\n\
     \  }"
+
 instance NFData ( Brush brushFields ) where
-  rnf ( BrushData { brushName, brushCode } )
+  rnf ( BrushData { brushName } )
-    = deepseq brushCode
+    = rnf brushName
-    $ rnf brushName
 instance Eq ( Brush brushFields ) where
-  BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2
+  BrushData name1 _ == BrushData name2 _ = name1 == name2
 instance Ord ( Brush brushFields ) where
-  compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 )
+  compare ( BrushData name1 _ ) ( BrushData name2 _ ) = compare name1 name2
 instance Hashable ( Brush brushFields ) where
-  hashWithSalt salt ( BrushData { brushName, brushCode } ) =
+  hashWithSalt salt ( BrushData { brushName } ) =
-    hashWithSalt ( hashWithSalt salt brushName ) brushCode
+    hashWithSalt salt brushName
 
 --------------------------------------------------------------------------------
 -- Instance dictionary passing machinery.
@@ -133,7 +134,7 @@ data SomeBrushFields where
     => SomeBrushFields
 
 instance Show SomeBrushFields where
-  show ( SomeBrushFields @kvs ) = show ( sTypesI @kvs )
+  show ( SomeBrushFields @kvs ) = show ( Proxy @kvs )
 
 -- | Reflects a list of brush fields to the type level.
 --

src/metabrushes/MetaBrush/DSL/AST.hs

@@ -1,422 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes        #-}
-{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE EmptyCase                  #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE FunctionalDependencies     #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MagicHash                  #-}
-{-# LANGUAGE PatternSynonyms            #-}
-{-# LANGUAGE PolyKinds                  #-}
-{-# LANGUAGE QuantifiedConstraints      #-}
-{-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE StandaloneKindSignatures   #-}
-{-# LANGUAGE TypeApplications           #-}
-{-# LANGUAGE TypeFamilyDependencies     #-}
-{-# LANGUAGE TypeOperators              #-}
-{-# LANGUAGE UndecidableInstances       #-}
-
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-module MetaBrush.DSL.AST
-  ( Span(..), Located(.., Location)
-  , Term(..), Pat(..), Decl(..)
-  , toTreeArgsTerm, toTreeTerm, toTreePat, toTreeDecl
-  , termSpan
-  , TypedTerm(..), TypedPat(..)
-  , Pass(..), Name, UniqueName(..), Loc
-  , Ext_With(..), X_With(..)
-  , UniqueField(..), UniqueTerm(..)
-  , X_Ext(..)
-  , Expr, EPat, RnExpr, RnPat
-  )
-  where
-
--- base
-import Data.Functor.Identity
-  ( Identity(..) )
-import Data.Kind
-  ( Type, Constraint )
-import GHC.Generics
-  ( Generic )
-import GHC.TypeLits
-  ( Symbol )
-
--- containers
-import Data.Tree
- ( Tree(Node) )
-
--- deepseq
-import Control.DeepSeq
-  ( NFData(..) )
-
--- text
-import Data.Text
-  ( Text )
-
--- 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
-  ( Spline(..), SplineType(..)
-  , SSplineType(..), SplineTypeI(ssplineType), KnownSplineType(bifoldSpline)
-  , Curve(..), NextPoint(..)
-  )
-import MetaBrush.DSL.Types
-  ( STypeI(..) )
-import MetaBrush.Records
-  ( Record, WithParams, foldRec )
-import MetaBrush.Unique
-  ( Unique )
-
---------------------------------------------------------------------------------
-
----------------------
--- Source locations.
-
-data Span = Span
-  { startRow :: !Int
-  , startCol :: !Int
-  , endRow   :: !Int
-  , endCol   :: !Int
-  } deriving stock ( Eq, Ord )
-instance Show Span where
-  show ( Span sr sc er ec ) =
-    "l" <> show sr <> "c" <> show sc <> " -- " <> "l" <> show er <> "c" <> show ec
-instance Semigroup Span where
-  Span 0 0 0 0 <> s = s
-  s <> Span 0 0 0 0 = s
-  Span sr1 sc1 er1 ec1 <> Span sr2 sc2 er2 ec2
-    = case ( compare ( sr1, sc1 ) ( sr2, sc2 ), compare ( er1, ec1 ) ( er2, ec2 ) ) of
-        ( LT, LT ) -> Span sr1 sc1 er2 ec2
-        ( LT, _  ) -> Span sr1 sc1 er1 ec1
-        ( _ , LT ) -> Span sr2 sc2 er2 ec2
-        _          -> Span sr2 sc2 er1 ec1
-instance Monoid Span where
-  mempty = Span 0 0 0 0
-
-data Located a =
-  Located
-    { location :: !Span
-    , located  :: !a
-    }
-  deriving stock Show
-
-{-# COMPLETE Location #-}
-pattern Location :: Span -> Located ()
-pattern Location loc = Located loc ()
-
-------------------------------------------------
--- AST. --
-----------
-
-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
-
--- | 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 ) ]
-
--- | 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
-
--- | 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
-
-infixl 9 :$
-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 )
-        -> Term p ( T p b )
-  Var   :: { varName :: !( Loc p ( Name p ) ) }
-        -> Term p ( T p a )
-  Let   :: { let_loc   :: ![ Loc p () ]
-           , let_decls :: ![ Decl p ]
-           , let_body  :: !( Term p ( T p a ) )
-           }
-        -> Term p ( T p a )
-  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 ( WithParams kvs a ) )
-  Lit   :: ( Show a, STypeI a )
-        => !( Loc p ( Maybe Text ) )
-        -> !a
-        -> Term p ( T p a )
-  Op    :: STypeI a
-        => ![ Loc p () ] -> !Text -> a -> Term p ( T p a )
-  Point :: ( C p ( STypeI a ), pt ~ Term p ( T p ( Point2D a ) ) )
-        => ![ Loc p () ]
-        -> !( Term p ( T p a ) ) -> !( Term p ( T p a ) )
-        -> Term p ( T p ( Point2D a ) )
-  Line  :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
-        => ![ Loc p () ]
-        -> !pt -> !pt
-        -> Term p ( T p ( Segment a ) )
-  Bez2  :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
-        => ![ Loc p () ]
-        -> !pt -> !pt -> !pt
-        -> Term p ( T p ( Quadratic.Bezier a ) )
-  Bez3  :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
-        => ![ Loc p () ]
-        -> !pt -> !pt -> !pt -> !pt
-        -> Term p ( T p ( Cubic.Bezier a ) )
-  PolyBez
-     :: ( KnownSplineType clo, C p ( STypeI a ) )
-     => ![ Loc p () ]
-     -> Spline clo [ Loc p () ] ( Term p ( T p a ) )
-     -> Term p ( T p ( Spline clo () a ) )
-  CExt :: !( X_Ext p ( T p a ) ) -> Term p ( T p a )
-
-data Decl ( p :: Pass ) where
-  ValDecl
-    :: C p ( STypeI a )
-    => !( Pat p ( T p a ) )
-    -> !( Loc p () )
-    -> !( Term p ( T p a ) )
-    -> Decl p
-  FunDecl
-    :: ( C p ( STypeI a ), C p ( STypeI b ) )
-    => !( Loc p ( Name p ) )
-    -> !( Pat p ( T p a ) )
-    -> !( Loc p () )
-    -> !( Term p ( T p b ) )
-    -> Decl p
-
-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 () ]
-         -> !( Pat p ( T p a ) )
-         -> !( Pat p ( T p a ) )
-         -> Pat p ( T p ( Point2D a ) )
-  PWild :: { wildName :: !( Loc p Text ) }
-        -> Pat p ( T p a )
-  AsPat :: { atSymbol  :: !( Loc p () )
-           , asPatName :: !( Loc p ( Name p ) )
-           , asPat     :: !( Pat p ( T p a ) )
-           }
-        -> Pat p ( T p a )
-
-type Expr = Term  P '()
-type EPat = Pat   P '()
-
-type RnExpr = Term  Rn '()
-type RnPat  = Pat   Rn '()
-
-data TypedTerm where
-  TypedTerm :: STypeI a => Term Tc a -> TypedTerm
-
-data TypedPat where
-  TypedPat :: STypeI a => Pat Tc a -> TypedPat
-
----------------------
--- Extension fields
-
-data UniqueName
-  = UniqueName
-  { occName    :: !Text
-  , nameUnique :: !Unique
-  }
-  deriving stock ( Show, Generic )
-
-type family   Name ( p :: Pass ) :: Type
-type instance Name   P   = Text
-type instance Name   Rn  = UniqueName
-type instance Name   Tc  = UniqueName
-
-type family   Loc  ( p :: Pass ) ( a :: Type ) :: Type
-type instance Loc p a = Located a
-
-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 :: 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 ]
-  toTreeWith ( P_With decls ) = map toTreeDecl decls
-
-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 :: Record UniqueTerm kvs -> X_With Tc kvs
-  toTreeWith ( Tc_With decls ) =
-    foldRec
-      ( \ ( UniqueTerm { uniqueTerm = a } ) rest -> toTreeTerm @Tc a : rest )
-      decls
-      []
-
-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
-  toTreeArgsExt :: [ Tree String ] -> X_Ext p a -> Tree String
-
-instance Ext P a where
-  data instance X_Ext P  a
-  toTreeArgsExt _ x = case x of {}
-
-instance Ext Rn a where
-  data instance X_Ext Rn a
-  toTreeArgsExt _ x = case x of {}
-
-instance Ext Tc a where
-  newtype instance X_Ext Tc a = Val a
-    deriving stock   ( Generic, Show )
-    deriving newtype NFData
-  toTreeArgsExt as ( Val _ ) = Node "Value..." as
-
-
-------------------------------------------------
--- Printing AST. --
--------------------
-
-termSpan :: Term p a -> Span
-termSpan ( f :$ a )                = termSpan f <> termSpan a
-termSpan ( Var ( Located l _ ) )   = l
-termSpan ( Let locs _ body )       = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
-termSpan ( With locs _ _ body )    = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
-termSpan ( Lit ( Located l _ ) _ ) = l
-termSpan ( Op locs _ _ )           = foldMap ( \ ( Located l _ ) -> l ) locs
-termSpan ( Point locs x y )        = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan x <> termSpan y
-termSpan ( Line locs _ _ )         = foldMap ( \ ( Located l _ ) -> l ) locs
-termSpan ( Bez2 locs _ _ _ )       = foldMap ( \ ( Located l _ ) -> l ) locs
-termSpan ( Bez3 locs _ _ _ _ )     = foldMap ( \ ( Located l _ ) -> l ) locs
-termSpan ( PolyBez locs _ )        = foldMap ( \ ( Located l _ ) -> l ) locs
-termSpan ( CExt _ )                = mempty
-
-
-toTreeTerm
-  :: forall ( p :: Pass ) ( a :: K p )
-  .  ( Show ( Name p ), forall x. Ext p x, forall kvs. Ext_With p kvs )
-  => Term p a
-  -> Tree String
-toTreeTerm = toTreeArgsTerm @p @a []
-
-toTreeArgsTerm
-  :: forall ( p :: Pass ) ( a :: K p )
-  .  ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Kvs p). Ext_With p kvs )
-  => [ Tree String ]
-  -> Term p a
-  -> Tree String
-toTreeArgsTerm as ( f :$ a )       = toTreeArgsTerm ( toTreeTerm a : as ) f
-toTreeArgsTerm as ( Op    _ nm _ ) = Node ( "Op " <> show nm ) as
-toTreeArgsTerm as ( Var  nm      ) = Node ( "Var " <> show nm ) as
-toTreeArgsTerm as ( Lit  loc a   ) =
-  case loc of
-    Located l Nothing     -> Node ( "Lit " <> show ( Located l a  ) ) as
-    Located l ( Just nm ) -> Node ( "Lit " <> show ( Located l nm ) ) as
-toTreeArgsTerm as ( Point   _ p1 p2       ) = Node "(,)"  ( toTreeTerm p1 : toTreeTerm p2 : as )
-toTreeArgsTerm as ( Line    _ p0 p1       ) = Node "Line" ( toTreeTerm p0 : toTreeTerm p1 : as )
-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 ] @_ )
-        ( const ( toTreeCurve @p ) )
-        ( Identity . (:[]) . toTreeTerm )
-      spline)
-  <> as
-  )
-toTreeArgsTerm as ( Let _ ds a ) =
-  Node "Let"
-    ( Node "Decls" ( map ( toTreeDecl @p ) ds )
-    : Node "In"    [ toTreeTerm a ]
-    : as
-    )
-toTreeArgsTerm as ( With _ args conds body ) =
-  Node "With"
-    ( Node "Params" ( toTreeWith @p args )
-    : Node "Conds"  ( map toTreeTerm conds )
-    : Node "Define" [ toTreeTerm body ]
-    : as
-    )
-toTreeArgsTerm as ( CExt ext ) = toTreeArgsExt as ext
-
-toTreeDecl
-  :: forall ( p :: Pass )
-  .  ( 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 ]
-toTreeDecl ( FunDecl nm arg _ rhs ) = Node "(=)" [ Node ( show nm ) [ toTreePat arg ], toTreeTerm rhs ]
-
-toTreePat :: Show ( Name p ) => Pat p a -> Tree String
-toTreePat ( PName   nm       ) = Node ( show nm ) [ ]
-toTreePat ( PPoint  _  pl pr ) = Node "(_,_)"     [ toTreePat pl, toTreePat pr ]
-toTreePat ( PWild   nm       ) = Node ( show nm ) [ ]
-toTreePat ( AsPat _ nm pat   ) = Node "(@)"       [ Node ( show nm ) [], toTreePat pat ]
-
-toTreeCurve
-  :: forall ( p :: Pass ) ( clo :: SplineType ) ( crvData :: Type ) ( a :: K p )
-  .  ( 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
-  SOpen -> case curve of
-    ( LineTo          ( NextPoint p1 ) _ ) -> Node "LineTo"    [ toTreeTerm p1 ]
-    ( Bezier2To p1    ( NextPoint p2 ) _ ) -> Node "Bezier2To" [ toTreeTerm p1, toTreeTerm p2 ]
-    ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, toTreeTerm p3 ]
-  SClosed -> case curve of
-    ( LineTo          BackToStart _ ) -> Node "LineTo"    [ Node "cycle" [] ]
-    ( Bezier2To p1    BackToStart _ ) -> Node "Bezier2To" [ toTreeTerm p1, Node "cycle" [] ]
-    ( Bezier3To p1 p2 BackToStart _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, Node "cycle" [] ]

src/metabrushes/MetaBrush/DSL/Driver.hs

@@ -1,151 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE MagicHash             #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications      #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module MetaBrush.DSL.Driver where
-
--- dlist
-import qualified Data.DList as DList
-  ( toList )
-
--- Earley
-import qualified Text.Earley as Earley
-  ( Report(..), fullParses, parser )
-
--- text
-import Data.Text
-  ( Text )
-
--- transformers
-import Control.Monad.Trans.Except
-  ( runExceptT )
-import Control.Monad.Trans.Reader
-  ( runReaderT )
-import Control.Monad.Trans.RWS.CPS
-  ( runRWST )
-import Control.Monad.Trans.State.Strict
-  ( evalState )
-
--- MetaBrush
-import Math.Bezier.Spline
-  ( SplinePts, SSplineType(SClosed), SplineTypeI(ssplineType) )
-import MetaBrush.Brush
-  ( BrushFunction )
-import MetaBrush.DSL.AST
-  ( Located
-  , Term, TypedTerm(..)
-  , Pass(Tc)
-  )
-import MetaBrush.DSL.Types
-  ( SType(..), STypeI(sTypeI)
-  , SomeSType(..), STypesI
-  )
-import MetaBrush.DSL.Eval
-  ( EvalState(..), eval )
-import MetaBrush.DSL.Parse
-  ( grammar, Token, tokenize )
-import MetaBrush.DSL.Rename
-  ( rename, RnM, RnMessage, RnError, emptyRnState )
-import MetaBrush.DSL.TypeCheck
-  ( typeCheck, TcM, TcMessage, TcError, emptyTcState )
-import MetaBrush.Records
-  ( WithParams )
-import MetaBrush.Unique
-  ( UniqueSupply, MonadUnique(freshUnique) )
-
---------------------------------------------------------------------------------
-
-#if !MIN_VERSION_mtl(2,3,0)
--- mtl
-import Control.Monad.Reader
-  ( MonadReader(..) )
-import Control.Monad.State
-  ( MonadState(..) )
-import Control.Monad.Writer
-  ( MonadWriter(..) )
-
--- transformers
-import qualified Control.Monad.Trans.RWS.CPS as CPSRWS
-
-instance ( Monad m, Monoid w ) => MonadReader r ( CPSRWS.RWST r w s m ) where
-  ask    = CPSRWS.ask
-  local  = CPSRWS.local
-  reader = CPSRWS.reader
-
-instance ( Monad m, Monoid w ) => MonadState  s ( CPSRWS.RWST r w s m ) where
-  get   = CPSRWS.get
-  put   = CPSRWS.put
-  state = CPSRWS.state
-
-instance ( Monoid w, Monad m ) => MonadWriter w ( CPSRWS.RWST r w s m ) where
-  writer = CPSRWS.writer
-  tell   = CPSRWS.tell
-  listen = CPSRWS.listen
-  pass   = CPSRWS.pass
-#endif
-
-data DriverError
-  = ParseError     !( Earley.Report Text [ Located Token ] )
-  | RenameError    !RnError
-  | TypeCheckError !TcError
-  | NonBrushType   !SomeSType
-  deriving stock Show
-
-data DriverMessage
-  = RenameMessage    !RnMessage
-  | TypeCheckMessage !TcMessage
-
-data SomeBrushFunction where
-  SomeBrushFunction
-    :: forall brushParams
-    .  ( STypesI brushParams )
-    => BrushFunction brushParams
-    -> SomeBrushFunction
-
-interpretBrush
-  :: UniqueSupply
-  -> Text
-  -> IO
-      ( Either DriverError SomeBrushFunction
-      , [ DriverMessage ]
-      )
-interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser grammar ) $ tokenize sourceText of
-  ( [], parserReport )  -> pure ( Left ( ParseError parserReport ), [] )
-  ( parsedExpr : _, _ ) -> do
-    ( renamedExpr, _, rnMessages ) <- runRWST              ( rename    @RnM  parsedExpr ) uniqSupply emptyRnState
-    ( tcResult   , _, tcMessages ) <- runRWST ( runExceptT $ typeCheck @TcM renamedExpr ) uniqSupply emptyTcState
-    let
-      messages :: [ DriverMessage ]
-      messages = DList.toList ( fmap RenameMessage rnMessages <> fmap TypeCheckMessage tcMessages )
-    case tcResult of
-      Left err -> pure ( Left ( TypeCheckError err ), messages )
-      -- Type checking succeeded: check that the type of the given program
-      -- is indeed a function that takes in a record of parameters and returns
-      -- a closed brush shape.
-      Right ( TypedTerm ( term :: Term Tc v ) )
-        | sTyWithFn@STyWithFn <- sTypeI @v
-        , ( _ :: SType ( WithParams kvs b ) ) <- sTyWithFn
-        , sTySpline@STySpline <- sTypeI @b
-        , ( _ :: SType ( SplinePts clo ) ) <- sTySpline
-        , SClosed <- ssplineType @clo
-        -> do
-          uniq <- ( `runReaderT` uniqSupply ) freshUnique
-          let
-            initEvalState :: EvalState
-            initEvalState =
-              EvalState { evalHeap = mempty, nextUnique = uniq }
-            val :: BrushFunction kvs
-            val = ( `evalState` initEvalState ) $ eval term
-          pure ( Right ( SomeBrushFunction @kvs val ), messages )
-        | otherwise
-        -> pure ( Left ( NonBrushType ( SomeSType @v ) ), messages )

src/metabrushes/MetaBrush/DSL/Eval.hs

@@ -1,251 +0,0 @@
-{-# LANGUAGE ApplicativeDo         #-}
-{-# LANGUAGE BlockArguments        #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE UndecidableInstances  #-}
-
-module MetaBrush.DSL.Eval
-  ( EvalState(..), eval )
-  where
-
--- base
-import Data.Foldable
-  ( for_, traverse_ )
-import Data.Type.Equality
-  ( (:~:)(Refl) )
-import GHC.Generics
-  ( Generic )
-
--- containers
-import Data.Map
-  ( Map )
-import qualified Data.Map.Strict as Map
-  ( insert, lookup, union, fromList )
-
--- generic-lens
-import Data.Generics.Product.Fields
-  ( field' )
-
--- lens
-import Control.Lens
-  ( assign, modifying, use )
-
--- mtl
-import Control.Monad.State
-  ( get )
-
--- text
-import Data.Text
-  ( Text )
-import qualified Data.Text as Text
-  ( pack )
-
--- transformers
-import Control.Monad.Trans.State.Strict
-  ( State, evalState )
-
--- MetaBrush
-import qualified Math.Bezier.Cubic     as Cubic
-  ( Bezier(..) )
-import qualified Math.Bezier.Quadratic as Quadratic
-  ( Bezier(..) )
-import Math.Bezier.Spline
-  ( KnownSplineType(bitraverseSpline), bitraverseCurve )
-import Math.Vector2D
-  ( Point2D(..), Segment(..) )
-import MetaBrush.DSL.AST
-  ( Term(..), Pat(..), Decl(..)
-  , TypedTerm(..)
-  , Pass(Tc), X_Ext(..), X_With(..)
-  , Span(..), Located(..)
-  , UniqueField(..), UniqueTerm(..)
-  )
-import MetaBrush.DSL.Types
-  ( STypeI(..), SType(..)
-  , eqTy
-  )
-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 )
-
---------------------------------------------------------------------------------
-
-data EvalState
-  = EvalState
-  { evalHeap   :: !( Map Unique TypedTerm )
-  , nextUnique :: !Unique
-  }
-  deriving stock Generic
-
-eval :: forall a. STypeI a => Term Tc a -> State EvalState a
-eval ( f :$ a )           = eval f <*> eval a
-eval ( Lit _ x )          = pure x
-eval ( Op _ _ f )         = pure f
-eval ( Point _ x y )      = Point2D <$> eval x <*> eval y
-eval ( Line _ p q )       = Segment <$> eval p <*> eval q
-eval ( Bez2 _ p q r )     = Quadratic.Bezier <$> eval p <*> eval q <*> eval r
-eval ( Bez3 _ p q r s )   = Cubic.Bezier <$> eval p <*> eval q <*> eval r <*> eval s
-eval ( PolyBez _ spline ) =
-  bitraverseSpline
-    ( const $ bitraverseCurve ( const $ pure () ) ( const eval ) )
-    eval
-    spline
-eval ( Let _ decls a ) = traverse_ declare decls *> eval a
-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
-    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 brushUniqParams evalHeap
-      in
-        ( `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
-        res <- eval r
-        modifying ( field' @"evalHeap" )
-          ( Map.insert varUniq ( TypedTerm $ CExt @Tc @a ( Val res ) ) )
-        pure res
-      | otherwise
-      -> error
-          ( "eval: unexpected type of variable read from environment.\n\
-            \Expected: " <> show ( sTypeI @a ) <> "\n\
-            \  Actual: " <> show ( sTypeI @b )
-          )
-eval ( CExt ( Val v ) ) = pure v
-
-declare :: Decl Tc -> State EvalState ( Maybe UniqueName )
-declare ( ValDecl pat _ t ) =
-  declareVal pat t
-declare ( FunDecl ( Located { located = nm } ) args _ t ) =
-  Just <$> declareFun nm args t
-
-declareVal :: forall a. STypeI a => Pat Tc a -> Term Tc a -> State EvalState ( Maybe UniqueName )
-declareVal ( PName ( Located { located = patUniqName@( UniqueName { nameUnique = patUniq } ) } ) ) r = do
-  modifying ( field' @"evalHeap" )
-    ( Map.insert patUniq $ TypedTerm r )
-  pure ( Just patUniqName )
-declareVal ( PPoint _ lpat rpat ) r = do
-  case sTypeI @a of
-    sTyPoint@STyPoint
-      | ( _ :: SType ( Point2D x ) ) <- sTyPoint
-      -> do
-      nextUnique <- use ( field' @"nextUnique" )
-      let
-        uniq1, uniq2, uniq3, nextUnique' :: Unique
-        uniq1       = nextUnique
-        uniq2       = succ uniq1
-        uniq3       = succ uniq2
-        nextUnique' = succ uniq3
-      assign ( field' @"nextUnique" ) nextUnique'
-      let
-        pairText :: Text
-        pairText = "$pair%" <> Text.pack ( show uniq1 )
-        pairName, fstName, sndName :: UniqueName
-        pairName = UniqueName pairText               uniq1
-        fstName  = UniqueName ( pairText <> "$fst" ) uniq2
-        sndName  = UniqueName ( pairText <> "$snd" ) uniq3
-        var_l, var_r :: Term Tc x
-        var_l = Var ( Located noSpan fstName )
-        var_r = Var ( Located noSpan sndName )
-      modifying ( field' @"evalHeap" )
-        ( Map.union
-        $ Map.fromList
-            [ ( uniq1, TypedTerm $ Point [] var_l var_r )
-            , ( uniq2, TypedTerm $ ( Op @( a -> x ) [] "fst" ( \ ~( Point2D x _ ) -> x ) ) :$ r )
-            , ( uniq3, TypedTerm $ ( Op @( a -> x ) [] "snd" ( \ ~( Point2D _ y ) -> y ) ) :$ r )
-            ]
-        )
-      _ <- declareVal lpat var_l
-      _ <- declareVal rpat var_r
-      pure ( Just pairName )
-declareVal ( AsPat _ ( Located { located = asUniqName@( UniqueName { nameUnique = asUniq } ) } ) patt ) r = do
-  mbNm <- declareVal patt r
-  for_ mbNm \ nm ->
-    modifying ( field' @"evalHeap" )
-      ( Map.insert asUniq ( TypedTerm $ Var @Tc @a ( Located noSpan nm ) ) )
-  pure ( Just asUniqName )
-declareVal ( PWild _ ) _ = pure Nothing
-
-declareFun
-  :: forall a b. ( STypeI a, STypeI b )
-  => UniqueName -> Pat Tc a -> Term Tc b -> State EvalState UniqueName
-declareFun uniq@( UniqueName { nameUnique = funUnique } ) argPat rhs = do
-  st <- get
-  let
-    fun :: a -> b
-    fun arg = ( `evalState` st ) do
-      _ <- declareVal argPat ( CExt @Tc @a ( Val arg ) )
-      eval rhs
-  modifying ( field' @"evalHeap" )
-    ( Map.insert funUnique ( TypedTerm $ CExt @Tc @( a -> b ) ( Val fun ) ) )
-  pure uniq
-
-bindRecordValues
-  :: forall brushFields
-  .  Record UniqueField brushFields
-  -> Map Unique TypedTerm
-  -> Map Unique TypedTerm
-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

src/metabrushes/MetaBrush/DSL/Parse.hs

@@ -1,791 +0,0 @@
-{-# LANGUAGE ApplicativeDo         #-}
-{-# LANGUAGE BlockArguments        #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE RecursiveDo           #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies          #-}
-
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-
-module MetaBrush.DSL.Parse where
-
--- base
-import Control.Applicative
-  ( Alternative
-    ( (<|>), some, many )
-  , optional
-  )
-import Control.Category
-  ( (>>>) )
-import Control.Monad
-  ( void )
-import qualified Data.Char as Char
-  ( isAlpha, isAlphaNum, isDigit, isSpace, isSymbol, isPunctuation, toLower )
-import Data.Foldable
-  ( for_ )
-
--- containers
-import Data.Set
-  ( Set )
-import qualified Data.Set as Set
-  ( member, fromList )
-import qualified Data.Sequence as Seq
-  ( fromList )
-
--- Earley
-import qualified Text.Earley as Earley
-import Text.Earley
-  ( (<?>) )
-import qualified Text.Earley.Mixfix as Earley
-
--- text
-import Data.Text.Internal
-  ( Text(..) )
-import qualified Data.Text as Text
-  ( all, break, cons, foldl'
-  , length, map, null
-  , singleton, span
-  , uncons, unpack
-  )
-import qualified Data.Text.Read as Text.Read
-  ( double )
-
--- tree-view
-import Data.Tree.View
-  ( drawTree )
-
--- MetaBrush
-import Math.Bezier.Spline
-  ( SplineType(..), SSplineType(..), SplineTypeI(ssplineType)
-  , Spline(..), Curves(..), Curve(..), NextPoint(..)
-  )
-import MetaBrush.DSL.AST
-  ( Span(..), Located(..)
-  , Expr, EPat
-  , Term(..), Pat(..), Decl(..)
-  , X_With(..)
-  , toTreeTerm
-  )
-import MetaBrush.DSL.PrimOp
-  ( Orientation(..), kappa
-  , rotate_around_by, rotate_by
-  , scale_around_by, scale_by
-  , shear_from_by, shear_by
-  , translate_by
-  , map_over
-  )
-
---------------------------------------------------------------------------------
--- Parsing using the language grammar.
-
-parse :: Text -> ( [ ( Expr, Int ) ], Earley.Report Text [ Located Token ] )
-parse = Earley.allParses ( Earley.parser grammar ) . tokenize
-
-showParses :: Text -> IO ()
-showParses x = do
-  let
-    ( parses, report ) = parse x
-  putStrLn "Report:\n"
-  print report
-  putStrLn "\n\n"
-  putStrLn "Parses:\n"
-  for_ parses \ ( expr, _ ) -> do
-    let
-      tree = toTreeTerm expr
-    drawTree tree
-
---------------------------------------------------------------------------------
--- Language grammar.
-
-grammar :: forall r. Earley.Grammar r ( Earley.Prod r Text ( Located Token ) Expr )
-grammar = mdo
-
-  pair  <- Earley.rule $
-    do
-      lp <- special '('
-      l <- expr
-      anyWhitespace
-      comma <- special ','
-      r <- expr
-      anyWhitespace
-      rp <- special ')'
-      pure $
-        Point
-          [ Location ( location lp )
-          , Location ( location comma )
-          , Location ( location rp ) ]
-          l r
-    <?> "pair"
-  atom  <- Earley.rule
-    ( identifier
-    <|> pair
-    <|> ( special '(' *> expr <* anyWhitespace <* special ')' )
-    <|> spline
-    )
-  app   <- Earley.rule ( atom <|> (:$) <$> app <*> ( anyWhitespace *> atom ) )
-
-  pairPattern <- Earley.rule
-    ( do
-      openLoc <- special '('
-      anyWhitespace
-      l <- anyPattern
-      anyWhitespace
-      commaLoc <- special ','
-      anyWhitespace
-      r <- anyPattern
-      anyWhitespace
-      closeLoc <- special ')'
-      pure $ PPoint
-        [ Location ( location openLoc )
-        , Location ( location commaLoc )
-        , Location ( location closeLoc )
-        ]
-        l r
-    <?> "pair"
-    )
-
-  basicPattern <- Earley.rule
-    ( wildcard
-    <|> ( PName <$> alphabeticName
-        <?> "pattern name"
-        )
-    <|> pairPattern
-    )
-
-  asPattern <- Earley.rule
-    ( do
-      n <- alphabeticName <?> "pattern name"
-      asLoc <- symbol "@"
-      pat <- anyPattern
-      pure $
-        AsPat ( Location ( location asLoc ) ) n pat
-    <?> "as pattern"
-    )
-
-  anyPattern <- Earley.rule ( ( basicPattern <|> asPattern ) <?> "pattern" )
-
-  declaration <-
-    Earley.rule $
-      ( do
-        funName <- alphabeticName
-        anyWhitespace
-        argPat <- anyPattern
-        anyWhitespace
-        eqLoc <- symbol "="
-        rhs <- expr
-        pure ( FunDecl funName argPat ( Location ( location eqLoc ) ) rhs )
-      <?> "function declaration"
-      ) <|>
-      ( do
-        lhs <- anyPattern
-        anyWhitespace
-        eqLoc <- symbol "="
-        rhs <- expr
-        pure ( ValDecl lhs ( Location ( location eqLoc ) ) rhs )
-      <?> "variable declaration"
-      )
-
-  moreDeclarations <- Earley.rule
-    ( do
-        separator
-        decl <- declaration
-        more <- moreDeclarations
-        pure ( decl : more )
-    <|> pure []
-    )
-
-  declarations <-
-    Earley.rule
-      ( do
-          decl <- declaration
-          more <- moreDeclarations
-          pure ( decl : more )
-      <|> pure []
-      )
-
-  let_statement <-
-    Earley.rule
-      ( do
-          loc_let <- tokAlpha "let"
-          anyWhitespace
-          decls <- declarations <?> "declarations"
-          anyWhitespace
-          loc_in <- tokAlpha "in"
-          e <- expr
-          pure $
-            Let
-              [ Location ( location loc_let )
-              , Location ( location loc_in  ) ]
-              decls
-              e
-      <?> "let statement"
-      )
-
-  moreProperties <- Earley.rule
-    ( do
-        separator
-        prop <- expr
-        more <- moreProperties
-        pure ( prop : more )
-    <|> pure []
-    )
-
-  properties <-
-    Earley.rule
-      ( do
-          prop <- expr
-          more <- moreProperties
-          pure ( prop : more )
-      <|> pure []
-      )
-
-  with_statement <-
-    Earley.rule
-      ( do
-          loc_with <- tokAlpha "with"
-          anyWhitespace
-          decls <- declarations <?> "parameter default definitions"
-          mbProps <- optional do
-            anyWhitespace
-            loc_sats <- tokAlpha "satisfying"
-            props    <- properties <?> "parameter range properties"
-            pure ( loc_sats, props )
-          anyWhitespace
-          loc_def <- tokAlpha "define"
-          e <- expr
-          pure $
-            let
-              ( locs, props ) = case mbProps of
-                Nothing ->
-                  ( [ Location ( location loc_with )
-                    , Location ( location loc_def  ) ]
-                  , []
-                  )
-                Just ( loc_sats, sat_props ) ->
-                  ( [ Location ( location loc_with )
-                    , Location ( location loc_sats )
-                    , Location ( location loc_def  ) ]
-                  , sat_props
-                  )
-            in
-              With locs ( P_With decls ) props e
-      <?> "with statement"
-      )
-
-  spline <-
-    Earley.rule
-    ( do
-        start <- special '['
-        p0 <- expr <?> "first point of spline"
-        openCurves <- many     $ curveTo @Open   expr <?> "open curve to"
-        mbClosed   <- optional $ curveTo @Closed expr <?> "closed curve"
-        anyWhitespace
-        end <- special ']'
-        pure $
-          ( \ opens -> \ case
-            Nothing     ->
-              PolyBez
-                [ Location ( location start ), Location ( location end ) ]
-                ( Spline p0 ( OpenCurves   opens ) )
-            Just closed ->
-              PolyBez
-                [ Location ( location start ), Location ( location end ) ]
-                ( Spline p0 ( ClosedCurves opens closed ) )
-          ) ( Seq.fromList openCurves ) mbClosed
-    <?> "spline" )
-
-  simpleExpr <- Earley.rule do
-    anyWhitespace
-    res <- app <|> let_statement
-    pure res
-  expr <- Earley.mixfixExpressionSeparate mixfixTable simpleExpr
-
-  pure ( with_statement <|> expr )
-
--- | Reserved alphabetic identifiers.
-reserved :: Set Text
-reserved
-  = Set.fromList
-  [ "let", "in"
-  , "with", "set", "satisfying"
-  , "around", "by", "rotate", "scale", "shear", "translate", "transform"
-  , "map", "over"
-  , "cw", "ccw"
-  , "pi", "tau", "kappa"
-  ]
-{-
-[ "=", "_", "@", "--", "->" ]
--}
-
-dots :: Earley.Prod r Text ( Located Token ) ( Located Token )
-dots = Earley.satisfy ( located >>> \case { TokSymbolic s | Text.all ( == '.' ) s -> True; _ -> False } )
-
-locatedToken :: Token -> Earley.Prod r Text ( Located Token ) ( Located Token )
-locatedToken t = Earley.satisfy ( located >>> ( == t ) )
-
-tokAlpha, ws_tokAlpha :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
-tokAlpha t = Earley.satisfy
-  ( located >>> \case { TokAlphabetic a | Text.map Char.toLower a == t -> True; _ -> False } )
-  <?> t
-ws_tokAlpha t = anyWhitespace *> tokAlpha t
-
-tokSymbol, ws_tokSymbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
-tokSymbol t = locatedToken ( TokSymbolic t ) <?> t
-ws_tokSymbol t = anyWhitespace *> tokSymbol t
-
-tokOrientation :: Earley.Prod r Text ( Located Token ) ( Located Token )
-tokOrientation = anyWhitespace *> ( tokAlpha "ccw" <|> tokAlpha "cw" )
-
-orientation :: Token -> Orientation
-orientation ( TokAlphabetic ori )
-  | Text.map Char.toLower ori == "ccw"
-  = CCW
-orientation _
-  = CW
-
-curveTo
-  :: forall clo r
-  .  SplineTypeI clo
-  => Earley.Prod r Text ( Located Token ) Expr
-  -> Earley.Prod r Text ( Located Token ) ( Curve clo [ Located () ] Expr )
-curveTo expr = do
-  anyWhitespace
-  cps <- optional do
-    locTo1 <- symbol "--"
-    cp1 <- expr
-    anyWhitespace
-    mb_cp2 <- optional do
-      locTo2 <- symbol "--"
-      cp2 <- expr
-      anyWhitespace
-      pure ( locTo2, cp2 )
-    pure ( ( locTo1, cp1), mb_cp2 )
-  locTo3 <- symbol "->"
-  mkCurve <- case ssplineType @clo of
-    SClosed ->
-      let
-        mkCurve
-          :: Located Token
-          -> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
-          -> Span
-          -> Curve Closed [ Located () ] Expr
-        mkCurve ( Located dotsLoc _ ) mbCps loc3 = case mbCps of
-          Nothing ->
-            LineTo BackToStart [ Location loc3, Location dotsLoc ]
-          Just ( ( Located loc1 _, cp1 ), Nothing  ) ->
-            Bezier2To cp1 BackToStart [ Location loc1, Location loc3, Location dotsLoc ]
-          Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
-            Bezier3To cp1 cp2 BackToStart [ Location loc1, Location loc2, Location loc3, Location dotsLoc ]
-      in do
-        anyWhitespace
-        locatedDots <- dots
-        pure ( mkCurve locatedDots )
-    SOpen ->
-      let
-        mkCurve
-          :: Expr
-          -> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
-          -> Span
-          -> Curve Open [ Located () ] Expr
-        mkCurve p mbCps loc3 = case mbCps of
-          Nothing ->
-            LineTo ( NextPoint p ) [ Location loc3 ]
-          Just ( ( Located loc1 _, cp1 ), Nothing  ) ->
-            Bezier2To cp1 ( NextPoint p ) [ Location loc1, Location loc3 ]
-          Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
-            Bezier3To cp1 cp2 ( NextPoint p ) [ Location loc1, Location loc2, Location loc3 ]
-      in do
-        p <- expr
-        pure ( mkCurve p )
-  pure ( mkCurve cps ( location locTo3 ) )
-
-mixfixTable
-  ::  [ [
-        ( Earley.Holey ( Earley.Prod r Text ( Located Token ) ( Located Token ) )
-        , Earley.Associativity
-        , Earley.Holey ( Located Token ) -> [ Expr ] -> Expr
-        )
-      ] ]
-mixfixTable
-  = [ [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just $ ws_tokAlpha "around", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
-      , Earley.NonAssoc
-      , \ [ Just ( Located lr _ ), _, Just ( Located la _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _ ), _ ] [ p, c, theta ] ->
-          let
-            ori :: Orientation
-            ori = orientation ori_tok
-            opName :: Text
-            opName = case ori of { CW -> "rotate_around_cwby_"; CCW -> "rotate_around_ccwby_" }
-          in
-            Op [ Location lr, Location la, Location lo, Location lb ]
-              opName ( rotate_around_by ori )
-                :$ p :$ c :$ theta
-      )
-    , ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "around", Nothing, Just $ ws_tokAlpha "by", Nothing ]
-      , Earley.NonAssoc
-      , \ [ Just ( Located ls _ ), _, Just ( Located la _ ), _, Just ( Located lb _ ), _ ] [ p, c, r ] ->
-        Op [ Location ls, Location la, Location lb ]
-          "scale_around_by_" scale_around_by
-            :$ p :$ c :$ r
-      )
-    , ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "from", Nothing, Just $ ws_tokAlpha "by", Nothing ]
-      , Earley.NonAssoc
-      , \ [ Just ( Located ls _ ), _, Just ( Located lf _ ), _, Just ( Located lb _ ), _ ] [ p, c, v ] ->
-        Op [ Location ls, Location lf, Location lb ]
-          "shear_from_by_" shear_from_by
-            :$ p :$ c :$ v
-      )
-    ]
-  , [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
-      , Earley.NonAssoc
-      , \ [ Just ( Located lr _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _), _ ] [ p, theta ] ->
-          let
-            ori :: Orientation
-            ori = orientation ori_tok
-            opName :: Text
-            opName = case ori of { CW -> "rotate_around_cw_"; CCW -> "rotate_around_ccw_" }
-          in
-            Op [ Location lr, Location lo, Location lb ]
-              opName ( rotate_by ori )
-                :$ p :$ theta
-      )
-    , ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "by", Nothing ]
-      , Earley.NonAssoc
-      , \  [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, r ] ->
-        Op [ Location ls, Location lb ]
-          "scale_by_" scale_by
-            :$ p :$ r
-      )
-    , ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "along", Nothing, Just $ ws_tokAlpha "by", Nothing ]
-      , Earley.NonAssoc
-      , \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, v ] ->
-        Op [ Location ls, Location lb ]
-          "shear_along_by_" shear_by
-            :$ p :$ v
-      )
-    , ( [ Just $ ws_tokAlpha "translate", Nothing, Just $ ws_tokAlpha "by", Nothing ]
-      , Earley.NonAssoc
-      , \ [ Just ( Located lt _ ), _, Just ( Located lb _ ), _ ] [ p, t ] ->
-        Op [ Location lt, Location lb ]
-          "translate_by_" translate_by
-            :$ p :$ t
-      )
-    , ( [ Just $ ws_tokAlpha "map", Nothing, Just $ ws_tokAlpha "over", Nothing ]
-      , Earley.NonAssoc
-      , \ [ Just ( Located lt _ ), _, Just ( Located lb _ ), _ ] [ f, v ] ->
-        Op [ Location lt, Location lb ]
-          "map_over_" map_over
-            :$ f :$ v
-      )
-    ]
-  , [ ( [ Nothing, Just $ ws_tokSymbol "||", Nothing ]
-      , Earley.RightAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(||)" (||)
-            :$ a :$ b
-      )
-    ]
-  , [ ( [ Nothing, Just $ ws_tokSymbol "&&", Nothing ]
-      , Earley.RightAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(&&)" (&&)
-            :$ a :$ b
-      )
-    ]
-  , [ ( [ Nothing, Just $ ws_tokSymbol "<", Nothing ]
-      , Earley.NonAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(<)" ( (<) @Double )
-            :$ a :$ b
-      )
-    , ( [ Nothing, Just $ ws_tokSymbol "<=", Nothing ]
-      , Earley.NonAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(<=)" ( (<=) @Double )
-            :$ a :$ b
-      )
-    , ( [ Nothing, Just $ ws_tokSymbol ">", Nothing ]
-      , Earley.NonAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(>)" ( (>) @Double )
-            :$ a :$ b
-      )
-    , ( [ Nothing, Just $ ws_tokSymbol ">=", Nothing ]
-      , Earley.NonAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(>=)" ( (>=) @Double )
-            :$ a :$ b
-      )
-    , ( [ Nothing, Just $ ws_tokSymbol "==", Nothing ]
-      , Earley.NonAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(==)" ( (==) @Double )
-            :$ a :$ b
-      )
-    ]
-  , [ ( [ Nothing, Just $ ws_tokSymbol "+", Nothing ]
-      , Earley.LeftAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(+)" ( (+) @Double )
-            :$ a :$ b
-      )
-    , ( [ Nothing, Just $ ws_tokSymbol "-", Nothing ]
-      , Earley.LeftAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(-)" ( (-) @Double )
-            :$ a :$ b
-      )
-    , ( [ Just $ ws_tokSymbol "-", Nothing ]
-      , Earley.RightAssoc
-      , \ [ Just ( Located l _ ), _ ] [ a ] ->
-        Op [ Location l ]
-          "negate" ( negate @Double )
-            :$ a
-      )
-    ]
-  , [ ( [ Nothing, Just $ ws_tokSymbol "*", Nothing ]
-      , Earley.LeftAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(*)" ( (*) @Double )
-            :$ a :$ b
-      )
-    , ( [ Nothing, Just $ ws_tokSymbol "/", Nothing ]
-      , Earley.LeftAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(/)" ( (/) @Double )
-            :$ a :$ b
-      )
-    ]
-  , [ ( [ Nothing, Just $ ws_tokSymbol "^", Nothing ]
-      , Earley.RightAssoc
-      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
-        Op [ Location l ]
-          "(^)" ( (**) @Double )
-            :$ a :$ b
-      )
-    ]
-  ]
-
-numericLiteral :: Located Token -> Maybe Expr
-numericLiteral ( Located l ( TokNumeric x ) ) = Just $ Lit @Double ( Located l Nothing ) x
-numericLiteral _                              = Nothing
-
-number :: Earley.Prod r Text ( Located Token ) Expr
-number = Earley.terminal numericLiteral
-  <?> "number"
-
-identifier :: Earley.Prod r Text ( Located Token ) Expr
-identifier =
-        number
-    <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "pi"    ) )    pi      ) <$> tokAlpha "pi"
-    <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "tau"   ) ) ( 2 * pi ) ) <$> tokAlpha "tau"
-    <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "kappa" ) )    kappa   ) <$> tokAlpha "kappa"
-    <|> ( ( \ n -> Var n ) <$> alphabeticName
-         <?> "identifier"
-        )
-
-
-
-whitespace, anyWhitespace :: Earley.Prod r Text ( Located Token ) ()
-whitespace    = Earley.terminal $ located >>> \case { TokWhitespace _ -> Just (); _ -> Nothing }
-anyWhitespace = void $ many whitespace
-
-significantWhitespace :: Earley.Prod r Text ( Located Token ) ()
-significantWhitespace = Earley.terminal ( located >>> \case { TokWhitespace True -> Just (); _ -> Nothing } )
-  <?> "newline"
-
-separator :: Earley.Prod r Text ( Located Token ) ()
-separator =
-    ( void ( some significantWhitespace )
-      <|> ( void ( anyWhitespace *> special ';' <* anyWhitespace ) )
-    )
-  <?> "separator"
-
-alphabeticName :: Earley.Prod r Text ( Located Token ) ( Located Text )
-alphabeticName =
-  Earley.terminal \case
-   Located l ( TokAlphabetic x )
-     | not ( x `Set.member` reserved )
-     -> Just ( Located l x )
-   _ -> Nothing
-
-special :: Char -> Earley.Prod r Text ( Located Token ) ( Located Token )
-special c = locatedToken ( TokSpecial c ) <?> Text.singleton c
-
-symbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
-symbol s = locatedToken ( TokSymbolic s ) <?> s
-
-wildcard :: Earley.Prod r Text ( Located Token ) EPat
-wildcard = Earley.terminal
-  \case
-    Located l ( TokWildcard x ) -> Just ( PWild ( Located l x ) )
-    _ -> Nothing
-  <?> "wildcard pattern"
-
---------------------------------------------------------------------------------
--- Tokenizer.
-
-isSpecial :: Char -> Bool
-isSpecial c = Set.member c ( Set.fromList "(){}[],;`\"" )
-
-data Token
-  = TokWhitespace Bool
-  | TokSpecial    Char
-  | TokAlphabetic Text
-  | TokNumeric    Double
-  | TokWildcard   Text
-  | TokSymbolic   Text
-  | OtherTok      Text
-  deriving stock ( Show, Eq, Ord )
-
-showToken :: Token -> String
-showToken ( TokWhitespace False ) = " "
-showToken ( TokWhitespace True  ) = "\n"
-showToken ( TokSpecial    s ) = [s]
-showToken ( TokAlphabetic a ) = Text.unpack a
-showToken ( TokNumeric    x ) = show x
-showToken ( TokWildcard   w ) = Text.unpack w
-showToken ( TokSymbolic   s ) = Text.unpack s
-showToken ( OtherTok      t ) = Text.unpack t
-
-tokenize :: Text -> [ Located Token ]
-tokenize = go 1 1
-  where
-    go :: Int -> Int -> Text -> [ Located Token ]
-    go sr sc t = case Text.uncons t of
-      Nothing -> []
-      Just ( x, xs )
-        -- White space.
-        | Char.isSpace x
-        , let
-            ( ys, rest ) = Text.span Char.isSpace xs
-            ( er1, er2, ec ) =
-              Text.foldl'
-                ( \ (r1,r2,c) -> \ case
-                      '\n' -> (r1+1,r2,1)
-                      '\r' -> (r1,r2+1,1)
-                      '\t' -> (r1,r2,c+2)
-                      '\f' -> (r1,r2,c)
-                      '\v' -> (r1,r2,c)
-                      _    -> (r1,r2,c+1)
-                )
-                (sr,sr,sc)
-                ( x `Text.cons` ys )
-            er = max er1 er2
-        -> if er > sr
-          then  Located ( Span sr sc er ec ) ( TokWhitespace True  ) : go er ec rest
-          else  Located ( Span sr sc er ec ) ( TokWhitespace False ) : go er ec rest
-        -- Special characters.
-        | isSpecial x
-        -> Located ( Span sr sc sr ( sc + 1 ) ) ( TokSpecial x )
-        : go sr ( sc + 1 ) xs
-        -- Alphabetic identifier.
-        | Char.isAlpha x
-        , let
-            ( ys, rest ) = Text.span ( \case { '\'' -> True; '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
-            tok = x `Text.cons` ys
-            l = Text.length tok
-        -> Located ( Span sr sc sr ( sc + l ) ) ( TokAlphabetic tok )
-        : go sr ( sc + l ) rest
-        -- Numeric identifier.
-        | Just ( locTok@Located { location = Span { endRow, endCol } }, rest ) <- tokenizeNumeric sr sc t
-        -> locTok
-        : go endRow endCol rest
-        -- Wildcard.
-        | '_' <- x
-        , let
-            ( ys, rest ) = Text.span ( \case { '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
-            tok :: Text
-            tok = x `Text.cons` ys
-            l = Text.length tok
-        -> Located ( Span sr sc sr ( sc + l ) ) ( TokWildcard tok )
-        : go sr ( sc + l ) rest
-        -- Symbolic identifier.
-        | Char.isSymbol x || Char.isPunctuation x
-        , let
-            ( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c || Char.isAlphaNum c ) xs
-            tok = x `Text.cons` ys
-            l = Text.length tok
-        -> Located ( Span sr sc sr ( sc + l ) ) ( TokSymbolic tok )
-        : go sr ( sc + l ) rest
-        -- Fallback.
-        | let
-            ( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c ) xs
-            tok = x `Text.cons` ys
-            l = Text.length tok
-        -> Located ( Span sr sc sr ( sc + l ) ) ( OtherTok tok )
-        : go sr ( sc + l ) rest
-
--- Tokenize a numeric literal (without any leading sign).
-tokenizeNumeric :: Int -> Int -> Text -> Maybe ( Located Token, Text )
-tokenizeNumeric sr sc t = case Text.span Char.isDigit t of
-  -- Integer part of the mantissa.
-  ( integ, rest )
-    | not ( Text.null integ )
-    -> case Text.uncons rest of
-        Just ( c, rest' )
-        -- Fraction.
-          | c == '.'
-          ->
-            -- Fractional part of the mantissa.
-            let ( frac, rest'' ) = Text.span Char.isDigit rest'
-            in case Text.uncons rest'' of
-                  Just ( c', rest''' )
-                  -- Fraction followed by exponent.
-                    | c' == 'e' || c' == 'E'
-                    , Just ( expo, rest'''' ) <- spanExponent rest'''
-                    , Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac <> "e" <> expo )
-                    , Text.null leftover
-                    , let
-                        l = Text.length integ + 1 + Text.length frac + 1 + Text.length expo
-                    -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'''' )
-                  -- Simple fraction (no exponent).
-                  _ | Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac )
-                    , Text.null leftover
-                    , let
-                        l = Text.length integ + 1 + Text.length frac
-                    -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
-                  _ -> Nothing
-        -- Positive integer followed by exponent.
-          | c == 'e' || c == 'E'
-          , Just ( expo, rest'' ) <- spanExponent rest'
-          , Right ( r, leftover ) <- Text.Read.double ( integ <> "e" <> expo )
-          , Text.null leftover
-          , let
-              l = Text.length integ + 1 + Text.length expo
-          -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
-        -- Simple positive integer (no fractional part or exponent).
-        _ | Right ( r, leftover ) <- Text.Read.double integ
-          , Text.null leftover
-          , let
-              l = Text.length integ
-          -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest )
-        _ -> Nothing
-  _ -> Nothing
-
-spanExponent :: Text -> Maybe ( Text, Text )
-spanExponent t = case Text.uncons t of
-  Just ( x, xs )
-    | x == '+' || x == '-' || Char.isDigit x
-    , let
-        ( ds, rest ) = Text.span Char.isDigit xs
-    -> Just ( Text.cons x ds, rest )
-  _ -> Nothing

src/metabrushes/MetaBrush/DSL/PrimOp.hs

@@ -1,48 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
-
-module MetaBrush.DSL.PrimOp where
-
--- MetaBrush
-import Math.Bezier.Spline
-  ( SplineType(Closed), SplinePts )
-import Math.Vector2D
-  ( Point2D(..) )
-
---------------------------------------------------------------------------------
--- Operations supported by the DSL.
-
-data Orientation = CCW | CW
-  deriving stock Show
-
-kappa :: Double
-kappa = 0.5519150244935105707435627227925
--- root of (Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]
-
-rotate_around_by :: Orientation -> Point2D Double -> Point2D Double -> Double -> Point2D Double
-rotate_around_by ori ( Point2D px py ) ( Point2D cx cy ) theta =
-  translate_by ( rotate_by ori ( Point2D ( px - cx ) ( py - cy ) ) theta ) ( Point2D cx cy )
-rotate_by :: Orientation -> Point2D Double -> Double -> Point2D Double
-rotate_by CCW ( Point2D px py ) theta = Point2D ( c * px - s * py ) ( c * py + s * px )
-  where
-    c, s :: Double
-    c = cos theta
-    s = sin theta
-rotate_by CW p theta = rotate_by CCW p ( -theta )
-
-scale_around_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double
-scale_around_by ( Point2D px py ) ( Point2D cx cy ) ( Point2D rx ry ) = Point2D ( rx * ( px - cx ) + cx ) ( ry * ( py - cy ) + cy )
-scale_by :: Point2D Double -> Point2D Double -> Point2D Double
-scale_by ( Point2D px py ) ( Point2D rx ry ) = Point2D ( rx * px ) ( ry * py )
-
-shear_from_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double
-shear_from_by ( Point2D px py ) ( Point2D cx cy ) v =
-  translate_by ( shear_by ( Point2D ( px - cx ) ( py - cy ) ) v ) ( Point2D cx cy )
-shear_by :: Point2D Double -> Point2D Double -> Point2D Double
-shear_by ( Point2D px py ) ( Point2D vx vy ) = undefined
-
-translate_by :: Point2D Double -> Point2D Double -> Point2D Double
-translate_by ( Point2D px py ) ( Point2D tx ty ) = Point2D ( px + tx ) ( py + ty )
-
-map_over :: ( Point2D Double -> Point2D Double ) -> ( SplinePts Closed -> SplinePts Closed )
-map_over = fmap

src/metabrushes/MetaBrush/DSL/Rename.hs

@@ -1,247 +0,0 @@
-{-# LANGUAGE BlockArguments      #-}
-{-# LANGUAGE ConstraintKinds     #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE DerivingStrategies  #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeFamilies        #-}
-
-module MetaBrush.DSL.Rename
-  ( rename, MonadRn, RnM
-  , RnMessage, RnError
-  , RnState, emptyRnState
-  , Env(..), UniqueName(..)
-  )
-  where
-
--- base
-import Data.Foldable
-  ( for_ )
-import GHC.Generics
-  ( Generic )
-
--- containers
-import Data.Map.Strict
-  ( Map )
-import qualified Data.Map.Strict as Map
-  ( lookup )
-
--- dlist
-import Data.DList
-  ( DList )
-import qualified Data.DList as DList
-  ( singleton )
-
--- generic-lens
-import Data.Generics.Product.Fields
-  ( field' )
-
--- lens
-import Control.Lens
-  ( assign, at, modifying, use )
-
--- mtl
-import Control.Monad.State
-  ( MonadState(..) )
-import Control.Monad.Writer
-  ( MonadWriter(..) )
-
--- text
-import Data.Text
-  ( Text )
-
--- transformers
-import Control.Monad.Trans.RWS.CPS
-  ( RWST )
-
--- MetaBrush
-import Math.Bezier.Spline
-  ( KnownSplineType(bitraverseSpline), bitraverseCurve )
-import MetaBrush.DSL.AST
-  ( Located(..)
-  , Pass(P,Rn), Name, UniqueName(..), X_With(..)
-  , Term(..), Decl(..), Pat(..)
-  )
-import MetaBrush.DSL.Parse
-  ( ) -- AST type family instances for parsing pass
-import MetaBrush.Unique
-  ( UniqueSupply, MonadUnique(freshUnique)
-  , Unique
-  )
-
---------------------------------------------------------------------------------
--- Renaming pass.
-
-rename :: MonadRn m => Term P '() -> m ( Term Rn '() )
-rename ( f :$ a ) = (:$) <$> locally ( rename f ) <*> locally ( rename a )
-rename ( Var locv@( Located l v ) ) = do
-  mbRes <- use ( field' @"localEnv" . field' @"rnLocalVars" . at v )
-  case mbRes of
-    Nothing -> do
-      rnError ( OutOfScope locv )
-      uniq' <- freshUnique
-      pure $ Var ( Located l ( UniqueName v uniq' ) )
-    Just uniq ->
-      pure $ Var ( Located l ( UniqueName v uniq ) )
-rename ( Lit l a ) = pure ( Lit l a )
-rename ( Op locs nm op ) = pure ( Op locs nm op )
-rename ( Point locs a b ) = Point locs <$> locally ( rename a ) <*> locally ( rename b )
-rename ( Line locs p1 p2 ) = Line locs <$> locally ( rename p1 ) <*> locally ( rename p2 )
-rename ( Bez2 locs p1 p2 p3 ) = Bez2 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 )
-rename ( Bez3 locs p1 p2 p3 p4 ) = Bez3 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 ) <*> locally ( rename p4 )
-rename ( PolyBez locs spline ) = PolyBez locs <$>
-  bitraverseSpline
-    ( const $ bitraverseCurve pure ( const $ locally . rename ) )
-    ( locally . rename )
-    spline
-rename ( Let locs decls body ) = do
-  decls' <- renameDecls decls
-  body'  <- rename body
-  pure ( Let locs decls' body' )
-rename ( With locs ( P_With decls ) conds body ) = do
-  decls' <- renameDecls decls
-  conds' <- traverse ( locally . rename ) conds
-  body'  <- rename body
-  pure ( With locs ( Rn_With decls' ) conds' body' )
-
-renameDecls :: forall m. MonadRn m => [ Decl P ] -> m [ Decl Rn ]
-renameDecls decls = do
-  outerLocalVars <- use ( field' @"localEnv" . field' @"rnLocalVars" )
-  assign ( field' @"localEnv" . field' @"rnLocalVars" ) mempty
-  decls' <- go outerLocalVars decls
-  pure decls'
-
-  where
-
-    go :: Map Text Unique -> [ Decl P ] -> m [ Decl Rn ]
-    go outerLocalVars ( ValDecl lhs eqLoc rhs : next ) = do
-      -- Collect all the declarations from the left-hand sides.
-      lhs'  <- renameLhs outerLocalVars lhs
-      next' <- go outerLocalVars next
-      -- Now rename the right-hand side with the full LHS info.
-      rhs'  <- locally ( rename rhs )
-      pure $ ValDecl lhs' eqLoc rhs' : next'
-    go outerLocalVars ( FunDecl funName argPat eqLoc rhs : next ) = do
-      -- Collect all the declarations from the left-hand sides.
-      funName' <- patName <$> renameLhs outerLocalVars ( PName funName )
-      next'    <- go outerLocalVars next
-      -- Now rename the right-hand side with the full LHS info,
-      -- taking care to bring into scope the names bound by the function
-      -- when renaming the RHS.
-      ( lhs', rhs' ) <- locally ( (,) <$> renameLhs outerLocalVars argPat <*> rename rhs )
-      pure $ FunDecl funName' lhs' eqLoc rhs' : next'
-    go outerLocalVars [] = do
-      -- Finished handling all the left-hand sides:
-      --   add all the declared names to the existing (outer) names,
-      --   shadowing the outer names if necessary.
-      modifying ( field' @"localEnv" . field' @"rnLocalVars" ) ( <> outerLocalVars )
-      pure []
-
-    renameLhs :: Map Text Unique -> Pat P '() -> m ( Pat Rn '() )
-    renameLhs outerLocalVars ( PName locPat@( Located l nm ) ) = do
-      mbUniq <- use ( field' @"localEnv" . field' @"rnLocalVars" . at nm )
-      case mbUniq of
-        Just uniq -> do
-          rnError ( DuplicateDecl uniq locPat )
-          uniq' <- freshUnique
-          pure $ PName ( Located l ( UniqueName nm uniq' ) )
-        Nothing -> do
-          let
-            mbPrevUniq :: Maybe Unique 
-            mbPrevUniq = Map.lookup nm outerLocalVars
-          uniq <- freshUnique
-          for_ mbPrevUniq \ prevUniq -> do
-            rnWarning ( NameShadowing prevUniq ( Located l ( UniqueName nm uniq ) ) )
-          assign ( field' @"localEnv"  . field' @"rnLocalVars"  . at nm   ) ( Just uniq   )
-          assign ( field' @"globalEnv" . field' @"rnGlobalVars" . at uniq ) ( Just locPat )
-          pure $ PName ( Located l ( UniqueName nm uniq ) )
-    renameLhs outerLocalVars ( PPoint l p1 p2 ) = PPoint l <$> renameLhs outerLocalVars p1 <*> renameLhs outerLocalVars p2
-    renameLhs _ ( PWild wild ) = pure ( PWild wild )
-    renameLhs outerLocalVars ( AsPat atLoc locName pat ) = do
-      name' <- renameLhs outerLocalVars ( PName locName )
-      case name' of
-        PName locName' -> do
-          pat' <- renameLhs outerLocalVars pat
-          pure $ AsPat atLoc locName' pat'
-        _ -> error "renameLHS: internal error"
-
-
---------------------------------------------------------------------------------
--- Renamer-specific data and instances.
-
-data RnLocalEnv
-  = RnLocalEnv
-    { rnLocalVars :: !( Map Text Unique ) }
-  deriving stock ( Show, Generic )
-
-data RnGlobalEnv
-  = RnGlobalEnv
-    { rnGlobalVars :: !( Map Unique ( Located Text ) ) }
-  deriving stock ( Show, Generic )
-
-data Env global local
-  = Env
-  { globalEnv :: !global
-  , localEnv  :: !local
-  }
-  deriving stock    ( Show, Generic )
-
-type RnState = Env RnGlobalEnv RnLocalEnv
-
-emptyRnState :: RnState
-emptyRnState = Env ( RnGlobalEnv mempty ) ( RnLocalEnv mempty )
-
-locally :: MonadState ( Env global local ) m => m a -> m a
-locally action = do
-  Env { localEnv } <- get
-  res <- action
-  assign ( field' @"localEnv" ) localEnv
-  pure res
-
-data RnMessage
-  = RnWarningMessage
-    { rnWarningMessage :: !RnWarning
-    , rnMessageState   :: !RnState
-    }
-  | RnErrorMessage
-    { rnErrorMessage :: !RnError
-    , rnMessageState :: !RnState
-    }
-  deriving stock ( Show, Generic )
-
-data RnError
-  = OutOfScope    !( Located Text )
-  | DuplicateDecl 
-    { prevDecl :: !Unique
-    , dupDecl  :: !( Located Text )
-    }
-  deriving stock ( Show, Generic )
-
-data RnWarning
-  = NameShadowing 
-  { shadowedUnique :: !Unique
-  , shadowingName  :: !( Located UniqueName )
-  }
-  deriving stock ( Show, Generic )
-
-rnError
-  :: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
-  => RnError -> m ()
-rnError err = do
-  st <- get
-  tell ( DList.singleton $ RnErrorMessage err st )
-
-rnWarning
-  :: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
-  => RnWarning -> m ()
-rnWarning warn = do
-  st <- get
-  tell ( DList.singleton $ RnWarningMessage warn st )
-
-type RnM = RWST UniqueSupply ( DList RnMessage ) RnState IO
-type MonadRn m = ( MonadUnique m, MonadState RnState m, MonadWriter ( DList RnMessage ) m )
-
-type instance Name Rn = UniqueName

src/metabrushes/MetaBrush/DSL/TypeCheck.hs

@@ -1,388 +0,0 @@
-{-# LANGUAGE BlockArguments         #-}
-{-# LANGUAGE ConstraintKinds        #-}
-{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE DeriveGeneric          #-}
-{-# LANGUAGE DerivingStrategies     #-}
-{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE MagicHash              #-}
-{-# LANGUAGE NamedFieldPuns         #-}
-{-# LANGUAGE GADTs                  #-}
-{-# LANGUAGE OverloadedStrings      #-}
-{-# LANGUAGE PartialTypeSignatures  #-}
-{-# LANGUAGE RankNTypes             #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE TypeApplications       #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE UndecidableInstances   #-}
-
-module MetaBrush.DSL.TypeCheck
-  ( typeCheck, MonadTc, TcM
-  , TcMessage, TcError
-  , TcState, emptyTcState
-  )
-  where
-
--- base
-import Control.Arrow
-  ( second )
-import Data.Either
-  ( partitionEithers )
-import Data.Kind
-  ( Type )
-import Data.Type.Equality
-  ( (:~:)(Refl) )
-import GHC.Exts
-  ( Any, Proxy# )
-import GHC.Generics
-  ( Generic )
-import Unsafe.Coerce
-  ( unsafeCoerce )
-
--- containers
-import Data.Map.Strict
-  ( Map )
-import Data.Sequence
-  ( Seq(..) )
-
--- dlist
-import Data.DList
-  ( DList )
-
--- generic-lens
-import Data.Generics.Product.Fields
-  ( field' )
-
--- lens
-import Control.Lens
-  ( assign, at, use )
-
--- mtl
-import Control.Monad.Except
-  ( MonadError(..) )
-import Control.Monad.State
-  ( MonadState(..) )
-import Control.Monad.Writer
-  ( MonadWriter(..) )
-
--- text
-import Data.Text
-  ( Text )
-
--- transformers
-import Control.Monad.Trans.RWS.CPS
-  ( RWST )
-import Control.Monad.Trans.Except
-  ( ExceptT )
-
--- unordered-containers
-import qualified Data.HashMap.Strict as HashMap
-  ( fromList )
-
--- MetaBrush
-import Math.Bezier.Spline
-  ( Spline(..), Curve(..), Curves(..)
-  , SSplineType(..), SplineTypeI(ssplineType)
-  , bitraverseCurve, KnownSplineType(bitraverseSpline)
-  , NextPoint(..)
-  )
-import Math.Vector2D
-  ( Point2D(..) )
-import MetaBrush.DSL.AST
-  ( Span(..), Located(..)
-  , Pass(Rn,Tc)
-  , Pat(..), Decl(..)
-  , X_With(..)
-  , UniqueTerm(..)
-  , Term(..), TypedTerm(..)
-  , termSpan
-  )
-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 )
-
---------------------------------------------------------------------------------
-
-typeCheckAt
-  :: forall ( a :: Type ) m
-  .  ( STypeI a, MonadTc m )
-  => Text
-  -> Term Rn '() -> m ( Term Tc a )
-typeCheckAt mismatchMessage term = do
-  TypedTerm ( x :: Term Tc x ) <- typeCheck term
-  case eqTy @a @x of
-    Just Refl -> pure x
-    Nothing   ->
-      tcError $
-        UnexpectedType
-          mismatchMessage
-          ( "Expected: ",                             SomeSType @a )
-          ( "  Actual: ", Located ( termSpan term ) $ SomeSType @x )
-
-typeCheck :: forall m. MonadTc m => Term Rn '() -> m TypedTerm
-typeCheck ( uf :$ ua ) = do
-  TypedTerm ( f :: Term Tc f ) <- typeCheck uf
-  case sTypeI @f of
-    sFunTy@SFunTy | ( _ :: SType ( b -> c ) ) <- sFunTy
-      -> do
-        TypedTerm ( a :: Term Tc a ) <- typeCheck ua
-        case eqTy @a @b of
-          Just Refl -> pure ( TypedTerm @c ( f :$ a ) )
-          Nothing   -> tcError $
-            UnexpectedType
-              "Unexpected function argument type"
-              ( "Expected: ", SomeSType @b )
-              ( "  Actual: ", Located ( termSpan ua ) $ SomeSType @a )
-    _ -> tcError $
-      OverSaturatedFunctionApplication
-        ( 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 @a ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) )
-    Nothing -> tcError ( OutOfScope locVar )
-typeCheck ( Let loc decls body ) = do
-  decls' <- typeCheckDecls decls
-  TypedTerm body' <- typeCheck body
-  pure ( TypedTerm $ Let loc decls' body' )
-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 :: 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
-  TypedTerm ( a' :: Term Tc a ) <- typeCheck a
-  TypedTerm ( b' :: Term Tc b ) <- typeCheck b
-  case eqTy @a @b of
-    Just Refl -> pure ( TypedTerm $ Point locs a' b' )
-    Nothing   ->
-      tcError $
-        MismatchedTypes
-          "Components of a point with different types."
-          ( "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'"
-typeCheck ( PolyBez locs spline@( Spline { splineStart, splineCurves } :: Spline clo [ Located () ] ( Term Rn '() ) ) ) = do
-  TypedTerm ( start' :: Term Tc pt ) <- typeCheck splineStart
-  case sTypeI @pt of
-    sTy@STyPoint
-      | ( _ :: SType ( Point2D a ) ) <- sTy
-      -> case sTypeI @a of
-        STyDouble -> let
-            tcPoint :: Term Rn '() -> m ( Term Tc pt )
-            tcPoint = typeCheckAt @pt "Unexpected Bézier spline coordinate type"
-          in case ssplineType @clo of
-            SClosed -> do
-              spline' <-
-                bitraverseSpline
-                  ( const $ bitraverseCurve pure ( const tcPoint ) ) tcPoint spline
-              pure ( TypedTerm $ PolyBez locs spline' )
-            SOpen   -> case splineCurves of
-              OpenCurves Empty ->
-                pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves Empty ) ) )
-              OpenCurves ( crv :<| Empty ) -> case crv of
-                LineTo          ( NextPoint p1 ) _ -> do
-                  p1' <- tcPoint p1
-                  pure ( TypedTerm $ Line locs start' p1' )
-                Bezier2To    p1 ( NextPoint p2 ) _ -> do
-                  p1' <- tcPoint p1
-                  p2' <- tcPoint p2
-                  pure ( TypedTerm $ Bez2 locs start' p1' p2' )
-                Bezier3To p1 p2 ( NextPoint p3 ) _ -> do
-                  p1' <- tcPoint p1
-                  p2' <- tcPoint p2
-                  p3' <- tcPoint p3
-                  pure ( TypedTerm $ Bez3 locs start' p1' p2' p3' )
-              OpenCurves crvs -> do
-                crvs' <- traverse ( traverse tcPoint ) crvs
-                pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves crvs' ) ) )
-        _ ->
-          tcError $
-            UnexpectedType
-              "Unexpected Bézier spline coordinate type"
-              ( "Expected: ", SomeSType @Double )
-              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType @a )
-    _ -> tcError $
-            UnexpectedType
-              "Unexpected Bézier spline point type"
-              ( "Expected: ", SomeSType @( Point2D Double ) )
-              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType @pt )
-
-typeCheckDecls :: forall m. MonadTc m => [ Decl Rn ] -> m [ Decl Tc ]
-typeCheckDecls = go []
-  where
-    go :: [ Decl Tc ] -> [ Decl Rn ] -> m [ Decl Tc ]
-    go dones [] = pure dones
-    go dones todos = do
-
-      ( not_oks, oks ) <-
-        partitionEithers
-         <$> traverse
-              ( \ decl -> ( `catchError` ( catchOutOfScope decl ) ) ( fmap Right $ typeCheckDecl decl ) )
-              todos
-      case oks of
-        [] -> traverse ( throwError . snd ) not_oks
-        _  -> go ( dones ++ oks ) ( fmap fst not_oks )
-
-    catchOutOfScope :: Decl Rn -> TcError -> m ( Either ( Decl Rn, TcError ) ( Decl Tc ) )
-    catchOutOfScope decl err@( OutOfScope {} ) = pure ( Left ( decl, err ) )
-    catchOutOfScope _    err                   = throwError err
-
-typeCheckDecl :: MonadTc m => Decl Rn -> m ( Decl Tc )
-typeCheckDecl ( ValDecl lhs eqLoc rhs ) = do
-  TypedTerm ( rhs' :: Term Tc a ) <- typeCheck rhs
-  lhs' <- typeCheckPatAt @a lhs
-  pure ( ValDecl lhs' eqLoc rhs' )
--- TODO: this assumes all user-declared functions are of type @ Point2D Double -> Point2D Double @.
--- A better solution would be to introduce a unification variable for the argument type,
--- and throw an error (or default) if there remain uninstantiated unification variables after typechecking the RHS.
-typeCheckDecl ( FunDecl funName@( Located _ ( UniqueName _ uniq ) ) argPat eqLoc rhs ) = do
-  argPat' <- typeCheckPatAt @( Point2D Double ) argPat
-  rhs'    <- typeCheckAt @( Point2D Double ) "Expected function of type `Point2D Double -> Point2D Double'"  rhs
-  assign
-    ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq )
-    ( 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 @a )
-  pure ( PName nm )
-typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of
-  sTyPair@STyPoint | ( _ :: SType ( Point2D c ) ) <- sTyPair
-    -> do
-      pat1' <- typeCheckPatAt @c pat1
-      pat2' <- typeCheckPatAt @c pat2
-      pure ( PPoint locs pat1' pat2' )
-  _ -> tcError $
-         UnexpectedPatType
-         "RHS of let binding does not have the expected type"
-         ( "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 @a )
-  pure ( AsPat symbLoc nm pat' )
-
-withDeclsRecord
-  :: forall r m
-  .  ( MonadTc m )
-  => [ Decl Tc ]
-  -> ( forall kvs. STypesI kvs => Record UniqueTerm kvs -> r )
-  -> m r
-withDeclsRecord decls f = do
-  -- 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.
-
-data TcLocalEnv
-  = TcLocalEnv
-  deriving stock ( Show, Generic )
-
-data TcGlobalEnv
-  = TcGlobalEnv
-    { tcGlobalVarTys :: !( Map Unique SomeSType )
-    , tyGlovalVars   :: !( Map Unique ( Located Text ) )
-    }
-  deriving stock ( Show, Generic )
-
-data TcMessage
-  = TcWarningMessage
-    { tcWarningMessage :: !TcWarning
-    , tcMessageState   :: !TcState
-    }
-  | TcErrorMessage
-    { tcErrorMessage :: !TcError
-    , tcMessageState :: !TcState
-    }
-  deriving stock ( Show, Generic )
-
-data TcError
-  = MismatchedTypes
-  { additionalErrorText :: !Text
-  , expectedLType       :: !( Text, Located SomeSType )
-  , actualLType         :: !( Text, Located SomeSType )
-  }
-  | UnexpectedType
-  { additionalErrorText :: !Text
-  , expectedType        :: !( Text, SomeSType )
-  , actualLType         :: !( Text, Located SomeSType )
-  }
-  | UnexpectedPatType
-  { additionaLErrorText :: !Text
-  , expectedPatType     :: !( Text, Located SomeSType )
-  , actualRHSType       :: !( Text, SomeSType )
-  }
-  | OverSaturatedFunctionApplication
-  { functionLType :: !( Located SomeSType )
-  , argument      :: !Span
-  }
-  | NoPatternName
-  { declarationSpan :: !Span
-  }
-  | OutOfScope
-  { outOfScopeVar :: !( Located UniqueName ) }
-  | UnexpectedFunDecl
-  { funDeclLoc :: !( Located UniqueName ) }
-  deriving stock ( Show, Generic )
-
-data TcWarning = TcWarning
-  deriving stock ( Show, Generic )
-
-type TcState = Env TcGlobalEnv TcLocalEnv
-
-emptyTcState :: TcState
-emptyTcState = Env ( TcGlobalEnv mempty mempty ) TcLocalEnv
-
-type TcM = ExceptT TcError ( RWST UniqueSupply ( DList TcMessage ) TcState IO )
-type MonadTc m =
-  ( MonadUnique m
-  , MonadState TcState m
-  , MonadWriter ( DList TcMessage ) m
-  , MonadError TcError m
-  )
-
-tcError
-  :: ( MonadError TcError m )
-  => TcError -> m a
-tcError err = throwError err
-
-{-
-tcWarning
-  :: ( MonadState TcState m, MonadWriter ( DList TcMessage ) m )
-  => TcWarning -> m ()
-tcWarning warn = do
-  st <- get
-  tell ( DList.singleton $ TcWarningMessage warn st )
--}

src/metabrushes/MetaBrush/DSL/Types.hs

@@ -15,10 +15,9 @@
 {-# LANGUAGE UndecidableInstances     #-}
 
 module MetaBrush.DSL.Types
-  ( SType(..), STypes(..)
+  ( STypeI, STypesI
-  , STypeI(..), STypesI(..)
   , SomeSType(..)
-  , eqTy, eqTys
+  , eqTys
   , someSTypes, proveSomeSTypes
   ) where
 
@@ -29,6 +28,8 @@ import Data.List
   ( intercalate )
 import Data.Proxy
   ( Proxy(..) )
+import Data.Typeable
+  ( Typeable, eqT )
 import Data.Type.Equality
   ( (:~:)(Refl) )
 import GHC.Exts
@@ -44,58 +45,14 @@ import qualified Data.Text as Text
   ( pack, unpack )
 
 -- MetaBrush
-import Math.Vector2D
+import MetaBrush.DSL.Interpolation
-  ( Point2D(..), Segment(..) )
+  ( Interpolatable )
-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
+class    ( Typeable ty, Interpolatable ty ) => STypeI ty where
-data SType ty where
+instance ( Typeable ty, Interpolatable ty ) => STypeI 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
@@ -107,7 +64,7 @@ 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 )
+  = ( symbolVal' ( proxy# :: Proxy# k ) <> " := " <> show( Proxy @v ) ) : showSTypes ( sTypesI @tail_kvs )
 
 type STypesI :: [ (Symbol, Type) ] -> Constraint
 class STypesI kvs where
@@ -119,60 +76,13 @@ instance STypesI '[] where
 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 <- eqT @v1 @v2
   , Just Refl <- eqTys @as' @bs'
   = Just Refl
 eqSTys _ _ = Nothing
@@ -180,15 +90,13 @@ 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 )
+  show ( SomeSType @a ) = show ( Proxy @a )
 instance Eq SomeSType where
   ( SomeSType @a ) == ( SomeSType @b ) =
-    case eqTy @a @b of
+    case eqT @a @b of
       Just _ -> True
       _      -> False
 

src/metabrushes/MetaBrush/Document.hs

@@ -110,7 +110,7 @@ import MetaBrush.Brush
 import MetaBrush.Serialisable
   ( Serialisable(..) )
 import MetaBrush.DSL.Types
-  ( STypesI(..) )
+  ( STypesI )
 import MetaBrush.DSL.Interpolation
   ( Interpolatable(..) )
 import MetaBrush.Records

src/metabrushes/MetaBrush/Document/Draw.hs

@@ -86,7 +86,7 @@ import MetaBrush.Document
 import MetaBrush.Serialisable
   ( Serialisable )
 import MetaBrush.DSL.Types
-  ( STypesI(..) )
+  ( STypesI )
 import MetaBrush.DSL.Interpolation
   ( Interpolatable )
 import MetaBrush.Records

src/metabrushes/MetaBrush/Document/Serialise.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE InstanceSigs         #-}
 {-# LANGUAGE LambdaCase           #-}
 {-# LANGUAGE MagicHash            #-}
+{-# LANGUAGE MultiWayIf           #-}
 {-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE PolyKinds            #-}
@@ -27,6 +28,8 @@ import qualified Data.Bifunctor as Bifunctor
   ( first )
 import Data.Functor.Identity
   ( Identity(..) )
+import Data.Typeable
+  ( eqT )
 import Data.Type.Equality
   ( (:~:)(Refl) )
 import Data.Version
@@ -68,7 +71,7 @@ import qualified Control.Concurrent.STM as STM
 import Data.Text
   ( Text )
 import qualified Data.Text as Text
-  ( pack, unwords )
+  ( unwords )
 
 -- transformers
 import Control.Monad.IO.Class
@@ -113,14 +116,12 @@ import qualified Waargonaut.Types.Whitespace as JSON
   ( WS )
 
 -- metabrushes
-import qualified Math.Bezier.Cubic as Cubic
-  ( Bezier )
-import qualified Math.Bezier.Quadratic as Quadratic
-  ( Bezier )
 import Math.Bezier.Spline
-  ( SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..) )
+  (  SplineType(..), SSplineType(..), SplineTypeI(..) )
 import Math.Vector2D
-  ( Point2D(..), Vector2D(..), Segment )
+  ( Point2D(..), Vector2D(..))
+import MetaBrush.Asset.Brushes
+  ( lookupBrush )
 import MetaBrush.Brush
   ( Brush(..), SomeBrush(..)
   , SomeFieldSType(..), SomeBrushFields(..)
@@ -132,12 +133,7 @@ import MetaBrush.Document
   , PointData(..), FocusState(..)
   )
 import MetaBrush.DSL.Types
-  ( SType(..), STypeI(..)
+  ( SomeSType(..), someSTypes )
-  , SomeSType(..), someSTypes
-  , eqTy
-  )
-import MetaBrush.DSL.Driver
-  ( SomeBrushFunction(..), interpretBrush )
 import MetaBrush.Serialisable
   ( Serialisable(..)
   , encodeSequence, decodeSequence
@@ -145,7 +141,7 @@ import MetaBrush.Serialisable
   , encodeSpline, decodeSpline
   )
 import MetaBrush.Records
-  ( Rec, WithParams )
+  ( Rec )
 import MetaBrush.Unique
   ( UniqueSupply, freshUnique )
 
@@ -206,37 +202,6 @@ loadDocument uniqueSupply fp = do
 
 --------------------------------------------------------------------------------
 
-{-
-encodeFocusState :: Applicative f => JSON.Encoder f FocusState
-encodeFocusState = contramap focusText JSON.Encoder.text
-  where
-    focusText :: FocusState -> Text
-    focusText Normal   = "normal"
-    focusText Hover    = "hover"
-    focusText Selected = "selected"
-
-decodeFocusState :: Monad m => JSON.Decoder m FocusState
-decodeFocusState = JSON.Decoder.oneOf JSON.Decoder.text "FocusState"
-  [ ( "normal"  , Normal   )
-  , ( "hover"   , Hover    )
-  , ( "selected", Selected )
-  ]
-
-
-
-encodeBrushPointData :: Applicative f => JSON.Encoder f BrushPointData
-encodeBrushPointData = JSON.Encoder.mapLikeObj \ ( BrushPointData { brushPointState } ) ->
-  JSON.Encoder.atKey' "focus" encodeFocusState brushPointState
-
-decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData
-decodeBrushPointData = do
-  brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState
-  pure ( BrushPointData { brushPointState } )
--}
-
-
-
-
 encodePointData
   :: forall f flds brushParams
   . ( Applicative f
@@ -267,84 +232,20 @@ decodePointData = do
 
 encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
 encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType @ty ) ->
-  case sTypeI @ty of
+  if
-    sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy
+    | Just Refl <- eqT @ty @Double
-      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun"
+    -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
-       . JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType @a )
+    | otherwise
-       . JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType @b )
+    -> error "SLD TODO" --( JSON.ParseFailed $ "Unsupported record field type (not double)" )
-    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 @a )
-    sTyLine@STyLine | ( _ :: SType ( Segment a ) ) <- sTyLine
-      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "line"
-       . 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 @a )
-    sTyBez3@STyBez3 | ( _ :: SType ( Cubic.Bezier a ) ) <- sTyBez3
-      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez3"
-       . 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 ( 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 @res )
-
-{-
-decodeSomeSType :: Monad m => JSON.Decoder m SomeSType
-decodeSomeSType = do
-  tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
-  case tag of
-    "fun"    -> do
-      ( 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 @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
-      pure ( SomeSType @( Point2D a ) )
-    "line"   -> do
-      ( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
-      pure ( SomeSType @( Segment a ) )
-    "bez2"   -> do
-      ( SomeSType @a ) <- JSON.Decoder.atKey "coords" decodeSomeSType
-      pure ( SomeSType @( Quadratic.Bezier a ) )
-    "bez3"   -> do
-      ( 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 @( SplinePts Closed ) )
-        False -> pure ( SomeSType @( SplinePts Open   ) )
-    "adaptableFun" -> do
-      ( 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 )
--}
 
 decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType
 decodeSomeFieldSType = do
   tag   <- JSON.Decoder.atKey "tag" JSON.Decoder.text
   case tag of
     "double" -> pure ( SomeFieldSType @Double )
-    "point"  -> do
-      SomeFieldSType @a <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
-      case eqTy @a @Double of
-        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 )
 
 
-
 encodeFieldTypes :: Monad f => JSON.Encoder f [ ( Text, SomeSType ) ]
 encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType
 
@@ -370,20 +271,15 @@ decodeFieldTypes = do
 
 encodeBrush :: Applicative f => JSON.Encoder f (Brush brushFields)
 encodeBrush = JSON.Encoder.mapLikeObj
-  \ ( BrushData { brushName, brushCode } ) ->
+  \ ( BrushData { brushName } ) ->
     JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
-  . JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode
 
-decodeBrush :: MonadIO m => UniqueSupply -> JSON.Decoder m SomeBrush
+decodeBrush :: MonadIO m => JSON.Decoder m SomeBrush
-decodeBrush uniqSupply = do
+decodeBrush = do
   brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
-  brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text
+  case lookupBrush brushName of
-  ( mbBrush, _ ) <- lift ( liftIO $ interpretBrush uniqSupply brushCode )
+    Nothing -> throwError ( JSON.ParseFailed ( "Unknown brush " <> brushName ) )
-  case mbBrush of
+    Just  b -> return b
-    Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) )
-    Right ( SomeBrushFunction brushFunction ) ->
-      pure ( SomeBrush $ BrushData { brushName, brushCode, brushFunction } )
-
 
 
 encodeStroke :: Monad f => JSON.Encoder f Stroke
@@ -421,7 +317,7 @@ decodeStroke uniqueSupply = do
   strokeUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
   strokeClosed  <- JSON.Decoder.atKey "closed"  JSON.Decoder.bool
   SomeBrushFields @pointFields <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
-  mbSomeBrush   <- JSON.Decoder.atKeyOptional "brush" ( decodeBrush uniqueSupply )
+  mbSomeBrush   <- JSON.Decoder.atKeyOptional "brush" decodeBrush
   if strokeClosed
   then do
     strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Rec pointFields ) ) decodePointData )

src/metabrushes/MetaBrush/Records.hs

@@ -25,7 +25,7 @@
 module MetaBrush.Records
   ( Record(..), Rec, AllFields(..)
 
-  , empty, insert
+  , empty, insert, lookup, Lookup
 
   , map, mapM
   , mapMWithKey
@@ -47,7 +47,7 @@ module MetaBrush.Records
 
 -- base
 import Prelude
-  hiding ( map, mapM, zipWith )
+  hiding ( lookup, map, mapM, zipWith )
 import Data.Coerce
   ( coerce )
 import Data.Functor.Const
@@ -63,9 +63,11 @@ import Data.Proxy
 import Data.Typeable
   ( Typeable, TypeRep, typeRep )
 import GHC.TypeLits
-  ( Symbol, KnownSymbol, symbolVal' )
+  ( Symbol, KnownSymbol, symbolVal'
+  , TypeError, ErrorMessage(..)
+  )
 import GHC.Exts
-  ( Any, Proxy#, proxy#, withDict )
+  ( Any, proxy#, withDict )
 import GHC.Show
   ( showCommaSpace )
 import Unsafe.Coerce
@@ -106,10 +108,29 @@ insert :: forall k v kvs f
 insert v (MkR r) = MkR $ HashMap.insert k v' r
   where
     k :: Text
-    k = Text.pack (symbolVal' (proxy# :: Proxy# k))
+    k = Text.pack $ symbolVal' @k proxy#
     v' :: f Any
     v' = unsafeCoerce v
 
+lookup :: forall k kvs f
+       .  KnownSymbol k
+       => Record f kvs -> f (Lookup k kvs)
+lookup ( MkR r ) = unsafeCoerce ( r HashMap.! k )
+  where
+    k :: Text
+    k = Text.pack $ symbolVal' @k proxy#
+
+type Lookup :: Symbol -> [(Symbol, Type)] -> Type
+type Lookup k kvs = LookupIn kvs k kvs
+
+type LookupIn :: [(Symbol, Type)] -> Symbol -> [(Symbol, Type)] -> Type
+type family LookupIn orig k kvs where
+  LookupIn _    k ( '(k, v) ': _ ) = v
+  LookupIn orig k ( _ ': kvs )     = LookupIn orig k kvs
+  LookupIn orig k _ = TypeError
+    (    'Text "Key '" :<>: ShowType k :<>: 'Text "' is not present in row:"
+    :$$: 'Text "  - " :<>: ShowType orig )
+
 type Rec :: [(Symbol, Type)] -> Type
 type Rec kvs = Record I kvs
 
@@ -140,7 +161,7 @@ instance ( c v, KnownSymbol k, AllFields c kvs ) => AllFields c ( '(k, v) ': kvs
     MkR kvs -> MkR $ HashMap.insert k dict kvs
       where
         k :: Text
-        k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
+        k = Text.pack $ symbolVal' @k proxy#
         dict :: Dict c Any
         dict = unsafeCoerce ( Dict :: Dict c v )
 

src/splines/Math/Bezier/Cubic.hs

@@ -84,13 +84,17 @@ import Math.Vector2D
 data Bezier p
   = Bezier
     { p0, p1, p2, p3 :: !p }
-  deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving stock ( Generic, Generic1, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
     via Generically ( Bezier p )
   deriving Applicative
     via Generically1 Bezier
   deriving anyclass ( NFData, NFData1 )
 
+instance Show p => Show (Bezier p) where
+  show (Bezier p1 p2 p3 p4) =
+    show p1 ++ "--" ++ show p2 ++ "--" ++ show p3 ++ "->" ++ show p4
+
 deriving via Ap Bezier p
   instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
 

src/splines/Math/Bezier/Quadratic.hs

@@ -79,13 +79,17 @@ import Math.Vector2D
 data Bezier p
   = Bezier
     { p0, p1, p2 :: !p }
-  deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving stock ( Generic, Generic1, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
     via Generically ( Bezier p )
   deriving Applicative
     via Generically1 Bezier
   deriving anyclass ( NFData, NFData1 )
 
+instance Show p => Show (Bezier p) where
+  show (Bezier p1 p2 p3) =
+    show p1 ++ "--" ++ show p2 ++ "->" ++ show p3
+
 deriving via Ap Bezier p
   instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
 

src/splines/Math/Bezier/Spline.hs

@@ -570,3 +570,22 @@ instance KnownSplineType Closed where
                 pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } )
               UseCurve lastCurve' ->
                 pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } )
+
+showSplinePoints :: forall clo ptData crvData
+                 .  (KnownSplineType clo, Show ptData)
+                 => Spline clo crvData ptData -> String
+showSplinePoints
+  = runIdentity
+  . bifoldSpline
+      ( \ _pt crv -> Identity $ f crv )
+      ( \ pt -> Identity $ "[ " <> show pt )
+  where
+    f :: SplineTypeI clo' => Curve clo' crvData ptData -> String
+    f (LineTo end _) = " -> " ++ showEnd end
+    f (Bezier2To cp end _) = " -- " ++ show cp ++ " -> " ++ showEnd end
+    f (Bezier3To cp1 cp2 end _) = " -- " ++ show cp1 ++ " -- " ++ show cp2 ++ " -> " ++ showEnd end
+
+    showEnd :: forall clo'. SplineTypeI clo' => NextPoint clo' ptData -> String
+    showEnd = case ssplineType @clo' of
+      SOpen   -> \ ( NextPoint pt ) -> show pt <> "\n,  "
+      SClosed -> \ BackToStart      -> ". ]"

src/splines/Math/Bezier/Stroke.hs

@@ -103,6 +103,7 @@ import Math.Bezier.Spline
     ( bifoldSpline, ibifoldSpline )
   , Spline(..), SplinePts, Curves(..), Curve(..)
   , openCurveStart, openCurveEnd, splitSplineAt, dropCurves
+  , showSplinePoints
   )
 import qualified Math.Bezier.Quadratic as Quadratic
 import Math.Epsilon
@@ -706,25 +707,26 @@ withTangent
   :: forall crvData ptData
   .  ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData )
   => Vector2D Double -> Spline Closed crvData ptData -> Offset
-withTangent ( Vector2D tx ty ) ( Spline { splineStart } )
+withTangent tgt_wanted spline@( Spline { splineStart } )
-  -- handle bad tangent vectors
+  -- only allow non-empty splines
-  |  isNaN tx
+  | Just tgt_last <- lastTangent spline
-  || isNaN ty
+  -- only allow well-defined query tangent vectors
-  || isInfinite tx
+  , not (badTangent tgt_wanted)
-  || isInfinite ty
+  = case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of
-  || ( abs tx < epsilon && abs ty < epsilon )
-  = Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }
-withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spline of
-  Nothing -> 
-    Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }
-  Just tgt_last ->
-    case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of
       Left off -> off
-      _ -> error $
+      Right _  ->
-            "withTangent: could not find any point with given tangent vector\n\
+        error $
-            \tangent vector: " <> show tgt_wanted <> "\n\
+          "withTangent: could not find any point with given tangent vector\n\
-            \spline: " <> show spline <> "\n"
+          \tangent vector: " <> show tgt_wanted <> "\n\
+          \spline:\n" <> showSplinePoints spline <> "\n"
+  | otherwise
+  = Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }
+
   where
+    badTangent :: Vector2D Double -> Bool
+    badTangent ( Vector2D tx ty ) =
+         isNaN tx || isNaN ty || isInfinite tx || isInfinite ty
+      || ( abs tx < epsilon && abs ty < epsilon )
     ori :: Orientation
     ori = splineOrientation @Double spline
     go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( Vector2D Double ) ( Except Offset ) ()

src/splines/Math/Vector2D.hs

@@ -45,19 +45,27 @@ import Data.Group.Generics
 --------------------------------------------------------------------------------
 
 data Point2D a = Point2D !a !a
-  deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving stock ( Eq, Generic, Generic1, Functor, Foldable, Traversable )
   deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
     via Vector2D a
   deriving Applicative
     via Generically1 Point2D
   deriving anyclass ( NFData, NFData1 )
 
+instance Show a => Show (Point2D a) where
+  showsPrec i (Point2D a b) = showsPrec i (a,b)
+
 newtype Vector2D a = MkVector2D { tip :: Point2D a }
-  deriving stock   ( Show, Generic, Generic1, Foldable, Traversable )
+  deriving stock   ( Generic, Generic1, Foldable, Traversable )
   deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 )
   deriving ( Semigroup, Monoid, Group )
     via Generically ( Point2D ( Sum a ) )
 
+data V a = V a a
+  deriving stock Show
+instance Show a => Show (Vector2D a) where
+  showsPrec i (Vector2D x y) = showsPrec i (V x y)
+
 {-# COMPLETE Vector2D #-}
 pattern Vector2D :: a -> a -> Vector2D a
 pattern Vector2D x y = MkVector2D ( Point2D x y )
@@ -74,9 +82,12 @@ data Segment p =
     { segmentStart :: !p
     , segmentEnd   :: !p
     }
-  deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving stock ( Generic, Generic1, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
     via Generically ( Segment p )
   deriving Applicative
     via Generically1 Segment
   deriving anyclass ( NFData, NFData1 )
+
+instance Show p => Show (Segment p) where
+  show (Segment s e) = show s ++ " -> " ++ show e