{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Readme.Lhs
(
Flavour (..),
readPandoc,
renderPandoc,
Output (..),
OutputMap,
output,
insertOutput,
runOutput,
tweakHaskellCodeBlock,
defaultTable,
defaultTextTable,
bootTableAttr,
thead,
tbody,
cell1,
badge,
hask,
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
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 :: 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"
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
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
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))
data Output = Native [Block] | Replace Text | Fence Text | RawHtml Text
type OutputMap = Map Text Output
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)
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)
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
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
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)
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%;")])
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)
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)
nullTfoot :: TableFoot
= (Text, [Text], [(Text, Text)]) -> [Row] -> TableFoot
TableFoot (Text, [Text], [(Text, Text)])
nullAttr []
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))
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
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
"")