@@ -1,4 +1,5 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23{-
34 Copyright (C) 2018 Yan Pashkovsky <yanp.bugz@gmail.com>
45
@@ -55,6 +56,8 @@ import Text.Parsec hiding (tokenPrim, space)
5556import qualified Text.Parsec as Parsec
5657import Text.Parsec.Pos (updatePosString)
5758import Text.Pandoc.GroffChar (characterCodes, combiningAccents)
59+import qualified Data.Sequence as Seq
60+import qualified Data.Foldable as Foldable
5861
5962-- import Debug.Trace (traceShowId)
6063
@@ -75,24 +78,29 @@ data LinePart = RoffStr (String, Font)
7578data ManToken = MLine [LinePart]
7679 | MEmptyLine
7780 | MMacro MacroKind [[LinePart]]
78− | MComment
7981 deriving Show
8082
83+newtype ManTokens = ManTokens { unManTokens :: Seq.Seq ManToken }
84+ deriving (Show, Semigroup, Monoid)
85+
86+singleTok :: ManToken -> ManTokens
87+singleTok t = ManTokens (Seq.singleton t)
88+
8189data RoffState = RoffState { fontKind :: Font
90+ , customMacros :: M.Map String ManTokens
8291 } deriving Show
8392
8493instance Default RoffState where
85− def = RoffState { fontKind = S.singleton Regular }
94+ def = RoffState { customMacros = mempty
95+ , fontKind = S.singleton Regular }
8696
87−data ManState = ManState { customMacros :: M.Map String [ManToken]
88− , readerOptions :: ReaderOptions
97+data ManState = ManState { readerOptions :: ReaderOptions
8998 , metadata :: Meta
9099 } deriving Show
91100
92101instance Default ManState where
93− def = ManState { customMacros = mempty
94− , readerOptions = def
95− , metadata = nullMeta }
102+ def = ManState { readerOptions = def
103+ , metadata = nullMeta }
96104
97105type ManLexer m = ParserT [Char] RoffState m
98106type ManParser m = ParserT [ManToken] ManState m
@@ -101,7 +109,9 @@ type ManParser m = ParserT [ManToken] ManState m
101109-- | Read man (troff) from an input string and return a Pandoc document.
102110readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
103111readMan opts txt = do
104− eithertokens <- readWithM (many manToken) def (T.unpack $ crFilter txt)
112+ eithertokens <- readWithM
113+ (Foldable.toList . unManTokens . mconcat <$> many manToken)
114+ def (T.unpack $ crFilter txt)
105115 case eithertokens of
106116 Left e -> throwError e
107117 Right tokenz -> do
@@ -128,7 +138,7 @@ readMan opts txt = do
128138-- String -> ManToken function
129139--
130140
131−manToken :: PandocMonad m => ManLexer m ManToken
141+manToken :: PandocMonad m => ManLexer m ManTokens
132142manToken = lexComment <|> lexMacro <|> lexLine <|> lexEmptyLine
133143
134144parseMan :: PandocMonad m => ManParser m Pandoc
@@ -147,8 +157,7 @@ parseBlock = choice [ parseList
147157 , parseSkippedContent
148158 , parseCodeBlock
149159 , parseHeader
150− , parseMacroDef
151− , parseUnkownMacro
160+ , skipUnkownMacro
152161 ]
153162
154163eofline :: Stream s m Char => ParsecT s u m ()
@@ -268,15 +277,15 @@ currentFont :: PandocMonad m => ManLexer m Font
268277currentFont = fontKind <$> getState
269278
270279-- separate function from lexMacro since real man files sometimes do not follow the rules
271−lexComment :: PandocMonad m => ManLexer m ManToken
280+lexComment :: PandocMonad m => ManLexer m ManTokens
272281lexComment = do
273282 try $ string ".\\\""
274283 many Parsec.space
275284 skipMany $ noneOf "\n"
276285 char '\n'
277− return MComment
286+ return mempty
278287
279−lexMacro :: PandocMonad m => ManLexer m ManToken
288+lexMacro :: PandocMonad m => ManLexer m ManTokens
280289lexMacro = do
281290 char '.' <|> char '\''
282291 many spacetab
@@ -287,15 +296,16 @@ lexMacro = do
287296 addFontToRoffStr _ x = x
288297
289298 case macroName of
290− "" -> return MComment
291− "\\\"" -> return MComment
292− "\\#" -> return MComment
299+ "" -> return mempty
300+ "\\\"" -> return mempty
301+ "\\#" -> return mempty
302+ "de" -> lexMacroDef args
293303 "B" -> do
294304 args' <- argsOrFromNextLine args
295− return $ MLine $ concatMap (addFont Bold) args'
305+ return $ singleTok $ MLine $ concatMap (addFont Bold) args'
296306 "I" -> do
297307 args' <- argsOrFromNextLine args
298− return $ MLine $ concatMap (addFont Italic) args'
308+ return $ singleTok $ MLine $ concatMap (addFont Italic) args'
299309 x | x `elem` ["BI", "IB", "RI", "IR", "BR", "RB"] -> do
300310 let toFont 'I' = Italic
301311 toFont 'R' = Regular
@@ -303,17 +313,56 @@ lexMacro = do
303313 toFont 'M' = Monospace
304314 toFont _ = Regular
305315 let fontlist = map toFont x
306− return $ MLine $ concat $ zipWith addFont (cycle fontlist) args
307− x | x `elem` [ "P", "PP", "LP", "sp"] -> return MEmptyLine
308− _ -> return $ MMacro macroName args
316+ return $ singleTok
317+ $ MLine $ concat $ zipWith addFont (cycle fontlist) args
318+ x | x `elem` [ "P", "PP", "LP", "sp"] -> return $ singleTok MEmptyLine
319+ _ -> resolveMacro macroName args
309320
310321 where
311322
312− argsOrFromNextLine :: PandocMonad m => [[LinePart]] -> ManLexer m [[LinePart]]
323+ resolveMacro :: PandocMonad m
324+ => String -> [[LinePart]] -> ManLexer m ManTokens
325+ resolveMacro macroName args = do
326+ macros <- customMacros <$> getState
327+ case M.lookup macroName macros of
328+ Nothing -> return $ singleTok $ MMacro macroName args
329+ Just ts -> do
330+ let fillLP (RoffStr (x,y)) zs = RoffStr (x,y) : zs
331+ fillLP (MacroArg i) zs =
332+ case drop (i - 1) args of
333+ [] -> zs
334+ (ys:_) -> ys ++ zs
335+ let fillMacroArg (MLine lineparts) =
336+ MLine (foldr fillLP [] lineparts)
337+ fillMacroArg x = x
338+ return $ ManTokens . fmap fillMacroArg . unManTokens $ ts
339+
340+ lexMacroDef :: PandocMonad m => [[LinePart]] -> ManLexer m ManTokens
341+ lexMacroDef args = do -- macro definition
342+ (macroName, stopMacro) <-
343+ case args of
344+ (x : y : _) -> return (linePartsToString x, linePartsToString y)
345+ -- optional second arg
346+ (x:_) -> return (linePartsToString x, ".")
347+ [] -> fail "No argument to .de"
348+ let stop = try $ do
349+ char '.' <|> char '\''
350+ many spacetab
351+ string stopMacro
352+ _ <- lexArgs
353+ return ()
354+ ts <- mconcat <$> manyTill manToken stop
355+ modifyState $ \st ->
356+ st{ customMacros = M.insert macroName ts (customMacros st) }
357+ return mempty
358+
359+ argsOrFromNextLine :: PandocMonad m
360+ => [[LinePart]] -> ManLexer m [[LinePart]]
313361 argsOrFromNextLine args =
314362 if null args
315363 then do
316− MLine lps <- lexLine
364+ lps <- many1 linePart
365+ eofline
317366 return [lps]
318367 else return args
319368
@@ -357,11 +406,11 @@ lexMacro = do
357406 fonts <- currentFont
358407 return $ RoffStr ("\"", fonts)
359408
360−lexLine :: PandocMonad m => ManLexer m ManToken
409+lexLine :: PandocMonad m => ManLexer m ManTokens
361410lexLine = do
362411 lnparts <- many1 linePart
363412 eofline
364− return $ MLine lnparts
413+ return $ singleTok $ MLine lnparts
365414 where
366415
367416linePart :: PandocMonad m => ManLexer m LinePart
@@ -398,8 +447,8 @@ spaceTabChar = do
398447 font <- currentFont
399448 return $ RoffStr ([c], font)
400449
401−lexEmptyLine :: PandocMonad m => ManLexer m ManToken
402−lexEmptyLine = char '\n' >> return MEmptyLine
450+lexEmptyLine :: PandocMonad m => ManLexer m ManTokens
451+lexEmptyLine = char '\n' >> return (singleTok MEmptyLine)
403452
404453--
405454-- ManToken parsec functions
@@ -434,11 +483,6 @@ mmacroAny = msatisfy isMMacro where
434483 isMMacro (MMacro _ _) = True
435484 isMMacro _ = False
436485
437−mcomment :: PandocMonad m => ManParser m ManToken
438−mcomment = msatisfy isMComment where
439− isMComment MComment = True
440− isMComment _ = False
441−
442486--
443487-- ManToken -> Block functions
444488--
@@ -459,7 +503,7 @@ parseTitle = do
459503 return mempty
460504
461505parseSkippedContent :: PandocMonad m => ManParser m Blocks
462−parseSkippedContent = mempty <$ (mcomment <|> memptyLine)
506+parseSkippedContent = mempty <$ memptyLine
463507
464508linePartsToInlines :: [LinePart] -> Inlines
465509linePartsToInlines = go
@@ -502,7 +546,7 @@ parsePara = para . trimInlines <$> parseInlines
502546
503547parseInlines :: PandocMonad m => ManParser m Inlines
504548parseInlines = do
505− inls <- many1 (lineInl <|> comment <|> parseLink <|> parseEmailLink)
549+ inls <- many1 (lineInl <|> parseLink <|> parseEmailLink)
506550 return $ mconcat $ intersperse B.space inls
507551
508552lineInl :: PandocMonad m => ManParser m Inlines
@@ -510,9 +554,6 @@ lineInl = do
510554 (MLine fragments) <- mline
511555 return $ linePartsToInlines $ fragments
512556
513−comment :: PandocMonad m => ManParser m Inlines
514−comment = mcomment >> return mempty
515−
516557bareIP :: PandocMonad m => ManParser m ManToken
517558bareIP = msatisfy isBareIP where
518559 isBareIP (MMacro "IP" []) = True
@@ -522,7 +563,7 @@ parseCodeBlock :: PandocMonad m => ManParser m Blocks
522563parseCodeBlock = try $ do
523564 optional bareIP -- some people indent their code
524565 mmacro "nf"
525− toks <- many (mline <|> memptyLine <|> mcomment)
566+ toks <- many (mline <|> memptyLine)
526567 mmacro "fi"
527568 return $ codeBlock (removeFinalNewline $
528569 intercalate "\n" . catMaybes $
@@ -612,7 +653,7 @@ parseDefinitionList = definitionList <$> many1 definitionListItem
612653parseLink :: PandocMonad m => ManParser m Inlines
613654parseLink = try $ do
614655 MMacro _ args <- mmacro "UR"
615− contents <- mconcat <$> many1 (lineInl <|> comment)
656+ contents <- mconcat <$> many1 lineInl
616657 mmacro "UE"
617658 let url = case args of
618659 [] -> ""
@@ -622,48 +663,19 @@ parseLink = try $ do
622663parseEmailLink :: PandocMonad m => ManParser m Inlines
623664parseEmailLink = do
624665 MMacro _ args <- mmacro "MT"
625− contents <- mconcat <$> many1 (lineInl <|> comment)
666+ contents <- mconcat <$> many1 lineInl
626667 mmacro "ME"
627668 let url = case args of
628669 [] -> ""
629670 (x:_) -> "mailto:" ++ linePartsToString x
630671 return $ link url "" contents
631672
632−parseMacroDef :: PandocMonad m => ManParser m Blocks
633−parseMacroDef = do
634− MMacro _ args <- mmacro "de"
635− (macroName, stopMacro) <-
636− case args of
637− (x : y : _) -> return (linePartsToString x, linePartsToString y)
638− -- optional second arg
639− (x:_) -> return (linePartsToString x, ".")
640− [] -> fail "No argument to .de"
641− ts <- manyTill (msatisfy (const True)) (mmacro stopMacro)
642− modifyState $ \st ->
643− st{ customMacros = M.insert macroName ts (customMacros st) }
644− return mempty
645−
646−-- In case of weird man file it will be parsed succesfully
647−parseUnkownMacro :: PandocMonad m => ManParser m Blocks
648−parseUnkownMacro = do
673+skipUnkownMacro :: PandocMonad m => ManParser m Blocks
674+skipUnkownMacro = do
649675 pos <- getPosition
650676 tok <- mmacroAny
651677 case tok of
652− MMacro mkind args -> do
653− macros <- customMacros <$> getState
654− case M.lookup mkind macros of
655− Nothing -> do
656− report $ SkippedContent ('.':mkind) pos
657− return mempty
658− Just ts -> do
659− toks <- getInput
660− let fillLP (RoffStr (x,y)) zs = RoffStr (x,y) : zs
661− fillLP (MacroArg i) zs =
662− case drop (i - 1) args of
663− [] -> zs
664− (ys:_) -> ys ++ zs
665− let fillMacroArg (MLine lineparts) = MLine (foldr fillLP [] lineparts)
666− fillMacroArg x = x
667− setInput $ (map fillMacroArg ts) ++ toks
668− return mempty
669− _ -> fail "the impossible happened"
678+ MMacro mkind _ -> do
679+ report $ SkippedContent ('.':mkind) pos
680+ return mempty
681+ _ -> fail "the impossible happened"