readme-lhs 0.6.0 → 0.8.1
raw patch · 7 files changed
Files
- other/example.hs +3/−8
- other/readme-lhs.hsfiles +101/−56
- readme-lhs.cabal +62/−33
- readme.md +30/−9
- src/Readme/Convert.hs +59/−33
- src/Readme/Lhs.hs +135/−133
- test/test.hs +3/−21
other/example.hs view
@@ -1,13 +1,8 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall #-} -import Protolude+import NumHask.Prelude import Readme.Lhs main :: IO ()
other/readme-lhs.hsfiles view
@@ -2,36 +2,30 @@ {{name}} === -[](https://travis-ci.org/{{github-username}}{{^github-username}}githubuser{{/github-username}}/{{name}}) [](https://hackage.haskell.org/package/{{name}}) [](http://stackage.org/lts/package/{{name}}) [](http://stackage.org/nightly/package/{{name}}) +[](https://travis-ci.org/{{github-username}}{{^github-username}}githubuser{{/github-username}}/{{name}}) [](https://hackage.haskell.org/package/{{name}}) -flow+develop ---- ```-stack build --test --exec "$(stack path --local-install-root)/bin/{{name}}" --file-watch+stack build --test --file-watch ``` {-# START_FILE app/{{name}}.hs #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-} import NumHask.Prelude main :: IO ()-main = do- let n = 10- let answer = product [1..n::Integer]- print answer+main = pure () {-# 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@@ -46,30 +40,68 @@ type: git location: https://github.com/{{github-username}}{{^github-username}}githubuser{{/github-username}}/{{name}} +library+ hs-source-dirs:+ src+ default-extensions:+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ build-depends:+ base >=4.7 && <5,+ numhask >= 0.7 && < 0.8,+ exposed-modules:++ other-modules:+ default-language: Haskell2010+ executable {{name}} main-is: {{name}}.hs hs-source-dirs: app+ build-depends:+ base >= 4.7 && < 5,+ numhask >= 0.7 && < 0.8,+ {{name}}+ default-language: Haskell2010 default-extensions:- NegativeLiterals- NoImplicitPrelude- OverloadedStrings- UnicodeSyntax ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts -with-rtsopts=-N++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs:+ test build-depends:- base >= 4.7 && < 5- , protolude >= 0.3.0 && < 0.4+ base >=4.7 && <5,+ doctest >= 0.16 && < 0.18,+ numhask >= 0.7 && < 0.8,+ {{name}} default-language: Haskell2010+ default-extensions:+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints {-# START_FILE .gitignore #-} /.stack-work/ /dist-newstyle/-TAGS+stack.yaml.lock+**/.DS_Store+cabal.project.local +{-# START_FILE .projectile #-}+ {-# START_FILE .gitattributes #-} other/* linguist-documentation index.html linguist-documentation@@ -107,59 +139,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 +173,51 @@ esac {-# START_FILE stack.yaml #-}-resolver: lts-15.13+resolver: nightly-2020-11-19 packages: - . extra-deps:+ - numhask-0.7.0.0 - protolude-0.3.0+ - random-1.2.0+ - splitmix-0.1.0.3++{-# START_FILE hie.yaml #-}+cradle:+ stack:+ - path: "./app/{{name}}.hs"+ component: "{{name}}:exe:{{name}}"+ - path: "./src"+ component: "{{name}}:lib"+ - path: "./test/{{name}}.hs"+ component: "{{name}}:test:{{name}}"++{-# START_FILE test/test.hs #-}+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE RebindableSyntax #-}+{-# OPTIONS_GHC -Wall #-}++module Main where++import NumHask.Prelude+import Test.DocTest++main :: IO ()+main =+ doctest+ [+ ]++{-# START_FILE cabal.project #-}+packages: {{name}}.cabal++-- if doctests seem broken, uncomment:+-- See https://github.com/haskell/cabal/issues/6087+-- write-ghc-environment-files: always++allow-newer: random++-- Might be helpful when hackage doesn't build properly...+keep-going: True
readme-lhs.cabal view
@@ -1,8 +1,36 @@-cabal-version: 3.0+cabal-version: 2.4 name: readme-lhs-version: 0.6.0-synopsis: See readme.md-description: See readme.md for description.+version: 0.8.1+synopsis: Literate programming support.+description: This package provides support for literate programming in haskell, including:+ .+ - conversion between *.lhs and *.hs formats.+ .+ - insertion of program output into *.lhs and *.md for fast feedback in+ development.+ .+ - a simple wrapper for pandoc functionality.+ .+ - a stack template, `readme-lhs`+ .+ == Usage+ .+ The best way to understand package functionality is to run the example.hs, with:+ .+ > stack build --test --exec "$(stack path --local-install-root)/bin/readme-lhs-example --file-watch+ .+ > import Readme.Lhs+ > main =+ > void $+ > runOutput ("other/readme_.md", GitHubMarkdown) ("readme.md", GitHubMarkdown) $+ > output "example" (Fence "Simple example of an output")+ .+ == Template+ .+ To use the provided template, copy readme-lhs.hsfiles to a local directory, and try:+ .+ > stack new xyzzy readme-lhs+ category: Development homepage: https://github.com/tonyday567/readme-lhs#readme bug-reports: https://github.com/tonyday567/readme-lhs/issues@@ -13,8 +41,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@@ -24,9 +52,6 @@ hs-source-dirs: src default-extensions:- NegativeLiterals- OverloadedStrings- UnicodeSyntax ghc-options: -Wall -Wcompat@@ -34,45 +59,49 @@ -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 && < 0.14,+ base >=4.7 && <5,+ blaze-html >= 0.9,+ containers >= 0.6,+ foldl >= 1.4,+ generic-lens >= 1.2 && < 3.0,+ numhask >= 0.7 && < 0.8,+ pandoc >= 2.10,+ pandoc-types >= 1.21,+ text >= 1.2,+ transformers >= 0.5 exposed-modules:- Readme.Lhs, Readme.Convert+ 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.7 && < 0.8,+ readme-lhs default-language: Haskell2010+ default-extensions:+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints test-suite test type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test- default-extensions: NoImplicitPrelude UnicodeSyntax NegativeLiterals OverloadedStrings+ default-extensions: build-depends:- base >=4.7 && <5- , containers- , doctest- , readme-lhs+ base >=4.7 && <5,+ doctest >= 0.16 && < 0.18,+ numhask >= 0.7 && < 0.8,+ readme-lhs, default-language: Haskell2010
readme.md view
@@ -1,22 +1,43 @@-[readme-lhs](https://tonyday567.github.io/readme-lhs) [](https://travis-ci.org/tonyday567/readme-lhs)-=====================================================================================================================================================================+# readme-lhs +[](https://travis-ci.org/tonyday567/readme-lhs)+[](https://hackage.haskell.org/package/readme-lhs)+ <blockquote cite> The language in which we express our ideas has a strong influence on our-thought processes. Knuth+thought processes ~ Knuth </blockquote> -example insert+Support for literate programming in haskell including: +- conversion between *.lhs and *.hs formats.+- insertion of program output into *.lhs and *.md for fast feedback in+ development.+- a simple wrapper for pandoc functionality.+- a stack template, `readme-lhs`++## example insert+ ``` {.output .example} Simple example of an output ``` -template-========+# template A bare bones stack template is located in [other/readme-lhs.hsfiles](other/readme-lhs.hsfiles). It contains what-you need to quickly get started with literate programming alongside the-challenge of using a rapid workflow-`stack build --test --exec "$(stack path --local-install-root)/bin/readme-lhs-example" --file-watch`.+you need to quickly get started with literate programming and enjoy a+rapid workflow++Place this in a local directory and then:++ stack new xyzzy readme-lhs+ cd xyzzy+ stack build++will get you bootstrapped and ready to hack!++# development++`stack build --test --exec "$(stack path --local-install-root)/bin/readme-lhs-example --file-watch`.
src/Readme/Convert.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- | Helpers for converting between lhs and hs files.+-- module Readme.Convert ( Section (..), Block (..),@@ -14,28 +18,32 @@ 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) +-- | Type of file section data Section = Code | Comment deriving (Show, Eq) +-- | A native section block. data Block = Block Section [Text] deriving (Show, Eq) --- starting with .lhs bird style-bird :: Text.Parser Block+-- | *.lhs bird style+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 +-- | Parse an lhs-style block of text in 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 +66,19 @@ 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 +-- | Convert a block of code into lhs. printLhs :: [Block] -> [Text] printLhs ss =- Protolude.mconcat $+ mconcat $ ( \(Block s ts) -> case s of Code -> ("> " <>) <$> ts@@ -80,40 +89,42 @@ 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])+-- | Parse a .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 :: 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 +-- | Parse assuming a hs block of code 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 +132,19 @@ 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) +-- | Print a block of code to hs style printHs :: [Block] -> [Text] printHs ss =- Protolude.mconcat $+ mconcat $ ( \(Block s ts) -> case s of Code -> ts@@ -140,13 +152,27 @@ ) <$> ss --- just in case there are ever other formats (YAML haskell anyone?)+-- | just in case there are ever other formats (YAML haskell anyone?) data Format = Lhs | Hs +-- | Print print :: Format -> [Block] -> [Text] print Lhs f = printLhs f print Hs f = printHs f +-- | Parse parse :: Format -> [Text] -> [Block] parse Lhs f = parseLhs f parse Hs f = parseHs f++-- | Convert a file from lhs to hs+lhs2hs :: FilePath -> IO ()+lhs2hs fp = do+ t <- readFile (fp <> ".lhs")+ writeFile (fp <> ".hs") $ unlines $ print Hs $ parse Lhs $ lines t++-- | Convert a file from hs to lhs+hs2lhs :: FilePath -> IO ()+hs2lhs fp = do+ t <- readFile (fp <> ".hs")+ writeFile (fp <> ".lhs") $ unlines $ print Lhs $ parse Hs $ lines t
src/Readme/Lhs.hs view
@@ -1,131 +1,77 @@ {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} +-- | Help for inserting programming output into an lhs or md-style file. module Readme.Lhs- ( para,- plain,- inline,- table,- table',- code,- link,- linkTooltip,- badge,- image,+ ( -- * Usage+ -- $setup++ -- * pandoc 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>",Para [RawInline (Format "html") "<br>",RawInline (Format "html") "<p>",Str "I",Space,Str "am",Space,Str "raw",Space,Str "Html",RawInline (Format "html") "</p>",RawInline (Format "html") "</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 LHS@ is equivalent to @markdown+lhs@+-- @exts GitHubMarkdown@ is equivalent to @gfm@+-- @exts Html@ is equivalent to @html@ exts :: Flavour -> Extensions exts LHS = enableExtension Ext_literate_haskell $ getDefaultExtensions "markdown" exts GitHubMarkdown =@@ -152,35 +98,45 @@ -- | 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\nan example table\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++-- | a 'Map' of output keyed off of defined section names in the receiving file+type OutputMap = Map Text Output++-- | Insert a block into the 'OutputMap' insertOutput :: OutputMap -> Block -> [Block] insertOutput m b = case b of b'@(CodeBlock (id', classes, kv) _) ->@@ -193,12 +149,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 +179,53 @@ 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
@@ -1,33 +1,15 @@+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Main where -import Prelude+import NumHask.Prelude import Test.DocTest 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"]-+ ]