diff options
Diffstat (limited to 'src/Text/Pandoc/Readers/Textile.hs')
| -rw-r--r-- | src/Text/Pandoc/Readers/Textile.hs | 273 |
1 files changed, 136 insertions, 137 deletions
diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs index a638fdf40..5e7aaf910 100644 --- a/src/Text/Pandoc/Readers/Textile.hs +++ b/src/Text/Pandoc/Readers/Textile.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.Textile Copyright : Copyright (C) 2010-2012 Paul Rivier @@ -38,7 +40,7 @@ import Prelude import Control.Monad (guard, liftM) import Control.Monad.Except (throwError) import Data.Char (digitToInt, isUpper) -import Data.List (intercalate, intersperse, transpose) +import Data.List (intersperse, transpose) import Data.Text (Text) import qualified Data.Text as T import Text.HTML.TagSoup (Tag (..), fromAttrib) @@ -52,7 +54,7 @@ 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 (crFilter, trim, underlineSpan) +import Text.Pandoc.Shared (crFilter, trim, underlineSpan, tshow) -- | Parse a Textile text and return a Pandoc document. readTextile :: PandocMonad m @@ -61,21 +63,21 @@ readTextile :: PandocMonad m -> m Pandoc readTextile opts s = do parsed <- readWithM parseTextile def{ stateOptions = opts } - (T.unpack (crFilter s) ++ "\n\n") + (crFilter s <> "\n\n") case parsed of Right result -> return result Left e -> throwError e -- | Generate a Pandoc ADT from a textile document -parseTextile :: PandocMonad m => ParserT [Char] ParserState m Pandoc +parseTextile :: PandocMonad m => ParserT Text ParserState 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 = noteBlock <|> lineClump - manyTill firstPassParser eof >>= setInput . concat + manyTill firstPassParser eof >>= setInput . T.concat setPosition startPos st' <- getState let reversedNotes = stateNotes st' @@ -84,29 +86,29 @@ parseTextile = do blocks <- parseBlocks return $ Pandoc nullMeta (B.toList blocks) -- FIXME -noteMarker :: PandocMonad m => ParserT [Char] ParserState m [Char] -noteMarker = skipMany spaceChar >> string "fn" >> manyTill digit (char '.') +noteMarker :: PandocMonad m => ParserT Text ParserState m Text +noteMarker = skipMany spaceChar >> string "fn" >> T.pack <$> manyTill digit (char '.') -noteBlock :: PandocMonad m => ParserT [Char] ParserState m [Char] +noteBlock :: PandocMonad m => ParserT Text ParserState m Text noteBlock = try $ do startPos <- getPosition ref <- noteMarker optional blankline - contents <- unlines <$> many1Till anyLine (blanklines <|> noteBlock) + contents <- T.unlines <$> many1Till anyLine (blanklines <|> noteBlock) endPos <- getPosition - let newnote = (ref, contents ++ "\n") + 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 $ replicate (sourceLine endPos - sourceLine startPos) '\n' + return $ T.replicate (sourceLine endPos - sourceLine startPos) "\n" -- | Parse document blocks -parseBlocks :: PandocMonad m => ParserT [Char] ParserState m Blocks +parseBlocks :: PandocMonad m => ParserT Text ParserState m Blocks parseBlocks = mconcat <$> manyTill block eof -- | Block parsers list tried in definition order -blockParsers :: PandocMonad m => [ParserT [Char] ParserState m Blocks] +blockParsers :: PandocMonad m => [ParserT Text ParserState m Blocks] blockParsers = [ codeBlock , header , blockQuote @@ -121,22 +123,22 @@ blockParsers = [ codeBlock ] -- | Any block in the order of definition of blockParsers -block :: PandocMonad m => ParserT [Char] ParserState m Blocks +block :: PandocMonad m => ParserT Text ParserState m Blocks block = do res <- choice blockParsers <?> "block" - trace (take 60 $ show $ B.toList res) + trace (T.take 60 $ tshow $ B.toList res) return res -commentBlock :: PandocMonad m => ParserT [Char] ParserState m Blocks +commentBlock :: PandocMonad m => ParserT Text ParserState m Blocks commentBlock = try $ do string "###." manyTill anyLine blanklines return mempty -codeBlock :: PandocMonad m => ParserT [Char] ParserState m Blocks +codeBlock :: PandocMonad m => ParserT Text ParserState m Blocks codeBlock = codeBlockBc <|> codeBlockPre -codeBlockBc :: PandocMonad m => ParserT [Char] ParserState m Blocks +codeBlockBc :: PandocMonad m => ParserT Text ParserState m Blocks codeBlockBc = try $ do string "bc." extended <- option False (True <$ char '.') @@ -150,31 +152,31 @@ codeBlockBc = try $ do rest <- many (notFollowedBy ender *> anyLine) return (f:rest) else manyTill anyLine blanklines - return $ B.codeBlock (trimTrailingNewlines (unlines contents)) + return $ B.codeBlock (trimTrailingNewlines (T.unlines contents)) -trimTrailingNewlines :: String -> String -trimTrailingNewlines = reverse . dropWhile (=='\n') . reverse +trimTrailingNewlines :: Text -> Text +trimTrailingNewlines = T.dropWhileEnd (=='\n') -- | Code Blocks in Textile are between <pre> and </pre> -codeBlockPre :: PandocMonad m => ParserT [Char] ParserState m Blocks +codeBlockPre :: PandocMonad m => ParserT Text ParserState m Blocks codeBlockPre = try $ do (t@(TagOpen _ attrs),_) <- htmlTag (tagOpen (=="pre") (const True)) - result' <- manyTill anyChar (htmlTag (tagClose (=="pre"))) + result' <- T.pack <$> manyTill anyChar (htmlTag (tagClose (=="pre"))) -- drop leading newline if any - let result'' = case result' of - '\n':xs -> xs - _ -> result' + let result'' = case T.uncons result' of + Just ('\n', xs) -> xs + _ -> result' -- drop trailing newline if any - let result''' = case reverse result'' of - '\n':_ -> init result'' - _ -> result'' - let classes = words $ fromAttrib "class" t + 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 => ParserT [Char] ParserState m Blocks +header :: PandocMonad m => ParserT Text ParserState m Blocks header = try $ do char 'h' level <- digitToInt <$> oneOf "123456" @@ -186,14 +188,14 @@ header = try $ do return $ B.headerWith attr' level name -- | Blockquote of the form "bq. content" -blockQuote :: PandocMonad m => ParserT [Char] ParserState m Blocks +blockQuote :: PandocMonad m => ParserT Text ParserState m Blocks blockQuote = try $ do string "bq" >> attributes >> char '.' >> whitespace B.blockQuote <$> para -- Horizontal rule -hrule :: PandocMonad m => ParserT [Char] st m Blocks +hrule :: PandocMonad m => ParserT Text st m Blocks hrule = try $ do skipSpaces start <- oneOf "-*" @@ -208,39 +210,39 @@ hrule = try $ do -- | 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 => ParserT [Char] ParserState m Blocks +anyList :: PandocMonad m => ParserT Text ParserState 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 -> ParserT [Char] ParserState m Blocks +anyListAtDepth :: PandocMonad m => Int -> ParserT Text ParserState 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 -> ParserT [Char] ParserState m Blocks +bulletListAtDepth :: PandocMonad m => Int -> ParserT Text ParserState 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 -> ParserT [Char] ParserState m Blocks +bulletListItemAtDepth :: PandocMonad m => Int -> ParserT Text ParserState m Blocks bulletListItemAtDepth = genericListItemAtDepth '*' -- | Ordered List of given depth, depth being the number of -- leading '#' -orderedListAtDepth :: PandocMonad m => Int -> ParserT [Char] ParserState m Blocks +orderedListAtDepth :: PandocMonad m => Int -> ParserT Text ParserState m Blocks orderedListAtDepth depth = try $ do items <- many1 (orderedListItemAtDepth depth) return $ B.orderedList items -- | Ordered List Item of given depth, depth being the number of -- leading '#' -orderedListItemAtDepth :: PandocMonad m => Int -> ParserT [Char] ParserState m Blocks +orderedListItemAtDepth :: PandocMonad m => Int -> ParserT Text ParserState m Blocks orderedListItemAtDepth = genericListItemAtDepth '#' -- | Common implementation of list items -genericListItemAtDepth :: PandocMonad m => Char -> Int -> ParserT [Char] ParserState m Blocks +genericListItemAtDepth :: PandocMonad m => Char -> Int -> ParserT Text ParserState m Blocks genericListItemAtDepth c depth = try $ do count depth (char c) >> attributes >> whitespace contents <- mconcat <$> many ((B.plain . mconcat <$> many1 inline) <|> @@ -250,25 +252,25 @@ genericListItemAtDepth c depth = try $ do return $ contents <> sublist -- | A definition list is a set of consecutive definition items -definitionList :: PandocMonad m => ParserT [Char] ParserState m Blocks +definitionList :: PandocMonad m => ParserT Text ParserState m Blocks definitionList = try $ B.definitionList <$> many1 definitionListItem -- | List start character. -listStart :: PandocMonad m => ParserT [Char] ParserState m () +listStart :: PandocMonad m => ParserT Text ParserState m () listStart = genericListStart '*' <|> () <$ genericListStart '#' <|> () <$ definitionListStart -genericListStart :: PandocMonad m => Char -> ParserT [Char] st m () +genericListStart :: PandocMonad m => Char -> ParserT Text st m () genericListStart c = () <$ try (many1 (char c) >> whitespace) -basicDLStart :: PandocMonad m => ParserT [Char] ParserState m () +basicDLStart :: PandocMonad m => ParserT Text ParserState m () basicDLStart = do char '-' whitespace notFollowedBy newline -definitionListStart :: PandocMonad m => ParserT [Char] ParserState m Inlines +definitionListStart :: PandocMonad m => ParserT Text ParserState m Inlines definitionListStart = try $ do basicDLStart trimInlines . mconcat <$> @@ -281,26 +283,26 @@ definitionListStart = try $ do -- 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 => ParserT [Char] ParserState m (Inlines, [Blocks]) +definitionListItem :: PandocMonad m => ParserT Text ParserState 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 => ParserT [Char] ParserState m [Blocks] + where inlineDef :: PandocMonad m => ParserT Text ParserState m [Blocks] inlineDef = liftM (\d -> [B.plain d]) $ optional whitespace >> (trimInlines . mconcat <$> many inline) <* newline - multilineDef :: PandocMonad m => ParserT [Char] ParserState m [Blocks] + multilineDef :: PandocMonad m => ParserT Text ParserState m [Blocks] multilineDef = try $ do optional whitespace >> newline - s <- many1Till anyChar (try (string "=:" >> newline)) - -- this ++ "\n\n" does not look very good - ds <- parseFromString' parseBlocks (s ++ "\n\n") + 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 => ParserT [Char] ParserState m Blocks +rawHtmlBlock :: PandocMonad m => ParserT Text ParserState m Blocks rawHtmlBlock = try $ do skipMany spaceChar (_,b) <- htmlTag isBlockTag @@ -308,14 +310,14 @@ rawHtmlBlock = try $ do return $ B.rawBlock "html" b -- | Raw block of LaTeX content -rawLaTeXBlock' :: PandocMonad m => ParserT [Char] ParserState m Blocks +rawLaTeXBlock' :: PandocMonad m => ParserT Text ParserState m Blocks rawLaTeXBlock' = do guardEnabled Ext_raw_tex B.rawBlock "latex" <$> (rawLaTeXBlock <* spaces) -- | In textile, paragraphs are separated by blank lines. -para :: PandocMonad m => ParserT [Char] ParserState m Blocks +para :: PandocMonad m => ParserT Text ParserState m Blocks para = B.para . trimInlines . mconcat <$> many1 inline -- Tables @@ -326,7 +328,7 @@ toAlignment '>' = AlignRight toAlignment '=' = AlignCenter toAlignment _ = AlignDefault -cellAttributes :: PandocMonad m => ParserT [Char] ParserState m (Bool, Alignment) +cellAttributes :: PandocMonad m => ParserT Text ParserState m (Bool, Alignment) cellAttributes = try $ do isHeader <- option False (True <$ char '_') -- we just ignore colspan and rowspan markers: @@ -339,18 +341,18 @@ cellAttributes = try $ do return (isHeader, alignment) -- | A table cell spans until a pipe | -tableCell :: PandocMonad m => ParserT [Char] ParserState m ((Bool, Alignment), Blocks) +tableCell :: PandocMonad m => ParserT Text ParserState m ((Bool, Alignment), Blocks) tableCell = try $ do char '|' (isHeader, alignment) <- option (False, AlignDefault) cellAttributes notFollowedBy blankline - raw <- trim <$> + raw <- trim . T.pack <$> many (noneOf "|\n" <|> try (char '\n' <* notFollowedBy blankline)) content <- mconcat <$> parseFromString' (many inline) raw return ((isHeader, alignment), B.plain content) -- | A table row is made of many table cells -tableRow :: PandocMonad m => ParserT [Char] ParserState m [((Bool, Alignment), Blocks)] +tableRow :: PandocMonad m => ParserT Text ParserState m [((Bool, Alignment), Blocks)] tableRow = try $ do -- skip optional row attributes optional $ try $ do @@ -360,7 +362,7 @@ tableRow = try $ do many1 tableCell <* char '|' <* blankline -- | A table with an optional header. -table :: PandocMonad m => ParserT [Char] ParserState m Blocks +table :: PandocMonad m => ParserT Text ParserState m Blocks table = try $ do -- ignore table attributes caption <- option mempty $ try $ do @@ -384,7 +386,7 @@ table = try $ do (map (map snd) rows) -- | Ignore markers for cols, thead, tfoot. -ignorableRow :: PandocMonad m => ParserT [Char] ParserState m () +ignorableRow :: PandocMonad m => ParserT Text ParserState m () ignorableRow = try $ do char '|' oneOf ":^-~" @@ -393,9 +395,9 @@ ignorableRow = try $ do _ <- anyLine return () -explicitBlockStart :: PandocMonad m => String -> ParserT [Char] ParserState m () +explicitBlockStart :: PandocMonad m => Text -> ParserT Text ParserState m () explicitBlockStart name = try $ do - string name + string (T.unpack name) attributes char '.' optional whitespace @@ -404,9 +406,9 @@ explicitBlockStart name = try $ do -- | Blocks like 'p' and 'table' do not need explicit block tag. -- However, they can be used to set HTML/CSS attributes when needed. maybeExplicitBlock :: PandocMonad m - => String -- ^ block tag name - -> ParserT [Char] ParserState m Blocks -- ^ implicit block - -> ParserT [Char] ParserState m Blocks + => Text -- ^ block tag name + -> ParserT Text ParserState m Blocks -- ^ implicit block + -> ParserT Text ParserState m Blocks maybeExplicitBlock name blk = try $ do optional $ explicitBlockStart name blk @@ -419,11 +421,11 @@ maybeExplicitBlock name blk = try $ do -- | Any inline element -inline :: PandocMonad m => ParserT [Char] ParserState m Inlines +inline :: PandocMonad m => ParserT Text ParserState m Inlines inline = choice inlineParsers <?> "inline" -- | Inline parsers tried in order -inlineParsers :: PandocMonad m => [ParserT [Char] ParserState m Inlines] +inlineParsers :: PandocMonad m => [ParserT Text ParserState m Inlines] inlineParsers = [ str , whitespace , endline @@ -437,13 +439,13 @@ inlineParsers = [ str , link , image , mark - , (B.str . (:[])) <$> characterReference + , (B.str . T.singleton) <$> characterReference , smartPunctuation inline , symbol ] -- | Inline markups -inlineMarkup :: PandocMonad m => ParserT [Char] ParserState m Inlines +inlineMarkup :: PandocMonad m => ParserT Text ParserState m Inlines inlineMarkup = choice [ simpleInline (string "??") (B.cite []) , simpleInline (string "**") B.strong , simpleInline (string "__") B.emph @@ -457,33 +459,33 @@ inlineMarkup = choice [ simpleInline (string "??") (B.cite []) ] -- | Trademark, registered, copyright -mark :: PandocMonad m => ParserT [Char] st m Inlines +mark :: PandocMonad m => ParserT Text st m Inlines mark = try $ char '(' >> (try tm <|> try reg <|> copy) -reg :: PandocMonad m => ParserT [Char] st m Inlines +reg :: PandocMonad m => ParserT Text st m Inlines reg = do oneOf "Rr" char ')' return $ B.str "\174" -tm :: PandocMonad m => ParserT [Char] st m Inlines +tm :: PandocMonad m => ParserT Text st m Inlines tm = do oneOf "Tt" oneOf "Mm" char ')' return $ B.str "\8482" -copy :: PandocMonad m => ParserT [Char] st m Inlines +copy :: PandocMonad m => ParserT Text st m Inlines copy = do oneOf "Cc" char ')' return $ B.str "\169" -note :: PandocMonad m => ParserT [Char] ParserState m Inlines +note :: PandocMonad m => ParserT Text ParserState m Inlines note = try $ do ref <- char '[' *> many1 digit <* char ']' notes <- stateNotes <$> getState - case lookup ref notes of + case lookup (T.pack ref) notes of Nothing -> Prelude.fail "note not found" Just raw -> B.note <$> parseFromString' parseBlocks raw @@ -500,42 +502,42 @@ stringBreakers :: [Char] stringBreakers = " \t\n\r.,\"'?!;:<>«»„“”‚‘’()[]" wordBoundaries :: [Char] -wordBoundaries = markupChars ++ stringBreakers +wordBoundaries = markupChars <> stringBreakers -- | Parse a hyphened sequence of words -hyphenedWords :: PandocMonad m => ParserT [Char] ParserState m String +hyphenedWords :: PandocMonad m => ParserT Text ParserState m Text hyphenedWords = do x <- wordChunk xs <- many (try $ char '-' >> wordChunk) - return $ intercalate "-" (x:xs) + return $ T.intercalate "-" (x:xs) -wordChunk :: PandocMonad m => ParserT [Char] ParserState m String +wordChunk :: PandocMonad m => ParserT Text ParserState m Text wordChunk = try $ do hd <- noneOf wordBoundaries tl <- many ( noneOf wordBoundaries <|> try (notFollowedBy' note *> oneOf markupChars <* lookAhead (noneOf wordBoundaries) ) ) - return $ hd:tl + return $ T.pack $ hd:tl -- | Any string -str :: PandocMonad m => ParserT [Char] ParserState m Inlines +str :: PandocMonad m => ParserT Text ParserState 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 $ all isUpper baseStr - acro <- enclosed (char '(') (char ')') anyChar' - return $ concat [baseStr, " (", acro, ")"] + 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 => ParserT [Char] st m Inlines +whitespace :: PandocMonad m => ParserT Text st m Inlines whitespace = many1 spaceChar >> return B.space <?> "whitespace" -- | In Textile, an isolated endline character is a line break -endline :: PandocMonad m => ParserT [Char] ParserState m Inlines +endline :: PandocMonad m => ParserT Text ParserState m Inlines endline = try $ do newline notFollowedBy blankline @@ -543,18 +545,18 @@ endline = try $ do notFollowedBy rawHtmlBlock return B.linebreak -rawHtmlInline :: PandocMonad m => ParserT [Char] ParserState m Inlines +rawHtmlInline :: PandocMonad m => ParserT Text ParserState m Inlines rawHtmlInline = B.rawInline "html" . snd <$> htmlTag isInlineTag -- | Raw LaTeX Inline -rawLaTeXInline' :: PandocMonad m => ParserT [Char] ParserState m Inlines +rawLaTeXInline' :: PandocMonad m => ParserT Text ParserState 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 => ParserT [Char] ParserState m Inlines +link :: PandocMonad m => ParserT Text ParserState m Inlines link = try $ do bracketed <- (True <$ char '[') <|> return False char '"' *> notFollowedBy (oneOf " \t\n\r") @@ -567,121 +569,122 @@ link = try $ do else lookAhead $ space <|> eof' <|> try (oneOf "!.,;:" *> (space <|> newline <|> eof')) - url <- many1Till nonspaceChar stop + url <- T.pack <$> many1Till nonspaceChar stop 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' -- | image embedding -image :: PandocMonad m => ParserT [Char] ParserState m Inlines +image :: PandocMonad m => ParserT Text ParserState 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 <- many1 (noneOf " \t\n\r!(") - alt <- option "" $ try $ char '(' *> manyTill anyChar (char ')') + src <- T.pack <$> many1 (noneOf " \t\n\r!(") + alt <- fmap T.pack $ option "" $ try $ char '(' *> manyTill anyChar (char ')') char '!' return $ B.imageWith attr src alt (B.str alt) -escapedInline :: PandocMonad m => ParserT [Char] ParserState m Inlines +escapedInline :: PandocMonad m => ParserT Text ParserState m Inlines escapedInline = escapedEqs <|> escapedTag -escapedEqs :: PandocMonad m => ParserT [Char] ParserState m Inlines -escapedEqs = B.str <$> +escapedEqs :: PandocMonad m => ParserT Text ParserState m Inlines +escapedEqs = B.str . T.pack <$> try (string "==" *> manyTill anyChar' (try $ string "==")) -- | literal text escaped btw <notextile> tags -escapedTag :: PandocMonad m => ParserT [Char] ParserState m Inlines -escapedTag = B.str <$> +escapedTag :: PandocMonad m => ParserT Text ParserState m Inlines +escapedTag = B.str . T.pack <$> try (string "<notextile>" *> manyTill anyChar' (try $ string "</notextile>")) -- | Any special symbol defined in wordBoundaries -symbol :: PandocMonad m => ParserT [Char] ParserState m Inlines -symbol = B.str . singleton <$> (notFollowedBy newline *> - notFollowedBy rawHtmlBlock *> - oneOf wordBoundaries) +symbol :: PandocMonad m => ParserT Text ParserState m Inlines +symbol = B.str . T.singleton <$> (notFollowedBy newline *> + notFollowedBy rawHtmlBlock *> + oneOf wordBoundaries) -- | Inline code -code :: PandocMonad m => ParserT [Char] ParserState m Inlines +code :: PandocMonad m => ParserT Text ParserState m Inlines code = code1 <|> code2 -- any character except a newline before a blank line -anyChar' :: PandocMonad m => ParserT [Char] ParserState m Char +anyChar' :: PandocMonad m => ParserT Text ParserState m Char anyChar' = satisfy (/='\n') <|> try (char '\n' <* notFollowedBy blankline) -code1 :: PandocMonad m => ParserT [Char] ParserState m Inlines -code1 = B.code <$> surrounded (char '@') anyChar' +code1 :: PandocMonad m => ParserT Text ParserState m Inlines +code1 = B.code . T.pack <$> surrounded (char '@') anyChar' -code2 :: PandocMonad m => ParserT [Char] ParserState m Inlines +code2 :: PandocMonad m => ParserT Text ParserState m Inlines code2 = do htmlTag (tagOpen (=="tt") null) - B.code <$> manyTill anyChar' (try $ htmlTag $ tagClose (=="tt")) + B.code . T.pack <$> manyTill anyChar' (try $ htmlTag $ tagClose (=="tt")) -- | Html / CSS attributes -attributes :: PandocMonad m => ParserT [Char] ParserState m Attr +attributes :: PandocMonad m => ParserT Text ParserState m Attr attributes = foldl (flip ($)) ("",[],[]) <$> try (do special <- option id specialAttribute attrs <- many attribute return (special : attrs)) -specialAttribute :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr) +specialAttribute :: PandocMonad m => ParserT Text ParserState m (Attr -> Attr) specialAttribute = do alignStr <- ("center" <$ char '=') <|> ("justify" <$ try (string "<>")) <|> ("right" <$ char '>') <|> ("left" <$ char '<') notFollowedBy spaceChar - return $ addStyle ("text-align:" ++ alignStr) + return $ addStyle $ T.pack $ "text-align:" ++ alignStr -attribute :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr) +attribute :: PandocMonad m => ParserT Text ParserState m (Attr -> Attr) attribute = try $ (classIdAttr <|> styleAttr <|> langAttr) <* notFollowedBy spaceChar -classIdAttr :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr) +classIdAttr :: PandocMonad m => ParserT Text ParserState m (Attr -> Attr) classIdAttr = try $ do -- (class class #id) char '(' - ws <- words `fmap` manyTill anyChar' (char ')') + ws <- T.words `fmap` T.pack <$> manyTill anyChar' (char ')') case reverse ws of - [] -> return $ \(_,_,keyvals) -> ("",[],keyvals) - (('#':ident'):classes') -> return $ \(_,_,keyvals) -> - (ident',classes',keyvals) - classes' -> return $ \(_,_,keyvals) -> - ("",classes',keyvals) - -styleAttr :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr) + [] + -> return $ \(_,_,keyvals) -> ("",[],keyvals) + ((T.uncons -> Just ('#', ident')):classes') + -> return $ \(_,_,keyvals) -> (ident',classes',keyvals) + classes' + -> return $ \(_,_,keyvals) -> ("",classes',keyvals) + +styleAttr :: PandocMonad m => ParserT Text ParserState m (Attr -> Attr) styleAttr = do style <- try $ enclosed (char '{') (char '}') anyChar' - return $ addStyle style + return $ addStyle $ T.pack style -addStyle :: String -> Attr -> Attr +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 ++ ";" ++ concat [v | ("style",v) <- keyvals] + style' = style <> ";" <> T.concat [v | ("style",v) <- keyvals] -langAttr :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr) +langAttr :: PandocMonad m => ParserT Text ParserState m (Attr -> Attr) langAttr = do lang <- try $ enclosed (char '[') (char ']') alphaNum - return $ \(id',classes,keyvals) -> (id',classes,("lang",lang):keyvals) + return $ \(id',classes,keyvals) -> (id',classes,("lang",T.pack lang):keyvals) -- | Parses material surrounded by a parser. surrounded :: (PandocMonad m, Show t) - => ParserT [Char] st m t -- ^ surrounding parser - -> ParserT [Char] st m a -- ^ content parser (to be used repeatedly) - -> ParserT [Char] st m [a] + => ParserT Text st m t -- ^ surrounding parser + -> ParserT Text st m a -- ^ content parser (to be used repeatedly) + -> ParserT Text st m [a] surrounded border = enclosed (border *> notFollowedBy (oneOf " \t\n\r")) (try border) simpleInline :: PandocMonad m - => ParserT [Char] ParserState m t -- ^ surrounding parser + => ParserT Text ParserState m t -- ^ surrounding parser -> (Inlines -> Inlines) -- ^ Inline constructor - -> ParserT [Char] ParserState m Inlines -- ^ content parser (to be used repeatedly) + -> ParserT Text ParserState m Inlines -- ^ content parser (to be used repeatedly) simpleInline border construct = try $ do notAfterString border *> notFollowedBy (oneOf " \t\n\r") @@ -695,7 +698,7 @@ simpleInline border construct = try $ do then body else B.spanWith attr body -groupedInlineMarkup :: PandocMonad m => ParserT [Char] ParserState m Inlines +groupedInlineMarkup :: PandocMonad m => ParserT Text ParserState m Inlines groupedInlineMarkup = try $ do char '[' sp1 <- option mempty $ B.space <$ whitespace @@ -704,9 +707,5 @@ groupedInlineMarkup = try $ do char ']' return $ sp1 <> result <> sp2 --- | Create a singleton list -singleton :: a -> [a] -singleton x = [x] - -eof' :: Monad m => ParserT [Char] s m Char +eof' :: Monad m => ParserT Text s m Char eof' = '\n' <$ eof |