{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Help for inserting programming output into an lhs or md-style file.
module Readme.Lhs
  ( -- * Usage
    -- $setup

    -- * pandoc
    Flavour (..),
    readPandoc,
    renderPandoc,

    -- * output
    Output (..),
    OutputMap,
    output,
    insertOutput,
    runOutput,
    tweakHaskellCodeBlock,

    -- * common patterns
    defaultTable,
    defaultTextTable,
    bootTableAttr,
    thead,
    tbody,
    cell1,
    badge,
    hask,

    -- * exports
    module Text.Pandoc.Definition,
    module B,
  )
where

import qualified Data.Map as Map
import NumHask.Prelude hiding (link)
import qualified Text.Blaze.Html.Renderer.Text as Blaze
import Text.Pandoc
import Text.Pandoc.Definition
import Text.Pandoc.Builder as B

-- $setup
--
-- >>> :set -XOverloadedStrings
-- >>> 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
--
--   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 (Flavour -> Flavour -> Bool
(Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool) -> Eq Flavour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flavour -> Flavour -> Bool
$c/= :: Flavour -> Flavour -> Bool
== :: Flavour -> Flavour -> Bool
$c== :: Flavour -> Flavour -> Bool
Eq, Int -> Flavour -> ShowS
[Flavour] -> ShowS
Flavour -> String
(Int -> Flavour -> ShowS)
-> (Flavour -> String) -> ([Flavour] -> ShowS) -> Show Flavour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flavour] -> ShowS
$cshowList :: [Flavour] -> ShowS
show :: Flavour -> String
$cshow :: Flavour -> String
showsPrec :: Int -> Flavour -> ShowS
$cshowsPrec :: Int -> Flavour -> ShowS
Show, Eq Flavour
Eq Flavour
-> (Flavour -> Flavour -> Ordering)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Flavour)
-> (Flavour -> Flavour -> Flavour)
-> Ord Flavour
Flavour -> Flavour -> Bool
Flavour -> Flavour -> Ordering
Flavour -> Flavour -> Flavour
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Flavour -> Flavour -> Flavour
$cmin :: Flavour -> Flavour -> Flavour
max :: Flavour -> Flavour -> Flavour
$cmax :: Flavour -> Flavour -> Flavour
>= :: Flavour -> Flavour -> Bool
$c>= :: Flavour -> Flavour -> Bool
> :: Flavour -> Flavour -> Bool
$c> :: Flavour -> Flavour -> Bool
<= :: Flavour -> Flavour -> Bool
$c<= :: Flavour -> Flavour -> Bool
< :: Flavour -> Flavour -> Bool
$c< :: Flavour -> Flavour -> Bool
compare :: Flavour -> Flavour -> Ordering
$ccompare :: Flavour -> Flavour -> Ordering
$cp1Ord :: Eq Flavour
Ord)

-- | @exts LHS@ is equivalent to @markdown+lhs@
-- @exts GitHubMarkdown@ is equivalent to @gfm@
-- @exts Html@ is equivalent to @html@
exts :: Flavour -> Extensions
exts :: Flavour -> Extensions
exts Flavour
LHS = Extension -> Extensions -> Extensions
enableExtension Extension
Ext_literate_haskell (Extensions -> Extensions) -> Extensions -> Extensions
forall a b. (a -> b) -> a -> b
$ Text -> Extensions
getDefaultExtensions Text
"markdown"
exts Flavour
GitHubMarkdown =
  Extension -> Extensions -> Extensions
enableExtension
    Extension
Ext_fenced_code_attributes
    Extensions
githubMarkdownExtensions
exts Flavour
Html = Text -> Extensions
getDefaultExtensions Text
"html"

-- |
-- 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 :: Block -> Block
tweakHaskellCodeBlock (CodeBlock (Text
id', [Text]
cs, [(Text, Text)]
kv) Text
b) =
  (Text, [Text], [(Text, Text)]) -> Text -> Block
CodeBlock (Text
id', [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [Text]
cs [Text
"haskell"] (Text
"haskell" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
cs), [(Text, Text)]
kv) Text
b
tweakHaskellCodeBlock Block
x = Block
x

-- | read a file into the pandoc AST
readPandoc :: FilePath -> Flavour -> IO (Either PandocError Pandoc)
readPandoc :: String -> Flavour -> IO (Either PandocError Pandoc)
readPandoc String
fp Flavour
f
  | Flavour
f Flavour -> Flavour -> Bool
forall a. Eq a => a -> a -> Bool
== Flavour
GitHubMarkdown = do
    Text
t <- IO Text -> IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
readFile String
fp
    PandocIO Pandoc -> IO (Either PandocError Pandoc)
forall a. PandocIO a -> IO (Either PandocError a)
runIO (PandocIO Pandoc -> IO (Either PandocError Pandoc))
-> PandocIO Pandoc -> IO (Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Text -> m Pandoc
readMarkdown (ReaderOptions
forall a. Default a => a
def :: ReaderOptions) {readerExtensions :: Extensions
readerExtensions = Flavour -> Extensions
exts Flavour
f} Text
t
  | Bool
otherwise = do
    Text
t <- IO Text -> IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
readFile String
fp
    PandocIO Pandoc -> IO (Either PandocError Pandoc)
forall a. PandocIO a -> IO (Either PandocError a)
runIO (PandocIO Pandoc -> IO (Either PandocError Pandoc))
-> PandocIO Pandoc -> IO (Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Text -> m Pandoc
readHtml (ReaderOptions
forall a. Default a => a
def :: ReaderOptions) {readerExtensions :: Extensions
readerExtensions = Flavour -> Extensions
exts Flavour
f} Text
t

-- | render a pandoc AST
--
-- >>> 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 :: Flavour -> Pandoc -> Either PandocError Text
renderPandoc Flavour
f (Pandoc Meta
meta [Block]
bs)
  | Flavour
f Flavour -> Flavour -> Bool
forall a. Eq a => a -> a -> Bool
== Flavour
Html = PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Either PandocError Text)
-> PandocPure Text -> Either PandocError Text
forall a b. (a -> b) -> a -> b
$ do
    Html
h <-
      WriterOptions -> Pandoc -> PandocPure Html
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Html
writeHtml5
        (WriterOptions
forall a. Default a => a
def :: WriterOptions) {writerExtensions :: Extensions
writerExtensions = Flavour -> Extensions
exts Flavour
f}
        (Meta -> [Block] -> Pandoc
Pandoc Meta
meta (Block -> Block
tweakHaskellCodeBlock (Block -> Block) -> [Block] -> [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block]
bs))
    Text -> PandocPure Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> PandocPure Text) -> Text -> PandocPure Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Html -> Text
Blaze.renderHtml Html
h
  | Bool
otherwise =
    PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Either PandocError Text)
-> PandocPure Text -> Either PandocError Text
forall a b. (a -> b) -> a -> b
$
      WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeMarkdown
        (WriterOptions
forall a. Default a => a
def :: WriterOptions) {writerExtensions :: Extensions
writerExtensions = Flavour -> Extensions
exts Flavour
f}
        (Meta -> [Block] -> Pandoc
Pandoc Meta
meta (Block -> Block
tweakHaskellCodeBlock (Block -> Block) -> [Block] -> [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block]
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 :: OutputMap -> Block -> [Block]
insertOutput OutputMap
m Block
b = case Block
b of
  b' :: Block
b'@(CodeBlock (Text
id', [Text]
classes, [(Text, Text)]
kv) Text
_) ->
    [Block] -> [Block] -> Bool -> [Block]
forall a. a -> a -> Bool -> a
bool
      [Block
b']
      ( [Block] -> (Text -> [Block]) -> Maybe Text -> [Block]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          [(Text, [Text], [(Text, Text)]) -> Text -> Block
CodeBlock (Text
id', [Text]
classes, [(Text, Text)]
kv) Text
forall a. Monoid a => a
mempty]
          ( \Text
x ->
              [Block] -> (Output -> [Block]) -> Maybe Output -> [Block]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                [(Text, [Text], [(Text, Text)]) -> Text -> Block
CodeBlock (Text
id', [Text]
classes, [(Text, Text)]
kv) Text
forall a. Monoid a => a
mempty]
                ( \case
                    Fence Text
t -> [(Text, [Text], [(Text, Text)]) -> Text -> Block
CodeBlock (Text
id', [Text]
classes, [(Text, Text)]
kv) Text
t]
                    Replace Text
t -> (Many Block -> [Block]
forall a. Many a -> [a]
B.toList (Many Block -> [Block]) -> Many Block -> [Block]
forall a b. (a -> b) -> a -> b
$ Inlines -> Many Block
plain (Text -> Inlines
str Text
t))
                    Native [Block]
bs -> [Block]
bs
                    RawHtml Text
h -> [Format -> Text -> Block
RawBlock (Text -> Format
Format Text
"html") Text
h]
                )
                (Text -> OutputMap -> Maybe Output
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
x OutputMap
m)
          )
          ([Text] -> Maybe Text
forall a. [a] -> Maybe a
headMay ([Text] -> Maybe Text)
-> (OutputMap -> [Text]) -> OutputMap -> Maybe Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes) ([Text] -> [Text]) -> (OutputMap -> [Text]) -> OutputMap -> [Text]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. OutputMap -> [Text]
forall k a. Map k a -> [k]
Map.keys (OutputMap -> Maybe Text) -> OutputMap -> Maybe Text
forall a b. (a -> b) -> a -> b
$ OutputMap
m)
      )
      (Text
"output" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes)
  Block
b' -> [Block
b']

insertOutputs :: OutputMap -> Pandoc -> Pandoc
insertOutputs :: OutputMap -> Pandoc -> Pandoc
insertOutputs OutputMap
out (Pandoc Meta
meta [Block]
bs) =
  Meta -> [Block] -> Pandoc
Pandoc Meta
meta ([[Block]] -> [Block]
forall a. Monoid a => [a] -> a
mconcat ([[Block]] -> [Block]) -> [[Block]] -> [Block]
forall a b. (a -> b) -> a -> b
$ OutputMap -> Block -> [Block]
insertOutput OutputMap
out (Block -> [Block]) -> [Block] -> [[Block]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block]
bs)

-- | add an output key-value pair to state
output :: (Monad m) => Text -> Output -> StateT OutputMap m ()
output :: Text -> Output -> StateT OutputMap m ()
output Text
k Output
v = (OutputMap -> OutputMap) -> StateT OutputMap m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Text -> Output -> OutputMap -> OutputMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
k Output
v)

-- | insert outputs into a new file
runOutput ::
  (FilePath, Flavour) ->
  (FilePath, Flavour) ->
  StateT OutputMap IO () ->
  IO (Either PandocError ())
runOutput :: (String, Flavour)
-> (String, Flavour)
-> StateT OutputMap IO ()
-> IO (Either PandocError ())
runOutput (String
fi, Flavour
flavi) (String
fo, Flavour
flavo) StateT OutputMap IO ()
out = do
  OutputMap
m <- StateT OutputMap IO () -> OutputMap -> IO OutputMap
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT OutputMap IO ()
out OutputMap
forall k a. Map k a
Map.empty
  Either PandocError Pandoc
p <- String -> Flavour -> IO (Either PandocError Pandoc)
readPandoc String
fi Flavour
flavi
  let w :: Either PandocError Text
w = do
        Pandoc
p' <- OutputMap -> Pandoc -> Pandoc
insertOutputs OutputMap
m (Pandoc -> Pandoc)
-> Either PandocError Pandoc -> Either PandocError Pandoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either PandocError Pandoc
p
        Flavour -> Pandoc -> Either PandocError Text
renderPandoc Flavour
flavo Pandoc
p'
  (PandocError -> IO (Either PandocError ()))
-> (Text -> IO (Either PandocError ()))
-> Either PandocError Text
-> IO (Either PandocError ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either PandocError () -> IO (Either PandocError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PandocError () -> IO (Either PandocError ()))
-> (PandocError -> Either PandocError ())
-> PandocError
-> IO (Either PandocError ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PandocError -> Either PandocError ()
forall a b. a -> Either a b
Left) (\Text
t -> String -> Text -> IO ()
writeFile String
fo Text
t IO () -> IO (Either PandocError ()) -> IO (Either PandocError ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either PandocError () -> IO (Either PandocError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either PandocError ()
forall a b. b -> Either a b
Right ())) Either PandocError Text
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 :: (Text, [Text], [(Text, Text)])
-> Inlines -> [ColSpec] -> [Inlines] -> [[Inlines]] -> Many Block
defaultTable (Text, [Text], [(Text, Text)])
attr Inlines
c [ColSpec]
cs [Inlines]
hs [[Inlines]]
rs = (Text, [Text], [(Text, Text)])
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Many Block
tableWith (Text, [Text], [(Text, Text)])
attr (Many Block -> Caption
simpleCaption (Inlines -> Many Block
plain Inlines
c)) [ColSpec]
cs ([Inlines] -> TableHead
thead [Inlines]
hs) ((TableBody -> [TableBody] -> [TableBody]
forall a. a -> [a] -> [a]
:[]) (TableBody -> [TableBody]) -> TableBody -> [TableBody]
forall a b. (a -> b) -> a -> b
$ [[Inlines]] -> TableBody
tbody [[Inlines]]
rs) TableFoot
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 :: (Text, [Text], [(Text, Text)])
-> Text -> [ColSpec] -> [Text] -> [[Text]] -> Many Block
defaultTextTable (Text, [Text], [(Text, Text)])
attr Text
c [ColSpec]
cs [Text]
hs [[Text]]
rs = (Text, [Text], [(Text, Text)])
-> Inlines -> [ColSpec] -> [Inlines] -> [[Inlines]] -> Many Block
defaultTable (Text, [Text], [(Text, Text)])
attr (Text -> Inlines
str Text
c) [ColSpec]
cs (Text -> Inlines
str (Text -> Inlines) -> [Text] -> [Inlines]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
hs) ((Text -> Inlines) -> [Text] -> [Inlines]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Inlines
str ([Text] -> [Inlines]) -> [[Text]] -> [[Inlines]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Text]]
rs)

-- | bootstrap classes
bootTableAttr :: Attr
bootTableAttr :: (Text, [Text], [(Text, Text)])
bootTableAttr = (Text
"",[Text
"table",Text
"table-bordered",Text
"table-hover",Text
"m-3"],[(Text
"style",Text
"width: 70%;")])

-- | aligned simple cell
cell1 :: Alignment -> Inlines -> Cell
cell1 :: Alignment -> Inlines -> Cell
cell1 Alignment
a Inlines
i = Alignment -> RowSpan -> ColSpan -> Many Block -> Cell
cell Alignment
a (Int -> RowSpan
RowSpan Int
1) (Int -> ColSpan
ColSpan Int
1) (Inlines -> Many Block
plain Inlines
i)

-- | aligned simple table header
thead :: [Inlines] -> TableHead
thead :: [Inlines] -> TableHead
thead [Inlines]
xs = (Text, [Text], [(Text, Text)]) -> [Row] -> TableHead
TableHead (Text, [Text], [(Text, Text)])
nullAttr ([Row] -> TableHead) -> ([Cell] -> [Row]) -> [Cell] -> TableHead
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Row -> [Row] -> [Row]
forall a. a -> [a] -> [a]
:[]) (Row -> [Row]) -> ([Cell] -> Row) -> [Cell] -> [Row]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text, [Text], [(Text, Text)]) -> [Cell] -> Row
Row (Text, [Text], [(Text, Text)])
nullAttr ([Cell] -> TableHead) -> [Cell] -> TableHead
forall a b. (a -> b) -> a -> b
$ (Many Block -> Cell
simpleCell (Many Block -> Cell) -> (Inlines -> Many Block) -> Inlines -> Cell
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Inlines -> Many Block
plain (Inlines -> Cell) -> [Inlines] -> [Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inlines]
xs)

-- | null table footer
nullTfoot :: TableFoot
nullTfoot :: TableFoot
nullTfoot = (Text, [Text], [(Text, Text)]) -> [Row] -> TableFoot
TableFoot (Text, [Text], [(Text, Text)])
nullAttr []

-- | aligned simple table body
tbody :: [[Inlines]] -> TableBody
tbody :: [[Inlines]] -> TableBody
tbody [[Inlines]]
xs = (Text, [Text], [(Text, Text)])
-> RowHeadColumns -> [Row] -> [Row] -> TableBody
TableBody (Text, [Text], [(Text, Text)])
nullAttr (Int -> RowHeadColumns
RowHeadColumns Int
0) [] ((Text, [Text], [(Text, Text)]) -> [Cell] -> Row
Row (Text, [Text], [(Text, Text)])
nullAttr ([Cell] -> Row) -> [[Cell]] -> [Row]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Inlines -> Cell) -> [Inlines] -> [Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Many Block -> Cell
simpleCell (Many Block -> Cell) -> (Inlines -> Many Block) -> Inlines -> Cell
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Inlines -> Many Block
plain) ([Inlines] -> [Cell]) -> [[Inlines]] -> [[Cell]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Inlines]]
xs))

-- | haskell code block
hask :: Maybe Text -> Text -> Inlines
hask :: Maybe Text -> Text -> Inlines
hask Maybe Text
name Text
t = (Text, [Text], [(Text, Text)]) -> Text -> Inlines
codeWith (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
forall a. Monoid a => a
mempty Maybe Text
name, [Text
"sourceCode",Text
"literate",Text
"haskell"], []) Text
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 :: Text -> Text -> Text -> Inlines
badge Text
label Text
badge' Text
url =
  Inline -> Inlines
forall a. a -> Many a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$
  (Text, [Text], [(Text, Text)])
-> [Inline] -> (Text, Text) -> Inline
Link (Text
"", [], [])
  [(Text, [Text], [(Text, Text)])
-> [Inline] -> (Text, Text) -> Inline
Image (Text
"", [], []) [Text -> Inline
Str Text
label] (Text
badge', Text
"")]
  (Text
url, Text
"")