packages feed

readme-lhs 0.2.2 → 0.3.0

raw patch · 3 files changed

+120/−72 lines, 3 filesdep +transformers

Dependencies added: transformers

Files

readme-lhs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name:           readme-lhs-version:        0.2.2+version:        0.3.0 synopsis:       See readme.md description:    See readme.md for description. category:       Development@@ -40,6 +40,7 @@     , pandoc     , pandoc-types     , containers+    , transformers   exposed-modules:     Readme.Lhs   other-modules:
src/Readme/Lhs.hs view
@@ -1,30 +1,40 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}  module Readme.Lhs-  ( para-  , plain-  , table-  , code-  , Flavour(..)-  , readPandoc-  , renderMarkdown-  , Output(..)-  , OutputMap-  , output-  , runOutput-  , tweakHaskellCodeBlock-  , Block(..)-  , module Text.Pandoc.Definition-  , Alignment(..)-  ) where+  ( para,+    plain,+    table,+    table',+    code,+    link,+    badge,+    image,+    Flavour (..),+    readPandoc,+    renderMarkdown,+    Output (..),+    OutputMap,+    output,+    runOutput,+    tweakHaskellCodeBlock,+    Block (..),+    module Text.Pandoc.Definition,+    Alignment (..),+  )+where -import Protolude+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Lazy+import Data.Bool+import qualified Data.Map as Map+import Data.Map (Map) import Data.Text as Text-import Text.Pandoc.Definition-import Text.Pandoc.Options+import qualified Data.Text.IO as Text import Text.Pandoc-import qualified Data.Map as Map+import Text.Pandoc.Definition+import Prelude  -- | output can be native pandoc, or text that replaces or inserts into the output code block. data Output = Native [Block] | Replace Text | Fence Text@@ -52,18 +62,48 @@ inline :: Text -> [Inline] inline = fmap (Str . Text.unpack) . Text.lines --- | table caption headers alignments widths rows+-- | create a link+-- >>> link "test" "link"+-- Link ("",[],[]) [Str "test"] ("link","")+link :: Text -> Text -> Inline+link name url = Link ("", [], []) [Str (Text.unpack name)] (Text.unpack url, "")++-- | create an image link+-- >>> image "test" "imagelink.svg"+-- Image ("",[],[]) [Str "test"] ("imagelink.svg","")+image :: Text -> Text -> Inline+image name url = Image ("", [], []) [Str (Text.unpack name)] (Text.unpack url, "")++-- | create a badge link+-- >>> badge "Build Status" "https://travis-ci.org/tonyday567/readme-lhs.svg" "https://travis-ci.org/tonyday567/readme-lhs"+-- Link ("",[],[]) [Image ("",[],[]) [Str "Build Status"] ("https://travis-ci.org/tonyday567/readme-lhs.svg","")] ("https://travis-ci.org/tonyday567/readme-lhs","")+badge :: Text -> Text -> Text -> Inline+badge label badge' url = Link ("", [], []) [Image ("", [], []) [Str (Text.unpack label)] (Text.unpack badge', "")] (Text.unpack url, "")++-- | create a table from text -- >>> table "an example table" ["first column", "second column"] [AlignLeft, AlignRight] [0,0] [["first row", "1"], ["second row", "1000"]] -- Table [Str "an example table"] [AlignLeft,AlignRight] [0.0,0.0] [[Para [Str "first column"]],[Para [Str "second column"]]] [[[Para [Str "first row"]],[Para [Str "1"]]],[[Para [Str "second row"]],[Para [Str "1000"]]]] table :: Text -> [Text] -> [Alignment] -> [Int] -> [[Text]] -> Block table caption hs as ws rs =-      Table-      (inline caption)-      as-      (fromIntegral <$> ws)-      ((:[]) . para <$> hs)-      (fmap ((:[]) . para) <$> rs)+  Table+    (inline caption)+    as+    (fromIntegral <$> ws)+    ((: []) . para <$> hs)+    (fmap ((: []) . para) <$> rs) +-- | create a table from inlines+-- >>> table' "an example table" [Str "first column", Str "second column"] [AlignLeft, AlignRight] [0,0] [[Str "first row", Str "1"], [Str "second row", Str "1000"]]+-- Table [Str "an example table"] [AlignLeft,AlignRight] [0.0,0.0] [[Para [Str "first column"]],[Para [Str "second column"]]] [[[Para [Str "first row"]],[Para [Str "1"]]],[[Para [Str "second row"]],[Para [Str "1000"]]]]+table' :: Text -> [Inline] -> [Alignment] -> [Int] -> [[Inline]] -> Block+table' caption hs as ws rs =+  Table+    (inline caption)+    as+    (fromIntegral <$> ws)+    ((: []) . Para . (: []) <$> hs)+    (fmap ((: []) . Para . (: [])) <$> rs)+ -- | code identifier classes text -- >>> code "name" ["sourceCode", "literate", "haskell"] "x = 1\n" -- CodeBlock ("name",["sourceCode","literate","haskell"],[]) "x = 1\n"@@ -80,72 +120,79 @@ exts :: Flavour -> Extensions exts LHS = enableExtension Ext_literate_haskell $ getDefaultExtensions "markdown" exts GitHubMarkdown =-  enableExtension Ext_fenced_code_attributes-  githubMarkdownExtensions--{- |-literate haskell code blocks comes out of markdown+lhs to native pandoc with the following classes:--["sourceCode","literate","haskell"]--  and then conversion to github flavour gives:--``` sourceCode-```--which doesn't lead to nice code highlighting on github (and elsewhere).  This function tweaks the list so that ["haskell"] is the class, and it all works.+  enableExtension+    Ext_fenced_code_attributes+    githubMarkdownExtensions --}+-- |+-- literate haskell code blocks comes out of markdown+lhs to native pandoc with the following classes:+--+-- ["sourceCode","literate","haskell"]+--+--   and then conversion to github flavour gives:+--+-- ``` sourceCode+-- ```+--+-- which doesn't lead to nice code highlighting on github (and elsewhere).  This function tweaks the list so that ["haskell"] is the class, and it all works. tweakHaskellCodeBlock :: Block -> Block tweakHaskellCodeBlock (CodeBlock (id', cs, kv) b) =-  CodeBlock (id', bool cs ["haskell"] (Protolude.any ("haskell" ==) cs), kv) b+  CodeBlock (id', bool cs ["haskell"] ("haskell" `elem` cs), kv) b tweakHaskellCodeBlock x = x  -- | read a file into the pandoc AST readPandoc :: FilePath -> Flavour -> IO (Either PandocError Pandoc) readPandoc fp f = do   t <- liftIO $ readFile fp-  runIO $ readMarkdown (def :: ReaderOptions) { readerExtensions = exts f} t+  runIO $ readMarkdown (def :: ReaderOptions) {readerExtensions = exts f} (Text.pack t)  -- | render a pandoc AST renderMarkdown :: Flavour -> Pandoc -> Either PandocError Text renderMarkdown f (Pandoc meta bs) =   runPure $-  writeMarkdown (def :: WriterOptions) { writerExtensions = exts f}-  (Pandoc meta (tweakHaskellCodeBlock <$> bs))+    writeMarkdown+      (def :: WriterOptions) {writerExtensions = exts f}+      (Pandoc meta (tweakHaskellCodeBlock <$> bs))  insertOutput :: OutputMap -> Block -> [Block] insertOutput m b = case b of-  (b'@ (CodeBlock (id', classes, kv) _)) ->-    bool [b']-    (maybe-     [CodeBlock (id', classes, kv) mempty]-     (\x ->-        (maybe [CodeBlock (id', classes, kv) mempty]-         (\ot -> case ot of-              Fence t -> [CodeBlock (id', classes, kv) . Text.unpack $ t]-              Replace t -> [plain t]-              Native bs -> bs-         )-        (Map.lookup x m)))-     (headMay . Protolude.filter ((`elem` classes) . Text.unpack) . Map.keys $ m))-    ("output" `elem` classes)+  b'@(CodeBlock (id', classes, kv) _) ->+    bool+      [b']+      ( maybe+          [CodeBlock (id', classes, kv) mempty]+          ( \x ->+              maybe+                [CodeBlock (id', classes, kv) mempty]+                ( \case+                    Fence t -> [CodeBlock (id', classes, kv) . Text.unpack $ t]+                    Replace t -> [plain t]+                    Native bs -> bs+                )+                (Map.lookup x m)+          )+          (headMaybe . Prelude.filter ((`elem` classes) . Text.unpack) . Map.keys $ m)+      )+      ("output" `elem` classes)   b' -> [b']+  where+    headMaybe [] = Nothing+    headMaybe (x : _) = Just x  -- | add an output key-value pair to state output :: (Monad m) => Text -> Output -> StateT OutputMap m () output k v = modify (Map.insert k v)  -- | insert outputs into a new file-runOutput-  :: (FilePath, Flavour)-  -> (FilePath, Flavour)-  -> StateT OutputMap IO ()-  -> IO (Either PandocError ())+runOutput ::+  (FilePath, Flavour) ->+  (FilePath, Flavour) ->+  StateT OutputMap IO () ->+  IO (Either PandocError ()) runOutput (fi, flavi) (fo, flavo) out = do   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'-  either (pure . Left) (\t -> writeFile fo t >> pure (Right ())) w+        p' <- fmap (\(Pandoc meta bs) -> Pandoc meta (mconcat $ insertOutput m <$> bs)) p+        renderMarkdown flavo p'+  either (pure . Left) (\t -> Text.writeFile fo t >> pure (Right ())) w
test/test.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}  module Main where -import Protolude+import Prelude import Test.DocTest import Readme.Lhs  -- | doctest -- >>> :set -XOverloadedStrings+-- >>> import Readme.Lhs  -- | The main differences between LHS and GitHubMarkdown is that GitHubMarkdown parses bird tracks as a BlockQuote. -- >>> readPandoc "test/test.md" GitHubMarkdown