From 35de1e9be786474fd283f372dd0118b511cfd606 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Sat, 28 Dec 2024 20:24:51 +0100 Subject: [PATCH 1/5] process markdown recursively --- app/App.hs | 14 ++ app/Commands/Html.hs | 41 +++--- app/Commands/Markdown.hs | 122 +++++++++++------- app/Commands/Markdown/Options.hs | 13 +- app/CommonOptions.hs | 19 ++- .../Html/Translation/FromTyped/Source.hs | 31 ++--- .../Markdown/Translation/FromTyped/Source.hs | 3 - src/Juvix/Compiler/Pipeline/Driver.hs | 45 +++++-- src/Juvix/Compiler/Pipeline/Run.hs | 3 +- src/Juvix/Extra/Assets.hs | 6 +- test/BackendMarkdown/Negative.hs | 2 +- test/BackendMarkdown/Positive.hs | 3 +- tests/smoke/Commands/markdown.smoke.yaml | 2 +- 13 files changed, 192 insertions(+), 112 deletions(-) diff --git a/app/App.hs b/app/App.hs index ab97f16eb8..93673e7c4a 100644 --- a/app/App.hs +++ b/app/App.hs @@ -3,6 +3,7 @@ module App where import CommonOptions import Data.ByteString qualified as ByteString import GlobalOptions +import Juvix.Compiler.Backend.Markdown.Error import Juvix.Compiler.Internal.Translation (InternalTypedResult) import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker import Juvix.Compiler.Pipeline.Loader.PathResolver @@ -264,6 +265,16 @@ runPipeline opts input_ = runPipelineLogger opts input_ . inject +runPipelineRecursive :: + forall r. + (Members '[App, EmbedIO, Logger, TaggedLock] r) => + Maybe (AppPath File) -> + Sem r (InternalTypedResult, [InternalTypedResult]) +runPipelineRecursive input_ = do + args <- askArgs + entry <- getEntryPoint' args input_ + runReader defaultPipelineOptions (runPipelineHtmlEither entry) >>= fromRightJuvixError + runPipelineHtml :: (Members '[App, EmbedIO, Logger, TaggedLock] r) => Bool -> @@ -318,6 +329,9 @@ getRight = either appError return runAppError :: forall e r a. (AppError e, Members '[App] r) => Sem (Error e ': r) a -> Sem r a runAppError = runErrorNoCallStackWith appError +instance AppError MarkdownBackendError where + appError = appError . JuvixError + instance AppError ParserError where appError = appError . JuvixError diff --git a/app/Commands/Html.hs b/app/Commands/Html.hs index a660d142f5..006ca1cb00 100644 --- a/app/Commands/Html.hs +++ b/app/Commands/Html.hs @@ -19,27 +19,26 @@ runGenOnlySourceHtml HtmlOptions {..} = do res <- runPipelineNoOptions _htmlInputFile upToScopingEntry let m = res ^. Scoper.resultModule outputDir <- fromAppPathDir _htmlOutputDir - liftIO $ - Html.genSourceHtml - GenSourceHtmlArgs - { _genSourceHtmlArgsAssetsDir = _htmlAssetsPrefix, - _genSourceHtmlArgsHtmlKind = Html.HtmlOnly, - _genSourceHtmlArgsOnlyCode = _htmlOnlyCode, - _genSourceHtmlArgsParamBase = "", - _genSourceHtmlArgsUrlPrefix = _htmlUrlPrefix, - _genSourceHtmlArgsIdPrefix = _htmlIdPrefix, - _genSourceHtmlArgsNoPath = _htmlNoPath, - _genSourceHtmlArgsFolderStructure = _htmlFolderStructure, - _genSourceHtmlArgsExt = _htmlExt, - _genSourceHtmlArgsStripPrefix = _htmlStripPrefix, - _genSourceHtmlArgsConcreteOpts = Concrete.defaultOptions, - _genSourceHtmlArgsModule = m, - _genSourceHtmlArgsComments = Scoper.getScoperResultComments res, - _genSourceHtmlArgsOutputDir = outputDir, - _genSourceHtmlArgsNoFooter = _htmlNoFooter, - _genSourceHtmlArgsNonRecursive = _htmlNonRecursive, - _genSourceHtmlArgsTheme = _htmlTheme - } + Html.genSourceHtml + GenSourceHtmlArgs + { _genSourceHtmlArgsAssetsDir = _htmlAssetsPrefix, + _genSourceHtmlArgsHtmlKind = Html.HtmlOnly, + _genSourceHtmlArgsOnlyCode = _htmlOnlyCode, + _genSourceHtmlArgsParamBase = "", + _genSourceHtmlArgsUrlPrefix = _htmlUrlPrefix, + _genSourceHtmlArgsIdPrefix = _htmlIdPrefix, + _genSourceHtmlArgsNoPath = _htmlNoPath, + _genSourceHtmlArgsFolderStructure = _htmlFolderStructure, + _genSourceHtmlArgsExt = _htmlExt, + _genSourceHtmlArgsStripPrefix = _htmlStripPrefix, + _genSourceHtmlArgsConcreteOpts = Concrete.defaultOptions, + _genSourceHtmlArgsModule = m, + _genSourceHtmlArgsComments = Scoper.getScoperResultComments res, + _genSourceHtmlArgsOutputDir = outputDir, + _genSourceHtmlArgsNoFooter = _htmlNoFooter, + _genSourceHtmlArgsNonRecursive = _htmlNonRecursive, + _genSourceHtmlArgsTheme = _htmlTheme + } resultToJudocCtx :: InternalTypedResult -> Html.JudocCtx resultToJudocCtx res = diff --git a/app/Commands/Markdown.hs b/app/Commands/Markdown.hs index 3d83b67f11..39809c5ab5 100644 --- a/app/Commands/Markdown.hs +++ b/app/Commands/Markdown.hs @@ -1,62 +1,92 @@ -module Commands.Markdown where +module Commands.Markdown (runCommand) where import Commands.Base import Commands.Markdown.Options -import Data.Text.IO qualified as Text +import Juvix.Compiler.Backend.Markdown.Error import Juvix.Compiler.Backend.Markdown.Translation.FromTyped.Source import Juvix.Compiler.Backend.Markdown.Translation.FromTyped.Source qualified as MK import Juvix.Compiler.Concrete.Data.ScopedName qualified as S -import Juvix.Compiler.Concrete.Language qualified as Concrete -import Juvix.Compiler.Concrete.Pretty qualified as Concrete +import Juvix.Compiler.Concrete.Language as Concrete +import Juvix.Compiler.Concrete.Pretty as Concrete import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper +import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.Base import Juvix.Extra.Assets (writeAssets) +data Mode + = Project (Path Abs Dir) + | SingleFile (Path Abs File) + +getMode :: forall r. (Members '[App, EmbedIO] r) => Maybe (AppPath FileOrDir) -> Sem r Mode +getMode mf = runFailDefaultM projectMode $ do + optFile <- failMaybe mf + either SingleFile Project <$> fromAppPathFileOrDir optFile + where + projectMode :: Sem r Mode + projectMode = Project . (^. rootRootDir) <$> askRoot + runCommand :: + forall r. (Members AppEffects r) => MarkdownOptions -> Sem r () runCommand opts = do - let inputFile = opts ^. markdownInputFile - scopedM <- runPipelineNoOptions inputFile upToScopingEntry - let m = scopedM ^. Scoper.resultModule - outputDir <- fromAppPathDir (opts ^. markdownOutputDir) - let res = - MK.fromJuvixMarkdown' - ProcessJuvixBlocksArgs - { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, - _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, - _processJuvixBlocksArgsIdPrefix = - opts ^. markdownIdPrefix, - _processJuvixBlocksArgsNoPath = - opts ^. markdownNoPath, - _processJuvixBlocksArgsExt = - opts ^. markdownExt, - _processJuvixBlocksArgsStripPrefix = - opts ^. markdownStripPrefix, - _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, - _processJuvixBlocksArgsModule = m, - _processJuvixBlocksArgsOutputDir = outputDir, - _processJuvixBlocksArgsFolderStructure = - opts ^. markdownFolderStructure - } - case res of - Left err -> exitJuvixError (JuvixError err) - Right md - | opts ^. markdownStdout -> liftIO . putStrLn $ md - | otherwise -> do - ensureDir outputDir - when (opts ^. markdownWriteAssets) $ - liftIO $ - writeAssets outputDir + mode :: Mode <- getMode (opts ^. markdownInputFile) + let inputFile = case mode of + Project {} -> Nothing + SingleFile f -> + Just + AppPath + { _pathPath = preFileFromAbs f, + _pathIsInput = True + } + let shouldRecurse :: ImportNode -> Bool + shouldRecurse node = case mode of + Project p -> p == node ^. importNodePackageRoot + SingleFile {} -> False + (scopedM, others) :: (Scoper.ScoperResult, [Scoper.ScoperResult]) <- + runPipelineEither () inputFile (processRecursivelyUpTo shouldRecurse upToScopingEntry) + >>= fmap ((^. pipelineResult) . snd) . getRight + mapM_ goScoperResult (scopedM : others) + where + goScoperResult :: Scoper.ScoperResult -> Sem r () + goScoperResult scopedM = do + let m :: Module 'Scoped 'ModuleTop = scopedM ^. Scoper.resultModule + outputDir <- fromAppPathDir (opts ^. markdownOutputDir) + let args = + ProcessJuvixBlocksArgs + { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, + _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, + _processJuvixBlocksArgsIdPrefix = + opts ^. markdownIdPrefix, + _processJuvixBlocksArgsNoPath = + opts ^. markdownNoPath, + _processJuvixBlocksArgsExt = + opts ^. markdownExt, + _processJuvixBlocksArgsStripPrefix = + opts ^. markdownStripPrefix, + _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, + _processJuvixBlocksArgsModule = m, + _processJuvixBlocksArgsOutputDir = outputDir, + _processJuvixBlocksArgsFolderStructure = + opts ^. markdownFolderStructure + } + + md :: Text <- runAppError @MarkdownBackendError (MK.fromJuvixMarkdown args) + if + | opts ^. markdownStdout -> putStrLn md + | otherwise -> do + ensureDir outputDir + when (opts ^. markdownWriteAssets) $ + writeAssets outputDir - let mdFile :: Path Rel File - mdFile = - relFile - ( Concrete.topModulePathToDottedPath - (m ^. Concrete.modulePath . S.nameConcrete) - <.> markdownFileExt - ) - absPath :: Path Abs File - absPath = outputDir mdFile + let mdFile :: Path Rel File + mdFile = + relFile + ( Concrete.topModulePathToDottedPath + (m ^. Concrete.modulePath . S.nameConcrete) + <.> markdownFileExt + ) + absPath :: Path Abs File + absPath = outputDir mdFile - liftIO $ Text.writeFile (toFilePath absPath) md + writeFileEnsureLn absPath md diff --git a/app/Commands/Markdown/Options.hs b/app/Commands/Markdown/Options.hs index ca675c939a..907117cbc9 100644 --- a/app/Commands/Markdown/Options.hs +++ b/app/Commands/Markdown/Options.hs @@ -3,7 +3,7 @@ module Commands.Markdown.Options where import CommonOptions data MarkdownOptions = MarkdownOptions - { _markdownInputFile :: Maybe (AppPath File), + { _markdownInputFile :: Maybe (AppPath FileOrDir), _markdownOutputDir :: AppPath Dir, _markdownUrlPrefix :: Text, _markdownIdPrefix :: Text, @@ -33,7 +33,16 @@ parseJuvixMarkdown = do <> showDefault <> help "Prefix used for HTML element IDs" ) - _markdownInputFile <- optional (parseInputFile FileExtJuvixMarkdown) + _markdownInputFile <- + optional + ( argument + someInputPreFileOrDirOpt + ( metavar "JUVIX_MD_FILE_OR_PROJECT" + <> help ("Path to a " <> show FileExtJuvixMarkdown <> " file or to a directory containing a Juvix project.") + <> completer (extCompleter FileExtJuvixMarkdown) + <> action "directory" + ) + ) _markdownOutputDir <- parseGenericOutputDir ( value "markdown" diff --git a/app/CommonOptions.hs b/app/CommonOptions.hs index 3df1922c62..9869e1ef7d 100644 --- a/app/CommonOptions.hs +++ b/app/CommonOptions.hs @@ -22,7 +22,6 @@ import Juvix.Compiler.Tree.Data.TransformationId.Parser qualified as Tree import Juvix.Data.Field import Juvix.Data.Keyword.All qualified as Kw import Juvix.Prelude -import Juvix.Prelude as Juvix import Juvix.Prelude.Parsing qualified as P import Juvix.Prelude.Pretty hiding (group, list) import Options.Applicative hiding (helpDoc) @@ -50,7 +49,7 @@ parseInputFilesMod :: NonEmpty FileExt -> Mod ArgumentFields (Prepath File) -> P parseInputFilesMod exts' mods = do let exts = NonEmpty.toList exts' mvars = intercalate "|" (map toMetavar exts) - dotExts = intercalate ", " (map Prelude.show exts) + dotExts = intercalate ", " (map show exts) helpMsg = "Path to a " <> dotExts <> " file" completers = foldMap (completer . extCompleter) exts _pathPath <- @@ -130,7 +129,7 @@ parseNumThreads = do <> value defaultNumThreads <> showDefault <> help "Number of physical threads to run" - <> completer (listCompleter (Juvix.show NumThreadsAuto : [Juvix.show j | j <- [1 .. numCapabilities]])) + <> completer (listCompleter (show NumThreadsAuto : [show j | j <- [1 .. numCapabilities]])) ) parseProgramInputFile :: Parser (AppPath File) @@ -186,6 +185,16 @@ parseGenericOutputDir m = do somePreDirOpt :: ReadM (Prepath Dir) somePreDirOpt = mkPrepath <$> str +someInputPreFileOrDirOpt :: ReadM (AppPath FileOrDir) +someInputPreFileOrDirOpt = mkInputAppPath . mkPrepath <$> str + where + mkInputAppPath :: Prepath f -> AppPath f + mkInputAppPath p = + AppPath + { _pathPath = p, + _pathIsInput = True + } + somePreFileOrDirOpt :: ReadM (Prepath FileOrDir) somePreFileOrDirOpt = mkPrepath <$> str @@ -240,13 +249,13 @@ enumReader :: forall a. (Bounded a, Enum a, Show a) => Proxy a -> ReadM a enumReader _ = eitherReader $ \val -> case lookup val assocs of Just x -> return x - Nothing -> Left ("Invalid value " <> val <> ". Valid values are: " <> (Juvix.show (allElements @a))) + Nothing -> Left ("Invalid value " <> val <> ". Valid values are: " <> (show (allElements @a))) where assocs :: [(String, a)] assocs = [(Prelude.show x, x) | x <- allElements @a] enumCompleter :: forall a. (Bounded a, Enum a, Show a) => Proxy a -> Completer -enumCompleter _ = listCompleter [Juvix.show e | e <- allElements @a] +enumCompleter _ = listCompleter [show e | e <- allElements @a] extCompleter :: FileExt -> Completer extCompleter ext = mkCompleter $ \word -> do diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs index 5768f8a668..18b9ef10b6 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs @@ -78,7 +78,7 @@ data GenModuleTextArgs = GenModuleTextArgs makeLenses ''GenModuleTextArgs -genSourceHtml :: GenSourceHtmlArgs -> IO () +genSourceHtml :: forall m. (MonadMask m, MonadIO m) => GenSourceHtmlArgs -> m () genSourceHtml o@GenSourceHtmlArgs {..} = do let outputDir = _genSourceHtmlArgsOutputDir ensureDir outputDir @@ -113,24 +113,25 @@ genSourceHtml o@GenSourceHtmlArgs {..} = do topModules :: HashMap NameId (Module 'Scoped 'ModuleTop) topModules = HashMap.fromList [(entry ^. modulePath . S.nameId, entry)] - outputModule :: Module 'Scoped 'ModuleTop -> IO () + outputModule :: Module 'Scoped 'ModuleTop -> m () outputModule m = do ensureDir (parent outputFile) let absPath = (htmlOptions ^. htmlOptionsOutputDir) outputFile putStrLn $ "Writing " <> pack (toFilePath absPath) - utc <- getCurrentTime - Text.writeFile - (toFilePath outputFile) - ( run - . runReader htmlOptions - $ genModuleText - GenModuleTextArgs - { _genModuleTextArgsConcreteOpts = o ^. genSourceHtmlArgsConcreteOpts, - _genModuleTextArgsUTC = utc, - _genModuleTextArgsComments = _genSourceHtmlArgsComments, - _genModuleTextArgsModule = m - } - ) + utc <- liftIO getCurrentTime + liftIO $ + Text.writeFile + (toFilePath outputFile) + ( run + . runReader htmlOptions + $ genModuleText + GenModuleTextArgs + { _genModuleTextArgsConcreteOpts = o ^. genSourceHtmlArgsConcreteOpts, + _genModuleTextArgsUTC = utc, + _genModuleTextArgsComments = _genSourceHtmlArgsComments, + _genModuleTextArgsModule = m + } + ) where ext = Text.unpack (htmlOptions ^. htmlOptionsExt) diff --git a/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs b/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs index ac53b3c3b5..bfe95e34df 100644 --- a/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs +++ b/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs @@ -39,9 +39,6 @@ data ProcessingState = ProcessingState makeLenses ''ProcessJuvixBlocksArgs makeLenses ''ProcessingState -fromJuvixMarkdown' :: ProcessJuvixBlocksArgs -> Either MarkdownBackendError Text -fromJuvixMarkdown' = run . runError . fromJuvixMarkdown - fromJuvixMarkdown :: (Members '[Error MarkdownBackendError] r) => ProcessJuvixBlocksArgs -> diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index c0818f3c7c..d1be32e57c 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -12,7 +12,8 @@ module Juvix.Compiler.Pipeline.Driver processFileUpToParsing, processModule, processImport, - processRecursiveUpToTyped, + processRecursivelyUpToTyped, + processRecursivelyUpTo, processImports, processModuleToStoredCore, ) @@ -280,8 +281,8 @@ processProject = do nodes <- toList <$> asks (importTreeProjectNodes rootDir) forWithM nodes (mkEntryIndex >=> processModule) -processRecursiveUpToTyped :: - forall r. +processRecursivelyUpTo :: + forall a r. ( Members '[ Reader EntryPoint, TopModuleNameChecker, @@ -294,24 +295,27 @@ processRecursiveUpToTyped :: ] r ) => - Sem r (InternalTypedResult, [InternalTypedResult]) -processRecursiveUpToTyped = do + (ImportNode -> Bool) -> + Sem (Reader Parser.ParserResult ': Reader Store.ModuleTable ': NameIdGen ': r) a -> + Sem r (a, [a]) +processRecursivelyUpTo shouldRecurse upto = do entry <- ask PipelineResult {..} <- processFileUpToParsing entry let imports = HashMap.keys (_pipelineResultImports ^. Store.moduleTable) - ms <- forM imports $ \imp -> + ms <- fmap catMaybes . forM imports $ \imp -> withPathFile imp goImport let pkg = entry ^. entryPointPackageId mid <- runReader pkg (getModuleId (_pipelineResult ^. Parser.resultModule . modulePath . to topModulePathKey)) - a <- + res <- evalTopNameIdGen mid . runReader _pipelineResultImports . runReader _pipelineResult - $ upToInternalTyped - return (a, ms) + $ upto + return (res, ms) where - goImport :: ImportNode -> Sem r InternalTypedResult - goImport node = do + goImport :: ImportNode -> Sem r (Maybe a) + goImport node = runFail $ do + failUnless (shouldRecurse node) pkgInfo <- fromJust . HashMap.lookup (node ^. importNodePackageRoot) <$> getPackageInfos let pid = pkgInfo ^. packageInfoPackageId entry <- ask @@ -321,7 +325,24 @@ processRecursiveUpToTyped = do _entryPointPackageId = pid, _entryPointModulePath = Just (node ^. importNodeAbsFile) } - (^. pipelineResult) <$> runReader entry' (processFileUpTo upToInternalTyped) + (^. pipelineResult) <$> runReader entry' (processFileUpTo (inject upto)) + +processRecursivelyUpToTyped :: + forall r. + ( Members + '[ Reader EntryPoint, + TopModuleNameChecker, + TaggedLock, + HighlightBuilder, + Error JuvixError, + Files, + PathResolver, + ModuleInfoCache + ] + r + ) => + Sem r (InternalTypedResult, [InternalTypedResult]) +processRecursivelyUpToTyped = processRecursivelyUpTo (const True) upToInternalTyped processImport :: forall r. diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index 979a56c610..714b90fb08 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -57,8 +57,7 @@ runPipelineHtmlEither :: EntryPoint -> Sem r (Either JuvixError (Typed.InternalTypedResult, [Typed.InternalTypedResult])) runPipelineHtmlEither entry = do - x <- runIOEitherPipeline' entry $ do - processRecursiveUpToTyped + x <- runIOEitherPipeline' entry processRecursivelyUpToTyped return . mapRight snd $ snd x runIOEitherHelper :: diff --git a/src/Juvix/Extra/Assets.hs b/src/Juvix/Extra/Assets.hs index 6cb93a9a76..763cdc0889 100644 --- a/src/Juvix/Extra/Assets.hs +++ b/src/Juvix/Extra/Assets.hs @@ -37,13 +37,13 @@ assetsWithAbsPathAndContent baseDir = let absPath = absDirAssetsByKind baseDir kind relPart ] -writeAssets :: Path Abs Dir -> IO () +writeAssets :: forall m. (MonadIO m) => Path Abs Dir -> m () writeAssets baseDir = do putStrLn $ "Copying assets files to " <> pack (toFilePath baseDir) mapM_ writeAssetFile (assetsWithAbsPathAndContent baseDir) where - writeAssetFile :: (Path Abs File, ByteString) -> IO () + writeAssetFile :: (Path Abs File, ByteString) -> m () writeAssetFile (p, content) = do let dirFile = parent p createDirIfMissing True dirFile - BS.writeFile (toFilePath p) content + liftIO (BS.writeFile (toFilePath p) content) diff --git a/test/BackendMarkdown/Negative.hs b/test/BackendMarkdown/Negative.hs index 70bd6ff8c9..2bfd7b79a1 100644 --- a/test/BackendMarkdown/Negative.hs +++ b/test/BackendMarkdown/Negative.hs @@ -48,7 +48,7 @@ testDescr NegTest {..} = _processJuvixBlocksArgsOutputDir = root $(mkRelDir "markdown") } - res = fromJuvixMarkdown' opts + res = run (runError @MarkdownBackendError (fromJuvixMarkdown opts)) case res of Left err -> whenJust (_checkErr (JuvixError err)) assertFailure Right _ -> assertFailure "Unexpected success" diff --git a/test/BackendMarkdown/Positive.hs b/test/BackendMarkdown/Positive.hs index 177c12f006..cd1731c454 100644 --- a/test/BackendMarkdown/Positive.hs +++ b/test/BackendMarkdown/Positive.hs @@ -1,6 +1,7 @@ module BackendMarkdown.Positive where import Base +import Juvix.Compiler.Backend.Markdown.Error import Juvix.Compiler.Backend.Markdown.Translation.FromTyped.Source import Juvix.Compiler.Concrete qualified as Concrete import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper @@ -53,7 +54,7 @@ testDescr PosTest {..} = root $(mkRelDir "markdown") } - let res = fromJuvixMarkdown' opts + let res = run (runError @MarkdownBackendError (fromJuvixMarkdown opts)) case res of Left err -> assertFailure (show err) Right md -> do diff --git a/tests/smoke/Commands/markdown.smoke.yaml b/tests/smoke/Commands/markdown.smoke.yaml index cca5fd5a35..da549f108a 100644 --- a/tests/smoke/Commands/markdown.smoke.yaml +++ b/tests/smoke/Commands/markdown.smoke.yaml @@ -9,7 +9,7 @@ tests: - markdown - --help stdout: - contains: JUVIX_MARKDOWN_FILE + contains: JUVIX_MD_FILE_OR_PROJECT exit-status: 0 - name: markdown-stdout From 3e52c038f11e0c6562b3b4e577094b2beec4d9a2 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 9 Jan 2025 22:54:42 +0100 Subject: [PATCH 2/5] implement processProjectWith and variants --- app/Commands/Format.hs | 10 +- src/Juvix/Compiler/Pipeline/Driver.hs | 131 ++++++++++++++++++++- src/Juvix/Compiler/Pipeline/Driver/Data.hs | 12 ++ src/Juvix/Formatter.hs | 55 +++------ 4 files changed, 163 insertions(+), 45 deletions(-) diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index 7242695c62..4d4d66d114 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -3,8 +3,8 @@ module Commands.Format where import Commands.Base import Commands.Format.Options import Data.Text qualified as Text +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.Base -import Juvix.Compiler.Store.Language (ModuleInfo) import Juvix.Formatter data FormatNoEditRenderMode @@ -52,11 +52,11 @@ formatProject :: (Members '[App, EmbedIO, TaggedLock, Logger, ScopeEff, Files, Output FormattedFileInfo] r) => Sem r FormatResult formatProject = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do - res :: [(ImportNode, PipelineResult ModuleInfo)] <- processProject + res :: [ProcessedNode ScoperResult] <- processProjectUpToScoping pkgId :: PackageId <- (^. entryPointPackageId) <$> ask - res' :: [(ImportNode, SourceCode)] <- runReader pkgId $ forM res $ \(node, nfo) -> do - src <- formatModuleInfo node nfo - return (node, src) + res' :: [(ImportNode, SourceCode)] <- runReader pkgId $ forM res $ \node -> do + src <- formatModuleInfo node + return (node ^. processedNode, src) formatRes <- formatProjectSourceCode res' formatPkgRes <- formatPackageDotJuvix return (formatRes <> formatPkgRes) diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index d1be32e57c..8eadf6ceca 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -16,6 +16,8 @@ module Juvix.Compiler.Pipeline.Driver processRecursivelyUpTo, processImports, processModuleToStoredCore, + processProjectUpToScoping, + processProjectUpToParsing, ) where @@ -23,9 +25,13 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Concrete.Data.Highlight import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Print.Base (docNoCommentsDefault) +import Juvix.Compiler.Concrete.Translation.FromParsed (scopeCheck) import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping (getModuleId) +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context qualified as Scoper +import Juvix.Compiler.Concrete.Translation.FromSource (fromSource) import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser +import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context (ParserResult) import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState (parserStateImports) import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState qualified as Parser import Juvix.Compiler.Concrete.Translation.FromSource.TopModuleNameChecker @@ -40,11 +46,13 @@ import Juvix.Compiler.Pipeline.JvoCache import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.ModuleInfoCache import Juvix.Compiler.Store.Core.Extra +import Juvix.Compiler.Store.Extra import Juvix.Compiler.Store.Extra qualified as Store import Juvix.Compiler.Store.Language import Juvix.Compiler.Store.Language qualified as Store import Juvix.Compiler.Store.Options qualified as StoredModule import Juvix.Compiler.Store.Options qualified as StoredOptions +import Juvix.Compiler.Store.Scoped.Language (ScopedModuleTable) import Juvix.Compiler.Store.Scoped.Language qualified as Scoped import Juvix.Data.CodeAnn import Juvix.Data.SHA256 qualified as SHA256 @@ -275,11 +283,128 @@ processModuleCacheMiss entryIx = do return r ProcessModuleRecompile recomp -> recomp ^. recompileDo -processProject :: (Members '[PathResolver, ModuleInfoCache, Reader EntryPoint, Reader ImportTree] r) => Sem r [(ImportNode, PipelineResult ModuleInfo)] +processProject :: + (Members '[PathResolver, ModuleInfoCache, Reader EntryPoint, Reader ImportTree] r) => + Sem r [ProcessedNode ()] processProject = do rootDir <- asks (^. entryPointRoot) - nodes <- toList <$> asks (importTreeProjectNodes rootDir) - forWithM nodes (mkEntryIndex >=> processModule) + nodes <- asks (importTreeProjectNodes rootDir) + map mkProcessed <$> forWithM nodes (mkEntryIndex >=> processModule) + where + mkProcessed :: (ImportNode, PipelineResult ModuleInfo) -> ProcessedNode () + mkProcessed (_processedNode, _processedNodeInfo) = + ProcessedNode + { _processedNodeData = (), + .. + } + +processProjectWith :: + forall a r. + ( Members + '[ Error JuvixError, + ModuleInfoCache, + PathResolver, + Reader EntryPoint, + Reader ImportTree, + Files + ] + r + ) => + ( forall r'. + ( Members + '[ Error JuvixError, + Files, + Reader PackageId, + HighlightBuilder, + PathResolver + ] + r' + ) => + ProcessedNode () -> + Sem r' a + ) -> + Sem r [ProcessedNode a] +processProjectWith procNode = do + l <- processProject + pkgId <- asks (^. entryPointPackageId) + runReader pkgId $ + sequence + [ do + d <- + withResolverRoot (n ^. processedNode . importNodePackageRoot) + . evalHighlightBuilder + $ procNode n + return (set processedNodeData d n) + | n <- l + ] + +processProjectUpToScoping :: + forall r. + ( Members + '[ Files, + Error JuvixError, + PathResolver, + ModuleInfoCache, + Reader EntryPoint, + Reader ImportTree + ] + r + ) => + Sem r [ProcessedNode ScoperResult] +processProjectUpToScoping = processProjectWith processNodeUpToScoping + +processProjectUpToParsing :: + forall r. + ( Members + '[ Files, + Error JuvixError, + PathResolver, + ModuleInfoCache, + Reader EntryPoint, + Reader ImportTree + ] + r + ) => + Sem r [ProcessedNode ParserResult] +processProjectUpToParsing = processProjectWith processNodeUpToParsing + +processNodeUpToParsing :: + ( Members + '[ PathResolver, + Error JuvixError, + Files, + HighlightBuilder, + Reader PackageId + ] + r + ) => + ProcessedNode () -> + Sem r ParserResult +processNodeUpToParsing node = + runTopModuleNameChecker $ + fromSource Nothing (Just (node ^. processedNode . importNodeAbsFile)) + +processNodeUpToScoping :: + ( Members + '[ PathResolver, + Error JuvixError, + Files, + HighlightBuilder, + Reader PackageId + ] + r + ) => + ProcessedNode () -> + Sem r ScoperResult +processNodeUpToScoping node = do + parseRes <- processNodeUpToParsing node + pkg <- ask + let modules = node ^. processedNodeInfo . pipelineResultImports + scopedModules :: ScopedModuleTable = getScopedModuleTable modules + tmp :: TopModulePathKey = relPathtoTopModulePathKey (node ^. processedNode . importNodeFile) + moduleid :: ModuleId = run (runReader pkg (getModuleId tmp)) + evalTopNameIdGen moduleid $ + scopeCheck pkg scopedModules parseRes processRecursivelyUpTo :: forall a r. diff --git a/src/Juvix/Compiler/Pipeline/Driver/Data.hs b/src/Juvix/Compiler/Pipeline/Driver/Data.hs index 298f0c06c2..deabfa1a0c 100644 --- a/src/Juvix/Compiler/Pipeline/Driver/Data.hs +++ b/src/Juvix/Compiler/Pipeline/Driver/Data.hs @@ -4,7 +4,9 @@ module Juvix.Compiler.Pipeline.Driver.Data ) where +import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.Base import Juvix.Compiler.Pipeline.Result +import Juvix.Compiler.Store.Language import Juvix.Compiler.Store.Language qualified as Store import Juvix.Prelude import Juvix.Prelude.Pretty @@ -15,7 +17,17 @@ data CompileResult = CompileResult _compileResultChanged :: Bool } +data ProcessedNode a = ProcessedNode + { _processedNode :: ImportNode, + _processedNodeInfo :: PipelineResult ModuleInfo, + _processedNodeData :: a + } + makeLenses ''CompileResult +makeLenses ''ProcessedNode + +instance Functor ProcessedNode where + fmap = over processedNodeData instance Semigroup CompileResult where sconcat l = diff --git a/src/Juvix/Formatter.hs b/src/Juvix/Formatter.hs index a0185a4cf4..5b2aadd03d 100644 --- a/src/Juvix/Formatter.hs +++ b/src/Juvix/Formatter.hs @@ -2,19 +2,13 @@ module Juvix.Formatter where -import Juvix.Compiler.Concrete.Data.Highlight.Builder (evalHighlightBuilder) import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Print (ppOutDefault) -import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping (ScoperResult, getModuleId, scopeCheck) +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping (ScoperResult) import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper -import Juvix.Compiler.Concrete.Translation.FromSource (ParserResult, fromSource) -import Juvix.Compiler.Concrete.Translation.FromSource.TopModuleNameChecker (runTopModuleNameChecker) +import Juvix.Compiler.Pipeline.Driver.Data import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.Loader.PathResolver -import Juvix.Compiler.Pipeline.Result -import Juvix.Compiler.Store.Extra (getScopedModuleTable) -import Juvix.Compiler.Store.Language qualified as Store -import Juvix.Compiler.Store.Scoped.Language (ScopedModuleTable) import Juvix.Data.CodeAnn import Juvix.Extra.Paths import Juvix.Prelude @@ -113,36 +107,23 @@ formatModuleInfo :: ] r ) => - ImportNode -> - PipelineResult Store.ModuleInfo -> + ProcessedNode ScoperResult -> Sem r SourceCode -formatModuleInfo node moduleInfo = - withResolverRoot (node ^. importNodePackageRoot) - . evalHighlightBuilder - $ do - pkg :: PackageId <- ask - parseRes :: ParserResult <- - runTopModuleNameChecker $ - fromSource Nothing (Just (node ^. importNodeAbsFile)) - let modules = moduleInfo ^. pipelineResultImports - scopedModules :: ScopedModuleTable = getScopedModuleTable modules - tmp :: TopModulePathKey = relPathtoTopModulePathKey (node ^. importNodeFile) - moduleid :: ModuleId = run (runReader pkg (getModuleId tmp)) - scopeRes :: ScoperResult <- - evalTopNameIdGen moduleid $ - scopeCheck pkg scopedModules parseRes - originalSource :: Text <- readFile' (node ^. importNodeAbsFile) - formattedTxt <- - runReader originalSource $ - formatScoperResult False scopeRes - let formatRes = - SourceCode - { _sourceCodeFormatted = formattedTxt, - _sourceCodeOriginal = originalSource - } - return . forcing formatRes $ do - forcesField sourceCodeFormatted - forcesField sourceCodeOriginal +formatModuleInfo pnode = do + let node = pnode ^. processedNode + scopeRes = pnode ^. processedNodeData + originalSource :: Text <- readFile' (node ^. importNodeAbsFile) + formattedTxt <- + runReader originalSource $ + formatScoperResult False scopeRes + let formatRes = + SourceCode + { _sourceCodeFormatted = formattedTxt, + _sourceCodeOriginal = originalSource + } + return . forcing formatRes $ do + forcesField sourceCodeFormatted + forcesField sourceCodeOriginal formatPath :: (Members '[Reader OriginalSource, ScopeEff] r) => From 41ba2c43d54a1cee5273bb2c627d870c528694a1 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 10 Jan 2025 00:04:39 +0100 Subject: [PATCH 3/5] wip --- app/Commands/Format.hs | 4 +- app/Commands/Markdown.hs | 202 ++++++++++++++++++++++++++------------- 2 files changed, 135 insertions(+), 71 deletions(-) diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index 4d4d66d114..3261fc6795 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -49,7 +49,7 @@ targetFromOptions opts = do -- | Formats the project on the root formatProject :: forall r. - (Members '[App, EmbedIO, TaggedLock, Logger, ScopeEff, Files, Output FormattedFileInfo] r) => + (Members (ScopeEff ': Output FormattedFileInfo ': AppEffects) r) => Sem r FormatResult formatProject = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do res :: [ProcessedNode ScoperResult] <- processProjectUpToScoping @@ -61,7 +61,7 @@ formatProject = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do formatPkgRes <- formatPackageDotJuvix return (formatRes <> formatPkgRes) -formatPackageDotJuvix :: forall r. (Members '[App, Files, Logger, Output FormattedFileInfo, ScopeEff] r) => Sem r FormatResult +formatPackageDotJuvix :: forall r. (Members (Output FormattedFileInfo ': ScopeEff ': AppEffects) r) => Sem r FormatResult formatPackageDotJuvix = do pkgDotJuvix <- askPackageDotJuvixPath ifM (fileExists' pkgDotJuvix) (format pkgDotJuvix) (return mempty) diff --git a/app/Commands/Markdown.hs b/app/Commands/Markdown.hs index 39809c5ab5..32a05560cd 100644 --- a/app/Commands/Markdown.hs +++ b/app/Commands/Markdown.hs @@ -8,85 +8,149 @@ import Juvix.Compiler.Backend.Markdown.Translation.FromTyped.Source qualified as import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Concrete.Language as Concrete import Juvix.Compiler.Concrete.Pretty as Concrete +import Juvix.Compiler.Concrete.Print.Base qualified as Concrete import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper -import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.Base +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context +import Juvix.Data.CodeAnn import Juvix.Extra.Assets (writeAssets) -data Mode - = Project (Path Abs Dir) - | SingleFile (Path Abs File) +-- data Mode +-- = Project (Path Abs Dir) +-- | SingleFile (Path Abs File) -getMode :: forall r. (Members '[App, EmbedIO] r) => Maybe (AppPath FileOrDir) -> Sem r Mode -getMode mf = runFailDefaultM projectMode $ do - optFile <- failMaybe mf - either SingleFile Project <$> fromAppPathFileOrDir optFile - where - projectMode :: Sem r Mode - projectMode = Project . (^. rootRootDir) <$> askRoot +-- getMode :: forall r. (Members '[App, EmbedIO] r) => Maybe (AppPath FileOrDir) -> Sem r Mode +-- getMode mf = runFailDefaultM projectMode $ do +-- optFile <- failMaybe mf +-- either SingleFile Project <$> fromAppPathFileOrDir optFile +-- where +-- projectMode :: Sem r Mode +-- projectMode = Project . (^. rootRootDir) <$> askRoot + +-- runCommand :: +-- forall r. +-- (Members AppEffects r) => +-- MarkdownOptions -> +-- Sem r () +-- runCommand opts = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do +-- mode :: Mode <- getMode (opts ^. markdownInputFile) +-- let inputFile = case mode of +-- Project {} -> Nothing +-- SingleFile f -> +-- Just +-- AppPath +-- { _pathPath = preFileFromAbs f, +-- _pathIsInput = True +-- } +-- let shouldRecurse :: ImportNode -> Bool +-- shouldRecurse node = case mode of +-- Project p -> p == node ^. importNodePackageRoot +-- SingleFile {} -> False +-- (scopedM, others) :: (Scoper.ScoperResult, [Scoper.ScoperResult]) <- +-- runPipelineEither () inputFile (processRecursivelyUpTo shouldRecurse upToScopingEntry) +-- >>= fmap ((^. pipelineResult) . snd) . getRight +-- mapM_ goScoperResult (scopedM : others) +-- where +-- goScoperResult :: Scoper.ScoperResult -> Sem r () +-- goScoperResult scopedM = do +-- let m :: Module 'Scoped 'ModuleTop = scopedM ^. Scoper.resultModule +-- outputDir <- fromAppPathDir (opts ^. markdownOutputDir) +-- let args = +-- ProcessJuvixBlocksArgs +-- { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, +-- _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, +-- _processJuvixBlocksArgsIdPrefix = +-- opts ^. markdownIdPrefix, +-- _processJuvixBlocksArgsNoPath = +-- opts ^. markdownNoPath, +-- _processJuvixBlocksArgsExt = +-- opts ^. markdownExt, +-- _processJuvixBlocksArgsStripPrefix = +-- opts ^. markdownStripPrefix, +-- _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, +-- _processJuvixBlocksArgsModule = m, +-- _processJuvixBlocksArgsOutputDir = outputDir, +-- _processJuvixBlocksArgsFolderStructure = +-- opts ^. markdownFolderStructure +-- } + +-- md :: Text <- runAppError @MarkdownBackendError (MK.fromJuvixMarkdown args) +-- if +-- | opts ^. markdownStdout -> putStrLn md +-- | otherwise -> do +-- ensureDir outputDir +-- when (opts ^. markdownWriteAssets) $ +-- writeAssets outputDir + +-- let mdFile :: Path Rel File +-- mdFile = +-- relFile +-- ( Concrete.topModulePathToDottedPath +-- (m ^. Concrete.modulePath . S.nameConcrete) +-- <.> markdownFileExt +-- ) +-- absPath :: Path Abs File +-- absPath = outputDir mdFile + +-- writeFileEnsureLn absPath md runCommand :: forall r. (Members AppEffects r) => MarkdownOptions -> Sem r () -runCommand opts = do - mode :: Mode <- getMode (opts ^. markdownInputFile) - let inputFile = case mode of - Project {} -> Nothing - SingleFile f -> - Just - AppPath - { _pathPath = preFileFromAbs f, - _pathIsInput = True - } - let shouldRecurse :: ImportNode -> Bool - shouldRecurse node = case mode of - Project p -> p == node ^. importNodePackageRoot - SingleFile {} -> False - (scopedM, others) :: (Scoper.ScoperResult, [Scoper.ScoperResult]) <- - runPipelineEither () inputFile (processRecursivelyUpTo shouldRecurse upToScopingEntry) - >>= fmap ((^. pipelineResult) . snd) . getRight - mapM_ goScoperResult (scopedM : others) - where - goScoperResult :: Scoper.ScoperResult -> Sem r () - goScoperResult scopedM = do - let m :: Module 'Scoped 'ModuleTop = scopedM ^. Scoper.resultModule - outputDir <- fromAppPathDir (opts ^. markdownOutputDir) - let args = - ProcessJuvixBlocksArgs - { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, - _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, - _processJuvixBlocksArgsIdPrefix = - opts ^. markdownIdPrefix, - _processJuvixBlocksArgsNoPath = - opts ^. markdownNoPath, - _processJuvixBlocksArgsExt = - opts ^. markdownExt, - _processJuvixBlocksArgsStripPrefix = - opts ^. markdownStripPrefix, - _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, - _processJuvixBlocksArgsModule = m, - _processJuvixBlocksArgsOutputDir = outputDir, - _processJuvixBlocksArgsFolderStructure = - opts ^. markdownFolderStructure - } +runCommand opts = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do + -- mode :: Mode <- getMode (opts ^. markdownInputFile) + -- let inputFile = case mode of + -- Project {} -> Nothing + -- SingleFile f -> + -- Just + -- AppPath + -- { _pathPath = preFileFromAbs f, + -- _pathIsInput = True + -- } + res :: [ProcessedNode ScoperResult] <- processProjectUpToScoping + forM_ res (goScoperResult opts . (^. processedNodeData)) + +goScoperResult :: (Members AppEffects r) => MarkdownOptions -> Scoper.ScoperResult -> Sem r () +goScoperResult opts scopedM = do + let m :: Module 'Scoped 'ModuleTop = scopedM ^. Scoper.resultModule + outputDir <- fromAppPathDir (opts ^. markdownOutputDir) + logProgress (mkAnsiText @(Doc CodeAnn) ("Processing" <+> Concrete.docNoCommentsDefault (m ^. modulePath))) + let args = + ProcessJuvixBlocksArgs + { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, + _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, + _processJuvixBlocksArgsIdPrefix = + opts ^. markdownIdPrefix, + _processJuvixBlocksArgsNoPath = + opts ^. markdownNoPath, + _processJuvixBlocksArgsExt = + opts ^. markdownExt, + _processJuvixBlocksArgsStripPrefix = + opts ^. markdownStripPrefix, + _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, + _processJuvixBlocksArgsModule = m, + _processJuvixBlocksArgsOutputDir = outputDir, + _processJuvixBlocksArgsFolderStructure = + opts ^. markdownFolderStructure + } - md :: Text <- runAppError @MarkdownBackendError (MK.fromJuvixMarkdown args) - if - | opts ^. markdownStdout -> putStrLn md - | otherwise -> do - ensureDir outputDir - when (opts ^. markdownWriteAssets) $ - writeAssets outputDir + md :: Text <- runAppError @MarkdownBackendError (MK.fromJuvixMarkdown args) + if + | opts ^. markdownStdout -> putStrLn md + | otherwise -> do + ensureDir outputDir + when (opts ^. markdownWriteAssets) $ + writeAssets outputDir - let mdFile :: Path Rel File - mdFile = - relFile - ( Concrete.topModulePathToDottedPath - (m ^. Concrete.modulePath . S.nameConcrete) - <.> markdownFileExt - ) - absPath :: Path Abs File - absPath = outputDir mdFile + let mdFile :: Path Rel File + mdFile = + relFile + ( Concrete.topModulePathToDottedPath + (m ^. Concrete.modulePath . S.nameConcrete) + <.> markdownFileExt + ) + absPath :: Path Abs File + absPath = outputDir mdFile - writeFileEnsureLn absPath md + writeFileEnsureLn absPath md From 42c9d6af6798fa9db89282eb331e40b85b5213af Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 10 Jan 2025 09:41:23 +0100 Subject: [PATCH 4/5] skip non markdown files --- app/Commands/Markdown.hs | 166 ++++++++++----------------------------- 1 file changed, 41 insertions(+), 125 deletions(-) diff --git a/app/Commands/Markdown.hs b/app/Commands/Markdown.hs index 32a05560cd..a0b522c43a 100644 --- a/app/Commands/Markdown.hs +++ b/app/Commands/Markdown.hs @@ -14,143 +14,59 @@ import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Cont import Juvix.Data.CodeAnn import Juvix.Extra.Assets (writeAssets) --- data Mode --- = Project (Path Abs Dir) --- | SingleFile (Path Abs File) - --- getMode :: forall r. (Members '[App, EmbedIO] r) => Maybe (AppPath FileOrDir) -> Sem r Mode --- getMode mf = runFailDefaultM projectMode $ do --- optFile <- failMaybe mf --- either SingleFile Project <$> fromAppPathFileOrDir optFile --- where --- projectMode :: Sem r Mode --- projectMode = Project . (^. rootRootDir) <$> askRoot - --- runCommand :: --- forall r. --- (Members AppEffects r) => --- MarkdownOptions -> --- Sem r () --- runCommand opts = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do --- mode :: Mode <- getMode (opts ^. markdownInputFile) --- let inputFile = case mode of --- Project {} -> Nothing --- SingleFile f -> --- Just --- AppPath --- { _pathPath = preFileFromAbs f, --- _pathIsInput = True --- } --- let shouldRecurse :: ImportNode -> Bool --- shouldRecurse node = case mode of --- Project p -> p == node ^. importNodePackageRoot --- SingleFile {} -> False --- (scopedM, others) :: (Scoper.ScoperResult, [Scoper.ScoperResult]) <- --- runPipelineEither () inputFile (processRecursivelyUpTo shouldRecurse upToScopingEntry) --- >>= fmap ((^. pipelineResult) . snd) . getRight --- mapM_ goScoperResult (scopedM : others) --- where --- goScoperResult :: Scoper.ScoperResult -> Sem r () --- goScoperResult scopedM = do --- let m :: Module 'Scoped 'ModuleTop = scopedM ^. Scoper.resultModule --- outputDir <- fromAppPathDir (opts ^. markdownOutputDir) --- let args = --- ProcessJuvixBlocksArgs --- { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, --- _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, --- _processJuvixBlocksArgsIdPrefix = --- opts ^. markdownIdPrefix, --- _processJuvixBlocksArgsNoPath = --- opts ^. markdownNoPath, --- _processJuvixBlocksArgsExt = --- opts ^. markdownExt, --- _processJuvixBlocksArgsStripPrefix = --- opts ^. markdownStripPrefix, --- _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, --- _processJuvixBlocksArgsModule = m, --- _processJuvixBlocksArgsOutputDir = outputDir, --- _processJuvixBlocksArgsFolderStructure = --- opts ^. markdownFolderStructure --- } - --- md :: Text <- runAppError @MarkdownBackendError (MK.fromJuvixMarkdown args) --- if --- | opts ^. markdownStdout -> putStrLn md --- | otherwise -> do --- ensureDir outputDir --- when (opts ^. markdownWriteAssets) $ --- writeAssets outputDir - --- let mdFile :: Path Rel File --- mdFile = --- relFile --- ( Concrete.topModulePathToDottedPath --- (m ^. Concrete.modulePath . S.nameConcrete) --- <.> markdownFileExt --- ) --- absPath :: Path Abs File --- absPath = outputDir mdFile - --- writeFileEnsureLn absPath md - runCommand :: forall r. (Members AppEffects r) => MarkdownOptions -> Sem r () -runCommand opts = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do - -- mode :: Mode <- getMode (opts ^. markdownInputFile) - -- let inputFile = case mode of - -- Project {} -> Nothing - -- SingleFile f -> - -- Just - -- AppPath - -- { _pathPath = preFileFromAbs f, - -- _pathIsInput = True - -- } +runCommand opts = runPipelineOptions . runPipelineSetup $ do res :: [ProcessedNode ScoperResult] <- processProjectUpToScoping forM_ res (goScoperResult opts . (^. processedNodeData)) goScoperResult :: (Members AppEffects r) => MarkdownOptions -> Scoper.ScoperResult -> Sem r () goScoperResult opts scopedM = do let m :: Module 'Scoped 'ModuleTop = scopedM ^. Scoper.resultModule - outputDir <- fromAppPathDir (opts ^. markdownOutputDir) - logProgress (mkAnsiText @(Doc CodeAnn) ("Processing" <+> Concrete.docNoCommentsDefault (m ^. modulePath))) - let args = - ProcessJuvixBlocksArgs - { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, - _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, - _processJuvixBlocksArgsIdPrefix = - opts ^. markdownIdPrefix, - _processJuvixBlocksArgsNoPath = - opts ^. markdownNoPath, - _processJuvixBlocksArgsExt = - opts ^. markdownExt, - _processJuvixBlocksArgsStripPrefix = - opts ^. markdownStripPrefix, - _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, - _processJuvixBlocksArgsModule = m, - _processJuvixBlocksArgsOutputDir = outputDir, - _processJuvixBlocksArgsFolderStructure = - opts ^. markdownFolderStructure - } - - md :: Text <- runAppError @MarkdownBackendError (MK.fromJuvixMarkdown args) if - | opts ^. markdownStdout -> putStrLn md + | isNothing (m ^. moduleMarkdownInfo) -> + logInfo (mkAnsiText @(Doc CodeAnn) ("Skipping" <+> Concrete.docNoCommentsDefault (m ^. modulePath))) | otherwise -> do - ensureDir outputDir - when (opts ^. markdownWriteAssets) $ - writeAssets outputDir + outputDir <- fromAppPathDir (opts ^. markdownOutputDir) + logProgress (mkAnsiText @(Doc CodeAnn) ("Processing" <+> Concrete.docNoCommentsDefault (m ^. modulePath))) + let args = + ProcessJuvixBlocksArgs + { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, + _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, + _processJuvixBlocksArgsIdPrefix = + opts ^. markdownIdPrefix, + _processJuvixBlocksArgsNoPath = + opts ^. markdownNoPath, + _processJuvixBlocksArgsExt = + opts ^. markdownExt, + _processJuvixBlocksArgsStripPrefix = + opts ^. markdownStripPrefix, + _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM, + _processJuvixBlocksArgsModule = m, + _processJuvixBlocksArgsOutputDir = outputDir, + _processJuvixBlocksArgsFolderStructure = + opts ^. markdownFolderStructure + } + + md :: Text <- runAppError @MarkdownBackendError (MK.fromJuvixMarkdown args) + if + | opts ^. markdownStdout -> putStrLn md + | otherwise -> do + ensureDir outputDir + when (opts ^. markdownWriteAssets) $ + writeAssets outputDir - let mdFile :: Path Rel File - mdFile = - relFile - ( Concrete.topModulePathToDottedPath - (m ^. Concrete.modulePath . S.nameConcrete) - <.> markdownFileExt - ) - absPath :: Path Abs File - absPath = outputDir mdFile + let mdFile :: Path Rel File + mdFile = + relFile + ( Concrete.topModulePathToDottedPath + (m ^. Concrete.modulePath . S.nameConcrete) + <.> markdownFileExt + ) + absPath :: Path Abs File + absPath = outputDir mdFile - writeFileEnsureLn absPath md + writeFileEnsureLn absPath md From ee1852153970091b7771cd18ccdab7d954185fc3 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 10 Jan 2025 10:12:42 +0100 Subject: [PATCH 5/5] restore single file --- app/Commands/Markdown.hs | 35 +++++++++++++++++++++++++++++++---- 1 file changed, 31 insertions(+), 4 deletions(-) diff --git a/app/Commands/Markdown.hs b/app/Commands/Markdown.hs index a0b522c43a..ea4523e8ad 100644 --- a/app/Commands/Markdown.hs +++ b/app/Commands/Markdown.hs @@ -19,12 +19,39 @@ runCommand :: (Members AppEffects r) => MarkdownOptions -> Sem r () -runCommand opts = runPipelineOptions . runPipelineSetup $ do +runCommand opts = runReader opts $ do + case opts ^. markdownInputFile of + Nothing -> goProject + Just p -> + fromAppPathFileOrDir p >>= \case + Left f -> goSingleFile f + Right {} -> goProject + +goSingleFile :: + forall r. + (Members (Reader MarkdownOptions ': AppEffects) r) => + Path Abs File -> + Sem r () +goSingleFile f = do + let inputFile = + AppPath + { _pathPath = preFileFromAbs f, + _pathIsInput = True + } + scopedM :: Scoper.ScoperResult <- runPipelineNoOptions (Just inputFile) upToScopingEntry + goScoperResult scopedM + +goProject :: + forall r. + (Members (Reader MarkdownOptions ': AppEffects) r) => + Sem r () +goProject = runPipelineOptions . runPipelineSetup $ do res :: [ProcessedNode ScoperResult] <- processProjectUpToScoping - forM_ res (goScoperResult opts . (^. processedNodeData)) + forM_ res (goScoperResult . (^. processedNodeData)) -goScoperResult :: (Members AppEffects r) => MarkdownOptions -> Scoper.ScoperResult -> Sem r () -goScoperResult opts scopedM = do +goScoperResult :: (Members (Reader MarkdownOptions ': AppEffects) r) => Scoper.ScoperResult -> Sem r () +goScoperResult scopedM = do + opts <- ask let m :: Module 'Scoped 'ModuleTop = scopedM ^. Scoper.resultModule if | isNothing (m ^. moduleMarkdownInfo) ->