Add the JuvixCore framework and its evaluator (#1421)

app/App.hs

@@ -11,6 +11,7 @@ import System.Console.ANSI qualified as Ansi
 data App m a where
   ExitMsg :: ExitCode -> Text -> App m ()
   ExitJuvixError :: JuvixError -> App m a
+  PrintJuvixError :: JuvixError -> App m ()
   ReadGlobalOptions :: App m GlobalOptions
   RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
   RunPipelineEither :: Sem PipelineEff a -> App m (Either JuvixError a)
@@ -31,11 +32,16 @@ runAppIO g = interpret $ \case
   Say t
     | g ^. globalOnlyErrors -> return ()
     | otherwise -> embed (putStrLn t)
+  PrintJuvixError e -> do
+    printErr e
   ExitJuvixError e -> do
-    (embed . hPutStrLn stderr . Error.render (not (g ^. globalNoColors)) (g ^. globalOnlyErrors)) e
+    printErr e
     embed exitFailure
   ExitMsg exitCode t -> embed (putStrLn t >> exitWith exitCode)
   Raw b -> embed (ByteString.putStr b)
+  where
+    printErr e =
+      (embed . hPutStrLn stderr . Error.render (not (g ^. globalNoColors)) (g ^. globalOnlyErrors)) e
 
 runPipeline :: Member App r => Sem PipelineEff a -> Sem r a
 runPipeline p = do

app/Commands/Dev.hs

@@ -1,5 +1,6 @@
 module Commands.Dev
   ( module Commands.Dev,
+    module Commands.Dev.Core,
     module Commands.Dev.Internal,
     module Commands.Dev.Parse,
     module Commands.Dev.Scope,
@@ -8,6 +9,7 @@ module Commands.Dev
   )
 where
 
+import Commands.Dev.Core
 import Commands.Dev.Doc
 import Commands.Dev.Internal
 import Commands.Dev.Parse
@@ -21,6 +23,7 @@ data InternalCommand
   = DisplayRoot
   | Highlight HighlightOptions
   | Internal MicroCommand
+  | Core CoreCommand
   | MiniC
   | MiniHaskell
   | MonoJuvix
@@ -39,6 +42,7 @@ parseInternalCommand =
     ( mconcat
         [ commandHighlight,
           commandInternal,
+          commandCore,
           commandMiniC,
           commandMiniHaskell,
           commandMonoJuvix,
@@ -96,6 +100,13 @@ commandInternal =
       (Internal <$> parseMicroCommand)
       (progDesc "Subcommands related to Internal")
 
+commandCore :: Mod CommandFields InternalCommand
+commandCore =
+  command "core" $
+    info
+      (Core <$> parseCoreCommand)
+      (progDesc "Subcommands related to JuvixCore")
+
 commandMiniHaskell :: Mod CommandFields InternalCommand
 commandMiniHaskell =
   command "minihaskell" $

app/Commands/Dev/Core.hs

@@ -0,0 +1,69 @@
+module Commands.Dev.Core where
+
+import Juvix.Prelude hiding (Doc)
+import Options.Applicative
+
+data CoreCommand
+  = Repl CoreReplOptions
+  | Eval CoreEvalOptions
+
+newtype CoreReplOptions = CoreReplOptions
+  { _coreReplShowDeBruijn :: Bool
+  }
+
+newtype CoreEvalOptions = CoreEvalOptions
+  { _coreEvalNoIO :: Bool
+  }
+
+makeLenses ''CoreReplOptions
+makeLenses ''CoreEvalOptions
+
+defaultCoreEvalOptions :: CoreEvalOptions
+defaultCoreEvalOptions =
+  CoreEvalOptions
+    { _coreEvalNoIO = False
+    }
+
+parseCoreCommand :: Parser CoreCommand
+parseCoreCommand =
+  hsubparser $
+    mconcat
+      [ commandRepl,
+        commandEval
+      ]
+  where
+    commandRepl :: Mod CommandFields CoreCommand
+    commandRepl = command "repl" replInfo
+
+    commandEval :: Mod CommandFields CoreCommand
+    commandEval = command "eval" evalInfo
+
+    replInfo :: ParserInfo CoreCommand
+    replInfo =
+      info
+        (Repl <$> parseCoreReplOptions)
+        (progDesc "Start an interactive session of the JuvixCore evaluator")
+
+    evalInfo :: ParserInfo CoreCommand
+    evalInfo =
+      info
+        (Eval <$> parseCoreEvalOptions)
+        (progDesc "Evaluate a JuvixCore file and pretty print the result")
+
+parseCoreEvalOptions :: Parser CoreEvalOptions
+parseCoreEvalOptions = do
+  _coreEvalNoIO <-
+    switch
+      ( long "no-io"
+          <> help "Don't interpret the IO effects"
+      )
+  pure CoreEvalOptions {..}
+
+parseCoreReplOptions :: Parser CoreReplOptions
+parseCoreReplOptions = do
+  _coreReplShowDeBruijn <-
+    switch
+      ( long "show-de-bruijn"
+          <> help "Show variable de Bruijn indices"
+      )
+  pure CoreReplOptions {..}

app/Main.hs

@@ -23,6 +23,15 @@ import Juvix.Compiler.Concrete.Data.InfoTable qualified as Scoper
 import Juvix.Compiler.Concrete.Pretty qualified as Scoper
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
 import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
+import Juvix.Compiler.Core.Data.InfoTable qualified as Core
+import Juvix.Compiler.Core.Error qualified as Core
+import Juvix.Compiler.Core.Evaluator qualified as Core
+import Juvix.Compiler.Core.Extra.Base qualified as Core
+import Juvix.Compiler.Core.Info qualified as Info
+import Juvix.Compiler.Core.Info.NoDisplayInfo qualified as Info
+import Juvix.Compiler.Core.Language qualified as Core
+import Juvix.Compiler.Core.Pretty qualified as Core
+import Juvix.Compiler.Core.Translation.FromSource qualified as Core
 import Juvix.Compiler.Internal.Pretty qualified as Internal
 import Juvix.Compiler.Internal.Translation.FromAbstract qualified as Internal
 import Juvix.Compiler.Internal.Translation.FromAbstract.Analysis.Termination qualified as Termination
@@ -39,6 +48,7 @@ import Juvix.Prelude.Pretty hiding (Doc)
 import Options.Applicative
 import System.Environment (getProgName)
 import System.Process qualified as Process
+import Text.Megaparsec.Pos qualified as M
 import Text.Show.Pretty hiding (Html)
 
 findRoot :: CommandGlobalOptions -> IO (FilePath, Package)
@@ -103,6 +113,7 @@ runCommand cmdWithOpts = do
   (root, pkg) <- embed (findRoot cmdWithOpts)
   case cmd of
     (Dev DisplayRoot) -> say (pack root)
+    (Dev (Core cmd')) -> runCoreCommand globalOpts cmd'
     _ -> do
       -- Other commands require an entry point:
       case getEntryPoint root pkg globalOpts of
@@ -264,6 +275,147 @@ runCommand cmdWithOpts = do
                                 printSuccessExit (n <> " Terminates with order " <> show (toList k))
                 _ -> impossible
 
+runCoreCommand :: Members '[Embed IO, App] r => GlobalOptions -> CoreCommand -> Sem r ()
+runCoreCommand globalOpts = \case
+  Repl opts -> do
+    embed showReplWelcome
+    runRepl opts Core.emptyInfoTable
+  Eval opts ->
+    case globalOpts ^. globalInputFiles of
+      [] -> printFailureExit "Provide a JuvixCore file to run this command\nUse --help to see all the options"
+      files -> mapM_ (evalFile opts) files
+  where
+    runRepl ::
+      forall r.
+      Members '[Embed IO, App] r =>
+      CoreReplOptions ->
+      Core.InfoTable ->
+      Sem r ()
+    runRepl opts tab = do
+      embed (putStr "> ")
+      embed (hFlush stdout)
+      done <- embed isEOF
+      unless done $ do
+        s <- embed getLine
+        case fromText (strip s) of
+          ":q" -> return ()
+          ":h" -> do
+            embed showReplHelp
+            runRepl opts tab
+          ':' : 'p' : ' ' : s' ->
+            case Core.parseText tab (fromString s') of
+              Left err -> do
+                printJuvixError (JuvixError err)
+                runRepl opts tab
+              Right (tab', Just node) -> do
+                renderStdOut (Core.ppOutDefault node)
+                embed (putStrLn "")
+                runRepl opts tab'
+              Right (tab', Nothing) ->
+                runRepl opts tab'
+          ':' : 'e' : ' ' : s' ->
+            case Core.parseText tab (fromString s') of
+              Left err -> do
+                printJuvixError (JuvixError err)
+                runRepl opts tab
+              Right (tab', Just node) ->
+                replEval True tab' node
+              Right (tab', Nothing) ->
+                runRepl opts tab'
+          ':' : 'l' : ' ' : f -> do
+            s' <- embed (readFile f)
+            case Core.runParser "" f Core.emptyInfoTable s' of
+              Left err -> do
+                printJuvixError (JuvixError err)
+                runRepl opts tab
+              Right (tab', Just node) ->
+                replEval False tab' node
+              Right (tab', Nothing) ->
+                runRepl opts tab'
+          ":r" ->
+            runRepl opts Core.emptyInfoTable
+          _ ->
+            case Core.parseText tab s of
+              Left err -> do
+                printJuvixError (JuvixError err)
+                runRepl opts tab
+              Right (tab', Just node) ->
+                replEval False tab' node
+              Right (tab', Nothing) ->
+                runRepl opts tab'
+      where
+        replEval :: Bool -> Core.InfoTable -> Core.Node -> Sem r ()
+        replEval noIO tab' node = do
+          r <- doEval noIO defaultLoc tab' node
+          case r of
+            Left err -> do
+              printJuvixError (JuvixError err)
+              runRepl opts tab'
+            Right node'
+              | Info.member Info.kNoDisplayInfo (Core.getInfo node') ->
+                  runRepl opts tab'
+            Right node' -> do
+              renderStdOut (Core.ppOut docOpts node')
+              embed (putStrLn "")
+              runRepl opts tab'
+          where
+            defaultLoc = singletonInterval (mkLoc "stdin" 0 (M.initialPos "stdin"))
+            docOpts = set Core.optShowDeBruijnIndices (opts ^. coreReplShowDeBruijn) Core.defaultOptions
+
+    showReplWelcome :: IO ()
+    showReplWelcome = do
+      putStrLn "JuvixCore REPL"
+      putStrLn ""
+      putStrLn "Type \":h\" for help."
+      putStrLn ""
+
+    showReplHelp :: IO ()
+    showReplHelp = do
+      putStrLn ""
+      putStrLn "JuvixCore REPL"
+      putStrLn ""
+      putStrLn "Type in a JuvixCore program to evaluate."
+      putStrLn ""
+      putStrLn "Available commands:"
+      putStrLn ":p expr               Pretty print \"expr\"."
+      putStrLn ":e expr               Evaluate \"expr\" without interpreting IO actions."
+      putStrLn ":l file               Load and evaluate \"file\". Resets REPL state."
+      putStrLn ":r                    Reset REPL state."
+      putStrLn ":q                    Quit."
+      putStrLn ":h                    Display this help message."
+      putStrLn ""
+
+    evalFile :: Members '[Embed IO, App] r => CoreEvalOptions -> FilePath -> Sem r ()
+    evalFile opts f = do
+      s <- embed (readFile f)
+      case Core.runParser "" f Core.emptyInfoTable s of
+        Left err -> exitJuvixError (JuvixError err)
+        Right (tab, Just node) -> do
+          r <- doEval (opts ^. coreEvalNoIO) defaultLoc tab node
+          case r of
+            Left err -> exitJuvixError (JuvixError err)
+            Right node'
+              | Info.member Info.kNoDisplayInfo (Core.getInfo node') ->
+                  return ()
+            Right node' -> do
+              renderStdOut (Core.ppOutDefault node')
+              embed (putStrLn "")
+        Right (_, Nothing) -> return ()
+      where
+        defaultLoc = singletonInterval (mkLoc f 0 (M.initialPos f))
+
+    doEval ::
+      Members '[Embed IO, App] r =>
+      Bool ->
+      Interval ->
+      Core.InfoTable ->
+      Core.Node ->
+      Sem r (Either Core.CoreError Core.Node)
+    doEval noIO loc tab node =
+      if noIO
+        then embed $ Core.catchEvalError loc (Core.eval (tab ^. Core.identContext) [] node)
+        else embed $ Core.catchEvalErrorIO loc (Core.evalIO (tab ^. Core.identContext) [] node)
+
 showHelpText :: ParserPrefs -> IO ()
 showHelpText p = do
   progn <- getProgName

src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs

@@ -13,8 +13,8 @@ import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
 import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Language qualified as L
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error.Pretty
-import Juvix.Compiler.Concrete.Translation.FromSource.Error qualified as Parser
 import Juvix.Data.CodeAnn
+import Juvix.Parser.Error qualified as Parser
 import Juvix.Prelude
 
 data MultipleDeclarations = MultipleDeclarations

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

@@ -2,7 +2,7 @@ module Juvix.Compiler.Concrete.Translation.FromSource
   ( module Juvix.Compiler.Concrete.Translation.FromSource,
     module Juvix.Compiler.Concrete.Translation.FromSource.Data.Context,
     module Juvix.Compiler.Concrete.Data.ParsedInfoTable,
-    module Juvix.Compiler.Concrete.Translation.FromSource.Error,
+    module Juvix.Parser.Error,
   )
 where
 
@@ -14,9 +14,9 @@ import Juvix.Compiler.Concrete.Extra (MonadParsec (takeWhile1P))
 import Juvix.Compiler.Concrete.Extra qualified as P
 import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context
-import Juvix.Compiler.Concrete.Translation.FromSource.Error
 import Juvix.Compiler.Concrete.Translation.FromSource.Lexer hiding (symbol)
 import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Parser.Error
 import Juvix.Prelude
 import Juvix.Prelude.Pretty (Pretty, prettyText)