Progress til before 13.3

* basic classes and inheritance done!

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"
 

src/Expr.hs

@@ -9,14 +9,15 @@ module Expr
   , Expr2
   , Callable (..)
   , eqLiteralValue
+  , XEnvDistance
   )
 where
 
 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

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

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

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

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

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)

test/ch13.lox

@@ -0,0 +1,10 @@
+class Doughnut {
+  cook() {
+    print "Fry until golden brown.";
+  }
+}
+
+class BostonCream < Doughnut {}
+
+BostonCream().cook();
+