From 8616370fb2f10eee08a4cf980f76608a4112722e Mon Sep 17 00:00:00 2001 From: Jonathan Cubides Date: Thu, 16 Nov 2023 11:20:34 +0100 Subject: [PATCH] Add MarkdownInfo entry in Module Concrete Decl and proper errors (#2515) Remove TODO added by @janmasrovira in - https://github.com/anoma/juvix/pull/2513 --- app/Commands/Markdown.hs | 30 +++++----- .../Compiler/Backend/Markdown/Data/Types.hs | 6 ++ src/Juvix/Compiler/Backend/Markdown/Error.hs | 51 ++++++++++++++++ .../Markdown/Translation/FromTyped/Source.hs | 35 ++++++++--- src/Juvix/Compiler/Concrete/Language.hs | 11 +++- .../FromParsed/Analysis/Scoping.hs | 6 +- .../Concrete/Translation/FromSource.hs | 40 +++++++++---- src/Juvix/Compiler/Pipeline/Package/Loader.hs | 3 +- src/Juvix/Parser/Error.hs | 3 + test/BackendMarkdown.hs | 11 ++++ test/BackendMarkdown/Negative.hs | 60 +++++++++++++++++++ .../Positive.hs} | 16 ++--- test/Main.hs | 4 +- tests/negative/Markdown/Empty.juvix.md | 0 .../Markdown/NoJuvixCodeBlocks.juvix.md | 1 + tests/negative/Markdown/juvix.yaml | 0 16 files changed, 227 insertions(+), 50 deletions(-) create mode 100644 src/Juvix/Compiler/Backend/Markdown/Error.hs create mode 100644 test/BackendMarkdown.hs create mode 100644 test/BackendMarkdown/Negative.hs rename test/{Markdown.hs => BackendMarkdown/Positive.hs} (85%) create mode 100644 tests/negative/Markdown/Empty.juvix.md create mode 100644 tests/negative/Markdown/NoJuvixCodeBlocks.juvix.md create mode 100644 tests/negative/Markdown/juvix.yaml diff --git a/app/Commands/Markdown.hs b/app/Commands/Markdown.hs index ef3de8a95..b52d29a95 100644 --- a/app/Commands/Markdown.hs +++ b/app/Commands/Markdown.hs @@ -20,20 +20,22 @@ runCommand opts = do scopedM <- runPipeline inputFile upToScoping let m = head (scopedM ^. Scoper.resultModules) outputDir <- fromAppPathDir (opts ^. markdownOutputDir) - md :: Text <- - MK.fromJuvixMarkdown - ProcessJuvixBlocksArgs - { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, - _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, - _processJuvixBlocksArgsIdPrefix = - opts ^. markdownIdPrefix, - _processJuvixBlocksArgsNoPath = - opts ^. markdownNoPath, - _processJuvixBlocksArgsComments = scopedM ^. Scoper.comments, - _processJuvixBlocksArgsModule = m, - _processJuvixBlocksArgsOutputDir = outputDir - } - if + let res = + MK.fromJuvixMarkdown' + ProcessJuvixBlocksArgs + { _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions, + _processJuvixBlocksArgsUrlPrefix = opts ^. markdownUrlPrefix, + _processJuvixBlocksArgsIdPrefix = + opts ^. markdownIdPrefix, + _processJuvixBlocksArgsNoPath = + opts ^. markdownNoPath, + _processJuvixBlocksArgsComments = scopedM ^. Scoper.comments, + _processJuvixBlocksArgsModule = m, + _processJuvixBlocksArgsOutputDir = outputDir + } + case res of + Left err -> exitJuvixError (JuvixError err) + Right md | opts ^. markdownStdout -> liftIO . putStrLn $ md | otherwise -> do ensureDir outputDir diff --git a/src/Juvix/Compiler/Backend/Markdown/Data/Types.hs b/src/Juvix/Compiler/Backend/Markdown/Data/Types.hs index e5b78893c..2e3341641 100644 --- a/src/Juvix/Compiler/Backend/Markdown/Data/Types.hs +++ b/src/Juvix/Compiler/Backend/Markdown/Data/Types.hs @@ -234,6 +234,12 @@ instance-- (MK.IsInline TextBlock) => xs ) +nullMk :: Mk -> Bool +nullMk = \case + MkConcat a b -> nullMk a && nullMk b + MkNull -> True + _ -> False + extractJuvixCodeBlock :: Mk -> [JuvixCodeBlock] extractJuvixCodeBlock = \case MkJuvixCodeBlock j -> [j] diff --git a/src/Juvix/Compiler/Backend/Markdown/Error.hs b/src/Juvix/Compiler/Backend/Markdown/Error.hs new file mode 100644 index 000000000..ad1ec48b4 --- /dev/null +++ b/src/Juvix/Compiler/Backend/Markdown/Error.hs @@ -0,0 +1,51 @@ +module Juvix.Compiler.Backend.Markdown.Error where + +import Juvix.Compiler.Concrete.Language +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error.Pretty +import Juvix.Prelude + +data MarkdownBackendError + = ErrInternalNoMarkdownInfo NoMarkdownInfoError + | ErrNoJuvixCodeBlocks NoJuvixCodeBlocksError + deriving stock (Show) + +instance ToGenericError MarkdownBackendError where + genericError = \case + ErrInternalNoMarkdownInfo e -> genericError e + ErrNoJuvixCodeBlocks e -> genericError e + +newtype NoMarkdownInfoError = NoMarkdownInfoError + { _noMarkdownInfoFilepath :: Path Abs File + } + deriving stock (Show) + +instance ToGenericError NoMarkdownInfoError where + genericError NoMarkdownInfoError {..} = do + let msg = "The markdown file is empty:\n" <+> pretty _noMarkdownInfoFilepath + return + GenericError + { _genericErrorLoc = i, + _genericErrorMessage = prettyError msg, + _genericErrorIntervals = [i] + } + where + i :: Interval + i = singletonInterval . mkInitialLoc $ _noMarkdownInfoFilepath + +newtype NoJuvixCodeBlocksError = NoJuvixCodeBlocksError + { _noJuvixCodeBlocksErrorFilepath :: Path Abs File + } + deriving stock (Show) + +instance ToGenericError NoJuvixCodeBlocksError where + genericError NoJuvixCodeBlocksError {..} = do + let msg = "The markdown file contain no Juvix code blocks:\n" <+> pretty _noJuvixCodeBlocksErrorFilepath + return + GenericError + { _genericErrorLoc = i, + _genericErrorMessage = prettyError msg, + _genericErrorIntervals = [i] + } + where + i :: Interval + i = singletonInterval . mkInitialLoc $ _noJuvixCodeBlocksErrorFilepath diff --git a/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs b/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs index 69945e145..d8c1d9af4 100644 --- a/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs +++ b/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs @@ -6,6 +6,7 @@ import Data.Text.Lazy (toStrict) import Juvix.Compiler.Backend.Html.Data.Options qualified as HtmlRender import Juvix.Compiler.Backend.Html.Translation.FromTyped.Source qualified as HtmlRender import Juvix.Compiler.Backend.Markdown.Data.Types +import Juvix.Compiler.Backend.Markdown.Error import Juvix.Compiler.Concrete.Language qualified as Concrete import Juvix.Compiler.Concrete.Pretty qualified as Concrete import Juvix.Prelude @@ -34,10 +35,11 @@ data ProcessingState = ProcessingState makeLenses ''ProcessJuvixBlocksArgs makeLenses ''ProcessingState -fromJuvixMarkdown' :: ProcessJuvixBlocksArgs -> Text -fromJuvixMarkdown' = run . fromJuvixMarkdown +fromJuvixMarkdown' :: ProcessJuvixBlocksArgs -> Either MarkdownBackendError Text +fromJuvixMarkdown' = run . runError . fromJuvixMarkdown fromJuvixMarkdown :: + (Members '[Error MarkdownBackendError] r) => ProcessJuvixBlocksArgs -> Sem r Text fromJuvixMarkdown opts = do @@ -55,8 +57,22 @@ fromJuvixMarkdown opts = do m :: Concrete.Module 'Concrete.Scoped 'Concrete.ModuleTop m = opts ^. processJuvixBlocksArgsModule - case (m ^. Concrete.moduleMarkdown, m ^. Concrete.moduleMarkdownSeparation) of - (Just mk, Just sepr) -> do + fname :: Path Abs File + fname = getLoc m ^. intervalFile + + case m ^. Concrete.moduleMarkdownInfo of + Just mkInfo -> do + let mk :: Mk = mkInfo ^. Concrete.markdownInfo + sepr :: [Int] = mkInfo ^. Concrete.markdownInfoBlockLengths + + when (nullMk mk || null sepr) $ + throw + ( ErrNoJuvixCodeBlocks + NoJuvixCodeBlocksError + { _noJuvixCodeBlocksErrorFilepath = fname + } + ) + let st = ProcessingState { _processingStateMk = mk, @@ -66,8 +82,13 @@ fromJuvixMarkdown opts = do } (_, r) <- runState st . runReader htmlOptions . runReader opts $ go return $ MK.toPlainText r - (Nothing, _) -> error "This module has no Markdown" - (_, _) -> error "This Markdown file has no Juvix code blocks" + Nothing -> + throw + ( ErrInternalNoMarkdownInfo + NoMarkdownInfoError + { _noMarkdownInfoFilepath = fname + } + ) htmlSemicolon :: Html htmlSemicolon = Html.span ! HtmlRender.juColor HtmlRender.JuDelimiter $ ";" @@ -141,7 +162,7 @@ go = do _processingStateStmts = drop n stmts, .. } - modify @ProcessingState $ \_ -> newState + modify @ProcessingState $ const newState return _processingStateMk goRender :: (Concrete.PrettyPrint a, Members '[Reader HtmlRender.HtmlOptions, Reader ProcessJuvixBlocksArgs] r) => a -> Sem r Html diff --git a/src/Juvix/Compiler/Concrete/Language.hs b/src/Juvix/Compiler/Concrete/Language.hs index e4f549859..ee0b6a501 100644 --- a/src/Juvix/Compiler/Concrete/Language.hs +++ b/src/Juvix/Compiler/Concrete/Language.hs @@ -921,7 +921,12 @@ type FunctionName s = SymbolType s type LocalModuleName s = SymbolType s --- TODO add MarkdownInfo that has both new fields +data MarkdownInfo = MarkdownInfo + { _markdownInfo :: Mk, + _markdownInfoBlockLengths :: [Int] + } + deriving stock (Show, Eq, Ord) + data Module (s :: Stage) (t :: ModuleIsTop) = Module { _moduleKw :: KeywordRef, _modulePath :: ModulePathType s t, @@ -930,8 +935,7 @@ data Module (s :: Stage) (t :: ModuleIsTop) = Module _moduleBody :: [Statement s], _moduleKwEnd :: ModuleEndType t, _moduleInductive :: ModuleInductiveType t, - _moduleMarkdown :: Maybe Mk, - _moduleMarkdownSeparation :: Maybe [Int] + _moduleMarkdownInfo :: Maybe MarkdownInfo } deriving stock instance Show (Module 'Parsed 'ModuleTop) @@ -1925,6 +1929,7 @@ makeLenses ''NameSignature makeLenses ''RecordNameSignature makeLenses ''NameBlock makeLenses ''NameItem +makeLenses ''MarkdownInfo fixityFieldHelper :: SimpleGetter (ParsedFixityFields s) (Maybe a) -> SimpleGetter (ParsedFixityInfo s) (Maybe a) fixityFieldHelper l = to (^? fixityFields . _Just . l . _Just) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index 7e6ace73c..daa82303d 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -1305,8 +1305,7 @@ checkSections sec = do { _moduleDoc = Nothing, _modulePragmas = Nothing, _moduleInductive = True, - _moduleMarkdown = Nothing, - _moduleMarkdownSeparation = Nothing, + _moduleMarkdownInfo = Nothing, .. } where @@ -1437,8 +1436,7 @@ checkLocalModule Module {..} = do _moduleBody = moduleBody', _moduleDoc = moduleDoc', _modulePragmas = _modulePragmas, - _moduleMarkdown = Nothing, - _moduleMarkdownSeparation = Nothing, + _moduleMarkdownInfo = Nothing, _moduleKw, _moduleInductive, _moduleKwEnd diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index bfd9be513..2e388d3b1 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -14,6 +14,7 @@ import Data.Singletons import Data.Text qualified as Text import Juvix.Compiler.Backend.Markdown.Data.Types (Mk (..)) import Juvix.Compiler.Backend.Markdown.Data.Types qualified as MK +import Juvix.Compiler.Backend.Markdown.Error import Juvix.Compiler.Concrete.Data.Highlight.Input (HighlightBuilder, ignoreHighlightBuilder) import Juvix.Compiler.Concrete.Data.ParsedInfoTable import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder @@ -141,7 +142,11 @@ runModuleParser fileName input res <- P.runParserT juvixCodeBlockParser (toFilePath fileName) input case res of Left err -> return . Left . ErrMegaparsec . MegaparsecError $ err - Right r -> runMarkdownModuleParser fileName r + Right r + | MK.nullMk r -> + return . Left . ErrMarkdownBackend $ + ErrNoJuvixCodeBlocks NoJuvixCodeBlocksError {_noJuvixCodeBlocksErrorFilepath = fileName} + | otherwise -> runMarkdownModuleParser fileName r | otherwise = do m <- evalState (Nothing @ParsedPragmas) @@ -156,10 +161,16 @@ runMarkdownModuleParser :: Path Abs File -> Mk -> Sem r (Either ParserError (Module 'Parsed 'ModuleTop)) -runMarkdownModuleParser fileName mk = +runMarkdownModuleParser fpath mk = runError $ case nonEmpty (MK.extractJuvixCodeBlock mk) of - -- TODO proper error - Nothing -> error "There is no module declaration in the markdown file" + Nothing -> + throw + ( ErrMarkdownBackend $ + ErrNoJuvixCodeBlocks + NoJuvixCodeBlocksError + { _noJuvixCodeBlocksErrorFilepath = fpath + } + ) Just (firstBlock :| restBlocks) -> do m0 <- parseFirstBlock firstBlock let iniBuilder = @@ -169,8 +180,14 @@ runMarkdownModuleParser fileName mk = } res <- Input.runInputList restBlocks (execState iniBuilder parseRestBlocks) let m = - set moduleMarkdown (Just mk) - . set moduleMarkdownSeparation (Just (reverse (res ^. mdModuleBuilderBlocksLengths))) + set + moduleMarkdownInfo + ( Just + MarkdownInfo + { _markdownInfo = mk, + _markdownInfoBlockLengths = reverse (res ^. mdModuleBuilderBlocksLengths) + } + ) $ res ^. mdModuleBuilder registerModule m $> m where @@ -186,7 +203,7 @@ runMarkdownModuleParser fileName mk = getInitialParserState code = let initPos = maybe - (P.initialPos (toFilePath fileName)) + (P.initialPos (toFilePath fpath)) getInitPos (code ^. MK.juvixCodeBlockInterval) in P.State @@ -251,13 +268,13 @@ runExpressionParser :: Path Abs File -> Text -> Sem r (Either ParserError (ExpressionAtoms 'Parsed)) -runExpressionParser fileName input = do +runExpressionParser fpath input = do m <- ignoreHighlightBuilder . runParserInfoTableBuilder . evalState (Nothing @ParsedPragmas) . evalState (Nothing @(Judoc 'Parsed)) - $ P.runParserT parseExpressionAtoms (toFilePath fileName) input + $ P.runParserT parseExpressionAtoms (toFilePath fpath) input case m of (_, _, Left err) -> return (Left (ErrMegaparsec (MegaparsecError err))) (_, _, Right r) -> return (Right r) @@ -326,7 +343,7 @@ juvixCodeBlockParser = do goValidText :: ParsecS r (WithLoc Text) goValidText = do - p <- withLoc $ P.manyTill P.anySingle (P.lookAhead mdCodeToken) + p <- withLoc $ toList <$> P.some (P.notFollowedBy mdCodeToken >> P.anySingle) return $ WithLoc { _withLocInt = getLoc p, @@ -1632,8 +1649,7 @@ moduleDef = P.label "" $ do _moduleKwEnd <- endModule return Module - { _moduleMarkdown = Nothing, - _moduleMarkdownSeparation = Nothing, + { _moduleMarkdownInfo = Nothing, .. } where diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader.hs b/src/Juvix/Compiler/Pipeline/Package/Loader.hs index 8be730f68..f69d32ce4 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader.hs @@ -78,8 +78,7 @@ toConcrete t p = run . runReader l $ do _moduleInductive = (), _moduleDoc = Nothing, _modulePragmas = Nothing, - _moduleMarkdown = Nothing, - _moduleMarkdownSeparation = Nothing, + _moduleMarkdownInfo = Nothing, .. } where diff --git a/src/Juvix/Parser/Error.hs b/src/Juvix/Parser/Error.hs index bef6101cf..2cbc7153d 100644 --- a/src/Juvix/Parser/Error.hs +++ b/src/Juvix/Parser/Error.hs @@ -1,6 +1,7 @@ module Juvix.Parser.Error where import Commonmark qualified as MK +import Juvix.Compiler.Backend.Markdown.Error import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Pretty.Options (fromGenericOptions) import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error @@ -19,6 +20,7 @@ data ParserError | ErrWrongTopModuleName WrongTopModuleName | ErrStdinOrFile StdinOrFileError | ErrDanglingJudoc DanglingJudoc + | ErrMarkdownBackend MarkdownBackendError deriving stock (Show) instance ToGenericError ParserError where @@ -29,6 +31,7 @@ instance ToGenericError ParserError where ErrWrongTopModuleName e -> genericError e ErrStdinOrFile e -> genericError e ErrDanglingJudoc e -> genericError e + ErrMarkdownBackend e -> genericError e instance Pretty MegaparsecError where pretty (MegaparsecError b) = pretty (M.errorBundlePretty b) diff --git a/test/BackendMarkdown.hs b/test/BackendMarkdown.hs new file mode 100644 index 000000000..2e6f99a5f --- /dev/null +++ b/test/BackendMarkdown.hs @@ -0,0 +1,11 @@ +module BackendMarkdown + ( allTests, + ) +where + +import BackendMarkdown.Negative qualified as N +import BackendMarkdown.Positive qualified as P +import Base + +allTests :: TestTree +allTests = testGroup "BackendMarkdown tests" [P.allTests, N.allTests] diff --git a/test/BackendMarkdown/Negative.hs b/test/BackendMarkdown/Negative.hs new file mode 100644 index 000000000..c39665852 --- /dev/null +++ b/test/BackendMarkdown/Negative.hs @@ -0,0 +1,60 @@ +module BackendMarkdown.Negative where + +import Base +import Juvix.Compiler.Backend.Markdown.Error +import Juvix.Parser.Error + +type FailMsg = String + +data NegTest = NegTest + { _name :: String, + _relDir :: Path Rel Dir, + _file :: Path Rel File, + _checkErr :: ParserError -> Maybe FailMsg + } + +testDescr :: NegTest -> TestDescr +testDescr NegTest {..} = + let tRoot = root _relDir + file' = tRoot _file + in TestDescr + { _testName = _name, + _testRoot = tRoot, + _testAssertion = Single $ do + entryPoint <- defaultEntryPointCwdIO file' + result <- runIOEither entryPoint upToParsing + case mapLeft fromJuvixError result of + Left (Just err) -> whenJust (_checkErr err) assertFailure + Right _ -> assertFailure "Unexpected success." + Left Nothing -> assertFailure "Unexpected error." + } + +allTests :: TestTree +allTests = + testGroup + "Markdown negative tests" + (map (mkTest . testDescr) tests) + +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/negative") + +wrongError :: Maybe FailMsg +wrongError = Just "Incorrect error" + +tests :: [NegTest] +tests = + [ NegTest + "Empty file" + $(mkRelDir "Markdown") + $(mkRelFile "Empty.juvix.md") + $ \case + ErrMarkdownBackend (ErrNoJuvixCodeBlocks _) -> Nothing + _ -> wrongError, + NegTest + "No Juvix code blocks" + $(mkRelDir "Markdown") + $(mkRelFile "NoJuvixCodeBlocks.juvix.md") + $ \case + ErrMarkdownBackend (ErrNoJuvixCodeBlocks _) -> Nothing + _ -> wrongError + ] diff --git a/test/Markdown.hs b/test/BackendMarkdown/Positive.hs similarity index 85% rename from test/Markdown.hs rename to test/BackendMarkdown/Positive.hs index 82add07fb..9508fc789 100644 --- a/test/Markdown.hs +++ b/test/BackendMarkdown/Positive.hs @@ -1,4 +1,4 @@ -module Markdown where +module BackendMarkdown.Positive where import Base import Juvix.Compiler.Backend.Markdown.Translation.FromTyped.Source @@ -61,17 +61,19 @@ testDescr PosTest {..} = root $(mkRelDir "markdown") } - let md :: Text = fromJuvixMarkdown' opts - - step "Checking against expected output file" - expFile :: Text <- readFile (toFilePath _expectedFile) - assertEqDiffText "Compare to expected output" md expFile + let res = fromJuvixMarkdown' opts + case res of + Left err -> assertFailure (show err) + Right md -> do + step "Checking against expected output file" + expFile :: Text <- readFile (toFilePath _expectedFile) + assertEqDiffText "Compare to expected output" md expFile } allTests :: TestTree allTests = testGroup - "Format positive tests" + "Markdown positive tests" (map (mkTest . testDescr) tests) tests :: [PosTest] diff --git a/test/Main.hs b/test/Main.hs index 74153c3e9..c3391e26a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -3,6 +3,7 @@ module Main (main) where import Arity qualified import Asm qualified import BackendGeb qualified +import BackendMarkdown qualified import Base import Compilation qualified import Core qualified @@ -45,7 +46,8 @@ fastTests = Reachability.allTests, Format.allTests, Formatter.allTests, - Package.allTests + Package.allTests, + BackendMarkdown.allTests ] main :: IO () diff --git a/tests/negative/Markdown/Empty.juvix.md b/tests/negative/Markdown/Empty.juvix.md new file mode 100644 index 000000000..e69de29bb diff --git a/tests/negative/Markdown/NoJuvixCodeBlocks.juvix.md b/tests/negative/Markdown/NoJuvixCodeBlocks.juvix.md new file mode 100644 index 000000000..6bacae790 --- /dev/null +++ b/tests/negative/Markdown/NoJuvixCodeBlocks.juvix.md @@ -0,0 +1 @@ +# There is no juvix code block in this file diff --git a/tests/negative/Markdown/juvix.yaml b/tests/negative/Markdown/juvix.yaml new file mode 100644 index 000000000..e69de29bb