Support extract-module-statements attribute in juvix code blocks (#…

…2734)

This PR adds support for the `extract-module-statements` attribute for
Juvix code blocks:

So if you write something like the following block in a Juvix markdown
file:

````
```juvix extract-module-statements
module Foo;
   type T := t;
end;
```
````

The statement `type T := t;` from the body of the module is rendered in
the output. The `module Foo;` , and `end;` lines are not rendered in the
output.

A block with the `extract-module-statements` must contain a single local
module statement and nothing else. An error is reported if this is not
the case.

The `extract-module-statements` attribute also takes an optional
argument. It sets the number of statements from the module body to drop
from the output.

In the following example, the output will contain the single line `a : T
:= t;`.

````
```juvix extract-module-statements 1
module Foo;
   type T := t;
   a : T  := t;
end;
```
````

---------

Co-authored-by: Jan Mas Rovira <janmasrovira@gmail.com>

src/Juvix/Compiler/Backend/Markdown/Data/MkJuvixBlockOptions.hs

@@ -0,0 +1,66 @@
+module Juvix.Compiler.Backend.Markdown.Data.MkJuvixBlockOptions where
+
+import Juvix.Parser.Error.Base
+import Juvix.Prelude.Base
+import Juvix.Prelude.Parsing hiding (runParser)
+import Juvix.Prelude.Path
+import Text.Megaparsec qualified as P
+import Text.Megaparsec.Char.Lexer qualified as L
+
+data MkJuvixBlockOptions
+  = MkJuvixBlockOptionsHide
+  | MkJuvixBlockOptionsShow
+  | MkJuvixBlockOptionsExtractModule JuvixBlockOptionsExtractModule
+  deriving stock (Eq, Show)
+
+newtype JuvixBlockOptionsExtractModule = JuvixBlockOptionsExtractModule
+  { _juvixBlockOptionsExtractModuleDrop :: Int
+  }
+  deriving stock (Eq, Show)
+
+makeLenses ''JuvixBlockOptionsExtractModule
+
+optionExtractModuleStatements :: (IsString s) => s
+optionExtractModuleStatements = "extract-module-statements"
+
+optionHide :: (IsString s) => s
+optionHide = "hide"
+
+parseJuvixBlockOptions :: Path Abs File -> Text -> Either MegaparsecError MkJuvixBlockOptions
+parseJuvixBlockOptions p = mapLeft MegaparsecError . P.runParser parseOptions (toFilePath p)
+
+type Parser = P.Parsec Void Text
+
+spaceConsumer :: Parser ()
+spaceConsumer = L.space space1 empty empty
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme spaceConsumer
+
+symbol :: Text -> Parser ()
+symbol = void . L.symbol spaceConsumer
+
+decimal :: Parser Int
+decimal = lexeme L.decimal
+
+parseOptions :: Parser MkJuvixBlockOptions
+parseOptions = do
+  spaceConsumer
+  opts <-
+    parseHide
+      <|> parseExtractModule
+      <|> parseShow
+  eof
+  return opts
+
+parseShow :: Parser MkJuvixBlockOptions
+parseShow = return MkJuvixBlockOptionsShow
+
+parseHide :: Parser MkJuvixBlockOptions
+parseHide = symbol optionHide $> MkJuvixBlockOptionsHide
+
+parseExtractModule :: Parser MkJuvixBlockOptions
+parseExtractModule = do
+  symbol optionExtractModuleStatements
+  dropNum <- fromMaybe 0 <$> optional decimal
+  return (MkJuvixBlockOptionsExtractModule (JuvixBlockOptionsExtractModule dropNum))

src/Juvix/Compiler/Backend/Markdown/Data/Types.hs

@@ -1,20 +1,20 @@
-module Juvix.Compiler.Backend.Markdown.Data.Types where
+module Juvix.Compiler.Backend.Markdown.Data.Types
+  ( module Juvix.Compiler.Backend.Markdown.Data.Types,
+    module Juvix.Compiler.Backend.Markdown.Data.MkJuvixBlockOptions,
+  )
+where
 
 import Commonmark qualified as MK
 import Data.Text qualified as T
+import Juvix.Compiler.Backend.Markdown.Data.MkJuvixBlockOptions
 import Juvix.Data.Loc
 import Juvix.Prelude hiding (Raw)
 import Juvix.Prelude.Pretty
 import Text.Show qualified as Show
 
-newtype MkJuvixBlockOptions = MkJuvixBlockOptions
-  { _mkJuvixBlockOptionsHide :: Bool
-  }
-  deriving stock (Eq, Ord)
-
 data JuvixCodeBlock = JuvixCodeBlock
   { _juvixCodeBlock :: Text,
-    _juvixCodeBlockOptions :: MkJuvixBlockOptions,
+    _juvixCodeBlockOptions :: Text,
     _juvixCodeBlockInterval :: Maybe Interval
   }
   deriving stock (Eq, Ord)
@@ -26,33 +26,16 @@ data TextBlock = TextBlock
   deriving stock (Eq, Ord)
 
 makeLenses ''JuvixCodeBlock
-makeLenses ''MkJuvixBlockOptions
 makeLenses ''TextBlock
 
-defaultMkJuvixBlockOptions :: MkJuvixBlockOptions
-defaultMkJuvixBlockOptions =
-  MkJuvixBlockOptions
-    { _mkJuvixBlockOptionsHide = False
-    }
-
 instance Show TextBlock where
   show t = T.unpack (t ^. textBlock)
 
-textJuvixBlockOptions :: MkJuvixBlockOptions -> Text
-textJuvixBlockOptions opt =
-  T.intercalate " " $
-    catMaybes
-      [ if opt ^. mkJuvixBlockOptionsHide then Just "hide" else Nothing
-      ]
-
-instance Show MkJuvixBlockOptions where
-  show opt = T.unpack (textJuvixBlockOptions opt)
-
 textJuvixCodeBlock :: JuvixCodeBlock -> Text
 textJuvixCodeBlock cb =
   mconcat
     [ "```juvix",
-      textJuvixBlockOptions (cb ^. juvixCodeBlockOptions),
+      cb ^. juvixCodeBlockOptions,
       nl,
       cb ^. juvixCodeBlock,
       "```"
@@ -83,19 +66,6 @@ instance Monoid TextBlock where
       }
   mappend = (<>)
 
-instance Semigroup MkJuvixBlockOptions where
-  a <> b =
-    MkJuvixBlockOptions
-      { _mkJuvixBlockOptionsHide = a ^. mkJuvixBlockOptionsHide || b ^. mkJuvixBlockOptionsHide
-      }
-
-instance Monoid MkJuvixBlockOptions where
-  mempty =
-    MkJuvixBlockOptions
-      { _mkJuvixBlockOptionsHide = False
-      }
-  mappend = (<>)
-
 instance Semigroup Mk where
   a <> MkNull = a
   MkNull <> a = a
@@ -190,25 +160,20 @@ instance MK.IsInline TextBlock where
         toTextBlock t
     | otherwise = mempty
 
-getJuvixBlockOptions :: Text -> MkJuvixBlockOptions
-getJuvixBlockOptions = \case
-  "hide" -> mempty {_mkJuvixBlockOptionsHide = True}
-  _ -> mempty
-
 nl' :: Mk
 nl' = toMK nl
 
 processCodeBlock :: Text -> Text -> Maybe Interval -> Mk
 processCodeBlock info t loc =
-  case T.splitOn " " (T.strip info) of
-    ("juvix" : opts) ->
+  case T.stripPrefix "juvix" (T.strip info) of
+    Just opts ->
       MkJuvixCodeBlock
         JuvixCodeBlock
           { _juvixCodeBlock = t,
-            _juvixCodeBlockOptions = foldMap getJuvixBlockOptions opts,
+            _juvixCodeBlockOptions = opts,
             _juvixCodeBlockInterval = loc
           }
-    _ ->
+    Nothing ->
       let b = "```" <> info <> t <> "```"
        in MkTextBlock TextBlock {_textBlock = b, _textBlockInterval = loc}
 

src/Juvix/Compiler/Backend/Markdown/Error.hs

@@ -1,18 +1,24 @@
 module Juvix.Compiler.Backend.Markdown.Error where
 
+import Juvix.Compiler.Backend.Markdown.Data.Types
 import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error.Pretty
+import Juvix.Parser.Error.Base
 import Juvix.Prelude
 
 data MarkdownBackendError
   = ErrInternalNoMarkdownInfo NoMarkdownInfoError
   | ErrNoJuvixCodeBlocks NoJuvixCodeBlocksError
+  | ErrInvalidExtractModuleBlock InvalidExtractModuleBlockError
+  | ErrInvalidCodeBlockAttribtues InvalidCodeBlockAttributesError
   deriving stock (Show)
 
 instance ToGenericError MarkdownBackendError where
   genericError = \case
     ErrInternalNoMarkdownInfo e -> genericError e
     ErrNoJuvixCodeBlocks e -> genericError e
+    ErrInvalidExtractModuleBlock e -> genericError e
+    ErrInvalidCodeBlockAttribtues e -> genericError e
 
 newtype NoMarkdownInfoError = NoMarkdownInfoError
   { _noMarkdownInfoFilepath :: Path Abs File
@@ -49,3 +55,35 @@ instance ToGenericError NoJuvixCodeBlocksError where
     where
       i :: Interval
       i = singletonInterval . mkInitialLoc $ _noJuvixCodeBlocksErrorFilepath
+
+data InvalidExtractModuleBlockError = InvalidExtractModuleBlockError
+  { _invalidExtractModuleBlockErrorInterval :: Maybe Interval,
+    _invalidExtractModuleBlockErrorPath :: Path Abs File
+  }
+  deriving stock (Show)
+
+instance ToGenericError InvalidExtractModuleBlockError where
+  genericError InvalidExtractModuleBlockError {..} = do
+    let msg :: Doc Ann
+        msg = "Juvix code blocks with attribute" <+> optionExtractModuleStatements <+> "must contain a single local module"
+    return
+      GenericError
+        { _genericErrorLoc = i,
+          _genericErrorMessage = prettyError msg,
+          _genericErrorIntervals = [i]
+        }
+    where
+      i :: Interval
+      i =
+        fromMaybe
+          (singletonInterval (mkInitialLoc (_invalidExtractModuleBlockErrorPath)))
+          _invalidExtractModuleBlockErrorInterval
+
+newtype InvalidCodeBlockAttributesError = InvalidCodeBlockAttributesError
+  { _invalidCodeBlockAttributesErrorMegaparsecError :: MegaparsecError
+  }
+  deriving stock (Show)
+
+instance ToGenericError InvalidCodeBlockAttributesError where
+  genericError InvalidCodeBlockAttributesError {..} =
+    genericError _invalidCodeBlockAttributesErrorMegaparsecError

src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs

@@ -86,7 +86,7 @@ fromJuvixMarkdown opts = do
                 _processingStateStmtsSeparation = sepr,
                 _processingStateStmts = indModuleFilter $ m ^. Concrete.moduleBody
               }
-      (_, r) <- runState st . runReader htmlOptions . runReader opts $ go
+      (_, r) <- runState st . runReader htmlOptions . runReader opts $ go fname
       return $ MK.toPlainText r
     Nothing ->
       throw
@@ -104,34 +104,49 @@ go ::
   ( Members
       '[ Reader HtmlRender.HtmlOptions,
          Reader ProcessJuvixBlocksArgs,
-         State ProcessingState
+         State ProcessingState,
+         Error MarkdownBackendError
        ]
       r
   ) =>
+  Path Abs File ->
   Sem r Mk
-go = do
+go fname = do
   stmts <- gets @ProcessingState (^. processingStateStmts)
   sepr <- gets @ProcessingState (^. processingStateStmtsSeparation)
   mk <- gets @ProcessingState (^. processingStateMk)
-  case (sepr, stmts) of
-    ([], _) -> return mk
-    ((n : ns), _) -> do
+  case sepr of
+    [] -> return mk
+    (n : ns) -> do
       case mk of
         MkNull -> return mk
         MkTextBlock _ -> return mk
         MkConcat l r -> do
           modify (set processingStateMk l)
-          lS <- go
+          lS <- go fname
           modify (set processingStateMk r)
-          MkConcat lS <$> go
+          MkConcat lS <$> go fname
         MkJuvixCodeBlock j -> do
+          opts <- case parseJuvixBlockOptions fname (j ^. juvixCodeBlockOptions) of
+            Left e ->
+              throw
+                ( ErrInvalidCodeBlockAttribtues
+                    (InvalidCodeBlockAttributesError e)
+                )
+            Right o -> return o
+
           m <-
             asks @ProcessJuvixBlocksArgs
               (^. processJuvixBlocksArgsModule)
 
           isFirstBlock <- gets @ProcessingState (^. processingStateFirstBlock)
 
-          let stmts' = take n stmts
+          stmts' <-
+            let blockStmts = take n stmts
+             in case opts of
+                  MkJuvixBlockOptionsExtractModule o ->
+                    checkExtractModule j (o ^. juvixBlockOptionsExtractModuleDrop) blockStmts
+                  _ -> return blockStmts
 
           htmlStatements :: [Html] <-
             mapM (\s -> goRender s <> pure htmlSemicolon) stmts'
@@ -153,15 +168,14 @@ go = do
                         Text.intercalate "\n\n" $
                           map (toStrict . Html.renderHtml) htmlStatements
 
-          let _processingStateMk =
-                if j ^. juvixCodeBlockOptions . mkJuvixBlockOptionsHide
-                  then MkNull
-                  else
-                    MkTextBlock
-                      TextBlock
-                        { _textBlock = Text.replace "\n" "<br/>" resHtml,
-                          _textBlockInterval = j ^. juvixCodeBlockInterval
-                        }
+          let _processingStateMk = case opts of
+                MkJuvixBlockOptionsHide -> MkNull
+                _ ->
+                  MkTextBlock
+                    TextBlock
+                      { _textBlock = Text.replace "\n" "<br/>" resHtml,
+                        _textBlockInterval = j ^. juvixCodeBlockInterval
+                      }
           let newState =
                 ProcessingState
                   { _processingStateFirstBlock = False,
@@ -171,6 +185,20 @@ go = do
                   }
           modify @ProcessingState $ const newState
           return _processingStateMk
+      where
+        checkExtractModule :: JuvixCodeBlock -> Int -> [Concrete.Statement 'Concrete.Scoped] -> Sem r [Concrete.Statement 'Concrete.Scoped]
+        checkExtractModule j dropNum xs = case xs of
+          [Concrete.StatementModule m] -> do
+            return (drop dropNum (indModuleFilter (m ^. Concrete.moduleBody)))
+          _ ->
+            throw
+              ( ErrInvalidExtractModuleBlock
+                  ( InvalidExtractModuleBlockError
+                      { _invalidExtractModuleBlockErrorPath = fname,
+                        _invalidExtractModuleBlockErrorInterval = j ^. juvixCodeBlockInterval
+                      }
+                  )
+              )
 
 goRender ::
   (Concrete.PrettyPrint c, Members '[Reader HtmlRender.HtmlOptions, Reader ProcessJuvixBlocksArgs] r) =>