publish-0.4.4: src/PandocToMarkdown.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module PandocToMarkdown
( pandocToMarkdown
, NotSafe(..)
, Rectangle(..)
, rectanglerize
, combineRectangles
, buildRow
, widthOf
, heightOf
, tableToMarkdown
)
where
import Control.DeepSeq (NFData)
import Core.Text
import Core.System
import Data.Foldable (foldl')
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.List (intersperse)
import GHC.Generics (Generic)
import Text.Pandoc (Pandoc(..), Block(..), Inline(..), Attr, Format(..)
, ListAttributes, Alignment(..), TableCell, MathType(..), QuoteType(..))
import Text.Pandoc.Shared (orderedListMarkers)
__WIDTH__ :: Int
__WIDTH__ = 78
pandocToMarkdown :: Pandoc -> Rope
pandocToMarkdown (Pandoc _ blocks) =
blocksToMarkdown __WIDTH__ blocks
blocksToMarkdown :: Int -> [Block] -> Rope
blocksToMarkdown _ [] = emptyRope
blocksToMarkdown margin (block1:blocks) =
convertBlock margin block1 <> foldl'
(\text block -> text <> "\n" <> convertBlock margin block) emptyRope blocks
convertBlock :: Int -> Block -> Rope
convertBlock margin block =
let
msg = "Unfinished block: " ++ show block -- FIXME
in case block of
Plain inlines -> plaintextToMarkdown margin inlines
Para inlines -> paragraphToMarkdown margin inlines
Header level _ inlines -> headingToMarkdown level inlines
Null -> emptyRope
RawBlock (Format "tex") string -> intoRope string <> "\n"
RawBlock (Format "html") string -> intoRope string <> "\n"
RawBlock _ _ -> error msg
CodeBlock attr string -> codeToMarkdown attr string
LineBlock list -> poemToMarkdown list
BlockQuote blocks -> quoteToMarkdown margin blocks
BulletList blockss -> bulletlistToMarkdown margin blockss
OrderedList attrs blockss -> orderedlistToMarkdown margin attrs blockss
DefinitionList blockss -> definitionlistToMarkdown margin blockss
HorizontalRule -> "---\n"
Table caption alignments relatives headers rows -> tableToMarkdown caption alignments relatives headers rows
Div attr blocks -> divToMarkdown margin attr blocks
{-
This does **not** emit a newline at the end. The intersperse happening in
`blocksToMarkdown` will terminate the line, but you won't get a blank line
between blocks as is the convention everywhere else (this was critical when
lists were nested in tight lists).
-}
plaintextToMarkdown :: Int -> [Inline] -> Rope
plaintextToMarkdown margin inlines =
wrap' margin (inlinesToMarkdown inlines)
{-
Everything was great until we had to figure out how to deal with line
breaks aka <BR>, represented in Markdown by [' ',' ']. We do this by
replacing the line break Inline with \x2028. This character, U+2028 LS, is
the Line Separator character. It's one of those symbols up in General
Punctuation that no one ever uses. So we use it as a sentinel internally
here; first we break on those, and then we wrap the results.
-}
paragraphToMarkdown :: Int -> [Inline] -> Rope
paragraphToMarkdown margin inlines =
wrap' margin (inlinesToMarkdown inlines) <> "\n"
wrap' :: Int -> Rope -> Rope
wrap' margin =
mconcat . intersperse " \n" . fmap (wrap margin) . breakPieces isLineSeparator
where
isLineSeparator = (== '\x2028')
headingToMarkdown :: Int -> [Inline] -> Rope
headingToMarkdown level inlines =
let
text = inlinesToMarkdown inlines
in
case level of
1 -> text <> "\n" <> underline '=' text <> "\n"
2 -> text <> "\n" <> underline '-' text <> "\n"
n -> intoRope (replicate n '#') <> " " <> text <> "\n"
codeToMarkdown :: Attr -> String -> Rope
codeToMarkdown attr literal =
let
body = intoRope literal
lang = fencedAttributesToMarkdown attr
in
"```" <> lang <> "\n" <>
body <> "\n" <>
"```" <> "\n"
poemToMarkdown :: [[Inline]] -> Rope
poemToMarkdown list =
mconcat (intersperse "\n" (fmap prefix list)) <> "\n"
where
prefix inlines = "| " <> inlinesToMarkdown inlines
quoteToMarkdown :: Int -> [Block] -> Rope
quoteToMarkdown margin blocks =
foldl' (\text block -> text <> prefix block) emptyRope blocks
where
prefix :: Block -> Rope
prefix = foldl' (\text line -> text <> "> " <> line <> "\n") emptyRope . rows
rows :: Block -> [Rope]
rows = breakLines . convertBlock (margin - 2)
bulletlistToMarkdown :: Int -> [[Block]] -> Rope
bulletlistToMarkdown = listToMarkdown (repeat "- ")
orderedlistToMarkdown :: Int -> ListAttributes -> [[Block]] -> Rope
orderedlistToMarkdown margin (num,style,delim) blockss =
listToMarkdown (intoMarkers (num,style,delim)) margin blockss
where
intoMarkers = fmap pad . fmap intoRope . orderedListMarkers
pad text = text <> if widthRope text > 2 then " " else " "
definitionlistToMarkdown :: Int -> [([Inline],[[Block]])] -> Rope
definitionlistToMarkdown margin definitions =
case definitions of
[] -> emptyRope
(definition1:definitionN) -> handleDefinition definition1 <> foldl'
(\text definition -> text <> "\n" <> handleDefinition definition) emptyRope definitionN
where
handleDefinition :: ([Inline],[[Block]]) -> Rope
handleDefinition (term,blockss) =
inlinesToMarkdown term <> "\n\n" <> listToMarkdown (repeat ": ") margin blockss
listToMarkdown :: [Rope] -> Int -> [[Block]] -> Rope
listToMarkdown markers margin items =
case pairs of
[] -> emptyRope
((marker1,blocks1):pairsN) -> listitem marker1 blocks1 <> foldl'
(\text (markerN,blocksN) -> text <> spacer blocksN <> listitem markerN blocksN) emptyRope pairsN
where
pairs = zip markers items
listitem :: Rope -> [Block] -> Rope
listitem _ [] = emptyRope
listitem marker blocks = indent marker blocks
{-
Tricky. Tight lists are represented by Plain, whereas more widely spaced
lists are represented by Para. A complex block (specifically a nested
list!) will handle its own spacing. This seems fragile.
-}
spacer :: [Block] -> Rope
spacer [] = emptyRope
spacer (block:_) = case block of
Plain _ -> emptyRope
Para _ -> "\n"
_ -> emptyRope -- ie nested list
indent :: Rope -> [Block] -> Rope
indent marker =
snd . foldl' (f marker) (True,emptyRope) . breakLines . blocksToMarkdown (margin - 4)
f :: Rope -> (Bool,Rope) -> Rope -> (Bool,Rope)
f marker (first,text) line
| nullRope line =
(False,text <> "\n") -- don't indent lines that should be blank
| otherwise =
if first
then (False,text <> marker <> line <> "\n")
else (False,text <> " " <> line <> "\n")
{-
In Pandoc flavoured Markdown, <div> are recognized as valid Markdown via
the `native_divs` extension. We turn that off, in favour of the
`fenced_divs` extension, three (or more) colons
::: {#identifier .class key=value}
Content
:::
-}
divToMarkdown :: Int -> Attr -> [Block] -> Rope
divToMarkdown margin attr blocks =
let
first = ":::" <> fencedAttributesToMarkdown attr
trail = ":::"
content = mconcat . intersperse "\n" . fmap (convertBlock margin)
in
first <> "\n" <> content blocks <> trail <> "\n"
-- special case for (notably) code blocks where a single class doesn't need braces.
fencedAttributesToMarkdown :: Attr -> Rope
fencedAttributesToMarkdown ("", [], []) = emptyRope
fencedAttributesToMarkdown ("", [single], []) = intoRope single
fencedAttributesToMarkdown (identifier, [], []) = " " <> attributesToMarkdown (identifier, [], [])
fencedAttributesToMarkdown (identifier, classes, pairs) = " " <> attributesToMarkdown (identifier, classes, pairs)
-- present attributes, used by both fenced blocks and inline spans
attributesToMarkdown :: Attr -> Rope
attributesToMarkdown ("", [], []) = emptyRope
attributesToMarkdown (identifier, [], []) = "{#" <> intoRope identifier <> "}"
attributesToMarkdown (identifier, classes, pairs) =
let
i = if null identifier
then emptyRope
else "#" <> intoRope identifier <> " "
cs = fmap (\c -> "." <> intoRope c) classes
ps = fmap (\ (k,v) -> intoRope k <> "=" <> intoRope v) pairs
in
"{" <> i <> mconcat (intersperse " " (cs ++ ps)) <> "}"
tableToMarkdown
:: [Inline]
-> [Alignment]
-> [Double]
-> [TableCell]
-> [[TableCell]]
-> Rope
tableToMarkdown _ alignments relatives headers rows =
mconcat (intersperse "\n"
[ wrapperLine
, header
, underlineHeaders
, body
, wrapperLine
]) <> "\n"
where
header = rowToMarkdown headers
bodylines = fmap rowToMarkdown rows
body = mconcat (intersperse "\n\n" bodylines)
sizes :: [Int]
sizes =
let
total = fromIntegral __WIDTH__
-- there's a weird thing where sometimes (in pipe tables?) the
-- value of relative is 0. If that happens, pick a value.
-- TODO Better heuristic? Because, this will break if cell too wide.
f x | x == 0.0 = 14
| otherwise = floor (total * x)
in
fmap (fromInteger . f) relatives
overall = sum sizes + (length headers) - 1
wrapperLine = intoRope (replicate overall '-')
rowToMarkdown :: [TableCell] -> Rope
rowToMarkdown = buildRow sizes . fmap convert . zipWith3
(\size align (block:_) -> (size,align,block)) sizes alignments
underlineHeaders :: Rope
underlineHeaders =
foldl' (<>) emptyRope . intersperse " "
. fmap (\size -> intoRope (replicate size '-'))
. take (length headers) $ sizes
convert :: (Int,Alignment,Block) -> Rectangle
convert (size,align,Plain inlines) =
rectanglerize size align (plaintextToMarkdown size inlines)
convert (_,_,_) =
impureThrow (NotSafe "Incorrect Block type encountered")
data NotSafe = NotSafe String
deriving Show
instance Exception NotSafe
data Rectangle = Rectangle Int Int [Rope]
deriving (Eq, Show, Generic, NFData)
widthOf :: Rectangle -> Int
widthOf (Rectangle size _ _) = size
heightOf :: Rectangle -> Int
heightOf (Rectangle _ height _) = height
rowsFrom :: Rectangle -> [Rope]
rowsFrom (Rectangle _ _ texts) = texts
instance Semigroup Rectangle where
(<>) = combineRectangles
instance Monoid Rectangle where
mempty = Rectangle 0 0 []
rectanglerize :: Int -> Alignment -> Rope -> Rectangle
rectanglerize size align text =
let
ls = breakLines (wrap size text)
fix l | widthRope l < size =
let
padding = size - widthRope l
(left,remain) = divMod padding 2
right = left + remain
in case align of
AlignCenter -> intoRope (replicate left ' ') <> l <> intoRope (replicate right ' ')
AlignRight -> intoRope (replicate padding ' ') <> l
AlignLeft -> l <> intoRope (replicate padding ' ')
AlignDefault -> l <> intoRope (replicate padding ' ')
| widthRope l == size = case align of
AlignRight -> impureThrow (NotSafe "Column width insufficient to show alignment")
_ -> l
| otherwise = impureThrow (NotSafe "Line wider than permitted size")
result = foldr (\l acc -> fix l:acc) [] ls
in
Rectangle size (length result) result
combineRectangles :: Rectangle -> Rectangle -> Rectangle
combineRectangles rect1@(Rectangle size1 height1 _) rect2@(Rectangle size2 height2 _) =
let
target = max height1 height2
extra1 = target - height1
extra2 = target - height2
padRows :: Int -> Rectangle -> [Rope]
padRows count (Rectangle size _ texts) =
let
texts' = texts ++ replicate count (intoRope (replicate size ' '))
in
texts'
texts1' = padRows extra1 rect1
texts2' = padRows extra2 rect2
pairs = zip texts1' texts2'
result = foldr (\ (text1,text2) texts -> text1 <> text2 : texts) [] pairs
in
Rectangle (size1 + size2) target result
ensureWidth :: Int -> Rectangle -> Rectangle
ensureWidth request rect =
if widthOf rect < request
then rectanglerize request AlignLeft (foldl' (<>) emptyRope (rowsFrom rect))
else rect
buildRow :: [Int] -> [Rectangle] -> Rope
buildRow cellWidths rects =
let
pairs = zip cellWidths rects
rects' = fmap (\ (desired,rect) -> ensureWidth desired rect) pairs
wall = vertical ' ' rects'
result = foldl' (<>) mempty . intersperse wall $ rects'
in
foldl' (<>) emptyRope (intersperse "\n" (rowsFrom result))
vertical :: Char -> [Rectangle] -> Rectangle
vertical ch rects =
let
height = maximum (fmap heightOf rects)
border = replicate height (intoRope [ch])
in
Rectangle 1 height border
---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
inlinesToMarkdown :: [Inline] -> Rope
inlinesToMarkdown inlines =
foldl' (\text inline -> appendRope (convertInline inline) text) emptyRope inlines
convertInline :: Inline -> Rope
convertInline inline =
let
msg = "Unfinished inline: " ++ show inline
in case inline of
Space -> " "
Str string -> stringToMarkdown string
Emph inlines -> "_" <> inlinesToMarkdown inlines <> "_"
Strong inlines -> "**" <> inlinesToMarkdown inlines <> "**"
SoftBreak -> " "
LineBreak -> "\x2028"
Image attr inlines target -> imageToMarkdown attr inlines target
Code _ string -> "`" <> intoRope string <> "`"
RawInline (Format "tex") string -> intoRope string
RawInline (Format "html") string -> intoRope string
RawInline _ _ -> error msg
Link ("",["uri"],[]) _ (url, _) -> uriToMarkdown url
Link attr inlines target -> linkToMarkdown attr inlines target
Strikeout inlines -> "~~" <> inlinesToMarkdown inlines <> "~~"
Math mode string -> mathToMarkdown mode string
-- then things start getting weird
SmallCaps inlines -> smallcapsToMarkdown inlines
Subscript inlines -> "~" <> inlinesToMarkdown inlines <> "~"
Superscript inlines -> "^" <> inlinesToMarkdown inlines <> "^"
Span attr inlines -> spanToMarkdown attr inlines
-- I don't know what the point of these ones are
Quoted SingleQuote inlines -> "'" <> inlinesToMarkdown inlines <> "'"
Quoted DoubleQuote inlines -> "\"" <> inlinesToMarkdown inlines <> "\""
_ -> error msg
{-
Pandoc uses U+00A0 aka ASCII 160 aka to mark a non-breaking space, which
seems to be how it describes an escaped space in Markdown. So scan for these
and replace the escaped space on output.
-}
stringToMarkdown :: String -> Rope
stringToMarkdown =
mconcat . intersperse "\\ " . breakPieces isNonBreaking . intoRope
where
isNonBreaking c = c == '\x00a0'
imageToMarkdown :: Attr -> [Inline] -> (String,String) -> Rope
imageToMarkdown attr inlines (url,title) =
let
alt = inlinesToMarkdown inlines
target = case title of
[] -> intoRope url
_ -> intoRope url <> " \"" <> intoRope title <> "\""
in
"![" <> alt <> "](" <> target <> ")" <> attributesToMarkdown attr
uriToMarkdown :: String -> Rope
uriToMarkdown url =
let
target = intoRope url
in
"<" <> target <> ">"
linkToMarkdown :: Attr -> [Inline] -> (String,String) -> Rope
linkToMarkdown attr inlines (url,title) =
let
text = inlinesToMarkdown inlines
target = case title of
[] -> intoRope url
_ -> intoRope url <> " \"" <> intoRope title <> "\""
in
"[" <> text <> "](" <> target <> ")" <> attributesToMarkdown attr
-- is there more to this?
mathToMarkdown :: MathType -> String -> Rope
mathToMarkdown (InlineMath) math = "$" <> intoRope math <> "$"
mathToMarkdown (DisplayMath) math = "$$" <> intoRope math <> "$$"
smallcapsToMarkdown :: [Inline] -> Rope
smallcapsToMarkdown inlines =
let
text = inlinesToMarkdown inlines
in
"[" <> text <> "]{.smallcaps}"
spanToMarkdown :: Attr -> [Inline] -> Rope
spanToMarkdown attr inlines =
let
text = inlinesToMarkdown inlines
in
"[" <> text <> "]" <> attributesToMarkdown attr