Support extract-module-statements attribute in juvix code blocks

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) =>