Make compile targets a subcommand instead of a flag (#2700)

# Changes
The main goal of this pr is to remove the `--target` flag for `juvix
compile` and use subcommands instead. The targets that are relevant to
normal users are found in `juvix compile --help`. Targets that are
relevant only to developers are found in `juvix dev compile --help`.

Below I list some of the changes in more detail.
## Compile targets for user-facing languages
- `juvix compile native`
- `juvix compile wasi`. I wasn't sure how to call this: `wasm`,
`wasm32-wasi`, etc. In the end I thought `wasi` was short and accurate,
but we can change it.
- `juvix compile vampir`
- `juvix compile anoma`
- `juvix compile cairo`
## *New* compile targets for internal languages
See `juvix dev compile --help`.

1. `dev compile core` has the same behaviour as `dev core
from-concrete`. The `dev core from-concrete` is redundant at the moment.
2. `dev compile tree` compiles to Tree and prints the InfoTable to the
output file wihout any additional checks.
3. `dev compile reg` compiles to Reg and prints the InfoTable to the
output file wihout any additional checks.
4. `dev compile asm` compiles to Asm and prints the InfoTable to the
output file wihout any additional checks.
5. 4. `dev compile casm` compiles to Asm and prints the Result to the
output file wihout any additional checks. TODO: should the Result be
printed or something else? At the moment the Result lacks a pretty
instance.
6. 
## Optional input file
1. The input file for commands that expect a .juvix file as input is now
optional. If the argument is ommited, he main file given in the
package.yaml will be used. This applies to the following commands:
   1. `juvix compile [native|wasi|geb|vampir|anoma|cairo]`
   8.  `juvix dev compile [core|reg|tree|casm|asm]`
   1. `juvix html`
   3. `juvix markdown`.
   4. `juvix dev internal [typecheck|pretty]`.
   5. `juvix dev [parse|scope]`
   7. `juvix compile [native|wasi|geb|vampir|anoma|cairo]`
   9. note that `juvix format` has not changed its behaviour.

## Refactor some C-like compiler flags
Both `juvix compile native` and `juvix compile wasi` support `--only-c`
(`-C`), `--only-preprocess` (`-E`), `--only-assemble` (`-S`). I propose
to deviate from the `gcc` style and instead use a flag with a single
argument:
- `--cstage [source|preprocess|assembly|exec(default)]`. I'm open to
suggestions. For now, I've kept the legacy flags but marked them as
deprecated in the help message.

## Remove code duplication
I've tried to reduce code duplication. This is sometimes in tension with
code readability so I've tried to find a good balance. I've tried to
make it so we don't have to jump to many different files to understand
what a single command is doing. I'm sure there is still room for
improvement.

## Other refactors
I've implemented other small refactors that I considered improved the
quality of the code.

## TODO/Future work
We should refactor commands (under `compile dev`) which still use
`module Commands.Extra.Compile` and remove it.

app/App.hs

@@ -20,6 +20,7 @@ data App :: Effect where
   ExitFailMsg :: Text -> App m a
   ExitJuvixError :: JuvixError -> App m a
   PrintJuvixError :: JuvixError -> App m ()
+  FromAppFile :: AppPath File -> App m (Path Abs File)
   AskRoot :: App m Root
   AskArgs :: App m RunAppIOArgs
   AskInvokeDir :: App m (Path Abs Dir)
@@ -29,6 +30,7 @@ data App :: Effect where
   AskPackageGlobal :: App m Bool
   AskGlobalOptions :: App m GlobalOptions
   FromAppPathFile :: AppPath File -> App m (Path Abs File)
+  GetMainAppFile :: Maybe (AppPath File) -> App m (AppPath File)
   GetMainFile :: Maybe (AppPath File) -> App m (Path Abs File)
   FromAppPathDir :: AppPath Dir -> App m (Path Abs Dir)
   RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
@@ -63,6 +65,8 @@ reAppIO args@RunAppIOArgs {..} =
   interpretTop $ \case
     AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase])
     FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath)
+    FromAppFile m -> fromAppFile' m
+    GetMainAppFile m -> getMainAppFile' m
     GetMainFile m -> getMainFile' m
     FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath))
     RenderStdOut t
@@ -80,8 +84,7 @@ reAppIO args@RunAppIOArgs {..} =
     Say t
       | g ^. globalOnlyErrors -> return ()
       | otherwise -> putStrLn t
-    PrintJuvixError e -> do
-      printErr e
+    PrintJuvixError e -> printErr e
     ExitJuvixError e -> do
       printErr e
       exitFailure
@@ -95,13 +98,24 @@ reAppIO args@RunAppIOArgs {..} =
     exitMsg' :: (Members '[EmbedIO] r') => IO x -> Text -> Sem r' x
     exitMsg' onExit t = liftIO (putStrLn t >> hFlush stdout >> onExit)
 
+    fromAppFile' :: (Members '[EmbedIO] r') => AppPath File -> Sem r' (Path Abs File)
+    fromAppFile' f = prepathToAbsFile invDir (f ^. pathPath)
+
     getMainFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File)
-    getMainFile' = \case
-      Just p -> prepathToAbsFile invDir (p ^. pathPath)
+    getMainFile' = getMainAppFile' >=> fromAppFile'
+
+    getMainAppFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (AppPath File)
+    getMainAppFile' = \case
+      Just p -> return p
       Nothing -> do
         pkg <- getPkg
         case pkg ^. packageMain of
-          Just p -> prepathToAbsFile invDir p
+          Just p ->
+            return
+              AppPath
+                { _pathPath = p,
+                  _pathIsInput = True
+                }
           Nothing -> missingMainErr
 
     missingMainErr :: (Members '[EmbedIO] r') => Sem r' x
@@ -121,17 +135,22 @@ reAppIO args@RunAppIOArgs {..} =
         . runReader (project' @GenericOptions g)
         $ Error.render (not (_runAppIOArgsGlobalOptions ^. globalNoColors)) (g ^. globalOnlyErrors) e
 
-getEntryPoint' :: (Members '[EmbedIO, TaggedLock] r) => RunAppIOArgs -> AppPath File -> Sem r EntryPoint
+getEntryPoint' ::
+  (Members '[App, EmbedIO, TaggedLock] r) =>
+  RunAppIOArgs ->
+  Maybe (AppPath File) ->
+  Sem r EntryPoint
 getEntryPoint' RunAppIOArgs {..} inputFile = do
   let opts = _runAppIOArgsGlobalOptions
       root = _runAppIOArgsRoot
   estdin <-
     if
         | opts ^. globalStdin -> Just <$> liftIO getContents
         | otherwise -> return Nothing
-  set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (inputFile ^. pathPath) opts
+  mainFile <- getMainAppFile inputFile
+  set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (mainFile ^. pathPath) opts
 
-runPipelineEither :: (Members '[EmbedIO, TaggedLock, App] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a))
+runPipelineEither :: (Members '[EmbedIO, TaggedLock, App] r) => Maybe (AppPath File) -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a))
 runPipelineEither input_ p = do
   args <- askArgs
   entry <- getEntryPoint' args input_
@@ -153,6 +172,12 @@ getEntryPointStdin' RunAppIOArgs {..} = do
         | otherwise -> return Nothing
   set entryPointStdin estdin <$> entryPointFromGlobalOptionsNoFile root opts
 
+fromRightGenericError :: (Members '[App] r, ToGenericError err, Typeable err) => Either err a -> Sem r a
+fromRightGenericError = fromRightJuvixError . mapLeft JuvixError
+
+fromRightJuvixError :: (Members '[App] r) => Either JuvixError a -> Sem r a
+fromRightJuvixError = getRight
+
 someBaseToAbs' :: (Members '[App] r) => SomeBase a -> Sem r (Path Abs a)
 someBaseToAbs' f = do
   r <- askInvokeDir
@@ -166,73 +191,59 @@ filePathToAbs fp = do
 askGenericOptions :: (Members '[App] r) => Sem r GenericOptions
 askGenericOptions = project <$> askGlobalOptions
 
-getEntryPoint :: (Members '[EmbedIO, App, TaggedLock] r) => AppPath File -> Sem r EntryPoint
+getEntryPoint :: (Members '[EmbedIO, App, TaggedLock] r) => Maybe (AppPath File) -> Sem r EntryPoint
 getEntryPoint inputFile = do
   _runAppIOArgsGlobalOptions <- askGlobalOptions
   _runAppIOArgsRoot <- askRoot
-  getEntryPoint' (RunAppIOArgs {..}) inputFile
+  getEntryPoint' RunAppIOArgs {..} inputFile
 
 getEntryPointStdin :: (Members '[EmbedIO, App, TaggedLock] r) => Sem r EntryPoint
 getEntryPointStdin = do
   _runAppIOArgsGlobalOptions <- askGlobalOptions
   _runAppIOArgsRoot <- askRoot
-  getEntryPointStdin' (RunAppIOArgs {..})
+  getEntryPointStdin' RunAppIOArgs {..}
 
-runPipelineTermination :: (Members '[EmbedIO, App, TaggedLock] r) => AppPath File -> Sem (Termination ': PipelineEff r) a -> Sem r (PipelineResult a)
+runPipelineTermination :: (Members '[EmbedIO, App, TaggedLock] r) => Maybe (AppPath File) -> Sem (Termination ': PipelineEff r) a -> Sem r (PipelineResult a)
 runPipelineTermination input_ p = do
-  r <- runPipelineEither input_ (evalTermination iniTerminationState p)
-  case r of
-    Left err -> exitJuvixError err
-    Right res -> return (snd res)
+  r <- runPipelineEither input_ (evalTermination iniTerminationState p) >>= fromRightJuvixError
+  return (snd r)
 
-runPipeline :: (Members '[App, EmbedIO, TaggedLock] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r a
+runPipeline :: (Members '[App, EmbedIO, TaggedLock] r) => Maybe (AppPath File) -> Sem (PipelineEff r) a -> Sem r a
 runPipeline input_ p = do
-  r <- runPipelineEither input_ p
-  case r of
-    Left err -> exitJuvixError err
-    Right res -> return (snd res ^. pipelineResult)
+  r <- runPipelineEither input_ p >>= fromRightJuvixError
+  return (snd r ^. pipelineResult)
 
-runPipelineHtml :: (Members '[App, EmbedIO, TaggedLock] r) => Bool -> AppPath File -> Sem r (InternalTypedResult, [InternalTypedResult])
+runPipelineHtml :: (Members '[App, EmbedIO, TaggedLock] r) => Bool -> Maybe (AppPath File) -> Sem r (InternalTypedResult, [InternalTypedResult])
 runPipelineHtml bNonRecursive input_
   | bNonRecursive = do
       r <- runPipeline input_ upToInternalTyped
       return (r, [])
   | otherwise = do
       args <- askArgs
       entry <- getEntryPoint' args input_
-      r <- runPipelineHtmlEither entry
-      case r of
-        Left err -> exitJuvixError err
-        Right res -> return res
+      runPipelineHtmlEither entry >>= fromRightJuvixError
 
 runPipelineEntry :: (Members '[App, EmbedIO, TaggedLock] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r a
 runPipelineEntry entry p = do
-  r <- runIOEither entry p
-  case r of
-    Left err -> exitJuvixError err
-    Right res -> return (snd res ^. pipelineResult)
+  r <- runIOEither entry p >>= fromRightJuvixError
+  return (snd r ^. pipelineResult)
 
 runPipelineSetup :: (Members '[App, EmbedIO, TaggedLock] r) => Sem (PipelineEff' r) a -> Sem r a
 runPipelineSetup p = do
-  r <- runPipelineSetupEither p
-  case r of
-    Left err -> exitJuvixError err
-    Right res -> return (snd res)
+  r <- runPipelineSetupEither p >>= fromRightJuvixError
+  return (snd r)
 
 newline :: (Member App r) => Sem r ()
 newline = say ""
 
 printSuccessExit :: (Member App r) => Text -> Sem r a
 printSuccessExit = exitMsg ExitSuccess
 
-printFailureExit :: (Member App r) => Text -> Sem r a
-printFailureExit = exitMsg (ExitFailure 1)
-
-getRight :: (Members '[App] r, AppError e) => Either e a -> Sem r a
+getRight :: forall e a r. (Members '[App] r, AppError e) => Either e a -> Sem r a
 getRight = either appError return
 
 instance AppError Text where
-  appError = printFailureExit
+  appError = exitFailMsg
 
 instance AppError JuvixError where
   appError = exitJuvixError

app/Commands/Compile.hs

@@ -1,43 +1,23 @@
-module Commands.Compile where
+module Commands.Compile
+  ( module Commands.Compile,
+    module Commands.Compile.Options,
+  )
+where
 
 import Commands.Base
+import Commands.Compile.Anoma qualified as Anoma
+import Commands.Compile.Cairo qualified as Cairo
+import Commands.Compile.Geb qualified as Geb
+import Commands.Compile.Native qualified as Native
 import Commands.Compile.Options
-import Commands.Dev.Core.Compile.Base qualified as Compile
-import Commands.Extra.Compile qualified as Compile
-import Juvix.Compiler.Core qualified as Core
-import Juvix.Compiler.Core.Pretty qualified as Core
-import Juvix.Compiler.Core.Transformation.DisambiguateNames qualified as Core
+import Commands.Compile.Vampir qualified as Vampir
+import Commands.Compile.Wasi qualified as Wasi
 
-runCommand :: (Members '[EmbedIO, App, TaggedLock] r) => CompileOptions -> Sem r ()
-runCommand opts@CompileOptions {..} = do
-  inputFile <- getMainFile _compileInputFile
-  Core.CoreResult {..} <- runPipeline (AppPath (preFileFromAbs inputFile) True) upToCore
-  let arg =
-        Compile.PipelineArg
-          { _pipelineArgFile = inputFile,
-            _pipelineArgOptions = opts,
-            _pipelineArgModule = _coreResultModule
-          }
-  case _compileTarget of
-    TargetNative64 -> Compile.runCPipeline arg
-    TargetWasm32Wasi -> Compile.runCPipeline arg
-    TargetGeb -> Compile.runGebPipeline arg
-    TargetVampIR -> Compile.runVampIRPipeline arg
-    TargetCore -> writeCoreFile arg
-    TargetTree -> Compile.runTreePipeline arg
-    TargetAsm -> Compile.runAsmPipeline arg
-    TargetReg -> Compile.runRegPipeline arg
-    TargetAnoma -> Compile.runAnomaPipeline arg
-    TargetCasm -> Compile.runCasmPipeline arg
-    TargetCairo -> Compile.runCairoPipeline arg
-
-writeCoreFile :: (Members '[EmbedIO, App, TaggedLock] r) => Compile.PipelineArg -> Sem r ()
-writeCoreFile pa@Compile.PipelineArg {..} = do
-  entryPoint <- Compile.getEntry pa
-  coreFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
-  r <- runReader entryPoint . runError @JuvixError $ Core.toStored _pipelineArgModule
-  case r of
-    Left e -> exitJuvixError e
-    Right md -> do
-      let txt = show (Core.ppOutDefault (Core.disambiguateNames md ^. Core.moduleInfoTable))
-      writeFileEnsureLn coreFile txt
+runCommand :: (Members '[EmbedIO, App, TaggedLock] r) => CompileCommand -> Sem r ()
+runCommand = \case
+  Native opts -> Native.runCommand opts
+  Wasi opts -> Wasi.runCommand opts
+  Geb opts -> Geb.runCommand opts
+  Anoma opts -> Anoma.runCommand opts
+  Cairo opts -> Cairo.runCommand opts
+  Vampir opts -> Vampir.runCommand opts

app/Commands/Compile/Anoma.hs

@@ -0,0 +1,34 @@
+module Commands.Compile.Anoma where
+
+import Commands.Base
+import Commands.Compile.Anoma.Options
+import Commands.Extra.NewCompile
+import Juvix.Compiler.Backend
+import Juvix.Compiler.Nockma.Pretty qualified as Nockma
+import Juvix.Compiler.Nockma.Translation.FromTree qualified as Nockma
+
+runCommand :: (Members '[App, EmbedIO, TaggedLock] r) => AnomaOptions -> Sem r ()
+runCommand opts = do
+  let opts' = opts ^. anomaCompileCommonOptions
+      inputFile = opts' ^. compileInputFile
+      moutputFile = opts' ^. compileOutputFile
+  coreRes <- fromCompileCommonOptionsMain opts' >>= compileToCore
+  entryPoint <-
+    set entryPointTarget (Just TargetAnoma)
+      . applyCompileCommonOptions opts'
+      <$> getEntryPoint (opts' ^. compileInputFile)
+  nockmaFile :: Path Abs File <- getOutputFile FileExtNockma inputFile moutputFile
+  r <-
+    runReader entryPoint
+      . runError @JuvixError
+      . coreToAnoma
+      $ coreRes ^. coreResultModule
+  res <- getRight r
+  outputAnomaResult nockmaFile res
+
+outputAnomaResult :: (Members '[EmbedIO, App] r) => Path Abs File -> Nockma.AnomaResult -> Sem r ()
+outputAnomaResult nockmaFile Nockma.AnomaResult {..} = do
+  let code = Nockma.ppSerialize _anomaClosure
+      prettyNockmaFile = replaceExtensions' [".pretty", ".nockma"] nockmaFile
+  writeFileEnsureLn nockmaFile code
+  writeFileEnsureLn prettyNockmaFile (Nockma.ppPrint _anomaClosure)

app/Commands/Compile/Anoma/Options.hs

@@ -0,0 +1,20 @@
+module Commands.Compile.Anoma.Options
+  ( module Commands.Compile.Anoma.Options,
+    module Commands.Compile.CommonOptions,
+  )
+where
+
+import Commands.Compile.CommonOptions
+import CommonOptions
+
+data AnomaOptions = AnomaOptions
+  { _anomaCompileCommonOptions :: CompileCommonOptionsMain
+  }
+  deriving stock (Data)
+
+makeLenses ''AnomaOptions
+
+parseAnoma :: Parser AnomaOptions
+parseAnoma = do
+  _anomaCompileCommonOptions <- parseCompileCommonOptionsMain
+  pure AnomaOptions {..}