Progress til 10.5.1 (just before closures)

src/Environment.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Environment where
+
+import Control.Monad.Except (ExceptT, MonadError (..))
+import Control.Monad.State.Class qualified as State
+import Control.Monad.State.Strict (StateT)
+import Data.ByteString.Char8 (ByteString)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as M
+import Error qualified
+import {-# SOURCE #-} Expr qualified
+import TokenType qualified
+
+newtype InterpreterState = InterpreterState {environment :: Environment}
+
+{- |
+Removing newtypes, @InterpreterM a@ is equivalent to:
+  + @StateT InterpreterState Identitity (Either RuntimeError a)@
+  + @InterpreterState -> Identitity (Either RuntimeError a, InterpreterState)@
+-}
+type InterpreterM a =
+  ExceptT Error.RuntimeException (StateT InterpreterState IO) a
+
+----------------------------------
+--- module Environment where
+
+data Environment
+  = GlobalEnvironment
+      {values :: Map ByteString Expr.LiteralValue}
+  | LocalEnvironment
+      { values :: Map ByteString Expr.LiteralValue
+      , _enclosing :: Environment -- DO NOT USE
+      }
+
+{-# INLINEABLE define #-}
+define :: ByteString -> Expr.LiteralValue -> Environment -> Environment
+define name value environment =
+  environment {values = M.insert name value environment.values}
+
+{-# INLINEABLE get #-}
+get :: TokenType.Token -> InterpreterM Expr.LiteralValue
+get name = do
+  state <- State.get
+  case envget state.environment of
+    Just v -> pure v
+    Nothing ->
+      throwError $
+        Error.RuntimeError name ("Undefined variable '" <> name.lexeme <> "'.")
+  where
+    envget :: Environment -> Maybe Expr.LiteralValue
+    envget env =
+      case env.values M.!? name.lexeme of
+        Nothing ->
+          case env of
+            LocalEnvironment _ enc -> envget enc
+            _ -> Nothing
+        v -> v
+
+{-# INLINEABLE assign #-}
+assign :: TokenType.Token -> Expr.LiteralValue -> InterpreterM ()
+assign name value = do
+  -- there's no implicit variable declaration like in python
+  state <- State.get
+  case envassign state.environment of
+    Just newEnv ->
+      -- we update the interpreter state
+      State.put $ state {environment = newEnv}
+    Nothing ->
+      throwError $
+        Error.RuntimeError name ("Undefined variable '" <> name.lexeme <> "'.")
+  where
+    envassign :: Environment -> Maybe Environment
+    envassign env =
+      if M.member name.lexeme env.values
+        then Just $ define name.lexeme value env
+        else case env of
+          GlobalEnvironment _ -> Nothing
+          LocalEnvironment values enclosing ->
+            LocalEnvironment values <$> envassign enclosing
+
+----------------------------------

src/Error.hs

@@ -5,13 +5,14 @@ module Error
   , parseError
   , reportRuntimeError
   , ErrorPresent (..)
-  , RuntimeError (..)
+  , RuntimeException (..)
   )
 where
 
 import Control.Monad.IO.Class
 import Control.Monad.RWS.Class
 import Data.ByteString.Char8 as BS
+import {-# SOURCE #-} Expr qualified
 import System.IO (stderr)
 import TokenType (Token (..), TokenType (..))
 
@@ -40,10 +41,11 @@ parseError token message =
     then report token.tline " at end" message
     else report token.tline (" at '" <> token.lexeme <> "'") message
 
-data RuntimeError
+data RuntimeException
   = RuntimeError {token :: TokenType.Token, message :: BS.ByteString}
+  | RuntimeReturn {value :: Expr.LiteralValue}
 
-reportRuntimeError :: MonadIO m => RuntimeError -> m ()
+reportRuntimeError :: MonadIO m => RuntimeException -> m ()
 reportRuntimeError rerror =
   liftIO $
     putStrLnStderr $

src/Expr.hs

@@ -1,21 +1,25 @@
 module Expr (Expr (..), LiteralValue (..)) where
 
-{-Literal (..),-}
 import Data.ByteString.Char8 (ByteString)
+import Data.Vector (Vector)
+import Environment (InterpreterM)
 import TokenType (Token (..))
 
 data Expr
   = -- | > EAssign
     -- >   Token -- name
     -- >   Expr  -- value
-    EAssign
-      !Token
-      !Expr
+    EAssign !Token !Expr
   | -- | > EBinary
     -- >   Expr -- left
     -- >   Token -- operator
     -- >   Expr -- right
     EBinary !Expr !Token !Expr
+  | -- | > ECall
+    -- >   Expr   -- callee
+    -- >   Token  -- paren
+    -- >   [Expr] -- arguments
+    ECall !Expr !Token !(Vector Expr)
   | -- | > EGrouping
     -- >   Expr -- expression
     EGrouping
@@ -35,11 +39,25 @@ data Expr
   | -- | > EVariable
     -- >   Token -- name
     EVariable !Token
-  deriving (Show)
 
 data LiteralValue
   = LNil
   | LBool !Bool
   | LString !ByteString
   | LNumber !Double
-  deriving (Eq, Show)
+  | LCallable
+      { callable_arity :: Int
+      , callable_call
+          :: Vector Expr.LiteralValue
+          -> InterpreterM LiteralValue
+      , callable_toString :: ByteString
+      }
+
+instance Eq LiteralValue where
+  a == b = case (a, b) of
+    (LNil, LNil) -> True
+    (LBool x, LBool y) -> x == y
+    (LString x, LString y) -> x == y
+    -- Lox considers NaN equal to NaN, contrary to what (==) does (7.2.5)
+    (Expr.LNumber vl, Expr.LNumber vr) | isNaN vl && isNaN vr -> True
+    _ -> False

src/Expr.hs-boot

@@ -0,0 +1,3 @@
+module Expr (LiteralValue) where
+
+data LiteralValue