Add MarkdownInfo entry in Module Concrete Decl and proper errors (#2515)

Remove TODO added by @janmasrovira in 
- #2513

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

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]

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

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

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)

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

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 "<module definition>" $ do
   _moduleKwEnd <- endModule
   return
     Module
-      { _moduleMarkdown = Nothing,
-        _moduleMarkdownSeparation = Nothing,
+      { _moduleMarkdownInfo = Nothing,
         ..
       }
   where

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

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)

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]