diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 7526875..25fc228 100644 --- a/MetaBrush.cabal +++ b/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 diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 316c56b..ad98e68 100644 --- a/src/app/MetaBrush/Application.hs +++ b/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 diff --git a/src/metabrushes/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs index 4c775a5..10ef341 100644 --- a/src/metabrushes/MetaBrush/Asset/Brushes.hs +++ b/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 -import Data.Kind - ( Type ) -import Data.Type.Equality - ( (:~:)(Refl) ) -import GHC.TypeLits - ( Symbol ) +-- containers +import qualified Data.Sequence as Seq + ( fromList ) -- 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 ) -import MetaBrush.DSL.Types - ( STypesI(..), eqTys - ) -import MetaBrush.DSL.Driver - ( SomeBrushFunction(..) - , interpretBrush - ) -import MetaBrush.Unique - ( UniqueSupply ) + ( Brush(..), SomeBrush(..) ) +import MetaBrush.Records + ( Rec, WithParams(..), I(..) ) +import qualified MetaBrush.Records as Rec -------------------------------------------------------------------------------- type CircleBrushFields = '[ '("r", Double) ] -circle :: UniqueSupply -> IO ( Brush CircleBrushFields ) -circle uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code - 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) -> . ]" +lookupBrush :: Text -> Maybe SomeBrush +lookupBrush nm = HashMap.lookup nm brushes -circleCW :: UniqueSupply -> IO ( Brush CircleBrushFields ) -circleCW uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code +-- | All brushes supported by this application. +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 - name = "Circle CW" - 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) -> . ]" + crvs = Seq.fromList + [ Bezier3To (p 1 c) (p c 1 ) (NextPoint (p 0 1 )) () + , Bezier3To (p (-c) 1) (p (-1) c ) (NextPoint (p (-1) 0 )) () + , Bezier3To (p (-1) (-c)) (p (-c) (-1)) (NextPoint (p 0 (-1))) () + ] + lastCrv = + Bezier3To (p c (-1)) (p 1 (-c)) BackToStart () + +circle :: Brush CircleBrushFields +circle = BrushData "circle" (WithParams deflts shape) + where + deflts :: Rec CircleBrushFields + 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 uniqueSupply = mkBrush @EllipseBrushFields uniqueSupply name code +ellipse :: Brush EllipseBrushFields +ellipse = BrushData "ellipse" (WithParams deflts shape) where - name, code :: Text - name = "Ellipse" - code = - "with\n\ - \ a = 1\n\ - \ b = 1\n\ - \ phi = 0\n\ - \satisfying\n\ - \ a > 0 && b > 0\n\ - \define\n\ - \ let\n\ - \ c = kappa\n\ - \ applyRotation pt = rotate pt CCW by phi\n\ - \ 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 ) - ) + deflts :: Rec EllipseBrushFields + deflts = Rec.insert @"a" (I 1) + $ Rec.insert @"b" (I 1) + $ Rec.insert @"phi" (I 0) + $ Rec.empty + shape :: Rec EllipseBrushFields -> SplinePts 'Closed + shape params = + let + !(I !a ) = Rec.lookup @"a" params + !(I !b ) = Rec.lookup @"b" params + !(I !phi) = Rec.lookup @"phi" params + in circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi) + (b * y * cos phi + a * x * sin phi) ) diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index fabb338..21f258d 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/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 } ) - = deepseq brushCode - $ rnf brushName + rnf ( BrushData { 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 ( hashWithSalt salt brushName ) brushCode + hashWithSalt salt ( BrushData { brushName } ) = + 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. -- diff --git a/src/metabrushes/MetaBrush/DSL/AST.hs b/src/metabrushes/MetaBrush/DSL/AST.hs deleted file mode 100644 index 832fec5..0000000 --- a/src/metabrushes/MetaBrush/DSL/AST.hs +++ /dev/null @@ -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" [] ] diff --git a/src/metabrushes/MetaBrush/DSL/Driver.hs b/src/metabrushes/MetaBrush/DSL/Driver.hs deleted file mode 100644 index 56f49f6..0000000 --- a/src/metabrushes/MetaBrush/DSL/Driver.hs +++ /dev/null @@ -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 ) diff --git a/src/metabrushes/MetaBrush/DSL/Eval.hs b/src/metabrushes/MetaBrush/DSL/Eval.hs deleted file mode 100644 index f97069f..0000000 --- a/src/metabrushes/MetaBrush/DSL/Eval.hs +++ /dev/null @@ -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 diff --git a/src/metabrushes/MetaBrush/DSL/Parse.hs b/src/metabrushes/MetaBrush/DSL/Parse.hs deleted file mode 100644 index 3991fca..0000000 --- a/src/metabrushes/MetaBrush/DSL/Parse.hs +++ /dev/null @@ -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 diff --git a/src/metabrushes/MetaBrush/DSL/PrimOp.hs b/src/metabrushes/MetaBrush/DSL/PrimOp.hs deleted file mode 100644 index a1f6cc6..0000000 --- a/src/metabrushes/MetaBrush/DSL/PrimOp.hs +++ /dev/null @@ -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 diff --git a/src/metabrushes/MetaBrush/DSL/Rename.hs b/src/metabrushes/MetaBrush/DSL/Rename.hs deleted file mode 100644 index fcc5590..0000000 --- a/src/metabrushes/MetaBrush/DSL/Rename.hs +++ /dev/null @@ -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 diff --git a/src/metabrushes/MetaBrush/DSL/TypeCheck.hs b/src/metabrushes/MetaBrush/DSL/TypeCheck.hs deleted file mode 100644 index b80eb8f..0000000 --- a/src/metabrushes/MetaBrush/DSL/TypeCheck.hs +++ /dev/null @@ -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 ) --} diff --git a/src/metabrushes/MetaBrush/DSL/Types.hs b/src/metabrushes/MetaBrush/DSL/Types.hs index ca8b8c8..98deb6b 100644 --- a/src/metabrushes/MetaBrush/DSL/Types.hs +++ b/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 - ( Point2D(..), Segment(..) ) -import qualified Math.Bezier.Cubic as Cubic - ( Bezier(..) ) -import qualified Math.Bezier.Quadratic as Quadratic - ( Bezier(..) ) -import Math.Bezier.Spline - ( SplinePts - , SSplineType(..), SplineTypeI(ssplineType) - , KnownSplineType - ) -import MetaBrush.Records - ( WithParams ) +import MetaBrush.DSL.Interpolation + ( Interpolatable ) -------------------------------------------------------------------------------- -- Types. -type SType :: Type -> Type -data SType ty where - SFunTy :: ( STypeI a, STypeI b ) => SType ( a -> b ) - STyBool :: SType Bool - STyDouble :: SType Double - STyPoint :: STypeI a => SType ( Point2D a ) - STyLine :: STypeI a => SType ( Segment a ) - STyBez2 :: STypeI a => SType ( Quadratic.Bezier a ) - STyBez3 :: STypeI a => SType ( Cubic.Bezier a ) - STySpline :: KnownSplineType clo => SType ( SplinePts clo ) - STyWithFn :: ( STypesI kvs, STypeI a ) => SType ( WithParams kvs a ) - -- reminder: update eqSTy when adding new constructors - -deriving stock instance Show ( SType ty ) - -class STypeI ty where - sTypeI :: SType ty -instance ( STypeI a, STypeI b ) => STypeI ( a -> b ) where - sTypeI = SFunTy -instance STypeI Bool where - sTypeI = STyBool -instance STypeI Double where - sTypeI = STyDouble -instance STypeI a => STypeI ( Point2D a ) where - sTypeI = STyPoint -instance STypeI a => STypeI ( Segment a ) where - sTypeI = STyLine -instance STypeI a => STypeI ( Quadratic.Bezier a ) where - sTypeI = STyBez2 -instance STypeI a => STypeI ( Cubic.Bezier a ) where - sTypeI = STyBez3 -instance KnownSplineType clo => STypeI ( SplinePts clo ) where - sTypeI = STySpline -instance ( STypesI kvs, STypeI a ) => STypeI ( WithParams kvs a ) where - sTypeI = STyWithFn +class ( Typeable ty, Interpolatable ty ) => STypeI ty where +instance ( Typeable ty, Interpolatable ty ) => STypeI ty where 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 diff --git a/src/metabrushes/MetaBrush/Document.hs b/src/metabrushes/MetaBrush/Document.hs index 2aee1b3..bd66bf8 100644 --- a/src/metabrushes/MetaBrush/Document.hs +++ b/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 diff --git a/src/metabrushes/MetaBrush/Document/Draw.hs b/src/metabrushes/MetaBrush/Document/Draw.hs index 203027c..363f9f4 100644 --- a/src/metabrushes/MetaBrush/Document/Draw.hs +++ b/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 diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index a1f6b7a..d45add2 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/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 - , eqTy - ) -import MetaBrush.DSL.Driver - ( SomeBrushFunction(..), interpretBrush ) + ( SomeSType(..), someSTypes ) 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 - sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy - -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun" - . JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType @a ) - . JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType @b ) - STyBool - -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bool" - STyDouble - -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double" - sTyPoint@STyPoint | ( _ :: SType ( Point2D a ) ) <- sTyPoint - -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "point" - . JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType @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 ) --} + if + | Just Refl <- eqT @ty @Double + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double" + | otherwise + -> error "SLD TODO" --( JSON.ParseFailed $ "Unsupported record field type (not double)" ) 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 uniqSupply = do +decodeBrush :: MonadIO m => JSON.Decoder m SomeBrush +decodeBrush = do brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text - brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text - ( mbBrush, _ ) <- lift ( liftIO $ interpretBrush uniqSupply brushCode ) - case mbBrush of - Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) ) - Right ( SomeBrushFunction brushFunction ) -> - pure ( SomeBrush $ BrushData { brushName, brushCode, brushFunction } ) - + case lookupBrush brushName of + Nothing -> throwError ( JSON.ParseFailed ( "Unknown brush " <> brushName ) ) + Just b -> return b 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 ) diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index f53090b..0165ec6 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/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 ) diff --git a/src/splines/Math/Bezier/Cubic.hs b/src/splines/Math/Bezier/Cubic.hs index 429c14a..52fb2f1 100644 --- a/src/splines/Math/Bezier/Cubic.hs +++ b/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 ) diff --git a/src/splines/Math/Bezier/Quadratic.hs b/src/splines/Math/Bezier/Quadratic.hs index f805b1b..8bbbba8 100644 --- a/src/splines/Math/Bezier/Quadratic.hs +++ b/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 ) diff --git a/src/splines/Math/Bezier/Spline.hs b/src/splines/Math/Bezier/Spline.hs index 5eb648d..1a2a8f6 100644 --- a/src/splines/Math/Bezier/Spline.hs +++ b/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 -> ". ]" diff --git a/src/splines/Math/Bezier/Stroke.hs b/src/splines/Math/Bezier/Stroke.hs index 4ad5bcd..2726d36 100644 --- a/src/splines/Math/Bezier/Stroke.hs +++ b/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 } ) - -- handle bad tangent vectors - | isNaN tx - || isNaN ty - || isInfinite tx - || isInfinite ty - || ( 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 +withTangent tgt_wanted spline@( Spline { splineStart } ) + -- only allow non-empty splines + | Just tgt_last <- lastTangent spline + -- only allow well-defined query tangent vectors + , not (badTangent tgt_wanted) + = case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of Left off -> off - _ -> error $ - "withTangent: could not find any point with given tangent vector\n\ - \tangent vector: " <> show tgt_wanted <> "\n\ - \spline: " <> show spline <> "\n" + Right _ -> + error $ + "withTangent: could not find any point with given tangent vector\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 ) () diff --git a/src/splines/Math/Vector2D.hs b/src/splines/Math/Vector2D.hs index 09fd634..4a2c3e1 100644 --- a/src/splines/Math/Vector2D.hs +++ b/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