@@ -0,0 +1,792 @@
1+{-
2+Copyright (C) 2006-7 John MacFarlane <jgm@berkeley.edu>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+
19+{- |
20+ Module : Text.Pandoc.Shared
21+ Copyright : Copyright (C) 2006-7 John MacFarlane
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : John MacFarlane <jgm@berkeley.edu>
25+ Stability : alpha
26+ Portability : portable
27+
28+Utility functions and definitions used by the various Pandoc modules.
29+-}
30+module Text.Pandoc.Shared (
31+ -- * List processing
32+ splitBy,
33+ splitByIndices,
34+ substitute,
35+ joinWithSep,
36+ -- * Text processing
37+ backslashEscapes,
38+ escapeStringUsing,
39+ stripTrailingNewlines,
40+ removeLeadingTrailingSpace,
41+ removeLeadingSpace,
42+ removeTrailingSpace,
43+ stripFirstAndLast,
44+ camelCaseToHyphenated,
45+ toRomanNumeral,
46+ wrapped,
47+ wrapIfNeeded,
48+ -- * Parsing
49+ (>>~),
50+ anyLine,
51+ many1Till,
52+ notFollowedBy',
53+ oneOfStrings,
54+ spaceChar,
55+ skipSpaces,
56+ blankline,
57+ blanklines,
58+ enclosed,
59+ stringAnyCase,
60+ parseFromString,
61+ lineClump,
62+ charsInBalanced,
63+ charsInBalanced',
64+ romanNumeral,
65+ withHorizDisplacement,
66+ nullBlock,
67+ failIfStrict,
68+ escaped,
69+ anyOrderedListMarker,
70+ orderedListMarker,
71+ charRef,
72+ readWith,
73+ testStringWith,
74+ ParserState (..),
75+ defaultParserState,
76+ HeaderType (..),
77+ ParserContext (..),
78+ QuoteContext (..),
79+ NoteTable,
80+ KeyTable,
81+ lookupKeySrc,
82+ refsMatch,
83+ -- * Native format prettyprinting
84+ prettyPandoc,
85+ -- * Pandoc block and inline list processing
86+ orderedListMarkers,
87+ normalizeSpaces,
88+ compactify,
89+ Element (..),
90+ hierarchicalize,
91+ isHeaderBlock,
92+ -- * Writer options
93+ WriterOptions (..),
94+ defaultWriterOptions
95+ ) where
96+
97+import Text.Pandoc.Definition
98+import Text.ParserCombinators.Parsec
99+import Text.PrettyPrint.HughesPJ ( Doc, fsep )
100+import Text.Pandoc.CharacterReferences ( characterReference )
101+import Data.Char ( toLower, toUpper, ord, isLower, isUpper )
102+import Data.List ( find, isPrefixOf )
103+import Control.Monad ( join )
104+
105+--
106+-- List processing
107+--
108+
109+-- | Split list by groups of one or more sep.
110+splitBy :: (Eq a) => a -> [a] -> [[a]]
111+splitBy _ [] = []
112+splitBy sep lst =
113+ let (first, rest) = break (== sep) lst
114+ rest' = dropWhile (== sep) rest
115+ in first:(splitBy sep rest')
116+
117+-- | Split list into chunks divided at specified indices.
118+splitByIndices :: [Int] -> [a] -> [[a]]
119+splitByIndices [] lst = [lst]
120+splitByIndices (x:xs) lst =
121+ let (first, rest) = splitAt x lst in
122+ first:(splitByIndices (map (\y -> y - x) xs) rest)
123+
124+-- | Replace each occurrence of one sublist in a list with another.
125+substitute :: (Eq a) => [a] -> [a] -> [a] -> [a]
126+substitute _ _ [] = []
127+substitute [] _ lst = lst
128+substitute target replacement lst =
129+ if target `isPrefixOf` lst
130+ then replacement ++ (substitute target replacement $ drop (length target) lst)
131+ else (head lst):(substitute target replacement $ tail lst)
132+
133+-- | Joins a list of lists, separated by another list.
134+joinWithSep :: [a] -- ^ List to use as separator
135+ -> [[a]] -- ^ Lists to join
136+ -> [a]
137+joinWithSep _ [] = []
138+joinWithSep sep lst = foldr1 (\a b -> a ++ sep ++ b) lst
139+
140+--
141+-- Text processing
142+--
143+
144+-- | Returns an association list of backslash escapes for the
145+-- designated characters.
146+backslashEscapes :: [Char] -- ^ list of special characters to escape
147+ -> [(Char, String)]
148+backslashEscapes = map (\ch -> (ch, ['\\',ch]))
149+
150+-- | Escape a string of characters, using an association list of
151+-- characters and strings.
152+escapeStringUsing :: [(Char, String)] -> String -> String
153+escapeStringUsing _ [] = ""
154+escapeStringUsing escapeTable (x:xs) =
155+ case (lookup x escapeTable) of
156+ Just str -> str ++ rest
157+ Nothing -> x:rest
158+ where rest = escapeStringUsing escapeTable xs
159+
160+-- | Strip trailing newlines from string.
161+stripTrailingNewlines :: String -> String
162+stripTrailingNewlines = reverse . dropWhile (== '\n') . reverse
163+
164+-- | Remove leading and trailing space (including newlines) from string.
165+removeLeadingTrailingSpace :: String -> String
166+removeLeadingTrailingSpace = removeLeadingSpace . removeTrailingSpace
167+
168+-- | Remove leading space (including newlines) from string.
169+removeLeadingSpace :: String -> String
170+removeLeadingSpace = dropWhile (`elem` " \n\t")
171+
172+-- | Remove trailing space (including newlines) from string.
173+removeTrailingSpace :: String -> String
174+removeTrailingSpace = reverse . removeLeadingSpace . reverse
175+
176+-- | Strip leading and trailing characters from string
177+stripFirstAndLast :: String -> String
178+stripFirstAndLast str =
179+ drop 1 $ take ((length str) - 1) str
180+
181+-- | Change CamelCase word to hyphenated lowercase (e.g., camel-case).
182+camelCaseToHyphenated :: String -> String
183+camelCaseToHyphenated [] = ""
184+camelCaseToHyphenated (a:b:rest) | isLower a && isUpper b =
185+ a:'-':(toLower b):(camelCaseToHyphenated rest)
186+camelCaseToHyphenated (a:rest) = (toLower a):(camelCaseToHyphenated rest)
187+
188+-- | Convert number < 4000 to uppercase roman numeral.
189+toRomanNumeral :: Int -> String
190+toRomanNumeral x =
191+ if x >= 4000 || x < 0
192+ then "?"
193+ else case x of
194+ _ | x >= 1000 -> "M" ++ toRomanNumeral (x - 1000)
195+ _ | x >= 900 -> "CM" ++ toRomanNumeral (x - 900)
196+ _ | x >= 500 -> "D" ++ toRomanNumeral (x - 500)
197+ _ | x >= 400 -> "CD" ++ toRomanNumeral (x - 400)
198+ _ | x >= 100 -> "C" ++ toRomanNumeral (x - 100)
199+ _ | x >= 90 -> "XC" ++ toRomanNumeral (x - 90)
200+ _ | x >= 50 -> "L" ++ toRomanNumeral (x - 50)
201+ _ | x >= 40 -> "XL" ++ toRomanNumeral (x - 40)
202+ _ | x >= 10 -> "X" ++ toRomanNumeral (x - 10)
203+ _ | x >= 9 -> "IX" ++ toRomanNumeral (x - 5)
204+ _ | x >= 5 -> "V" ++ toRomanNumeral (x - 5)
205+ _ | x >= 4 -> "IV" ++ toRomanNumeral (x - 4)
206+ _ | x >= 1 -> "I" ++ toRomanNumeral (x - 1)
207+ _ -> ""
208+
209+-- | Wrap inlines to line length.
210+wrapped :: Monad m => ([Inline] -> m Doc) -> [Inline] -> m Doc
211+wrapped listWriter sect = (mapM listWriter $ splitBy Space sect) >>=
212+ return . fsep
213+
214+wrapIfNeeded :: Monad m => WriterOptions -> ([Inline] -> m Doc) ->
215+ [Inline] -> m Doc
216+wrapIfNeeded opts = if writerWrapText opts
217+ then wrapped
218+ else ($)
219+
220+--
221+-- Parsing
222+--
223+
224+-- | Like >>, but returns the operation on the left.
225+-- (Suggested by Tillmann Rendel on Haskell-cafe list.)
226+(>>~) :: (Monad m) => m a -> m b -> m a
227+a >>~ b = a >>= \x -> b >> return x
228+
229+-- | Parse any line of text
230+anyLine :: GenParser Char st [Char]
231+anyLine = manyTill anyChar newline
232+
233+-- | Like @manyTill@, but reads at least one item.
234+many1Till :: GenParser tok st a
235+ -> GenParser tok st end
236+ -> GenParser tok st [a]
237+many1Till p end = do
238+ first <- p
239+ rest <- manyTill p end
240+ return (first:rest)
241+
242+-- | A more general form of @notFollowedBy@. This one allows any
243+-- type of parser to be specified, and succeeds only if that parser fails.
244+-- It does not consume any input.
245+notFollowedBy' :: Show b => GenParser a st b -> GenParser a st ()
246+notFollowedBy' p = try $ join $ do a <- try p
247+ return (unexpected (show a))
248+ <|>
249+ return (return ())
250+-- (This version due to Andrew Pimlott on the Haskell mailing list.)
251+
252+-- | Parses one of a list of strings (tried in order).
253+oneOfStrings :: [String] -> GenParser Char st String
254+oneOfStrings listOfStrings = choice $ map (try . string) listOfStrings
255+
256+-- | Parses a space or tab.
257+spaceChar :: CharParser st Char
258+spaceChar = char ' ' <|> char '\t'
259+
260+-- | Skips zero or more spaces or tabs.
261+skipSpaces :: GenParser Char st ()
262+skipSpaces = skipMany spaceChar
263+
264+-- | Skips zero or more spaces or tabs, then reads a newline.
265+blankline :: GenParser Char st Char
266+blankline = try $ skipSpaces >> newline
267+
268+-- | Parses one or more blank lines and returns a string of newlines.
269+blanklines :: GenParser Char st [Char]
270+blanklines = many1 blankline
271+
272+-- | Parses material enclosed between start and end parsers.
273+enclosed :: GenParser Char st t -- ^ start parser
274+ -> GenParser Char st end -- ^ end parser
275+ -> GenParser Char st a -- ^ content parser (to be used repeatedly)
276+ -> GenParser Char st [a]
277+enclosed start end parser = try $
278+ start >> notFollowedBy space >> many1Till parser end
279+
280+-- | Parse string, case insensitive.
281+stringAnyCase :: [Char] -> CharParser st String
282+stringAnyCase [] = string ""
283+stringAnyCase (x:xs) = do
284+ firstChar <- char (toUpper x) <|> char (toLower x)
285+ rest <- stringAnyCase xs
286+ return (firstChar:rest)
287+
288+-- | Parse contents of 'str' using 'parser' and return result.
289+parseFromString :: GenParser tok st a -> [tok] -> GenParser tok st a
290+parseFromString parser str = do
291+ oldPos <- getPosition
292+ oldInput <- getInput
293+ setInput str
294+ result <- parser
295+ setInput oldInput
296+ setPosition oldPos
297+ return result
298+
299+-- | Parse raw line block up to and including blank lines.
300+lineClump :: GenParser Char st String
301+lineClump = blanklines
302+ <|> (many1 (notFollowedBy blankline >> anyLine) >>= return . unlines)
303+
304+-- | Parse a string of characters between an open character
305+-- and a close character, including text between balanced
306+-- pairs of open and close, which must be different. For example,
307+-- @charsInBalanced '(' ')'@ will parse "(hello (there))"
308+-- and return "hello (there)". Stop if a blank line is
309+-- encountered.
310+charsInBalanced :: Char -> Char -> GenParser Char st String
311+charsInBalanced open close = try $ do
312+ char open
313+ raw <- many $ (many1 (noneOf [open, close, '\n']))
314+ <|> (do res <- charsInBalanced open close
315+ return $ [open] ++ res ++ [close])
316+ <|> try (string "\n" >>~ notFollowedBy' blanklines)
317+ char close
318+ return $ concat raw
319+
320+-- | Like @charsInBalanced@, but allow blank lines in the content.
321+charsInBalanced' :: Char -> Char -> GenParser Char st String
322+charsInBalanced' open close = try $ do
323+ char open
324+ raw <- many $ (many1 (noneOf [open, close]))
325+ <|> (do res <- charsInBalanced' open close
326+ return $ [open] ++ res ++ [close])
327+ char close
328+ return $ concat raw
329+
330+-- | Parses a roman numeral (uppercase or lowercase), returns number.
331+romanNumeral :: Bool -- ^ Uppercase if true
332+ -> GenParser Char st Int
333+romanNumeral upperCase = do
334+ let charAnyCase c = char (if upperCase then toUpper c else c)
335+ let one = charAnyCase 'i'
336+ let five = charAnyCase 'v'
337+ let ten = charAnyCase 'x'
338+ let fifty = charAnyCase 'l'
339+ let hundred = charAnyCase 'c'
340+ let fivehundred = charAnyCase 'd'
341+ let thousand = charAnyCase 'm'
342+ thousands <- many thousand >>= (return . (1000 *) . length)
343+ ninehundreds <- option 0 $ try $ hundred >> thousand >> return 900
344+ fivehundreds <- many fivehundred >>= (return . (500 *) . length)
345+ fourhundreds <- option 0 $ try $ hundred >> fivehundred >> return 400
346+ hundreds <- many hundred >>= (return . (100 *) . length)
347+ nineties <- option 0 $ try $ ten >> hundred >> return 90
348+ fifties <- many fifty >>= (return . (50 *) . length)
349+ forties <- option 0 $ try $ ten >> fifty >> return 40
350+ tens <- many ten >>= (return . (10 *) . length)
351+ nines <- option 0 $ try $ one >> ten >> return 9
352+ fives <- many five >>= (return . (5 *) . length)
353+ fours <- option 0 $ try $ one >> five >> return 4
354+ ones <- many one >>= (return . length)
355+ let total = thousands + ninehundreds + fivehundreds + fourhundreds +
356+ hundreds + nineties + fifties + forties + tens + nines +
357+ fives + fours + ones
358+ if total == 0
359+ then fail "not a roman numeral"
360+ else return total
361+
362+-- | Applies a parser, returns tuple of its results and its horizontal
363+-- displacement (the difference between the source column at the end
364+-- and the source column at the beginning). Vertical displacement
365+-- (source row) is ignored.
366+withHorizDisplacement :: GenParser Char st a -- ^ Parser to apply
367+ -> GenParser Char st (a, Int) -- ^ (result, displacement)
368+withHorizDisplacement parser = do
369+ pos1 <- getPosition
370+ result <- parser
371+ pos2 <- getPosition
372+ return (result, sourceColumn pos2 - sourceColumn pos1)
373+
374+-- | Parses a character and returns 'Null' (so that the parser can move on
375+-- if it gets stuck).
376+nullBlock :: GenParser Char st Block
377+nullBlock = anyChar >> return Null
378+
379+-- | Fail if reader is in strict markdown syntax mode.
380+failIfStrict :: GenParser Char ParserState ()
381+failIfStrict = do
382+ state <- getState
383+ if stateStrict state then fail "strict mode" else return ()
384+
385+-- | Parses backslash, then applies character parser.
386+escaped :: GenParser Char st Char -- ^ Parser for character to escape
387+ -> GenParser Char st Inline
388+escaped parser = try $ do
389+ char '\\'
390+ result <- parser
391+ return (Str [result])
392+
393+-- | Parses an uppercase roman numeral and returns (UpperRoman, number).
394+upperRoman :: GenParser Char st (ListNumberStyle, Int)
395+upperRoman = do
396+ num <- romanNumeral True
397+ return (UpperRoman, num)
398+
399+-- | Parses a lowercase roman numeral and returns (LowerRoman, number).
400+lowerRoman :: GenParser Char st (ListNumberStyle, Int)
401+lowerRoman = do
402+ num <- romanNumeral False
403+ return (LowerRoman, num)
404+
405+-- | Parses a decimal numeral and returns (Decimal, number).
406+decimal :: GenParser Char st (ListNumberStyle, Int)
407+decimal = do
408+ num <- many1 digit
409+ return (Decimal, read num)
410+
411+-- | Parses a '#' returns (DefaultStyle, 1).
412+defaultNum :: GenParser Char st (ListNumberStyle, Int)
413+defaultNum = do
414+ char '#'
415+ return (DefaultStyle, 1)
416+
417+-- | Parses a lowercase letter and returns (LowerAlpha, number).
418+lowerAlpha :: GenParser Char st (ListNumberStyle, Int)
419+lowerAlpha = do
420+ ch <- oneOf ['a'..'z']
421+ return (LowerAlpha, ord ch - ord 'a' + 1)
422+
423+-- | Parses an uppercase letter and returns (UpperAlpha, number).
424+upperAlpha :: GenParser Char st (ListNumberStyle, Int)
425+upperAlpha = do
426+ ch <- oneOf ['A'..'Z']
427+ return (UpperAlpha, ord ch - ord 'A' + 1)
428+
429+-- | Parses a roman numeral i or I
430+romanOne :: GenParser Char st (ListNumberStyle, Int)
431+romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
432+ (char 'I' >> return (UpperRoman, 1))
433+
434+-- | Parses an ordered list marker and returns list attributes.
435+anyOrderedListMarker :: GenParser Char st ListAttributes
436+anyOrderedListMarker = choice $
437+ [delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens],
438+ numParser <- [decimal, defaultNum, romanOne,
439+ lowerAlpha, lowerRoman, upperAlpha, upperRoman]]
440+
441+-- | Parses a list number (num) followed by a period, returns list attributes.
442+inPeriod :: GenParser Char st (ListNumberStyle, Int)
443+ -> GenParser Char st ListAttributes
444+inPeriod num = try $ do
445+ (style, start) <- num
446+ char '.'
447+ let delim = if style == DefaultStyle
448+ then DefaultDelim
449+ else Period
450+ return (start, style, delim)
451+
452+-- | Parses a list number (num) followed by a paren, returns list attributes.
453+inOneParen :: GenParser Char st (ListNumberStyle, Int)
454+ -> GenParser Char st ListAttributes
455+inOneParen num = try $ do
456+ (style, start) <- num
457+ char ')'
458+ return (start, style, OneParen)
459+
460+-- | Parses a list number (num) enclosed in parens, returns list attributes.
461+inTwoParens :: GenParser Char st (ListNumberStyle, Int)
462+ -> GenParser Char st ListAttributes
463+inTwoParens num = try $ do
464+ char '('
465+ (style, start) <- num
466+ char ')'
467+ return (start, style, TwoParens)
468+
469+-- | Parses an ordered list marker with a given style and delimiter,
470+-- returns number.
471+orderedListMarker :: ListNumberStyle
472+ -> ListNumberDelim
473+ -> GenParser Char st Int
474+orderedListMarker style delim = do
475+ let num = case style of
476+ DefaultStyle -> decimal <|> defaultNum
477+ Decimal -> decimal
478+ UpperRoman -> upperRoman
479+ LowerRoman -> lowerRoman
480+ UpperAlpha -> upperAlpha
481+ LowerAlpha -> lowerAlpha
482+ let context = case delim of
483+ DefaultDelim -> inPeriod
484+ Period -> inPeriod
485+ OneParen -> inOneParen
486+ TwoParens -> inTwoParens
487+ (start, _, _) <- context num
488+ return start
489+
490+-- | Parses a character reference and returns a Str element.
491+charRef :: GenParser Char st Inline
492+charRef = do
493+ c <- characterReference
494+ return $ Str [c]
495+
496+-- | Parse a string with a given parser and state.
497+readWith :: GenParser Char ParserState a -- ^ parser
498+ -> ParserState -- ^ initial state
499+ -> String -- ^ input string
500+ -> a
501+readWith parser state input =
502+ case runParser parser state "source" input of
503+ Left err -> error $ "\nError:\n" ++ show err
504+ Right result -> result
505+
506+-- | Parse a string with @parser@ (for testing).
507+testStringWith :: (Show a) => GenParser Char ParserState a
508+ -> String
509+ -> IO ()
510+testStringWith parser str = putStrLn $ show $
511+ readWith parser defaultParserState str
512+
513+-- | Parsing options.
514+data ParserState = ParserState
515+ { stateParseRaw :: Bool, -- ^ Parse raw HTML and LaTeX?
516+ stateParserContext :: ParserContext, -- ^ Inside list?
517+ stateQuoteContext :: QuoteContext, -- ^ Inside quoted environment?
518+ stateKeys :: KeyTable, -- ^ List of reference keys
519+ stateNotes :: NoteTable, -- ^ List of notes
520+ stateTabStop :: Int, -- ^ Tab stop
521+ stateStandalone :: Bool, -- ^ Parse bibliographic info?
522+ stateTitle :: [Inline], -- ^ Title of document
523+ stateAuthors :: [String], -- ^ Authors of document
524+ stateDate :: String, -- ^ Date of document
525+ stateStrict :: Bool, -- ^ Use strict markdown syntax?
526+ stateSmart :: Bool, -- ^ Use smart typography?
527+ stateColumns :: Int, -- ^ Number of columns in terminal
528+ stateHeaderTable :: [HeaderType] -- ^ Ordered list of header types used
529+ }
530+ deriving Show
531+
532+defaultParserState :: ParserState
533+defaultParserState =
534+ ParserState { stateParseRaw = False,
535+ stateParserContext = NullState,
536+ stateQuoteContext = NoQuote,
537+ stateKeys = [],
538+ stateNotes = [],
539+ stateTabStop = 4,
540+ stateStandalone = False,
541+ stateTitle = [],
542+ stateAuthors = [],
543+ stateDate = [],
544+ stateStrict = False,
545+ stateSmart = False,
546+ stateColumns = 80,
547+ stateHeaderTable = [] }
548+
549+data HeaderType
550+ = SingleHeader Char -- ^ Single line of characters underneath
551+ | DoubleHeader Char -- ^ Lines of characters above and below
552+ deriving (Eq, Show)
553+
554+data ParserContext
555+ = ListItemState -- ^ Used when running parser on list item contents
556+ | NullState -- ^ Default state
557+ deriving (Eq, Show)
558+
559+data QuoteContext
560+ = InSingleQuote -- ^ Used when parsing inside single quotes
561+ | InDoubleQuote -- ^ Used when parsing inside double quotes
562+ | NoQuote -- ^ Used when not parsing inside quotes
563+ deriving (Eq, Show)
564+
565+type NoteTable = [(String, [Block])]
566+
567+type KeyTable = [([Inline], Target)]
568+
569+-- | Look up key in key table and return target object.
570+lookupKeySrc :: KeyTable -- ^ Key table
571+ -> [Inline] -- ^ Key
572+ -> Maybe Target
573+lookupKeySrc table key = case find (refsMatch key . fst) table of
574+ Nothing -> Nothing
575+ Just (_, src) -> Just src
576+
577+-- | Returns @True@ if keys match (case insensitive).
578+refsMatch :: [Inline] -> [Inline] -> Bool
579+refsMatch ((Str x):restx) ((Str y):resty) =
580+ ((map toLower x) == (map toLower y)) && refsMatch restx resty
581+refsMatch ((Emph x):restx) ((Emph y):resty) =
582+ refsMatch x y && refsMatch restx resty
583+refsMatch ((Strong x):restx) ((Strong y):resty) =
584+ refsMatch x y && refsMatch restx resty
585+refsMatch ((Strikeout x):restx) ((Strikeout y):resty) =
586+ refsMatch x y && refsMatch restx resty
587+refsMatch ((Superscript x):restx) ((Superscript y):resty) =
588+ refsMatch x y && refsMatch restx resty
589+refsMatch ((Subscript x):restx) ((Subscript y):resty) =
590+ refsMatch x y && refsMatch restx resty
591+refsMatch ((Quoted t x):restx) ((Quoted u y):resty) =
592+ t == u && refsMatch x y && refsMatch restx resty
593+refsMatch ((Code x):restx) ((Code y):resty) =
594+ ((map toLower x) == (map toLower y)) && refsMatch restx resty
595+refsMatch ((TeX x):restx) ((TeX y):resty) =
596+ ((map toLower x) == (map toLower y)) && refsMatch restx resty
597+refsMatch ((HtmlInline x):restx) ((HtmlInline y):resty) =
598+ ((map toLower x) == (map toLower y)) && refsMatch restx resty
599+refsMatch (x:restx) (y:resty) = (x == y) && refsMatch restx resty
600+refsMatch [] x = null x
601+refsMatch x [] = null x
602+
603+--
604+-- Native format prettyprinting
605+--
606+
607+-- | Indent string as a block.
608+indentBy :: Int -- ^ Number of spaces to indent the block
609+ -> Int -- ^ Number of spaces (rel to block) to indent first line
610+ -> String -- ^ Contents of block to indent
611+ -> String
612+indentBy _ _ [] = ""
613+indentBy num first str =
614+ let (firstLine:restLines) = lines str
615+ firstLineIndent = num + first
616+ in (replicate firstLineIndent ' ') ++ firstLine ++ "\n" ++
617+ (joinWithSep "\n" $ map ((replicate num ' ') ++ ) restLines)
618+
619+-- | Prettyprint list of Pandoc blocks elements.
620+prettyBlockList :: Int -- ^ Number of spaces to indent list of blocks
621+ -> [Block] -- ^ List of blocks
622+ -> String
623+prettyBlockList indent [] = indentBy indent 0 "[]"
624+prettyBlockList indent blocks = indentBy indent (-2) $ "[ " ++
625+ (joinWithSep "\n, " (map prettyBlock blocks)) ++ " ]"
626+
627+-- | Prettyprint Pandoc block element.
628+prettyBlock :: Block -> String
629+prettyBlock (BlockQuote blocks) = "BlockQuote\n " ++
630+ (prettyBlockList 2 blocks)
631+prettyBlock (OrderedList attribs blockLists) =
632+ "OrderedList " ++ show attribs ++ "\n" ++ indentBy 2 0 ("[ " ++
633+ (joinWithSep ", " $ map (\blocks -> prettyBlockList 2 blocks)
634+ blockLists)) ++ " ]"
635+prettyBlock (BulletList blockLists) = "BulletList\n" ++
636+ indentBy 2 0 ("[ " ++ (joinWithSep ", "
637+ (map (\blocks -> prettyBlockList 2 blocks) blockLists))) ++ " ]"
638+prettyBlock (DefinitionList blockLists) = "DefinitionList\n" ++
639+ indentBy 2 0 ("[" ++ (joinWithSep ",\n"
640+ (map (\(term, blocks) -> " (" ++ show term ++ ",\n" ++
641+ indentBy 1 2 (prettyBlockList 2 blocks) ++ " )") blockLists))) ++ " ]"
642+prettyBlock (Table caption aligns widths header rows) =
643+ "Table " ++ show caption ++ " " ++ show aligns ++ " " ++
644+ show widths ++ "\n" ++ prettyRow header ++ " [\n" ++
645+ (joinWithSep ",\n" (map prettyRow rows)) ++ " ]"
646+ where prettyRow cols = indentBy 2 0 ("[ " ++ (joinWithSep ", "
647+ (map (\blocks -> prettyBlockList 2 blocks)
648+ cols))) ++ " ]"
649+prettyBlock block = show block
650+
651+-- | Prettyprint Pandoc document.
652+prettyPandoc :: Pandoc -> String
653+prettyPandoc (Pandoc meta blocks) = "Pandoc " ++ "(" ++ show meta ++
654+ ")\n" ++ (prettyBlockList 0 blocks) ++ "\n"
655+
656+--
657+-- Pandoc block and inline list processing
658+--
659+
660+-- | Generate infinite lazy list of markers for an ordered list,
661+-- depending on list attributes.
662+orderedListMarkers :: (Int, ListNumberStyle, ListNumberDelim) -> [String]
663+orderedListMarkers (start, numstyle, numdelim) =
664+ let singleton c = [c]
665+ nums = case numstyle of
666+ DefaultStyle -> map show [start..]
667+ Decimal -> map show [start..]
668+ UpperAlpha -> drop (start - 1) $ cycle $
669+ map singleton ['A'..'Z']
670+ LowerAlpha -> drop (start - 1) $ cycle $
671+ map singleton ['a'..'z']
672+ UpperRoman -> map toRomanNumeral [start..]
673+ LowerRoman -> map (map toLower . toRomanNumeral) [start..]
674+ inDelim str = case numdelim of
675+ DefaultDelim -> str ++ "."
676+ Period -> str ++ "."
677+ OneParen -> str ++ ")"
678+ TwoParens -> "(" ++ str ++ ")"
679+ in map inDelim nums
680+
681+-- | Normalize a list of inline elements: remove leading and trailing
682+-- @Space@ elements, collapse double @Space@s into singles, and
683+-- remove empty Str elements.
684+normalizeSpaces :: [Inline] -> [Inline]
685+normalizeSpaces [] = []
686+normalizeSpaces list =
687+ let removeDoubles [] = []
688+ removeDoubles (Space:Space:rest) = removeDoubles (Space:rest)
689+ removeDoubles (Space:(Str ""):Space:rest) = removeDoubles (Space:rest)
690+ removeDoubles ((Str ""):rest) = removeDoubles rest
691+ removeDoubles (x:rest) = x:(removeDoubles rest)
692+ removeLeading (Space:xs) = removeLeading xs
693+ removeLeading x = x
694+ removeTrailing [] = []
695+ removeTrailing lst = if (last lst == Space)
696+ then init lst
697+ else lst
698+ in removeLeading $ removeTrailing $ removeDoubles list
699+
700+-- | Change final list item from @Para@ to @Plain@ if the list should
701+-- be compact.
702+compactify :: [[Block]] -- ^ List of list items (each a list of blocks)
703+ -> [[Block]]
704+compactify [] = []
705+compactify items =
706+ let final = last items
707+ others = init items
708+ in case final of
709+ [Para a] -> if any containsPara others
710+ then items
711+ else others ++ [[Plain a]]
712+ _ -> items
713+
714+containsPara :: [Block] -> Bool
715+containsPara [] = False
716+containsPara ((Para _):_) = True
717+containsPara ((BulletList items):rest) = any containsPara items ||
718+ containsPara rest
719+containsPara ((OrderedList _ items):rest) = any containsPara items ||
720+ containsPara rest
721+containsPara ((DefinitionList items):rest) = any containsPara (map snd items) ||
722+ containsPara rest
723+containsPara (_:rest) = containsPara rest
724+
725+-- | Data structure for defining hierarchical Pandoc documents
726+data Element = Blk Block
727+ | Sec [Inline] [Element] deriving (Eq, Read, Show)
728+
729+-- | Returns @True@ on Header block with at least the specified level
730+headerAtLeast :: Int -> Block -> Bool
731+headerAtLeast level (Header x _) = x <= level
732+headerAtLeast _ _ = False
733+
734+-- | Convert list of Pandoc blocks into (hierarchical) list of Elements
735+hierarchicalize :: [Block] -> [Element]
736+hierarchicalize [] = []
737+hierarchicalize (block:rest) =
738+ case block of
739+ (Header level title) ->
740+ let (thisSection, rest') = break (headerAtLeast level) rest
741+ in (Sec title (hierarchicalize thisSection)):(hierarchicalize rest')
742+ x -> (Blk x):(hierarchicalize rest)
743+
744+-- | True if block is a Header block.
745+isHeaderBlock :: Block -> Bool
746+isHeaderBlock (Header _ _) = True
747+isHeaderBlock _ = False
748+
749+--
750+-- Writer options
751+--
752+
753+-- | Options for writers
754+data WriterOptions = WriterOptions
755+ { writerStandalone :: Bool -- ^ Include header and footer
756+ , writerHeader :: String -- ^ Header for the document
757+ , writerTitlePrefix :: String -- ^ Prefix for HTML titles
758+ , writerTabStop :: Int -- ^ Tabstop for conversion btw spaces and tabs
759+ , writerTableOfContents :: Bool -- ^ Include table of contents
760+ , writerS5 :: Bool -- ^ We're writing S5
761+ , writerUseASCIIMathML :: Bool -- ^ Use ASCIIMathML
762+ , writerASCIIMathMLURL :: Maybe String -- ^ URL to asciiMathML.js
763+ , writerIgnoreNotes :: Bool -- ^ Ignore footnotes (used in making toc)
764+ , writerIncremental :: Bool -- ^ Incremental S5 lists
765+ , writerNumberSections :: Bool -- ^ Number sections in LaTeX
766+ , writerIncludeBefore :: String -- ^ String to include before the body
767+ , writerIncludeAfter :: String -- ^ String to include after the body
768+ , writerStrictMarkdown :: Bool -- ^ Use strict markdown syntax
769+ , writerReferenceLinks :: Bool -- ^ Use reference links in writing markdown, rst
770+ , writerWrapText :: Bool -- ^ Wrap text to line length
771+ } deriving Show
772+
773+-- | Default writer options.
774+defaultWriterOptions :: WriterOptions
775+defaultWriterOptions =
776+ WriterOptions { writerStandalone = False
777+ , writerHeader = ""
778+ , writerTitlePrefix = ""
779+ , writerTabStop = 4
780+ , writerTableOfContents = False
781+ , writerS5 = False
782+ , writerUseASCIIMathML = False
783+ , writerASCIIMathMLURL = Nothing
784+ , writerIgnoreNotes = False
785+ , writerIncremental = False
786+ , writerNumberSections = False
787+ , writerIncludeBefore = ""
788+ , writerIncludeAfter = ""
789+ , writerStrictMarkdown = False
790+ , writerReferenceLinks = False
791+ , writerWrapText = True
792+ }