diff --git a/src/Environment.hs b/src/Environment.hs index e73b84f..e616dad 100644 --- a/src/Environment.hs +++ b/src/Environment.hs @@ -5,6 +5,7 @@ module Environment ( InterpreterState (..) , InterpreterM , Environment (..) + , ClassMethodChain (..) , lookUpVariable , assignAt , assignFromMap @@ -48,6 +49,14 @@ data Environment } deriving (Show, Eq) +data ClassMethodChain + = ClassNoSuper {this_methods :: IORef (Map ByteString Expr.Callable)} + | ClassWithSuper + { this_methods :: IORef (Map ByteString Expr.Callable) + , _superMethods :: ClassMethodChain + } + deriving (Eq) + instance Show (IORef (Map ByteString Expr.LiteralValue)) where show _ = "iorefmap" diff --git a/src/Expr.hs b/src/Expr.hs index 7899bbf..efa0441 100644 --- a/src/Expr.hs +++ b/src/Expr.hs @@ -9,6 +9,7 @@ module Expr , Expr2 , Callable (..) , eqLiteralValue + , XEnvDistance ) where @@ -16,7 +17,7 @@ import Data.ByteString.Char8 (ByteString) import Data.IORef (IORef) import Data.Map.Strict (Map) import Data.Vector (Vector) -import Environment (Environment, InterpreterM) +import Environment (ClassMethodChain, Environment, InterpreterM) import Stmt qualified import TokenType (Token (..)) @@ -97,7 +98,7 @@ data Callable } | CClass { callable_toString :: !ByteString - , callable_arity :: Int + , callable_arity :: !Int , callable_call :: ( Token -- function token -> Vector Stmt.Stmt2 -- body of lox function @@ -108,7 +109,7 @@ data Callable ) -> Vector LiteralValue -- arguments -> InterpreterM LiteralValue - , class_methods :: !(IORef (Map ByteString Callable)) + , class_methods :: !ClassMethodChain } instance Eq Callable where @@ -125,6 +126,7 @@ eqCallable x y = && (isinit1 == isinit2) && closure1 == closure2 (CClass name1 arity1 _ methds1, CClass name2 arity2 _ methds2) -> + -- TODO superclasses (name1 == name2) && (arity1 == arity2) && (methds1 == methds2) @@ -137,9 +139,9 @@ data LiteralValue | LNumber !Double | LCallable Callable | LInstance - { _LInstanceFields :: IORef (Map ByteString LiteralValue) - , _LInstanceClassName :: ByteString - , _LInstanceMethods :: IORef (Map ByteString Callable) + { _LInstanceFields :: !(IORef (Map ByteString LiteralValue)) + , _LInstanceClassName :: !ByteString + , _LInstanceMethods :: !ClassMethodChain } instance Eq LiteralValue where diff --git a/src/Expr.hs-boot b/src/Expr.hs-boot index c166446..c1fc3ca 100644 --- a/src/Expr.hs-boot +++ b/src/Expr.hs-boot @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} -module Expr (IPhase (..), LiteralValue, Expr) where +module Expr (IPhase (..), LiteralValue, Expr, XEnvDistance, Callable) where data LiteralValue @@ -10,3 +11,9 @@ data IPhase = PH1 | PH2 type role Expr nominal data Expr (phase :: IPhase) + +type family XEnvDistance (phase :: IPhase) where + XEnvDistance PH1 = () + XEnvDistance PH2 = Int + +data Callable diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 697e03c..f7c2589 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -7,7 +7,6 @@ module Interpreter (evaluate, interpret) where import Control.Monad (void, when) -import Control.Monad.Error.Class (catchError) import Control.Monad.Except (runExceptT, throwError, tryError) import Control.Monad.State.Strict ( MonadIO (..) @@ -26,7 +25,6 @@ import Data.Maybe (fromMaybe) import Data.Time.Clock.POSIX qualified as Time import Data.Vector (Vector) import Data.Vector qualified as V -import Debug.Trace (traceShowId, traceShowWith) import Environment import Error qualified import Expr qualified @@ -123,38 +121,49 @@ getInstanceFieldOrMethod :: TokenType.Token -> ByteString -> IORef (Map ByteString Expr.LiteralValue) - -> IORef (Map ByteString Expr.Callable) + -> ClassMethodChain -> InterpreterM Expr.LiteralValue -getInstanceFieldOrMethod fieldName instanceName fieldsRef methdsRef = do +getInstanceFieldOrMethod fieldName instanceName fieldsRef classMethodChain = do fields <- liftIO $ readIORef fieldsRef case fields M.!? fieldName.lexeme of Just v -> pure v Nothing -> do - methds <- liftIO $ readIORef methdsRef - case methds M.!? fieldName.lexeme of + checkMethodchain classMethodChain >>= \case Just foundMthd -> do Expr.LCallable . fst - <$> bind fieldName fieldsRef instanceName methdsRef foundMthd + <$> bind fieldName fieldsRef instanceName classMethodChain foundMthd Nothing -> throwError $ Error.RuntimeError fieldName ("Undefined property '" <> fieldName.lexeme <> "'.") + where + checkMethodchain :: ClassMethodChain -> InterpreterM (Maybe Expr.Callable) + checkMethodchain = \case + ClassNoSuper v -> common v + ClassWithSuper v n -> + common v >>= \case + Nothing -> checkMethodchain n + just -> pure just + where + common + :: IORef (Map ByteString Expr.Callable) -> InterpreterM (Maybe Expr.Callable) + common ref = liftIO (readIORef ref) >>= \m -> pure (m M.!? fieldName.lexeme) bind :: TokenType.Token -> IORef (Map ByteString Expr.LiteralValue) -> ByteString - -> IORef (Map ByteString Expr.Callable) + -> ClassMethodChain -> Expr.Callable -> InterpreterM (Expr.Callable, Expr.LiteralValue) -bind fieldName fieldsRef instanceName methdsRef cf = +bind fieldName fieldsRef instanceName methdsChain cf = case cf of Expr.CFunction {} -> do newClosureEnv <- liftIO (newIORef M.empty) <&> \mref -> LocalEnvironment mref cf.callable_closure - let classInstance = Expr.LInstance fieldsRef instanceName methdsRef + let classInstance = Expr.LInstance fieldsRef instanceName methdsChain define "this" classInstance newClosureEnv pure (cf {Expr.callable_closure = newClosureEnv}, classInstance) _ -> @@ -219,11 +228,18 @@ execute = \case newEnvValueMapRef <- liftIO $ newIORef mempty prevEnv <- State.gets (.environment) executeBlock statements prevEnv (LocalEnvironment newEnvValueMapRef prevEnv) - Stmt.SClass klassName _methods -> do + Stmt.SClass klassName superclass _methods -> do + superClassMethdChain <- case superclass of + Nothing -> pure Environment.ClassNoSuper + Just (superclassTok, dist) -> + evaluate (Expr.EVariable superclassTok dist) + >>= \case + Expr.LCallable (Expr.CClass {Expr.class_methods}) -> pure $ \curr -> Environment.ClassWithSuper curr class_methods + _ -> throwError $ Error.RuntimeError superclassTok "Superclass must be a class." env <- State.gets (.environment) define klassName.lexeme Expr.LNil env mayInitMethd <- liftIO $ newIORef Nothing - methodsRef <- + thisClassMethodsChain <- V.foldM ( \acc next@(Stmt.FFunctionH fname _ _) -> do let isInit = fname.lexeme == "init" @@ -236,21 +252,20 @@ execute = \case M.empty _methods >>= (liftIO . newIORef) + <&> superClassMethdChain mayInit <- liftIO (readIORef mayInitMethd) let (classArity, initMaker) = case mayInit of Just (initTok, originalInitMthd) -> do let initM fieldMapRef args = do (initFunc, classInstance) <- - bind initTok fieldMapRef klassName.lexeme methodsRef originalInitMthd - initFunc.callable_call - (call initFunc.callable_closure) - args + bind initTok fieldMapRef klassName.lexeme thisClassMethodsChain originalInitMthd + initFunc.callable_call (call initFunc.callable_closure) args pure classInstance (originalInitMthd.callable_arity, initM) Nothing -> do let initM fieldMapRef _args = pure $ - Expr.LInstance fieldMapRef klassName.lexeme methodsRef + Expr.LInstance fieldMapRef klassName.lexeme thisClassMethodsChain (0, initM) let klass = Expr.LCallable $ @@ -260,7 +275,7 @@ execute = \case , Expr.callable_call = \_evaluator args -> do fieldMapRef <- liftIO $ newIORef M.empty initMaker fieldMapRef args - , Expr.class_methods = methodsRef + , Expr.class_methods = thisClassMethodsChain } assignFromMap klassName klass env.values Stmt.SFunction f@(Stmt.FFunctionH name _params _body) -> do diff --git a/src/Parser.hs b/src/Parser.hs index c9b6423..d126a14 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant <$>" #-} @@ -97,10 +98,15 @@ declaration = do classDeclaration :: ParserM r Stmt.Stmt1 classDeclaration = do name <- consume IDENTIFIER "Expect class name." + superclass <- + safePeek >>= \case + Just (Token LESS _ _) -> + advance >> Just . (,()) <$> consume IDENTIFIER "expect superclass name." + _ -> pure Nothing consume LEFT_BRACE "Expect '{' before class body.." methods <- getMethods VB.empty consume RIGHT_BRACE "Expect '}' after class body." - pure $ Stmt.SClass name methods + pure $ Stmt.SClass name superclass methods where getMethods :: VB.Builder Stmt.FunctionH1 -> ParserM r (Vector Stmt.FunctionH1) getMethods accum = do diff --git a/src/Resolver.hs b/src/Resolver.hs index 6dbee31..68c8be9 100644 --- a/src/Resolver.hs +++ b/src/Resolver.hs @@ -53,11 +53,17 @@ resolveStmt = \case newStmts <- traverse resolveStmt stmts endScope pure $ Stmt.SBlock newStmts - Stmt.SClass name _methods -> do + Stmt.SClass name superclass _methods -> do enclosingClass <- State.gets (.currentClass) State.modify' $ \st -> st {currentClass = CTClass} declare name define name + nSuperclass <- case superclass of + Just (superclassTok, ()) -> do + when (superclassTok.lexeme == name.lexeme) $ + Error.resolverError superclassTok "A class can't inherit from itself." + Just . (superclassTok,) <$> resolveVariableName superclassTok + Nothing -> pure Nothing beginScope newSt <- @@ -80,7 +86,7 @@ resolveStmt = \case _methods endScope State.modify' $ \st -> st {currentClass = enclosingClass} - pure $ Stmt.SClass name nMethods + pure $ Stmt.SClass name nSuperclass nMethods Stmt.SVar name initializer -> do declare name nInitializer <- traverse resolveExpr initializer @@ -129,18 +135,22 @@ resolveFunction params body funType = do endScope pure nBody +resolveVariableName :: TokenType.Token -> ResolverM Int +resolveVariableName name = do + State.gets (.scopes) >>= \case + [] -> pure () + (closestScope : _) -> + case closestScope M.!? name.lexeme of + Just v + | not v -> + Error.resolverError name "Can't read local variable in its own initializer." + _ -> pure () + resolveLocal name.lexeme + resolveExpr :: Expr.Expr1 -> ResolverM Expr.Expr2 resolveExpr = \case Expr.EVariable name _ -> do - State.gets (.scopes) >>= \case - [] -> pure () - (closestScope : _) -> - case closestScope M.!? name.lexeme of - Just v - | not v -> - Error.resolverError name "Can't read local variable in its own initializer." - _ -> pure () - distance <- resolveLocal name.lexeme + distance <- resolveVariableName name pure $ Expr.EVariable name distance Expr.EAssign name value _ -> do nValue <- resolveExpr value diff --git a/src/Stmt.hs b/src/Stmt.hs index 9c0cbdc..11f99a6 100644 --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -16,8 +16,12 @@ data Stmt (phase :: Expr.IPhase) SBlock !(Vector (Stmt phase)) | -- | > SClass -- > Token -- name + -- > Maybe (Token, XEnvDistance phase) -- superclass -- > Vector (FunctionH phase) -- methods - SClass !TokenType.Token !(Vector (FunctionH phase)) + SClass + !TokenType.Token + !(Maybe (TokenType.Token, Expr.XEnvDistance phase)) + !(Vector (FunctionH phase)) | -- | > SExpression -- > Expr phase -- expression SExpression !(Expr.Expr phase) diff --git a/test/ch13.lox b/test/ch13.lox new file mode 100644 index 0000000..6ec4a31 --- /dev/null +++ b/test/ch13.lox @@ -0,0 +1,10 @@ +class Doughnut { + cook() { + print "Fry until golden brown."; + } +} + +class BostonCream < Doughnut {} + +BostonCream().cook(); +