mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
kill off brush EDSL
This commit is contained in:
sheaf
parent
e6565aeb00
commit
4e5c848883
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) )
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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" [] ]
|
||||
|
|
@ -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 )
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 )
|
||||
-}
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -> ". ]"
|
||||
|
|
|
|||
|
|
@ -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 ) ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue