@@ -0,0 +1,559 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-
3+ Copyright (C) 2018 Yan Pashkovsky <yanp.bugz@gmail.com>
4+
5+This program is free software; you can redistribute it and/or modify
6+it under the terms of the GNU General Public License as published by
7+the Free Software Foundation; either version 2 of the License, or
8+(at your option) any later version.
9+
10+This program is distributed in the hope that it will be useful,
11+but WITHOUT ANY WARRANTY; without even the implied warranty of
12+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+GNU General Public License for more details.
14+
15+You should have received a copy of the GNU General Public License
16+along with this program; if not, write to the Free Software
17+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18+
19+
20+
21+-}
22+
23+{- |
24+ Module : Text.Pandoc.Readers.Man
25+ Copyright : Copyright (C) 2018 Yan Pashkovsky
26+ License : GNU GPL, version 2 or above
27+
28+ Maintainer : Yan Pashkovsky <yanp.bugz@gmail.com>
29+ Stability : WIP
30+ Portability : portable
31+
32+Conversion of man to 'Pandoc' document.
33+-}
34+module Text.Pandoc.Readers.Man (readMan) where
35+
36+import Prelude
37+import Control.Monad (liftM, void)
38+import Control.Monad.Except (throwError)
39+import Data.Char (isDigit, isUpper, isLower)
40+import Data.Default (Default)
41+import Data.Map (insert)
42+import Data.Set (Set, singleton)
43+import qualified Data.Set as S (fromList, toList)
44+import Data.Maybe (catMaybes, fromMaybe, isNothing)
45+import Data.List (intersperse, intercalate)
46+import qualified Data.Text as T
47+
48+import Text.Pandoc.Class (PandocMonad(..))
49+import Text.Pandoc.Builder as B hiding (singleton)
50+import Text.Pandoc.Error (PandocError (PandocParsecError))
51+import Text.Pandoc.Logging (LogMessage(..))
52+import Text.Pandoc.Options
53+import Text.Pandoc.Parsing
54+import Text.Pandoc.Shared (crFilter)
55+import Text.Parsec hiding (tokenPrim, space)
56+import qualified Text.Parsec as Parsec
57+import Text.Parsec.Pos (updatePosString)
58+
59+--
60+-- Data Types
61+--
62+data FontKind = Bold | Italic | Monospace | Regular deriving (Show, Eq, Ord)
63+
64+data MacroKind = KTitle
65+ | KCodeBlStart
66+ | KCodeBlEnd
67+ | KTab
68+ | KTabEnd
69+ | KSubTab
70+ deriving (Show, Eq)
71+
72+type Font = Set FontKind
73+
74+type RoffStr = (String, Font)
75+
76+-- TODO parse tables (see man tbl)
77+data ManToken = MStr RoffStr
78+ | MLine [RoffStr]
79+ | MMaybeLink String
80+ | MEmptyLine
81+ | MHeader Int [RoffStr]
82+ | MMacro MacroKind [RoffStr]
83+ | MUnknownMacro String [RoffStr]
84+ | MComment String
85+ deriving Show
86+
87+data EscapeThing = EFont Font
88+ | EChar Char
89+ | ENothing
90+ deriving Show
91+
92+data RoffState = RoffState { fontKind :: Font
93+ } deriving Show
94+
95+instance Default RoffState where
96+ def = RoffState {fontKind = singleton Regular}
97+
98+type ManLexer m = ParserT [Char] RoffState m
99+type ManParser m = ParserT [ManToken] ParserState m
100+
101+---- debug functions
102+{-
103+import Text.Pandoc.Class (runIOorExplode)
104+
105+printPandoc :: Pandoc -> [Char]
106+printPandoc (Pandoc m content) =
107+ let ttl = "Pandoc: " ++ (show $ unMeta m)
108+ cnt = intercalate "\n" $ map show content
109+ in ttl ++ "\n" ++ cnt
110+
111+testStr :: String -> IO ()
112+testStr str = do
113+ pand <- runIOorExplode $ readMan def (T.pack str)
114+ putStrLn $ printPandoc pand
115+
116+
117+testFile :: FilePath -> IO ()
118+testFile fname = do
119+ cont <- readFile fname
120+ testStr cont
121+-}
122+----
123+
124+
125+-- | Read man (troff) from an input string and return a Pandoc document.
126+readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
127+readMan opts txt = do
128+ eithertokens <- readWithM lexMan def (T.unpack $ crFilter txt)
129+ case eithertokens of
130+ Left e -> throwError e
131+ Right tokenz -> do
132+ let state = def {stateOptions = opts} :: ParserState
133+ eitherdoc <- readWithMTokens parseMan state tokenz
134+ either throwError return eitherdoc
135+
136+ where
137+
138+ readWithMTokens :: PandocMonad m
139+ => ParserT [ManToken] ParserState m a -- ^ parser
140+ -> ParserState -- ^ initial state
141+ -> [ManToken] -- ^ input
142+ -> m (Either PandocError a)
143+ readWithMTokens parser state input =
144+ let leftF = PandocParsecError . (intercalate "\n") $ show <$> input
145+ in mapLeft leftF `liftM` runParserT parser state "source" input
146+
147+ mapLeft :: (a -> c) -> Either a b -> Either c b
148+ mapLeft f (Left x) = Left $ f x
149+ mapLeft _ (Right r) = Right r
150+
151+--
152+-- String -> ManToken function
153+--
154+
155+lexMan :: PandocMonad m => ManLexer m [ManToken]
156+lexMan = many (lexComment <|> lexMacro <|> lexLine <|> lexEmptyLine)
157+
158+parseMan :: PandocMonad m => ManParser m Pandoc
159+parseMan = do
160+ let parsers = [ try parseList, parseTitle, parsePara, parseSkippedContent
161+ , try parseCodeBlock, parseHeader, parseSkipMacro]
162+ bs <- many $ choice parsers
163+ let (Pandoc _ blocks) = doc $ mconcat bs
164+ meta <- stateMeta <$> getState
165+ return $ Pandoc meta blocks
166+
167+eofline :: Stream s m Char => ParsecT s u m ()
168+eofline = void newline <|> eof
169+
170+spacetab :: Stream s m Char => ParsecT s u m Char
171+spacetab = char ' ' <|> char '\t'
172+
173+-- TODO add other sequences from man (7) groff
174+escapeLexer :: PandocMonad m => ManLexer m EscapeThing
175+escapeLexer = do
176+ char '\\'
177+ choice [escChar, escFont, escUnknown]
178+ where
179+
180+ escChar :: PandocMonad m => ManLexer m EscapeThing
181+ escChar =
182+ let skipSeqs = ["%", "{", "}", "&", "\n", ":", "\"", "0", "c"]
183+ subsSeqs = [ ("-", '-'), (" ", ' '), ("\\", '\\'), ("[lq]", '“'), ("[rq]", '”')
184+ , ("[em]", '—'), ("[en]", '–'), ("*(lq", '«'), ("*(rq", '»')
185+ , ("t", '\t'), ("e", '\\'), ("`", '`'), ("^", ' '), ("|", ' ')
186+ , ("'", '`') ]
187+ substitute :: PandocMonad m => (String,Char) -> ManLexer m EscapeThing
188+ substitute (from,to) = try $ string from >> return (EChar to)
189+ skip :: PandocMonad m => String -> ManLexer m EscapeThing
190+ skip seq' = try $ string seq' >> return ENothing
191+ in choice $ (substitute <$> subsSeqs) ++
192+ (skip <$> skipSeqs) ++
193+ [ char '(' >> anyChar >> return ENothing
194+ , char '[' >> many alphaNum >> char ']' >> return ENothing
195+ ]
196+
197+ escFont :: PandocMonad m => ManLexer m EscapeThing
198+ escFont = do
199+ char 'f'
200+ font <- choice [ singleton <$> letterFontKind
201+ , char '(' >> anyChar >> anyChar >> return (singleton Regular)
202+ , try lettersFont
203+ , digit >> return (singleton Regular)
204+ ]
205+ modifyState (\r -> r {fontKind = font})
206+ return $ EFont font
207+
208+ where
209+
210+ lettersFont :: PandocMonad m => ManLexer m Font
211+ lettersFont = do
212+ char '['
213+ fs <- many letterFontKind
214+ many letter
215+ char ']'
216+ return $ S.fromList fs
217+
218+ letterFontKind :: PandocMonad m => ManLexer m FontKind
219+ letterFontKind = choice [
220+ char 'B' >> return Bold
221+ , char 'I' >> return Italic
222+ , char 'C' >> return Monospace
223+ , (char 'P' <|> char 'R') >> return Regular
224+ ]
225+
226+ escUnknown :: PandocMonad m => ManLexer m EscapeThing
227+ escUnknown = do
228+ c <- anyChar
229+ pos <- getPosition
230+ logOutput $ SkippedContent ("Unknown escape sequence \\" ++ [c]) pos
231+ return ENothing
232+
233+currentFont :: PandocMonad m => ManLexer m Font
234+currentFont = fontKind <$> getState
235+
236+-- separate function from lexMacro since real man files sometimes do not follow the rules
237+lexComment :: PandocMonad m => ManLexer m ManToken
238+lexComment = do
239+ try $ string ".\\\""
240+ many Parsec.space
241+ body <- many $ noneOf "\n"
242+ char '\n'
243+ return $ MComment body
244+
245+lexMacro :: PandocMonad m => ManLexer m ManToken
246+lexMacro = do
247+ char '.' <|> char '\''
248+ many spacetab
249+ macroName <- many1 (letter <|> oneOf ['\\', '"', '&'])
250+ args <- lexArgs
251+ let joinedArgs = unwords $ fst <$> args
252+ knownMacro mkind = MMacro mkind args
253+
254+ tok = case macroName of
255+ x | x `elem` ["\\\"", "\\#"] -> MComment joinedArgs
256+ "TH" -> knownMacro KTitle
257+ "IP" -> knownMacro KTab
258+ "TP" -> knownMacro KTab
259+ "RE" -> knownMacro KTabEnd
260+ "RS" -> knownMacro KSubTab
261+ "nf" -> knownMacro KCodeBlStart
262+ "fi" -> knownMacro KCodeBlEnd
263+ "B" -> MStr (joinedArgs, singleton Bold)
264+ "BR" -> MMaybeLink joinedArgs
265+ x | x `elem` ["BI", "IB"] -> MStr (joinedArgs, S.fromList [Italic, Bold])
266+ x | x `elem` ["I", "IR", "RI"] -> MStr (joinedArgs, singleton Italic)
267+ "SH" -> MHeader 2 args
268+ "SS" -> MHeader 3 args
269+ x | x `elem` [ "P", "PP", "LP", "sp"] -> MEmptyLine
270+ _ -> MUnknownMacro macroName args
271+ return tok
272+
273+ where
274+
275+ -- TODO better would be [[RoffStr]], since one arg may have different fonts
276+ lexArgs :: PandocMonad m => ManLexer m [RoffStr]
277+ lexArgs = do
278+ args <- many $ try oneArg
279+ many spacetab
280+ eofline
281+ return args
282+
283+ where
284+
285+ oneArg :: PandocMonad m => ManLexer m RoffStr
286+ oneArg = do
287+ many1 spacetab
288+ many $ try $ string "\\\n"
289+ try quotedArg <|> plainArg -- try, because there are some erroneous files, e.g. linux/bpf.2
290+
291+ plainArg :: PandocMonad m => ManLexer m RoffStr
292+ plainArg = do
293+ indents <- many spacetab
294+ arg <- many1 $ escChar <|> (Just <$> noneOf " \t\n")
295+ f <- currentFont
296+ return (indents ++ catMaybes arg, f)
297+
298+ quotedArg :: PandocMonad m => ManLexer m RoffStr
299+ quotedArg = do
300+ char '"'
301+ val <- many quotedChar
302+ char '"'
303+ val2 <- many $ escChar <|> (Just <$> noneOf " \t\n")
304+ f <- currentFont
305+ return (catMaybes $ val ++ val2, f)
306+
307+ quotedChar :: PandocMonad m => ManLexer m (Maybe Char)
308+ quotedChar = escChar <|> (Just <$> noneOf "\"\n") <|> (Just <$> try (string "\"\"" >> return '"'))
309+
310+ escChar :: PandocMonad m => ManLexer m (Maybe Char)
311+ escChar = do
312+ ec <- escapeLexer
313+ case ec of
314+ (EChar c) -> return $ Just c
315+ _ -> return Nothing
316+
317+lexLine :: PandocMonad m => ManLexer m ManToken
318+lexLine = do
319+ lnparts <- many1 (esc <|> linePart)
320+ eofline
321+ return $ MLine $ catMaybes lnparts
322+ where
323+
324+ esc :: PandocMonad m => ManLexer m (Maybe (String, Font))
325+ esc = do
326+ someesc <- escapeLexer
327+ font <- currentFont
328+ let rv = case someesc of
329+ EChar c -> Just ([c], font)
330+ _ -> Nothing
331+ return rv
332+
333+ linePart :: PandocMonad m => ManLexer m (Maybe (String, Font))
334+ linePart = do
335+ lnpart <- many1 $ noneOf "\n\\"
336+ font <- currentFont
337+ return $ Just (lnpart, font)
338+
339+
340+lexEmptyLine :: PandocMonad m => ManLexer m ManToken
341+lexEmptyLine = char '\n' >> return MEmptyLine
342+
343+--
344+-- ManToken parsec functions
345+--
346+
347+msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t
348+msatisfy predic = tokenPrim show nextPos testTok
349+ where
350+ testTok t = if predic t then Just t else Nothing
351+ nextPos pos _x _xs = updatePosString (setSourceColumn (setSourceLine pos $ sourceLine pos + 1) 1) ("")
352+
353+mstr :: PandocMonad m => ManParser m ManToken
354+mstr = msatisfy isMStr where
355+ isMStr (MStr _) = True
356+ isMStr _ = False
357+
358+mline :: PandocMonad m => ManParser m ManToken
359+mline = msatisfy isMLine where
360+ isMLine (MLine _) = True
361+ isMLine _ = False
362+
363+mmaybeLink :: PandocMonad m => ManParser m ManToken
364+mmaybeLink = msatisfy isMMaybeLink where
365+ isMMaybeLink (MMaybeLink _) = True
366+ isMMaybeLink _ = False
367+
368+memplyLine :: PandocMonad m => ManParser m ManToken
369+memplyLine = msatisfy isMEmptyLine where
370+ isMEmptyLine MEmptyLine = True
371+ isMEmptyLine _ = False
372+
373+mheader :: PandocMonad m => ManParser m ManToken
374+mheader = msatisfy isMHeader where
375+ isMHeader (MHeader _ _) = True
376+ isMHeader _ = False
377+
378+mmacro :: PandocMonad m => MacroKind -> ManParser m ManToken
379+mmacro mk = msatisfy isMMacro where
380+ isMMacro (MMacro mk' _) | mk == mk' = True
381+ | otherwise = False
382+ isMMacro _ = False
383+
384+mmacroAny :: PandocMonad m => ManParser m ManToken
385+mmacroAny = msatisfy isMMacro where
386+ isMMacro (MMacro _ _) = True
387+ isMMacro _ = False
388+
389+munknownMacro :: PandocMonad m => ManParser m ManToken
390+munknownMacro = msatisfy isMUnknownMacro where
391+ isMUnknownMacro (MUnknownMacro _ _) = True
392+ isMUnknownMacro _ = False
393+
394+mcomment :: PandocMonad m => ManParser m ManToken
395+mcomment = msatisfy isMComment where
396+ isMComment (MComment _) = True
397+ isMComment _ = False
398+
399+--
400+-- ManToken -> Block functions
401+--
402+
403+parseTitle :: PandocMonad m => ManParser m Blocks
404+parseTitle = do
405+ (MMacro _ args) <- mmacro KTitle
406+ if null args
407+ then return mempty
408+ else do
409+ let mantitle = fst $ head args
410+ modifyState (changeTitle mantitle)
411+ return $ header 1 $ str mantitle
412+ where
413+ changeTitle title pst =
414+ let meta = stateMeta pst
415+ metaUp = Meta $ insert "title" (MetaString title) (unMeta meta)
416+ in
417+ pst {stateMeta = metaUp}
418+
419+parseSkippedContent :: PandocMonad m => ManParser m Blocks
420+parseSkippedContent = do
421+ tok <- munknownMacro <|> mcomment <|> memplyLine
422+ onToken tok
423+ return mempty
424+
425+ where
426+
427+ onToken :: PandocMonad m => ManToken -> ManParser m ()
428+ onToken (MUnknownMacro mname _) = do
429+ pos <- getPosition
430+ logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos
431+ onToken _ = return ()
432+
433+strToInlines :: RoffStr -> Inlines
434+strToInlines (s, fonts) = inner $ S.toList fonts where
435+ inner :: [FontKind] -> Inlines
436+ inner [] = str s
437+ inner (Bold:fs) = strong $ inner fs
438+ inner (Italic:fs) = emph $ inner fs
439+
440+ -- Monospace goes after Bold and Italic in ordered set
441+ inner (Monospace:_) = code s
442+ inner (Regular:fs) = inner fs
443+
444+parsePara :: PandocMonad m => ManParser m Blocks
445+parsePara = para <$> parseInlines
446+
447+parseInlines :: PandocMonad m => ManParser m Inlines
448+parseInlines = do
449+ inls <- many1 (strInl <|> lineInl <|> linkInl <|> comment)
450+ let withspaces = intersperse B.space inls
451+ return $ mconcat withspaces
452+
453+ where
454+
455+ strInl :: PandocMonad m => ManParser m Inlines
456+ strInl = do
457+ (MStr rstr) <- mstr
458+ return $ strToInlines rstr
459+
460+ lineInl :: PandocMonad m => ManParser m Inlines
461+ lineInl = do
462+ (MLine fragments) <- mline
463+ return $ mconcat $ strToInlines <$> fragments
464+
465+ linkInl :: PandocMonad m => ManParser m Inlines
466+ linkInl = do
467+ (MMaybeLink txt) <- mmaybeLink
468+ let inls = case runParser linkParser () "" txt of
469+ Right lnk -> lnk
470+ Left _ -> strong $ str txt
471+ return inls
472+
473+ where
474+
475+ -- assuming man pages are generated from Linux-like repository
476+ linkParser :: Parsec String () Inlines
477+ linkParser = do
478+ mpage <- many1 (alphaNum <|> char '_')
479+ spacetab
480+ char '('
481+ mansect <- digit
482+ char ')'
483+ other <- many anyChar
484+ let manurl pagename section = "../"++section++"/"++pagename++"."++section
485+ lnkInls = link (manurl mpage [mansect]) mpage (strong $ str mpage)
486+ return $ lnkInls <> strong (str (" ("++[mansect] ++ ")") <> str other)
487+
488+ comment :: PandocMonad m => ManParser m Inlines
489+ comment = mcomment >> return mempty
490+
491+
492+parseCodeBlock :: PandocMonad m => ManParser m Blocks
493+parseCodeBlock = do
494+ mmacro KCodeBlStart
495+ toks <- many (mstr <|> mline <|> mmaybeLink <|> memplyLine <|> munknownMacro <|> mcomment)
496+ mmacro KCodeBlEnd
497+ return $ codeBlock (intercalate "\n" . catMaybes $ extractText <$> toks)
498+
499+ where
500+
501+ extractText :: ManToken -> Maybe String
502+ extractText (MStr (s, _)) = Just s
503+ extractText (MLine ss) = Just . concat $ map fst ss -- TODO maybe unwords?
504+ extractText (MMaybeLink s) = Just s
505+ extractText MEmptyLine = Just "" -- string are intercalated with '\n', this prevents double '\n'
506+ extractText _ = Nothing
507+
508+parseHeader :: PandocMonad m => ManParser m Blocks
509+parseHeader = do
510+ (MHeader lvl ss) <- mheader
511+ return $ header lvl (mconcat $ intersperse B.space $ strToInlines <$> ss)
512+
513+type ListBuilder = [Blocks] -> Blocks
514+
515+parseList :: PandocMonad m => ManParser m Blocks
516+parseList = do
517+ xx <- many1 paras
518+ let bls = map snd xx
519+ let bldr = fst $ head xx
520+ return $ bldr bls
521+
522+ where
523+
524+ macroIPInl :: [RoffStr] -> Inlines
525+ macroIPInl (x:_:[]) = strToInlines x <> B.space
526+ macroIPInl _ = mempty
527+
528+ listKind :: [RoffStr] -> Maybe ListBuilder
529+ listKind (((c:_), _):_:[]) =
530+ let params style = orderedListWith (1, style, DefaultDelim)
531+ in case c of
532+ _ | isDigit c -> Just $ params Decimal
533+ _ | isUpper c -> Just $ params UpperAlpha
534+ _ | isLower c -> Just $ params LowerAlpha
535+ _ -> Nothing
536+
537+ listKind _ = Nothing
538+
539+ paras :: PandocMonad m => ManParser m (ListBuilder, Blocks)
540+ paras = do
541+ (MMacro _ args) <- mmacro KTab
542+ let lbuilderOpt = listKind args
543+ lbuilder = fromMaybe bulletList lbuilderOpt
544+ macroinl = macroIPInl args
545+ inls <- parseInlines
546+ let parainls = if isNothing lbuilderOpt then macroinl <> inls else inls
547+ subls <- mconcat <$> many sublist
548+ return $ (lbuilder, plain parainls <> subls)
549+
550+ sublist :: PandocMonad m => ManParser m Blocks
551+ sublist = do
552+ mmacro KSubTab
553+ bl <- parseList
554+ mmacro KTabEnd
555+ return bl
556+
557+-- In case of weird man file it will be parsed succesfully
558+parseSkipMacro :: PandocMonad m => ManParser m Blocks
559+parseSkipMacro = mmacroAny >> mempty