Nockma compile refactor (#2582)

This PR contains refactors split out from the Nockma compile PR
#2570. Each refactor is associated
with a separate commit in this PR.

app/App.hs

@@ -17,6 +17,7 @@ import System.Console.ANSI qualified as Ansi
 
 data App m a where
   ExitMsg :: ExitCode -> Text -> App m a
+  ExitFailMsg :: Text -> App m a
   ExitJuvixError :: JuvixError -> App m a
   PrintJuvixError :: JuvixError -> App m ()
   AskRoot :: App m Root
@@ -78,20 +79,21 @@ reAppIO args@RunAppIOArgs {..} =
     AskBuildDir -> return (resolveAbsBuildDir (_runAppIOArgsRoot ^. rootRootDir) (_runAppIOArgsRoot ^. rootBuildDir))
     Say t
       | g ^. globalOnlyErrors -> return ()
-      | otherwise -> embed (putStrLn t)
+      | otherwise -> putStrLn t
     PrintJuvixError e -> do
       printErr e
     ExitJuvixError e -> do
       printErr e
       embed exitFailure
-    ExitMsg exitCode t -> exitMsg' exitCode t
+    ExitMsg exitCode t -> exitMsg' (exitWith exitCode) t
+    ExitFailMsg t -> exitMsg' exitFailure t
     SayRaw b -> embed (ByteString.putStr b)
   where
     getPkg :: (Members '[SCache Package] r') => Sem r' Package
     getPkg = cacheSingletonGet
 
-    exitMsg' :: (Members '[Embed IO] r') => ExitCode -> Text -> Sem r' x
-    exitMsg' exitCode t = liftIO (putStrLn t >> hFlush stdout >> exitWith exitCode)
+    exitMsg' :: (Members '[Embed IO] r') => IO x -> Text -> Sem r' x
+    exitMsg' onExit t = liftIO (putStrLn t >> hFlush stdout >> onExit)
 
     getMainFile' :: (Members '[SCache Package, Embed IO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File)
     getMainFile' = \case
@@ -105,7 +107,7 @@ reAppIO args@RunAppIOArgs {..} =
     missingMainErr :: (Members '[Embed IO] r') => Sem r' x
     missingMainErr =
       exitMsg'
-        (ExitFailure 1)
+        exitFailure
         ( "A path to the main file must be given in the CLI or specified in the `main` field of the "
             <> pack (toFilePath juvixYamlFile)
             <> " file"
@@ -127,9 +129,9 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do
   set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (inputFile ^. pathPath) opts
 
 runPipelineEither :: (Members '[Embed IO, TaggedLock, App] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a))
-runPipelineEither input p = do
+runPipelineEither input_ p = do
   args <- askArgs
-  entry <- getEntryPoint' args input
+  entry <- getEntryPoint' args input_
   runIOEither entry p
 
 runPipelineSetupEither :: (Members '[Embed IO, TaggedLock, App] r) => Sem (PipelineEff' r) a -> Sem r (Either JuvixError (ResolverState, a))
@@ -174,28 +176,28 @@ getEntryPointStdin = do
   getEntryPointStdin' (RunAppIOArgs {..})
 
 runPipelineTermination :: (Members '[Embed IO, App, TaggedLock] r) => AppPath File -> Sem (Termination ': PipelineEff r) a -> Sem r (PipelineResult a)
-runPipelineTermination input p = do
-  r <- runPipelineEither input (evalTermination iniTerminationState p)
+runPipelineTermination input_ p = do
+  r <- runPipelineEither input_ (evalTermination iniTerminationState p)
   case r of
     Left err -> exitJuvixError err
     Right res -> return (snd res)
 
 runPipeline :: (Members '[App, Embed IO, TaggedLock] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r a
-runPipeline input p = do
-  r <- runPipelineEither input p
+runPipeline input_ p = do
+  r <- runPipelineEither input_ p
   case r of
     Left err -> exitJuvixError err
     Right res -> return (snd res ^. pipelineResult)
 
 runPipelineHtml :: (Members '[App, Embed IO, TaggedLock] r) => Bool -> AppPath File -> Sem r (InternalTypedResult, [InternalTypedResult])
-runPipelineHtml bNonRecursive input =
+runPipelineHtml bNonRecursive input_ =
   if
       | bNonRecursive -> do
-          r <- runPipeline input upToInternalTyped
+          r <- runPipeline input_ upToInternalTyped
           return (r, [])
       | otherwise -> do
           args <- askArgs
-          entry <- getEntryPoint' args input
+          entry <- getEntryPoint' args input_
           r <- runPipelineHtmlEither entry
           case r of
             Left err -> exitJuvixError err

app/AsmInterpreter.hs

@@ -25,7 +25,7 @@ runAsm bValidate tab =
                   return ()
                 Right val -> do
                   renderStdOut (Asm.ppOut (Asm.defaultOptions tab) val)
-                  embed (putStrLn "")
+                  putStrLn ""
             Nothing ->
               exitMsg (ExitFailure 1) "no 'main' function"
   where

app/Commands/Compile.hs

@@ -4,7 +4,6 @@ import Commands.Base
 import Commands.Compile.Options
 import Commands.Dev.Core.Compile.Base qualified as Compile
 import Commands.Extra.Compile qualified as Compile
-import Data.Text.IO qualified as TIO
 import Juvix.Compiler.Core qualified as Core
 import Juvix.Compiler.Core.Pretty qualified as Core
 import Juvix.Compiler.Core.Transformation.DisambiguateNames qualified as Core
@@ -35,4 +34,4 @@ writeCoreFile [email protected] {..} = do
   case r of
     Left e -> exitJuvixError e
     Right md ->
-      embed $ TIO.writeFile (toFilePath coreFile) (show $ Core.ppOutDefault (Core.disambiguateNames md ^. Core.moduleInfoTable))
+      embed @IO (writeFile (toFilePath coreFile) (show $ Core.ppOutDefault (Core.disambiguateNames md ^. Core.moduleInfoTable)))

app/Commands/Dev/Asm/Compile.hs

@@ -3,7 +3,6 @@ module Commands.Dev.Asm.Compile where
 import Commands.Base
 import Commands.Dev.Asm.Compile.Options
 import Commands.Extra.Compile qualified as Compile
-import Data.Text.IO qualified as TIO
 import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm
 import Juvix.Compiler.Backend qualified as Backend
 import Juvix.Compiler.Backend.C qualified as C
@@ -29,7 +28,7 @@ runCommand opts = do
           buildDir <- askBuildDir
           ensureDir buildDir
           cFile <- inputCFile file
-          embed $ TIO.writeFile (toFilePath cFile) _resultCCode
+          embed @IO (writeFile (toFilePath cFile) _resultCCode)
           outfile <- Compile.outputFile opts file
           Compile.runCommand
             opts

app/Commands/Dev/Core/Compile/Base.hs

@@ -3,7 +3,6 @@ module Commands.Dev.Core.Compile.Base where
 import Commands.Base
 import Commands.Dev.Core.Compile.Options
 import Commands.Extra.Compile qualified as Compile
-import Data.Text.IO qualified as TIO
 import Juvix.Compiler.Asm.Pretty qualified as Asm
 import Juvix.Compiler.Backend qualified as Backend
 import Juvix.Compiler.Backend.C qualified as C
@@ -53,7 +52,7 @@ runCPipeline pa@PipelineArg {..} = do
   entryPoint <- getEntry pa
   C.MiniCResult {..} <- getRight (run (runReader entryPoint (runError (coreToMiniC _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] C.MiniCResult))))
   cFile <- inputCFile _pipelineArgFile
-  embed $ TIO.writeFile (toFilePath cFile) _resultCCode
+  embed @IO (writeFile (toFilePath cFile) _resultCCode)
   outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
   Compile.runCommand
     _pipelineArgOptions
@@ -85,7 +84,7 @@ runGebPipeline pa@PipelineArg {..} = do
                       _lispPackageEntry = "*entry*"
                     }
   Geb.Result {..} <- getRight (run (runReader entryPoint (runError (coreToGeb spec _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] Geb.Result))))
-  embed $ TIO.writeFile (toFilePath gebFile) _resultCode
+  embed @IO (writeFile (toFilePath gebFile) _resultCode)
 
 runVampIRPipeline ::
   forall r.
@@ -96,7 +95,7 @@ runVampIRPipeline pa@PipelineArg {..} = do
   entryPoint <- getEntry pa
   vampirFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
   VampIR.Result {..} <- getRight (run (runReader entryPoint (runError (coreToVampIR _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] VampIR.Result))))
-  embed $ TIO.writeFile (toFilePath vampirFile) _resultCode
+  embed @IO (writeFile (toFilePath vampirFile) _resultCode)
 
 runAsmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
 runAsmPipeline pa@PipelineArg {..} = do
@@ -105,4 +104,4 @@ runAsmPipeline pa@PipelineArg {..} = do
   r <- runReader entryPoint $ runError @JuvixError (coreToAsm _pipelineArgModule)
   tab' <- getRight r
   let code = Asm.ppPrint tab' tab'
-  embed $ TIO.writeFile (toFilePath asmFile) code
+  embed @IO (writeFile (toFilePath asmFile) code)

app/Commands/Dev/Core/Read.hs

@@ -36,14 +36,14 @@ runCommand opts = do
     doEval tab' node =
       if
           | project opts ^. coreReadEval -> do
-              embed (putStrLn "--------------------------------")
-              embed (putStrLn "|            Eval              |")
-              embed (putStrLn "--------------------------------")
+              putStrLn "--------------------------------"
+              putStrLn "|            Eval              |"
+              putStrLn "--------------------------------"
               Eval.evalAndPrint opts tab' node
           | project opts ^. coreReadNormalize -> do
-              embed (putStrLn "--------------------------------")
-              embed (putStrLn "|         Normalize            |")
-              embed (putStrLn "--------------------------------")
+              putStrLn "--------------------------------"
+              putStrLn "|         Normalize            |"
+              putStrLn "--------------------------------"
               Eval.normalizeAndPrint opts tab' node
           | otherwise -> return ()
     sinputFile :: AppPath File

app/Commands/Dev/Core/Repl.hs

@@ -26,7 +26,7 @@ parseText = Core.runParser replPath defaultModuleId
 
 runRepl :: forall r. (Members '[Embed IO, App] r) => CoreReplOptions -> Core.InfoTable -> Sem r ()
 runRepl opts tab = do
-  embed (putStr "> ")
+  putStr "> "
   embed (hFlush stdout)
   done <- embed isEOF
   unless done $ do
@@ -43,7 +43,7 @@ runRepl opts tab = do
             runRepl opts tab
           Right (tab', Just node) -> do
             renderStdOut (Core.ppOut opts node)
-            embed (putStrLn "")
+            putStrLn ""
             runRepl opts tab'
           Right (tab', Nothing) ->
             runRepl opts tab'
@@ -107,7 +107,7 @@ runRepl opts tab = do
           | Info.member Info.kNoDisplayInfo (Core.getInfo node') -> runRepl opts tab'
           | otherwise -> do
               renderStdOut (Core.ppOut opts (Core.disambiguateNodeNames (Core.moduleFromInfoTable tab') node'))
-              embed (putStrLn "")
+              putStrLn ""
               runRepl opts tab'
       where
         defaultLoc = singletonInterval (mkInitialLoc replPath)
@@ -121,19 +121,19 @@ runRepl opts tab = do
                   runRepl opts tab'
               | otherwise -> do
                   renderStdOut (Core.ppOut opts (Core.disambiguateNodeNames md' node'))
-                  embed (putStrLn "")
+                  putStrLn ""
                   runRepl opts tab'
 
     replType :: Core.InfoTable -> Core.Node -> Sem r ()
     replType tab' node = do
       let md' = Core.moduleFromInfoTable tab'
           ty = Core.disambiguateNodeNames md' (Core.computeNodeType md' node)
       renderStdOut (Core.ppOut opts ty)
-      embed (putStrLn "")
+      putStrLn ""
       runRepl opts tab'
 
 showReplWelcome :: (Members '[Embed IO, App] r) => Sem r ()
-showReplWelcome = embed $ do
+showReplWelcome = do
   putStrLn "JuvixCore REPL"
   putStrLn ""
   putStrLn "Type \":h\" for help."

app/Commands/Dev/Geb/Check.hs

@@ -21,6 +21,6 @@ runCommand opts = do
         Left err -> exitJuvixError (JuvixError err)
         Right ty -> do
           renderStdOut (ppOutDefault ty)
-          embed (putStrLn "")
+          putStrLn ""
     Right _ -> exitJuvixError (error @JuvixError "Not a morphism")
     Left err -> exitJuvixError (JuvixError err)

app/Commands/Dev/Geb/Eval.hs

@@ -24,7 +24,7 @@ runCommand opts = do
     Left err -> exitJuvixError (JuvixError err)
     Right gebTerm -> do
       evalAndPrint opts gebTerm
-      embed (putStrLn "")
+      putStrLn ""
 
 evalAndPrint ::
   forall r a.

app/Commands/Dev/Geb/Infer.hs

@@ -27,7 +27,7 @@ runCommand opts = do
             Geb.ppOut
               opts
               (tyMorph ^. Geb.typedMorphismObject)
-          embed $ putStrLn ""
+          putStrLn ""
     Right (Geb.ExpressionObject _) ->
       exitJuvixError (error @JuvixError "No inference for objects")
     Left err -> exitJuvixError (JuvixError err)

app/Commands/Dev/Geb/Read.hs

@@ -19,4 +19,4 @@ runCommand opts = do
     Left err -> exitJuvixError (JuvixError err)
     Right gebTerm -> do
       renderStdOut (Geb.ppOut opts gebTerm)
-      embed (putStrLn "")
+      putStrLn ""

app/Commands/Dev/Geb/Repl.hs

@@ -114,25 +114,25 @@ checkTypedMorphism gebMorphism = Repline.dontCrash $ do
     Right _ -> printError (error "Checking only works on typed Geb morphisms.")
 
 runReplCommand :: String -> Repl ()
-runReplCommand input =
+runReplCommand input_ =
   Repline.dontCrash $
     do
       let evalRes =
             Geb.runEval $
               Geb.RunEvalArgs
-                { _runEvalArgsContent = pack input,
+                { _runEvalArgsContent = pack input_,
                   _runEvalArgsInputFile = gebReplPath,
                   _runEvalArgsEvaluatorOptions = Geb.defaultEvaluatorOptions
                 }
       printEvalResult evalRes
 
 evalAndOutputMorphism :: String -> Repl ()
-evalAndOutputMorphism input =
+evalAndOutputMorphism input_ =
   Repline.dontCrash $ do
     let evalRes =
           Geb.runEval $
             Geb.RunEvalArgs
-              { _runEvalArgsContent = pack input,
+              { _runEvalArgsContent = pack input_,
                 _runEvalArgsInputFile = gebReplPath,
                 _runEvalArgsEvaluatorOptions =
                   Geb.defaultEvaluatorOptions

app/Commands/Dev/Nockma/Repl.hs

@@ -148,8 +148,8 @@ evalStatement = \case
         Right res -> liftIO (putStrLn (ppPrint res))
 
 replCommand :: String -> Repl ()
-replCommand input = Repline.dontCrash $ do
-  readStatement input >>= evalStatement
+replCommand input_ = Repline.dontCrash $ do
+  readStatement input_ >>= evalStatement
 
 replAction :: ReplS ()
 replAction =

app/Commands/Init.hs

@@ -130,7 +130,7 @@ getProjName = do
               go
 
 say :: (Members '[Embed IO] r) => Text -> Sem r ()
-say = embed . putStrLn
+say = putStrLn
 
 tryAgain :: (Members '[Embed IO] r) => Sem r ()
 tryAgain = say "Please, try again:"

app/Commands/Repl.hs

@@ -155,10 +155,10 @@ displayVersion :: String -> Repl ()
 displayVersion _ = liftIO (putStrLn versionTag)
 
 replCommand :: ReplOptions -> String -> Repl ()
-replCommand opts input = catchAll $ do
+replCommand opts input_ = catchAll $ do
   ctx <- replGetContext
   let tab = Core.computeCombinedInfoTable $ ctx ^. replContextArtifacts . artifactCoreModule
-  evalRes <- compileThenEval ctx input
+  evalRes <- compileThenEval ctx input_
   whenJust evalRes $ \n ->
     if
         | Info.member Info.kNoDisplayInfo (Core.getInfo n) -> return ()
@@ -200,22 +200,22 @@ replCommand opts input = catchAll $ do
           return res'
 
 core :: String -> Repl ()
-core input = do
+core input_ = do
   ctx <- replGetContext
   opts <- Reader.asks (^. replOptions)
-  compileRes <- liftIO (compileReplInputIO' ctx (strip (pack input))) >>= replFromEither . snd
+  compileRes <- liftIO (compileReplInputIO' ctx (strip (pack input_))) >>= replFromEither . snd
   whenJust compileRes (renderOutLn . Core.ppOut opts)
 
 dev :: String -> Repl ()
-dev input = do
+dev input_ = do
   ctx <- replGetContext
   if
-      | input == scoperStateCmd -> do
+      | input_ == scoperStateCmd -> do
           renderOutLn (Concrete.ppTrace (ctx ^. replContextArtifacts . artifactScoperState))
       | otherwise ->
           renderOutLn
             ( "Unrecognized command "
-                <> input
+                <> input_
                 <> "\nAvailable commands: "
                 <> unwords cmds
             )
@@ -238,8 +238,8 @@ printConcreteLn :: (Concrete.PrettyPrint a) => a -> Repl ()
 printConcreteLn = ppConcrete >=> renderOutLn
 
 replParseIdentifiers :: String -> Repl (NonEmpty Concrete.ScopedIden)
-replParseIdentifiers input =
-  replExpressionUpToScopedAtoms (strip (pack input))
+replParseIdentifiers input_ =
+  replExpressionUpToScopedAtoms (strip (pack input_))
     >>= getIdentifiers
   where
     getIdentifiers :: Concrete.ExpressionAtoms 'Concrete.Scoped -> Repl (NonEmpty Concrete.ScopedIden)
@@ -375,9 +375,9 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
               printInductive (ind ^. Scoped.nameId)
 
 inferType :: String -> Repl ()
-inferType input = do
+inferType input_ = do
   gopts <- State.gets (^. replStateGlobalOptions)
-  n <- replExpressionUpToTyped (strip (pack input))
+  n <- replExpressionUpToTyped (strip (pack input_))
   renderOutLn (Internal.ppOut (project' @GenericOptions gopts) (n ^. Internal.typedType))
 
 replCommands :: ReplOptions -> [(String, String -> Repl ())]

app/Evaluator.hs

@@ -72,4 +72,4 @@ normalizeAndPrint opts tab node =
           | otherwise -> do
               let node'' = if project opts ^. evalNoDisambiguate then node' else Core.disambiguateNodeNames (Core.moduleFromInfoTable tab) node'
               renderStdOut (Core.ppOut opts node'')
-              embed (putStrLn "")
+              putStrLn ""