module Text.Pandoc.Shared (
splitBy,
splitByIndices,
substitute,
backslashEscapes,
escapeStringUsing,
stripTrailingNewlines,
removeLeadingTrailingSpace,
removeLeadingSpace,
removeTrailingSpace,
stripFirstAndLast,
camelCaseToHyphenated,
toRomanNumeral,
wrapped,
wrapIfNeeded,
wrappedTeX,
wrapTeXIfNeeded,
BlockWrapper (..),
wrappedBlocksToDoc,
tabFilter,
(>>~),
anyLine,
many1Till,
notFollowedBy',
oneOfStrings,
spaceChar,
skipSpaces,
blankline,
blanklines,
enclosed,
stringAnyCase,
parseFromString,
lineClump,
charsInBalanced,
charsInBalanced',
romanNumeral,
emailAddress,
uri,
withHorizDisplacement,
nullBlock,
failIfStrict,
failUnlessLHS,
escaped,
anyOrderedListMarker,
orderedListMarker,
charRef,
readWith,
testStringWith,
ParserState (..),
defaultParserState,
HeaderType (..),
ParserContext (..),
QuoteContext (..),
NoteTable,
KeyTable,
lookupKeySrc,
refsMatch,
hang',
prettyPandoc,
orderedListMarkers,
normalizeSpaces,
compactify,
Element (..),
hierarchicalize,
uniqueIdent,
isHeaderBlock,
HTMLMathMethod (..),
ObfuscationMethod (..),
WriterOptions (..),
defaultWriterOptions,
inDirectory,
readDataFile
) where
import Text.Pandoc.Definition
import Text.ParserCombinators.Parsec
import Text.PrettyPrint.HughesPJ ( Doc, fsep, ($$), (<>), empty, isEmpty, text, nest )
import qualified Text.PrettyPrint.HughesPJ as PP
import Text.Pandoc.CharacterReferences ( characterReference )
import Data.Char ( toLower, toUpper, ord, isLower, isUpper, isAlpha,
isPunctuation )
import Data.List ( find, isPrefixOf, intercalate )
import Network.URI ( parseURI, URI (..), isAllowedInURI )
import System.Directory
import System.FilePath ( (</>) )
#if MIN_VERSION_base(4,2,0)
#else
import Prelude hiding ( putStr, putStrLn, writeFile, readFile, getContents )
import System.IO.UTF8
#endif
import Data.Generics
import qualified Control.Monad.State as S
import Control.Monad (join)
import Paths_pandoc (getDataFileName)
splitBy :: (Eq a) => a -> [a] -> [[a]]
splitBy _ [] = []
splitBy sep lst =
let (first, rest) = break (== sep) lst
rest' = dropWhile (== sep) rest
in first:(splitBy sep rest')
splitByIndices :: [Int] -> [a] -> [[a]]
splitByIndices [] lst = [lst]
splitByIndices (x:xs) lst =
let (first, rest) = splitAt x lst in
first:(splitByIndices (map (\y -> y x) xs) rest)
substitute :: (Eq a) => [a] -> [a] -> [a] -> [a]
substitute _ _ [] = []
substitute [] _ lst = lst
substitute target replacement lst =
if target `isPrefixOf` lst
then replacement ++ (substitute target replacement $ drop (length target) lst)
else (head lst):(substitute target replacement $ tail lst)
backslashEscapes :: [Char]
-> [(Char, String)]
backslashEscapes = map (\ch -> (ch, ['\\',ch]))
escapeStringUsing :: [(Char, String)] -> String -> String
escapeStringUsing _ [] = ""
escapeStringUsing escapeTable (x:xs) =
case (lookup x escapeTable) of
Just str -> str ++ rest
Nothing -> x:rest
where rest = escapeStringUsing escapeTable xs
stripTrailingNewlines :: String -> String
stripTrailingNewlines = reverse . dropWhile (== '\n') . reverse
removeLeadingTrailingSpace :: String -> String
removeLeadingTrailingSpace = removeLeadingSpace . removeTrailingSpace
removeLeadingSpace :: String -> String
removeLeadingSpace = dropWhile (`elem` " \n\t")
removeTrailingSpace :: String -> String
removeTrailingSpace = reverse . removeLeadingSpace . reverse
stripFirstAndLast :: String -> String
stripFirstAndLast str =
drop 1 $ take ((length str) 1) str
camelCaseToHyphenated :: String -> String
camelCaseToHyphenated [] = ""
camelCaseToHyphenated (a:b:rest) | isLower a && isUpper b =
a:'-':(toLower b):(camelCaseToHyphenated rest)
camelCaseToHyphenated (a:rest) = (toLower a):(camelCaseToHyphenated rest)
toRomanNumeral :: Int -> String
toRomanNumeral x =
if x >= 4000 || x < 0
then "?"
else case x of
_ | x >= 1000 -> "M" ++ toRomanNumeral (x 1000)
_ | x >= 900 -> "CM" ++ toRomanNumeral (x 900)
_ | x >= 500 -> "D" ++ toRomanNumeral (x 500)
_ | x >= 400 -> "CD" ++ toRomanNumeral (x 400)
_ | x >= 100 -> "C" ++ toRomanNumeral (x 100)
_ | x >= 90 -> "XC" ++ toRomanNumeral (x 90)
_ | x >= 50 -> "L" ++ toRomanNumeral (x 50)
_ | x >= 40 -> "XL" ++ toRomanNumeral (x 40)
_ | x >= 10 -> "X" ++ toRomanNumeral (x 10)
_ | x >= 9 -> "IX" ++ toRomanNumeral (x 5)
_ | x >= 5 -> "V" ++ toRomanNumeral (x 5)
_ | x >= 4 -> "IV" ++ toRomanNumeral (x 4)
_ | x >= 1 -> "I" ++ toRomanNumeral (x 1)
_ -> ""
wrapped :: Monad m => ([Inline] -> m Doc) -> [Inline] -> m Doc
wrapped listWriter sect = (mapM listWriter $ splitBy Space sect) >>=
return . fsep
wrapIfNeeded :: Monad m => WriterOptions -> ([Inline] -> m Doc) ->
[Inline] -> m Doc
wrapIfNeeded opts = if writerWrapText opts
then wrapped
else ($)
isNote :: Inline -> Bool
isNote (Note _) = True
isNote _ = False
wrappedTeX :: Monad m
=> Bool
-> ([Inline] -> m Doc)
-> [Inline]
-> m Doc
wrappedTeX includePercent listWriter sect = do
let (firstpart, rest) = break isNote sect
firstpartWrapped <- wrapped listWriter firstpart
if null rest
then return firstpartWrapped
else do let (note:rest') = rest
let (rest1, rest2) = break (== Space) rest'
rest1Out <- if null rest1
then return empty
else listWriter rest1
rest2Wrapped <- if null rest2
then return empty
else wrappedTeX includePercent listWriter (tail rest2)
noteText <- listWriter [note]
return $ (firstpartWrapped <> if includePercent then PP.char '%' else empty) $$
(noteText <> rest1Out) $$
rest2Wrapped
wrapTeXIfNeeded :: Monad m
=> WriterOptions
-> Bool
-> ([Inline] -> m Doc)
-> [Inline]
-> m Doc
wrapTeXIfNeeded opts includePercent = if writerWrapText opts
then wrappedTeX includePercent
else ($)
data BlockWrapper = Pad Doc | Reg Doc
wrappedBlocksToDoc :: [BlockWrapper] -> Doc
wrappedBlocksToDoc = foldr addBlock empty
where addBlock (Pad d) accum | isEmpty accum = d
addBlock (Pad d) accum = d $$ text "" $$ accum
addBlock (Reg d) accum = d $$ accum
tabFilter :: Int
-> String
-> String
tabFilter tabStop =
let go _ [] = ""
go _ ('\n':xs) = '\n' : go tabStop xs
go _ ('\r':'\n':xs) = '\n' : go tabStop xs
go _ ('\r':xs) = '\n' : go tabStop xs
go spsToNextStop ('\t':xs) =
if tabStop == 0
then '\t' : go tabStop xs
else replicate spsToNextStop ' ' ++ go tabStop xs
go 1 (x:xs) =
x : go tabStop xs
go spsToNextStop (x:xs) =
x : go (spsToNextStop 1) xs
in go tabStop
(>>~) :: (Monad m) => m a -> m b -> m a
a >>~ b = a >>= \x -> b >> return x
anyLine :: GenParser Char st [Char]
anyLine = manyTill anyChar newline
many1Till :: GenParser tok st a
-> GenParser tok st end
-> GenParser tok st [a]
many1Till p end = do
first <- p
rest <- manyTill p end
return (first:rest)
notFollowedBy' :: Show b => GenParser a st b -> GenParser a st ()
notFollowedBy' p = try $ join $ do a <- try p
return (unexpected (show a))
<|>
return (return ())
oneOfStrings :: [String] -> GenParser Char st String
oneOfStrings listOfStrings = choice $ map (try . string) listOfStrings
spaceChar :: CharParser st Char
spaceChar = char ' ' <|> char '\t'
skipSpaces :: GenParser Char st ()
skipSpaces = skipMany spaceChar
blankline :: GenParser Char st Char
blankline = try $ skipSpaces >> newline
blanklines :: GenParser Char st [Char]
blanklines = many1 blankline
enclosed :: GenParser Char st t
-> GenParser Char st end
-> GenParser Char st a
-> GenParser Char st [a]
enclosed start end parser = try $
start >> notFollowedBy space >> many1Till parser end
stringAnyCase :: [Char] -> CharParser st String
stringAnyCase [] = string ""
stringAnyCase (x:xs) = do
firstChar <- char (toUpper x) <|> char (toLower x)
rest <- stringAnyCase xs
return (firstChar:rest)
parseFromString :: GenParser tok st a -> [tok] -> GenParser tok st a
parseFromString parser str = do
oldPos <- getPosition
oldInput <- getInput
setInput str
result <- parser
setInput oldInput
setPosition oldPos
return result
lineClump :: GenParser Char st String
lineClump = blanklines
<|> (many1 (notFollowedBy blankline >> anyLine) >>= return . unlines)
charsInBalanced :: Char -> Char -> GenParser Char st String
charsInBalanced open close = try $ do
char open
raw <- many $ (many1 (noneOf [open, close, '\n']))
<|> (do res <- charsInBalanced open close
return $ [open] ++ res ++ [close])
<|> try (string "\n" >>~ notFollowedBy' blanklines)
char close
return $ concat raw
charsInBalanced' :: Char -> Char -> GenParser Char st String
charsInBalanced' open close = try $ do
char open
raw <- many $ (many1 (noneOf [open, close]))
<|> (do res <- charsInBalanced' open close
return $ [open] ++ res ++ [close])
char close
return $ concat raw
lowercaseRomanDigits :: [Char]
lowercaseRomanDigits = ['i','v','x','l','c','d','m']
uppercaseRomanDigits :: [Char]
uppercaseRomanDigits = map toUpper lowercaseRomanDigits
romanNumeral :: Bool
-> GenParser Char st Int
romanNumeral upperCase = do
let romanDigits = if upperCase
then uppercaseRomanDigits
else lowercaseRomanDigits
lookAhead $ oneOf romanDigits
let [one, five, ten, fifty, hundred, fivehundred, thousand] =
map char romanDigits
thousands <- many thousand >>= (return . (1000 *) . length)
ninehundreds <- option 0 $ try $ hundred >> thousand >> return 900
fivehundreds <- many fivehundred >>= (return . (500 *) . length)
fourhundreds <- option 0 $ try $ hundred >> fivehundred >> return 400
hundreds <- many hundred >>= (return . (100 *) . length)
nineties <- option 0 $ try $ ten >> hundred >> return 90
fifties <- many fifty >>= (return . (50 *) . length)
forties <- option 0 $ try $ ten >> fifty >> return 40
tens <- many ten >>= (return . (10 *) . length)
nines <- option 0 $ try $ one >> ten >> return 9
fives <- many five >>= (return . (5 *) . length)
fours <- option 0 $ try $ one >> five >> return 4
ones <- many one >>= (return . length)
let total = thousands + ninehundreds + fivehundreds + fourhundreds +
hundreds + nineties + fifties + forties + tens + nines +
fives + fours + ones
if total == 0
then fail "not a roman numeral"
else return total
emailChar :: GenParser Char st Char
emailChar = alphaNum <|> oneOf "-+_."
domainChar :: GenParser Char st Char
domainChar = alphaNum <|> char '-'
domain :: GenParser Char st [Char]
domain = do
first <- many1 domainChar
dom <- many1 $ try (char '.' >> many1 domainChar )
return $ intercalate "." (first:dom)
emailAddress :: GenParser Char st [Char]
emailAddress = try $ do
firstLetter <- alphaNum
restAddr <- many emailChar
let addr = firstLetter:restAddr
char '@'
dom <- domain
return $ addr ++ '@':dom
uri :: GenParser Char st String
uri = try $ do
str <- many1 $ satisfy isAllowedInURI
case parseURI str of
Just uri' -> if uriScheme uri' `elem` [ "http:", "https:", "ftp:",
"file:", "mailto:",
"news:", "telnet:" ]
then return $ show uri'
else fail "not a URI"
Nothing -> fail "not a URI"
withHorizDisplacement :: GenParser Char st a
-> GenParser Char st (a, Int)
withHorizDisplacement parser = do
pos1 <- getPosition
result <- parser
pos2 <- getPosition
return (result, sourceColumn pos2 sourceColumn pos1)
nullBlock :: GenParser Char st Block
nullBlock = anyChar >> return Null
failIfStrict :: GenParser Char ParserState ()
failIfStrict = do
state <- getState
if stateStrict state then fail "strict mode" else return ()
failUnlessLHS :: GenParser tok ParserState ()
failUnlessLHS = do
state <- getState
if stateLiterateHaskell state then return () else fail "Literate haskell feature"
escaped :: GenParser Char st Char
-> GenParser Char st Inline
escaped parser = try $ do
char '\\'
result <- parser
return (Str [result])
upperRoman :: GenParser Char st (ListNumberStyle, Int)
upperRoman = do
num <- romanNumeral True
return (UpperRoman, num)
lowerRoman :: GenParser Char st (ListNumberStyle, Int)
lowerRoman = do
num <- romanNumeral False
return (LowerRoman, num)
decimal :: GenParser Char st (ListNumberStyle, Int)
decimal = do
num <- many1 digit
return (Decimal, read num)
defaultNum :: GenParser Char st (ListNumberStyle, Int)
defaultNum = do
char '#'
return (DefaultStyle, 1)
lowerAlpha :: GenParser Char st (ListNumberStyle, Int)
lowerAlpha = do
ch <- oneOf ['a'..'z']
return (LowerAlpha, ord ch ord 'a' + 1)
upperAlpha :: GenParser Char st (ListNumberStyle, Int)
upperAlpha = do
ch <- oneOf ['A'..'Z']
return (UpperAlpha, ord ch ord 'A' + 1)
romanOne :: GenParser Char st (ListNumberStyle, Int)
romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
(char 'I' >> return (UpperRoman, 1))
anyOrderedListMarker :: GenParser Char st ListAttributes
anyOrderedListMarker = choice $
[delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens],
numParser <- [decimal, defaultNum, romanOne,
lowerAlpha, lowerRoman, upperAlpha, upperRoman]]
inPeriod :: GenParser Char st (ListNumberStyle, Int)
-> GenParser Char st ListAttributes
inPeriod num = try $ do
(style, start) <- num
char '.'
let delim = if style == DefaultStyle
then DefaultDelim
else Period
return (start, style, delim)
inOneParen :: GenParser Char st (ListNumberStyle, Int)
-> GenParser Char st ListAttributes
inOneParen num = try $ do
(style, start) <- num
char ')'
return (start, style, OneParen)
inTwoParens :: GenParser Char st (ListNumberStyle, Int)
-> GenParser Char st ListAttributes
inTwoParens num = try $ do
char '('
(style, start) <- num
char ')'
return (start, style, TwoParens)
orderedListMarker :: ListNumberStyle
-> ListNumberDelim
-> GenParser Char st Int
orderedListMarker style delim = do
let num = defaultNum <|>
case style of
DefaultStyle -> decimal
Decimal -> decimal
UpperRoman -> upperRoman
LowerRoman -> lowerRoman
UpperAlpha -> upperAlpha
LowerAlpha -> lowerAlpha
let context = case delim of
DefaultDelim -> inPeriod
Period -> inPeriod
OneParen -> inOneParen
TwoParens -> inTwoParens
(start, _, _) <- context num
return start
charRef :: GenParser Char st Inline
charRef = do
c <- characterReference
return $ Str [c]
readWith :: GenParser Char ParserState a
-> ParserState
-> String
-> a
readWith parser state input =
case runParser parser state "source" input of
Left err -> error $ "\nError:\n" ++ show err
Right result -> result
testStringWith :: (Show a) => GenParser Char ParserState a
-> String
-> IO ()
testStringWith parser str = putStrLn $ show $
readWith parser defaultParserState str
data ParserState = ParserState
{ stateParseRaw :: Bool,
stateParserContext :: ParserContext,
stateQuoteContext :: QuoteContext,
stateSanitizeHTML :: Bool,
stateKeys :: KeyTable,
#ifdef _CITEPROC
stateCitations :: [String],
#endif
stateNotes :: NoteTable,
stateTabStop :: Int,
stateStandalone :: Bool,
stateTitle :: [Inline],
stateAuthors :: [[Inline]],
stateDate :: [Inline],
stateStrict :: Bool,
stateSmart :: Bool,
stateLiterateHaskell :: Bool,
stateColumns :: Int,
stateHeaderTable :: [HeaderType],
stateIndentedCodeClasses :: [String]
}
deriving Show
defaultParserState :: ParserState
defaultParserState =
ParserState { stateParseRaw = False,
stateParserContext = NullState,
stateQuoteContext = NoQuote,
stateSanitizeHTML = False,
stateKeys = [],
#ifdef _CITEPROC
stateCitations = [],
#endif
stateNotes = [],
stateTabStop = 4,
stateStandalone = False,
stateTitle = [],
stateAuthors = [],
stateDate = [],
stateStrict = False,
stateSmart = False,
stateLiterateHaskell = False,
stateColumns = 80,
stateHeaderTable = [],
stateIndentedCodeClasses = [] }
data HeaderType
= SingleHeader Char
| DoubleHeader Char
deriving (Eq, Show)
data ParserContext
= ListItemState
| NullState
deriving (Eq, Show)
data QuoteContext
= InSingleQuote
| InDoubleQuote
| NoQuote
deriving (Eq, Show)
type NoteTable = [(String, String)]
type KeyTable = [([Inline], Target)]
lookupKeySrc :: KeyTable
-> [Inline]
-> Maybe Target
lookupKeySrc table key = case find (refsMatch key . fst) table of
Nothing -> Nothing
Just (_, src) -> Just src
refsMatch :: [Inline] -> [Inline] -> Bool
refsMatch ((Str x):restx) ((Str 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 ((Strikeout x):restx) ((Strikeout y):resty) =
refsMatch x y && refsMatch restx resty
refsMatch ((Superscript x):restx) ((Superscript y):resty) =
refsMatch x y && refsMatch restx resty
refsMatch ((Subscript x):restx) ((Subscript y):resty) =
refsMatch x y && refsMatch restx resty
refsMatch ((SmallCaps x):restx) ((SmallCaps y):resty) =
refsMatch x y && refsMatch restx resty
refsMatch ((Quoted t x):restx) ((Quoted u y):resty) =
t == u && refsMatch x y && refsMatch restx resty
refsMatch ((Code x):restx) ((Code y):resty) =
((map toLower x) == (map toLower y)) && refsMatch restx resty
refsMatch ((Math t x):restx) ((Math u y):resty) =
((map toLower x) == (map toLower y)) && t == u && 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 (x:restx) (y:resty) = (x == y) && refsMatch restx resty
refsMatch [] x = null x
refsMatch x [] = null x
hang' :: Doc -> Int -> Doc -> Doc
hang' d1 n d2 = d1 $$ (nest n d2)
indentBy :: Int
-> Int
-> String
-> String
indentBy _ _ [] = ""
indentBy num first str =
let (firstLine:restLines) = lines str
firstLineIndent = num + first
in (replicate firstLineIndent ' ') ++ firstLine ++ "\n" ++
(intercalate "\n" $ map ((replicate num ' ') ++ ) restLines)
prettyBlockList :: Int
-> [Block]
-> String
prettyBlockList indent [] = indentBy indent 0 "[]"
prettyBlockList indent blocks = indentBy indent (2) $ "[ " ++
(intercalate "\n, " (map prettyBlock blocks)) ++ " ]"
prettyBlock :: Block -> String
prettyBlock (BlockQuote blocks) = "BlockQuote\n " ++
(prettyBlockList 2 blocks)
prettyBlock (OrderedList attribs blockLists) =
"OrderedList " ++ show attribs ++ "\n" ++ indentBy 2 0 ("[ " ++
(intercalate ", " $ map (\blocks -> prettyBlockList 2 blocks)
blockLists)) ++ " ]"
prettyBlock (BulletList blockLists) = "BulletList\n" ++
indentBy 2 0 ("[ " ++ (intercalate ", "
(map (\blocks -> prettyBlockList 2 blocks) blockLists))) ++ " ]"
prettyBlock (DefinitionList items) = "DefinitionList\n" ++
indentBy 2 0 ("[ " ++ (intercalate "\n, "
(map (\(term, defs) -> "(" ++ show term ++ ",\n" ++
indentBy 3 0 ("[ " ++ (intercalate ", "
(map (\blocks -> prettyBlockList 2 blocks) defs)) ++ "]") ++
")") items))) ++ " ]"
prettyBlock (Table caption aligns widths header rows) =
"Table " ++ show caption ++ " " ++ show aligns ++ " " ++
show widths ++ "\n" ++ prettyRow header ++ " [\n" ++
(intercalate ",\n" (map prettyRow rows)) ++ " ]"
where prettyRow cols = indentBy 2 0 ("[ " ++ (intercalate ", "
(map (\blocks -> prettyBlockList 2 blocks)
cols))) ++ " ]"
prettyBlock block = show block
prettyPandoc :: Pandoc -> String
prettyPandoc (Pandoc meta blocks) = "Pandoc " ++ "(" ++ show meta ++
")\n" ++ (prettyBlockList 0 blocks) ++ "\n"
orderedListMarkers :: (Int, ListNumberStyle, ListNumberDelim) -> [String]
orderedListMarkers (start, numstyle, numdelim) =
let singleton c = [c]
nums = case numstyle of
DefaultStyle -> map show [start..]
Decimal -> map show [start..]
UpperAlpha -> drop (start 1) $ cycle $
map singleton ['A'..'Z']
LowerAlpha -> drop (start 1) $ cycle $
map singleton ['a'..'z']
UpperRoman -> map toRomanNumeral [start..]
LowerRoman -> map (map toLower . toRomanNumeral) [start..]
inDelim str = case numdelim of
DefaultDelim -> str ++ "."
Period -> str ++ "."
OneParen -> str ++ ")"
TwoParens -> "(" ++ str ++ ")"
in map inDelim nums
normalizeSpaces :: [Inline] -> [Inline]
normalizeSpaces [] = []
normalizeSpaces list =
let removeDoubles [] = []
removeDoubles (Space:Space:rest) = removeDoubles (Space:rest)
removeDoubles (Space:(Str ""):Space:rest) = removeDoubles (Space:rest)
removeDoubles ((Str ""):rest) = removeDoubles rest
removeDoubles (x:rest) = x:(removeDoubles rest)
removeLeading (Space:xs) = removeLeading xs
removeLeading x = x
removeTrailing [] = []
removeTrailing lst = if (last lst == Space)
then init lst
else lst
in removeLeading $ removeTrailing $ removeDoubles list
compactify :: [[Block]]
-> [[Block]]
compactify [] = []
compactify items =
case (init items, last items) of
(_,[]) -> items
(others, final) ->
case last final of
Para a -> case (filter isPara $ concat items) of
[_] -> others ++ [init final ++ [Plain a]]
_ -> items
_ -> items
isPara :: Block -> Bool
isPara (Para _) = True
isPara _ = False
data Element = Blk Block
| Sec Int [Int] String [Inline] [Element]
deriving (Eq, Read, Show, Typeable, Data)
inlineListToIdentifier :: [Inline] -> String
inlineListToIdentifier = dropWhile (not . isAlpha) . inlineListToIdentifier'
inlineListToIdentifier' :: [Inline] -> [Char]
inlineListToIdentifier' [] = ""
inlineListToIdentifier' (x:xs) =
xAsText ++ inlineListToIdentifier' xs
where xAsText = case x of
Str s -> filter (\c -> c `elem` "_-." || not (isPunctuation c)) $
intercalate "-" $ words $ map toLower s
Emph lst -> inlineListToIdentifier' lst
Strikeout lst -> inlineListToIdentifier' lst
Superscript lst -> inlineListToIdentifier' lst
SmallCaps lst -> inlineListToIdentifier' lst
Subscript lst -> inlineListToIdentifier' lst
Strong lst -> inlineListToIdentifier' lst
Quoted _ lst -> inlineListToIdentifier' lst
Cite _ lst -> inlineListToIdentifier' lst
Code s -> s
Space -> "-"
EmDash -> "-"
EnDash -> "-"
Apostrophe -> ""
Ellipses -> ""
LineBreak -> "-"
Math _ _ -> ""
TeX _ -> ""
HtmlInline _ -> ""
Link lst _ -> inlineListToIdentifier' lst
Image lst _ -> inlineListToIdentifier' lst
Note _ -> ""
hierarchicalize :: [Block] -> [Element]
hierarchicalize blocks = S.evalState (hierarchicalizeWithIds blocks) ([],[])
hierarchicalizeWithIds :: [Block] -> S.State ([Int],[String]) [Element]
hierarchicalizeWithIds [] = return []
hierarchicalizeWithIds ((Header level title'):xs) = do
(lastnum, usedIdents) <- S.get
let ident = uniqueIdent title' usedIdents
let lastnum' = take level lastnum
let newnum = if length lastnum' >= level
then init lastnum' ++ [last lastnum' + 1]
else lastnum ++ replicate (level length lastnum 1) 0 ++ [1]
S.put (newnum, (ident : usedIdents))
let (sectionContents, rest) = break (headerLtEq level) xs
sectionContents' <- hierarchicalizeWithIds sectionContents
rest' <- hierarchicalizeWithIds rest
return $ Sec level newnum ident title' sectionContents' : rest'
hierarchicalizeWithIds (x:rest) = do
rest' <- hierarchicalizeWithIds rest
return $ (Blk x) : rest'
headerLtEq :: Int -> Block -> Bool
headerLtEq level (Header l _) = l <= level
headerLtEq _ _ = False
uniqueIdent :: [Inline] -> [String] -> String
uniqueIdent title' usedIdents =
let baseIdent = inlineListToIdentifier title'
numIdent n = baseIdent ++ "-" ++ show n
in if baseIdent `elem` usedIdents
then case find (\x -> numIdent x `notElem` usedIdents) ([1..60000] :: [Int]) of
Just x -> numIdent x
Nothing -> baseIdent
else baseIdent
isHeaderBlock :: Block -> Bool
isHeaderBlock (Header _ _) = True
isHeaderBlock _ = False
data HTMLMathMethod = PlainMath
| LaTeXMathML (Maybe String)
| JsMath (Maybe String)
| GladTeX
| MimeTeX String
| MathML (Maybe String)
deriving (Show, Read, Eq)
data ObfuscationMethod = NoObfuscation
| ReferenceObfuscation
| JavascriptObfuscation
deriving (Show, Read, Eq)
data WriterOptions = WriterOptions
{ writerStandalone :: Bool
, writerTemplate :: String
, writerVariables :: [(String, String)]
, writerIncludeBefore :: String
, writerIncludeAfter :: String
, writerTabStop :: Int
, writerTableOfContents :: Bool
, writerS5 :: Bool
, writerXeTeX :: Bool
, writerHTMLMathMethod :: HTMLMathMethod
, writerIgnoreNotes :: Bool
, writerIncremental :: Bool
, writerNumberSections :: Bool
, writerStrictMarkdown :: Bool
, writerReferenceLinks :: Bool
, writerWrapText :: Bool
, writerLiterateHaskell :: Bool
, writerEmailObfuscation :: ObfuscationMethod
, writerIdentifierPrefix :: String
} deriving Show
defaultWriterOptions :: WriterOptions
defaultWriterOptions =
WriterOptions { writerStandalone = False
, writerTemplate = ""
, writerVariables = []
, writerIncludeBefore = ""
, writerIncludeAfter = ""
, writerTabStop = 4
, writerTableOfContents = False
, writerS5 = False
, writerXeTeX = False
, writerHTMLMathMethod = PlainMath
, writerIgnoreNotes = False
, writerIncremental = False
, writerNumberSections = False
, writerStrictMarkdown = False
, writerReferenceLinks = False
, writerWrapText = True
, writerLiterateHaskell = False
, writerEmailObfuscation = JavascriptObfuscation
, writerIdentifierPrefix = ""
}
inDirectory :: FilePath -> IO a -> IO a
inDirectory path action = do
oldDir <- getCurrentDirectory
setCurrentDirectory path
result <- action
setCurrentDirectory oldDir
return result
readDataFile :: Maybe FilePath -> FilePath -> IO String
readDataFile userDir fname =
case userDir of
Nothing -> getDataFileName fname >>= readFile
Just u -> catch (readFile $ u </> fname)
(\_ -> getDataFileName fname >>= readFile)