add Nockma programs and extend the repl

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 <TERM> 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 <TERM> 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 <TERM> 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
+        }

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

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

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

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]

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

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