pandoc-3.12: src/Text/Pandoc/Readers/Textile.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{- |
Module : Text.Pandoc.Readers.Textile
Copyright : Copyright (C) 2010-2012 Paul Rivier
2010-2024 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : Paul Rivier <paul*rivier#demotera*com>
Stability : alpha
Portability : portable
Conversion from Textile to 'Pandoc' document, based on the spec
available at https://www.promptworks.com/textile/.
Implemented and parsed:
- Paragraphs
- Code blocks
- Lists
- blockquote
- Inlines : strong, emph, cite, code, deleted, superscript,
subscript, links
- footnotes
- HTML-specific and CSS-specific attributes on headers
Left to be implemented:
- dimension sign
- all caps
- continued blocks (ex bq..)
TODO : refactor common patterns across readers :
- more ...
-}
module Text.Pandoc.Readers.Textile ( readTextile) where
import Control.Monad (guard, liftM)
import Control.Monad.Except (throwError)
import Data.Char (digitToInt, isUpper)
import Data.List (intersperse, transpose)
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Text.HTML.TagSoup (Tag (..), fromAttrib)
import Text.HTML.TagSoup.Match
import Text.Pandoc.Builder (Blocks, Inlines, trimInlines)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
import Text.Pandoc.CSS
import Text.Pandoc.Definition
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.Pandoc.Parsing
import Text.Pandoc.Readers.HTML (htmlTag, isBlockTag, isInlineTag)
import Text.Pandoc.Readers.LaTeX (rawLaTeXBlock, rawLaTeXInline)
import Text.Pandoc.Shared (trim, tshow, compactifyTable)
import Text.Read (readMaybe)
-- | Parse a Textile text and return a Pandoc document.
readTextile :: (PandocMonad m, ToSources a)
=> ReaderOptions -- ^ Reader options
-> a
-> m Pandoc
readTextile opts s = do
let sources = ensureFinalNewlines 2 (toSources s)
parsed <- readWithM parseTextile def{ stateOptions = opts } sources
case parsed of
Right result -> return result
Left e -> throwError e
type TextileParser = ParsecT Sources ParserState
-- | Generate a Pandoc ADT from a textile document
parseTextile :: PandocMonad m => TextileParser m Pandoc
parseTextile = do
many blankline
startPos <- getPosition
-- go through once just to get list of reference keys and notes
-- docMinusKeys is the raw document with blanks where the keys/notes were...
let firstPassParser = do
pos <- getPosition
t <- noteBlock <|> referenceKey <|> lineClump
return (pos, t)
manyTill firstPassParser eof >>= setInput . Sources
setPosition startPos
st' <- getState
let reversedNotes = stateNotes st'
updateState $ \s -> s { stateNotes = reverse reversedNotes }
-- now parse it for real...
Pandoc nullMeta . B.toList <$> parseBlocks -- FIXME
noteMarker :: PandocMonad m => TextileParser m Text
noteMarker = do
skipMany spaceChar
string "fn"
T.pack <$> manyTill digit (string "." <|> try (string "^."))
noteBlock :: PandocMonad m => TextileParser m Text
noteBlock = try $ do
startPos <- getPosition
ref <- noteMarker
optional blankline
contents <- T.unlines <$> many1Till anyLine (blanklines <|> noteBlock)
endPos <- getPosition
let newnote = (ref, contents <> "\n")
st <- getState
let oldnotes = stateNotes st
updateState $ \s -> s { stateNotes = newnote : oldnotes }
-- return blanks so line count isn't affected
return $ T.replicate (sourceLine endPos - sourceLine startPos) "\n"
referenceKey :: PandocMonad m => TextileParser m Text
referenceKey = try $ do
pos <- getPosition
char '['
refName <- T.pack <$> many1Till nonspaceChar (char ']')
refDestination <- T.pack <$> many1Till anyChar newline
st <- getState
let oldKeys = stateKeys st
let key = toKey refName
-- Textile doesn't support link titles on the reference
-- definition, so use the empty string
let target = (refDestination, "")
case M.lookup key oldKeys of
Just (t, _) | not (t == target) ->
-- similar to Markdown, only warn when the targets
-- for matching named references differ
logMessage $ DuplicateLinkReference refName pos
_ -> return ()
updateState $ \s -> s {stateKeys = M.insert key (target, nullAttr) oldKeys }
return "\n"
-- | Parse document blocks
parseBlocks :: PandocMonad m => TextileParser m Blocks
parseBlocks = mconcat <$> manyTill block eof
-- | Block parsers list tried in definition order
blockParsers :: PandocMonad m => [TextileParser m Blocks]
blockParsers = [ codeBlock
, header
, blockQuote
, hrule
, commentBlock
, anyList
, rawHtmlBlock
, rawLaTeXBlock'
, table
, explicitBlock "p" (para <|> pure (B.para mempty))
, para
, mempty <$ blanklines
]
-- | Any block in the order of definition of blockParsers
block :: PandocMonad m => TextileParser m Blocks
block = do
res <- choice blockParsers <?> "block"
trace (T.take 60 $ tshow $ B.toList res)
return res
commentBlock :: PandocMonad m => TextileParser m Blocks
commentBlock = try $ do
string "###."
manyTill anyLine blanklines
return mempty
codeBlock :: PandocMonad m => TextileParser m Blocks
codeBlock = codeBlockTextile <|> codeBlockHtml
codeBlockTextile :: PandocMonad m => TextileParser m Blocks
codeBlockTextile = try $ do
string "bc." <|> string "pre."
extended <- option False (True <$ char '.')
char ' '
let starts = ["p", "table", "bq", "bc", "pre", "h1", "h2", "h3",
"h4", "h5", "h6", "pre", "###", "notextile"]
let ender = () <$ choice (map explicitBlockStart starts)
contents <- if extended
then do
f <- anyLine
rest <- many (notFollowedBy ender *> anyLine)
return (f:rest)
else manyTill anyLine blanklines
return $ B.codeBlock (trimTrailingNewlines (T.unlines contents))
trimTrailingNewlines :: Text -> Text
trimTrailingNewlines = T.dropWhileEnd (=='\n')
-- | Code Blocks in Textile are between <pre> and </pre>
codeBlockHtml :: PandocMonad m => TextileParser m Blocks
codeBlockHtml = try $ do
(t@(TagOpen _ attrs),_) <- htmlTag (tagOpen (=="pre") (const True))
result' <- T.pack <$> manyTill anyChar (htmlTag (tagClose (=="pre")))
-- drop leading newline if any
let result'' = case T.uncons result' of
Just ('\n', xs) -> xs
_ -> result'
-- drop trailing newline if any
let result''' = case T.unsnoc result'' of
Just (xs, '\n') -> xs
_ -> result''
let classes = T.words $ fromAttrib "class" t
let ident = fromAttrib "id" t
let kvs = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
return $ B.codeBlockWith (ident,classes,kvs) result'''
-- | Header of the form "hN. content" with N in 1..6
header :: PandocMonad m => TextileParser m Blocks
header = try $ do
char 'h'
level <- digitToInt <$> oneOf "123456"
attr <- attributes
char '.'
lookAhead whitespace
name <- trimInlines . mconcat <$> many inline
attr' <- registerHeader attr name
return $ B.headerWith attr' level name
-- | Blockquote of the form "bq. content"
blockQuote :: PandocMonad m => TextileParser m Blocks
blockQuote = try $ do
string "bq" >> attributes >> char '.' >> whitespace
B.blockQuote <$> para
-- Horizontal rule
hrule :: PandocMonad m => TextileParser m Blocks
hrule = try $ do
skipSpaces
start <- oneOf "-*"
count 2 (skipSpaces >> char start)
skipMany (spaceChar <|> char start)
newline
optional blanklines
return B.horizontalRule
-- Lists handling
-- | Can be a bullet list or an ordered list. This implementation is
-- strict in the nesting, sublist must start at exactly "parent depth
-- plus one"
anyList :: PandocMonad m => TextileParser m Blocks
anyList = try $ anyListAtDepth 1 <* blanklines
-- | This allow one type of list to be nested into an other type,
-- provided correct nesting
anyListAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
anyListAtDepth depth = choice [ bulletListAtDepth depth,
orderedListAtDepth depth,
definitionList ]
-- | Bullet List of given depth, depth being the number of leading '*'
bulletListAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
bulletListAtDepth depth = try $ B.bulletList <$> many1 (bulletListItemAtDepth depth)
-- | Bullet List Item of given depth, depth being the number of
-- leading '*'
bulletListItemAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
bulletListItemAtDepth depth = try $ do
bulletListStartAtDepth depth
genericListItemContentsAtDepth depth
-- | Ordered List of given depth, depth being the number of
-- leading '#'
-- The first Ordered List Item may have a start attribute
orderedListAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
orderedListAtDepth depth = try $ do
(startNum, firstItem) <- firstOrderedListItemAtDepth depth
moreItems <- many (orderedListItemAtDepth depth)
let listItems = firstItem : moreItems
return $ B.orderedListWith (startNum, DefaultStyle, DefaultDelim) listItems
-- | The first Ordered List Item, which could have a start attribute
firstOrderedListItemAtDepth :: PandocMonad m => Int
-> TextileParser m (Int, Blocks)
firstOrderedListItemAtDepth depth = try $ do
startNum <- orderedListStartAtDepth depth
contents <- genericListItemContentsAtDepth depth
return (startNum, contents)
-- | Ordered List Item of given depth, depth being the number of
-- leading '#'
orderedListItemAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
orderedListItemAtDepth depth = try $ do
orderedListStartAtDepth depth
genericListItemContentsAtDepth depth
-- | Lists always start with a number of leading characters '#' or '*'
-- Ordered list start characters '#' can be followed by the start attribute
-- number, but bullet list characters '*' can not
orderedListStartAtDepth :: PandocMonad m => Int -> TextileParser m Int
orderedListStartAtDepth depth = count depth (char '#') >>
try orderedListStartAttr <* (attributes >> whitespace)
bulletListStartAtDepth :: PandocMonad m => Int -> TextileParser m ()
bulletListStartAtDepth depth = () <$ (count depth (char '*') >>
attributes >> whitespace)
-- | The leading characters and start attributes differ between ordered and
-- unordered lists, but their contents have the same structure and can
-- share a Parser
genericListItemContentsAtDepth :: PandocMonad m => Int
-> TextileParser m Blocks
genericListItemContentsAtDepth depth = do
contents <- mconcat <$> many ((B.plain . mconcat <$> many1 inline) <|>
try (newline >> codeBlockHtml))
newline
sublist <- option mempty (anyListAtDepth (depth + 1))
return $ contents <> sublist
-- | A definition list is a set of consecutive definition items
definitionList :: PandocMonad m => TextileParser m Blocks
definitionList = try $ B.definitionList <$> many1 definitionListItem
-- | List start character.
listStart :: PandocMonad m => TextileParser m ()
listStart = genericListStart '*'
<|> () <$ orderedListStart
<|> () <$ definitionListStart
genericListStart :: PandocMonad m => Char -> TextileParser m ()
genericListStart c = () <$ try (many1 (char c) >> whitespace)
orderedListStart :: PandocMonad m => TextileParser m ()
orderedListStart = () <$ try (many1 (char '#') >>
try orderedListStartAttr >>
whitespace)
basicDLStart :: PandocMonad m => TextileParser m ()
basicDLStart = do
char '-'
whitespace
notFollowedBy newline
definitionListStart :: PandocMonad m => TextileParser m Inlines
definitionListStart = try $ do
basicDLStart
trimInlines . mconcat <$>
many1Till inline
( try (newline *> lookAhead basicDLStart)
<|> try (lookAhead (() <$ string ":="))
)
-- | A definition list item in textile begins with '- ', followed by
-- the term defined, then spaces and ":=". The definition follows, on
-- the same single line, or spaned on multiple line, after a line
-- break.
definitionListItem :: PandocMonad m => TextileParser m (Inlines, [Blocks])
definitionListItem = try $ do
term <- mconcat . intersperse B.linebreak <$> many1 definitionListStart
def' <- string ":=" *> optional whitespace *> (multilineDef <|> inlineDef)
return (term, def')
where inlineDef :: PandocMonad m => TextileParser m [Blocks]
inlineDef = liftM (\d -> [B.plain d])
$ optional whitespace >> (trimInlines . mconcat <$> many inline) <* newline
multilineDef :: PandocMonad m => TextileParser m [Blocks]
multilineDef = try $ do
optional whitespace >> newline
s <- T.pack <$> many1Till anyChar (try (string "=:" >> newline))
-- this <> "\n\n" does not look very good
ds <- parseFromString' parseBlocks (s <> "\n\n")
return [ds]
-- raw content
-- | A raw Html Block, optionally followed by blanklines
rawHtmlBlock :: PandocMonad m => TextileParser m Blocks
rawHtmlBlock = try $ do
skipMany spaceChar
(_,b) <- htmlTag isBlockTag
optional blanklines
return $ B.rawBlock "html" b
-- | Raw block of LaTeX content
rawLaTeXBlock' :: PandocMonad m => TextileParser m Blocks
rawLaTeXBlock' = do
guardEnabled Ext_raw_tex
B.rawBlock "latex" <$> (rawLaTeXBlock <* spaces)
-- | In textile, paragraphs are separated by blank lines.
para :: PandocMonad m => TextileParser m Blocks
para = B.para . trimInlines . mconcat <$> many1 inline
-- Tables
toAlignment :: Char -> Alignment
toAlignment '<' = AlignLeft
toAlignment '>' = AlignRight
toAlignment '=' = AlignCenter
toAlignment _ = AlignDefault
cellAttributes :: PandocMonad m => TextileParser m (Bool, Alignment)
cellAttributes = try $ do
isHeader <- option False (True <$ char '_')
-- we just ignore colspan and rowspan markers:
optional $ try $ oneOf "/\\" >> many1 digit
-- we pay attention to alignments:
alignment <- option AlignDefault $ toAlignment <$> oneOf "<>="
-- ignore other attributes for now:
_ <- attributes
char '.'
return (isHeader, alignment)
-- | A table cell spans until a pipe |
tableCell :: PandocMonad m => TextileParser m ((Bool, Alignment), Blocks)
tableCell = try $ do
char '|'
(isHeader, alignment) <- option (False, AlignDefault) cellAttributes
notFollowedBy blankline
raw <- trim . T.pack <$>
many (noneOf "|\n" <|> try (char '\n' <* notFollowedBy blankline))
content <- parseFromString' parseBlocks (raw <> "\n\n")
-- Convert lone Para to Plain for backward compatibility
let content' = case B.toList content of
[Para ils] -> B.plain (B.fromList ils)
_ -> content
return ((isHeader, alignment), content')
-- | A table row is made of many table cells
tableRow :: PandocMonad m => TextileParser m [((Bool, Alignment), Blocks)]
tableRow = try $ do
-- skip optional row attributes
optional $ try $ do
_ <- attributes
char '.'
many1 spaceChar
many1 tableCell <* char '|' <* blankline
-- | A table with an optional header.
table :: PandocMonad m => TextileParser m Blocks
table = try $ do
-- ignore table attributes
caption <- option mempty $ try $ do
string "table"
_ <- attributes
char '.'
rawcapt <- trim <$> anyLine
parseFromString' (mconcat <$> many inline) rawcapt
rawrows <- many1 $ skipMany ignorableRow >> tableRow
skipMany ignorableRow
blanklines
let (headers, rows) = case rawrows of
(toprow:rest) | any (fst . fst) toprow ->
(toprow, rest)
_ -> (mempty, rawrows)
let nbOfCols = maximum $ fmap length (headers :| rows)
let aligns = map (maybe AlignDefault minimum . nonEmpty) $
transpose $ map (map (snd . fst)) (headers:rows)
let toRow = Row nullAttr . map B.simpleCell
toHeaderRow l = [toRow l | not (null l)]
return $ compactifyTable
$ B.table (B.simpleCaption $ B.plain caption)
(zip aligns (replicate nbOfCols ColWidthDefault))
(TableHead nullAttr $ toHeaderRow $ map snd headers)
[TableBody nullAttr 0 [] $ map (toRow . map snd) rows]
(TableFoot nullAttr [])
-- | Ignore markers for cols, thead, tfoot.
ignorableRow :: PandocMonad m => TextileParser m ()
ignorableRow = try $ do
char '|'
oneOf ":^-~"
_ <- attributes
char '.'
_ <- anyLine
return ()
explicitBlockStart :: PandocMonad m => Text -> TextileParser m Attr
explicitBlockStart name = try $ do
string (T.unpack name)
attr <- attributes
char '.'
optional whitespace
optional endline
return attr
-- | Blocks like 'p' and 'table' do not need explicit block tag.
-- However, they can be used to set HTML/CSS attributes when needed.
explicitBlock :: PandocMonad m
=> Text -- ^ block tag name
-> TextileParser m Blocks -- ^ implicit block
-> TextileParser m Blocks
explicitBlock name blk = try $ do
attr <- explicitBlockStart name
contents <- blk
return $ if attr == nullAttr
then contents
else B.divWith attr contents
----------
-- Inlines
----------
-- | Any inline element
inline :: PandocMonad m => TextileParser m Inlines
inline = choice inlineParsers <?> "inline"
-- | Inline parsers tried in order
inlineParsers :: PandocMonad m => [TextileParser m Inlines]
inlineParsers = [ str
, whitespace
, endline
, code
, escapedInline
, spanGroup
, inlineMarkup
, groupedInlineMarkup
, rawHtmlInline
, rawLaTeXInline'
, note
, link
, image
, mark
, B.str <$> characterReference
, smartPunctuation inline
, symbol
]
-- | Inline markups
inlineMarkup :: PandocMonad m => TextileParser m Inlines
inlineMarkup = choice [ simpleInline (string "??") (B.cite [])
, simpleInline (string "**") B.strong
, simpleInline (string "__") B.emph
, simpleInline (char '*') B.strong
, simpleInline (char '_') B.emph
, simpleInline (char '+') B.underline
, simpleInline (char '-' <* notFollowedBy (char '-')) B.strikeout
, simpleInline (char '^') B.superscript
, simpleInline (char '~') B.subscript
]
-- "The <span> tag is created by percent % signs between whitespaces."
-- e.g. My mother has %{color:green;}green% eyes.
spanGroup :: PandocMonad m => TextileParser m Inlines
spanGroup = try $ do
notAfterString >>= guard
char '%' *> notFollowedBy whitespace
attr <- option nullAttr attributes
contents <- mconcat <$> manyTill
(try (((B.space <>) <$> try (whitespace *> notFollowedBy newline *> inline))
<|> try (notFollowedBy newline *> inline)))
(try (char '%' <* lookAhead (newline <|> ' ' <$ whitespace)))
pure $ B.spanWith attr contents
-- | Trademark, registered, copyright
mark :: PandocMonad m => TextileParser m Inlines
mark = try $ char '(' >> (try tm <|> try reg <|> copy)
reg :: PandocMonad m => TextileParser m Inlines
reg = do
oneOf "Rr"
char ')'
return $ B.str "\174"
tm :: PandocMonad m => TextileParser m Inlines
tm = do
oneOf "Tt"
oneOf "Mm"
char ')'
return $ B.str "\8482"
copy :: PandocMonad m => TextileParser m Inlines
copy = do
oneOf "Cc"
char ')'
return $ B.str "\169"
note :: PandocMonad m => TextileParser m Inlines
note = try $ do
ref <- char '[' *> many1 digit <* char ']'
notes <- stateNotes <$> getState
case lookup (T.pack ref) notes of
Nothing -> Prelude.fail "note not found"
Just raw -> B.note <$> parseFromString' parseBlocks raw
-- | Special chars
markupChars :: [Char]
markupChars = "\\*#_@~-+^|%=[]&"
-- | Break strings on following chars. Space tab and newline break for
-- inlines breaking. Open paren breaks for mark. Quote, dash and dot
-- break for smart punctuation. Punctuation breaks for regular
-- punctuation. Double quote breaks for named links. > and < break
-- for inline html.
stringBreakers :: [Char]
stringBreakers = " \t\n\r.,\"'?!;:<>«»„“”‚‘’()[]"
wordBoundaries :: [Char]
wordBoundaries = markupChars <> stringBreakers
-- | Parse a hyphened sequence of words
hyphenedWords :: PandocMonad m => TextileParser m Text
hyphenedWords = do
x <- wordChunk
xs <- many (try $ char '-' >> wordChunk)
return $ T.intercalate "-" (x:xs)
wordChunk :: PandocMonad m => TextileParser m Text
wordChunk = try $ do
hd <- noneOf wordBoundaries
tl <- many ( noneOf wordBoundaries <|>
try (notFollowedBy' note *> oneOf markupChars
<* lookAhead (noneOf wordBoundaries) ) )
return $ T.pack $ hd:tl
-- | Any string
str :: PandocMonad m => TextileParser m Inlines
str = do
baseStr <- hyphenedWords
-- RedCloth compliance : if parsed word is uppercase and immediately
-- followed by parens, parens content is unconditionally word acronym
fullStr <- option baseStr $ try $ do
guard $ T.all isUpper baseStr
acro <- T.pack <$> enclosed (char '(') (char ')') anyChar'
return $ T.concat [baseStr, " (", acro, ")"]
updateLastStrPos
return $ B.str fullStr
-- | Some number of space chars
whitespace :: PandocMonad m => TextileParser m Inlines
whitespace = many1 spaceChar >> return B.space <?> "whitespace"
-- | In Textile, an isolated endline character is a line break
endline :: PandocMonad m => TextileParser m Inlines
endline = try $ do
newline
notFollowedBy blankline
notFollowedBy listStart
notFollowedBy rawHtmlBlock
return B.linebreak
rawHtmlInline :: PandocMonad m => TextileParser m Inlines
rawHtmlInline = B.rawInline "html" . snd <$> htmlTag isInlineTag
-- | Raw LaTeX Inline
rawLaTeXInline' :: PandocMonad m => TextileParser m Inlines
rawLaTeXInline' = try $ do
guardEnabled Ext_raw_tex
B.rawInline "latex" <$> rawLaTeXInline
-- | Textile standard link syntax is "label":target. But we
-- can also have ["label":target].
link :: PandocMonad m => TextileParser m Inlines
link = try $ do
bracketed <- (True <$ char '[') <|> return False
char '"' *> notFollowedBy (oneOf " \t\n\r")
attr <- attributes
name <- trimInlines . mconcat <$>
withQuoteContext InDoubleQuote (many1Till inline (char '"'))
url <- linkUrl bracketed
let name' = if B.toList name == [Str "$"] then B.str url else name
return $ if attr == nullAttr
then B.link url "" name'
else B.spanWith attr $ B.link url "" name'
linkUrl :: PandocMonad m => Bool -> TextileParser m Text
linkUrl bracketed = do
char ':'
let stop = if bracketed
then char ']'
else lookAhead $ space <|> eof' <|> oneOf "[]" <|>
try (oneOf "!.,;:*" *>
(space <|> newline <|> eof'))
rawLink <- T.pack <$> many1Till nonspaceChar stop
st <- getState
return $ case M.lookup (toKey rawLink) (stateKeys st) of
Nothing -> rawLink
Just ((src, _), _) -> src
-- | image embedding
image :: PandocMonad m => TextileParser m Inlines
image = try $ do
char '!' >> notFollowedBy space
(ident, cls, kvs) <- attributes
let attr = case lookup "style" kvs of
Just stls -> (ident, cls, pickStylesToKVs ["width", "height"] stls)
Nothing -> (ident, cls, kvs)
src <- takeWhile1P (`notElem` (" \t\n\r!(" :: [Char]))
alt <- fmap T.pack $ option "" $ try $ char '(' *> manyTill anyChar (char ')')
char '!'
let img = B.imageWith attr src alt (B.str alt)
try (do -- image link
url <- linkUrl False
return (B.link url "" img))
<|> return img
escapedInline :: PandocMonad m => TextileParser m Inlines
escapedInline = escapedEqs <|> escapedTag
escapedEqs :: PandocMonad m => TextileParser m Inlines
escapedEqs = B.str . T.pack <$>
try (string "==" *> manyTill anyChar' (try $ string "=="))
-- | literal text escaped btw <notextile> tags
escapedTag :: PandocMonad m => TextileParser m Inlines
escapedTag = B.str . T.pack <$>
try (string "<notextile>" *>
manyTill anyChar' (try $ string "</notextile>"))
-- | Any special symbol defined in wordBoundaries
symbol :: PandocMonad m => TextileParser m Inlines
symbol = do
c <- notFollowedBy newline *>
notFollowedBy rawHtmlBlock *>
oneOf wordBoundaries
updateLastStrPos
pure $ B.str . T.singleton $ c
-- | Inline code
code :: PandocMonad m => TextileParser m Inlines
code = code1 <|> code2
-- any character except a newline before a blank line
anyChar' :: PandocMonad m => TextileParser m Char
anyChar' =
satisfy (/='\n') <|>
try (char '\n' <* notFollowedBy blankline)
code1 :: PandocMonad m => TextileParser m Inlines
code1 = B.code . T.pack <$> surrounded (char '@') anyChar'
code2 :: PandocMonad m => TextileParser m Inlines
code2 = do
htmlTag (tagOpen (=="tt") null)
B.code . T.pack <$> manyTill anyChar' (try $ htmlTag $ tagClose (=="tt"))
orderedListStartAttr :: PandocMonad m => TextileParser m Int
orderedListStartAttr = do
digits <- many digit
case readMaybe digits :: Maybe Int of
Nothing -> return 1
Just n -> return n
-- | Html / CSS attributes
attributes :: PandocMonad m => TextileParser m Attr
attributes = L.foldl' (flip ($)) ("",[],[]) <$>
try (do special <- option id specialAttribute
attrs <- many attribute
return (special : attrs))
specialAttribute :: PandocMonad m => TextileParser m (Attr -> Attr)
specialAttribute = do
alignStr <- ("center" <$ char '=') <|>
("justify" <$ try (string "<>")) <|>
("right" <$ char '>') <|>
("left" <$ char '<')
notFollowedBy spaceChar
return $ addStyle $ T.pack $ "text-align:" ++ alignStr
attribute :: PandocMonad m => TextileParser m (Attr -> Attr)
attribute = try $
(classIdAttr <|> styleAttr <|> langAttr) <* notFollowedBy spaceChar
classIdAttr :: PandocMonad m => TextileParser m (Attr -> Attr)
classIdAttr = try $ do -- (class class #id)
char '('
ws <- T.words `fmap` T.pack <$> manyTill anyChar' (char ')')
case reverse ws of
[]
-> return $ \(_,_,keyvals) -> ("",[],keyvals)
((T.uncons -> Just ('#', ident')):classes')
-> return $ \(_,_,keyvals) -> (ident',classes',keyvals)
classes'
-> return $ \(_,_,keyvals) -> ("",classes',keyvals)
styleAttr :: PandocMonad m => TextileParser m (Attr -> Attr)
styleAttr = do
style <- try $ enclosed (char '{') (char '}') anyChar'
return $ addStyle $ T.pack style
addStyle :: Text -> Attr -> Attr
addStyle style (id',classes,keyvals) =
(id',classes,keyvals')
where keyvals' = ("style", style') : [(k,v) | (k,v) <- keyvals, k /= "style"]
style' = style <> ";" <> T.concat [v | ("style",v) <- keyvals]
langAttr :: PandocMonad m => TextileParser m (Attr -> Attr)
langAttr = do
lang <- try $ enclosed (char '[') (char ']') alphaNum
return $ \(id',classes,keyvals) -> (id',classes,("lang",T.pack lang):keyvals)
-- | Parses material surrounded by a parser.
surrounded :: (PandocMonad m, Show t)
=> ParsecT Sources st m t -- ^ surrounding parser
-> ParsecT Sources st m a -- ^ content parser (to be used repeatedly)
-> ParsecT Sources st m [a]
surrounded border =
enclosed (border *> notFollowedBy (oneOf " \t\n\r")) (try border)
simpleInline :: PandocMonad m
=> TextileParser m t -- ^ surrounding parser
-> (Inlines -> Inlines) -- ^ Inline constructor
-> TextileParser m Inlines -- ^ content parser (to be used repeatedly)
simpleInline border construct = try $ do
notAfterString >>= guard
border *> notFollowedBy (oneOf " \t\n\r")
attr <- attributes
body <- trimInlines . mconcat <$>
withQuoteContext InSingleQuote
(manyTill (((B.space <>) <$>
try (whitespace *> notFollowedBy newline >> inline))
<|> try (notFollowedBy newline >> inline))
(try border <* notFollowedBy alphaNum))
return $ construct $
if attr == nullAttr
then body
else B.spanWith attr body
groupedInlineMarkup :: PandocMonad m => TextileParser m Inlines
groupedInlineMarkup = try $ do
char '['
sp1 <- option mempty $ B.space <$ whitespace
result <- withQuoteContext InSingleQuote inlineMarkup
sp2 <- option mempty $ B.space <$ whitespace
char ']'
return $ sp1 <> result <> sp2
eof' :: Monad m => ParsecT Sources s m Char
eof' = '\n' <$ eof