diff options
-rw-r--r-- | src/Text/Pandoc/MediaBag.hs | 2 | ||||
-rw-r--r-- | src/Text/Pandoc/PDF.hs | 8 | ||||
-rw-r--r-- | src/Text/Pandoc/Pretty.hs | 36 | ||||
-rw-r--r-- | src/Text/Pandoc/Readers/CommonMark.hs | 4 | ||||
-rw-r--r-- | src/Text/Pandoc/Readers/Creole.hs | 36 | ||||
-rw-r--r-- | src/Text/Pandoc/Readers/DocBook.hs | 40 | ||||
-rw-r--r-- | src/Text/Pandoc/Readers/Docx/Combine.hs | 24 | ||||
-rw-r--r-- | src/Text/Pandoc/Readers/Docx/Lists.hs | 68 | ||||
-rw-r--r-- | src/Text/Pandoc/Readers/Docx/Parse.hs | 26 |
9 files changed, 118 insertions, 126 deletions
diff --git a/src/Text/Pandoc/MediaBag.hs b/src/Text/Pandoc/MediaBag.hs index f89c60c9e..1c15d1cee 100644 --- a/src/Text/Pandoc/MediaBag.hs +++ b/src/Text/Pandoc/MediaBag.hs @@ -80,4 +80,4 @@ lookupMedia fp (MediaBag mediamap) = M.lookup (splitDirectories fp) mediamap mediaDirectory :: MediaBag -> [(String, MimeType, Int)] mediaDirectory (MediaBag mediamap) = M.foldrWithKey (\fp (mime,contents) -> - (((Posix.joinPath fp), mime, fromIntegral $ BL.length contents):)) [] mediamap + ((Posix.joinPath fp, mime, fromIntegral $ BL.length contents):)) [] mediamap diff --git a/src/Text/Pandoc/PDF.hs b/src/Text/Pandoc/PDF.hs index 028d63dcb..cafb4a226 100644 --- a/src/Text/Pandoc/PDF.hs +++ b/src/Text/Pandoc/PDF.hs @@ -327,7 +327,7 @@ ms2pdf verbosity args source = do putStrLn "[makePDF] Environment:" mapM_ print env' putStr "\n" - putStrLn $ "[makePDF] Contents:\n" + putStrLn "[makePDF] Contents:\n" putStr $ T.unpack source putStr "\n" (exit, out) <- E.catch @@ -351,9 +351,7 @@ html2pdf :: Verbosity -- ^ Verbosity level -> IO (Either ByteString ByteString) html2pdf verbosity program args source = do pdfFile <- withTempFile "." "html2pdf.pdf" $ \fp _ -> return fp - let pdfFileArgName = if program == "prince" - then ["-o"] - else [] + let pdfFileArgName = ["-o" | program == "prince"] let programArgs = args ++ ["-"] ++ pdfFileArgName ++ [pdfFile] env' <- getEnvironment when (verbosity >= INFO) $ do @@ -363,7 +361,7 @@ html2pdf verbosity program args source = do putStrLn "[makePDF] Environment:" mapM_ print env' putStr "\n" - putStrLn $ "[makePDF] Contents of intermediate HTML:" + putStrLn "[makePDF] Contents of intermediate HTML:" TextIO.putStr source putStr "\n" (exit, out) <- E.catch diff --git a/src/Text/Pandoc/Pretty.hs b/src/Text/Pandoc/Pretty.hs index b5600ad39..40a7d018c 100644 --- a/src/Text/Pandoc/Pretty.hs +++ b/src/Text/Pandoc/Pretty.hs @@ -78,6 +78,7 @@ module Text.Pandoc.Pretty ( where import Control.Monad.State.Strict +import Control.Monad (when) import Data.Char (isSpace) import Data.Foldable (toList) import Data.List (intersperse) @@ -144,11 +145,10 @@ hcat = mconcat -- between them. infixr 6 <+> (<+>) :: Doc -> Doc -> Doc -(<+>) x y = if isEmpty x - then y - else if isEmpty y - then x - else x <> space <> y +(<+>) x y + | isEmpty x = y + | isEmpty y = x + | otherwise = x <> space <> y -- | Same as 'cat', but putting breakable spaces between the -- 'Doc's. @@ -158,20 +158,18 @@ hsep = foldr (<+>) empty infixr 5 $$ -- | @a $$ b@ puts @a@ above @b@. ($$) :: Doc -> Doc -> Doc -($$) x y = if isEmpty x - then y - else if isEmpty y - then x - else x <> cr <> y +($$) x y + | isEmpty x = y + | isEmpty y = x + | otherwise = x <> cr <> y infixr 5 $+$ -- | @a $+$ b@ puts @a@ above @b@, with a blank line between. ($+$) :: Doc -> Doc -> Doc -($+$) x y = if isEmpty x - then y - else if isEmpty y - then x - else x <> blankline <> y +($+$) x y + | isEmpty x = y + | isEmpty y = x + | otherwise = x <> blankline <> y -- | List version of '$$'. 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) st' <- get 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 - , column = column st + realLength pref } + , column = column st + realLength pref } modify $ \st -> st{ output = fromString s : output st , column = column st + off , newlines = 0 } @@ -328,9 +326,7 @@ renderList (BreakingSpace : xs) = do renderList (AfterBreak s : xs) = do st <- get - if newlines st > 0 - then outp (realLength s) s - else return () + when (newlines st > 0) $ outp (realLength s) s renderList xs renderList (Block i1 s1 : Block i2 s2 : xs) = diff --git a/src/Text/Pandoc/Readers/CommonMark.hs b/src/Text/Pandoc/Readers/CommonMark.hs index 8189e7760..6b864521f 100644 --- a/src/Text/Pandoc/Readers/CommonMark.hs +++ b/src/Text/Pandoc/Readers/CommonMark.hs @@ -132,12 +132,12 @@ addBlock opts (Node _ (LIST listAttrs) nodes) = setTightness = if listTight listAttrs then map paraToPlain else id - paraToPlain (Para xs) = Plain (xs) + paraToPlain (Para xs) = Plain xs paraToPlain x = x delim = case listDelim listAttrs of PERIOD_DELIM -> Period PAREN_DELIM -> OneParen -addBlock opts (Node _ (TABLE alignments) nodes) = do +addBlock opts (Node _ (TABLE alignments) nodes) = (Table [] aligns widths headers rows :) where aligns = map fromTableCellAlignment alignments fromTableCellAlignment NoAlignment = AlignDefault diff --git a/src/Text/Pandoc/Readers/Creole.hs b/src/Text/Pandoc/Readers/Creole.hs index 9886394a7..3b330e544 100644 --- a/src/Text/Pandoc/Readers/Creole.hs +++ b/src/Text/Pandoc/Readers/Creole.hs @@ -111,7 +111,7 @@ block = do return res 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 content = brackets <|> line 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 = try $ do skipSpaces - level <- many1 (char '=') >>= return . length + level <- + fmap length (many1 (char '=')) guard $ level <= 6 skipSpaces 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 list :: PandocMonad m => Char -> ([B.Blocks] -> B.Blocks) -> Int -> CRLParser m B.Blocks -list c f n = many1 (itemPlusSublist <|> listItem c n) - >>= return . f +list c f n = + fmap f (many1 (itemPlusSublist <|> listItem c n)) where itemPlusSublist = try $ listItem c n <+> anyList (n+1) listItem :: PandocMonad m => Char -> Int -> CRLParser m B.Blocks -listItem c n = (listStart >> many1Till inline itemEnd) - >>= return . B.plain . B.trimInlines .mconcat +listItem c n = + fmap (B.plain . B.trimInlines .mconcat) (listStart >> many1Till inline itemEnd) where listStart = try $ optional newline >> skipSpaces >> count n (char c) - >> (lookAhead $ noneOf [c]) >> skipSpaces + >> lookAhead (noneOf [c]) >> skipSpaces itemEnd = endOfParaElement <|> nextItem n <|> if n < 3 then nextItem (n+1) else nextItem (n+1) <|> nextItem (n-1) @@ -176,7 +177,7 @@ table = try $ do cellEnd = lookAhead $ try $ char '|' <|> rowEnd para :: PandocMonad m => CRLParser m B.Blocks -para = many1Till inline endOfParaElement >>= return . result . mconcat +para = fmap (result . mconcat) (many1Till inline endOfParaElement) where result content = if F.all (==Space) content then mempty @@ -192,7 +193,7 @@ endOfParaElement = lookAhead $ endOfInput <|> endOfPara startOf :: PandocMonad m => CRLParser m a -> CRLParser m () startOf p = try $ blankline >> p >> return mempty startOfList = startOf $ anyList 1 - startOfTable = startOf $ table + startOfTable =startOf table startOfHeader = startOf header startOfNowiki = startOf nowiki hr = startOf horizontalRule @@ -223,7 +224,8 @@ inline = choice [ whitespace ] <?> "inline" 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 = try $ do @@ -234,7 +236,7 @@ escapedLink = try $ do image :: PandocMonad m => CRLParser m B.Inlines image = try $ do (orig, src) <- wikiImg - return $ B.image src "" (B.str $ orig) + return $ B.image src "" (B.str orig) where linkSrc = 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" linkDsc :: PandocMonad m => String -> CRLParser m B.Inlines linkDsc otxt = B.str - <$> (try $ option otxt + <$> try (option otxt (char '|' >> many (noneOf "]\n\r\t"))) linkImg = try $ char '|' >> image wikiLink = try $ do @@ -270,17 +272,17 @@ inlineNowiki :: PandocMonad m => CRLParser m B.Inlines inlineNowiki = B.code <$> (start >> manyTill (noneOf "\n\r") end) where start = try $ string "{{{" - end = try $ string "}}}" >> (lookAhead $ noneOf "}") + end = try $ string "}}}" >> lookAhead (noneOf "}") placeholder :: PandocMonad m => CRLParser m B.Inlines -- The semantics of the placeholder is basicallly implementation -- dependent, so there is no way to DTRT for all cases. -- So for now we just drop them. -placeholder = B.text <$> (try $ string "<<<" >> manyTill anyChar (string ">>>") +placeholder = B.text <$> try (string "<<<" >> manyTill anyChar (string ">>>") >> return "") whitespace :: PandocMonad m => CRLParser m B.Inlines -whitespace = (lb <|> regsp) >>= return +whitespace = (lb <|> regsp) where lb = try $ skipMany spaceChar >> linebreak >> return B.space regsp = try $ skipMany1 spaceChar >> return B.space @@ -290,11 +292,11 @@ linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline) innerNewline = return B.space 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 = 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 = B.strong . mconcat <$> diff --git a/src/Text/Pandoc/Readers/DocBook.hs b/src/Text/Pandoc/Readers/DocBook.hs index f816a9c47..0f3f6f6e3 100644 --- a/src/Text/Pandoc/Readers/DocBook.hs +++ b/src/Text/Pandoc/Readers/DocBook.hs @@ -1,5 +1,5 @@ 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.Options import Text.Pandoc.Definition @@ -8,7 +8,6 @@ import Text.XML.Light import Text.HTML.TagSoup.Entity (lookupEntity) import Data.Either (rights) import Data.Generics -import Data.Char (isSpace) import Control.Monad.State.Strict import Data.List (intersperse) import Data.Maybe (fromMaybe) @@ -528,7 +527,7 @@ readDocBook :: PandocMonad m => ReaderOptions -> Text -> m Pandoc readDocBook _ inp = do let tree = normalizeTree . parseXML . handleInstructions $ 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) -- We treat <?asciidoc-br?> specially (issue #1236), converting it @@ -567,14 +566,12 @@ normalizeTree = everywhere (mkT go) go xs = xs 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 "" attrValue :: String -> Element -> String attrValue attr elt = - case lookupAttrBy (\x -> qName x == attr) (elAttribs elt) of - Just z -> z - Nothing -> "" + fromMaybe "" (lookupAttrBy (\x -> qName x == attr) (elAttribs elt)) -- convenience function named :: String -> Element -> Bool @@ -654,15 +651,17 @@ getMediaobject e = do || named "textobject" x || named "alt" x) el of Nothing -> return mempty - Just z -> mconcat <$> (mapM parseInline $ elContent z) + Just z -> mconcat <$> + mapM parseInline (elContent z) figTitle <- gets dbFigureTitle let (caption, title) = if isNull figTitle then (getCaption e, "") else (return figTitle, "fig:") - liftM (imageWith attr imageUrl title) caption + fmap (imageWith attr imageUrl title) caption 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 @@ -806,7 +805,8 @@ parseBlock (Elem e) = attrib <- case filterChild (named "attribution") e of Nothing -> return mempty Just z -> (para . (str "— " <>) . mconcat) - <$> (mapM parseInline $ elContent z) + <$> + mapM parseInline (elContent z) contents <- getBlocks e return $ blockQuote (contents <> attrib) listitems = mapM getBlocks $ filterChildren (named "listitem") e @@ -906,7 +906,8 @@ parseBlock (Elem e) = metaBlock = acceptingMetadata (getBlocks e) >> return mempty 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 = strContent . @@ -919,7 +920,7 @@ elementToStr x = x parseInline :: PandocMonad m => Content -> DB m Inlines parseInline (Text (CData _ s _)) = return $ text s parseInline (CRef ref) = - return $ maybe (text $ map toUpper ref) (text) $ lookupEntity ref + return $ maybe (text $ map toUpper ref) text $ lookupEntity ref parseInline (Elem e) = case qName (elName e) of "equation" -> equation displayMath @@ -960,8 +961,10 @@ parseInline (Elem e) = "userinput" -> codeWithLang "varargs" -> return $ code "(...)" "keycap" -> return (str $ strContent e) - "keycombo" -> keycombo <$> (mapM parseInline $ elContent e) - "menuchoice" -> menuchoice <$> (mapM parseInline $ + "keycombo" -> keycombo <$> + mapM parseInline (elContent e) + "menuchoice" -> menuchoice <$> + mapM parseInline ( filter isGuiMenu $ elContent e) "xref" -> do content <- dbContent <$> get @@ -980,7 +983,7 @@ parseInline (Elem e) = ils <- innerInlines let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of Just h -> h - _ -> ('#' : attrValue "linkend" e) + _ -> '#' : attrValue "linkend" e let ils' = if ils == mempty then str href else ils let attr = (attrValue "id" e, words $ attrValue "role" e, []) return $ linkWith attr href "" ils' @@ -990,7 +993,8 @@ parseInline (Elem e) = "strong" -> strong <$> innerInlines "strikethrough" -> strikeout <$> innerInlines _ -> emph <$> innerInlines - "footnote" -> (note . mconcat) <$> (mapM parseBlock $ elContent e) + "footnote" -> (note . mconcat) <$> + mapM parseBlock (elContent e) "title" -> return mempty "affiliation" -> return mempty -- Note: this isn't a real docbook tag; it's what we convert @@ -999,7 +1003,7 @@ parseInline (Elem e) = "br" -> return linebreak _ -> innerInlines where innerInlines = (trimInlines . mconcat) <$> - (mapM parseInline $ elContent e) + mapM parseInline (elContent e) equation constructor = return $ mconcat $ map (constructor . writeTeX) $ rights diff --git a/src/Text/Pandoc/Readers/Docx/Combine.hs b/src/Text/Pandoc/Readers/Docx/Combine.hs index f516d63d4..003265e6e 100644 --- a/src/Text/Pandoc/Readers/Docx/Combine.hs +++ b/src/Text/Pandoc/Readers/Docx/Combine.hs @@ -36,16 +36,16 @@ spaceOutInlines ils = right = case viewr contents of (_ :> Space) -> space _ -> mempty in - (left, (stackInlines fs $ trimInlines . Many $ contents), right) + (left, stackInlines fs $ trimInlines . Many $ contents, right) stackInlines :: [Modifier Inlines] -> Inlines -> Inlines stackInlines [] ms = ms stackInlines (NullModifier : fs) ms = stackInlines fs ms -stackInlines ((Modifier f) : fs) ms = +stackInlines (Modifier f : fs) ms = if isEmpty ms then 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 ms = case ilModifier ms of @@ -97,7 +97,7 @@ combineInlines x y = let (xs', x') = inlinesR x (y', ys') = inlinesL y in - xs' <> (combineSingletonInlines x' y') <> ys' + xs' <> combineSingletonInlines x' y' <> ys' combineSingletonInlines :: Inlines -> Inlines -> Inlines combineSingletonInlines x y = @@ -114,10 +114,10 @@ combineSingletonInlines x y = stackInlines (x_rem_attr ++ y_rem_attr) mempty | isEmpty xs -> let (sp, y') = spaceOutInlinesL y in - (stackInlines x_rem_attr mempty) <> sp <> y' + stackInlines x_rem_attr mempty <> sp <> y' | isEmpty ys -> let (x', sp) = spaceOutInlinesR x in - x' <> sp <> (stackInlines y_rem_attr mempty) + x' <> sp <> stackInlines y_rem_attr mempty | otherwise -> let (x', xsp) = spaceOutInlinesR x (ysp, y') = spaceOutInlinesL y @@ -130,15 +130,15 @@ combineSingletonInlines x y = combineBlocks :: Blocks -> Blocks -> Blocks combineBlocks bs cs - | bs' :> (BlockQuote bs'') <- viewr (unMany bs) - , (BlockQuote cs'') :< cs' <- viewl (unMany cs) = - Many $ (bs' |> (BlockQuote (bs'' <> cs''))) >< cs' + | bs' :> BlockQuote bs'' <- viewr (unMany bs) + , BlockQuote cs'' :< cs' <- viewl (unMany cs) = + Many $ (bs' |> BlockQuote (bs'' <> cs'')) >< cs' combineBlocks bs cs = bs <> cs instance (Monoid a, Eq a) => Eq (Modifier a) where - (Modifier f) == (Modifier g) = (f mempty == g mempty) - (AttrModifier f attr) == (AttrModifier g attr') = (f attr mempty == g attr' mempty) - (NullModifier) == (NullModifier) = True + (Modifier f) == (Modifier g) = f mempty == g mempty + (AttrModifier f attr) == (AttrModifier g attr') = f attr mempty == g attr' mempty + NullModifier == NullModifier = True _ == _ = False isEmpty :: (Monoid a, Eq a) => a -> Bool diff --git a/src/Text/Pandoc/Readers/Docx/Lists.hs b/src/Text/Pandoc/Readers/Docx/Lists.hs index 8be2e1894..c7f4adc98 100644 --- a/src/Text/Pandoc/Readers/Docx/Lists.hs +++ b/src/Text/Pandoc/Readers/Docx/Lists.hs @@ -33,7 +33,6 @@ module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets , listParagraphDivs ) where -import Control.Monad import Data.List import Data.Maybe import Text.Pandoc.Generic (bottomUp) @@ -45,22 +44,18 @@ isListItem (Div (_, classes, _) _) | "list-item" `elem` classes = True isListItem _ = False getLevel :: Block -> Maybe Integer -getLevel (Div (_, _, kvs) _) = liftM read $ lookup "level" kvs +getLevel (Div (_, _, kvs) _) = fmap read $ lookup "level" kvs getLevel _ = Nothing getLevelN :: Block -> Integer -getLevelN b = case getLevel b of - Just n -> n - Nothing -> -1 +getLevelN b = fromMaybe (-1) (getLevel b) getNumId :: Block -> Maybe Integer -getNumId (Div (_, _, kvs) _) = liftM read $ lookup "num-id" kvs +getNumId (Div (_, _, kvs) _) = fmap read $ lookup "num-id" kvs getNumId _ = Nothing getNumIdN :: Block -> Integer -getNumIdN b = case getNumId b of - Just n -> n - Nothing -> -1 +getNumIdN b = fromMaybe (-1) (getNumId b) getText :: Block -> Maybe String getText (Div (_, _, kvs) _) = lookup "text" kvs @@ -109,27 +104,27 @@ listParagraphDivs = ["ListParagraph"] handleListParagraphs :: [Block] -> [Block] handleListParagraphs [] = [] handleListParagraphs ( - (Div attr1@(_, classes1, _) blks1) : - (Div (ident2, classes2, kvs2) blks2) : + Div attr1@(_, classes1, _) blks1 : + Div (ident2, classes2, kvs2) blks2 : blks ) | "list-item" `elem` classes1 && - not ("list-item" `elem` classes2) && + notElem "list-item" classes2 && (not . null) (listParagraphDivs `intersect` classes2) = -- We don't want to keep this indent. let newDiv2 = - (Div (ident2, classes2, filter (\kv -> fst kv /= "indent") kvs2) blks2) + Div (ident2, classes2, filter (\kv -> fst kv /= "indent") kvs2) blks2 in - handleListParagraphs ((Div attr1 (blks1 ++ [newDiv2])) : blks) -handleListParagraphs (blk:blks) = blk : (handleListParagraphs blks) + handleListParagraphs (Div attr1 (blks1 ++ [newDiv2]) : blks) +handleListParagraphs (blk:blks) = blk : handleListParagraphs blks separateBlocks' :: Block -> [[Block]] -> [[Block]] -separateBlocks' blk ([] : []) = [[blk]] -separateBlocks' b@(BulletList _) acc = (init acc) ++ [(last acc) ++ [b]] -separateBlocks' b@(OrderedList _ _) acc = (init acc) ++ [(last acc) ++ [b]] +separateBlocks' blk [[]] = [[blk]] +separateBlocks' b@(BulletList _) 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 -- pandoc-generated ooxml does multiparagraph item lists. -separateBlocks' b acc | liftM trim (getText b) == Just "" = - (init acc) ++ [(last acc) ++ [b]] +separateBlocks' b acc | fmap trim (getText b) == Just "" = + init acc ++ [last acc ++ [b]] separateBlocks' b acc = acc ++ [[b]] separateBlocks :: [Block] -> [[Block]] @@ -138,38 +133,37 @@ separateBlocks blks = foldr separateBlocks' [[]] (reverse blks) flatToBullets' :: Integer -> [Block] -> [Block] flatToBullets' _ [] = [] flatToBullets' num xs@(b : elems) - | getLevelN b == num = b : (flatToBullets' num elems) + | getLevelN b == num = b : flatToBullets' num elems | otherwise = let bNumId = getNumIdN b bLevel = getLevelN b (children, remaining) = span (\b' -> - ((getLevelN b') > bLevel || - ((getLevelN b') == bLevel && (getNumIdN b') == bNumId))) + (getLevelN b') > bLevel || + ((getLevelN b') == bLevel && (getNumIdN b') == bNumId)) xs in case getListType b of Just (Enumerated attr) -> - (OrderedList attr (separateBlocks $ flatToBullets' bLevel children)) : - (flatToBullets' num remaining) + OrderedList attr (separateBlocks $ flatToBullets' bLevel children) : + flatToBullets' num remaining _ -> - (BulletList (separateBlocks $ flatToBullets' bLevel children)) : - (flatToBullets' num remaining) + BulletList (separateBlocks $ flatToBullets' bLevel children) : + flatToBullets' num remaining flatToBullets :: [Block] -> [Block] flatToBullets elems = flatToBullets' (-1) elems singleItemHeaderToHeader :: Block -> Block -singleItemHeaderToHeader (OrderedList _ [[h@(Header _ _ _)]]) = h +singleItemHeaderToHeader (OrderedList _ [[h@(Header{})]]) = h singleItemHeaderToHeader blk = blk blocksToBullets :: [Block] -> [Block] blocksToBullets blks = map singleItemHeaderToHeader $ - bottomUp removeListDivs $ - flatToBullets $ (handleListParagraphs blks) + bottomUp removeListDivs $flatToBullets (handleListParagraphs blks) plainParaInlines :: Block -> [Inline] plainParaInlines (Plain ils) = ils @@ -179,18 +173,16 @@ plainParaInlines _ = [] blocksToDefinitions' :: [([Inline], [[Block]])] -> [Block] -> [Block] -> [Block] blocksToDefinitions' [] acc [] = reverse acc blocksToDefinitions' defAcc acc [] = - reverse $ (DefinitionList (reverse defAcc)) : acc + reverse $ DefinitionList (reverse 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 = let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2) - pair = case remainingAttr2 == ("", [], []) of - True -> (concatMap plainParaInlines blks1, [blks2]) - False -> (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]]) + pair = if remainingAttr2 == ("", [], []) then (concatMap plainParaInlines blks1, [blks2]) else (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]]) in blocksToDefinitions' (pair : defAcc) acc blks blocksToDefinitions' defAcc acc - ((Div (ident2, classes2, kvs2) blks2) : blks) + (Div (ident2, classes2, kvs2) blks2 : blks) | (not . null) defAcc && "Definition" `elem` classes2 = let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2) defItems2 = case remainingAttr2 == ("", [], []) of @@ -205,14 +197,14 @@ blocksToDefinitions' defAcc acc blocksToDefinitions' [] acc (b:blks) = blocksToDefinitions' [] (b:acc) blks blocksToDefinitions' defAcc acc (b:blks) = - blocksToDefinitions' [] (b : (DefinitionList (reverse defAcc)) : acc) blks + blocksToDefinitions' [] (b : DefinitionList (reverse defAcc) : acc) blks removeListDivs' :: Block -> [Block] removeListDivs' (Div (ident, classes, kvs) blks) | "list-item" `elem` classes = case delete "list-item" classes of [] -> blks - classes' -> [Div (ident, classes', kvs) $ blks] + classes' -> [Div (ident, classes', kvs) blks] removeListDivs' (Div (ident, classes, kvs) blks) | not $ null $ listParagraphDivs `intersect` classes = case classes \\ listParagraphDivs of diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs index 05ce691a6..1aa69f62e 100644 --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -106,7 +106,7 @@ eitherToD (Right b) = return b eitherToD (Left _) = throwError DocxError 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 @@ -304,7 +304,7 @@ archiveToDocument zf = do elemToBody :: NameSpaces -> Element -> D Body elemToBody ns element | isElem ns "w" "body" element = mapD (elemToBodyPart ns) (elChildren element) >>= - (\bps -> return $ Body bps) + (return . Body) elemToBody _ _ = throwError WrongElem archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap) @@ -329,7 +329,7 @@ isBasedOnStyle ns element parentStyle , styleType == cStyleType parentStyle , Just basedOnVal <- findChildByName ns "w" "basedOn" element >>= findAttrByName ns "w" "val" - , Just ps <- parentStyle = (basedOnVal == getStyleId ps) + , Just ps <- parentStyle = basedOnVal == getStyleId ps | isElem ns "w" "style" element , Just styleType <- findAttrByName ns "w" "type" element , styleType == cStyleType parentStyle @@ -371,10 +371,10 @@ getStyleChildren ns element parentStyle buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a] buildBasedOnList ns element rootStyle = - case (getStyleChildren ns element rootStyle) of + case getStyleChildren ns element rootStyle of [] -> [] stys -> stys ++ - (concatMap (\s -> buildBasedOnList ns element (Just s)) stys) + concatMap (\s -> buildBasedOnList ns element (Just s)) stys archiveToNotes :: Archive -> Notes archiveToNotes zf = @@ -389,8 +389,8 @@ archiveToNotes zf = Just e -> elemToNameSpaces e Nothing -> [] ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces - fn = fnElem >>= (elemToNotes ns "footnote") - en = enElem >>= (elemToNotes ns "endnote") + fn = fnElem >>= elemToNotes ns "footnote" + en = enElem >>= elemToNotes ns "endnote" in Notes ns fn en @@ -401,7 +401,7 @@ archiveToComments zf = cmts_namespaces = case cmtsElem of Just e -> elemToNameSpaces e Nothing -> [] - cmts = (elemToComments cmts_namespaces) <$> cmtsElem + cmts = elemToComments cmts_namespaces <$> cmtsElem in case cmts of Just c -> Comments cmts_namespaces c @@ -442,8 +442,7 @@ lookupLevel :: String -> String -> Numbering -> Maybe Level lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs - lvl <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls - return lvl + lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls numElemToNum :: NameSpaces -> Element -> Maybe Numb @@ -479,7 +478,7 @@ levelElemToLevel ns element levelElemToLevel _ _ = Nothing archiveToNumbering' :: Archive -> Maybe Numbering -archiveToNumbering' zf = do +archiveToNumbering' zf = case findEntryByPath "word/numbering.xml" zf of Nothing -> Just $ Numbering [] [] [] Just entry -> do @@ -503,7 +502,8 @@ elemToNotes ns notetype element (\a -> Just (a, e))) (findChildrenByName ns "w" notetype element) in - Just $ M.fromList $ pairs + Just $ + M.fromList pairs elemToNotes _ _ _ = Nothing elemToComments :: NameSpaces -> Element -> M.Map String Element @@ -514,7 +514,7 @@ elemToComments ns element (\a -> Just (a, e))) (findChildrenByName ns "w" "comment" element) in - M.fromList $ pairs + M.fromList pairs elemToComments _ _ = M.empty |