hlint changes.
This commit is contained in:
John MacFarlane
parent
f3e901c29d
commit
b201a8aa58
9 changed files with 118 additions and 126 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <$>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue