From eba08a6eddc9451da1f6a8f816a7d3d39a8190fc Mon Sep 17 00:00:00 2001 From: sheaf Date: Tue, 25 May 2021 13:45:21 +0200 Subject: [PATCH] add first-class functions to brush language --- src/app/MetaBrush/Application.hs | 19 +-- src/app/MetaBrush/Asset/Brushes.hs | 41 +++++-- src/app/MetaBrush/MetaParameter/AST.hs | 24 ++-- src/app/MetaBrush/MetaParameter/Eval.hs | 119 +++++++++++-------- src/app/MetaBrush/MetaParameter/Parse.hs | 88 ++++---------- src/app/MetaBrush/MetaParameter/PrimOp.hs | 12 +- src/app/MetaBrush/MetaParameter/Rename.hs | 15 ++- src/app/MetaBrush/MetaParameter/TypeCheck.hs | 21 +++- 8 files changed, 190 insertions(+), 149 deletions(-) diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 6d7dae7..904a5e9 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -102,7 +102,7 @@ import Math.Vector2D import MetaBrush.Action ( ActionOrigin(..) ) import qualified MetaBrush.Asset.Brushes as Asset.Brushes - ( circle ) + ( EllipseBrushFields, ellipse ) import MetaBrush.Asset.Colours ( getColours ) import MetaBrush.Asset.Logo @@ -164,7 +164,7 @@ runApplication application = do uniqueSupply <- newUniqueSupply - circleBrush <- Asset.Brushes.circle uniqueSupply + ellipseBrush <- Asset.Brushes.ellipse uniqueSupply docUnique <- runReaderT freshUnique uniqueSupply strokeUnique <- runReaderT freshUnique uniqueSupply @@ -179,14 +179,14 @@ runApplication application = do { strokeName = "Stroke 1" , strokeVisible = True , strokeUnique = strokeUnique - , strokeBrush = Just $ adaptBrush @'[ "r" SuperRecord.:= Double ] circleBrush + , strokeBrush = Just $ adaptBrush @Asset.Brushes.EllipseBrushFields ellipseBrush , strokeSpline = Spline - { splineStart = mkPoint ( Point2D 10 -20 ) 2 + { splineStart = mkPoint ( Point2D 10 -20 ) 2 1 0 , splineCurves = OpenCurves $ Seq.fromList - [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 10 ), curveData = invalidateCache undefined } - , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined } - , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 15 ), curveData = invalidateCache undefined } + [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 10 5 ( pi / 4 ) ), curveData = invalidateCache undefined } + , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 8 5 ( pi / 4 ) ), curveData = invalidateCache undefined } + , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined } ] } } @@ -194,8 +194,9 @@ runApplication application = do ) ] where - mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] ) - mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil ) + mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Super.Rec Asset.Brushes.EllipseBrushFields ) + mkPoint pt a b phi = PointData pt Normal + ( #a SuperRecord.:= a SuperRecord.& #b SuperRecord.:= b SuperRecord.& #phi SuperRecord.:= phi SuperRecord.& SuperRecord.rnil ) recomputeStrokesTVar <- STM.newTVarIO @Bool False documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () ) diff --git a/src/app/MetaBrush/Asset/Brushes.hs b/src/app/MetaBrush/Asset/Brushes.hs index 679178d..9927960 100644 --- a/src/app/MetaBrush/Asset/Brushes.hs +++ b/src/app/MetaBrush/Asset/Brushes.hs @@ -39,11 +39,10 @@ import MetaBrush.Unique -------------------------------------------------------------------------------- -circle - :: forall circleBrushFields - . ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] ) - => UniqueSupply -> IO ( Brush circleBrushFields ) -circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code +type CircleBrushFields = '[ "r" SuperRecord.:= Double ] + +circle :: UniqueSupply -> IO ( Brush CircleBrushFields ) +circle uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code where name, code :: Text name = "Circle" @@ -59,11 +58,8 @@ circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code \ -- (-r ,-r*c) -- (-r*c,-r ) -> ( 0,-r)\n\ \ -- ( r*c,-r ) -- ( r ,-r*c) -> . ]" -circleCW - :: forall circleBrushFields - . ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] ) - => UniqueSupply -> IO ( Brush circleBrushFields ) -circleCW uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code +circleCW :: UniqueSupply -> IO ( Brush CircleBrushFields ) +circleCW uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code where name, code :: Text name = "Circle CW" @@ -79,6 +75,31 @@ circleCW uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code \ -- (-r , r*c) -- (-r*c, r ) -> ( 0, r)\n\ \ -- ( r*c, r ) -- ( r , r*c) -> . ]" +type EllipseBrushFields = '[ "a" SuperRecord.:= Double, "b" SuperRecord.:= Double, "phi" SuperRecord.:= Double ] + +ellipse :: UniqueSupply -> IO ( Brush EllipseBrushFields ) +ellipse uniqueSupply = mkBrush @EllipseBrushFields uniqueSupply name code + 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 diff --git a/src/app/MetaBrush/MetaParameter/AST.hs b/src/app/MetaBrush/MetaParameter/AST.hs index b32a59d..9cd6c91 100644 --- a/src/app/MetaBrush/MetaParameter/AST.hs +++ b/src/app/MetaBrush/MetaParameter/AST.hs @@ -370,10 +370,19 @@ data Term ( p :: Pass ) ( kind :: K p ) where CExt :: !( X_Ext p ( T p a ) ) -> Term p ( T p a ) data Decl ( p :: Pass ) where - Decl :: C p ( STypeI a ) - => !( Loc p () ) - -> !( Pat p ( T p a ) ) -> !( Term p ( T p a ) ) - -> Decl p + 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 data Pat ( p :: Pass ) ( kind :: K p ) where PName :: { patName :: !( Loc p ( Name p ) ) } @@ -550,7 +559,7 @@ instance Ext Tc a where ------------------- termSpan :: Term p a -> Span -termSpan ( f :$ a ) = termSpan f <> termSpan a +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 @@ -561,7 +570,7 @@ 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 +termSpan ( CExt _ ) = mempty toTreeTerm @@ -617,7 +626,8 @@ toTreeDecl . ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs ) => Decl p -> Tree String -toTreeDecl ( Decl _ lhs rhs ) = Node "(=)" [ toTreePat lhs, toTreeTerm rhs ] +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 ) [ ] diff --git a/src/app/MetaBrush/MetaParameter/Eval.hs b/src/app/MetaBrush/MetaParameter/Eval.hs index 9a65952..5c49dbc 100644 --- a/src/app/MetaBrush/MetaParameter/Eval.hs +++ b/src/app/MetaBrush/MetaParameter/Eval.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,7 +21,7 @@ module MetaBrush.MetaParameter.Eval -- base import Data.Foldable - ( for_ ) + ( for_, traverse_ ) import Data.Functor.Compose ( Compose(..) ) import Data.Type.Equality @@ -107,7 +108,7 @@ eval ( PolyBez _ spline ) = ( const $ bitraverseCurve ( const $ pure () ) ( const eval ) ) eval spline -eval ( Let _ decls a ) = declare decls *> eval a +eval ( Let _ decls a ) = traverse_ declare decls *> eval a eval ( With _ ( Tc_With ( withDeclsRecord :: Super.Rec ( MapFields UniqueTerm brushFields ) ) ) _ ( body :: Term Tc r ) ) = do defaultParamsRecord <- SuperRecord.traverseC @IsUniqueTerm2 @( State EvalState ) @( MapFields UniqueTerm brushFields ) @( MapFields UniqueField brushFields ) @@ -154,56 +155,72 @@ eval ( Var var@( Located _ ( UniqueName _ varUniq ) ) ) = do ) eval ( CExt ( Val v ) ) = pure v -declare :: [ Decl Tc ] -> State EvalState () -declare [] = pure () -declare ( Decl _ pat t : next ) = go pat t *> declare next - where - go :: forall a. STypeI a => Pat Tc a -> Term Tc a -> State EvalState ( Maybe UniqueName ) - go ( PName ( Located _ patUniqName@( UniqueName _ patUniq ) ) ) r = do +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.insert patUniq $ TypedTerm r ) - pure ( Just patUniqName ) - go ( 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 ) - ] - ) - go lpat var_l - go rpat var_r - pure ( Just pairName ) - go ( AsPat _ ( Located _ asUniqName@( UniqueName _ asUniq ) ) patt ) r = do - mbNm <- go patt r - for_ mbNm \ nm -> - modifying ( field' @"evalHeap" ) - ( Map.insert asUniq ( TypedTerm $ Var @Tc @a ( Located noSpan nm ) ) ) - pure ( Just asUniqName ) - go ( PWild _ ) _ = pure Nothing + ( 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 usedFields defaultFields diff --git a/src/app/MetaBrush/MetaParameter/Parse.hs b/src/app/MetaBrush/MetaParameter/Parse.hs index f4fd0e0..d673ab2 100644 --- a/src/app/MetaBrush/MetaParameter/Parse.hs +++ b/src/app/MetaBrush/MetaParameter/Parse.hs @@ -80,6 +80,7 @@ import MetaBrush.MetaParameter.PrimOp , scale_around_by, scale_by , shear_from_by, shear_by , translate_by + , map_over ) -------------------------------------------------------------------------------- @@ -101,61 +102,6 @@ showParses x = do tree = toTreeTerm expr drawTree tree -examples :: [ Located Token ] -> Int -> IO () -examples inputToks n = - for_ ( Earley.exactly n ( Earley.generator grammar inputToks ) ) \ ( expr, toks ) -> do - for_ toks ( located >>> showToken >>> ( <> " " ) >>> putStr ) - putStrLn "" - drawTree ( toTreeTerm expr ) - putStrLn "\n\n" - -someToks :: [ Located Token ] -someToks = map ( Located mempty ) - [ TokAlphabetic "x" - , TokAlphabetic "let" - , TokAlphabetic "in" - , TokSpecial '[' - , TokSpecial ']' - , TokSpecial '(' - , TokSpecial ')' - , TokSymbolic "=" - , TokSymbolic "--" - , TokSymbolic "->" - , TokSymbolic "." - ] - -test1 :: Text -test1 = - " let\n\ - \ q = rotate p around c CW by theta + 3 * theta2\n\ - \ r = scale ( translate q by t ) by (7,11)\n\ - \ in rotate q around p CW by phi" - -test2 :: Text -test2 = - " let\n\ - \ p = (3,3)\n\ - \ q = (1,1)\n\ - \ in\n\ - \ rotate p\n\ - \ around q\n\ - \ CCW by\n\ - \ let\n\ - \ q = pi / 2 \n\ - \ in q" - -test3 :: Text -test3 = - " let\n\ - \ p = (1,1)\n\ - \ in\n\ - \ [ p -- c1 -- c2 -> q\n\ - \ -- c3 -- c4 -> r\n\ - \ -> s -> .\n\ - \ ]" - - - -------------------------------------------------------------------------------- -- Language grammar. @@ -227,14 +173,24 @@ grammar = mdo anyPattern <- Earley.rule ( ( basicPattern <|> asPattern ) "pattern" ) declaration <- - Earley.rule + Earley.rule $ ( do - p <- anyPattern + funName <- alphabeticName + anyWhitespace + argPat <- anyPattern anyWhitespace eqLoc <- symbol "=" - e <- expr - pure ( Location ( location eqLoc ), p, e ) - "declaration" + 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 @@ -242,7 +198,7 @@ grammar = mdo separator decl <- declaration more <- moreDeclarations - pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl + pure ( decl : more ) <|> pure [] ) @@ -251,7 +207,7 @@ grammar = mdo ( do decl <- declaration more <- moreDeclarations - pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl + pure ( decl : more ) <|> pure [] ) @@ -361,6 +317,7 @@ reserved [ "let", "in" , "with", "set", "satisfying" , "around", "by", "rotate", "scale", "shear", "translate", "transform" + , "map", "over" , "cw", "ccw" , "pi", "tau", "kappa" ] @@ -520,6 +477,13 @@ mixfixTable "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 diff --git a/src/app/MetaBrush/MetaParameter/PrimOp.hs b/src/app/MetaBrush/MetaParameter/PrimOp.hs index b045b4d..af0b983 100644 --- a/src/app/MetaBrush/MetaParameter/PrimOp.hs +++ b/src/app/MetaBrush/MetaParameter/PrimOp.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} module MetaBrush.MetaParameter.PrimOp where -- MetaBrush +import Math.Bezier.Spline + ( SplineType(Closed), SplinePts ) import Math.Vector2D ( Point2D(..) ) @@ -19,15 +22,15 @@ kappa = 0.5519150244935105707435627227925 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 :: 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 ) +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 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 ) @@ -40,3 +43,6 @@ shear_by ( Point2D px py ) ( Point2D vx vy ) = undefined translate_by :: Point2D Double -> Point2D Double -> Point2D Double translate_by ( Point2D px py ) ( Point2D tx ty ) = Point2D ( px + tx ) ( py + ty ) + +map_over :: ( Point2D Double -> Point2D Double ) -> ( SplinePts Closed -> SplinePts Closed ) +map_over = fmap diff --git a/src/app/MetaBrush/MetaParameter/Rename.hs b/src/app/MetaBrush/MetaParameter/Rename.hs index e79de88..3b2b26b 100644 --- a/src/app/MetaBrush/MetaParameter/Rename.hs +++ b/src/app/MetaBrush/MetaParameter/Rename.hs @@ -117,13 +117,22 @@ renameDecls decls = do where go :: Map Text Unique -> [ Decl P ] -> m [ Decl Rn ] - go outerLocalVars ( Decl loc lhs rhs : next ) = do + 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 each right-hand side with the full LHS info. + -- Now rename the right-hand side with the full LHS info. rhs' <- locally ( rename rhs ) - pure $ Decl loc lhs' rhs' : next' + 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, diff --git a/src/app/MetaBrush/MetaParameter/TypeCheck.hs b/src/app/MetaBrush/MetaParameter/TypeCheck.hs index e18a688..17e1400 100644 --- a/src/app/MetaBrush/MetaParameter/TypeCheck.hs +++ b/src/app/MetaBrush/MetaParameter/TypeCheck.hs @@ -263,10 +263,20 @@ typeCheckDecls = go [] catchOutOfScope _ err = throwError err typeCheckDecl :: MonadTc m => Decl Rn -> m ( Decl Tc ) -typeCheckDecl ( Decl loc lhs rhs ) = do +typeCheckDecl ( ValDecl lhs eqLoc rhs ) = do TypedTerm ( rhs' :: Term Tc a ) <- typeCheck rhs lhs' <- typeCheckPatAt @a lhs - pure ( Decl loc lhs' rhs' ) + 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 ( proxy# :: Proxy# ( 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 @@ -307,10 +317,11 @@ withDeclsRecord decls f = do revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ] revSortDecls = fmap ( sortOn ( Down . fst ) ) . traverse getDeclName getDeclName :: Decl Tc -> m ( Text, ( UniqueName, TypedTerm ) ) - getDeclName ( Decl ( Located loc _ ) pat term ) = case pat of + getDeclName ( ValDecl pat ( Located eqLoc _ ) term ) = case pat of PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, ( uniq, TypedTerm term ) ) AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, ( uniq, TypedTerm term ) ) - _ -> tcError $ NoPatternName loc + _ -> tcError $ NoPatternName eqLoc + getDeclName ( FunDecl funName _ _ _ ) = tcError $ UnexpectedFunDecl funName go :: TypedTermsRecord -> [ ( Text, ( UniqueName, TypedTerm ) ) ] -> TypedTermsRecord go record [] = record go ( TypedTermsRecord ( record :: Super.Rec ( MapFields UniqueTerm kvs ) ) ) @@ -413,6 +424,8 @@ data TcError } | OutOfScope { outOfScopeVar :: !( Located UniqueName ) } + | UnexpectedFunDecl + { funDeclLoc :: !( Located UniqueName ) } deriving stock ( Show, Generic ) data TcWarning = TcWarning