Apply common options in dev compile subcommands (#2732)

app/App.hs

@@ -151,13 +151,21 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do
   mainFile <- getMainAppFile inputFile
   set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (mainFile ^. pathPath) opts
 
-runPipelineEither :: (Members '[EmbedIO, TaggedLock, App] r) => Maybe (AppPath File) -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a))
-runPipelineEither input_ p = do
+runPipelineEither ::
+  (Members '[EmbedIO, TaggedLock, App] r, EntryPointOptions opts) =>
+  opts ->
+  Maybe (AppPath File) ->
+  Sem (PipelineEff r) a ->
+  Sem r (Either JuvixError (ResolverState, PipelineResult a))
+runPipelineEither opts input_ p = do
   args <- askArgs
-  entry <- getEntryPoint' args input_
+  entry <- applyOptions opts <$> getEntryPoint' args input_
   runIOEither entry p
 
-runPipelineSetupEither :: (Members '[EmbedIO, TaggedLock, App] r) => Sem (PipelineEff' r) a -> Sem r (Either JuvixError (ResolverState, a))
+runPipelineSetupEither ::
+  (Members '[EmbedIO, TaggedLock, App] r) =>
+  Sem (PipelineEff' r) a ->
+  Sem r (Either JuvixError (ResolverState, a))
 runPipelineSetupEither p = do
   args <- askArgs
   entry <- getEntryPointStdin' args
@@ -204,18 +212,30 @@ getEntryPointStdin = do
   _runAppIOArgsRoot <- askRoot
   getEntryPointStdin' RunAppIOArgs {..}
 
-runPipelineTermination :: (Members '[EmbedIO, App, TaggedLock] r) => Maybe (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) >>= fromRightJuvixError
+  r <- runPipelineEither () input_ (evalTermination iniTerminationState p) >>= fromRightJuvixError
   return (snd r)
 
-runPipeline ::
+runPipelineNoOptions ::
   (Members '[App, EmbedIO, TaggedLock] r) =>
   Maybe (AppPath File) ->
   Sem (PipelineEff r) a ->
   Sem r a
-runPipeline input_ p = do
-  r <- runPipelineEither input_ p >>= fromRightJuvixError
+runPipelineNoOptions = runPipeline ()
+
+runPipeline ::
+  (Members '[App, EmbedIO, TaggedLock] r, EntryPointOptions opts) =>
+  opts ->
+  Maybe (AppPath File) ->
+  Sem (PipelineEff r) a ->
+  Sem r a
+runPipeline opts input_ p = do
+  r <- runPipelineEither opts input_ p >>= fromRightJuvixError
   return (snd r ^. pipelineResult)
 
 runPipelineHtml ::
@@ -225,7 +245,7 @@ runPipelineHtml ::
   Sem r (InternalTypedResult, [InternalTypedResult])
 runPipelineHtml bNonRecursive input_
   | bNonRecursive = do
-      r <- runPipeline input_ upToInternalTyped
+      r <- runPipelineNoOptions input_ upToInternalTyped
       return (r, [])
   | otherwise = do
       args <- askArgs

app/Commands/Dev/Core/FromConcrete.hs

@@ -14,7 +14,7 @@ import Juvix.Compiler.Core.Translation
 runCommand :: forall r. (Members '[EmbedIO, TaggedLock, App] r) => CoreFromConcreteOptions -> Sem r ()
 runCommand coreOpts = do
   gopts <- askGlobalOptions
-  md <- (^. coreResultModule) <$> runPipeline (Just (coreOpts ^. coreFromConcreteInputFile)) upToCore
+  md <- (^. coreResultModule) <$> runPipelineNoOptions (Just (coreOpts ^. coreFromConcreteInputFile)) upToCore
   path :: Path Abs File <- fromAppPathFile (coreOpts ^. coreFromConcreteInputFile)
   let r =
         run

app/Commands/Dev/DevCompile/Asm.hs

@@ -11,6 +11,6 @@ runCommand opts = do
   let inputFile = opts ^. asmCompileCommonOptions . compileInputFile
       moutputFile = opts ^. asmCompileCommonOptions . compileOutputFile
   outFile :: Path Abs File <- getOutputFile FileExtJuvixAsm inputFile moutputFile
-  res :: InfoTable <- runPipeline inputFile upToAsm
+  res :: InfoTable <- runPipeline opts inputFile upToAsm
   let txt = ppPrint res res
   writeFileEnsureLn outFile txt

app/Commands/Dev/DevCompile/Casm.hs

@@ -11,6 +11,6 @@ runCommand opts = do
   let inputFile = opts ^. casmCompileCommonOptions . compileInputFile
       moutputFile = opts ^. casmCompileCommonOptions . compileOutputFile
   outFile :: Path Abs File <- getOutputFile FileExtCasm inputFile moutputFile
-  res :: Result <- runPipeline inputFile upToCasm
+  res :: Result <- runPipeline opts inputFile upToCasm
   let txt = ppPrint res
   writeFileEnsureLn outFile txt

app/Commands/Dev/DevCompile/Core.hs

@@ -20,7 +20,7 @@ runCommand opts = do
       moutputFile = opts ^. coreCompileCommonOptions . compileOutputFile
   gopts <- askGlobalOptions
   outFile :: Path Abs File <- getOutputFile FileExtJuvixCore inputFile moutputFile
-  coremodule :: Core.Module <- (^. coreResultModule) <$> runPipeline inputFile upToStoredCore
+  coremodule :: Core.Module <- (^. coreResultModule) <$> runPipeline opts inputFile upToStoredCore
   res :: Core.Module <-
     ( runError @JuvixError
         . runReader (project' @Core.CoreOptions gopts)

app/Commands/Dev/DevCompile/Reg.hs

@@ -14,6 +14,6 @@ runCommand opts = do
   let inputFile = opts ^. regCompileCommonOptions . compileInputFile
       moutputFile = opts ^. regCompileCommonOptions . compileOutputFile
   outFile :: Path Abs File <- getOutputFile FileExtJuvixReg inputFile moutputFile
-  res :: InfoTable <- runPipeline inputFile upToReg
+  res :: InfoTable <- runPipeline opts inputFile upToReg
   let txt = ppPrint res res
   writeFileEnsureLn outFile txt

app/Commands/Dev/DevCompile/Tree.hs

@@ -14,6 +14,6 @@ runCommand opts = do
   let inputFile = opts ^. treeCompileCommonOptions . compileInputFile
       moutputFile = opts ^. treeCompileCommonOptions . compileOutputFile
   outFile :: Path Abs File <- getOutputFile FileExtJuvixTree inputFile moutputFile
-  res :: InfoTable <- runPipeline inputFile upToTree
+  res :: InfoTable <- runPipeline opts inputFile upToTree
   let txt = ppPrint res res
   writeFileEnsureLn outFile txt

app/Commands/Dev/Internal/Typecheck.hs

@@ -8,7 +8,7 @@ import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking qu
 runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => InternalTypeOptions -> Sem r ()
 runCommand localOpts = do
   globalOpts <- askGlobalOptions
-  res <- runPipeline (localOpts ^. internalTypeInputFile) upToInternalTyped
+  res <- runPipelineNoOptions (localOpts ^. internalTypeInputFile) upToInternalTyped
   say "Well done! It type checks"
   when (localOpts ^. internalTypePrint) $ do
     let checkedModule = res ^. InternalTyped.resultModule

app/Commands/Dev/Parse.hs

@@ -9,5 +9,5 @@ runCommand :: (Members '[EmbedIO, App, TaggedLock] r) => ParseOptions -> Sem r (
 runCommand opts = do
   m <-
     (^. Parser.resultModule)
-      <$> runPipeline (opts ^. parseOptionsInputFile) upToParsing
+      <$> runPipelineNoOptions (opts ^. parseOptionsInputFile) upToParsing
   if opts ^. parseOptionsNoPrettyShow then say (show m) else say (pack (ppShow m))

app/Commands/Dev/Scope.hs

@@ -10,7 +10,7 @@ import Juvix.Prelude.Pretty
 runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => ScopeOptions -> Sem r ()
 runCommand opts = do
   globalOpts <- askGlobalOptions
-  res :: Scoper.ScoperResult <- runPipeline (opts ^. scopeInputFile) upToScoping
+  res :: Scoper.ScoperResult <- runPipelineNoOptions (opts ^. scopeInputFile) upToScoping
   let m :: Module 'Scoped 'ModuleTop = res ^. Scoper.resultModule
   if
       | opts ^. scopeWithComments ->

app/Commands/Eval.hs

@@ -9,7 +9,7 @@ import Juvix.Extra.Strings qualified as Str
 runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => EvalOptions -> Sem r ()
 runCommand opts@EvalOptions {..} = do
   gopts <- askGlobalOptions
-  Core.CoreResult {..} <- runPipeline _evalInputFile upToCore
+  Core.CoreResult {..} <- runPipelineNoOptions _evalInputFile upToCore
   let r =
         run
           . runReader (project gopts)

app/Commands/Extra/NewCompile.hs

@@ -31,7 +31,7 @@ compileToCore ::
   (Members '[App, EmbedIO, TaggedLock] r) =>
   CompileCommonOptions ('InputExtension 'FileExtJuvix) ->
   Sem r CoreResult
-compileToCore opts = runPipeline (Just (opts ^. compileInputFile)) upToCore
+compileToCore opts = runPipeline opts (Just (opts ^. compileInputFile)) upToCore
 
 commandTargetHelper :: CompileTarget -> Parser a -> Mod CommandFields a
 commandTargetHelper t parseCommand =

app/Commands/Format.hs

@@ -103,5 +103,5 @@ runScopeFileApp = interpret $ \case
             { _pathPath = mkPrepath (toFilePath p),
               _pathIsInput = False
             }
-    runPipeline (Just appFile) upToScoping
+    runPipelineNoOptions (Just appFile) upToScoping
   ScopeStdin e -> runPipelineEntry e upToScoping

app/Commands/Html.hs

@@ -16,7 +16,7 @@ import System.Process qualified as Process
 
 runGenOnlySourceHtml :: (Members '[EmbedIO, TaggedLock, App] r) => HtmlOptions -> Sem r ()
 runGenOnlySourceHtml HtmlOptions {..} = do
-  res <- runPipeline _htmlInputFile upToScoping
+  res <- runPipelineNoOptions _htmlInputFile upToScoping
   let m = res ^. Scoper.resultModule
   outputDir <- fromAppPathDir _htmlOutputDir
   liftIO $

app/Commands/Markdown.hs

@@ -17,7 +17,7 @@ runCommand ::
   Sem r ()
 runCommand opts = do
   let inputFile = opts ^. markdownInputFile
-  scopedM <- runPipeline inputFile upToScoping
+  scopedM <- runPipelineNoOptions inputFile upToScoping
   let m = scopedM ^. Scoper.resultModule
   outputDir <- fromAppPathDir (opts ^. markdownOutputDir)
   let res =

app/Commands/Typecheck.hs

@@ -5,5 +5,5 @@ import Commands.Typecheck.Options
 
 runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => TypecheckOptions -> Sem r ()
 runCommand localOpts = do
-  void (runPipeline (localOpts ^. typecheckInputFile) upToCoreTypecheck)
+  void (runPipelineNoOptions (localOpts ^. typecheckInputFile) upToCoreTypecheck)
   say "Well done! It type checks"

app/CommonOptions.hs

@@ -288,3 +288,6 @@ optRegTransformationIds = optTransformationIds Reg.parseTransformations Reg.comp
 
 class EntryPointOptions a where
   applyOptions :: a -> EntryPoint -> EntryPoint
+
+instance EntryPointOptions () where
+  applyOptions () = id