packages feed

readme-lhs 0.6.0 → 0.7.0

raw patch · 7 files changed

+344/−251 lines, 7 filesdep +numhaskdep +scientificdep +tdigestdep −protoludedep ~attoparsecdep ~blaze-htmldep ~containers

Dependencies added: numhask, scientific, tdigest

Dependencies removed: protolude

Dependency ranges changed: attoparsec, blaze-html, containers, foldl, pandoc, pandoc-types, text, transformers

Files

other/example.hs view
@@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} -import Protolude+import NumHask.Prelude import Readme.Lhs  main :: IO ()
other/readme-lhs.hsfiles view
@@ -13,10 +13,16 @@  {-# START_FILE app/{{name}}.hs #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} @@ -25,13 +31,13 @@ main :: IO () main = do   let n = 10-  let answer = product [1..n::Integer]+  let answer = 1 + product [1..n::Integer]   print answer  {-# START_FILE {{name}}.cabal #-}-cabal-version: 3.0-name: {{name}}-version: 0.0.1+cabal-version: 2.4+name:          {{name}}+version:       0.0.1 synopsis: See readme.md description: See readme.md for description. category: project@@ -49,6 +55,10 @@ executable {{name}}   main-is: {{name}}.hs   hs-source-dirs: app+  build-depends:+    base >= 4.7 && < 5,+    numhask-prelude >= 0.6+  default-language: Haskell2010   default-extensions:     NegativeLiterals     NoImplicitPrelude@@ -60,16 +70,14 @@     -threaded     -rtsopts     -with-rtsopts=-N-  build-depends:-      base >= 4.7 && < 5-    , protolude >= 0.3.0 && < 0.4-  default-language: Haskell2010  {-# START_FILE .gitignore #-} /.stack-work/ /dist-newstyle/ TAGS +{-# START_FILE .projectile #-}+ {-# START_FILE .gitattributes #-} other/* linguist-documentation index.html linguist-documentation@@ -107,59 +115,31 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  {-# START_FILE .travis.yml #-}-language: haskell-dist: trusty+language: generic  cache:   directories:   - $HOME/.stack   - $TRAVIS_BUILD_DIR/.stack-work-  - $TRAVIS_BUILD_DIR/dist-newstyle -cabal: "3.0"- matrix:   include:-    - env: BUILD=cabal-      ghc: "8.8.3"-    - env: BUILD=stack ARGS="--system-ghc"-      ghc: "8.8.3"+    - env: BUILD=stack       # a -Werror build that is allowed to fail-    - env: BUILD=werror ARGS="--system-ghc"-      ghc: "8.8.3"-    - env: BUILD=stack ARGS="--resolver nightly --system-ghc"-      ghc: "8.8.3"+    - env: BUILD=werror    allow_failures:-    - env: BUILD=stack ARGS="--resolver nightly --system-ghc"-    - env: BUILD=werror ARGS="--system-ghc"+    - env: BUILD=werror  install: - |-  case "$BUILD" in-    cabal)-      cabal --version-      ghc --version-      ;;-    stack|werror)-      ghc --version       PATH=$HOME/.local/bin:$PATH       mkdir -p ~/.local/bin-      if [ `uname` = "Darwin" ]-      then-        travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin-      else-        travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'-      fi-      ;;-  esac+      travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'  script: - |   case "$BUILD" in-    cabal)-      cabal build all-      ;;     stack)       stack --no-terminal $ARGS test --haddock --no-haddock-deps       ;;@@ -169,10 +149,23 @@   esac  {-# START_FILE stack.yaml #-}-resolver: lts-15.13+resolver: nightly-2020-06-25  packages:   - .  extra-deps:-  - protolude-0.3.0+  - git: https://github.com/tonyday567/numhask-space+    commit: 6525f5096525196fe367dabdfe596a7bd0c0aa6c+  - git: https://github.com/tonyday567/numhask+    commit: 37ee8dced120f60a511baa6bb6c7ac382b1e8827+    subdir: numhask-prelude+  - git: https://github.com/tonyday567/numhask+    commit: 37ee8dced120f60a511baa6bb6c7ac382b1e8827+    subdir: numhask++{-# START_FILE hie.yaml #-}+cradle:+  stack:+    - path: "./app/{{name}}.hs"+      component: "{{name}}:exe:{{name}}"
readme-lhs.cabal view
@@ -1,6 +1,6 @@-cabal-version: 3.0+cabal-version:  2.4 name:           readme-lhs-version:        0.6.0+version:        0.7.0 synopsis:       See readme.md description:    See readme.md for description. category:       Development@@ -13,8 +13,8 @@ license-file:   LICENSE build-type:     Simple extra-source-files:-    readme.md-    other/readme-lhs.hsfiles+  readme.md+  other/readme-lhs.hsfiles  source-repository head   type: git@@ -25,6 +25,7 @@     src   default-extensions:     NegativeLiterals+    NoImplicitPrelude     OverloadedStrings     UnicodeSyntax   ghc-options:@@ -34,35 +35,46 @@     -Wincomplete-uni-patterns     -Wredundant-constraints   build-depends:-    base >=4.7 && <5-    , attoparsec-    , blaze-html-    , foldl-    , protolude >= 0.3 && < 0.4-    , text-    , pandoc-    , pandoc-types-    , containers-    , transformers+    attoparsec >= 0.13,+    base >=4.7 && <5,+    blaze-html >= 0.9,+    containers >= 0.6,+    foldl >= 1.4,+    numhask >= 0.6 && < 0.7,+    pandoc >= 2.10,+    pandoc-types >= 1.21,+    scientific >= 0.3,+    tdigest >= 0.2,+    text >= 1.2,+    transformers >= 0.5   exposed-modules:-    Readme.Lhs,     Readme.Convert+    Readme.Format+    Readme.Lhs   other-modules:   default-language: Haskell2010  executable readme-lhs-example   main-is: example.hs   hs-source-dirs:-      other-  default-extensions: NoImplicitPrelude UnicodeSyntax NegativeLiterals OverloadedStrings-  ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N+    other   build-depends:-      base >=4.7 && <5-    , protolude >= 0.3 && < 0.4-    , readme-lhs-    , text-+    base >=4.7 && <5,+    numhask >= 0.6 && < 0.7,+    readme-lhs,+    text >= 1.2   default-language: Haskell2010+  default-extensions:+    NegativeLiterals+    NoImplicitPrelude+    OverloadedStrings+    UnicodeSyntax+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints  test-suite test   type: exitcode-stdio-1.0@@ -71,8 +83,8 @@       test   default-extensions: NoImplicitPrelude UnicodeSyntax NegativeLiterals OverloadedStrings   build-depends:-      base >=4.7 && <5-    , containers-    , doctest-    , readme-lhs+    base >=4.7 && <5,+    containers,+    doctest,+    readme-lhs   default-language: Haskell2010
src/Readme/Convert.hs view
@@ -14,28 +14,29 @@     printLhs,     parse,     print,+    lhs2hs,+    hs2lhs   ) where  import qualified Control.Foldl as L-import qualified Data.Attoparsec.Text as Text+import qualified Data.Attoparsec.Text as A import qualified Data.List as List-import qualified Data.Text as Text-import Protolude hiding (print)+import NumHask.Prelude 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 :: A.Parser Block bird =-  (\x -> Block Code [x]) <$> ("> " *> Text.takeText)-    <|> (\_ -> Block Code [""]) <$> (">" *> Text.takeText)-    <|> (\x -> Block Comment [x]) <$> Text.takeText+  (\x -> Block Code [x]) <$> ("> " *> A.takeText)+    <|> (\_ -> Block Code [""]) <$> (">" *> A.takeText)+    <|> (\x -> Block Comment [x]) <$> A.takeText  parseLhs :: [Text] -> [Block]-parseLhs text = L.fold (L.Fold step begin done) $ Text.parseOnly bird <$> text+parseLhs text = L.fold (L.Fold step begin done) $ A.parseOnly bird <$> text   where     begin = (Block Code [], [])     done (Block _ [], out) = unlit' out@@ -58,18 +59,18 @@     unlit [""] = [""]     unlit xs =       if-        | (Protolude.head xs == Just "") && (Protolude.head (reverse xs) == Just "") ->+        | (head xs == Just "") && (head (reverse xs) == Just "") ->           List.init $ List.tail xs-        | (Protolude.head xs == Just "") ->+        | (head xs == Just "") ->           List.tail xs-        | (Protolude.head (reverse xs) == Just "") ->+        | (head (reverse xs) == Just "") ->           List.init xs         | otherwise ->           xs  printLhs :: [Block] -> [Text] printLhs ss =-  Protolude.mconcat $+  mconcat $     ( \(Block s ts) ->         case s of           Code -> ("> " <>) <$> ts@@ -80,40 +81,40 @@     lit [] = [""]     lit [""] = [""]     lit xs =-      (if Protolude.head xs == Just "" then [] else [""])+      bool [""] [] (head xs == Just "")         <> xs-        <> (if List.last xs == "" then [] else [""])+        <> bool [""] [] (List.last xs == "")  -- 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 :: A.Parser (Maybe (Section, Section), [Text]) normal =   -- Nothing represents a continuation of previous section-  (\_ -> (Nothing, [""])) <$> Text.endOfInput+  (Nothing, [""]) <$ A.endOfInput     <|>     -- exact matches include line removal-    (\_ -> (Just (Comment, Comment), [])) <$> ("{-" *> Text.endOfInput)-    <|> (\_ -> (Just (Comment, Code), [])) <$> ("-}" *> Text.endOfInput)+    (Just (Comment, Comment), []) <$ ("{-" *> A.endOfInput)+    <|> (Just (Comment, Code), []) <$ ("-}" *> A.endOfInput)     <|>     -- single line braced     (\x -> (Just (Code, Code), ["{-" <> x <> "-}"]))-      <$> ("{-" *> (Text.pack <$> Text.manyTill' Text.anyChar "-}"))+      <$> ("{-" *> (pack <$> A.manyTill' A.anyChar "-}"))     <|>     -- pragmas-    (\x -> (Just (Code, Code), ["{-#" <> x])) <$> ("{-#" *> Text.takeText)-    <|> (\x -> (Just (Code, Code), [x])) <$> (Text.pack <$> Text.manyTill' Text.anyChar "#-}")+    (\x -> (Just (Code, Code), ["{-#" <> x])) <$> ("{-#" *> A.takeText)+    <|> (\x -> (Just (Code, Code), [x])) <$> (pack <$> A.manyTill' A.anyChar "#-}")     <|>     -- braced start of multi-line comment (brace is stripped)-    (\x -> (Just (Comment, Comment), [x])) <$> ("{-" *> Text.takeText)+    (\x -> (Just (Comment, Comment), [x])) <$> ("{-" *> A.takeText)     <|>     -- braced end of multi-line comment (brace is stripped)-    (\x -> (Just (Comment, Code), [x])) <$> (Text.pack <$> Text.manyTill' Text.anyChar "-}")+    (\x -> (Just (Comment, Code), [x])) <$> (pack <$> A.manyTill' A.anyChar "-}")     <|>     -- everything else a continuation and verbatim-    (\x -> (Nothing, [x])) <$> Text.takeText+    (\x -> (Nothing, [x])) <$> A.takeText  parseHs :: [Text] -> [Block]-parseHs text = L.fold (L.Fold step begin done) $ Text.parseOnly normal <$> text+parseHs text = L.fold (L.Fold step begin done) $ A.parseOnly normal <$> text   where     begin = (Block Code [], [])     done (Block _ [], out) = out@@ -121,18 +122,18 @@     step x (Left _) = x     step (Block s ts, out) (Right (Just (this, next), ts')) =       if-        | ts <> ts' == [] -> (Block next [], out)+        | null (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)+        | null (ts <> ts') -> (Block s [], out)         | otherwise -> (Block s (ts <> ts'), out)  printHs :: [Block] -> [Text] printHs ss =-  Protolude.mconcat $+  mconcat $     ( \(Block s ts) ->         case s of           Code -> ts@@ -150,3 +151,13 @@ parse :: Format -> [Text] -> [Block] parse Lhs f = parseLhs f parse Hs f = parseHs f++lhs2hs :: FilePath -> IO ()+lhs2hs fp = do+  t <- readFile (fp <> ".lhs")+  writeFile (fp <> ".hs") $ unlines $ print Hs $ parse Lhs $ lines t++hs2lhs :: FilePath -> IO ()+hs2lhs fp = do+  t <- readFile (fp <> ".hs")+  writeFile (fp <> ".lhs") $ unlines $ print Lhs $ parse Hs $ lines t
+ src/Readme/Format.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RebindableSyntax #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++-- | formatting of numbers and statistics+module Readme.Format+  ( average,+    deciles,+    percentile,+    fixed,+    commas,+    prec,+    secs,+  ) where++import NumHask.Prelude+import Data.Scientific+import Data.TDigest+import qualified Data.Text as Text++-- | average+--+-- >>> average [0..1000]+-- 500.0+average :: (Foldable f) => f Double -> Double+average xs = sum xs / fromIntegral (length xs)++-- | compute deciles+--+-- >>> deciles 5 [1..1000]+-- [1.0,200.5,400.5,600.5000000000001,800.5,1000.0]+--+deciles :: (Foldable f) => Int -> f Double -> [Double]+deciles n xs =+  ( \x ->+      fromMaybe 0 $+        quantile x (tdigest xs :: TDigest 25)+  )+    <$> ((/ fromIntegral n) . fromIntegral <$> [0 .. n])++-- | compute a percentile+--+-- >>> percentile 0.1 [1..1000]+-- 100.5+--+percentile :: (Foldable f) => Double -> f Double -> Double+percentile p xs = fromMaybe 0 $ quantile p (tdigest xs :: TDigest 25)++-- | fixed+-- >>> fixed 2 22.256+-- "22.26"+fixed :: Int -> Double -> Text+fixed n x+  | Text.length a == 0 = "0." <> (Text.replicate (n - Text.length b) "0") <> b+  | Text.length b == 0 = a+  | otherwise = a <> "." <> b+  where+    i = show (round (x * (10.0 ^ n)) :: Integer) :: Text+    (a, b) = Text.splitAt (Text.length i - n) i++-- | format a Float as a Scientific with a precision+-- >>> prec 3 123456+-- "1.235e5"+prec :: Int -> Double -> Text+prec p x = sciprec p (fromFloatDigits x)++-- | format with 1000 separated commas, and a fixed decimal part+-- >>> commas 2 123456.789+-- "123,456.79"+commas :: Int -> Double -> Text+commas n a+  | a < 0 = "-" <> commas n (- a)+  | a < 1000.0 = fixed n a+  | otherwise = intPart (floor a) "" <> decPart (a - fromInteger (floor a))+  where+    intPart :: Integer -> Text -> Text+    intPart x t+      | x < 1000 = Text.pack (show x) <> t+      | otherwise =+        let (d, m) = divMod x 1000+         in intPart d ("," <> Text.pack (show m))+    decPart :: Double -> Text+    decPart x = Text.drop 1 $ fixed n x++sciprec :: Int -> Scientific -> Text+sciprec n x = Text.pack $ formatScientific Exponent (Just n) x++-- | format as seconds+-- >>> secs 2 0.0000002345+-- "234ns"+secs :: Int -> Double -> Text+secs p s+  | s < 0.0 = "-" <> secs p (- s)+  | s >= 1.0 = fixed p s <> "s"+  | s >= 1e-3 = fixed 0 (s * 1e3) <> "ms"+  | s >= 1e-6 = fixed 0 (s * 1e6) <> "μs"+  | s >= 1e-9 = fixed 0 (s * 1e9) <> "ns"+  | otherwise = fixed p (s * 1e12) <> "ps"
src/Readme/Lhs.hs view
@@ -4,128 +4,68 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Readme.Lhs-  ( para,-    plain,-    inline,-    table,-    table',-    code,-    link,-    linkTooltip,-    badge,-    image,+  ( -- * restricted pandoc types     Flavour (..),     readPandoc,-    renderMarkdown,-    renderHtml,+    renderPandoc,++    -- * output     Output (..),     OutputMap,     output,     insertOutput,     runOutput,     tweakHaskellCodeBlock,-    Block (..),++    -- * common patterns+    defaultTable,+    defaultTextTable,+    bootTableAttr,+    thead,+    tbody,+    cell1,+    badge,+    hask,++    -- * exports     module Text.Pandoc.Definition,-    Alignment (..),+    module B,   ) where -import Control.Monad.IO.Class import qualified Data.Map as Map-import Data.Text as Text-import qualified Data.Text.IO as Text+import NumHask.Prelude hiding (link)+import qualified Text.Blaze.Html.Renderer.Text as Blaze import Text.Pandoc import Text.Pandoc.Definition-import Protolude hiding (link)-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--type OutputMap = Map Text Output+import Text.Pandoc.Builder as B --- | doctest+-- $setup -- >>> :set -XOverloadedStrings---- | turn text into a Pandoc Paragraph Block--- >>> para "hello"--- Para [Str "hello"]-para :: Text -> Block-para = Para . fmap (Str) . Text.lines---- | turn text into a Pandoc Plain Block--- >>> plain "hello"--- Plain [Str "hello"]-plain :: Text -> Block-plain = Plain . fmap (Str) . Text.lines---- |--- >>> inline "two\nlines"--- [Str "two",Str "lines"]-inline :: Text -> [Inline]-inline = fmap (Str) . Text.lines---- | create a link--- >>> link "test" "link"--- Link ("",[],[]) [Str "test"] ("link","")-link :: Text -> Text -> Inline-link name url = Link ("", [], []) [Str (name)] (url, "")---- | create a link--- >>> linkTooltip "test" "link" "tooltip"--- Link ("",[],[]) [Str "test"] ("link","tooltip")-linkTooltip :: Text -> Text -> Text -> Inline-linkTooltip name url tooltip = Link ("", [], []) [Str (name)] (url, tooltip)---- | create an image link--- >>> image "test" "imagelink.svg"--- Image ("",[],[]) [Str "test"] ("imagelink.svg","")-image :: Text -> Text -> Inline-image name url = Image ("", [], []) [Str (name)] (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 (label)] (badge', "")] (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)---- | 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"-code :: Text -> [Text] -> Text -> Block-code name classes =-  CodeBlock (name, classes, [])+-- >>> import Readme.Lhs+-- >>> import Text.Pandoc.Builder as B+-- >>> let table1 = Table ("",["table","table-bordered","table-hover","m-3"],[("style","width: 70%;")]) (Caption Nothing [Plain [Str "an",Space,Str "example",Space,Str "table"]]) [(AlignLeft,ColWidthDefault),(AlignRight,ColWidthDefault)] (TableHead ("",[],[]) [Row ("",[],[]) [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) [Plain [Str "first",Space,Str "column"]],Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) [Plain [Str "second",Space,Str "column"]]]]) [TableBody ("",[],[]) (RowHeadColumns 0) [] [Row ("",[],[]) [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) [Plain [Str "first",Space,Str "row"]],Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) [Plain [Str "1"]]],Row ("",[],[]) [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) [Plain [Str "second",Space,Str "row"]],Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) [Plain [Str "1000"]]]]] (TableFoot ("",[],[]) [])  -- | 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 | Html+--+--   use GitHubMarkdown for rendering code and results on github+--+--   The main differences between LHS and GitHubMarkdown is that GitHubMarkdown parses bird tracks as a BlockQuote.+-- >>> readPandoc "test/test.md" GitHubMarkdown+-- 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"],[]) "",Para [Str "raw",Space,Str "html"],RawBlock (Format "html") "<div><br><p>I am raw Html</p></div>"])+--+-- >>> readPandoc "test/test.md" LHS+-- Right (Pandoc (Meta {unMeta = fromList []}) [Plain [Str "haskell",Space,Str "LHS",Space,Str "style",SoftBreak,Str "```{.sourceCode",Space,Str ".literate",Space,Str ".haskell}",SoftBreak,Str "```",SoftBreak,Str "bird-tracks",SoftBreak,Str ">",Space,Str "import",Space,Str "Readme.Lhs",SoftBreak,Str "code",Space,Str "block",SoftBreak,Str "indented",SoftBreak,Str "unfenced",Space,Str "code",SoftBreak,Str "github-style",Space,Str "fenced",Space,Str "code",Space,Str "blocks",SoftBreak,Str "```",Space,Str "haskell",SoftBreak,Str "```",SoftBreak,Str "```",Space,Str "output",Space,Str "test1",SoftBreak,Str "```",SoftBreak,Str "php-style",Space,Str "fenced",Space,Str "code",Space,Str "blocks",SoftBreak,Str "```",Space,Str "{.output",Space,Str ".test1}",SoftBreak,Str "```",SoftBreak,Str "raw",Space,Str "html"],Div ("",[],[]) [Plain [LineBreak],Para [Str "I",Space,Str "am",Space,Str "raw",Space,Str "Html"]]])+--+-- Note how raw html inside markdown files is broken.+--+-- >>> (Right (Pandoc _ t1)) <- readPandoc "test/table1.html" Html+-- >>> t1 == [table1]+-- True+data Flavour = GitHubMarkdown | LHS | Html deriving (Eq, Show, Ord)  -- | exts LHS is equivalent to 'markdown+lhs'---  exts GitHubMarkdown is equivalent to 'gfm'+-- exts GitHubMarkdown is equivalent to 'gfm' exts :: Flavour -> Extensions exts LHS = enableExtension Ext_literate_haskell $ getDefaultExtensions "markdown" exts GitHubMarkdown =@@ -152,35 +92,43 @@  -- | 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+readPandoc fp f+  | f == GitHubMarkdown = do+    t <- liftIO $ readFile fp+    runIO $ readMarkdown (def :: ReaderOptions) {readerExtensions = exts f} t+  | otherwise = do+    t <- liftIO $ readFile fp+    runIO $ readHtml (def :: ReaderOptions) {readerExtensions = exts f} t  -- | render a pandoc AST--- >>> renderMarkdown GitHubMarkdown (Pandoc mempty [Table [] [] [] [] [[[Para [Str "1"]],[Para [Str "2"]]]]])--- Right "|     |     |\n|-----|-----|\n| 1   | 2   |\n"-renderMarkdown :: Flavour -> Pandoc -> Either PandocError Text-renderMarkdown f (Pandoc meta bs) =-  runPure $-    writeMarkdown-      (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))+-- >>> renderPandoc GitHubMarkdown (Pandoc mempty [table1])+-- Right "| first column | second column |\n|:-------------|--------------:|\n| first row    |             1 |\n| second row   |          1000 |\n"+--+-- >>> renderPandoc Html (Pandoc mempty [table1])+-- Right "<table class=\"table table-bordered table-hover m-3\" style=\"width: 70%;\">\n<caption>an example table</caption>\n<thead>\n<tr class=\"header\">\n<th style=\"text-align: left;\">first column</th>\n<th style=\"text-align: right;\">second column</th>\n</tr>\n</thead>\n<tbody>\n<tr class=\"odd\">\n<td style=\"text-align: left;\">first row</td>\n<td style=\"text-align: right;\">1</td>\n</tr>\n<tr class=\"even\">\n<td style=\"text-align: left;\">second row</td>\n<td style=\"text-align: right;\">1000</td>\n</tr>\n</tbody>\n</table>"+--+-- Note how pandoc strips things like links, style and scripts.+--+renderPandoc :: Flavour -> Pandoc -> Either PandocError Text+renderPandoc f (Pandoc meta bs)+  | f == Html = runPure $ do+    h <-+      writeHtml5+        (def :: WriterOptions) {writerExtensions = exts f}+        (Pandoc meta (tweakHaskellCodeBlock <$> bs))     pure $ toStrict $ Blaze.renderHtml h+  | otherwise =+    runPure $+      writeMarkdown+        (def :: WriterOptions) {writerExtensions = exts f}+        (Pandoc meta (tweakHaskellCodeBlock <$> bs)) +-- | output can be native pandoc, text that replaces or inserts into the output code block, or Html.+data Output = Native [Block] | Replace Text | Fence Text | RawHtml Text++type OutputMap = Map Text Output+ insertOutput :: OutputMap -> Block -> [Block] insertOutput m b = case b of   b'@(CodeBlock (id', classes, kv) _) ->@@ -193,12 +141,13 @@                 [CodeBlock (id', classes, kv) mempty]                 ( \case                     Fence t -> [CodeBlock (id', classes, kv) t]-                    Replace t -> [plain t]+                    Replace t -> (B.toList $ plain (str t))                     Native bs -> bs+                    RawHtml h -> [RawBlock (Format "html") h]                 )                 (Map.lookup x m)           )-          (headMay . Protolude.filter ((`elem` classes)) . Map.keys $ m)+          (headMay . filter (`elem` classes) . Map.keys $ m)       )       ("output" `elem` classes)   b' -> [b']@@ -222,8 +171,51 @@   p <- readPandoc fi flavi   let w = do         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+        renderPandoc flavo p'+  either (pure . Left) (\t -> writeFile fo t >> pure (Right ())) w +-- | create a simple table from Inlines+-- >>> defaultTable bootTableAttr (B.fromList [Str "an",Space,Str "example",Space,Str "table"]) [(AlignLeft, ColWidthDefault), (AlignRight, ColWidthDefault)] (B.fromList <$> [[Str "first",Space,Str "column"], [Str "second",Space,Str "column"]]) (fmap B.fromList <$> [[[Str "first",Space,Str "row"], [Str "1"]], [[Str "second",Space,Str "row"], [Str "1000"]]]) == singleton table1+-- True+defaultTable :: Attr -> Inlines -> [ColSpec] -> [Inlines] -> [[Inlines]] -> Blocks+defaultTable attr c cs hs rs = tableWith attr (simpleCaption (plain c)) cs (thead hs) ((:[]) $ tbody rs) nullTfoot++-- | create a simple table from Text+--+-- > defaultTextTable bootTableAttr "an example table" [(AlignLeft, ColWidthDefault), (AlignRight, ColWidthDefault)] ["first column", "second column"] [["first row", "1"], ["second row", "1000"]]+defaultTextTable :: Attr -> Text -> [ColSpec] -> [Text] -> [[Text]] -> Blocks+defaultTextTable attr c cs hs rs = defaultTable attr (str c) cs (str <$> hs) (fmap str <$> rs)++-- | bootstrap classes+bootTableAttr :: Attr+bootTableAttr = ("",["table","table-bordered","table-hover","m-3"],[("style","width: 70%;")])++-- | aligned simple cell+cell1 :: Alignment -> Inlines -> Cell+cell1 a i = cell a (RowSpan 1) (ColSpan 1) (plain i)++-- | aligned simple table header+thead :: [Inlines] -> TableHead+thead xs = TableHead nullAttr . (:[]) . Row nullAttr $ (simpleCell . plain <$> xs)++-- | null table footer+nullTfoot :: TableFoot+nullTfoot = TableFoot nullAttr []++-- | aligned simple table body+tbody :: [[Inlines]] -> TableBody+tbody xs = TableBody nullAttr (RowHeadColumns 0) [] (Row nullAttr <$> (fmap (simpleCell . plain) <$> xs))++-- | haskell code block+hask :: Maybe Text -> Text -> Inlines+hask name t = codeWith (fromMaybe mempty name, ["sourceCode","literate","haskell"], []) t++-- | create a badge link+-- >>> B.toList $ 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 -> Inlines+badge label badge' url =+  singleton $+  Link ("", [], [])+  [Image ("", [], []) [Str label] (badge', "")]+  (url, "")
test/test.hs view
@@ -8,26 +8,9 @@ import Readme.Lhs import qualified Data.Map as Map --- | 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--- 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 =   doctest-  [ "src/Readme/Lhs.hs"---  , "other/example.hs"-  , "test/test.hs"]-+  [ "src/Readme/Lhs.hs",+    "src/Readme/Format.hs"+  ]