aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Readers
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Readers')
-rw-r--r--src/Text/Pandoc/Readers/Markdown.hs169
1 files changed, 94 insertions, 75 deletions
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index e50180a63..05a46c511 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/src/Text/Pandoc/Readers/Markdown.hs
@@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
{- |
Module : Text.Pandoc.Readers.Markdown
Copyright : Copyright (C) 2006-7 John MacFarlane
- License : GNU GPL, version 2 or above
+ License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
@@ -27,8 +27,8 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Conversion of markdown-formatted plain text to 'Pandoc' document.
-}
-module Text.Pandoc.Readers.Markdown (
- readMarkdown
+module Text.Pandoc.Readers.Markdown (
+ readMarkdown
) where
import Data.List ( transpose, isPrefixOf, isSuffixOf, lookup, sortBy )
@@ -36,9 +36,9 @@ import Data.Ord ( comparing )
import Data.Char ( isAlphaNum )
import Network.URI ( isURI )
import Text.Pandoc.Definition
-import Text.Pandoc.Shared
+import Text.Pandoc.Shared
import Text.Pandoc.Readers.LaTeX ( rawLaTeXInline, rawLaTeXEnvironment )
-import Text.Pandoc.Readers.HTML ( rawHtmlBlock, anyHtmlBlockTag,
+import Text.Pandoc.Readers.HTML ( rawHtmlBlock, anyHtmlBlockTag,
anyHtmlInlineTag, anyHtmlTag,
anyHtmlEndTag, htmlEndTag, extractTagType,
htmlBlockElement )
@@ -68,14 +68,14 @@ specialChars = "\\[]*_~`<>$!^-.&'\"\8216\8217\8220\8221"
indentSpaces = try $ do
state <- getState
let tabStop = stateTabStop state
- try (count tabStop (char ' ')) <|>
+ try (count tabStop (char ' ')) <|>
(many (char ' ') >> string "\t") <?> "indentation"
nonindentSpaces = do
state <- getState
let tabStop = stateTabStop state
sps <- many (char ' ')
- if length sps < tabStop
+ if length sps < tabStop
then return sps
else unexpected "indented line"
@@ -90,8 +90,8 @@ failUnlessSmart = do
if stateSmart state then return () else fail "Smart typography feature"
-- | Parse an inline Str element with a given content.
-inlineString str = try $ do
- (Str res) <- inline
+inlineString str = try $ do
+ (Str res) <- inline
if res == str then return res else fail $ "unexpected Str content"
-- | Parse a sequence of inline elements between a string
@@ -102,9 +102,9 @@ inlinesInBalanced opener closer = try $ do
string opener
result <- manyTill ( (do lookAhead (inlineString opener)
-- because it might be a link...
- bal <- inlinesInBalanced opener closer
+ bal <- inlinesInBalanced opener closer
return $ [Str opener] ++ bal ++ [Str closer])
- <|> (count 1 inline))
+ <|> (count 1 inline))
(try (string closer))
return $ concat result
@@ -114,7 +114,7 @@ inlinesInBalanced opener closer = try $ do
titleLine = try $ char '%' >> skipSpaces >> manyTill inline newline
-authorsLine = try $ do
+authorsLine = try $ do
char '%'
skipSpaces
authors <- sepEndBy (many1 (noneOf ",;\n")) (oneOf ",;")
@@ -142,15 +142,24 @@ parseMarkdown = do
startPos <- getPosition
-- go through once just to get list of reference keys
-- docMinusKeys is the raw document with blanks where the keys were...
- docMinusKeys <- manyTill (referenceKey <|> lineClump) eof >>=
- return . concat
+ docMinusKeys <- manyTill (referenceKey <|> headerReference <|>
+ lineClump) eof >>= return . concat
setInput docMinusKeys
setPosition startPos
st <- getState
+ -- get headers and construct implicit references unless strict
+ if stateStrict st
+ then return ()
+ else do let oldkeys = stateKeys st
+ let headers = reverse $ stateHeaders st
+ let idents = uniqueIdentifiers headers
+ let implicitRefs = zipWith (\hd ident -> (hd, ("#" ++ ident, "")))
+ headers idents
+ updateState $ \st -> st { stateKeys = oldkeys ++ implicitRefs }
-- go through again for notes unless strict...
if stateStrict st
then return ()
- else do docMinusNotes <- manyTill (noteBlock <|> lineClump) eof >>=
+ else do docMinusNotes <- manyTill (noteBlock <|> lineClump) eof >>=
return . concat
st <- getState
let reversedNotes = stateNotes st
@@ -159,10 +168,10 @@ parseMarkdown = do
setPosition startPos
-- now parse it for real...
(title, author, date) <- option ([],[],"") titleBlock
- blocks <- parseBlocks
+ blocks <- parseBlocks
return $ Pandoc (Meta title author date) $ filter (/= Null) blocks
---
+--
-- initial pass for references and notes
--
@@ -185,7 +194,17 @@ referenceKey = try $ do
-- return blanks so line count isn't affected
return $ replicate (sourceLine endPos - sourceLine startPos) '\n'
-referenceTitle = try $ do
+headerReference = try $ do
+ failIfStrict
+ startPos <- getPosition
+ (Header level text) <- lookAhead $ atxHeader <|> setextHeader
+ st <- getState
+ let headers = stateHeaders st
+ updateState $ \st -> st { stateHeaders = text:headers }
+ endPos <- getPosition
+ lineClump -- return the raw header, because we need to parse it later
+
+referenceTitle = try $ do
(many1 spaceChar >> option '\n' newline) <|> newline
skipSpaces
tit <- (charsInBalanced '(' ')' >>= return . unwords . words)
@@ -200,7 +219,7 @@ rawLine = do
notFollowedBy blankline
notFollowedBy' noteMarker
contents <- many1 nonEndline
- end <- option "" (newline >> optional indentSpaces >> return "\n")
+ end <- option "" (newline >> optional indentSpaces >> return "\n")
return $ contents ++ end
rawLines = many1 rawLine >>= return . concat
@@ -229,7 +248,7 @@ noteBlock = try $ do
parseBlocks = manyTill block eof
-block = choice [ header
+block = choice [ header
, table
, codeBlock
, hrule
@@ -260,7 +279,7 @@ setextHeader = try $ do
-- first, see if this block has any chance of being a setextHeader:
lookAhead (anyLine >> oneOf setextHChars)
text <- many1Till inline newline >>= return . normalizeSpaces
- level <- choice $ zipWith
+ level <- choice $ zipWith
(\ch lev -> try (many1 $ char ch) >> blanklines >> return lev)
setextHChars [1..(length setextHChars)]
return $ Header level text
@@ -285,7 +304,7 @@ hrule = try $ do
indentedLine = indentSpaces >> manyTill anyChar newline >>= return . (++ "\n")
codeBlock = do
- contents <- many1 (indentedLine <|>
+ contents <- many1 (indentedLine <|>
try (do b <- blanklines
l <- indentedLine
return $ b ++ l))
@@ -300,7 +319,7 @@ emacsBoxQuote = try $ do
failIfStrict
string ",----"
manyTill anyChar newline
- raw <- manyTill
+ raw <- manyTill
(try (char '|' >> optional (char ' ') >> manyTill anyChar newline))
(try (string "`----"))
blanklines
@@ -310,7 +329,7 @@ emailBlockQuoteStart = try $ nonindentSpaces >> char '>' >>~ optional (char ' ')
emailBlockQuote = try $ do
emailBlockQuoteStart
- raw <- sepBy (many (nonEndline <|>
+ raw <- sepBy (many (nonEndline <|>
(try (endline >> notFollowedBy emailBlockQuoteStart >>
return '\n'))))
(try (newline >> emailBlockQuoteStart))
@@ -318,12 +337,12 @@ emailBlockQuote = try $ do
optional blanklines
return raw
-blockQuote = do
+blockQuote = do
raw <- emailBlockQuote <|> emacsBoxQuote
-- parse the extracted block, which may contain various block elements:
contents <- parseFromString parseBlocks $ (joinWithSep "\n" raw) ++ "\n\n"
return $ BlockQuote contents
-
+
--
-- list blocks
--
@@ -358,7 +377,7 @@ orderedListStart style delim = try $ do
then do many1 digit
char '.'
return 1
- else orderedListMarker style delim
+ else orderedListMarker style delim
if delim == Period && (style == UpperAlpha || (style == UpperRoman &&
num `elem` [1, 5, 10, 50, 100, 500, 1000]))
then char '\t' <|> (spaceChar >> spaceChar)
@@ -382,7 +401,7 @@ rawListItem start = try $ do
blanks <- many blankline
return $ concat result ++ blanks
--- continuation of a list item - indented and separated by blankline
+-- continuation of a list item - indented and separated by blankline
-- or (in compact lists) endline.
-- note: nested lists are parsed as continuations
listContinuation start = try $ do
@@ -398,7 +417,7 @@ listContinuationLine start = try $ do
result <- manyTill anyChar newline
return $ result ++ "\n"
-listItem start = try $ do
+listItem start = try $ do
first <- rawListItem start
continuations <- many (listContinuation start)
-- parsing with ListItemState forces markers at beginning of lines to
@@ -418,7 +437,7 @@ orderedList = try $ do
items <- many1 (listItem (orderedListStart style delim))
return $ OrderedList (start, style, delim) $ compactify items
-bulletList = many1 (listItem bulletListStart) >>=
+bulletList = many1 (listItem bulletListStart) >>=
return . BulletList . compactify
-- definition lists
@@ -459,7 +478,7 @@ definitionList = do
-- paragraph block
--
-para = try $ do
+para = try $ do
result <- many1 inline
newline
blanklines <|> do st <- getState
@@ -468,9 +487,9 @@ para = try $ do
else lookAhead emacsBoxQuote >> return ""
return $ Para $ normalizeSpaces result
-plain = many1 inline >>= return . Plain . normalizeSpaces
+plain = many1 inline >>= return . Plain . normalizeSpaces
---
+--
-- raw html
--
@@ -487,25 +506,25 @@ htmlBlock = do
else rawHtmlBlocks
-- True if tag is self-closing
-isSelfClosing tag =
+isSelfClosing tag =
isSuffixOf "/>" $ filter (not . (`elem` " \n\t")) tag
strictHtmlBlock = try $ do
- tag <- anyHtmlBlockTag
+ tag <- anyHtmlBlockTag
let tag' = extractTagType tag
- if isSelfClosing tag || tag' == "hr"
+ if isSelfClosing tag || tag' == "hr"
then return tag
- else do contents <- many (notFollowedBy' (htmlEndTag tag') >>
+ else do contents <- many (notFollowedBy' (htmlEndTag tag') >>
(htmlElement <|> (count 1 anyChar)))
end <- htmlEndTag tag'
return $ tag ++ concat contents ++ end
rawHtmlBlocks = do
- htmlBlocks <- many1 rawHtmlBlock
+ htmlBlocks <- many1 rawHtmlBlock
let combined = concatMap (\(RawHtml str) -> str) htmlBlocks
let combined' = if not (null combined) && last combined == '\n'
- then init combined -- strip extra newline
- else combined
+ then init combined -- strip extra newline
+ else combined
return $ RawHtml combined'
--
@@ -516,7 +535,7 @@ rawLaTeXEnvironment' = failIfStrict >> rawLaTeXEnvironment
--
-- Tables
---
+--
-- Parse a dashed line with optional trailing spaces; return its length
-- and the length including trailing space.
@@ -525,7 +544,7 @@ dashedLine ch = do
sp <- many spaceChar
return $ (length dashes, length $ dashes ++ sp)
--- Parse a table header with dashed lines of '-' preceded by
+-- Parse a table header with dashed lines of '-' preceded by
-- one line of text.
simpleTableHeader = try $ do
rawContent <- anyLine
@@ -548,7 +567,7 @@ tableSep = try $ nonindentSpaces >> many1 (dashedLine '-') >> string "\n"
rawTableLine indices = do
notFollowedBy' (blanklines <|> tableFooter)
line <- many1Till anyChar newline
- return $ map removeLeadingTrailingSpace $ tail $
+ return $ map removeLeadingTrailingSpace $ tail $
splitByIndices (init indices) line
-- Parse a table line and return a list of lists of blocks (columns).
@@ -565,8 +584,8 @@ multilineRow indices = do
widthsFromIndices :: Int -- Number of columns on terminal
-> [Int] -- Indices
-> [Float] -- Fractional relative sizes of columns
-widthsFromIndices _ [] = []
-widthsFromIndices numColumns indices =
+widthsFromIndices _ [] = []
+widthsFromIndices numColumns indices =
let lengths = zipWith (-) indices (0:indices)
totLength = sum lengths
quotient = if totLength > numColumns
@@ -605,14 +624,14 @@ simpleTable = tableWith simpleTableHeader tableLine blanklines
multilineTable = tableWith multilineTableHeader multilineRow tableFooter
multilineTableHeader = try $ do
- tableSep
+ tableSep
rawContent <- many1 (notFollowedBy' tableSep >> many1Till anyChar newline)
initSp <- nonindentSpaces
dashes <- many1 (dashedLine '-')
newline
let (lengths, lines) = unzip dashes
let indices = scanl (+) (length initSp) lines
- let rawHeadsList = transpose $ map
+ let rawHeadsList = transpose $ map
(\ln -> tail $ splitByIndices (init indices) ln)
rawContent
let rawHeads = map (joinWithSep " ") rawHeadsList
@@ -625,7 +644,7 @@ multilineTableHeader = try $ do
alignType :: [String] -> Int -> Alignment
alignType [] len = AlignDefault
alignType strLst len =
- let str = head $ sortBy (comparing length) $
+ let str = head $ sortBy (comparing length) $
map removeTrailingSpace strLst
leftSpace = if null str then False else (str !! 0) `elem` " \t"
rightSpace = length str < len || (str !! (len - 1)) `elem` " \t"
@@ -637,7 +656,7 @@ alignType strLst len =
table = failIfStrict >> (simpleTable <|> multilineTable) <?> "table"
---
+--
-- inline
--
@@ -667,7 +686,7 @@ inline = choice [ str
escapedChar = do
char '\\'
state <- getState
- result <- option '\\' $ if stateStrict state
+ result <- option '\\' $ if stateStrict state
then oneOf "\\`*_{}[]()>#+-.!~"
else satisfy (not . isAlphaNum)
return $ Str [result]
@@ -681,17 +700,17 @@ ltSign = do
specialCharsMinusLt = filter (/= '<') specialChars
-symbol = do
+symbol = do
result <- oneOf specialCharsMinusLt
return $ Str [result]
-- parses inline code, between n `s and n `s
-code = try $ do
+code = try $ do
starts <- many1 (char '`')
skipSpaces
result <- many1Till (many1 (noneOf "`\n") <|> many1 (char '`') <|>
- (char '\n' >> return " "))
- (try (skipSpaces >> count (length starts) (char '`') >>
+ (char '\n' >> return " "))
+ (try (skipSpaces >> count (length starts) (char '`') >>
notFollowedBy (char '`')))
return $ Code $ removeLeadingTrailingSpace $ concat result
@@ -707,30 +726,30 @@ math = try $ do
return $ TeX ("$" ++ (joinWithSep " " words) ++ "$")
emph = ((enclosed (char '*') (char '*') inline) <|>
- (enclosed (char '_') (char '_' >> notFollowedBy alphaNum) inline)) >>=
+ (enclosed (char '_') (char '_' >> notFollowedBy alphaNum) inline)) >>=
return . Emph . normalizeSpaces
-strong = ((enclosed (string "**") (try $ string "**") inline) <|>
+strong = ((enclosed (string "**") (try $ string "**") inline) <|>
(enclosed (string "__") (try $ string "__") inline)) >>=
return . Strong . normalizeSpaces
strikeout = failIfStrict >> enclosed (string "~~") (try $ string "~~") inline >>=
return . Strikeout . normalizeSpaces
-superscript = failIfStrict >> enclosed (char '^') (char '^')
+superscript = failIfStrict >> enclosed (char '^') (char '^')
(notFollowedBy' whitespace >> inline) >>= -- may not contain Space
return . Superscript
subscript = failIfStrict >> enclosed (char '~') (char '~')
(notFollowedBy' whitespace >> inline) >>= -- may not contain Space
- return . Subscript
+ return . Subscript
-smartPunctuation = failUnlessSmart >>
+smartPunctuation = failUnlessSmart >>
choice [ quoted, apostrophe, dash, ellipses ]
apostrophe = (char '\'' <|> char '\8217') >> return Apostrophe
-quoted = doubleQuoted <|> singleQuoted
+quoted = doubleQuoted <|> singleQuoted
withQuoteContext context parser = do
oldState <- getState
@@ -746,7 +765,7 @@ singleQuoted = try $ do
withQuoteContext InSingleQuote $ many1Till inline singleQuoteEnd >>=
return . Quoted SingleQuote . normalizeSpaces
-doubleQuoted = try $ do
+doubleQuoted = try $ do
doubleQuoteStart
withQuoteContext InDoubleQuote $ many1Till inline doubleQuoteEnd >>=
return . Quoted DoubleQuote . normalizeSpaces
@@ -757,13 +776,13 @@ failIfInQuoteContext context = do
then fail "already inside quotes"
else return ()
-singleQuoteStart = do
+singleQuoteStart = do
failIfInQuoteContext InSingleQuote
- char '\8216' <|>
- (try $ do char '\''
+ char '\8216' <|>
+ (try $ do char '\''
notFollowedBy (oneOf ")!],.;:-? \t\n")
notFollowedBy (try (oneOfStrings ["s","t","m","ve","ll","re"] >>
- satisfy (not . isAlphaNum)))
+ satisfy (not . isAlphaNum)))
-- possess/contraction
return '\'')
@@ -807,13 +826,13 @@ endline = try $ do
newline
notFollowedBy blankline
st <- getState
- if stateStrict st
+ if stateStrict st
then do notFollowedBy emailBlockQuoteStart
notFollowedBy (char '#') -- atx header
- else return ()
+ else return ()
-- parse potential list-starts differently if in a list:
if stateParserContext st == ListItemState
- then notFollowedBy' (bulletListStart <|>
+ then notFollowedBy' (bulletListStart <|>
(anyOrderedListStart >> return ()))
else return ()
return Space
@@ -827,7 +846,7 @@ reference = notFollowedBy' (string "[^") >> -- footnote reference
inlinesInBalanced "[" "]" >>= (return . normalizeSpaces)
-- source for a link, with optional title
-source = try $ do
+source = try $ do
char '('
optional (char '<')
src <- many (noneOf ")> \t\n")
@@ -837,7 +856,7 @@ source = try $ do
char ')'
return (removeTrailingSpace src, tit)
-linkTitle = try $ do
+linkTitle = try $ do
(many1 spaceChar >> option '\n' newline) <|> newline
skipSpaces
delim <- char '\'' <|> char '"'
@@ -852,13 +871,13 @@ link = try $ do
-- a link like [this][ref] or [this][] or [this]
referenceLink label = do
- ref <- option [] (try (optional (char ' ') >>
+ ref <- option [] (try (optional (char ' ') >>
optional (newline >> skipSpaces) >> reference))
let ref' = if null ref then label else ref
state <- getState
case lookupKeySrc (stateKeys state) ref' of
- Nothing -> fail "no corresponding key"
- Just target -> return target
+ Nothing -> fail "no corresponding key"
+ Just target -> return target
emailAddress = try $ do
name <- many1 (alphaNum <|> char '+')
@@ -879,7 +898,7 @@ autoLink = try $ do
char '>'
let src' = if "mailto:" `isPrefixOf` src
then drop 7 src
- else src
+ else src
st <- getState
return $ if stateStrict st
then Link [Str src'] (src, "")
@@ -910,7 +929,7 @@ rawLaTeXInline' = failIfStrict >> rawLaTeXInline
rawHtmlInline' = do
st <- getState
result <- choice $ if stateStrict st
- then [htmlBlockElement, anyHtmlTag, anyHtmlEndTag]
+ then [htmlBlockElement, anyHtmlTag, anyHtmlEndTag]
else [htmlBlockElement, anyHtmlInlineTag]
return $ HtmlInline result