git.iko.soy/typeable/pandoc
on master help sign in
nested lists
9030c5aYan Pas
src/Text/Pandoc/Readers/Man.hs+84−52
compare with master
unifiedsplit
@@ -36,6 +36,7 @@ module Text.Pandoc.Readers.Man (readMan, testFile) where
36import Prelude
36import Prelude
37import Control.Monad (liftM)
37import Control.Monad (liftM)
38import Control.Monad.Except (throwError)
38import Control.Monad.Except (throwError)
39+import Data.Char (isDigit, isUpper, isLower)
39import Data.Default (Default)
40import Data.Default (Default)
40import Data.Map (insert)
41import Data.Map (insert)
41import Data.Maybe (catMaybes)
42import Data.Maybe (catMaybes)
@@ -64,18 +65,18 @@ data MacroKind = KTitle
64 | KCodeBlEnd
65 | KCodeBlEnd
65 | KTab
66 | KTab
66 | KTabEnd
67 | KTabEnd
68+ | KSubTab
67 deriving (Show, Eq)
69 deriving (Show, Eq)
68
70
69−-- TODO header strings
71+type RoffStr = (String, FontKind)
70−-- TODO remove MStr
72+
71−-- TODO filter skipped content
72−data ManToken = MStr String FontKind
73+data ManToken = MStr RoffStr
73− | MLine [(String, FontKind)]
74+ | MLine [RoffStr]
74 | MMaybeLink String
75 | MMaybeLink String
75 | MEmptyLine
76 | MEmptyLine
76− | MHeader Int String
77+ | MHeader Int [RoffStr]
77− | MMacro MacroKind [String]
78+ | MMacro MacroKind [RoffStr]
78− | MUnknownMacro String [String]
79+ | MUnknownMacro String [RoffStr]
79 | MComment String
80 | MComment String
80 deriving Show
81 deriving Show
81
82
@@ -152,7 +153,7 @@ lexMan = many (lexMacro <|> lexLine <|> lexEmptyLine)
152
153
153parseMan :: PandocMonad m => ManParser m Pandoc
154parseMan :: PandocMonad m => ManParser m Pandoc
154parseMan = do
155parseMan = do
155− let parsers = [ parseBulletList, parseTitle, parsePara, parseSkippedContent
156+ let parsers = [ try parseBulletList, parseTitle, parsePara, parseSkippedContent
156 , parseCodeBlock, parseHeader, parseSkipMacro]
157 , parseCodeBlock, parseHeader, parseSkipMacro]
157 blocks <- many $ choice parsers
158 blocks <- many $ choice parsers
158 parserst <- getState
159 parserst <- getState
@@ -212,13 +213,18 @@ escapeLexer = do
212 , char 'P' >> return Regular
213 , char 'P' >> return Regular
213 ]
214 ]
214
215
216+currentFont :: PandocMonad m => ManLexer m FontKind
217+currentFont = do
218+ RoffState {fontKind = fk} <- getState
219+ return fk
220+
215lexMacro :: PandocMonad m => ManLexer m ManToken
221lexMacro :: PandocMonad m => ManLexer m ManToken
216lexMacro = do
222lexMacro = do
217 char '.' <|> char '\''
223 char '.' <|> char '\''
218 many spacetab
224 many spacetab
219 macroName <- many1 (letter <|> oneOf ['\\', '"'])
225 macroName <- many1 (letter <|> oneOf ['\\', '"'])
220 args <- lexArgs
226 args <- lexArgs
221− let joinedArgs = unwords args
227+ let joinedArgs = unwords $ fst <$> args
222 let knownMacro mkind = MMacro mkind args
228 let knownMacro mkind = MMacro mkind args
223
229
224 let tok = case macroName of
230 let tok = case macroName of
@@ -227,21 +233,22 @@ lexMacro = do
227 "IP" -> knownMacro KTab
233 "IP" -> knownMacro KTab
228 "TP" -> knownMacro KTab
234 "TP" -> knownMacro KTab
229 "RE" -> knownMacro KTabEnd
235 "RE" -> knownMacro KTabEnd
236+ "RS" -> knownMacro KSubTab
230 "nf" -> knownMacro KCodeBlStart
237 "nf" -> knownMacro KCodeBlStart
231 "fi" -> knownMacro KCodeBlEnd
238 "fi" -> knownMacro KCodeBlEnd
232− "B" -> MStr joinedArgs Bold
239+ "B" -> MStr (joinedArgs,Bold)
233 "BR" -> MMaybeLink joinedArgs
240 "BR" -> MMaybeLink joinedArgs
234− x | x `elem` ["BI", "IB"] -> MStr joinedArgs ItalicBold
241+ x | x `elem` ["BI", "IB"] -> MStr (joinedArgs, ItalicBold)
235− x | x `elem` ["I", "IR", "RI"] -> MStr joinedArgs Italic
242+ x | x `elem` ["I", "IR", "RI"] -> MStr (joinedArgs, Italic)
236− "SH" -> MHeader 2 joinedArgs
243+ "SH" -> MHeader 2 args
237− "SS" -> MHeader 3 joinedArgs
244+ "SS" -> MHeader 3 args
238 x | x `elem` [ "P", "PP", "LP", "sp"] -> MEmptyLine
245 x | x `elem` [ "P", "PP", "LP", "sp"] -> MEmptyLine
239 _ -> MUnknownMacro macroName args
246 _ -> MUnknownMacro macroName args
240 return tok
247 return tok
241
248
242 where
249 where
243
250
244− lexArgs :: PandocMonad m => ManLexer m [String]
251+ lexArgs :: PandocMonad m => ManLexer m [RoffStr]
245 lexArgs = do
252 lexArgs = do
246 args <- many oneArg
253 args <- many oneArg
247 eofline
254 eofline
@@ -249,20 +256,24 @@ lexMacro = do
249
256
250 where
257 where
251
258
252− oneArg :: PandocMonad m => ManLexer m String
259+ oneArg :: PandocMonad m => ManLexer m RoffStr
253 oneArg = do
260 oneArg = do
254 many1 spacetab
261 many1 spacetab
255 quotedArg <|> plainArg
262 quotedArg <|> plainArg
256
263
257− plainArg :: PandocMonad m => ManLexer m String
264+ plainArg :: PandocMonad m => ManLexer m RoffStr
265+ plainArg = do
258− plainArg = fmap catMaybes . many1 $ escChar <|> (Just <$> noneOf " \t\n")
266+ arg <- many1 $ escChar <|> (Just <$> noneOf " \t\n")
267+ f <- currentFont
268+ return (catMaybes arg, f)
259
269
260− quotedArg :: PandocMonad m => ManLexer m String
270+ quotedArg :: PandocMonad m => ManLexer m RoffStr
261 quotedArg = do
271 quotedArg = do
262 char '"'
272 char '"'
263 val <- catMaybes <$> many quotedChar
273 val <- catMaybes <$> many quotedChar
264 char '"'
274 char '"'
275+ f <- currentFont
265− return val
276+ return (val, f)
266
277
267 quotedChar :: PandocMonad m => ManLexer m (Maybe Char)
278 quotedChar :: PandocMonad m => ManLexer m (Maybe Char)
268 quotedChar = escChar <|> (Just <$> noneOf "\"\n") <|> (Just <$> try (string "\"\"" >> return '"'))
279 quotedChar = escChar <|> (Just <$> noneOf "\"\n") <|> (Just <$> try (string "\"\"" >> return '"'))
@@ -295,11 +306,6 @@ lexLine = do
295 lnpart <- many1 $ noneOf "\n\\"
306 lnpart <- many1 $ noneOf "\n\\"
296 font <- currentFont
307 font <- currentFont
297 return $ Just (lnpart, font)
308 return $ Just (lnpart, font)
298−
299− currentFont :: PandocMonad m => ManLexer m FontKind
300− currentFont = do
301− RoffState {fontKind = fk} <- getState
302− return fk
303
309
304
310
305lexEmptyLine :: PandocMonad m => ManLexer m ManToken
311lexEmptyLine :: PandocMonad m => ManLexer m ManToken
@@ -313,11 +319,11 @@ msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t
313msatisfy predic = tokenPrim show nextPos testTok
319msatisfy predic = tokenPrim show nextPos testTok
314 where
320 where
315 testTok t = if predic t then Just t else Nothing
321 testTok t = if predic t then Just t else Nothing
316− nextPos pos x _xs = updatePosString pos (show x)
322+ nextPos pos x _xs = updatePosString (setSourceLine pos $ sourceLine pos + (if predic x then 1 else 0)) (show x)
317
323
318mstr :: PandocMonad m => ManParser m ManToken
324mstr :: PandocMonad m => ManParser m ManToken
319mstr = msatisfy isMStr where
325mstr = msatisfy isMStr where
320− isMStr (MStr _ _) = True
326+ isMStr (MStr _) = True
321 isMStr _ = False
327 isMStr _ = False
322
328
323mline :: PandocMonad m => ManParser m ManToken
329mline :: PandocMonad m => ManParser m ManToken
@@ -371,7 +377,7 @@ parseTitle = do
371 if null args
377 if null args
372 then return Null
378 then return Null
373 else do
379 else do
374− let mantitle = head args
380+ let mantitle = fst $ head args
375 modifyState (changeTitle mantitle)
381 modifyState (changeTitle mantitle)
376 return $ Header 1 nullAttr [Str mantitle]
382 return $ Header 1 nullAttr [Str mantitle]
377 where
383 where
@@ -395,29 +401,32 @@ parseSkippedContent = do
395 logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos
401 logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos
396 onToken _ = return ()
402 onToken _ = return ()
397
403
398−strToInline :: String -> FontKind -> Inline
404+strToInline :: RoffStr -> Inline
399−strToInline s Regular = Str s
405+strToInline (s, Regular) = Str s
400−strToInline s Italic = Emph [Str s]
406+strToInline (s, Italic) = Emph [Str s]
401−strToInline s Bold = Strong [Str s]
407+strToInline (s, Bold) = Strong [Str s]
402−strToInline s ItalicBold = Strong [Emph [Str s]]
408+strToInline (s, ItalicBold) = Strong [Emph [Str s]]
403
409
404parsePara :: PandocMonad m => ManParser m Block
410parsePara :: PandocMonad m => ManParser m Block
405−parsePara = do
411+parsePara = Para <$> parseInlines
412+
413+parseInlines :: PandocMonad m => ManParser m [Inline]
414+parseInlines = do
406 inls <- many1 (strInl <|> lineInl <|> linkInl <|> comment)
415 inls <- many1 (strInl <|> lineInl <|> linkInl <|> comment)
407 let withspaces = intersperse [Space] inls
416 let withspaces = intersperse [Space] inls
408− return $ Para (concat withspaces)
417+ return $ concat withspaces
409
418
410 where
419 where
411
420
412 strInl :: PandocMonad m => ManParser m [Inline]
421 strInl :: PandocMonad m => ManParser m [Inline]
413 strInl = do
422 strInl = do
414− (MStr str fk) <- mstr
423+ (MStr rstr) <- mstr
415− return [strToInline str fk]
424+ return [strToInline rstr]
416
425
417 lineInl :: PandocMonad m => ManParser m [Inline]
426 lineInl :: PandocMonad m => ManParser m [Inline]
418 lineInl = do
427 lineInl = do
419 (MLine fragments) <- mline
428 (MLine fragments) <- mline
420− return $ fmap (\(s,f) -> strToInline s f) fragments
429+ return $ strToInline <$> fragments
421
430
422 linkInl :: PandocMonad m => ManParser m [Inline]
431 linkInl :: PandocMonad m => ManParser m [Inline]
423 linkInl = do
432 linkInl = do
@@ -458,7 +467,7 @@ parseCodeBlock = do
458 where
467 where
459
468
460 extractText :: ManToken -> Maybe String
469 extractText :: ManToken -> Maybe String
461− extractText (MStr s _) = Just s
470+ extractText (MStr (s, _)) = Just s
462 extractText (MLine ss) = Just . concat $ map fst ss -- TODO maybe unwords?
471 extractText (MLine ss) = Just . concat $ map fst ss -- TODO maybe unwords?
463 extractText (MMaybeLink s) = Just s
472 extractText (MMaybeLink s) = Just s
464 extractText MEmptyLine = Just "" -- string are intercalated with '\n', this prevents double '\n'
473 extractText MEmptyLine = Just "" -- string are intercalated with '\n', this prevents double '\n'
@@ -466,20 +475,43 @@ parseCodeBlock = do
466
475
467parseHeader :: PandocMonad m => ManParser m Block
476parseHeader :: PandocMonad m => ManParser m Block
468parseHeader = do
477parseHeader = do
469− (MHeader lvl s) <- mheader
478+ (MHeader lvl ss) <- mheader
470− return $ Header lvl nullAttr [Str s]
479+ return $ Header lvl nullAttr $ intersperse Space $ strToInline <$> ss
471
480
472parseBulletList :: PandocMonad m => ManParser m Block
481parseBulletList :: PandocMonad m => ManParser m Block
473−parseBulletList = BulletList . map (: []) <$> many1 block
482+parseBulletList = BulletList <$> many1 paras where
474−
483+
475− where
484+ macroIPInl :: [RoffStr] -> [Inline]
476−
485+ macroIPInl (x:_:[]) = [strToInline x, Space]
486+ macroIPInl _ = []
487+
488+ listKind :: [RoffStr] -> Maybe ([[Block]] -> Block)
489+ listKind (((c:_), _):_:[]) =
490+ let params style = OrderedList (1, style, DefaultDelim)
491+ in Just $ case c of
492+ _ | isDigit c -> params Decimal
493+ _ | isUpper c -> params UpperAlpha
494+ _ | isLower c -> params LowerAlpha
495+ _ -> BulletList
496+
497+ listKind _ = Nothing
498+
477− block :: PandocMonad m => ManParser m Block
499+ paras :: PandocMonad m => ManParser m [Block]
478− block = do
500+ paras = do
479− mmacro KTab
501+ (MMacro _ args) <- mmacro KTab
480− pars <- parsePara
502+ let lk = listKind args
503+ inls <- parseInlines
504+ let macroinl = macroIPInl args
505+ let para = Plain $ macroinl ++ inls
506+ subls <- many sublist
507+ return $ para : subls
508+
509+ sublist :: PandocMonad m => ManParser m Block
510+ sublist = do
511+ mmacro KSubTab
512+ bl <- parseBulletList
481− many $ mmacro KTabEnd
513+ mmacro KTabEnd
482− return pars
514+ return bl
483
515
484-- In case of weird man file it will be parsed succesfully
516-- In case of weird man file it will be parsed succesfully
485parseSkipMacro :: PandocMonad m => ManParser m Block
517parseSkipMacro :: PandocMonad m => ManParser m Block