diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for scripths +## 0.2.0.0 -- 2026-03-01 + +* Add mime type to output. + +* Make blocks out of single lines of code as well. + ## 0.1.0.2 -- 2026-02-28 * Make blocks out of single lines of code as well. diff --git a/scripths.cabal b/scripths.cabal --- a/scripths.cabal +++ b/scripths.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: scripths -version: 0.1.0.2 +version: 0.2.0.0 synopsis: GHCi scripts for standalone execution and Markdown documentation. description: GHCi scripts for standalone execution (with dependency resolution) and Markdown documentation (produces inline output). homepage: https://www.datahaskell.org/ diff --git a/src/ScriptHs/Markdown.hs b/src/ScriptHs/Markdown.hs --- a/src/ScriptHs/Markdown.hs +++ b/src/ScriptHs/Markdown.hs @@ -2,14 +2,28 @@ Segment (..), parseMarkdown, reassemble, + MimeType (..), + CodeOutput (..), ) where import Data.Text (Text) import qualified Data.Text as T +data MimeType + = MimeHtml + | MimeMarkdown + | MimeSvg + | MimeLatex + | MimeJson + | MimeImage Text -- image type + | MimePlain + deriving (Show, Eq) + +data CodeOutput = CodeOutput MimeType Text deriving (Show, Eq) + data Segment = Prose Text - | CodeBlock Text Text (Maybe Text) + | CodeBlock Text Text (Maybe CodeOutput) -- Language, Code, Output deriving (Show, Eq) parseMarkdown :: Text -> [Segment] @@ -25,11 +39,24 @@ let prose = T.unlines acc (codeLines, rest') = fmap (drop 1) (break ((== fence) . T.strip) rest) + (output, rest'') = case (dropWhile ((== "") . T.strip) rest') of + (x : xs) -> + if not (T.isPrefixOf "> "] ++ T.lines t trimmed = reverse $ dropWhile T.null $ reverse ls - quoted = T.unlines $ map (\l -> if T.null l then ">" else "> " <> l) trimmed + quoted = T.unlines $ map (\l -> if T.null l then "> " else "> " <> l) trimmed in quoted <> "\n" + +mimeIndicator :: MimeType -> Text +mimeIndicator m = case m of + MimeHtml -> "text/html" + MimeMarkdown -> "text/markdown" + MimeSvg -> "image/svg+xml" + MimeLatex -> "text/latex" + MimeJson -> "application/json" + MimeImage t -> t <> ";base64" + MimePlain -> "text/plain" + +mimeFromTag :: Text -> MimeType +mimeFromTag t + | T.isInfixOf "text/html" t = MimeHtml + | T.isInfixOf "text/markdown" t = MimeMarkdown + | T.isInfixOf "image/svg+html" t = MimeSvg + | T.isInfixOf "text/latex" t = MimeLatex + | T.isInfixOf "application/json" t = MimeJson + | T.isInfixOf "base64" t = + MimeImage (T.takeWhile (/= ';') (T.drop (T.length "" + , "> 2" + , "" + , "Some text after." + ] + let segs = parseMarkdown input + length segs @?= 2 + case segs of + [(CodeBlock _ _ (Just (CodeOutput m _))), Prose _] -> assertBool "mime is latex" (m == MimeLatex) + other -> assertFailure $ "expected [CodeBlock, Prose], got: " ++ show other , testCase "multiple code blocks" $ do let input = T.unlines @@ -81,15 +100,26 @@ , "print 1" , "```" , "" + , "> " + , "> 1" + , "" , "Middle text." , "" , "```haskell" , "print 2" , "```" + , "" + , "> " + , "> 2" ] let segs = parseMarkdown input let codeBlocks = [c | c@(CodeBlock{}) <- segs] + let outputBlocks = [o | (CodeBlock _ _ o@(Just _)) <- segs] length codeBlocks @?= 2 + length outputBlocks @?= 2 + assertBool + "all mimeType plain" + (all (== MimePlain) [m | (Just (CodeOutput m _)) <- outputBlocks]) , testCase "non-haskell code block preserved" $ do let input = T.unlines @@ -142,26 +172,22 @@ assertBool "has code" (T.isInfixOf "print 42" result) assertBool "no blockquote" (not $ T.isInfixOf "> " result) , testCase "code block with output" $ do - let result = reassemble [CodeBlock "haskell" "print 42\n" (Just "42")] + let result = + reassemble [CodeBlock "haskell" "print 42\n" (Just $ CodeOutput MimePlain "42")] assertBool "has fence" (T.isInfixOf "```haskell" result) assertBool "has code" (T.isInfixOf "print 42" result) assertBool "has blockquote" (T.isInfixOf "> 42" result) , testCase "code block with multi-line output" $ do - let result = reassemble [CodeBlock "hs" "print [1,2]\n" (Just "1\n2")] + let result = + reassemble [CodeBlock "hs" "print [1,2]\n" (Just $ CodeOutput MimePlain "1\n2")] assertBool "has > 1" (T.isInfixOf "> 1" result) assertBool "has > 2" (T.isInfixOf "> 2" result) - , testCase "empty output is omitted" $ do - let result = reassemble [CodeBlock "haskell" "import X\n" (Just "")] - assertBool "no blockquote" (not $ T.isInfixOf "> " result) - , testCase "whitespace-only output is omitted" $ do - let result = reassemble [CodeBlock "haskell" "import X\n" (Just " \n \n")] - assertBool "no blockquote" (not $ T.isInfixOf "> " result) , testCase "full document roundtrip" $ do let segs = [ Prose "# Title\n\n" - , CodeBlock "haskell" "print 42\n" (Just "42") + , CodeBlock "haskell" "print 42\n" (Just $ CodeOutput MimePlain "42") , Prose "\nSome text.\n" - , CodeBlock "haskell" "print 99\n" (Just "99") + , CodeBlock "haskell" "print 99\n" (Just $ CodeOutput MimePlain "99") ] let result = reassemble segs @@ -181,11 +207,11 @@ , testGroup "blockquote" [ testCase "single line" $ do - let result = reassemble [CodeBlock "hs" "x\n" (Just "hello")] + let result = reassemble [CodeBlock "hs" "x\n" (Just $ CodeOutput MimePlain "hello")] assertBool "blockquoted" (T.isInfixOf "> hello" result) , testCase "empty lines in output get bare >" $ do - let result = reassemble [CodeBlock "hs" "x\n" (Just "a\n\nb")] - assertBool "has bare >" (T.isInfixOf "\n>\n" result) + let result = reassemble [CodeBlock "hs" "x\n" (Just $ CodeOutput MimePlain "a\n\nb")] + assertBool "has bare >" (T.isInfixOf "\n> \n" result) ] ] diff --git a/test/Test/Notebook.hs b/test/Test/Notebook.hs --- a/test/Test/Notebook.hs +++ b/test/Test/Notebook.hs @@ -5,7 +5,7 @@ import qualified Data.Text as T -import ScriptHs.Markdown (Segment (..)) +import ScriptHs.Markdown (CodeOutput (..), MimeType (..), Segment (..)) import ScriptHs.Notebook ( addOutputToSegments, generatedMarkedScript, @@ -110,7 +110,13 @@ [ (0, Prose "intro\n") , (1, CodeBlock "haskell" "print 1\n" Nothing) , (2, CodeBlock "python" "print('x')\n" Nothing) - , (3, CodeBlock "hs" "print 3\n" (Just "old-should-be-replaced")) + , + ( 3 + , CodeBlock + "hs" + "print 3\n" + (Just $ CodeOutput MimePlain "old-should-be-replaced") + ) , (4, Prose "outro\n") ] @@ -121,8 +127,9 @@ head result @?= Prose "intro\n" result !! 4 @?= Prose "outro\n" - result !! 1 @?= CodeBlock "haskell" "print 1\n" (Just "out-1") - result !! 3 @?= CodeBlock "hs" "print 3\n" (Just "out-3") + result !! 1 + @?= CodeBlock "haskell" "print 1\n" (Just $ CodeOutput MimePlain "out-1") + result !! 3 @?= CodeBlock "hs" "print 3\n" (Just $ CodeOutput MimePlain "out-3") result !! 2 @?= CodeBlock "python" "print('x')\n" Nothing ]