refactor --target into subcommands for dev tree compile and other improvements

app/App.hs

@@ -10,6 +10,7 @@ import Juvix.Compiler.Pipeline.Root
 import Juvix.Compiler.Pipeline.Run
 import Juvix.Data.Error qualified as Error
 import Juvix.Extra.Paths.Base hiding (rootBuildDir)
+import Juvix.Parser.Error
 import Juvix.Prelude.Pretty hiding
   ( Doc,
   )
@@ -208,12 +209,20 @@ runPipelineTermination input_ p = do
   r <- runPipelineEither input_ (evalTermination iniTerminationState p) >>= fromRightJuvixError
   return (snd r)
 
-runPipeline :: (Members '[App, EmbedIO, TaggedLock] r) => Maybe (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 >>= fromRightJuvixError
   return (snd r ^. pipelineResult)
 
-runPipelineHtml :: (Members '[App, EmbedIO, TaggedLock] r) => Bool -> Maybe (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
@@ -242,6 +251,9 @@ printSuccessExit = exitMsg ExitSuccess
 getRight :: forall e a r. (Members '[App] r, AppError e) => Either e a -> Sem r a
 getRight = either appError return
 
+instance AppError MegaparsecError where
+  appError = appError . JuvixError
+
 instance AppError Text where
   appError = exitFailMsg
 

app/Commands/Compile/Anoma.hs

@@ -3,19 +3,17 @@ 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 :: (Members '[App, EmbedIO, TaggedLock] r) => AnomaOptions 'InputMain -> 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'
+    applyOptions opts
       <$> getEntryPoint (opts' ^. compileInputFile)
   nockmaFile :: Path Abs File <- getOutputFile FileExtNockma inputFile moutputFile
   r <-

app/Commands/Compile/Anoma/Options.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Commands.Compile.Anoma.Options
   ( module Commands.Compile.Anoma.Options,
     module Commands.Compile.CommonOptions,
@@ -7,14 +9,20 @@ where
 import Commands.Compile.CommonOptions
 import CommonOptions
 
-data AnomaOptions = AnomaOptions
-  { _anomaCompileCommonOptions :: CompileCommonOptionsMain
+data AnomaOptions (k :: InputKind) = AnomaOptions
+  { _anomaCompileCommonOptions :: CompileCommonOptions k
   }
-  deriving stock (Data)
+
+deriving stock instance (Typeable k, Data (InputFileType k)) => Data (AnomaOptions k)
 
 makeLenses ''AnomaOptions
 
-parseAnoma :: Parser AnomaOptions
+parseAnoma :: (SingI k) => Parser (AnomaOptions k)
 parseAnoma = do
-  _anomaCompileCommonOptions <- parseCompileCommonOptionsMain
+  _anomaCompileCommonOptions <- parseCompileCommonOptions
   pure AnomaOptions {..}
+
+instance EntryPointOptions (AnomaOptions k) where
+  applyOptions opts =
+    set entryPointTarget (Just TargetAnoma)
+      . applyOptions (opts ^. anomaCompileCommonOptions)

app/Commands/Compile/Cairo.hs

@@ -4,17 +4,15 @@ import Commands.Base
 import Commands.Compile.Cairo.Options
 import Commands.Extra.NewCompile
 import Data.Aeson qualified as JSON
-import Juvix.Compiler.Backend
 
-runCommand :: (Members '[App, TaggedLock, EmbedIO] r) => CairoOptions -> Sem r ()
+runCommand :: (Members '[App, TaggedLock, EmbedIO] r) => CairoOptions 'InputMain -> Sem r ()
 runCommand opts = do
   let opts' = opts ^. cairoCompileCommonOptions
       inputFile = opts' ^. compileInputFile
       moutputFile = opts' ^. compileOutputFile
   coreRes <- fromCompileCommonOptionsMain opts' >>= compileToCore
   entryPoint <-
-    set entryPointTarget (Just TargetCairo)
-      . applyCompileCommonOptions opts'
+    applyOptions opts
       <$> getEntryPoint (opts' ^. compileInputFile)
   cairoFile :: Path Abs File <- getOutputFile FileExtJson inputFile moutputFile
   r <-

app/Commands/Compile/Cairo/Options.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Commands.Compile.Cairo.Options
   ( module Commands.Compile.Cairo.Options,
     module Commands.Compile.CommonOptions,
@@ -7,14 +9,20 @@ where
 import Commands.Compile.CommonOptions
 import CommonOptions
 
-data CairoOptions = CairoOptions
-  { _cairoCompileCommonOptions :: CompileCommonOptionsMain
+data CairoOptions (k :: InputKind) = CairoOptions
+  { _cairoCompileCommonOptions :: CompileCommonOptions k
   }
-  deriving stock (Data)
+
+deriving stock instance (Typeable k, Data (InputFileType k)) => Data (CairoOptions k)
 
 makeLenses ''CairoOptions
 
-parseCairo :: Parser CairoOptions
+parseCairo :: (SingI k) => Parser (CairoOptions k)
 parseCairo = do
-  _cairoCompileCommonOptions <- parseCompileCommonOptionsMain
+  _cairoCompileCommonOptions <- parseCompileCommonOptions
   pure CairoOptions {..}
+
+instance EntryPointOptions (CairoOptions k) where
+  applyOptions opts =
+    set entryPointTarget (Just TargetCairo)
+      . applyOptions (opts ^. cairoCompileCommonOptions)

app/Commands/Compile/CommonOptions.hs

@@ -1,58 +1,72 @@
-module Commands.Compile.CommonOptions where
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Commands.Compile.CommonOptions
+  ( module Commands.Compile.CommonOptions,
+    module Commands.Compile.CommonOptions.InputKind,
+    module Juvix.Compiler.Pipeline.EntryPoint,
+    module Juvix.Compiler.Backend,
+  )
+where
 
 import App
+import Commands.Compile.CommonOptions.InputKind
 import CommonOptions
+import Juvix.Compiler.Backend
 import Juvix.Compiler.Pipeline.EntryPoint
 
--- | If the input file can be defaulted to the `main` in the `package.yaml` file, we
--- can omit the input file.
-type CompileCommonOptionsMain = CompileCommonOptions' (Maybe (AppPath File))
-
-type CompileCommonOptions = CompileCommonOptions' (AppPath File)
-
-data CompileCommonOptions' inputFile = CompileCommonOptions
-  { _compileInputFile :: inputFile,
+data CompileCommonOptions (k :: InputKind) = CompileCommonOptions
+  { _compileInputFile :: InputFileType k,
     _compileOutputFile :: Maybe (AppPath File),
     _compileDebug :: Bool,
     _compileInliningDepth :: Int,
     _compileOptimizationLevel :: Maybe Int
   }
-  deriving stock (Data)
 
-makeLenses ''CompileCommonOptions'
+deriving stock instance (Typeable k, Data (InputFileType k)) => Data (CompileCommonOptions k)
 
-applyCompileCommonOptions :: CompileCommonOptions' b -> EntryPoint -> EntryPoint
-applyCompileCommonOptions opts e =
-  e
-    { _entryPointDebug = opts ^. compileDebug,
-      _entryPointOptimizationLevel = fromMaybe defaultOptimization (opts ^. compileOptimizationLevel),
-      _entryPointInliningDepth = opts ^. compileInliningDepth
-    }
-  where
-    defaultOptimization :: Int
-    defaultOptimization
-      | opts ^. compileDebug = 0
-      | otherwise = defaultOptimizationLevel
+makeLenses ''CompileCommonOptions
 
-fromCompileCommonOptionsMain :: (Members '[App] r) => CompileCommonOptionsMain -> Sem r CompileCommonOptions
+instance EntryPointOptions (CompileCommonOptions b) where
+  applyOptions opts e =
+    e
+      { _entryPointDebug = opts ^. compileDebug,
+        _entryPointOptimizationLevel = fromMaybe defaultOptimization (opts ^. compileOptimizationLevel),
+        _entryPointInliningDepth = opts ^. compileInliningDepth
+      }
+    where
+      defaultOptimization :: Int
+      defaultOptimization
+        | opts ^. compileDebug = 0
+        | otherwise = defaultOptimizationLevel
+
+fromCompileCommonOptionsMain ::
+  (Members '[App] r) =>
+  CompileCommonOptions 'InputMain ->
+  Sem r (CompileCommonOptions ('InputExtension 'FileExtJuvix))
 fromCompileCommonOptionsMain = traverseOf compileInputFile getMainAppFile
 
-parseCompileCommonOptionsMain ::
-  Parser CompileCommonOptionsMain
-parseCompileCommonOptionsMain =
-  parseCompileCommonOptionsGeneric
-    (optional (parseInputFile FileExtJuvix))
+getMainFileFromInputFileType ::
+  forall (k :: InputKind) r.
+  (SingI k, Members '[App] r) =>
+  InputFileType k ->
+  Sem r (Path Abs File)
+getMainFileFromInputFileType = getMainAppFileFromInputFileType @k >=> fromAppFile
 
-parseCompileCommonOptions ::
-  Parser CompileCommonOptions
-parseCompileCommonOptions =
-  parseCompileCommonOptionsGeneric
-    (parseInputFile FileExtJuvix)
+getMainAppFileFromInputFileType ::
+  forall (k :: InputKind) r.
+  (SingI k, Members '[App] r) =>
+  InputFileType k ->
+  Sem r (AppPath File)
+getMainAppFileFromInputFileType i = case sing :: SInputKind k of
+  SInputMain -> getMainAppFile i
+  SInputExtension {} -> return i
 
-parseCompileCommonOptionsGeneric ::
-  Parser inputFile ->
-  Parser (CompileCommonOptions' inputFile)
-parseCompileCommonOptionsGeneric parserFile = do
+parseCompileCommonOptions ::
+  forall k.
+  (SingI k) =>
+  Parser (CompileCommonOptions k)
+parseCompileCommonOptions = do
   _compileDebug <-
     switch
       ( short 'g'
@@ -76,5 +90,5 @@ parseCompileCommonOptionsGeneric parserFile = do
           <> help ("Automatic inlining depth limit, logarithmic in the function size (default: " <> show defaultInliningDepth <> ")")
       )
   _compileOutputFile <- optional parseGenericOutputFile
-  _compileInputFile <- parserFile
+  _compileInputFile <- parseInputFileType @k
   pure CompileCommonOptions {..}

app/Commands/Compile/CommonOptions/InputKind.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Commands.Compile.CommonOptions.InputKind where
+
+import CommonOptions
+
+data InputKind
+  = -- | The input is a .juvix or .juvix.md file. If omitted, the main in juvix.yaml is used
+    InputMain
+  | -- | The input is a non-optional file with some extension
+    InputExtension FileExt
+
+$(genSingletons [''InputKind])
+
+type InputFileType :: InputKind -> GHCType
+type family InputFileType s = res where
+  InputFileType 'InputMain = Maybe (AppPath File)
+  InputFileType ('InputExtension _) = AppPath File
+
+parseInputFileType :: forall k. (SingI k) => Parser (InputFileType k)
+parseInputFileType = case sing :: SInputKind k of
+  SInputMain -> optional (parseInputFiles (FileExtJuvix :| [FileExtMarkdown]))
+  SInputExtension inputExtension -> parseInputFile (fromSing inputExtension)

app/Commands/Compile/Geb.hs

@@ -3,19 +3,17 @@ module Commands.Compile.Geb where
 import Commands.Base
 import Commands.Compile.Geb.Options
 import Commands.Extra.NewCompile
-import Juvix.Compiler.Backend
 import Juvix.Compiler.Backend.Geb qualified as Geb
 import System.FilePath (takeBaseName)
 
-runCommand :: (Members '[App, TaggedLock, EmbedIO] r) => GebOptions -> Sem r ()
+runCommand :: (Members '[App, TaggedLock, EmbedIO] r) => GebOptions 'InputMain -> Sem r ()
 runCommand opts = do
   let opts' = opts ^. gebCompileCommonOptions
       inputFile = opts' ^. compileInputFile
       moutputFile = opts' ^. compileOutputFile
   coreRes <- fromCompileCommonOptionsMain opts' >>= compileToCore
   entryPoint <-
-    set entryPointTarget (Just TargetGeb)
-      . applyCompileCommonOptions opts'
+    applyOptions opts
       <$> getEntryPoint (opts' ^. compileInputFile)
   let ext :: FileExt
       ext

app/Commands/Compile/Geb/Options.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Commands.Compile.Geb.Options
   ( module Commands.Compile.Geb.Options,
     module Commands.Compile.CommonOptions,
@@ -7,21 +9,27 @@ where
 import Commands.Compile.CommonOptions
 import CommonOptions
 
-data GebOptions = GebOptions
-  { _gebCompileCommonOptions :: CompileCommonOptionsMain,
+data GebOptions (k :: InputKind) = GebOptions
+  { _gebCompileCommonOptions :: CompileCommonOptions k,
     _gebOnlyTerm :: Bool
   }
-  deriving stock (Data)
+
+deriving stock instance (Typeable k, Data (InputFileType k)) => Data (GebOptions k)
 
 makeLenses ''GebOptions
 
-parseGeb :: Parser GebOptions
+parseGeb :: (SingI k) => Parser (GebOptions k)
 parseGeb = do
-  _gebCompileCommonOptions <- parseCompileCommonOptionsMain
+  _gebCompileCommonOptions <- parseCompileCommonOptions
   _gebOnlyTerm <-
     switch
       ( short 'G' -- TODO I would like to deprecate the short flag
           <> long "only-term"
           <> help "Produce term output only"
       )
   pure GebOptions {..}
+
+instance EntryPointOptions (GebOptions k) where
+  applyOptions opts =
+    set entryPointTarget (Just TargetGeb)
+      . applyOptions (opts ^. gebCompileCommonOptions)

app/Commands/Compile/Native.hs

@@ -3,40 +3,10 @@ module Commands.Compile.Native where
 import Commands.Base
 import Commands.Compile.Native.Options
 import Commands.Compile.NativeWasiHelper as Helper
-import Data.ByteString qualified as BS
-import Data.FileEmbed qualified as FE
-import Juvix.Compiler.Backend
 
-runCommand :: forall r. (Members '[App, TaggedLock, EmbedIO] r) => NativeOptions -> Sem r ()
-runCommand opts =
-  Helper.runCommand
-    HelperOptions
-      { _helperCStage = opts ^. nativeCStage,
-        _helperTarget = TargetCNative64,
-        _helperCompileCommonOptions = opts ^. nativeCompileCommonOptions,
-        _helperClangBackend = ClangNative,
-        _helperDefaultOutputFile = \inputFile baseOutputFile ->
-          case opts ^. nativeCStage of
-            CSource -> replaceExtension' cFileExt inputFile
-            CPreprocess -> addExtension' cFileExt (addExtension' ".out" (removeExtension' inputFile))
-            CAssembly -> replaceExtension' ".s" inputFile
-            CExecutable -> removeExtension' baseOutputFile,
-        _helperPrepareRuntime = prepareRuntime
-      }
-  where
-    prepareRuntime ::
-      forall s.
-      (Members '[App, EmbedIO] s) =>
-      Sem s ()
-    prepareRuntime = writeRuntime runtime
-      where
-        runtime :: BS.ByteString
-        runtime
-          | opts ^. nativeCompileCommonOptions . compileDebug = nativeDebugRuntime
-          | otherwise = nativeReleaseRuntime
-          where
-            nativeReleaseRuntime :: BS.ByteString
-            nativeReleaseRuntime = $(FE.makeRelativeToProject "runtime/_build.native64/libjuvix.a" >>= FE.embedFile)
-
-            nativeDebugRuntime :: BS.ByteString
-            nativeDebugRuntime = $(FE.makeRelativeToProject "runtime/_build.native64-debug/libjuvix.a" >>= FE.embedFile)
+runCommand ::
+  forall r.
+  (Members '[App, TaggedLock, EmbedIO] r) =>
+  NativeOptions 'InputMain ->
+  Sem r ()
+runCommand = Helper.runCommand . nativeHelperOptions