readme-lhs 0.3.0 → 0.4.0
raw patch · 5 files changed
+208/−9 lines, 5 filesdep +attoparsecdep +blaze-htmldep +foldl
Dependencies added: attoparsec, blaze-html, foldl
Files
- other/readme-lhs.hsfiles +3/−3
- readme-lhs.cabal +7/−3
- src/Readme/Convert.hs +152/−0
- src/Readme/Lhs.hs +39/−3
- test/test.hs +7/−0
other/readme-lhs.hsfiles view
@@ -51,7 +51,7 @@ > let n = 10 > let answer = product [1..n::Integer] > void $ runOutput ("app/example.lhs", LHS) ("readme.md", GitHubMarkdown) $ do-> output "example" (show answer)+> output "example" (Fence $ show answer) 10! is equal to: @@ -251,10 +251,10 @@ main = do doctest ["app/example.lhs"] {-# START_FILE stack.yaml #-}-resolver: lts-14.11+resolver: lts-14.13 packages: - . extra-deps:- - readme-lhs-0.2.2+ - readme-lhs-0.4.0
readme-lhs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: readme-lhs-version: 0.3.0+version: 0.4.0 synopsis: See readme.md description: See readme.md for description. category: Development@@ -35,6 +35,9 @@ -Wredundant-constraints build-depends: base >=4.7 && <5+ , attoparsec+ , blaze-html+ , foldl , protolude , text , pandoc@@ -42,7 +45,8 @@ , containers , transformers exposed-modules:- Readme.Lhs+ Readme.Lhs,+ Readme.Convert other-modules: default-language: Haskell2010 @@ -70,7 +74,7 @@ default-extensions: NoImplicitPrelude UnicodeSyntax NegativeLiterals OverloadedStrings build-depends: base >=4.7 && <5+ , containers , doctest- , protolude , readme-lhs default-language: Haskell2010
+ src/Readme/Convert.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++module Readme.Convert+ ( Section (..),+ Block (..),+ Format (..),+ bird,+ normal,+ parseHs,+ printHs,+ parseLhs,+ printLhs,+ parse,+ print,+ )+where++import qualified Control.Foldl as L+import qualified Data.Attoparsec.Text as Text+import qualified Data.List as List+import qualified Data.Text as Text+import Protolude hiding (print)++data Section = Code | Comment deriving (Show, Eq)++data Block = Block Section [Text] deriving (Show, Eq)++-- starting with .lhs bird style+bird :: Text.Parser Block+bird =+ (\x -> Block Code [x]) <$> ("> " *> Text.takeText)+ <|> (\_ -> Block Code [""]) <$> (">" *> Text.takeText)+ <|> (\x -> Block Comment [x]) <$> Text.takeText++parseLhs :: [Text] -> [Block]+parseLhs text = L.fold (L.Fold step begin done) $ Text.parseOnly bird <$> text+ where+ begin = (Block Code [], [])+ done (Block _ [], out) = unlit' out+ done (block, out) = unlit' $ out <> [block]+ unlit' ss =+ ( \(Block s ts) ->+ case s of+ Comment -> Block s (unlit ts)+ Code -> Block s ts+ )+ <$> ss+ step x (Left _) = x+ step (Block s ts, out) (Right (Block s' ts')) =+ if+ | s == s' -> (Block s (ts <> ts'), out)+ | otherwise -> case ts of+ [] -> (Block s' ts, out)+ _ -> (Block s' ts', out <> [Block s ts])+ unlit [] = [""]+ unlit [""] = [""]+ unlit xs =+ if+ | (Protolude.head xs == Just "") && (Protolude.head (reverse xs) == Just "") ->+ List.init $ List.tail xs+ | (Protolude.head xs == Just "") ->+ List.tail xs+ | (Protolude.head (reverse xs) == Just "") ->+ List.init xs+ | otherwise ->+ xs++printLhs :: [Block] -> [Text]+printLhs ss =+ Protolude.mconcat $+ ( \(Block s ts) ->+ case s of+ Code -> ("> " <>) <$> ts+ Comment -> lit ts+ )+ <$> ss+ where+ lit [] = [""]+ lit [""] = [""]+ lit xs =+ (if Protolude.head xs == Just "" then [] else [""])+ <> xs+ <> (if List.last xs == "" then [] else [""])++-- coming from hs+-- normal code (.hs) is parsed where lines that are continuation of a section (neither contain clues as to whether code or comment) are output as Nothing, and the clues as to what the current and next section are is encoded as Just (current, next).+normal :: Text.Parser (Maybe (Section, Section), [Text])+normal =+ -- Nothing represents a continuation of previous section+ (\_ -> (Nothing, [""])) <$> Text.endOfInput+ <|>+ -- exact matches include line removal+ (\_ -> (Just (Comment, Comment), [])) <$> ("{-" *> Text.endOfInput)+ <|> (\_ -> (Just (Comment, Code), [])) <$> ("-}" *> Text.endOfInput)+ <|>+ -- single line braced+ (\x -> (Just (Code, Code), ["{-" <> x <> "-}"]))+ <$> ("{-" *> (Text.pack <$> Text.manyTill' Text.anyChar "-}"))+ <|>+ -- pragmas+ (\x -> (Just (Code, Code), ["{-#" <> x])) <$> ("{-#" *> Text.takeText)+ <|> (\x -> (Just (Code, Code), [x])) <$> (Text.pack <$> Text.manyTill' Text.anyChar "#-}")+ <|>+ -- braced start of multi-line comment (brace is stripped)+ (\x -> (Just (Comment, Comment), [x])) <$> ("{-" *> Text.takeText)+ <|>+ -- braced end of multi-line comment (brace is stripped)+ (\x -> (Just (Comment, Code), [x])) <$> (Text.pack <$> Text.manyTill' Text.anyChar "-}")+ <|>+ -- everything else a continuation and verbatim+ (\x -> (Nothing, [x])) <$> Text.takeText++parseHs :: [Text] -> [Block]+parseHs text = L.fold (L.Fold step begin done) $ Text.parseOnly normal <$> text+ where+ begin = (Block Code [], [])+ done (Block _ [], out) = out+ done (buff, out) = out <> [buff]+ step x (Left _) = x+ step (Block s ts, out) (Right (Just (this, next), ts')) =+ if+ | ts <> ts' == [] -> (Block next [], out)+ | this == s && next == s -> (Block s (ts <> ts'), out)+ | this /= s -> (Block this ts', out <> [Block s ts])+ | otherwise -> (Block next [], out <> [Block s (ts <> ts')])+ step (Block s ts, out) (Right (Nothing, ts')) =+ if+ | ts <> ts' == [] -> (Block s [], out)+ | otherwise -> (Block s (ts <> ts'), out)++printHs :: [Block] -> [Text]+printHs ss =+ Protolude.mconcat $+ ( \(Block s ts) ->+ case s of+ Code -> ts+ Comment -> ["{-"] <> ts <> ["-}"]+ )+ <$> ss++-- just in case there are ever other formats (YAML haskell anyone?)+data Format = Lhs | Hs++print :: Format -> [Block] -> [Text]+print Lhs f = printLhs f+print Hs f = printHs f++parse :: Format -> [Text] -> [Block]+parse Lhs f = parseLhs f+parse Hs f = parseHs f
src/Readme/Lhs.hs view
@@ -9,14 +9,17 @@ table', code, link,+ linkTooltip, badge, image, Flavour (..), readPandoc, renderMarkdown,+ renderHtml, Output (..), OutputMap, output,+ insertOutput, runOutput, tweakHaskellCodeBlock, Block (..),@@ -31,10 +34,12 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.Text as Text+import Data.Text.Lazy (toStrict) import qualified Data.Text.IO as Text import Text.Pandoc import Text.Pandoc.Definition import Prelude+import qualified Text.Blaze.Html.Renderer.Text as Blaze -- | output can be native pandoc, or text that replaces or inserts into the output code block. data Output = Native [Block] | Replace Text | Fence Text@@ -68,6 +73,12 @@ link :: Text -> Text -> Inline link name url = Link ("", [], []) [Str (Text.unpack name)] (Text.unpack url, "") +-- | create a link+-- >>> linkTooltip "test" "link" "tooltip"+-- Link ("",[],[]) [Str "test"] ("link","tooltip")+linkTooltip :: Text -> Text -> Text -> Inline+linkTooltip name url tooltip = Link ("", [], []) [Str (Text.unpack name)] (Text.unpack url, Text.unpack tooltip)+ -- | create an image link -- >>> image "test" "imagelink.svg" -- Image ("",[],[]) [Str "test"] ("imagelink.svg","")@@ -113,7 +124,7 @@ -- | use LHS when you want to just add output to a *.lhs -- | use GitHubMarkdown for rendering code and results on github-data Flavour = GitHubMarkdown | LHS+data Flavour = GitHubMarkdown | LHS | Html -- | exts LHS is equivalent to 'markdown+lhs' -- exts GitHubMarkdown is equivalent to 'gfm'@@ -123,6 +134,7 @@ enableExtension Ext_fenced_code_attributes githubMarkdownExtensions+exts Html = getDefaultExtensions "html" -- | -- literate haskell code blocks comes out of markdown+lhs to native pandoc with the following classes:@@ -147,6 +159,8 @@ runIO $ readMarkdown (def :: ReaderOptions) {readerExtensions = exts f} (Text.pack t) -- | render a pandoc AST+-- >>> renderMarkdown GitHubMarkdown (Pandoc mempty [Table [] [] [] [] [[[Para [Str "1"]],[Para [Str "2"]]]]])+-- Right "| | |\n|-----|-----|\n| 1 | 2 |" renderMarkdown :: Flavour -> Pandoc -> Either PandocError Text renderMarkdown f (Pandoc meta bs) = runPure $@@ -154,6 +168,21 @@ (def :: WriterOptions) {writerExtensions = exts f} (Pandoc meta (tweakHaskellCodeBlock <$> bs)) +-- Blaze.renderHtml <$> (runPure $ writeHtml5 (def {writerExtensions = enableExtension Ext_multiline_tables (getDefaultExtensions "html")}) (Pandoc mempty [Table [Str "test"] [AlignLeft,AlignLeft] [0.0,0.0] [[Plain [Str "first",Space,Str "column"]],[Plain [Str "second",Space,Str "column"]]] [[[Plain [Str "1"]] ,[Plain [Str "2"]]] ,[[Plain [Str "3"]] ,[Plain [Str "4"]]]]]++-- | render a pandoc AST to Html+-- Note that text align for a Table cannot be blank when rendering to html+-- >>> Blaze.renderHtml <$> (runPure $ writeHtml5 (def {writerExtensions = (getDefaultExtensions "html")}) (Pandoc mempty [Table [] [AlignLeft,AlignLeft] [] [] [[[Plain [Str "1"]] ,[Plain [Str "2"]]]]]))+-- Right "<table>\n<tbody>\n<tr class=\"odd\">\n<td style=\"text-align: left;\">1</td>\n<td style=\"text-align: left;\">2</td>\n</tr>\n</tbody>\n</table>"+--+renderHtml :: Flavour -> Pandoc -> Either PandocError Text+renderHtml f (Pandoc meta bs) =+ runPure $ do+ h <- writeHtml5+ (def :: WriterOptions) {writerExtensions = exts f}+ (Pandoc meta (tweakHaskellCodeBlock <$> bs))+ pure $ toStrict $ Blaze.renderHtml h+ insertOutput :: OutputMap -> Block -> [Block] insertOutput m b = case b of b'@(CodeBlock (id', classes, kv) _) ->@@ -179,6 +208,10 @@ headMaybe [] = Nothing headMaybe (x : _) = Just x +insertOutputs :: OutputMap -> Pandoc -> Pandoc+insertOutputs out (Pandoc meta bs) =+ Pandoc meta (mconcat $ insertOutput out <$> bs)+ -- | add an output key-value pair to state output :: (Monad m) => Text -> Output -> StateT OutputMap m () output k v = modify (Map.insert k v)@@ -193,6 +226,9 @@ m <- execStateT out Map.empty p <- readPandoc fi flavi let w = do- p' <- fmap (\(Pandoc meta bs) -> Pandoc meta (mconcat $ insertOutput m <$> bs)) p- renderMarkdown flavo p'+ p' <- insertOutputs m <$> p+ case flavo of+ Html -> renderHtml flavo p'+ _ -> renderMarkdown flavo p' either (pure . Left) (\t -> Text.writeFile fo t >> pure (Right ())) w+
test/test.hs view
@@ -6,6 +6,7 @@ import Prelude import Test.DocTest import Readme.Lhs+import qualified Data.Map as Map -- | doctest -- >>> :set -XOverloadedStrings@@ -16,6 +17,12 @@ -- Right (Pandoc (Meta {unMeta = fromList []}) [Para [Str "haskell",Space,Str "LHS",Space,Str "style"],CodeBlock ("",["sourceCode","literate","haskell"],[]) "",Para [Str "bird-tracks"],BlockQuote [Para [Str "import",Space,Str "Readme.Lhs"]],Para [Str "code",Space,Str "block"],CodeBlock ("",[],[]) "indented\nunfenced code",Para [Str "github-style",Space,Str "fenced",Space,Str "code",Space,Str "blocks"],CodeBlock ("",["haskell"],[]) "",Para [Code ("",[],[]) "output test1"],Para [Str "php-style",Space,Str "fenced",Space,Str "code",Space,Str "blocks"],CodeBlock ("",["output","test1"],[]) ""]) -- >>> readPandoc "test/test.md" LHS -- Right (Pandoc (Meta {unMeta = fromList []}) [Para [Str "haskell",Space,Str "LHS",Space,Str "style"],CodeBlock ("",["sourceCode","literate","haskell"],[]) "",Para [Str "bird-tracks"],CodeBlock ("",["haskell","literate"],[]) "import Readme.Lhs",Para [Str "code",Space,Str "block"],CodeBlock ("",[],[]) "indented\nunfenced code",Para [Str "github-style",Space,Str "fenced",Space,Str "code",Space,Str "blocks"],CodeBlock ("",["haskell"],[]) "",Para [Code ("",[],[]) "output test1"],Para [Str "php-style",Space,Str "fenced",Space,Str "code",Space,Str "blocks"],CodeBlock ("",["output","test1"],[]) ""])+--+-- >>> (Right (Pandoc _ bs)) <- readPandoc "test/test.md" GitHubMarkdown+-- >>> let p' = Pandoc mempty (mconcat $ insertOutput (Map.fromList [("test1", Replace "inserted text")]) <$> bs)+-- >>> renderHtml Html p'+-- Right "<p>haskell LHS style</p>\n<div class=\"sourceCode\" id=\"cb1\"><pre class=\"sourceCode haskell\"><code class=\"sourceCode haskell\"></code></pre></div>\n<p>bird-tracks</p>\n<blockquote>\n<p>import Readme.Lhs</p>\n</blockquote>\n<p>code block</p>\n<pre><code>indented\nunfenced code</code></pre>\n<p>github-style fenced code blocks</p>\n<div class=\"sourceCode\" id=\"cb3\"><pre class=\"sourceCode haskell\"><code class=\"sourceCode haskell\"></code></pre></div>\n<p><code>output test1</code></p>\n<p>php-style fenced code blocks</p>\ninserted text"+ main :: IO () main =