aboutsummaryrefslogtreecommitdiff
path: root/src/Text
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text')
-rw-r--r--src/Text/Pandoc/Parsing.hs2
-rw-r--r--src/Text/Pandoc/Readers/HTML.hs34
-rw-r--r--src/Text/Pandoc/Readers/LaTeX.hs104
-rw-r--r--src/Text/Pandoc/Readers/Muse.hs68
-rw-r--r--src/Text/Pandoc/Readers/RST.hs18
-rw-r--r--src/Text/Pandoc/Writers/HTML.hs11
-rw-r--r--src/Text/Pandoc/Writers/Markdown.hs18
-rw-r--r--src/Text/Pandoc/Writers/Org.hs63
8 files changed, 214 insertions, 104 deletions
diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs
index 9ed18d4e0..2543f11f0 100644
--- a/src/Text/Pandoc/Parsing.hs
+++ b/src/Text/Pandoc/Parsing.hs
@@ -838,7 +838,7 @@ blankLineBlockLine = try (char '|' >> blankline)
lineBlockLines :: Monad m => ParserT [Char] st m [String]
lineBlockLines = try $ do
lines' <- many1 (lineBlockLine <|> ((:[]) <$> blankLineBlockLine))
- skipMany1 $ blankline <|> blankLineBlockLine
+ skipMany $ blankline
return lines'
-- | Parse a table using 'headerParser', 'rowParser',
diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index d85488478..2093be19c 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -58,7 +58,7 @@ import Data.Maybe ( fromMaybe, isJust, isNothing )
import Data.List.Split ( wordsBy )
import Data.List ( intercalate, isPrefixOf )
import Data.Char ( isDigit, isLetter, isAlphaNum )
-import Control.Monad ( guard, mzero, void, unless, mplus )
+import Control.Monad ( guard, mzero, void, unless, mplus, msum )
import Control.Arrow ((***))
import Control.Applicative ( (<|>) )
import Data.Monoid (First (..))
@@ -576,23 +576,23 @@ pPara = do
return $ B.para contents
pFigure :: PandocMonad m => TagParser m Blocks
-pFigure = do
+pFigure = try $ do
TagOpen _ _ <- pSatisfy (matchTagOpen "figure" [])
skipMany pBlank
- let pImg = pOptInTag "p" pImage <* skipMany pBlank
- pCapt = option mempty $ pInTags "figcaption" inline <* skipMany pBlank
- pImgCapt = do
- img <- pImg
- cap <- pCapt
- return (img, cap)
- pCaptImg = do
- cap <- pCapt
- img <- pImg
- return (img, cap)
- (imgMany, caption) <- pImgCapt <|> pCaptImg
+ let pImg = (\x -> (Just x, Nothing)) <$>
+ (pOptInTag "p" pImage <* skipMany pBlank)
+ pCapt = (\x -> (Nothing, Just x)) <$>
+ (pInTags "figcaption" inline <* skipMany pBlank)
+ pSkip = (Nothing, Nothing) <$ pSatisfy (not . matchTagClose "figure")
+ res <- many (pImg <|> pCapt <|> pSkip)
+ let mbimg = msum $ map fst res
+ let mbcap = msum $ map snd res
TagClose _ <- pSatisfy (matchTagClose "figure")
- let (Image attr _ (url, tit)):_ = B.toList imgMany
- return $ B.para $ B.imageWith attr url ("fig:" ++ tit) caption
+ let caption = fromMaybe mempty mbcap
+ case B.toList <$> mbimg of
+ Just [Image attr _ (url, tit)] ->
+ return $ B.para $ B.imageWith attr url ("fig:" ++ tit) caption
+ _ -> mzero
pCodeBlock :: PandocMonad m => TagParser m Blocks
pCodeBlock = try $ do
@@ -961,7 +961,7 @@ blockHtmlTags = Set.fromList
"dir", "div", "dl", "dt", "fieldset", "figcaption", "figure",
"footer", "form", "h1", "h2", "h3", "h4",
"h5", "h6", "head", "header", "hgroup", "hr", "html",
- "isindex", "main", "menu", "noframes", "ol", "output", "p", "pre",
+ "isindex", "main", "menu", "meta", "noframes", "ol", "output", "p", "pre",
"section", "table", "tbody", "textarea",
"thead", "tfoot", "ul", "dd",
"dt", "frameset", "li", "tbody", "td", "tfoot",
@@ -1048,7 +1048,7 @@ x `closes` "p" | x `elem` ["address", "article", "aside", "blockquote",
"dir", "div", "dl", "fieldset", "footer", "form", "h1", "h2", "h3", "h4",
"h5", "h6", "header", "hr", "main", "menu", "nav", "ol", "p", "pre", "section",
"table", "ul"] = True
-"meta" `closes` "meta" = True
+_ `closes` "meta" = True
"form" `closes` "form" = True
"label" `closes` "label" = True
"map" `closes` "map" = True
diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs
index 3292550b2..d0e95bd85 100644
--- a/src/Text/Pandoc/Readers/LaTeX.hs
+++ b/src/Text/Pandoc/Readers/LaTeX.hs
@@ -44,7 +44,7 @@ import Control.Applicative (many, optional, (<|>))
import Control.Monad
import Control.Monad.Except (throwError)
import Control.Monad.Trans (lift)
-import Data.Char (chr, isAlphaNum, isLetter, ord, isDigit)
+import Data.Char (chr, isAlphaNum, isLetter, ord, isDigit, toLower)
import Data.Default
import Data.Text (Text)
import qualified Data.Text as T
@@ -770,11 +770,13 @@ keyval = try $ do
keyvals :: PandocMonad m => LP m [(String, String)]
keyvals = try $ symbol '[' >> manyTill keyval (symbol ']')
-accent :: (Char -> String) -> Inlines -> LP m Inlines
-accent f ils =
+accent :: PandocMonad m => Char -> (Char -> String) -> LP m Inlines
+accent c f = try $ do
+ ils <- tok
case toList ils of
(Str (x:xs) : ys) -> return $ fromList (Str (f x ++ xs) : ys)
- [] -> mzero
+ [Space] -> return $ str [c]
+ [] -> return $ str [c]
_ -> return ils
grave :: Char -> String
@@ -961,6 +963,19 @@ hacek 'Z' = "Ž"
hacek 'z' = "ž"
hacek c = [c]
+ogonek :: Char -> String
+ogonek 'a' = "ą"
+ogonek 'e' = "ę"
+ogonek 'o' = "ǫ"
+ogonek 'i' = "į"
+ogonek 'u' = "ų"
+ogonek 'A' = "Ą"
+ogonek 'E' = "Ę"
+ogonek 'I' = "Į"
+ogonek 'O' = "Ǫ"
+ogonek 'U' = "Ų"
+ogonek c = [c]
+
breve :: Char -> String
breve 'A' = "Ă"
breve 'a' = "ă"
@@ -1275,17 +1290,19 @@ inlineCommands = M.fromList $
, ("copyright", lit "©")
, ("textasciicircum", lit "^")
, ("textasciitilde", lit "~")
- , ("H", try $ tok >>= accent hungarumlaut)
- , ("`", option (str "`") $ try $ tok >>= accent grave)
- , ("'", option (str "'") $ try $ tok >>= accent acute)
- , ("^", option (str "^") $ try $ tok >>= accent circ)
- , ("~", option (str "~") $ try $ tok >>= accent tilde)
- , ("\"", option (str "\"") $ try $ tok >>= accent umlaut)
- , (".", option (str ".") $ try $ tok >>= accent dot)
- , ("=", option (str "=") $ try $ tok >>= accent macron)
- , ("c", option (str "c") $ try $ tok >>= accent cedilla)
- , ("v", option (str "v") $ try $ tok >>= accent hacek)
- , ("u", option (str "u") $ try $ tok >>= accent breve)
+ , ("H", accent '\779' hungarumlaut)
+ , ("`", accent '`' grave)
+ , ("'", accent '\'' acute)
+ , ("^", accent '^' circ)
+ , ("~", accent '~' tilde)
+ , ("\"", accent '\776' umlaut)
+ , (".", accent '\775' dot)
+ , ("=", accent '\772' macron)
+ , ("c", accent '\807' cedilla)
+ , ("v", accent 'ˇ' hacek)
+ , ("u", accent '\774' breve)
+ , ("k", accent '\808' ogonek)
+ , ("textogonekcentered", accent '\808' ogonek)
, ("i", lit "i")
, ("\\", linebreak <$ (do inTableCell <- sInTableCell <$> getState
guard $ not inTableCell
@@ -1391,11 +1408,8 @@ inlineCommands = M.fromList $
<|> citation "citeauthor" AuthorInText False)
, ("nocite", mempty <$ (citation "nocite" NormalCitation False >>=
addMeta "nocite"))
- -- hyperlink: for now, we just preserve contents.
- -- we might add the actual links, but we need to avoid clashes
- -- with ids produced by label.
- , ("hypertarget", braced >> tok)
- , ("hyperlink", braced >> tok)
+ , ("hyperlink", hyperlink)
+ , ("hypertarget", hypertargetInline)
-- glossaries package
, ("gls", doAcronym "short")
, ("Gls", doAcronym "short")
@@ -1445,8 +1459,56 @@ inlineCommands = M.fromList $
, ("toggletrue", braced >>= setToggle True)
, ("togglefalse", braced >>= setToggle False)
, ("iftoggle", try $ ifToggle >> inline)
+ -- biblatex misc
+ , ("RN", romanNumeralUpper)
+ , ("Rn", romanNumeralLower)
]
+hyperlink :: PandocMonad m => LP m Inlines
+hyperlink = try $ do
+ src <- toksToString <$> braced
+ lab <- tok
+ return $ link ('#':src) "" lab
+
+hypertargetBlock :: PandocMonad m => LP m Blocks
+hypertargetBlock = try $ do
+ ref <- toksToString <$> braced
+ bs <- grouped block
+ case toList bs of
+ [Header 1 (ident,_,_) _] | ident == ref -> return bs
+ _ -> return $ divWith (ref, [], []) bs
+
+hypertargetInline :: PandocMonad m => LP m Inlines
+hypertargetInline = try $ do
+ ref <- toksToString <$> braced
+ ils <- grouped inline
+ return $ spanWith (ref, [], []) ils
+
+romanNumeralUpper :: (PandocMonad m) => LP m Inlines
+romanNumeralUpper =
+ str . toRomanNumeral <$> romanNumeralArg
+
+romanNumeralLower :: (PandocMonad m) => LP m Inlines
+romanNumeralLower =
+ str . map toLower . toRomanNumeral <$> romanNumeralArg
+
+romanNumeralArg :: (PandocMonad m) => LP m Int
+romanNumeralArg = spaces *> (parser <|> inBraces)
+ where
+ inBraces = do
+ symbol '{'
+ spaces
+ res <- parser
+ spaces
+ symbol '}'
+ return res
+ parser = do
+ Tok _ Word s <- satisfyTok isWordTok
+ let (digits, rest) = T.span isDigit s
+ unless (T.null rest) $
+ fail "Non-digits in argument to \\Rn or \\RN"
+ safeRead $ T.unpack digits
+
newToggle :: (Monoid a, PandocMonad m) => [Tok] -> LP m a
newToggle name = do
updateState $ \st ->
@@ -1944,7 +2006,7 @@ blockCommands = M.fromList $
, ("setdefaultlanguage", setDefaultLanguage)
, ("setmainlanguage", setDefaultLanguage)
-- hyperlink
- , ("hypertarget", try $ braced >> grouped block)
+ , ("hypertarget", hypertargetBlock)
-- LaTeX colors
, ("textcolor", coloredBlock "color")
, ("colorbox", coloredBlock "background-color")
diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs
index 74622a639..2454057fa 100644
--- a/src/Text/Pandoc/Readers/Muse.hs
+++ b/src/Text/Pandoc/Readers/Muse.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
{-
Copyright (C) 2017 Alexander Krotov <ilabdsf@gmail.com>
@@ -32,7 +33,6 @@ TODO:
- {{{ }}} syntax for <example>
- Page breaks (five "*")
- Headings with anchors (make it round trip with Muse writer)
-- <verse> and ">"
- Org tables
- table.el tables
- Images with attributes (floating and width)
@@ -101,6 +101,9 @@ parseBlocks = do
-- utility functions
--
+eol :: Stream s m Char => ParserT s st m ()
+eol = void newline <|> eof
+
nested :: PandocMonad m => MuseParser m a -> MuseParser m a
nested p = do
nestlevel <- stateMaxNestingLevel <$> getState
@@ -180,6 +183,9 @@ blockElements = choice [ comment
, centerTag
, rightTag
, quoteTag
+ , divTag
+ , verseTag
+ , lineBlock
, bulletList
, orderedList
, definitionList
@@ -193,7 +199,7 @@ comment = try $ do
char ';'
space
many $ noneOf "\n"
- void newline <|> eof
+ eol
return mempty
separator :: PandocMonad m => MuseParser m (F Blocks)
@@ -201,7 +207,7 @@ separator = try $ do
string "----"
many $ char '-'
many spaceChar
- void newline <|> eof
+ eol
return $ return B.horizontalRule
header :: PandocMonad m => MuseParser m (F Blocks)
@@ -211,8 +217,8 @@ header = try $ do
getPosition >>= \pos -> guard (st == NullState && q == NoQuote && sourceColumn pos == 1)
level <- liftM length $ many1 $ char '*'
guard $ level <= 5
- skipSpaces
- content <- trimInlinesF . mconcat <$> manyTill inline newline
+ spaceChar
+ content <- trimInlinesF . mconcat <$> manyTill inline eol
attr <- registerHeader ("", [], []) (runF content defaultParserState)
return $ B.headerWith attr level <$> content
@@ -244,6 +250,30 @@ rightTag = blockTag id "right"
quoteTag :: PandocMonad m => MuseParser m (F Blocks)
quoteTag = withQuoteContext InDoubleQuote $ blockTag B.blockQuote "quote"
+-- <div> tag is supported by Emacs Muse, but not Amusewiki 2.025
+divTag :: PandocMonad m => MuseParser m (F Blocks)
+divTag = do
+ (attrs, content) <- parseHtmlContentWithAttrs "div" block
+ return $ (B.divWith attrs) <$> mconcat content
+
+verseLine :: PandocMonad m => MuseParser m String
+verseLine = do
+ line <- anyLine <|> many1Till anyChar eof
+ let (white, rest) = span (== ' ') line
+ return $ replicate (length white) '\160' ++ rest
+
+verseLines :: PandocMonad m => MuseParser m (F Blocks)
+verseLines = do
+ optionMaybe blankline -- Skip blankline after opening tag on separate line
+ lns <- many verseLine
+ lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns
+ return $ B.lineBlock <$> sequence lns'
+
+verseTag :: PandocMonad m => MuseParser m (F Blocks)
+verseTag = do
+ (_, content) <- htmlElement "verse"
+ parseFromString verseLines content
+
commentTag :: PandocMonad m => MuseParser m (F Blocks)
commentTag = parseHtmlContent "comment" anyChar >> return mempty
@@ -280,6 +310,26 @@ noteBlock = try $ do
many1Till block (eof <|> () <$ lookAhead noteMarker)
--
+-- Verse markup
+--
+
+lineVerseLine :: PandocMonad m => MuseParser m String
+lineVerseLine = try $ do
+ char '>'
+ white <- many1 (char ' ' >> pure '\160')
+ rest <- anyLine
+ return $ tail white ++ rest
+
+blanklineVerseLine :: PandocMonad m => MuseParser m Char
+blanklineVerseLine = try $ char '>' >> blankline
+
+lineBlock :: PandocMonad m => MuseParser m (F Blocks)
+lineBlock = try $ do
+ lns <- many1 (pure <$> blanklineVerseLine <|> lineVerseLine)
+ lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns
+ return $ B.lineBlock <$> sequence lns'
+
+--
-- lists
--
@@ -359,8 +409,8 @@ definitionListItem = try $ do
pure $ do lineContent' <- lineContent
pure (B.text term, [lineContent'])
where
- termParser = (many1 spaceChar) >> -- Initial space as required by Amusewiki, but not Emacs Muse
- (many1Till anyChar $ lookAhead (void (try (spaceChar >> string "::")) <|> void newline))
+ termParser = many1 spaceChar >> -- Initial space as required by Amusewiki, but not Emacs Muse
+ many1Till anyChar (lookAhead (void (try (spaceChar >> string "::")) <|> void newline))
endOfInput = try $ skipMany blankline >> skipSpaces >> eof
twoBlankLines = try $ blankline >> skipMany1 blankline
newDefinitionListItem = try $ void termParser
@@ -418,10 +468,10 @@ museAppendElement tbl element =
tableCell :: PandocMonad m => MuseParser m (F Blocks)
tableCell = try $ liftM B.plain . trimInlinesF . mconcat <$> manyTill inline (lookAhead cellEnd)
- where cellEnd = try $ void (many1 spaceChar >> char '|') <|> void newline <|> eof
+ where cellEnd = try $ void (many1 spaceChar >> char '|') <|> eol
tableElements :: PandocMonad m => MuseParser m [MuseTableElement]
-tableElements = tableParseElement `sepEndBy1` (void newline <|> eof)
+tableElements = tableParseElement `sepEndBy1` eol
elementsToTable :: [MuseTableElement] -> F MuseTable
elementsToTable = foldM museAppendElement emptyTable
diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs
index 190b065fb..daaeff2f0 100644
--- a/src/Text/Pandoc/Readers/RST.hs
+++ b/src/Text/Pandoc/Readers/RST.hs
@@ -219,7 +219,6 @@ block = choice [ codeBlock
, directive
, anchor
, comment
- , include
, header
, hrule
, lineBlock -- must go before definitionList
@@ -460,16 +459,16 @@ tab-width
encoding
-}
-include :: PandocMonad m => RSTParser m Blocks
-include = try $ do
- string ".. include::"
- skipMany spaceChar
- f <- trim <$> anyLine
- fields <- many $ rawFieldListItem 3
+includeDirective :: PandocMonad m
+ => String -> [(String, String)] -> String
+ -> RSTParser m Blocks
+includeDirective top fields body = do
+ let f = trim top
+ guard $ not (null f)
+ guard $ null (trim body)
-- options
let (startLine :: Maybe Int) = lookup "start-line" fields >>= safeRead
let (endLine :: Maybe Int) = lookup "end-line" fields >>= safeRead
- guard $ not (null f)
oldPos <- getPosition
oldInput <- getInput
containers <- stateContainers <$> getState
@@ -501,7 +500,7 @@ include = try $ do
Just patt -> drop 1 .
dropWhile (not . (patt `isInfixOf`))
Nothing -> id) $ contentLines'
- let contents' = unlines contentLines''
+ let contents' = unlines contentLines'' ++ "\n"
case lookup "code" fields of
Just lang -> do
let numberLines = lookup "number-lines" fields
@@ -687,6 +686,7 @@ directive' = do
$ lookup "height" fields >>=
(lengthToDim . filter (not . isSpace))
case label of
+ "include" -> includeDirective top fields body'
"table" -> tableDirective top fields body'
"list-table" -> listTableDirective top fields body'
"csv-table" -> csvTableDirective top fields body'
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index 9ac37a0ba..1641b991c 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -47,7 +47,7 @@ import Control.Monad.State.Strict
import Data.Char (ord, toLower)
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
-import Data.List (intersperse, isPrefixOf)
+import Data.List (intersperse, isPrefixOf, partition, intercalate)
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Monoid ((<>))
import qualified Data.Set as Set
@@ -569,8 +569,15 @@ imgAttrsToHtml opts attr = do
isNotDim _ = True
dimensionsToAttrList :: Attr -> [(String, String)]
-dimensionsToAttrList attr = (go Width) ++ (go Height)
+dimensionsToAttrList attr = consolidateStyles $ go Width ++ go Height
where
+ consolidateStyles :: [(String, String)] -> [(String, String)]
+ consolidateStyles xs =
+ case partition isStyle xs of
+ ([], _) -> xs
+ (ss, rest) -> ("style", intercalate ";" $ map snd ss) : rest
+ isStyle ("style", _) = True
+ isStyle _ = False
go dir = case (dimension dir attr) of
(Just (Pixel a)) -> [(show dir, show a)]
(Just x) -> [("style", show dir ++ ":" ++ show x)]
diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs
index 95977ce17..3dbfe3f11 100644
--- a/src/Text/Pandoc/Writers/Markdown.hs
+++ b/src/Text/Pandoc/Writers/Markdown.hs
@@ -787,6 +787,7 @@ blockListToMarkdown :: PandocMonad m
-> MD m Doc
blockListToMarkdown opts blocks = do
inlist <- asks envInList
+ isPlain <- asks envPlain
-- a) insert comment between list and indented code block, or the
-- code block will be treated as a list continuation paragraph
-- b) change Plain to Para unless it's followed by a RawBlock
@@ -813,9 +814,11 @@ blockListToMarkdown opts blocks = do
isListBlock (OrderedList _ _) = True
isListBlock (DefinitionList _) = True
isListBlock _ = False
- commentSep = if isEnabled Ext_raw_html opts
- then RawBlock "html" "<!-- -->\n"
- else RawBlock "markdown" "&nbsp;\n"
+ commentSep = if isPlain
+ then Null
+ else if isEnabled Ext_raw_html opts
+ then RawBlock "html" "<!-- -->\n"
+ else RawBlock "markdown" "&nbsp;\n"
mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . cat
getKey :: Doc -> Key
@@ -931,7 +934,7 @@ avoidBadWrapsInList (s:Str cs:[])
avoidBadWrapsInList (x:xs) = x : avoidBadWrapsInList xs
isOrderedListMarker :: String -> Bool
-isOrderedListMarker xs = (last xs `elem` ['.',')']) &&
+isOrderedListMarker xs = not (null xs) && (last xs `elem` ['.',')']) &&
isRight (runParser (anyOrderedListMarker >> eof)
defaultParserState "" xs)
@@ -946,11 +949,10 @@ inlineToMarkdown opts (Span attrs ils) = do
contents <- inlineListToMarkdown opts ils
return $ case plain of
True -> contents
- False | isEnabled Ext_bracketed_spans opts ->
+ False | attrs == nullAttr -> contents
+ | isEnabled Ext_bracketed_spans opts ->
"[" <> contents <> "]" <>
- if attrs == nullAttr
- then "{}"
- else linkAttributes opts attrs
+ linkAttributes opts attrs
| isEnabled Ext_raw_html opts ||
isEnabled Ext_native_spans opts ->
tagWithAttrs "span" attrs <> contents <> text "</span>"
diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs
index 48f17c4fb..88f42acd4 100644
--- a/src/Text/Pandoc/Writers/Org.hs
+++ b/src/Text/Pandoc/Writers/Org.hs
@@ -129,36 +129,25 @@ blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do
blankline $$ contents $$
blankline $$ drawerEndTag $$
blankline
-blockToOrg (Div attrs bs) = do
+blockToOrg (Div (ident, classes, kv) bs) = do
contents <- blockListToOrg bs
+ -- if one class looks like the name of a greater block then output as such:
+ -- The ID, if present, is added via the #+NAME keyword; other classes and
+ -- key-value pairs are kept as #+ATTR_HTML attributes.
let isGreaterBlockClass = (`elem` ["center", "quote"]) . map toLower
- return $ case attrs of
- ("", [], []) ->
- -- nullAttr, treat contents as if it wasn't wrapped
- blankline $$ contents $$ blankline
- (ident, [], []) ->
- -- only an id: add id as an anchor, unwrap the rest
- blankline $$ "<<" <> text ident <> ">>" $$ contents $$ blankline
- (ident, classes, kv) ->
- -- if one class looks like the name of a greater block then output as
- -- such: The ID, if present, is added via the #+NAME keyword; other
- -- classes and key-value pairs are kept as #+ATTR_HTML attributes.
- let
- (blockTypeCand, classes') = partition isGreaterBlockClass classes
- in case blockTypeCand of
- (blockType:classes'') ->
- blankline $$ attrHtml (ident, classes'' <> classes', kv) $$
- "#+BEGIN_" <> text blockType $$ contents $$
- "#+END_" <> text blockType $$ blankline
- _ ->
- -- fallback: wrap in div tags
- let
- startTag = tagWithAttrs "div" attrs
- endTag = text "</div>"
- in blankline $$ "#+BEGIN_HTML" $$
- nest 2 startTag $$ "#+END_HTML" $$ blankline $$
- contents $$ blankline $$ "#+BEGIN_HTML" $$
- nest 2 endTag $$ "#+END_HTML" $$ blankline
+ (blockTypeCand, classes') = partition isGreaterBlockClass classes
+ return $ case blockTypeCand of
+ (blockType:classes'') ->
+ blankline $$ attrHtml (ident, classes'' <> classes', kv) $$
+ "#+BEGIN_" <> text blockType $$ contents $$
+ "#+END_" <> text blockType $$ blankline
+ _ ->
+ -- fallback with id: add id as an anchor if present, discard classes and
+ -- key-value pairs, unwrap the content.
+ let contents' = if not (null ident)
+ then "<<" <> text ident <> ">>" $$ contents
+ else contents
+ in blankline $$ contents' $$ blankline
blockToOrg (Plain inlines) = inlineListToOrg inlines
-- title beginning with fig: indicates that the image is a figure
blockToOrg (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do
@@ -173,7 +162,7 @@ blockToOrg (Para inlines) = do
blockToOrg (LineBlock lns) = do
let splitStanza [] = []
splitStanza xs = case break (== mempty) xs of
- (l, []) -> l : []
+ (l, []) -> [l]
(l, _:r) -> l : splitStanza r
let joinWithLinefeeds = nowrap . mconcat . intersperse cr
let joinWithBlankLines = mconcat . intersperse blankline
@@ -213,7 +202,7 @@ blockToOrg (Table caption' _ _ headers rows) = do
caption'' <- inlineListToOrg caption'
let caption = if null caption'
then empty
- else ("#+CAPTION: " <> caption'')
+ else "#+CAPTION: " <> caption''
headers' <- mapM blockListToOrg headers
rawRows <- mapM (mapM blockListToOrg) rows
let numChars = maximum . map offset
@@ -289,8 +278,8 @@ propertiesDrawer (ident, classes, kv) =
let
drawerStart = text ":PROPERTIES:"
drawerEnd = text ":END:"
- kv' = if (classes == mempty) then kv else ("CLASS", unwords classes):kv
- kv'' = if (ident == mempty) then kv' else ("CUSTOM_ID", ident):kv'
+ kv' = if classes == mempty then kv else ("CLASS", unwords classes):kv
+ kv'' = if ident == mempty then kv' else ("CUSTOM_ID", ident):kv'
properties = vcat $ map kvToOrgProperty kv''
in
drawerStart <> cr <> properties <> cr <> drawerEnd
@@ -303,7 +292,7 @@ attrHtml :: Attr -> Doc
attrHtml ("" , [] , []) = mempty
attrHtml (ident, classes, kvs) =
let
- name = if (null ident) then mempty else "#+NAME: " <> text ident <> cr
+ name = if null ident then mempty else "#+NAME: " <> text ident <> cr
keyword = "#+ATTR_HTML"
classKv = ("class", unwords classes)
kvStrings = map (\(k,v) -> ":" <> k <> " " <> v) (classKv:kvs)
@@ -370,19 +359,19 @@ inlineToOrg SoftBreak = do
WrapPreserve -> return cr
WrapAuto -> return space
WrapNone -> return space
-inlineToOrg (Link _ txt (src, _)) = do
+inlineToOrg (Link _ txt (src, _)) =
case txt of
[Str x] | escapeURI x == src -> -- autolink
- do return $ "[[" <> text (orgPath x) <> "]]"
+ return $ "[[" <> text (orgPath x) <> "]]"
_ -> do contents <- inlineListToOrg txt
return $ "[[" <> text (orgPath src) <> "][" <> contents <> "]]"
-inlineToOrg (Image _ _ (source, _)) = do
+inlineToOrg (Image _ _ (source, _)) =
return $ "[[" <> text (orgPath source) <> "]]"
inlineToOrg (Note contents) = do
-- add to notes in state
notes <- gets stNotes
modify $ \st -> st { stNotes = contents:notes }
- let ref = show $ (length notes) + 1
+ let ref = show $ length notes + 1
return $ "[fn:" <> text ref <> "]"
orgPath :: String -> String
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-11 14:29:35 +0000