Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

hlint changes.

Browse source
This commit is contained in:
John MacFarlane 2017-10-27 21:29:22 -07:00
parent f3e901c29d
commit b201a8aa58
9 changed files with 118 additions and 126 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Text/Pandoc/MediaBag.hs
View file

@ -80,4 +80,4 @@ lookupMedia fp (MediaBag mediamap) = M.lookup (splitDirectories fp) mediamap
mediaDirectory :: MediaBag -> [(String, MimeType, Int)] mediaDirectory :: MediaBag -> [(String, MimeType, Int)]
mediaDirectory (MediaBag mediamap) = mediaDirectory (MediaBag mediamap) =
M.foldrWithKey (\fp (mime,contents) -> M.foldrWithKey (\fp (mime,contents) ->
(((Posix.joinPath fp), mime, fromIntegral $ BL.length contents):)) [] mediamap ((Posix.joinPath fp, mime, fromIntegral $ BL.length contents):)) [] mediamap

8
src/Text/Pandoc/PDF.hs
View file

@ -327,7 +327,7 @@ ms2pdf verbosity args source = do
putStrLn "[makePDF] Environment:" putStrLn "[makePDF] Environment:"
mapM_ print env' mapM_ print env'
putStr "\n" putStr "\n"
putStrLn $ "[makePDF] Contents:\n" putStrLn "[makePDF] Contents:\n"
putStr $ T.unpack source putStr $ T.unpack source
putStr "\n" putStr "\n"
(exit, out) <- E.catch (exit, out) <- E.catch
@ -351,9 +351,7 @@ html2pdf :: Verbosity -- ^ Verbosity level
-> IO (Either ByteString ByteString) -> IO (Either ByteString ByteString)
html2pdf verbosity program args source = do html2pdf verbosity program args source = do
pdfFile <- withTempFile "." "html2pdf.pdf" $ \fp _ -> return fp pdfFile <- withTempFile "." "html2pdf.pdf" $ \fp _ -> return fp
let pdfFileArgName = if program == "prince" let pdfFileArgName = ["-o" | program == "prince"]
then ["-o"]
else []
let programArgs = args ++ ["-"] ++ pdfFileArgName ++ [pdfFile] let programArgs = args ++ ["-"] ++ pdfFileArgName ++ [pdfFile]
env' <- getEnvironment env' <- getEnvironment
when (verbosity >= INFO) $ do when (verbosity >= INFO) $ do
@ -363,7 +361,7 @@ html2pdf verbosity program args source = do
putStrLn "[makePDF] Environment:" putStrLn "[makePDF] Environment:"
mapM_ print env' mapM_ print env'
putStr "\n" putStr "\n"
putStrLn $ "[makePDF] Contents of intermediate HTML:" putStrLn "[makePDF] Contents of intermediate HTML:"
TextIO.putStr source TextIO.putStr source
putStr "\n" putStr "\n"
(exit, out) <- E.catch (exit, out) <- E.catch

36
src/Text/Pandoc/Pretty.hs
View file

@ -78,6 +78,7 @@ module Text.Pandoc.Pretty (
where where
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad (when)
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.List (intersperse) import Data.List (intersperse)
@ -144,11 +145,10 @@ hcat = mconcat
-- between them. -- between them.
infixr 6 <+> infixr 6 <+>
(<+>) :: Doc -> Doc -> Doc (<+>) :: Doc -> Doc -> Doc
(<+>) x y = if isEmpty x (<+>) x y
then y | isEmpty x = y
else if isEmpty y | isEmpty y = x
then x | otherwise = x <> space <> y
else x <> space <> y
-- | Same as 'cat', but putting breakable spaces between the -- | Same as 'cat', but putting breakable spaces between the
-- 'Doc's. -- 'Doc's.
@ -158,20 +158,18 @@ hsep = foldr (<+>) empty
infixr 5 $$ infixr 5 $$
-- | @a $$ b@ puts @a@ above @b@. -- | @a $$ b@ puts @a@ above @b@.
($$) :: Doc -> Doc -> Doc ($$) :: Doc -> Doc -> Doc
($$) x y = if isEmpty x ($$) x y
then y | isEmpty x = y
else if isEmpty y | isEmpty y = x
then x | otherwise = x <> cr <> y
else x <> cr <> y
infixr 5 $+$ infixr 5 $+$
-- | @a $+$ b@ puts @a@ above @b@, with a blank line between. -- | @a $+$ b@ puts @a@ above @b@, with a blank line between.
($+$) :: Doc -> Doc -> Doc ($+$) :: Doc -> Doc -> Doc
($+$) x y = if isEmpty x ($+$) x y
then y | isEmpty x = y
else if isEmpty y | isEmpty y = x
then x | otherwise = x <> blankline <> y
else x <> blankline <> y
-- | List version of '$$'. -- | List version of '$$'.
vcat :: [Doc] -> Doc vcat :: [Doc] -> Doc
@ -217,9 +215,9 @@ outp off s | off < 0 = do -- offset < 0 means newline characters
outp off s = do -- offset >= 0 (0 might be combining char) outp off s = do -- offset >= 0 (0 might be combining char)
st' <- get st' <- get
let pref = prefix st' let pref = prefix st'
when (column st' == 0 && usePrefix st' && not (null pref)) $ do when (column st' == 0 && usePrefix st' && not (null pref)) $
modify $ \st -> st{ output = fromString pref : output st modify $ \st -> st{ output = fromString pref : output st
, column = column st + realLength pref } , column = column st + realLength pref }
modify $ \st -> st{ output = fromString s : output st modify $ \st -> st{ output = fromString s : output st
, column = column st + off , column = column st + off
, newlines = 0 } , newlines = 0 }
@ -328,9 +326,7 @@ renderList (BreakingSpace : xs) = do
renderList (AfterBreak s : xs) = do renderList (AfterBreak s : xs) = do
st <- get st <- get
if newlines st > 0 when (newlines st > 0) $ outp (realLength s) s
then outp (realLength s) s
else return ()
renderList xs renderList xs
renderList (Block i1 s1 : Block i2 s2 : xs) = renderList (Block i1 s1 : Block i2 s2 : xs) =

4
src/Text/Pandoc/Readers/CommonMark.hs
View file

@ -132,12 +132,12 @@ addBlock opts (Node _ (LIST listAttrs) nodes) =
setTightness = if listTight listAttrs setTightness = if listTight listAttrs
then map paraToPlain then map paraToPlain
else id else id
paraToPlain (Para xs) = Plain (xs) paraToPlain (Para xs) = Plain xs
paraToPlain x = x paraToPlain x = x
delim = case listDelim listAttrs of delim = case listDelim listAttrs of
PERIOD_DELIM -> Period PERIOD_DELIM -> Period
PAREN_DELIM -> OneParen PAREN_DELIM -> OneParen
addBlock opts (Node _ (TABLE alignments) nodes) = do addBlock opts (Node _ (TABLE alignments) nodes) =
(Table [] aligns widths headers rows :) (Table [] aligns widths headers rows :)
where aligns = map fromTableCellAlignment alignments where aligns = map fromTableCellAlignment alignments
fromTableCellAlignment NoAlignment = AlignDefault fromTableCellAlignment NoAlignment = AlignDefault

36
src/Text/Pandoc/Readers/Creole.hs
View file

@ -111,7 +111,7 @@ block = do
return res return res
nowiki :: PandocMonad m => CRLParser m B.Blocks nowiki :: PandocMonad m => CRLParser m B.Blocks
nowiki = try $ nowikiStart >> manyTill content nowikiEnd >>= return . B.codeBlock . mconcat nowiki = try $ fmap (B.codeBlock . mconcat) (nowikiStart >> manyTill content nowikiEnd)
where where
content = brackets <|> line content = brackets <|> line
brackets = try $ option "" ((:[]) <$> newline) brackets = try $ option "" ((:[]) <$> newline)
@ -124,7 +124,8 @@ nowiki = try $ nowikiStart >> manyTill content nowikiEnd >>= return . B.codeBloc
header :: PandocMonad m => CRLParser m B.Blocks header :: PandocMonad m => CRLParser m B.Blocks
header = try $ do header = try $ do
skipSpaces skipSpaces
level <- many1 (char '=') >>= return . length level <-
fmap length (many1 (char '='))
guard $ level <= 6 guard $ level <= 6
skipSpaces skipSpaces
content <- B.str <$> manyTill (noneOf "\n") headerEnd content <- B.str <$> manyTill (noneOf "\n") headerEnd
@ -145,16 +146,16 @@ anyListItem :: PandocMonad m => Int -> CRLParser m B.Blocks
anyListItem n = listItem '*' n <|> listItem '#' n anyListItem n = listItem '*' n <|> listItem '#' n
list :: PandocMonad m => Char -> ([B.Blocks] -> B.Blocks) -> Int -> CRLParser m B.Blocks list :: PandocMonad m => Char -> ([B.Blocks] -> B.Blocks) -> Int -> CRLParser m B.Blocks
list c f n = many1 (itemPlusSublist <|> listItem c n) list c f n =
>>= return . f fmap f (many1 (itemPlusSublist <|> listItem c n))
where itemPlusSublist = try $ listItem c n <+> anyList (n+1) where itemPlusSublist = try $ listItem c n <+> anyList (n+1)
listItem :: PandocMonad m => Char -> Int -> CRLParser m B.Blocks listItem :: PandocMonad m => Char -> Int -> CRLParser m B.Blocks
listItem c n = (listStart >> many1Till inline itemEnd) listItem c n =
>>= return . B.plain . B.trimInlines .mconcat fmap (B.plain . B.trimInlines .mconcat) (listStart >> many1Till inline itemEnd)
where where
listStart = try $ optional newline >> skipSpaces >> count n (char c) listStart = try $ optional newline >> skipSpaces >> count n (char c)
>> (lookAhead $ noneOf [c]) >> skipSpaces >> lookAhead (noneOf [c]) >> skipSpaces
itemEnd = endOfParaElement <|> nextItem n itemEnd = endOfParaElement <|> nextItem n
<|> if n < 3 then nextItem (n+1) <|> if n < 3 then nextItem (n+1)
else nextItem (n+1) <|> nextItem (n-1) else nextItem (n+1) <|> nextItem (n-1)
@ -176,7 +177,7 @@ table = try $ do
cellEnd = lookAhead $ try $ char '|' <|> rowEnd cellEnd = lookAhead $ try $ char '|' <|> rowEnd
para :: PandocMonad m => CRLParser m B.Blocks para :: PandocMonad m => CRLParser m B.Blocks
para = many1Till inline endOfParaElement >>= return . result . mconcat para = fmap (result . mconcat) (many1Till inline endOfParaElement)
where where
result content = if F.all (==Space) content result content = if F.all (==Space) content
then mempty then mempty
@ -192,7 +193,7 @@ endOfParaElement = lookAhead $ endOfInput <|> endOfPara
startOf :: PandocMonad m => CRLParser m a -> CRLParser m () startOf :: PandocMonad m => CRLParser m a -> CRLParser m ()
startOf p = try $ blankline >> p >> return mempty startOf p = try $ blankline >> p >> return mempty
startOfList = startOf $ anyList 1 startOfList = startOf $ anyList 1
startOfTable = startOf $ table startOfTable =startOf table
startOfHeader = startOf header startOfHeader = startOf header
startOfNowiki = startOf nowiki startOfNowiki = startOf nowiki
hr = startOf horizontalRule hr = startOf horizontalRule
@ -223,7 +224,8 @@ inline = choice [ whitespace
] <?> "inline" ] <?> "inline"
escapedChar :: PandocMonad m => CRLParser m B.Inlines escapedChar :: PandocMonad m => CRLParser m B.Inlines
escapedChar = (try $ char '~' >> noneOf "\t\n ") >>= return . B.str . (:[]) escapedChar =
fmap (B.str . (:[])) (try $ char '~' >> noneOf "\t\n ")
escapedLink :: PandocMonad m => CRLParser m B.Inlines escapedLink :: PandocMonad m => CRLParser m B.Inlines
escapedLink = try $ do escapedLink = try $ do
@ -234,7 +236,7 @@ escapedLink = try $ do
image :: PandocMonad m => CRLParser m B.Inlines image :: PandocMonad m => CRLParser m B.Inlines
image = try $ do image = try $ do
(orig, src) <- wikiImg (orig, src) <- wikiImg
return $ B.image src "" (B.str $ orig) return $ B.image src "" (B.str orig)
where where
linkSrc = many $ noneOf "|}\n\r\t" linkSrc = many $ noneOf "|}\n\r\t"
linkDsc = char '|' >> many (noneOf "}\n\r\t") linkDsc = char '|' >> many (noneOf "}\n\r\t")
@ -253,7 +255,7 @@ link = try $ do
linkSrc = many $ noneOf "|]\n\r\t" linkSrc = many $ noneOf "|]\n\r\t"
linkDsc :: PandocMonad m => String -> CRLParser m B.Inlines linkDsc :: PandocMonad m => String -> CRLParser m B.Inlines
linkDsc otxt = B.str linkDsc otxt = B.str
<$> (try $ option otxt <$> try (option otxt
(char '|' >> many (noneOf "]\n\r\t"))) (char '|' >> many (noneOf "]\n\r\t")))
linkImg = try $ char '|' >> image linkImg = try $ char '|' >> image
wikiLink = try $ do wikiLink = try $ do
@ -270,17 +272,17 @@ inlineNowiki :: PandocMonad m => CRLParser m B.Inlines
inlineNowiki = B.code <$> (start >> manyTill (noneOf "\n\r") end) inlineNowiki = B.code <$> (start >> manyTill (noneOf "\n\r") end)
where where
start = try $ string "{{{" start = try $ string "{{{"
end = try $ string "}}}" >> (lookAhead $ noneOf "}") end = try $ string "}}}" >> lookAhead (noneOf "}")
placeholder :: PandocMonad m => CRLParser m B.Inlines placeholder :: PandocMonad m => CRLParser m B.Inlines
-- The semantics of the placeholder is basicallly implementation -- The semantics of the placeholder is basicallly implementation
-- dependent, so there is no way to DTRT for all cases. -- dependent, so there is no way to DTRT for all cases.
-- So for now we just drop them. -- So for now we just drop them.
placeholder = B.text <$> (try $ string "<<<" >> manyTill anyChar (string ">>>") placeholder = B.text <$> try (string "<<<" >> manyTill anyChar (string ">>>")
>> return "") >> return "")
whitespace :: PandocMonad m => CRLParser m B.Inlines whitespace :: PandocMonad m => CRLParser m B.Inlines
whitespace = (lb <|> regsp) >>= return whitespace = (lb <|> regsp)
where lb = try $ skipMany spaceChar >> linebreak >> return B.space where lb = try $ skipMany spaceChar >> linebreak >> return B.space
regsp = try $ skipMany1 spaceChar >> return B.space regsp = try $ skipMany1 spaceChar >> return B.space
@ -290,11 +292,11 @@ linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
innerNewline = return B.space innerNewline = return B.space
symbol :: PandocMonad m => CRLParser m B.Inlines symbol :: PandocMonad m => CRLParser m B.Inlines
symbol = oneOf specialChars >>= return . B.str . (:[]) symbol = fmap (B.str . (:[])) (oneOf specialChars)
str :: PandocMonad m => CRLParser m B.Inlines str :: PandocMonad m => CRLParser m B.Inlines
str = let strChar = noneOf ("\t\n " ++ specialChars) in str = let strChar = noneOf ("\t\n " ++ specialChars) in
many1 strChar >>= return . B.str fmap B.str (many1 strChar)
bold :: PandocMonad m => CRLParser m B.Inlines bold :: PandocMonad m => CRLParser m B.Inlines
bold = B.strong . mconcat <$> bold = B.strong . mconcat <$>

40
src/Text/Pandoc/Readers/DocBook.hs
View file

@ -1,5 +1,5 @@
module Text.Pandoc.Readers.DocBook ( readDocBook ) where module Text.Pandoc.Readers.DocBook ( readDocBook ) where
import Data.Char (toUpper) import Data.Char (toUpper, isSpace)
import Text.Pandoc.Shared (safeRead, crFilter) import Text.Pandoc.Shared (safeRead, crFilter)
import Text.Pandoc.Options import Text.Pandoc.Options
import Text.Pandoc.Definition import Text.Pandoc.Definition
@ -8,7 +8,6 @@ import Text.XML.Light
import Text.HTML.TagSoup.Entity (lookupEntity) import Text.HTML.TagSoup.Entity (lookupEntity)
import Data.Either (rights) import Data.Either (rights)
import Data.Generics import Data.Generics
import Data.Char (isSpace)
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.List (intersperse) import Data.List (intersperse)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -528,7 +527,7 @@ readDocBook :: PandocMonad m => ReaderOptions -> Text -> m Pandoc
readDocBook _ inp = do readDocBook _ inp = do
let tree = normalizeTree . parseXML . handleInstructions let tree = normalizeTree . parseXML . handleInstructions
$ T.unpack $ crFilter inp $ T.unpack $ crFilter inp
(bs, st') <- flip runStateT (def{ dbContent = tree }) $ mapM parseBlock $ tree (bs, st') <- flip runStateT (def{ dbContent = tree }) $ mapM parseBlock tree
return $ Pandoc (dbMeta st') (toList . mconcat $ bs) return $ Pandoc (dbMeta st') (toList . mconcat $ bs)
-- We treat <?asciidoc-br?> specially (issue #1236), converting it -- We treat <?asciidoc-br?> specially (issue #1236), converting it
@ -567,14 +566,12 @@ normalizeTree = everywhere (mkT go)
go xs = xs go xs = xs
convertEntity :: String -> String convertEntity :: String -> String
convertEntity e = maybe (map toUpper e) id (lookupEntity e) convertEntity e = Data.Maybe.fromMaybe (map toUpper e) (lookupEntity e)
-- convenience function to get an attribute value, defaulting to "" -- convenience function to get an attribute value, defaulting to ""
attrValue :: String -> Element -> String attrValue :: String -> Element -> String
attrValue attr elt = attrValue attr elt =
case lookupAttrBy (\x -> qName x == attr) (elAttribs elt) of fromMaybe "" (lookupAttrBy (\x -> qName x == attr) (elAttribs elt))
Just z -> z
Nothing -> ""
-- convenience function -- convenience function
named :: String -> Element -> Bool named :: String -> Element -> Bool
@ -654,15 +651,17 @@ getMediaobject e = do
|| named "textobject" x || named "textobject" x
|| named "alt" x) el of || named "alt" x) el of
Nothing -> return mempty Nothing -> return mempty
Just z -> mconcat <$> (mapM parseInline $ elContent z) Just z -> mconcat <$>
mapM parseInline (elContent z)
figTitle <- gets dbFigureTitle figTitle <- gets dbFigureTitle
let (caption, title) = if isNull figTitle let (caption, title) = if isNull figTitle
then (getCaption e, "") then (getCaption e, "")
else (return figTitle, "fig:") else (return figTitle, "fig:")
liftM (imageWith attr imageUrl title) caption fmap (imageWith attr imageUrl title) caption
getBlocks :: PandocMonad m => Element -> DB m Blocks getBlocks :: PandocMonad m => Element -> DB m Blocks
getBlocks e = mconcat <$> (mapM parseBlock $ elContent e) getBlocks e = mconcat <$>
mapM parseBlock (elContent e)
parseBlock :: PandocMonad m => Content -> DB m Blocks parseBlock :: PandocMonad m => Content -> DB m Blocks
@ -806,7 +805,8 @@ parseBlock (Elem e) =
attrib <- case filterChild (named "attribution") e of attrib <- case filterChild (named "attribution") e of
Nothing -> return mempty Nothing -> return mempty
Just z -> (para . (str "— " <>) . mconcat) Just z -> (para . (str "— " <>) . mconcat)
<$> (mapM parseInline $ elContent z) <$>
mapM parseInline (elContent z)
contents <- getBlocks e contents <- getBlocks e
return $ blockQuote (contents <> attrib) return $ blockQuote (contents <> attrib)
listitems = mapM getBlocks $ filterChildren (named "listitem") e listitems = mapM getBlocks $ filterChildren (named "listitem") e
@ -906,7 +906,8 @@ parseBlock (Elem e) =
metaBlock = acceptingMetadata (getBlocks e) >> return mempty metaBlock = acceptingMetadata (getBlocks e) >> return mempty
getInlines :: PandocMonad m => Element -> DB m Inlines getInlines :: PandocMonad m => Element -> DB m Inlines
getInlines e' = (trimInlines . mconcat) <$> (mapM parseInline $ elContent e') getInlines e' = (trimInlines . mconcat) <$>
mapM parseInline (elContent e')
strContentRecursive :: Element -> String strContentRecursive :: Element -> String
strContentRecursive = strContent . strContentRecursive = strContent .
@ -919,7 +920,7 @@ elementToStr x = x
parseInline :: PandocMonad m => Content -> DB m Inlines parseInline :: PandocMonad m => Content -> DB m Inlines
parseInline (Text (CData _ s _)) = return $ text s parseInline (Text (CData _ s _)) = return $ text s
parseInline (CRef ref) = parseInline (CRef ref) =
return $ maybe (text $ map toUpper ref) (text) $ lookupEntity ref return $ maybe (text $ map toUpper ref) text $ lookupEntity ref
parseInline (Elem e) = parseInline (Elem e) =
case qName (elName e) of case qName (elName e) of
"equation" -> equation displayMath "equation" -> equation displayMath
@ -960,8 +961,10 @@ parseInline (Elem e) =
"userinput" -> codeWithLang "userinput" -> codeWithLang
"varargs" -> return $ code "(...)" "varargs" -> return $ code "(...)"
"keycap" -> return (str $ strContent e) "keycap" -> return (str $ strContent e)
"keycombo" -> keycombo <$> (mapM parseInline $ elContent e) "keycombo" -> keycombo <$>
"menuchoice" -> menuchoice <$> (mapM parseInline $ mapM parseInline (elContent e)
"menuchoice" -> menuchoice <$>
mapM parseInline (
filter isGuiMenu $ elContent e) filter isGuiMenu $ elContent e)
"xref" -> do "xref" -> do
content <- dbContent <$> get content <- dbContent <$> get
@ -980,7 +983,7 @@ parseInline (Elem e) =
ils <- innerInlines ils <- innerInlines
let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
Just h -> h Just h -> h
_ -> ('#' : attrValue "linkend" e) _ -> '#' : attrValue "linkend" e
let ils' = if ils == mempty then str href else ils let ils' = if ils == mempty then str href else ils
let attr = (attrValue "id" e, words $ attrValue "role" e, []) let attr = (attrValue "id" e, words $ attrValue "role" e, [])
return $ linkWith attr href "" ils' return $ linkWith attr href "" ils'
@ -990,7 +993,8 @@ parseInline (Elem e) =
"strong" -> strong <$> innerInlines "strong" -> strong <$> innerInlines
"strikethrough" -> strikeout <$> innerInlines "strikethrough" -> strikeout <$> innerInlines
_ -> emph <$> innerInlines _ -> emph <$> innerInlines
"footnote" -> (note . mconcat) <$> (mapM parseBlock $ elContent e) "footnote" -> (note . mconcat) <$>
mapM parseBlock (elContent e)
"title" -> return mempty "title" -> return mempty
"affiliation" -> return mempty "affiliation" -> return mempty
-- Note: this isn't a real docbook tag; it's what we convert -- Note: this isn't a real docbook tag; it's what we convert
@ -999,7 +1003,7 @@ parseInline (Elem e) =
"br" -> return linebreak "br" -> return linebreak
_ -> innerInlines _ -> innerInlines
where innerInlines = (trimInlines . mconcat) <$> where innerInlines = (trimInlines . mconcat) <$>
(mapM parseInline $ elContent e) mapM parseInline (elContent e)
equation constructor = return $ mconcat $ equation constructor = return $ mconcat $
map (constructor . writeTeX) map (constructor . writeTeX)
$ rights $ rights

24
src/Text/Pandoc/Readers/Docx/Combine.hs
View file

@ -36,16 +36,16 @@ spaceOutInlines ils =
right = case viewr contents of right = case viewr contents of
(_ :> Space) -> space (_ :> Space) -> space
_ -> mempty in _ -> mempty in
(left, (stackInlines fs $ trimInlines . Many $ contents), right) (left, stackInlines fs $ trimInlines . Many $ contents, right)
stackInlines :: [Modifier Inlines] -> Inlines -> Inlines stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
stackInlines [] ms = ms stackInlines [] ms = ms
stackInlines (NullModifier : fs) ms = stackInlines fs ms stackInlines (NullModifier : fs) ms = stackInlines fs ms
stackInlines ((Modifier f) : fs) ms = stackInlines (Modifier f : fs) ms =
if isEmpty ms if isEmpty ms
then stackInlines fs ms then stackInlines fs ms
else f $ stackInlines fs ms else f $ stackInlines fs ms
stackInlines ((AttrModifier f attr) : fs) ms = f attr $ stackInlines fs ms stackInlines (AttrModifier f attr : fs) ms = f attr $ stackInlines fs ms
unstackInlines :: Inlines -> ([Modifier Inlines], Inlines) unstackInlines :: Inlines -> ([Modifier Inlines], Inlines)
unstackInlines ms = case ilModifier ms of unstackInlines ms = case ilModifier ms of
@ -97,7 +97,7 @@ combineInlines x y =
let (xs', x') = inlinesR x let (xs', x') = inlinesR x
(y', ys') = inlinesL y (y', ys') = inlinesL y
in in
xs' <> (combineSingletonInlines x' y') <> ys' xs' <> combineSingletonInlines x' y' <> ys'
combineSingletonInlines :: Inlines -> Inlines -> Inlines combineSingletonInlines :: Inlines -> Inlines -> Inlines
combineSingletonInlines x y = combineSingletonInlines x y =
@ -114,10 +114,10 @@ combineSingletonInlines x y =
stackInlines (x_rem_attr ++ y_rem_attr) mempty stackInlines (x_rem_attr ++ y_rem_attr) mempty
| isEmpty xs -> | isEmpty xs ->
let (sp, y') = spaceOutInlinesL y in let (sp, y') = spaceOutInlinesL y in
(stackInlines x_rem_attr mempty) <> sp <> y' stackInlines x_rem_attr mempty <> sp <> y'
| isEmpty ys -> | isEmpty ys ->
let (x', sp) = spaceOutInlinesR x in let (x', sp) = spaceOutInlinesR x in
x' <> sp <> (stackInlines y_rem_attr mempty) x' <> sp <> stackInlines y_rem_attr mempty
| otherwise -> | otherwise ->
let (x', xsp) = spaceOutInlinesR x let (x', xsp) = spaceOutInlinesR x
(ysp, y') = spaceOutInlinesL y (ysp, y') = spaceOutInlinesL y
@ -130,15 +130,15 @@ combineSingletonInlines x y =
combineBlocks :: Blocks -> Blocks -> Blocks combineBlocks :: Blocks -> Blocks -> Blocks
combineBlocks bs cs combineBlocks bs cs
| bs' :> (BlockQuote bs'') <- viewr (unMany bs) | bs' :> BlockQuote bs'' <- viewr (unMany bs)
, (BlockQuote cs'') :< cs' <- viewl (unMany cs) = , BlockQuote cs'' :< cs' <- viewl (unMany cs) =
Many $ (bs' |> (BlockQuote (bs'' <> cs''))) >< cs' Many $ (bs' |> BlockQuote (bs'' <> cs'')) >< cs'
combineBlocks bs cs = bs <> cs combineBlocks bs cs = bs <> cs
instance (Monoid a, Eq a) => Eq (Modifier a) where instance (Monoid a, Eq a) => Eq (Modifier a) where
(Modifier f) == (Modifier g) = (f mempty == g mempty) (Modifier f) == (Modifier g) = f mempty == g mempty
(AttrModifier f attr) == (AttrModifier g attr') = (f attr mempty == g attr' mempty) (AttrModifier f attr) == (AttrModifier g attr') = f attr mempty == g attr' mempty
(NullModifier) == (NullModifier) = True NullModifier == NullModifier = True
_ == _ = False _ == _ = False
isEmpty :: (Monoid a, Eq a) => a -> Bool isEmpty :: (Monoid a, Eq a) => a -> Bool

68
src/Text/Pandoc/Readers/Docx/Lists.hs
View file

@ -33,7 +33,6 @@ module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets
, listParagraphDivs , listParagraphDivs
) where ) where
import Control.Monad
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Text.Pandoc.Generic (bottomUp) import Text.Pandoc.Generic (bottomUp)
@ -45,22 +44,18 @@ isListItem (Div (_, classes, _) _) | "list-item" `elem` classes = True
isListItem _ = False isListItem _ = False
getLevel :: Block -> Maybe Integer getLevel :: Block -> Maybe Integer
getLevel (Div (_, _, kvs) _) = liftM read $ lookup "level" kvs getLevel (Div (_, _, kvs) _) = fmap read $ lookup "level" kvs
getLevel _ = Nothing getLevel _ = Nothing
getLevelN :: Block -> Integer getLevelN :: Block -> Integer
getLevelN b = case getLevel b of getLevelN b = fromMaybe (-1) (getLevel b)
Just n -> n
Nothing -> -1
getNumId :: Block -> Maybe Integer getNumId :: Block -> Maybe Integer
getNumId (Div (_, _, kvs) _) = liftM read $ lookup "num-id" kvs getNumId (Div (_, _, kvs) _) = fmap read $ lookup "num-id" kvs
getNumId _ = Nothing getNumId _ = Nothing
getNumIdN :: Block -> Integer getNumIdN :: Block -> Integer
getNumIdN b = case getNumId b of getNumIdN b = fromMaybe (-1) (getNumId b)
Just n -> n
Nothing -> -1
getText :: Block -> Maybe String getText :: Block -> Maybe String
getText (Div (_, _, kvs) _) = lookup "text" kvs getText (Div (_, _, kvs) _) = lookup "text" kvs
@ -109,27 +104,27 @@ listParagraphDivs = ["ListParagraph"]
handleListParagraphs :: [Block] -> [Block] handleListParagraphs :: [Block] -> [Block]
handleListParagraphs [] = [] handleListParagraphs [] = []
handleListParagraphs ( handleListParagraphs (
(Div attr1@(_, classes1, _) blks1) : Div attr1@(_, classes1, _) blks1 :
(Div (ident2, classes2, kvs2) blks2) : Div (ident2, classes2, kvs2) blks2 :
blks blks
) | "list-item" `elem` classes1 && ) | "list-item" `elem` classes1 &&
not ("list-item" `elem` classes2) && notElem "list-item" classes2 &&
(not . null) (listParagraphDivs `intersect` classes2) = (not . null) (listParagraphDivs `intersect` classes2) =
-- We don't want to keep this indent. -- We don't want to keep this indent.
let newDiv2 = let newDiv2 =
(Div (ident2, classes2, filter (\kv -> fst kv /= "indent") kvs2) blks2) Div (ident2, classes2, filter (\kv -> fst kv /= "indent") kvs2) blks2
in in
handleListParagraphs ((Div attr1 (blks1 ++ [newDiv2])) : blks) handleListParagraphs (Div attr1 (blks1 ++ [newDiv2]) : blks)
handleListParagraphs (blk:blks) = blk : (handleListParagraphs blks) handleListParagraphs (blk:blks) = blk : handleListParagraphs blks
separateBlocks' :: Block -> [[Block]] -> [[Block]] separateBlocks' :: Block -> [[Block]] -> [[Block]]
separateBlocks' blk ([] : []) = [[blk]] separateBlocks' blk [[]] = [[blk]]
separateBlocks' b@(BulletList _) acc = (init acc) ++ [(last acc) ++ [b]] separateBlocks' b@(BulletList _) acc = init acc ++ [last acc ++ [b]]
separateBlocks' b@(OrderedList _ _) acc = (init acc) ++ [(last acc) ++ [b]] separateBlocks' b@(OrderedList _ _) acc = init acc ++ [last acc ++ [b]]
-- The following is for the invisible bullet lists. This is how -- The following is for the invisible bullet lists. This is how
-- pandoc-generated ooxml does multiparagraph item lists. -- pandoc-generated ooxml does multiparagraph item lists.
separateBlocks' b acc | liftM trim (getText b) == Just "" = separateBlocks' b acc | fmap trim (getText b) == Just "" =
(init acc) ++ [(last acc) ++ [b]] init acc ++ [last acc ++ [b]]
separateBlocks' b acc = acc ++ [[b]] separateBlocks' b acc = acc ++ [[b]]
separateBlocks :: [Block] -> [[Block]] separateBlocks :: [Block] -> [[Block]]
@ -138,38 +133,37 @@ separateBlocks blks = foldr separateBlocks' [[]] (reverse blks)
flatToBullets' :: Integer -> [Block] -> [Block] flatToBullets' :: Integer -> [Block] -> [Block]
flatToBullets' _ [] = [] flatToBullets' _ [] = []
flatToBullets' num xs@(b : elems) flatToBullets' num xs@(b : elems)
| getLevelN b == num = b : (flatToBullets' num elems) | getLevelN b == num = b : flatToBullets' num elems
| otherwise = | otherwise =
let bNumId = getNumIdN b let bNumId = getNumIdN b
bLevel = getLevelN b bLevel = getLevelN b
(children, remaining) = (children, remaining) =
span span
(\b' -> (\b' ->
((getLevelN b') > bLevel || (getLevelN b') > bLevel ||
((getLevelN b') == bLevel && (getNumIdN b') == bNumId))) ((getLevelN b') == bLevel && (getNumIdN b') == bNumId))
xs xs
in in
case getListType b of case getListType b of
Just (Enumerated attr) -> Just (Enumerated attr) ->
(OrderedList attr (separateBlocks $ flatToBullets' bLevel children)) : OrderedList attr (separateBlocks $ flatToBullets' bLevel children) :
(flatToBullets' num remaining) flatToBullets' num remaining
_ -> _ ->
(BulletList (separateBlocks $ flatToBullets' bLevel children)) : BulletList (separateBlocks $ flatToBullets' bLevel children) :
(flatToBullets' num remaining) flatToBullets' num remaining
flatToBullets :: [Block] -> [Block] flatToBullets :: [Block] -> [Block]
flatToBullets elems = flatToBullets' (-1) elems flatToBullets elems = flatToBullets' (-1) elems
singleItemHeaderToHeader :: Block -> Block singleItemHeaderToHeader :: Block -> Block
singleItemHeaderToHeader (OrderedList _ [[h@(Header _ _ _)]]) = h singleItemHeaderToHeader (OrderedList _ [[h@(Header{})]]) = h
singleItemHeaderToHeader blk = blk singleItemHeaderToHeader blk = blk
blocksToBullets :: [Block] -> [Block] blocksToBullets :: [Block] -> [Block]
blocksToBullets blks = blocksToBullets blks =
map singleItemHeaderToHeader $ map singleItemHeaderToHeader $
bottomUp removeListDivs $ bottomUp removeListDivs $flatToBullets (handleListParagraphs blks)
flatToBullets $ (handleListParagraphs blks)
plainParaInlines :: Block -> [Inline] plainParaInlines :: Block -> [Inline]
plainParaInlines (Plain ils) = ils plainParaInlines (Plain ils) = ils
@ -179,18 +173,16 @@ plainParaInlines _ = []
blocksToDefinitions' :: [([Inline], [[Block]])] -> [Block] -> [Block] -> [Block] blocksToDefinitions' :: [([Inline], [[Block]])] -> [Block] -> [Block] -> [Block]
blocksToDefinitions' [] acc [] = reverse acc blocksToDefinitions' [] acc [] = reverse acc
blocksToDefinitions' defAcc acc [] = blocksToDefinitions' defAcc acc [] =
reverse $ (DefinitionList (reverse defAcc)) : acc reverse $ DefinitionList (reverse defAcc) : acc
blocksToDefinitions' defAcc acc blocksToDefinitions' defAcc acc
((Div (_, classes1, _) blks1) : (Div (ident2, classes2, kvs2) blks2) : blks) (Div (_, classes1, _) blks1 : Div (ident2, classes2, kvs2) blks2 : blks)
| "DefinitionTerm" `elem` classes1 && "Definition" `elem` classes2 = | "DefinitionTerm" `elem` classes1 && "Definition" `elem` classes2 =
let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2) let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)
pair = case remainingAttr2 == ("", [], []) of pair = if remainingAttr2 == ("", [], []) then (concatMap plainParaInlines blks1, [blks2]) else (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]])
True -> (concatMap plainParaInlines blks1, [blks2])
False -> (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]])
in in
blocksToDefinitions' (pair : defAcc) acc blks blocksToDefinitions' (pair : defAcc) acc blks
blocksToDefinitions' defAcc acc blocksToDefinitions' defAcc acc
((Div (ident2, classes2, kvs2) blks2) : blks) (Div (ident2, classes2, kvs2) blks2 : blks)
| (not . null) defAcc && "Definition" `elem` classes2 = | (not . null) defAcc && "Definition" `elem` classes2 =
let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2) let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)
defItems2 = case remainingAttr2 == ("", [], []) of defItems2 = case remainingAttr2 == ("", [], []) of
@ -205,14 +197,14 @@ blocksToDefinitions' defAcc acc
blocksToDefinitions' [] acc (b:blks) = blocksToDefinitions' [] acc (b:blks) =
blocksToDefinitions' [] (b:acc) blks blocksToDefinitions' [] (b:acc) blks
blocksToDefinitions' defAcc acc (b:blks) = blocksToDefinitions' defAcc acc (b:blks) =
blocksToDefinitions' [] (b : (DefinitionList (reverse defAcc)) : acc) blks blocksToDefinitions' [] (b : DefinitionList (reverse defAcc) : acc) blks
removeListDivs' :: Block -> [Block] removeListDivs' :: Block -> [Block]
removeListDivs' (Div (ident, classes, kvs) blks) removeListDivs' (Div (ident, classes, kvs) blks)
| "list-item" `elem` classes = | "list-item" `elem` classes =
case delete "list-item" classes of case delete "list-item" classes of
[] -> blks [] -> blks
classes' -> [Div (ident, classes', kvs) $ blks] classes' -> [Div (ident, classes', kvs) blks]
removeListDivs' (Div (ident, classes, kvs) blks) removeListDivs' (Div (ident, classes, kvs) blks)
| not $ null $ listParagraphDivs `intersect` classes = | not $ null $ listParagraphDivs `intersect` classes =
case classes \\ listParagraphDivs of case classes \\ listParagraphDivs of

26
src/Text/Pandoc/Readers/Docx/Parse.hs
View file

@ -106,7 +106,7 @@ eitherToD (Right b) = return b
eitherToD (Left _) = throwError DocxError eitherToD (Left _) = throwError DocxError
concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = liftM concat (mapM f xs) concatMapM f xs = fmap concat (mapM f xs)
-- This is similar to `mapMaybe`: it maps a function returning the D -- This is similar to `mapMaybe`: it maps a function returning the D
@ -304,7 +304,7 @@ archiveToDocument zf = do
elemToBody :: NameSpaces -> Element -> D Body elemToBody :: NameSpaces -> Element -> D Body
elemToBody ns element | isElem ns "w" "body" element = elemToBody ns element | isElem ns "w" "body" element =
mapD (elemToBodyPart ns) (elChildren element) >>= mapD (elemToBodyPart ns) (elChildren element) >>=
(\bps -> return $ Body bps) (return . Body)
elemToBody _ _ = throwError WrongElem elemToBody _ _ = throwError WrongElem
archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap) archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)
@ -329,7 +329,7 @@ isBasedOnStyle ns element parentStyle
, styleType == cStyleType parentStyle , styleType == cStyleType parentStyle
, Just basedOnVal <- findChildByName ns "w" "basedOn" element >>= , Just basedOnVal <- findChildByName ns "w" "basedOn" element >>=
findAttrByName ns "w" "val" findAttrByName ns "w" "val"
, Just ps <- parentStyle = (basedOnVal == getStyleId ps) , Just ps <- parentStyle = basedOnVal == getStyleId ps
| isElem ns "w" "style" element | isElem ns "w" "style" element
, Just styleType <- findAttrByName ns "w" "type" element , Just styleType <- findAttrByName ns "w" "type" element
, styleType == cStyleType parentStyle , styleType == cStyleType parentStyle
@ -371,10 +371,10 @@ getStyleChildren ns element parentStyle
buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a] buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]
buildBasedOnList ns element rootStyle = buildBasedOnList ns element rootStyle =
case (getStyleChildren ns element rootStyle) of case getStyleChildren ns element rootStyle of
[] -> [] [] -> []
stys -> stys ++ stys -> stys ++
(concatMap (\s -> buildBasedOnList ns element (Just s)) stys) concatMap (\s -> buildBasedOnList ns element (Just s)) stys
archiveToNotes :: Archive -> Notes archiveToNotes :: Archive -> Notes
archiveToNotes zf = archiveToNotes zf =
@ -389,8 +389,8 @@ archiveToNotes zf =
Just e -> elemToNameSpaces e Just e -> elemToNameSpaces e
Nothing -> [] Nothing -> []
ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces
fn = fnElem >>= (elemToNotes ns "footnote") fn = fnElem >>= elemToNotes ns "footnote"
en = enElem >>= (elemToNotes ns "endnote") en = enElem >>= elemToNotes ns "endnote"
in in
Notes ns fn en Notes ns fn en
@ -401,7 +401,7 @@ archiveToComments zf =
cmts_namespaces = case cmtsElem of cmts_namespaces = case cmtsElem of
Just e -> elemToNameSpaces e Just e -> elemToNameSpaces e
Nothing -> [] Nothing -> []
cmts = (elemToComments cmts_namespaces) <$> cmtsElem cmts = elemToComments cmts_namespaces <$> cmtsElem
in in
case cmts of case cmts of
Just c -> Comments cmts_namespaces c Just c -> Comments cmts_namespaces c
@ -442,8 +442,7 @@ lookupLevel :: String -> String -> Numbering -> Maybe Level
lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do
absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs
lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs
lvl <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls
return lvl
numElemToNum :: NameSpaces -> Element -> Maybe Numb numElemToNum :: NameSpaces -> Element -> Maybe Numb
@ -479,7 +478,7 @@ levelElemToLevel ns element
levelElemToLevel _ _ = Nothing levelElemToLevel _ _ = Nothing
archiveToNumbering' :: Archive -> Maybe Numbering archiveToNumbering' :: Archive -> Maybe Numbering
archiveToNumbering' zf = do archiveToNumbering' zf =
case findEntryByPath "word/numbering.xml" zf of case findEntryByPath "word/numbering.xml" zf of
Nothing -> Just $ Numbering [] [] [] Nothing -> Just $ Numbering [] [] []
Just entry -> do Just entry -> do
@ -503,7 +502,8 @@ elemToNotes ns notetype element
(\a -> Just (a, e))) (\a -> Just (a, e)))
(findChildrenByName ns "w" notetype element) (findChildrenByName ns "w" notetype element)
in in
Just $ M.fromList $ pairs Just $
M.fromList pairs
elemToNotes _ _ _ = Nothing elemToNotes _ _ _ = Nothing
elemToComments :: NameSpaces -> Element -> M.Map String Element elemToComments :: NameSpaces -> Element -> M.Map String Element
@ -514,7 +514,7 @@ elemToComments ns element
(\a -> Just (a, e))) (\a -> Just (a, e)))
(findChildrenByName ns "w" "comment" element) (findChildrenByName ns "w" "comment" element)
in in
M.fromList $ pairs M.fromList pairs
elemToComments _ _ = M.empty elemToComments _ _ = M.empty