@@ -52,45 +52,6 @@ module Text.Pandoc.Shared (
52 BlockWrapper (..),
52 BlockWrapper (..),
53 wrappedBlocksToDoc,
53 wrappedBlocksToDoc,
54 tabFilter,
54 tabFilter,
74− withHorizDisplacement,
79− anyOrderedListMarker,
94 -- * Prettyprinting
55 -- * Prettyprinting
96 prettyPandoc,
57 prettyPandoc,
@@ -113,22 +74,18 @@ module Text.Pandoc.Shared (
115import Text.Pandoc.Definition
76import Text.Pandoc.Definition
116−import qualified Text.Pandoc.UTF8 as UTF8 (readFile, putStrLn)
77+import qualified Text.Pandoc.UTF8 as UTF8 (readFile)
117−import Text.ParserCombinators.Parsec
118import Text.PrettyPrint.HughesPJ ( Doc, fsep, ($$), (<>), empty, isEmpty, text, nest )
78import Text.PrettyPrint.HughesPJ ( Doc, fsep, ($$), (<>), empty, isEmpty, text, nest )
119import qualified Text.PrettyPrint.HughesPJ as PP
79import qualified Text.PrettyPrint.HughesPJ as PP
120−import Text.Pandoc.CharacterReferences ( characterReference )
121−import Data.Char ( toLower, toUpper, ord, isLower, isUpper, isAlpha, isAscii,
80+import Data.Char ( toLower, isLower, isUpper, isAlpha, isAscii,
122 isLetter, isDigit )
81 isLetter, isDigit )
123import Data.List ( find, isPrefixOf, intercalate )
82import Data.List ( find, isPrefixOf, intercalate )
124−import Network.URI ( parseURI, URI (..), isAllowedInURI, escapeURIString, unEscapeString )
83+import Network.URI ( isAllowedInURI, escapeURIString, unEscapeString )
125import Codec.Binary.UTF8.String ( encodeString, decodeString )
84import Codec.Binary.UTF8.String ( encodeString, decodeString )
126import System.Directory
85import System.Directory
127import System.FilePath ( (</>) )
86import System.FilePath ( (</>) )
128import Data.Generics (Typeable, Data)
87import Data.Generics (Typeable, Data)
129import qualified Control.Monad.State as S
88import qualified Control.Monad.State as S
130−import Control.Monad (join)
131−import qualified Data.Map as M
132import Paths_pandoc (getDataFileName)
89import Paths_pandoc (getDataFileName)
@@ -328,467 +285,6 @@ tabFilter tabStop =
328 x : go (spsToNextStop - 1) xs
285 x : go (spsToNextStop - 1) xs
329 in go tabStop
286 in go tabStop
335−-- | Like >>, but returns the operation on the left.
336−-- (Suggested by Tillmann Rendel on Haskell-cafe list.)
337−(>>~) :: (Monad m) => m a -> m b -> m a
338−a >>~ b = a >>= \x -> b >> return x
340−-- | Parse any line of text
341−anyLine :: GenParser Char st [Char]
342−anyLine = manyTill anyChar newline
344−-- | Like @manyTill@, but reads at least one item.
345−many1Till :: GenParser tok st a
346− -> GenParser tok st end
347− -> GenParser tok st [a]
350− rest <- manyTill p end
353−-- | A more general form of @notFollowedBy@. This one allows any
354−-- type of parser to be specified, and succeeds only if that parser fails.
355−-- It does not consume any input.
356−notFollowedBy' :: Show b => GenParser a st b -> GenParser a st ()
357−notFollowedBy' p = try $ join $ do a <- try p
358− return (unexpected (show a))
361−-- (This version due to Andrew Pimlott on the Haskell mailing list.)
363−-- | Parses one of a list of strings (tried in order).
364−oneOfStrings :: [String] -> GenParser Char st String
365−oneOfStrings listOfStrings = choice $ map (try . string) listOfStrings
367−-- | Parses a space or tab.
368−spaceChar :: CharParser st Char
369−spaceChar = char ' ' <|> char '\t'
371−-- | Skips zero or more spaces or tabs.
372−skipSpaces :: GenParser Char st ()
373−skipSpaces = skipMany spaceChar
375−-- | Skips zero or more spaces or tabs, then reads a newline.
376−blankline :: GenParser Char st Char
377−blankline = try $ skipSpaces >> newline
379−-- | Parses one or more blank lines and returns a string of newlines.
380−blanklines :: GenParser Char st [Char]
381−blanklines = many1 blankline
383−-- | Parses material enclosed between start and end parsers.
384−enclosed :: GenParser Char st t -- ^ start parser
385− -> GenParser Char st end -- ^ end parser
386− -> GenParser Char st a -- ^ content parser (to be used repeatedly)
387− -> GenParser Char st [a]
388−enclosed start end parser = try $
389− start >> notFollowedBy space >> many1Till parser end
391−-- | Parse string, case insensitive.
392−stringAnyCase :: [Char] -> CharParser st String
393−stringAnyCase [] = string ""
394−stringAnyCase (x:xs) = do
395− firstChar <- char (toUpper x) <|> char (toLower x)
396− rest <- stringAnyCase xs
397− return (firstChar:rest)
399−-- | Parse contents of 'str' using 'parser' and return result.
400−parseFromString :: GenParser tok st a -> [tok] -> GenParser tok st a
401−parseFromString parser str = do
402− oldPos <- getPosition
403− oldInput <- getInput
410−-- | Parse raw line block up to and including blank lines.
411−lineClump :: GenParser Char st String
412−lineClump = blanklines
413− <|> (many1 (notFollowedBy blankline >> anyLine) >>= return . unlines)
415−-- | Parse a string of characters between an open character
416−-- and a close character, including text between balanced
417−-- pairs of open and close, which must be different. For example,
418−-- @charsInBalanced '(' ')'@ will parse "(hello (there))"
419−-- and return "hello (there)". Stop if a blank line is
421−charsInBalanced :: Char -> Char -> GenParser Char st String
422−charsInBalanced open close = try $ do
424− raw <- many $ (many1 (noneOf [open, close, '\n']))
425− <|> (do res <- charsInBalanced open close
426− return $ [open] ++ res ++ [close])
427− <|> try (string "\n" >>~ notFollowedBy' blanklines)
431−-- | Like @charsInBalanced@, but allow blank lines in the content.
432−charsInBalanced' :: Char -> Char -> GenParser Char st String
433−charsInBalanced' open close = try $ do
435− raw <- many $ (many1 (noneOf [open, close]))
436− <|> (do res <- charsInBalanced' open close
437− return $ [open] ++ res ++ [close])
441−-- Auxiliary functions for romanNumeral:
443−lowercaseRomanDigits :: [Char]
444−lowercaseRomanDigits = ['i','v','x','l','c','d','m']
446−uppercaseRomanDigits :: [Char]
447−uppercaseRomanDigits = map toUpper lowercaseRomanDigits
449−-- | Parses a roman numeral (uppercase or lowercase), returns number.
450−romanNumeral :: Bool -- ^ Uppercase if true
451− -> GenParser Char st Int
452−romanNumeral upperCase = do
453− let romanDigits = if upperCase
454− then uppercaseRomanDigits
455− else lowercaseRomanDigits
456− lookAhead $ oneOf romanDigits
457− let [one, five, ten, fifty, hundred, fivehundred, thousand] =
458− map char romanDigits
459− thousands <- many thousand >>= (return . (1000 *) . length)
460− ninehundreds <- option 0 $ try $ hundred >> thousand >> return 900
461− fivehundreds <- many fivehundred >>= (return . (500 *) . length)
462− fourhundreds <- option 0 $ try $ hundred >> fivehundred >> return 400
463− hundreds <- many hundred >>= (return . (100 *) . length)
464− nineties <- option 0 $ try $ ten >> hundred >> return 90
465− fifties <- many fifty >>= (return . (50 *) . length)
466− forties <- option 0 $ try $ ten >> fifty >> return 40
467− tens <- many ten >>= (return . (10 *) . length)
468− nines <- option 0 $ try $ one >> ten >> return 9
469− fives <- many five >>= (return . (5 *) . length)
470− fours <- option 0 $ try $ one >> five >> return 4
471− ones <- many one >>= (return . length)
472− let total = thousands + ninehundreds + fivehundreds + fourhundreds +
473− hundreds + nineties + fifties + forties + tens + nines +
474− fives + fours + ones
476− then fail "not a roman numeral"
479−-- Parsers for email addresses and URIs
481−emailChar :: GenParser Char st Char
482−emailChar = alphaNum <|> oneOf "-+_."
484−domainChar :: GenParser Char st Char
485−domainChar = alphaNum <|> char '-'
487−domain :: GenParser Char st [Char]
489− first <- many1 domainChar
490− dom <- many1 $ try (char '.' >> many1 domainChar )
491− return $ intercalate "." (first:dom)
493−-- | Parses an email address; returns original and corresponding
494−-- escaped mailto: URI.
495−emailAddress :: GenParser Char st (String, String)
496−emailAddress = try $ do
497− firstLetter <- alphaNum
498− restAddr <- many emailChar
499− let addr = firstLetter:restAddr
502− let full = addr ++ '@':dom
503− return (full, escapeURI $ "mailto:" ++ full)
505−-- | Parses a URI. Returns pair of original and URI-escaped version.
506−uri :: GenParser Char st (String, String)
508− let protocols = [ "http:", "https:", "ftp:", "file:", "mailto:",
509− "news:", "telnet:" ]
510− lookAhead $ oneOfStrings protocols
511− -- scan non-ascii characters and ascii characters allowed in a URI
512− str <- many1 $ satisfy (\c -> not (isAscii c) || isAllowedInURI c)
513− -- now see if they amount to an absolute URI
514− case parseURI (escapeURI str) of
515− Just uri' -> if uriScheme uri' `elem` protocols
516− then return (str, show uri')
517− else fail "not a URI"
518− Nothing -> fail "not a URI"
520−-- | Applies a parser, returns tuple of its results and its horizontal
521−-- displacement (the difference between the source column at the end
522−-- and the source column at the beginning). Vertical displacement
523−-- (source row) is ignored.
524−withHorizDisplacement :: GenParser Char st a -- ^ Parser to apply
525− -> GenParser Char st (a, Int) -- ^ (result, displacement)
526−withHorizDisplacement parser = do
530− return (result, sourceColumn pos2 - sourceColumn pos1)
532−-- | Parses a character and returns 'Null' (so that the parser can move on
533−-- if it gets stuck).
534−nullBlock :: GenParser Char st Block
535−nullBlock = anyChar >> return Null
537−-- | Fail if reader is in strict markdown syntax mode.
538−failIfStrict :: GenParser Char ParserState ()
541− if stateStrict state then fail "strict mode" else return ()
543−-- | Fail unless we're in literate haskell mode.
544−failUnlessLHS :: GenParser tok ParserState ()
547− if stateLiterateHaskell state then return () else fail "Literate haskell feature"
549−-- | Parses backslash, then applies character parser.
550−escaped :: GenParser Char st Char -- ^ Parser for character to escape
551− -> GenParser Char st Inline
552−escaped parser = try $ do
555− return (Str [result])
557−-- | Parses an uppercase roman numeral and returns (UpperRoman, number).
558−upperRoman :: GenParser Char st (ListNumberStyle, Int)
560− num <- romanNumeral True
561− return (UpperRoman, num)
563−-- | Parses a lowercase roman numeral and returns (LowerRoman, number).
564−lowerRoman :: GenParser Char st (ListNumberStyle, Int)
566− num <- romanNumeral False
567− return (LowerRoman, num)
569−-- | Parses a decimal numeral and returns (Decimal, number).
570−decimal :: GenParser Char st (ListNumberStyle, Int)
573− return (Decimal, read num)
575−-- | Parses a '#' returns (DefaultStyle, 1).
576−defaultNum :: GenParser Char st (ListNumberStyle, Int)
579− return (DefaultStyle, 1)
581−-- | Parses a lowercase letter and returns (LowerAlpha, number).
582−lowerAlpha :: GenParser Char st (ListNumberStyle, Int)
584− ch <- oneOf ['a'..'z']
585− return (LowerAlpha, ord ch - ord 'a' + 1)
587−-- | Parses an uppercase letter and returns (UpperAlpha, number).
588−upperAlpha :: GenParser Char st (ListNumberStyle, Int)
590− ch <- oneOf ['A'..'Z']
591− return (UpperAlpha, ord ch - ord 'A' + 1)
593−-- | Parses a roman numeral i or I
594−romanOne :: GenParser Char st (ListNumberStyle, Int)
595−romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
596− (char 'I' >> return (UpperRoman, 1))
598−-- | Parses an ordered list marker and returns list attributes.
599−anyOrderedListMarker :: GenParser Char st ListAttributes
600−anyOrderedListMarker = choice $
601− [delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens],
602− numParser <- [decimal, defaultNum, romanOne,
603− lowerAlpha, lowerRoman, upperAlpha, upperRoman]]
605−-- | Parses a list number (num) followed by a period, returns list attributes.
606−inPeriod :: GenParser Char st (ListNumberStyle, Int)
607− -> GenParser Char st ListAttributes
608−inPeriod num = try $ do
609− (style, start) <- num
611− let delim = if style == DefaultStyle
614− return (start, style, delim)
616−-- | Parses a list number (num) followed by a paren, returns list attributes.
617−inOneParen :: GenParser Char st (ListNumberStyle, Int)
618− -> GenParser Char st ListAttributes
619−inOneParen num = try $ do
620− (style, start) <- num
622− return (start, style, OneParen)
624−-- | Parses a list number (num) enclosed in parens, returns list attributes.
625−inTwoParens :: GenParser Char st (ListNumberStyle, Int)
626− -> GenParser Char st ListAttributes
627−inTwoParens num = try $ do
629− (style, start) <- num
631− return (start, style, TwoParens)
633−-- | Parses an ordered list marker with a given style and delimiter,
635−orderedListMarker :: ListNumberStyle
637− -> GenParser Char st Int
638−orderedListMarker style delim = do
639− let num = defaultNum <|> -- # can continue any kind of list
641− DefaultStyle -> decimal
643− UpperRoman -> upperRoman
644− LowerRoman -> lowerRoman
645− UpperAlpha -> upperAlpha
646− LowerAlpha -> lowerAlpha
647− let context = case delim of
648− DefaultDelim -> inPeriod
650− OneParen -> inOneParen
651− TwoParens -> inTwoParens
652− (start, _, _) <- context num
655−-- | Parses a character reference and returns a Str element.
656−charRef :: GenParser Char st Inline
658− c <- characterReference
661−-- | Parse a string with a given parser and state.
662−readWith :: GenParser Char ParserState a -- ^ parser
663− -> ParserState -- ^ initial state
664− -> String -- ^ input string
666−readWith parser state input =
667− case runParser parser state "source" input of
668− Left err -> error $ "\nError:\n" ++ show err
669− Right result -> result
671−-- | Parse a string with @parser@ (for testing).
672−testStringWith :: (Show a) => GenParser Char ParserState a
675−testStringWith parser str = UTF8.putStrLn $ show $
676− readWith parser defaultParserState str
678−-- | Parsing options.
679−data ParserState = ParserState
680− { stateParseRaw :: Bool, -- ^ Parse raw HTML and LaTeX?
681− stateParserContext :: ParserContext, -- ^ Inside list?
682− stateQuoteContext :: QuoteContext, -- ^ Inside quoted environment?
683− stateSanitizeHTML :: Bool, -- ^ Sanitize HTML?
684− stateKeys :: KeyTable, -- ^ List of reference keys
686− stateCitations :: [String], -- ^ List of available citations
688− stateNotes :: NoteTable, -- ^ List of notes
689− stateTabStop :: Int, -- ^ Tab stop
690− stateStandalone :: Bool, -- ^ Parse bibliographic info?
691− stateTitle :: [Inline], -- ^ Title of document
692− stateAuthors :: [[Inline]], -- ^ Authors of document
693− stateDate :: [Inline], -- ^ Date of document
694− stateStrict :: Bool, -- ^ Use strict markdown syntax?
695− stateSmart :: Bool, -- ^ Use smart typography?
696− stateLiterateHaskell :: Bool, -- ^ Treat input as literate haskell
697− stateColumns :: Int, -- ^ Number of columns in terminal
698− stateHeaderTable :: [HeaderType], -- ^ Ordered list of header types used
699− stateIndentedCodeClasses :: [String] -- ^ Classes to use for indented code blocks
703−defaultParserState :: ParserState
705− ParserState { stateParseRaw = False,
706− stateParserContext = NullState,
707− stateQuoteContext = NoQuote,
708− stateSanitizeHTML = False,
709− stateKeys = M.empty,
711− stateCitations = [],
715− stateStandalone = False,
719− stateStrict = False,
721− stateLiterateHaskell = False,
723− stateHeaderTable = [],
724− stateIndentedCodeClasses = [] }
727− = SingleHeader Char -- ^ Single line of characters underneath
728− | DoubleHeader Char -- ^ Lines of characters above and below
732− = ListItemState -- ^ Used when running parser on list item contents
733− | NullState -- ^ Default state
737− = InSingleQuote -- ^ Used when parsing inside single quotes
738− | InDoubleQuote -- ^ Used when parsing inside double quotes
739− | NoQuote -- ^ Used when not parsing inside quotes
742−type NoteTable = [(String, String)]
744−newtype Key = Key [Inline] deriving (Show, Read)
746−instance Eq Key where
747− Key a == Key b = refsMatch a b
749−instance Ord Key where
750− compare (Key a) (Key b) = if a == b then EQ else compare a b
752−type KeyTable = M.Map Key Target
754−-- | Look up key in key table and return target object.
755−lookupKeySrc :: KeyTable -- ^ Key table
758−lookupKeySrc table key = case M.lookup key table of
760− Just src -> Just src
762−-- | Returns @True@ if keys match (case insensitive).
763−refsMatch :: [Inline] -> [Inline] -> Bool
764−refsMatch ((Str x):restx) ((Str y):resty) =
765− ((map toLower x) == (map toLower y)) && refsMatch restx resty
766−refsMatch ((Emph x):restx) ((Emph y):resty) =
767− refsMatch x y && refsMatch restx resty
768−refsMatch ((Strong x):restx) ((Strong y):resty) =
769− refsMatch x y && refsMatch restx resty
770−refsMatch ((Strikeout x):restx) ((Strikeout y):resty) =
771− refsMatch x y && refsMatch restx resty
772−refsMatch ((Superscript x):restx) ((Superscript y):resty) =
773− refsMatch x y && refsMatch restx resty
774−refsMatch ((Subscript x):restx) ((Subscript y):resty) =
775− refsMatch x y && refsMatch restx resty
776−refsMatch ((SmallCaps x):restx) ((SmallCaps y):resty) =
777− refsMatch x y && refsMatch restx resty
778−refsMatch ((Quoted t x):restx) ((Quoted u y):resty) =
779− t == u && refsMatch x y && refsMatch restx resty
780−refsMatch ((Code x):restx) ((Code y):resty) =
781− ((map toLower x) == (map toLower y)) && refsMatch restx resty
782−refsMatch ((Math t x):restx) ((Math u y):resty) =
783− ((map toLower x) == (map toLower y)) && t == u && refsMatch restx resty
784−refsMatch ((TeX x):restx) ((TeX y):resty) =
785− ((map toLower x) == (map toLower y)) && refsMatch restx resty
786−refsMatch ((HtmlInline x):restx) ((HtmlInline y):resty) =
787− ((map toLower x) == (map toLower y)) && refsMatch restx resty
788−refsMatch (x:restx) (y:resty) = (x == y) && refsMatch restx resty
789−refsMatch [] x = null x
790−refsMatch x [] = null x
793-- Prettyprinting
289-- Prettyprinting