From de5472bb5688c5e51c77f64f04c22969e08d1074 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Tue, 19 Dec 2023 10:47:34 +0000 Subject: [PATCH] Several REPL improvements --- app/Commands/Dev/Nockma/Repl.hs | 105 +++++++++++++----- src/Juvix/Compiler/Nockma/Evaluator.hs | 33 +++--- src/Juvix/Compiler/Nockma/Evaluator/Error.hs | 1 + src/Juvix/Compiler/Nockma/Language.hs | 4 + .../Compiler/Nockma/Translation/FromSource.hs | 34 +++--- 5 files changed, 120 insertions(+), 57 deletions(-) diff --git a/app/Commands/Dev/Nockma/Repl.hs b/app/Commands/Dev/Nockma/Repl.hs index 4850d1ad4d..121854a861 100644 --- a/app/Commands/Dev/Nockma/Repl.hs +++ b/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,20 +60,32 @@ noStackErr = error "no stack is set. Use :set-stack 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 @@ -60,13 +93,6 @@ 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 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 } diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index 350e660a00..26923e09cc 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/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 diff --git a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs index 4c48507a88..327424a241 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs @@ -8,6 +8,7 @@ data NockEvalError | ExpectedAtom | ExpectedCell | NoStack + | AssignmentNotFound Text deriving stock (Show) newtype GenericNockEvalError = GenericNockEvalError diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index aaaf4014eb..52acf0b778 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/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) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource.hs index 527a181572..fdc1561fb7 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource.hs +++ b/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