From 45419d88a6dc826dfad0c129482d5b448d0b20c0 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 19 Dec 2023 00:36:11 +0100 Subject: [PATCH] add Nockma programs and extend the repl --- app/Commands/Dev/Nockma/Repl.hs | 90 ++++++++++++++----- src/Juvix/Compiler/Nockma/Evaluator.hs | 30 +++++++ src/Juvix/Compiler/Nockma/Evaluator/Error.hs | 1 + src/Juvix/Compiler/Nockma/Language.hs | 33 ++++++- .../Compiler/Nockma/Translation/FromSource.hs | 77 +++++++++++++++- src/Juvix/Prelude/Base.hs | 3 + 6 files changed, 205 insertions(+), 29 deletions(-) diff --git a/app/Commands/Dev/Nockma/Repl.hs b/app/Commands/Dev/Nockma/Repl.hs index 31941c03f7..4850d1ad4d 100644 --- a/app/Commands/Dev/Nockma/Repl.hs +++ b/app/Commands/Dev/Nockma/Repl.hs @@ -4,18 +4,21 @@ 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, eval) +import Juvix.Compiler.Nockma.Evaluator (NockEvalError, evalRepl) import Juvix.Compiler.Nockma.Language import Juvix.Compiler.Nockma.Pretty (ppPrint) -import Juvix.Compiler.Nockma.Translation.FromSource (parseText) +import Juvix.Compiler.Nockma.Translation.FromSource (parseProgramFile, parseReplExpression, parseText) import Juvix.Parser.Error import System.Console.Haskeline import System.Console.Repline qualified as Repline +import Text.Megaparsec (errorBundlePretty) type ReplS = State.StateT ReplState IO -newtype ReplState = ReplState - {_replStateStack :: Maybe (Term Natural)} +data ReplState = ReplState + { _replStateProgram :: Maybe (Program Natural), + _replStateStack :: Maybe (Term Natural) + } type Repl a = Repline.HaskelineT ReplS a @@ -27,39 +30,72 @@ quit _ = liftIO (throwIO Interrupt) printStack :: String -> Repl () printStack _ = Repline.dontCrash $ do stack <- getStack - liftIO (putStrLn (ppPrint stack)) + case stack of + Nothing -> noStackErr + Just s -> liftIO (putStrLn (ppPrint s)) + +noStackErr :: a +noStackErr = error "no stack is set. Use :set-stack to set a stack." setStack :: String -> Repl () setStack s = Repline.dontCrash $ do newStack <- readTerm s State.modify (set replStateStack (Just newStack)) +loadFile :: String -> Repl () +loadFile s = Repline.dontCrash $ do + prog <- readProgram s + State.modify (set replStateProgram (Just prog)) + options :: [(String, String -> Repl ())] -options = [("quit", quit), ("get-stack", printStack), ("set-stack", setStack)] +options = + [ ("quit", quit), + ("get-stack", printStack), + ("set-stack", setStack), + ("load", loadFile) + ] banner :: Repline.MultiLine -> Repl String banner = \case Repline.MultiLine -> return "... " Repline.SingleLine -> return "nockma> " -getStack :: Repl (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 = 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) + +getProgram :: Repl (Maybe (Program Natural)) +getProgram = State.gets (^. replStateProgram) + +readProgram :: FilePath -> Repl (Program Natural) +readProgram s = fromMegaParsecError <$> parseProgramFile s + +fromMegaParsecError :: Either MegaparsecError a -> a +fromMegaParsecError = \case + Left (MegaparsecError e) -> error (pack (errorBundlePretty e)) + Right a -> a readTerm :: String -> Repl (Term Natural) -readTerm s = do - let p = parseText (strip (pack s)) - case p of - Left (e :: MegaparsecError) -> error (show e) - Right t -> return t - -evalTerm :: Term Natural -> Repl (Term Natural) -evalTerm t = do +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 - let et = run (runError @(ErrNockNatural Natural) (runError @NockEvalError (eval s t))) + prog <- getProgram + let et = + run + . runError @(ErrNockNatural Natural) + . runError @NockEvalError + $ evalRepl prog s t case et of Left e -> error (show e) Right ev -> case ev of @@ -68,8 +104,7 @@ evalTerm t = do replCommand :: String -> Repl () replCommand input = Repline.dontCrash $ do - t <- readTerm input - et <- evalTerm t + et <- readExpression input >>= evalExpression liftIO (putStrLn (ppPrint et)) replAction :: ReplS () @@ -87,4 +122,11 @@ replAction = } runCommand :: forall r. (Members '[Embed IO, App] r) => NockmaReplOptions -> Sem r () -runCommand _ = embed . (`State.evalStateT` (ReplState {_replStateStack = Nothing})) $ replAction +runCommand _ = embed . (`State.evalStateT` iniState) $ replAction + where + iniState :: ReplState + iniState = + ReplState + { _replStateStack = Nothing, + _replStateProgram = Nothing + } diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index 65cc1f2c81..350e660a00 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator.hs @@ -68,6 +68,36 @@ parseCell c = case c ^. cellLeft of _operatorCellTerm = t } +-- | The stack provided in the replExpression has priority +evalRepl :: + forall r a. + (Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) => + Maybe (Program a) -> + Maybe (Term a) -> + 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) + stack <- maybe errNoStack return mstack + eval stack (fromReplTerm t) + 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 + ] + eval :: forall r a. (Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) => Term a -> Term a -> Sem r (Term a) eval stack = \case TermAtom {} -> throw ExpectedCell diff --git a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs index c20c0f669f..4c48507a88 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs @@ -7,6 +7,7 @@ data NockEvalError = InvalidPosition | ExpectedAtom | ExpectedCell + | NoStack deriving stock (Show) newtype GenericNockEvalError = GenericNockEvalError diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index 74ce2780d9..aaaf4014eb 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -5,6 +5,32 @@ import GHC.Base (Type) import Juvix.Prelude hiding (Atom) import Juvix.Prelude.Pretty +data ReplExpression a + = ReplExpressionTerm (ReplTerm a) + | ReplExpressionWithStack (WithStack a) + +data WithStack a = WithStack + { _withStackStack :: ReplTerm a, + _withStackTerm :: ReplTerm a + } + +data ReplTerm a + = ReplName Text + | ReplTerm (Term a) + +newtype Program a = Program + { _programStatements :: [Statement a] + } + +data Statement a + = StatementAssignment (Assignment a) + | StatementStandalone (Term a) + +data Assignment a = Assignment + { _assignmentName :: Text, + _assignmentBody :: Term a + } + data Term a = TermAtom (Atom a) | TermCell (Cell a) @@ -78,7 +104,9 @@ data ParsedCell a type EncodedPosition = Natural -data Direction = L | R +data Direction + = L + | R deriving stock (Show) newtype Position = Position {_positionDirections :: [Direction]} @@ -89,6 +117,9 @@ makeLenses ''Atom makeLenses ''OperatorCell makeLenses ''AutoConsCell makeLenses ''Position +makeLenses ''Program +makeLenses ''Assignment +makeLenses ''WithStack naturalNockOps :: HashMap Natural NockOp naturalNockOps = HashMap.fromList [(serializeOp op, op) | op <- allElements] diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource.hs index 1156ae2b7f..527a181572 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource.hs @@ -2,6 +2,7 @@ module Juvix.Compiler.Nockma.Translation.FromSource where import Data.HashMap.Internal.Strict qualified as HashMap import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text import Juvix.Compiler.Nockma.Language qualified as N import Juvix.Parser.Error import Juvix.Prelude hiding (Atom, many, some) @@ -14,11 +15,25 @@ type Parser = Parsec Void Text parseText :: Text -> Either MegaparsecError (N.Term Natural) parseText = runParser "" -runParser :: FilePath -> Text -> Either MegaparsecError (N.Term Natural) -runParser f input = case P.runParser term f input of +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 "" + +runParserProgram :: FilePath -> Text -> Either MegaparsecError (N.Program Natural) +runParserProgram = runParserFor program + +runParserFor :: Parser a -> FilePath -> Text -> Either MegaparsecError a +runParserFor p f input = case P.runParser p f input of Left err -> Left (MegaparsecError err) Right t -> Right t +runParser :: FilePath -> Text -> Either MegaparsecError (N.Term Natural) +runParser = runParserFor term + spaceConsumer :: Parser () spaceConsumer = L.space space1 empty empty @@ -62,10 +77,18 @@ atomNat :: Parser (N.Atom Natural) atomNat = (\n -> N.Atom n (Irrelevant Nothing)) <$> dottedNatural atomBool :: Parser (N.Atom Natural) -atomBool = choice [symbol "true" $> N.nockTrue, symbol "false" $> N.nockFalse] +atomBool = + choice + [ symbol "true" $> N.nockTrue, + symbol "false" $> N.nockFalse + ] atom :: Parser (N.Atom Natural) -atom = atomOp <|> atomNat <|> atomDirection <|> atomBool +atom = + atomOp + <|> atomNat + <|> atomDirection + <|> atomBool cell :: Parser (N.Cell Natural) cell = do @@ -84,3 +107,49 @@ term :: Parser (N.Term Natural) term = N.TermAtom <$> atom <|> N.TermCell <$> cell + +program :: Parser (N.Program Natural) +program = N.Program <$> many statement <* eof + where + statement :: Parser (N.Statement Natural) + statement = + 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 + hs <- P.takeWhileP Nothing isAlphaNum + return (Text.cons h hs) + +withStack :: Parser (N.WithStack Natural) +withStack = do + st <- replTerm + symbol "/" + tm <- replTerm + return + N.WithStack + { _withStackStack = st, + _withStackTerm = tm + } + +replExpression :: Parser (N.ReplExpression Natural) +replExpression = + N.ReplExpressionWithStack <$> P.try withStack + <|> N.ReplExpressionTerm <$> replTerm + +replTerm :: Parser (N.ReplTerm Natural) +replTerm = + N.ReplName <$> name + <|> N.ReplTerm <$> term diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs index 9ed64fcba7..ed983aae9b 100644 --- a/src/Juvix/Prelude/Base.hs +++ b/src/Juvix/Prelude/Base.hs @@ -556,3 +556,6 @@ indexedByInt getIx l = IntMap.fromList [(getIx i, i) | i <- toList l] indexedByHash :: (Foldable f, Hashable k) => (a -> k) -> f a -> HashMap k a indexedByHash getIx l = HashMap.fromList [(getIx i, i) | i <- toList l] + +hashMap :: (Foldable f, Hashable k) => f (k, v) -> HashMap k v +hashMap = HashMap.fromList . toList