diff options
author | fiddlosopher <fiddlosopher@788f1e2b-df1e-0410-8736-df70ead52e1b> | 2006-12-20 06:50:14 +0000 |
---|---|---|
committer | fiddlosopher <fiddlosopher@788f1e2b-df1e-0410-8736-df70ead52e1b> | 2006-12-20 06:50:14 +0000 |
commit | dc9c6450f3b16592d0ee865feafc17b670e4ad14 (patch) | |
tree | dc29955e1ea518d6652af3d12876863b19819f6d /src/Text/Pandoc/Shared.hs | |
parent | 42d29838960f9aed3a08a4d76fc7e9c3941680a8 (diff) | |
download | pandoc-dc9c6450f3b16592d0ee865feafc17b670e4ad14.tar.gz |
+ Added module data for haddock.
+ Reformatted code consistently.
git-svn-id: https://pandoc.googlecode.com/svn/trunk@252 788f1e2b-df1e-0410-8736-df70ead52e1b
Diffstat (limited to 'src/Text/Pandoc/Shared.hs')
-rw-r--r-- | src/Text/Pandoc/Shared.hs | 267 |
1 files changed, 163 insertions, 104 deletions
diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs index a420e3766..0bedef0bc 100644 --- a/src/Text/Pandoc/Shared.hs +++ b/src/Text/Pandoc/Shared.hs @@ -1,4 +1,14 @@ --- | Utility functions and definitions used by the various Pandoc modules. +{- | + Module : Text.Pandoc.Shared + Copyright : Copyright (C) 2006 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm at berkeley dot edu> + Stability : unstable + Portability : portable + +Utility functions and definitions used by the various Pandoc modules. +-} module Text.Pandoc.Shared ( -- * Text processing gsub, @@ -50,17 +60,16 @@ readWith :: GenParser Char ParserState a -- ^ parser -> a readWith parser state input = case runParser parser state "source" input of - Left err -> error $ "\nError:\n" ++ show err + Left err -> error $ "\nError:\n" ++ show err Right result -> result -- | Parse a string with @parser@ (for testing). testStringWith :: (Show a) => GenParser Char ParserState a - -> String - -> IO () -testStringWith parser str = putStrLn $ show $ readWith parser defaultParserState str - --- | Parser state + -> String + -> IO () +testStringWith parser str = putStrLn $ show $ + readWith parser defaultParserState str data HeaderType = SingleHeader Char -- ^ Single line of characters underneath @@ -68,24 +77,28 @@ data HeaderType deriving (Eq, Show) data ParserContext - = BlockQuoteState -- ^ Used when running parser on contents of blockquote - | ListItemState -- ^ Used when running parser on list item contents - | NullState -- ^ Default state + = BlockQuoteState -- ^ Used when running parser on contents of blockquote + | ListItemState -- ^ Used when running parser on list item contents + | NullState -- ^ Default state deriving (Eq, Show) data ParserState = ParserState - { stateParseRaw :: Bool, -- ^ Parse untranslatable HTML and LaTeX? - stateParserContext :: ParserContext, -- ^ What are we parsing? - stateKeyBlocks :: [Block], -- ^ List of reference key blocks - stateKeysUsed :: [[Inline]], -- ^ List of references used so far - stateNoteBlocks :: [Block], -- ^ List of note blocks - stateNoteIdentifiers :: [String], -- ^ List of footnote identifiers, in order encountered - stateTabStop :: Int, -- ^ Tab stop - stateStandalone :: Bool, -- ^ If @True@, parse bibliographic info - stateTitle :: [Inline], -- ^ Title of document - stateAuthors :: [String], -- ^ Authors of document - stateDate :: String, -- ^ Date of document - stateHeaderTable :: [HeaderType] -- ^ List of header types used, in what order (for reStructuredText only) + { stateParseRaw :: Bool, -- ^ Parse untranslatable HTML + -- and LaTeX? + stateParserContext :: ParserContext, -- ^ What are we parsing? + stateKeyBlocks :: [Block], -- ^ List of reference key blocks + stateKeysUsed :: [[Inline]], -- ^ List of references used + stateNoteBlocks :: [Block], -- ^ List of note blocks + stateNoteIdentifiers :: [String], -- ^ List of footnote identifiers + -- in the order encountered + stateTabStop :: Int, -- ^ Tab stop + stateStandalone :: Bool, -- ^ If @True@, parse + -- bibliographic info + stateTitle :: [Inline], -- ^ Title of document + stateAuthors :: [String], -- ^ Authors of document + stateDate :: String, -- ^ Date of document + stateHeaderTable :: [HeaderType] -- ^ List of header types used, + -- in what order (rst only) } deriving Show @@ -115,9 +128,9 @@ consolidateList (inline:rest) = inline:(consolidateList rest) consolidateList [] = [] -- | Indent string as a block. -indentBy :: Int -- ^ Number of spaces to indent the block - -> Int -- ^ Number of spaces to indent first line, relative to block - -> String -- ^ Contents of block to indent +indentBy :: Int -- ^ Number of spaces to indent the block + -> Int -- ^ Number of spaces (rel to block) to indent first line + -> String -- ^ Contents of block to indent -> String indentBy num first [] = "" indentBy num first str = @@ -130,19 +143,27 @@ prettyBlockList :: Int -- ^ Number of spaces to indent list of blocks -> [Block] -- ^ List of blocks -> String prettyBlockList indent [] = indentBy indent 0 "[]" -prettyBlockList indent blocks = indentBy indent (-2) $ "[ " ++ (joinWithSep "\n, " (map prettyBlock blocks)) ++ " ]" +prettyBlockList indent blocks = indentBy indent (-2) $ "[ " ++ + (joinWithSep "\n, " (map prettyBlock blocks)) ++ " ]" -- | Prettyprint Pandoc block element. prettyBlock :: Block -> String -prettyBlock (BlockQuote blocks) = "BlockQuote\n " ++ (prettyBlockList 2 blocks) -prettyBlock (Note ref blocks) = "Note " ++ (show ref) ++ "\n " ++ (prettyBlockList 2 blocks) -prettyBlock (OrderedList blockLists) = "OrderedList\n" ++ indentBy 2 0 ("[ " ++ (joinWithSep ", " (map (\blocks -> prettyBlockList 2 blocks) blockLists))) ++ " ]" -prettyBlock (BulletList blockLists) = "BulletList\n" ++ indentBy 2 0 ("[ " ++ (joinWithSep ", " (map (\blocks -> prettyBlockList 2 blocks) blockLists))) ++ " ]" +prettyBlock (BlockQuote blocks) = "BlockQuote\n " ++ + (prettyBlockList 2 blocks) +prettyBlock (Note ref blocks) = "Note " ++ (show ref) ++ "\n " ++ + (prettyBlockList 2 blocks) +prettyBlock (OrderedList blockLists) = + "OrderedList\n" ++ indentBy 2 0 ("[ " ++ (joinWithSep ", " + (map (\blocks -> prettyBlockList 2 blocks) blockLists))) ++ " ]" +prettyBlock (BulletList blockLists) = "BulletList\n" ++ + indentBy 2 0 ("[ " ++ (joinWithSep ", " + (map (\blocks -> prettyBlockList 2 blocks) blockLists))) ++ " ]" prettyBlock block = show block -- | Prettyprint Pandoc document. prettyPandoc :: Pandoc -> String -prettyPandoc (Pandoc meta blocks) = "Pandoc " ++ "(" ++ (show meta) ++ ")\n" ++ (prettyBlockList 0 blocks) ++ "\n" +prettyPandoc (Pandoc meta blocks) = "Pandoc " ++ "(" ++ (show meta) ++ + ")\n" ++ (prettyBlockList 0 blocks) ++ "\n" -- | Convert tabs to spaces (with adjustable tab stop). tabsToSpaces :: Int -- ^ Tabstop @@ -160,7 +181,9 @@ tabsInLine num tabstop "" = "" tabsInLine num tabstop (c:cs) = let replacement = (if (c == '\t') then (replicate num ' ') else [c]) in let nextnumraw = (num - (length replacement)) in - let nextnum = if (nextnumraw < 1) then (nextnumraw + tabstop) else nextnumraw in + let nextnum = if (nextnumraw < 1) + then (nextnumraw + tabstop) + else nextnumraw in replacement ++ (tabsInLine nextnum tabstop cs) -- | Substitute string for every occurrence of regular expression. @@ -175,10 +198,9 @@ backslashEscape :: [Char] -- ^ list of special characters to escape -> String -- ^ string input -> String backslashEscape special [] = [] -backslashEscape special (x:xs) = if x `elem` special then - '\\':x:(backslashEscape special xs) - else - x:(backslashEscape special xs) +backslashEscape special (x:xs) = if x `elem` special + then '\\':x:(backslashEscape special xs) + else x:(backslashEscape special xs) -- | Escape string by applying a function, but don't touch anything that matches regex. escapePreservingRegex :: (String -> String) -- ^ Escaping function @@ -187,10 +209,9 @@ escapePreservingRegex :: (String -> String) -- ^ Escaping function -> String escapePreservingRegex escapeFunction regex str = case (matchRegexAll regex str) of - Nothing -> escapeFunction str - Just (before, matched, after, _) -> - (escapeFunction before) ++ matched ++ - (escapePreservingRegex escapeFunction regex after) + Nothing -> escapeFunction str + Just (before, matched, after, _) -> (escapeFunction before) ++ + matched ++ (escapePreservingRegex escapeFunction regex after) -- | Returns @True@ if string ends with given character. endsWith :: Char -> [Char] -> Bool @@ -213,10 +234,9 @@ joinWithSep sep lst = foldr1 (\a b -> a ++ sep ++ b) lst stripTrailingNewlines :: String -> String stripTrailingNewlines "" = "" stripTrailingNewlines str = - if (last str) == '\n' then - stripTrailingNewlines (init str) - else - str + if (last str) == '\n' + then stripTrailingNewlines (init str) + else str -- | Remove leading and trailing space (including newlines) from string. removeLeadingTrailingSpace :: String -> String @@ -224,7 +244,8 @@ removeLeadingTrailingSpace = removeLeadingSpace . removeTrailingSpace -- | Remove leading space (including newlines) from string. removeLeadingSpace :: String -> String -removeLeadingSpace = dropWhile (\x -> (x == ' ') || (x == '\n') || (x == '\t')) +removeLeadingSpace = dropWhile (\x -> (x == ' ') || (x == '\n') || + (x == '\t')) -- | Remove trailing space (including newlines) from string. removeTrailingSpace :: String -> String @@ -248,12 +269,17 @@ normalizeSpaces list = removeDoubles (Space:Space:rest) = removeDoubles (Space:rest) removeDoubles (x:rest) = x:(removeDoubles rest) in let removeLeading [] = [] - removeLeading lst = if ((head lst) == Space) then tail lst else lst in + removeLeading lst = if ((head lst) == Space) + then tail lst + else lst in let removeTrailing [] = [] - removeTrailing lst = if ((last lst) == Space) then init lst else lst in + removeTrailing lst = if ((last lst) == Space) + then init lst + else lst in removeLeading $ removeTrailing $ removeDoubles list --- | Change final list item from @Para@ to @Plain@ if the list should be compact. +-- | Change final list item from @Para@ to @Plain@ if the list should +-- be compact. compactify :: [[Block]] -- ^ List of list items (each a list of blocks) -> [[Block]] compactify [] = [] @@ -261,30 +287,34 @@ compactify items = let final = last items others = init items in case final of - [Para a] -> if any containsPara others then items else others ++ [[Plain a]] + [Para a] -> if any containsPara others + then items + else others ++ [[Plain a]] otherwise -> items containsPara :: [Block] -> Bool containsPara [] = False containsPara ((Para a):rest) = True -containsPara ((BulletList items):rest) = (any containsPara items) || (containsPara rest) -containsPara ((OrderedList items):rest) = (any containsPara items) || (containsPara rest) +containsPara ((BulletList items):rest) = (any containsPara items) || + (containsPara rest) +containsPara ((OrderedList items):rest) = (any containsPara items) || + (containsPara rest) containsPara (x:rest) = containsPara rest -- | Options for writers data WriterOptions = WriterOptions - { writerStandalone :: Bool -- ^ If @True@, writer header and footer - , writerTitlePrefix :: String -- ^ Prefix for HTML titles - , writerHeader :: String -- ^ Header for the document - , writerIncludeBefore :: String -- ^ String to include before the document body - , writerIncludeAfter :: String -- ^ String to include after the document body - , writerSmart :: Bool -- ^ If @True@, use smart quotes, dashes, and ellipses - , writerS5 :: Bool -- ^ @True@ if we're writing S5 instead of normal HTML - , writerIncremental :: Bool -- ^ If @True@, display S5 lists incrementally - , writerNumberSections :: Bool -- ^ If @True@, number sections in LaTeX - , writerTabStop :: Int -- ^ Tabstop for conversion between spaces and tabs - } - deriving Show + { writerStandalone :: Bool -- ^ If @True@, writer header and footer + , writerTitlePrefix :: String -- ^ Prefix for HTML titles + , writerHeader :: String -- ^ Header for the document + , writerIncludeBefore :: String -- ^ String to include before the body + , writerIncludeAfter :: String -- ^ String to include after the body + , writerSmart :: Bool -- ^ If @True@, use smart typography + , writerS5 :: Bool -- ^ @True@ if we're writing S5 + , writerIncremental :: Bool -- ^ If @True@, inceremental S5 lists + , writerNumberSections :: Bool -- ^ If @True@, number sections in LaTeX + , writerTabStop :: Int -- ^ Tabstop for conversion between + -- spaces and tabs + } deriving Show -- -- Functions for constructing lists of reference keys @@ -296,10 +326,9 @@ keyFoundIn :: [Block] -- ^ List of key blocks to search -> Target -- ^ Target to search for -> Maybe String keyFoundIn [] src = Nothing -keyFoundIn ((Key [Str num] src1):rest) src = if (src1 == src) then - Just num - else - keyFoundIn rest src +keyFoundIn ((Key [Str num] src1):rest) src = if (src1 == src) + then Just num + else keyFoundIn rest src keyFoundIn (_:rest) src = keyFoundIn rest src -- | Return next unique numerical key, given keyList @@ -308,7 +337,7 @@ nextUniqueKey keys = let nums = [1..10000] notAKey n = not (any (== [Str (show n)]) keys) in case (find notAKey nums) of - Just x -> show x + Just x -> show x Nothing -> error "Could not find unique key for reference link" -- | Generate a reference for a URL (either an existing reference, if @@ -325,8 +354,10 @@ generateReference url title = do Just num -> return (Ref [Str num]) Nothing -> do let nextNum = nextUniqueKey keysUsed - updateState (\st -> st {stateKeyBlocks = (Key [Str nextNum] src):keyBlocks, - stateKeysUsed = [Str nextNum]:keysUsed}) + updateState (\st -> st { stateKeyBlocks = + (Key [Str nextNum] src):keyBlocks, + stateKeysUsed = + [Str nextNum]:keysUsed }) return (Ref [Str nextNum]) -- @@ -348,21 +379,25 @@ keyTable ((Key ref target):lst) = (((ref, target):table), rest) where (table, rest) = keyTable lst keyTable (Null:lst) = keyTable lst -- get rid of Nulls keyTable (Blank:lst) = keyTable lst -- get rid of Blanks -keyTable ((BlockQuote blocks):lst) = ((table1 ++ table2), ((BlockQuote rest1):rest2)) +keyTable ((BlockQuote blocks):lst) = ((table1 ++ table2), + ((BlockQuote rest1):rest2)) where (table1, rest1) = keyTable blocks (table2, rest2) = keyTable lst -keyTable ((Note ref blocks):lst) = ((table1 ++ table2), ((Note ref rest1):rest2)) +keyTable ((Note ref blocks):lst) = ((table1 ++ table2), + ((Note ref rest1):rest2)) where (table1, rest1) = keyTable blocks (table2, rest2) = keyTable lst -keyTable ((OrderedList blockLists):lst) = ((table1 ++ table2), ((OrderedList rest1):rest2)) - where results = map keyTable blockLists - rest1 = map snd results - table1 = concatMap fst results +keyTable ((OrderedList blockLists):lst) = ((table1 ++ table2), + ((OrderedList rest1):rest2)) + where results = map keyTable blockLists + rest1 = map snd results + table1 = concatMap fst results (table2, rest2) = keyTable lst -keyTable ((BulletList blockLists):lst) = ((table1 ++ table2), ((BulletList rest1):rest2)) - where results = map keyTable blockLists - rest1 = map snd results - table1 = concatMap fst results +keyTable ((BulletList blockLists):lst) = ((table1 ++ table2), + ((BulletList rest1):rest2)) + where results = map keyTable blockLists + rest1 = map snd results + table1 = concatMap fst results (table2, rest2) = keyTable lst keyTable (other:lst) = (table, (other:rest)) where (table, rest) = keyTable lst @@ -372,55 +407,79 @@ lookupKeySrc :: KeyTable -- ^ Key table -> [Inline] -- ^ Key -> Maybe Target lookupKeySrc table key = case table of - [] -> Nothing - (k, src):rest -> if (refsMatch k key) then Just src else lookupKeySrc rest key + [] -> Nothing + (k, src):rest -> if (refsMatch k key) + then Just src + else lookupKeySrc rest key -- | Returns @True@ if keys match (case insensitive). refsMatch :: [Inline] -> [Inline] -> Bool -refsMatch ((Str x):restx) ((Str y):resty) = ((map toLower x) == (map toLower y)) && refsMatch restx resty -refsMatch ((Code x):restx) ((Code y):resty) = ((map toLower x) == (map toLower y)) && refsMatch restx resty -refsMatch ((TeX x):restx) ((TeX y):resty) = ((map toLower x) == (map toLower y)) && refsMatch restx resty -refsMatch ((HtmlInline x):restx) ((HtmlInline y):resty) = ((map toLower x) == (map toLower y)) && refsMatch restx resty -refsMatch ((NoteRef x):restx) ((NoteRef y):resty) = ((map toLower x) == (map toLower y)) && refsMatch restx resty -refsMatch ((Emph x):restx) ((Emph y):resty) = refsMatch x y && refsMatch restx resty -refsMatch ((Strong x):restx) ((Strong y):resty) = refsMatch x y && refsMatch restx resty +refsMatch ((Str x):restx) ((Str y):resty) = + ((map toLower x) == (map toLower y)) && refsMatch restx resty +refsMatch ((Code x):restx) ((Code y):resty) = + ((map toLower x) == (map toLower y)) && refsMatch restx resty +refsMatch ((TeX x):restx) ((TeX y):resty) = + ((map toLower x) == (map toLower y)) && refsMatch restx resty +refsMatch ((HtmlInline x):restx) ((HtmlInline y):resty) = + ((map toLower x) == (map toLower y)) && refsMatch restx resty +refsMatch ((NoteRef x):restx) ((NoteRef y):resty) = + ((map toLower x) == (map toLower y)) && refsMatch restx resty +refsMatch ((Emph x):restx) ((Emph y):resty) = + refsMatch x y && refsMatch restx resty +refsMatch ((Strong x):restx) ((Strong y):resty) = + refsMatch x y && refsMatch restx resty refsMatch (x:restx) (y:resty) = (x == y) && refsMatch restx resty refsMatch [] x = null x refsMatch x [] = null x --- | Replace reference links with explicit links in list of blocks, removing key blocks. +-- | Replace reference links with explicit links in list of blocks, +-- removing key blocks. replaceReferenceLinks :: [Block] -> [Block] replaceReferenceLinks blocks = let (keytable, purged) = keyTable blocks in replaceRefLinksBlockList keytable purged --- | Use key table to replace reference links with explicit links in a list of blocks +-- | Use key table to replace reference links with explicit links in a list +-- of blocks replaceRefLinksBlockList :: KeyTable -> [Block] -> [Block] -replaceRefLinksBlockList keytable lst = map (replaceRefLinksBlock keytable) lst +replaceRefLinksBlockList keytable lst = + map (replaceRefLinksBlock keytable) lst -- | Use key table to replace reference links with explicit links in a block replaceRefLinksBlock :: KeyTable -> Block -> Block -replaceRefLinksBlock keytable (Plain lst) = Plain (map (replaceRefLinksInline keytable) lst) -replaceRefLinksBlock keytable (Para lst) = Para (map (replaceRefLinksInline keytable) lst) -replaceRefLinksBlock keytable (Header lvl lst) = Header lvl (map (replaceRefLinksInline keytable) lst) -replaceRefLinksBlock keytable (BlockQuote lst) = BlockQuote (map (replaceRefLinksBlock keytable) lst) -replaceRefLinksBlock keytable (Note ref lst) = Note ref (map (replaceRefLinksBlock keytable) lst) -replaceRefLinksBlock keytable (OrderedList lst) = OrderedList (map (replaceRefLinksBlockList keytable) lst) -replaceRefLinksBlock keytable (BulletList lst) = BulletList (map (replaceRefLinksBlockList keytable) lst) +replaceRefLinksBlock keytable (Plain lst) = + Plain (map (replaceRefLinksInline keytable) lst) +replaceRefLinksBlock keytable (Para lst) = + Para (map (replaceRefLinksInline keytable) lst) +replaceRefLinksBlock keytable (Header lvl lst) = + Header lvl (map (replaceRefLinksInline keytable) lst) +replaceRefLinksBlock keytable (BlockQuote lst) = + BlockQuote (map (replaceRefLinksBlock keytable) lst) +replaceRefLinksBlock keytable (Note ref lst) = + Note ref (map (replaceRefLinksBlock keytable) lst) +replaceRefLinksBlock keytable (OrderedList lst) = + OrderedList (map (replaceRefLinksBlockList keytable) lst) +replaceRefLinksBlock keytable (BulletList lst) = + BulletList (map (replaceRefLinksBlockList keytable) lst) replaceRefLinksBlock keytable other = other --- | Use key table to replace reference links with explicit links in an inline element. +-- | Use key table to replace reference links with explicit links in an +-- inline element. replaceRefLinksInline :: KeyTable -> Inline -> Inline replaceRefLinksInline keytable (Link text (Ref ref)) = (Link newText newRef) - where newRef = case lookupKeySrc keytable (if (null ref) then text else ref) of + where newRef = case lookupKeySrc keytable + (if (null ref) then text else ref) of Nothing -> (Ref ref) Just src -> src newText = map (replaceRefLinksInline keytable) text replaceRefLinksInline keytable (Image text (Ref ref)) = (Image newText newRef) - where newRef = case lookupKeySrc keytable (if (null ref) then text else ref) of + where newRef = case lookupKeySrc keytable + (if (null ref) then text else ref) of Nothing -> (Ref ref) Just src -> src newText = map (replaceRefLinksInline keytable) text -replaceRefLinksInline keytable (Emph lst) = Emph (map (replaceRefLinksInline keytable) lst) -replaceRefLinksInline keytable (Strong lst) = Strong (map (replaceRefLinksInline keytable) lst) +replaceRefLinksInline keytable (Emph lst) = + Emph (map (replaceRefLinksInline keytable) lst) +replaceRefLinksInline keytable (Strong lst) = + Strong (map (replaceRefLinksInline keytable) lst) replaceRefLinksInline keytable other = other |