Several REPL improvements

app/Commands/Dev/Nockma/Repl.hs

@@ -1,29 +1,50 @@
+{-# LANGUAGE QuasiQuotes #-}
+
 module Commands.Dev.Nockma.Repl where
 
 import Commands.Base hiding (Atom)
 import Commands.Dev.Nockma.Repl.Options
 import Control.Exception (throwIO)
 import Control.Monad.State.Strict qualified as State
-import Juvix.Compiler.Nockma.Evaluator (NockEvalError, evalRepl)
+import Data.String.Interpolate (__i)
+import Juvix.Compiler.Nockma.Evaluator (NockEvalError, evalRepl, fromReplTerm, programAssignments)
 import Juvix.Compiler.Nockma.Language
 import Juvix.Compiler.Nockma.Pretty (ppPrint)
-import Juvix.Compiler.Nockma.Translation.FromSource (parseProgramFile, parseReplExpression, parseText)
+import Juvix.Compiler.Nockma.Translation.FromSource (parseProgramFile, parseReplStatement, parseReplText, parseText)
 import Juvix.Parser.Error
 import System.Console.Haskeline
 import System.Console.Repline qualified as Repline
 import Text.Megaparsec (errorBundlePretty)
+import Prelude (read)
 
 type ReplS = State.StateT ReplState IO
 
 data ReplState = ReplState
   { _replStateProgram :: Maybe (Program Natural),
-    _replStateStack :: Maybe (Term Natural)
+    _replStateStack :: Maybe (Term Natural),
+    _replStateLoadedFile :: Maybe (FilePath)
   }
 
 type Repl a = Repline.HaskelineT ReplS a
 
 makeLenses ''ReplState
 
+printHelpTxt :: Repl ()
+printHelpTxt = liftIO $ putStrLn helpTxt
+  where
+    helpTxt :: Text =
+      [__i|
+  EXPRESSION                      Evaluate a Nockma expression in the context of the current stack
+  STACK_EXPRESSION / EXPRESSION   Evaluate a Nockma EXPRESSION in the context of STACK_EXPRESSION
+  :load FILE                      Load a file containing Nockma assignments
+  :reload                         Reload the current file
+  :help                           Print help text and describe options
+  :set-stack EXPRESSION           Set the current stack
+  :get-stack                      Print the current stack
+  :dir       NATURAL              Convert a natural number representing a position into a sequence of L and Rs. S means the empty sequence
+  :quit                           Exit the REPL
+          |]
+
 quit :: String -> Repl ()
 quit _ = liftIO (throwIO Interrupt)
 
@@ -39,34 +60,39 @@ noStackErr = error "no stack is set. Use :set-stack <TERM> to set a stack."
 
 setStack :: String -> Repl ()
 setStack s = Repline.dontCrash $ do
-  newStack <- readTerm s
+  newStack <- readReplTerm s
   State.modify (set replStateStack (Just newStack))
 
 loadFile :: String -> Repl ()
 loadFile s = Repline.dontCrash $ do
+  State.modify (set replStateLoadedFile (Just s))
   prog <- readProgram s
   State.modify (set replStateProgram (Just prog))
 
+reloadFile :: Repl ()
+reloadFile = Repline.dontCrash $ do
+  fp <- State.gets (^. replStateLoadedFile)
+  case fp of
+    Nothing -> error "no file loaded"
+    Just f -> do
+      prog <- readProgram f
+      State.modify (set replStateProgram (Just prog))
+
 options :: [(String, String -> Repl ())]
 options =
   [ ("quit", quit),
     ("get-stack", printStack),
     ("set-stack", setStack),
-    ("load", loadFile)
+    ("load", loadFile),
+    ("reload", const reloadFile),
+    ("dir", direction')
   ]
 
 banner :: Repline.MultiLine -> Repl String
 banner = \case
   Repline.MultiLine -> return "... "
   Repline.SingleLine -> return "nockma> "
 
--- getStack :: Repl (Maybe (Term Natural))
--- getStack = do
---   ms <- State.gets (^. replStateStack)
---   case ms of
---     Just s -> return s
---     Nothing -> error "no stack is set. Use :set-stack <TERM> to set a stack."
-
 getStack :: Repl (Maybe (Term Natural))
 getStack = State.gets (^. replStateStack)
 
@@ -81,31 +107,49 @@ fromMegaParsecError = \case
   Left (MegaparsecError e) -> error (pack (errorBundlePretty e))
   Right a -> a
 
+direction' :: String -> Repl ()
+direction' s = Repline.dontCrash $ do
+  let n = read s :: Natural
+      p = run (runFailDefault (error "invalid position") (decodePosition n))
+  liftIO (putStrLn (ppPrint p))
+
 readTerm :: String -> Repl (Term Natural)
 readTerm s = return (fromMegaParsecError (parseText (strip (pack s))))
 
-readExpression :: String -> Repl (ReplExpression Natural)
-readExpression s = return (fromMegaParsecError (parseReplExpression (strip (pack s))))
-
-evalExpression :: ReplExpression Natural -> Repl (Term Natural)
-evalExpression t = do
-  s <- getStack
-  prog <- getProgram
-  let et =
-        run
-          . runError @(ErrNockNatural Natural)
-          . runError @NockEvalError
-          $ evalRepl prog s t
-  case et of
+readReplTerm :: String -> Repl (Term Natural)
+readReplTerm s = do
+  mprog <- getProgram
+  let t = run $ runError @NockEvalError (fromReplTerm (programAssignments mprog) (fromMegaParsecError (parseReplText (strip (pack s)))))
+  case t of
     Left e -> error (show e)
-    Right ev -> case ev of
+    Right tv -> return tv
+
+readStatement :: String -> Repl (ReplStatement Natural)
+readStatement s = return (fromMegaParsecError (parseReplStatement (strip (pack s))))
+
+evalStatement :: ReplStatement Natural -> Repl ()
+evalStatement = \case
+  ReplStatementAssignment as -> do
+    prog <- fromMaybe (Program []) <$> getProgram
+    let p' = over programStatements (++ [StatementAssignment as]) prog
+    State.modify (set replStateProgram (Just p'))
+  ReplStatementExpression t -> do
+    s <- getStack
+    prog <- getProgram
+    let et =
+          run
+            . runError @(ErrNockNatural Natural)
+            . runError @NockEvalError
+            $ evalRepl prog s t
+    case et of
       Left e -> error (show e)
-      Right res -> return res
+      Right ev -> case ev of
+        Left e -> error (show e)
+        Right res -> liftIO (putStrLn (ppPrint res))
 
 replCommand :: String -> Repl ()
 replCommand input = Repline.dontCrash $ do
-  et <- readExpression input >>= evalExpression
-  liftIO (putStrLn (ppPrint et))
+  readStatement input >>= evalStatement
 
 replAction :: ReplS ()
 replAction =
@@ -128,5 +172,6 @@ runCommand _ = embed . (`State.evalStateT` iniState) $ replAction
     iniState =
       ReplState
         { _replStateStack = Nothing,
-          _replStateProgram = Nothing
+          _replStateProgram = Nothing,
+          _replStateLoadedFile = Nothing
         }

src/Juvix/Compiler/Nockma/Evaluator.hs

@@ -68,6 +68,18 @@ parseCell c = case c ^. cellLeft of
             _operatorCellTerm = t
           }
 
+fromReplTerm :: (Members '[Error NockEvalError] r) => HashMap Text (Term a) -> ReplTerm a -> Sem r (Term a)
+fromReplTerm namedTerms = \case
+  ReplName n -> maybe (throw (AssignmentNotFound n)) return (namedTerms ^. at n)
+  ReplTerm t -> return t
+
+programAssignments :: Maybe (Program a) -> HashMap Text (Term a)
+programAssignments mprog =
+  hashMap
+    [ (as ^. assignmentName, as ^. assignmentBody)
+      | StatementAssignment as <- mprog ^. _Just . programStatements
+    ]
+
 -- | The stack provided in the replExpression has priority
 evalRepl ::
   forall r a.
@@ -77,26 +89,19 @@ evalRepl ::
   ReplExpression a ->
   Sem r (Term a)
 evalRepl mprog defaultStack expr = do
-  let (mstack, t) = case expr of
-        ReplExpressionTerm tm -> (defaultStack, tm)
-        ReplExpressionWithStack w -> (Just (fromReplTerm (w ^. withStackStack)), w ^. withStackTerm)
+  (mstack, t) <- case expr of
+    ReplExpressionTerm tm -> return (defaultStack, tm)
+    ReplExpressionWithStack w -> do
+      t' <- fromReplTerm namedTerms (w ^. withStackStack)
+      return (Just t', w ^. withStackTerm)
   stack <- maybe errNoStack return mstack
-  eval stack (fromReplTerm t)
+  fromReplTerm namedTerms t >>= eval stack
   where
     errNoStack :: Sem r x
     errNoStack = throw NoStack
 
-    fromReplTerm :: ReplTerm a -> Term a
-    fromReplTerm = \case
-      ReplName n -> namedTerms ^?! at n . _Just
-      ReplTerm t -> t
-
     namedTerms :: HashMap Text (Term a)
-    namedTerms =
-      hashMap
-        [ (as ^. assignmentName, as ^. assignmentBody)
-          | StatementAssignment as <- mprog ^. _Just . programStatements
-        ]
+    namedTerms = programAssignments mprog
 
 eval :: forall r a. (Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) => Term a -> Term a -> Sem r (Term a)
 eval stack = \case

src/Juvix/Compiler/Nockma/Evaluator/Error.hs

@@ -8,6 +8,7 @@ data NockEvalError
   | ExpectedAtom
   | ExpectedCell
   | NoStack
+  | AssignmentNotFound Text
   deriving stock (Show)
 
 newtype GenericNockEvalError = GenericNockEvalError

src/Juvix/Compiler/Nockma/Language.hs

@@ -5,6 +5,10 @@ import GHC.Base (Type)
 import Juvix.Prelude hiding (Atom)
 import Juvix.Prelude.Pretty
 
+data ReplStatement a
+  = ReplStatementExpression (ReplExpression a)
+  | ReplStatementAssignment (Assignment a)
+
 data ReplExpression a
   = ReplExpressionTerm (ReplTerm a)
   | ReplExpressionWithStack (WithStack a)

src/Juvix/Compiler/Nockma/Translation/FromSource.hs

@@ -15,13 +15,16 @@ type Parser = Parsec Void Text
 parseText :: Text -> Either MegaparsecError (N.Term Natural)
 parseText = runParser ""
 
+parseReplText :: Text -> Either MegaparsecError (N.ReplTerm Natural)
+parseReplText = runParserFor replTerm ""
+
 parseProgramFile :: (MonadIO m) => FilePath -> m (Either MegaparsecError (N.Program Natural))
 parseProgramFile fp = do
   txt <- readFile fp
   return (runParserProgram fp txt)
 
-parseReplExpression :: Text -> Either MegaparsecError (N.ReplExpression Natural)
-parseReplExpression = runParserFor replExpression ""
+parseReplStatement :: Text -> Either MegaparsecError (N.ReplStatement Natural)
+parseReplStatement = runParserFor replStatement ""
 
 runParserProgram :: FilePath -> Text -> Either MegaparsecError (N.Program Natural)
 runParserProgram = runParserFor program
@@ -108,6 +111,17 @@ term =
   N.TermAtom <$> atom
     <|> N.TermCell <$> cell
 
+assig :: Parser (N.Assignment Natural)
+assig = do
+  n <- name
+  symbol ":="
+  t <- term
+  return
+    N.Assignment
+      { _assignmentName = n,
+        _assignmentBody = t
+      }
+
 program :: Parser (N.Program Natural)
 program = N.Program <$> many statement <* eof
   where
@@ -116,17 +130,6 @@ program = N.Program <$> many statement <* eof
       P.try (N.StatementAssignment <$> assig)
         <|> N.StatementStandalone <$> term
 
-    assig :: Parser (N.Assignment Natural)
-    assig = do
-      n <- name
-      symbol ":="
-      t <- term
-      return
-        N.Assignment
-          { _assignmentName = n,
-            _assignmentBody = t
-          }
-
 name :: Parser Text
 name = lexeme $ do
   h <- P.satisfy isLetter
@@ -149,6 +152,11 @@ replExpression =
   N.ReplExpressionWithStack <$> P.try withStack
     <|> N.ReplExpressionTerm <$> replTerm
 
+replStatement :: Parser (N.ReplStatement Natural)
+replStatement =
+  N.ReplStatementAssignment <$> P.try assig
+    <|> N.ReplStatementExpression <$> replExpression
+
 replTerm :: Parser (N.ReplTerm Natural)
 replTerm =
   N.ReplName <$> name