@@ -35,6 +35,7 @@ module Text.Pandoc.Readers.Man (readMan) where
3535import Prelude
3636import Control.Monad.Except (throwError)
3737import Data.Default (Default)
38+import Data.Functor.Identity (Identity)
3839import Data.Map (insert)
3940import Data.Maybe (isJust, fromMaybe)
4041import Data.List (intersperse, intercalate)
@@ -46,11 +47,38 @@ import Text.Pandoc.Logging (LogMessage(..))
4647import Text.Pandoc.Options
4748import Text.Pandoc.Parsing
4849import Text.Pandoc.Shared (crFilter)
49−import Text.Parsec
50+import Text.Parsec hiding (tokenPrim)
5051import Text.Parsec.Char ()
52+import Text.Parsec.Pos (updatePosString)
53+
54+--
55+-- Data Types
56+--
5157
5258data FontKind = Regular | Italic | Bold | ItalicBold deriving Show
5359
60+data MacroKind = KTitle
61+ | KCodeBlStart
62+ | KCodeBlEnd
63+ | KTab
64+ | KTabEnd
65+ deriving Show
66+
67+data ManToken = MStr String FontKind
68+ | MLine [(String, FontKind)]
69+ | MLink String Target
70+ | MEmptyLine
71+ | MHeader Integer String
72+ | MMacro MacroKind [String]
73+ | MUnknownMacro String [String]
74+ | MComment String
75+ deriving Show
76+
77+data EscapeThing = EFont FontKind
78+ | EChar Char
79+ | ENothing
80+ deriving Show
81+
5482data RoffState = RoffState { inCodeBlock :: Bool
5583 , fontKind :: FontKind
5684 } deriving Show
@@ -60,48 +88,60 @@ instance Default RoffState where
6088
6189data ManState = ManState {pState :: ParserState, rState :: RoffState}
6290
91+type ManParser m = ParserT [Char] ManState m
92+type ManCompiler m = ParserT [ManToken] ManState m
93+
6394instance HasLogMessages ManState where
6495 addLogMessage lm mst = mst {pState = addLogMessage lm (pState mst)}
6596 getLogMessages mst = getLogMessages $ pState mst
6697
98+-- | Read man (troff) from an input string and return a Pandoc document.
99+readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
100+readMan opts txt = do
101+ let state = ManState { pState = def{ stateOptions = opts }, rState = def}
102+ parsed <- readWithM parseMan state (T.unpack $ crFilter txt)
103+ case parsed of
104+ Right result -> return result
105+ Left e -> throwError e
106+
107+--
108+-- String -> ManToken function
109+--
110+
111+parseMan :: PandocMonad m => ManParser m Pandoc
112+parseMan = do
113+ tokens <- many (parseMacro <|> parseLine <|> parseEmptyLine)
114+ let blocks = []
115+ parserst <- pState <$> getState
116+ return $ Pandoc (stateMeta parserst) blocks
117+
67118modifyRoffState :: PandocMonad m => (RoffState -> RoffState) -> ParsecT a ManState m ()
68119modifyRoffState f = do
69120 mst <- getState
70121 setState mst { rState = f $ rState mst }
71122
72−type ManParser m = ParserT [Char] ManState m
73−
74−parseMacro :: PandocMonad m => ManParser m Block
123+parseMacro :: PandocMonad m => ManParser m ManToken
75124parseMacro = do
76125 char '.' <|> char '\''
77126 many space
78127 macroName <- many1 (letter <|> oneOf ['\\', '"'])
79128 args <- parseArgs
80129 let joinedArgs = concat $ intersperse " " args
81− ManState { rState = rst } <- getState
82− let toTextF transf = if inCodeBlock rst then [Code nullAttr joinedArgs] else transf [Str joinedArgs]
83− let toText = return . Plain . toTextF
84− let toBold = toText (\s -> [Strong s])
85− let toItalic = toText (\s -> [Emph s])
86− let toBoldItalic = toText (\s -> [Strong [Emph s]])
87−
88− case macroName of
89− "\\\"" -> return Null -- comment
90− "TH" -> macroTitle (if null args then "" else head args) -- man-title
91− "TP" -> return Null -- tab-indented paragraph
92− "PP" -> return Null -- end of tab-indented paragraphs
93− "nf" -> macroCodeBlock True >> return Null
94− "fi" -> macroCodeBlock False >> return Null
95− "B" -> toBold
96− "BR" -> return $ macroBR joinedArgs (inCodeBlock rst)
97− "BI" -> toBoldItalic
98− "IB" -> toBoldItalic
99− "I" -> toItalic
100− "IR" -> toItalic
101− "RI" -> toItalic
102− "SH" -> return $ Header 2 nullAttr [Str joinedArgs]
103− "sp" -> return $ if inCodeBlock rst then Null else Plain [LineBreak]
104− _ -> unkownMacro macroName
130+
131+ let tok = case macroName of
132+ x | x `elem` ["\\\"", "\\#"] -> MComment joinedArgs
133+ "TH" -> MMacro KTitle args
134+ "TP" -> MMacro KTab []
135+ "PP" -> MMacro KTabEnd []
136+ "nf" -> MMacro KCodeBlStart []
137+ "fi" -> MMacro KCodeBlEnd []
138+ x | x `elem` ["B", "BR"] -> MStr joinedArgs Bold -- "BR" is often used as a link to another man
139+ x | x `elem` ["BI", "IB"] -> MStr joinedArgs ItalicBold
140+ x | x `elem` ["I", "IR", "RI"] -> MStr joinedArgs Italic
141+ "SH" -> MHeader 2 joinedArgs
142+ "sp" -> MEmptyLine
143+ _ -> MUnknownMacro macroName args
144+ return tok
105145
106146 where
107147
@@ -174,111 +214,115 @@ parseMacro = do
174214 quotedChar :: PandocMonad m => ManParser m Char
175215 quotedChar = noneOf "\"\n" <|> try (string "\"\"" >> return '"')
176216
177−roffInline :: RoffState -> String -> [Inline]
178−roffInline rst str
179− | null str && (not $ inCodeBlock rst) = []
180− | inCodeBlock rst = [Code nullAttr str]
181− | otherwise = case fontKind rst of
182− Regular -> [Str str]
183− Italic -> [Emph [Str str]]
184− Bold -> [Strong [Str str]]
185− ItalicBold -> [Emph [Strong [Str str]]]
186−
187−parseLine :: PandocMonad m => ManParser m Block
217+escapeParser :: PandocMonad m => ManParser m EscapeThing
218+escapeParser = do
219+ char '\\'
220+ choice [escChar, escFont]
221+ where
222+
223+ escChar :: PandocMonad m => ManParser m EscapeThing
224+ escChar = choice [ char '-' >> return (EChar '-')
225+ , oneOf ['%', '{', '}'] >> return ENothing
226+ ]
227+
228+ escFont :: PandocMonad m => ManParser m EscapeThing
229+ escFont = do
230+ char 'f'
231+ font <- choice [ char 'B' >> return Bold
232+ , char 'I' >> return Italic
233+ , (char 'P' <|> anyChar) >> return Regular
234+ , char '(' >> anyChar >> anyChar >> return Regular
235+ , string "[]" >> return Regular
236+ , char '[' >> many1 letter >> char ']' >> return Regular
237+ ]
238+ modifyRoffState (\r -> RoffState {fontKind = font})
239+ return $ EFont font
240+
241+parseLine :: PandocMonad m => ManParser m ManToken
188242parseLine = do
189− parts <- parseLineParts
190− newline
191− return $ if null parts
192− then Null
193− else Plain parts
243+ lnparts <- many1 (esc <|> linePart)
244+ return $ MLine lnparts
194245 where
195− parseLineParts :: PandocMonad m => ManParser m [Inline]
196− parseLineParts = do
197− lnpart <- many $ noneOf "\n\\"
198− ManState {rState = roffSt} <- getState
199− let inls = roffInline roffSt lnpart
200− others <- backSlash <|> return []
201− return $ inls ++ others
246+
247+ esc :: PandocMonad m => ManParser m (String, FontKind)
248+ esc = do
249+ someesc <- escapeParser
250+ font <- currentFont
251+ let rv = case someesc of
252+ EChar c -> ([c], font)
253+ _ -> ("", font)
254+ return rv
255+
256+ linePart :: PandocMonad m => ManParser m (String, FontKind)
257+ linePart = do
258+ lnpart <- many1 $ noneOf "\n\\"
259+ font <- currentFont
260+ return (lnpart, font)
261+
262+ currentFont :: PandocMonad m => ManParser m FontKind
263+ currentFont = do
264+ RoffState {fontKind = fk} <- rState <$> getState
265+ return fk
266+
202267
203− backSlash :: PandocMonad m => ManParser m [Inline]
204− backSlash = do
205− char '\\'
206− esc <- choice [ char 'f' >> fEscape
207− , char '-' >> return (Just '-')
208− , char '%' >> return Nothing
209− , Just <$> noneOf "\n"
210− ]
211− ManState {rState = roffSt} <- getState
212− case esc of
213− Just c -> let inls = roffInline roffSt [c]
214− in parseLineParts >>= (\oth -> return $ inls ++ oth)
215− Nothing -> parseLineParts
216− where
217−
218− fEscape :: PandocMonad m => ManParser m (Maybe Char)
219− fEscape = choice [ char 'B' >> modifyRoffState (\rst -> rst {fontKind = Bold})
220− , char 'I' >> modifyRoffState (\rst -> rst {fontKind = Italic})
221− , (char 'P' <|> anyChar) >> modifyRoffState (\rst -> rst {fontKind = Regular})
222− ]
223− >> return Nothing
224−
225−finds :: (a -> Bool) -> [a] -> ([a], [a])
226−finds predic els = let matched = finds' els
227− in (matched, drop (length matched) els) where
228− finds' [] = []
229− finds' (e:es) | predic e = e : finds' es
230− | otherwise = []
231−
232−-- | return (matched, notmatched, others)
233−findsBoth :: (a -> Bool) -> [a] -> ([a], [a], [a])
234−findsBoth predic els =
235− let (matched, els') = finds predic els
236− (notmatched, els'') = finds (not . predic) els'
237− in (matched, notmatched, els'')
238−
239−createParas :: [Block] -> [Block]
240−createParas bs = inner bs [] where
241− inner :: [Block] -> [Inline] -> [Block]
242− inner [] inls = plainInlinesToPara inls
243− inner (Plain einls : oth) inls = inner oth (inls ++ joinCode einls)
244− inner (block : oth) inls = (plainInlinesToPara inls ++ [block]) ++ inner oth []
245−
246− joinCode :: [Inline] -> [Inline]
247− joinCode inls =
248− let (codes, notcodes) = finds isCode inls
249− codeStr (Code _ s) = s
250− codeStr _ = ""
251− joined = Code nullAttr (concat $ codeStr <$> codes)
252− in if null codes
253− then notcodes
254− else joined : notcodes
255−
256− plainInlinesToPara :: [Inline] -> [Block]
257− plainInlinesToPara [] = []
258− plainInlinesToPara inls =
259− let (cds, ncds, oth) = findsBoth isCode inls
260− codeToStr (Code _ s) = s
261− codeToStr _ = ""
262− cbs = if null cds
263− then []
264− else [CodeBlock nullAttr (intercalate "\n" $ codeToStr <$> cds)]
265− paras = [Para (intersperse (Str " ") ncds)]
266− in cbs ++ paras ++ plainInlinesToPara oth
267−
268− isCode (Code _ _) = True
269− isCode _ = False
268+parseEmptyLine :: PandocMonad m => ManParser m ManToken
269+parseEmptyLine = char '\n' >> return MEmptyLine
270270
271−parseMan :: PandocMonad m => ManParser m Pandoc
272−parseMan = do
273− blocks <- createParas <$> many (parseMacro <|> parseLine)
274− parserst <- pState <$> getState
275− return $ Pandoc (stateMeta parserst) blocks
271+--
272+-- ManToken parsec functions
273+--
274+
275+msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t
276+msatisfy pred = tokenPrim show nextPos testTok
277+ where
278+ posFromTok (pos,t) = pos
279+ testTok t = if pred t then Just t else Nothing
280+ nextPos pos x xs = updatePosString pos (show x)
281+
282+mstr :: PandocMonad m => ManCompiler m ManToken
283+mstr = msatisfy isMStr where
284+ isMStr (MStr _ _) = True
285+ isMStr _ = False
286+
287+mline :: PandocMonad m => ManCompiler m ManToken
288+mline = msatisfy isMLine where
289+ isMLine (MLine _) = True
290+ isMLine _ = False
291+
292+mlink :: PandocMonad m => ManCompiler m ManToken
293+mlink = msatisfy isMLink where
294+ isMLink (MLink _ _) = True
295+ isMLink _ = False
296+
297+memplyLine :: PandocMonad m => ManCompiler m ManToken
298+memplyLine = msatisfy isMEmptyLine where
299+ isMEmptyLine MEmptyLine = True
300+ isMEmptyLine _ = False
301+
302+mheader :: PandocMonad m => ManCompiler m ManToken
303+mheader = msatisfy isMHeader where
304+ isMHeader (MHeader _ _) = True
305+ isMHeader _ = False
306+
307+mmacro :: PandocMonad m => ManCompiler m ManToken
308+mmacro = msatisfy isMMacro where
309+ isMMacro (MMacro _ _) = True
310+ isMMacro _ = False
311+
312+munknownMacro :: PandocMonad m => ManCompiler m ManToken
313+munknownMacro = msatisfy isMUnknownMacro where
314+ isMUnknownMacro (MUnknownMacro _ _) = True
315+ isMUnknownMacro _ = False
316+
317+mcomment :: PandocMonad m => ManCompiler m ManToken
318+mcomment = msatisfy isMComment where
319+ isMComment (MComment _) = True
320+ isMComment _ = False
321+
322+--
323+-- ManToken -> Block functions
324+--
325+
326+compileHeader :: PandocMonad m => ManCompiler m Block
327+compileHeader = undefined --do
276328
277−-- | Read man (troff) from an input string and return a Pandoc document.
278−readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
279−readMan opts txt = do
280− let state = ManState { pState = def{ stateOptions = opts }, rState = def}
281− parsed <- readWithM parseMan state (T.unpack $ crFilter txt)
282− case parsed of
283− Right result -> return result
284− Left e -> throwError e