@@ -52,45 +52,6 @@ module Text.Pandoc.Shared (
5252 BlockWrapper (..),
5353 wrappedBlocksToDoc,
5454 tabFilter,
55− -- * Parsing
56− (>>~),
57− anyLine,
58− many1Till,
59− notFollowedBy',
60− oneOfStrings,
61− spaceChar,
62− skipSpaces,
63− blankline,
64− blanklines,
65− enclosed,
66− stringAnyCase,
67− parseFromString,
68− lineClump,
69− charsInBalanced,
70− charsInBalanced',
71− romanNumeral,
72− emailAddress,
73− uri,
74− withHorizDisplacement,
75− nullBlock,
76− failIfStrict,
77− failUnlessLHS,
78− escaped,
79− anyOrderedListMarker,
80− orderedListMarker,
81− charRef,
82− readWith,
83− testStringWith,
84− ParserState (..),
85− defaultParserState,
86− HeaderType (..),
87− ParserContext (..),
88− QuoteContext (..),
89− NoteTable,
90− KeyTable,
91− Key (..),
92− lookupKeySrc,
93− refsMatch,
9455 -- * Prettyprinting
9556 hang',
9657 prettyPandoc,
@@ -113,22 +74,18 @@ module Text.Pandoc.Shared (
11374 ) where
11475
11576import Text.Pandoc.Definition
116−import qualified Text.Pandoc.UTF8 as UTF8 (readFile, putStrLn)
117−import Text.ParserCombinators.Parsec
77+import qualified Text.Pandoc.UTF8 as UTF8 (readFile)
11878import Text.PrettyPrint.HughesPJ ( Doc, fsep, ($$), (<>), empty, isEmpty, text, nest )
11979import 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,
12281 isLetter, isDigit )
12382import Data.List ( find, isPrefixOf, intercalate )
124−import Network.URI ( parseURI, URI (..), isAllowedInURI, escapeURIString, unEscapeString )
83+import Network.URI ( isAllowedInURI, escapeURIString, unEscapeString )
12584import Codec.Binary.UTF8.String ( encodeString, decodeString )
12685import System.Directory
12786import System.FilePath ( (</>) )
12887import Data.Generics (Typeable, Data)
12988import qualified Control.Monad.State as S
130−import Control.Monad (join)
131−import qualified Data.Map as M
13289import Paths_pandoc (getDataFileName)
13390
13491--
@@ -328,467 +285,6 @@ tabFilter tabStop =
328285 x : go (spsToNextStop - 1) xs
329286 in go tabStop
330287
331−--
332−-- Parsing
333−--
334−
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
339−
340−-- | Parse any line of text
341−anyLine :: GenParser Char st [Char]
342−anyLine = manyTill anyChar newline
343−
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]
348−many1Till p end = do
349− first <- p
350− rest <- manyTill p end
351− return (first:rest)
352−
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))
359− <|>
360− return (return ())
361−-- (This version due to Andrew Pimlott on the Haskell mailing list.)
362−
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
366−
367−-- | Parses a space or tab.
368−spaceChar :: CharParser st Char
369−spaceChar = char ' ' <|> char '\t'
370−
371−-- | Skips zero or more spaces or tabs.
372−skipSpaces :: GenParser Char st ()
373−skipSpaces = skipMany spaceChar
374−
375−-- | Skips zero or more spaces or tabs, then reads a newline.
376−blankline :: GenParser Char st Char
377−blankline = try $ skipSpaces >> newline
378−
379−-- | Parses one or more blank lines and returns a string of newlines.
380−blanklines :: GenParser Char st [Char]
381−blanklines = many1 blankline
382−
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
390−
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)
398−
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
404− setInput str
405− result <- parser
406− setInput oldInput
407− setPosition oldPos
408− return result
409−
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)
414−
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
420−-- encountered.
421−charsInBalanced :: Char -> Char -> GenParser Char st String
422−charsInBalanced open close = try $ do
423− char open
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)
428− char close
429− return $ concat raw
430−
431−-- | Like @charsInBalanced@, but allow blank lines in the content.
432−charsInBalanced' :: Char -> Char -> GenParser Char st String
433−charsInBalanced' open close = try $ do
434− char open
435− raw <- many $ (many1 (noneOf [open, close]))
436− <|> (do res <- charsInBalanced' open close
437− return $ [open] ++ res ++ [close])
438− char close
439− return $ concat raw
440−
441−-- Auxiliary functions for romanNumeral:
442−
443−lowercaseRomanDigits :: [Char]
444−lowercaseRomanDigits = ['i','v','x','l','c','d','m']
445−
446−uppercaseRomanDigits :: [Char]
447−uppercaseRomanDigits = map toUpper lowercaseRomanDigits
448−
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
475− if total == 0
476− then fail "not a roman numeral"
477− else return total
478−
479−-- Parsers for email addresses and URIs
480−
481−emailChar :: GenParser Char st Char
482−emailChar = alphaNum <|> oneOf "-+_."
483−
484−domainChar :: GenParser Char st Char
485−domainChar = alphaNum <|> char '-'
486−
487−domain :: GenParser Char st [Char]
488−domain = do
489− first <- many1 domainChar
490− dom <- many1 $ try (char '.' >> many1 domainChar )
491− return $ intercalate "." (first:dom)
492−
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
500− char '@'
501− dom <- domain
502− let full = addr ++ '@':dom
503− return (full, escapeURI $ "mailto:" ++ full)
504−
505−-- | Parses a URI. Returns pair of original and URI-escaped version.
506−uri :: GenParser Char st (String, String)
507−uri = try $ do
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"
519−
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
527− pos1 <- getPosition
528− result <- parser
529− pos2 <- getPosition
530− return (result, sourceColumn pos2 - sourceColumn pos1)
531−
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
536−
537−-- | Fail if reader is in strict markdown syntax mode.
538−failIfStrict :: GenParser Char ParserState ()
539−failIfStrict = do
540− state <- getState
541− if stateStrict state then fail "strict mode" else return ()
542−
543−-- | Fail unless we're in literate haskell mode.
544−failUnlessLHS :: GenParser tok ParserState ()
545−failUnlessLHS = do
546− state <- getState
547− if stateLiterateHaskell state then return () else fail "Literate haskell feature"
548−
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
553− char '\\'
554− result <- parser
555− return (Str [result])
556−
557−-- | Parses an uppercase roman numeral and returns (UpperRoman, number).
558−upperRoman :: GenParser Char st (ListNumberStyle, Int)
559−upperRoman = do
560− num <- romanNumeral True
561− return (UpperRoman, num)
562−
563−-- | Parses a lowercase roman numeral and returns (LowerRoman, number).
564−lowerRoman :: GenParser Char st (ListNumberStyle, Int)
565−lowerRoman = do
566− num <- romanNumeral False
567− return (LowerRoman, num)
568−
569−-- | Parses a decimal numeral and returns (Decimal, number).
570−decimal :: GenParser Char st (ListNumberStyle, Int)
571−decimal = do
572− num <- many1 digit
573− return (Decimal, read num)
574−
575−-- | Parses a '#' returns (DefaultStyle, 1).
576−defaultNum :: GenParser Char st (ListNumberStyle, Int)
577−defaultNum = do
578− char '#'
579− return (DefaultStyle, 1)
580−
581−-- | Parses a lowercase letter and returns (LowerAlpha, number).
582−lowerAlpha :: GenParser Char st (ListNumberStyle, Int)
583−lowerAlpha = do
584− ch <- oneOf ['a'..'z']
585− return (LowerAlpha, ord ch - ord 'a' + 1)
586−
587−-- | Parses an uppercase letter and returns (UpperAlpha, number).
588−upperAlpha :: GenParser Char st (ListNumberStyle, Int)
589−upperAlpha = do
590− ch <- oneOf ['A'..'Z']
591− return (UpperAlpha, ord ch - ord 'A' + 1)
592−
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))
597−
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]]
604−
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
610− char '.'
611− let delim = if style == DefaultStyle
612− then DefaultDelim
613− else Period
614− return (start, style, delim)
615−
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
621− char ')'
622− return (start, style, OneParen)
623−
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
628− char '('
629− (style, start) <- num
630− char ')'
631− return (start, style, TwoParens)
632−
633−-- | Parses an ordered list marker with a given style and delimiter,
634−-- returns number.
635−orderedListMarker :: ListNumberStyle
636− -> ListNumberDelim
637− -> GenParser Char st Int
638−orderedListMarker style delim = do
639− let num = defaultNum <|> -- # can continue any kind of list
640− case style of
641− DefaultStyle -> decimal
642− Decimal -> decimal
643− UpperRoman -> upperRoman
644− LowerRoman -> lowerRoman
645− UpperAlpha -> upperAlpha
646− LowerAlpha -> lowerAlpha
647− let context = case delim of
648− DefaultDelim -> inPeriod
649− Period -> inPeriod
650− OneParen -> inOneParen
651− TwoParens -> inTwoParens
652− (start, _, _) <- context num
653− return start
654−
655−-- | Parses a character reference and returns a Str element.
656−charRef :: GenParser Char st Inline
657−charRef = do
658− c <- characterReference
659− return $ Str [c]
660−
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
665− -> a
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
670−
671−-- | Parse a string with @parser@ (for testing).
672−testStringWith :: (Show a) => GenParser Char ParserState a
673− -> String
674− -> IO ()
675−testStringWith parser str = UTF8.putStrLn $ show $
676− readWith parser defaultParserState str
677−
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
685−#ifdef _CITEPROC
686− stateCitations :: [String], -- ^ List of available citations
687−#endif
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
700− }
701− deriving Show
702−
703−defaultParserState :: ParserState
704−defaultParserState =
705− ParserState { stateParseRaw = False,
706− stateParserContext = NullState,
707− stateQuoteContext = NoQuote,
708− stateSanitizeHTML = False,
709− stateKeys = M.empty,
710−#ifdef _CITEPROC
711− stateCitations = [],
712−#endif
713− stateNotes = [],
714− stateTabStop = 4,
715− stateStandalone = False,
716− stateTitle = [],
717− stateAuthors = [],
718− stateDate = [],
719− stateStrict = False,
720− stateSmart = False,
721− stateLiterateHaskell = False,
722− stateColumns = 80,
723− stateHeaderTable = [],
724− stateIndentedCodeClasses = [] }
725−
726−data HeaderType
727− = SingleHeader Char -- ^ Single line of characters underneath
728− | DoubleHeader Char -- ^ Lines of characters above and below
729− deriving (Eq, Show)
730−
731−data ParserContext
732− = ListItemState -- ^ Used when running parser on list item contents
733− | NullState -- ^ Default state
734− deriving (Eq, Show)
735−
736−data QuoteContext
737− = InSingleQuote -- ^ Used when parsing inside single quotes
738− | InDoubleQuote -- ^ Used when parsing inside double quotes
739− | NoQuote -- ^ Used when not parsing inside quotes
740− deriving (Eq, Show)
741−
742−type NoteTable = [(String, String)]
743−
744−newtype Key = Key [Inline] deriving (Show, Read)
745−
746−instance Eq Key where
747− Key a == Key b = refsMatch a b
748−
749−instance Ord Key where
750− compare (Key a) (Key b) = if a == b then EQ else compare a b
751−
752−type KeyTable = M.Map Key Target
753−
754−-- | Look up key in key table and return target object.
755−lookupKeySrc :: KeyTable -- ^ Key table
756− -> Key -- ^ Key
757− -> Maybe Target
758−lookupKeySrc table key = case M.lookup key table of
759− Nothing -> Nothing
760− Just src -> Just src
761−
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
791−
792288--
793289-- Prettyprinting
794290--