The language in which we express our ideas has a strong influence on our -thought processes. Knuth +thought processes ~ Knuth-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`. diff --git a/src/Readme/Convert.hs b/src/Readme/Convert.hs --- a/src/Readme/Convert.hs +++ b/src/Readme/Convert.hs @@ -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 diff --git a/src/Readme/Lhs.hs b/src/Readme/Lhs.hs --- a/src/Readme/Lhs.hs +++ b/src/Readme/Lhs.hs @@ -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") "
",Str "I",Space,Str "am",Space,Str "raw",Space,Str "Html",RawInline (Format "html") "
",RawInline (Format "html") "| 1 | \n2 | \n
| first column | \nsecond column | \n
|---|---|
| first row | \n1 | \n
| second row | \n1000 | \n
haskell LHS style
\nbird-tracks
\n\n\nimport Readme.Lhs
\n
code block
\nindented\nunfenced codegithub-style fenced code blocks
\noutput test1
php-style fenced code blocks
\ninserted text" - - main :: IO () main = doctest [ "src/Readme/Lhs.hs" --- , "other/example.hs" - , "test/test.hs"] - + ]