@@ -33,7 +33,6 @@ Tokenizer for groff formats (man, ms).
3333-}
3434module Text.Pandoc.Readers.Groff
3535 ( FontKind(..)
36− , Font
3736 , MacroKind
3837 , LinePart(..)
3938 , Arg
@@ -54,8 +53,6 @@ import Text.Pandoc.Class
5453import Data.Char (isHexDigit, chr, ord, isAscii, isAlphaNum, isSpace)
5554import Data.Default (Default)
5655import qualified Data.Map as M
57−import Data.Set (Set)
58−import qualified Data.Set as S
5956import Data.List (intercalate, isSuffixOf)
6057import qualified Data.Text as T
6158import Text.Pandoc.Builder as B
@@ -79,9 +76,9 @@ data FontKind = Bold | Italic | Monospace | Regular deriving (Show, Eq, Ord)
7976
8077type MacroKind = String
8178
82−type Font = Set FontKind
83−
84−data LinePart = RoffStr (String, Font)
79+data LinePart = RoffStr String
80+ | Font [FontKind]
81+ | FontSize Int
8582 | MacroArg Int
8683 deriving Show
8784
@@ -100,20 +97,19 @@ newtype ManTokens = ManTokens { unManTokens :: Seq.Seq ManToken }
10097singleTok :: ManToken -> ManTokens
10198singleTok t = ManTokens (Seq.singleton t)
10299
103−data RoffState = RoffState { fontKind :: Font
104− , customMacros :: M.Map String ManTokens
100+data RoffState = RoffState { customMacros :: M.Map String ManTokens
105101 } deriving Show
106102
107103instance Default RoffState where
108104 def = RoffState { customMacros = M.fromList
109105 $ map (\(n, s) ->
110106 (n, singleTok
111− (MLine [RoffStr (s, mempty)])))
107+ (MLine [RoffStr s])))
112108 [ ("Tm", "\x2122")
113109 , ("lq", "\x201C")
114110 , ("rq", "\x201D")
115111 , ("R", "\x00AE") ]
116− , fontKind = S.singleton Regular }
112+ }
117113
118114type ManLexer m = ParserT [Char] RoffState m
119115
@@ -135,15 +131,16 @@ combiningAccentsMap :: M.Map String Char
135131combiningAccentsMap =
136132 M.fromList $ map (\(x,y) -> (y,x)) combiningAccents
137133
138−escapeLexer :: PandocMonad m => ManLexer m String
139−escapeLexer = try $ do
134+escape :: PandocMonad m => ManLexer m [LinePart]
135+escape = do
140136 char '\\'
141− c <- noneOf ['*','$'] -- see escStar, macroArg
137+ c <- anyChar
142138 case c of
143− '(' -> twoCharGlyph
144− '[' -> bracketedGlyph
145139 'f' -> escFont
146140 's' -> escFontSize
141+ '*' -> escStar
142+ '(' -> twoCharGlyph
143+ '[' -> bracketedGlyph
147144 '"' -> mempty <$ skipMany (satisfy (/='\n')) -- line comment
148145 '#' -> mempty <$ manyTill anyChar newline
149146 '%' -> return mempty
@@ -154,27 +151,27 @@ escapeLexer = try $ do
154151 ':' -> return mempty
155152 '0' -> return mempty
156153 'c' -> return mempty
157− '-' -> return "-"
158− '_' -> return "_"
159− ' ' -> return " "
160− '\\' -> return "\\"
161− 't' -> return "\t"
162− 'e' -> return "\\"
163− '`' -> return "`"
164− '^' -> return " "
165− '|' -> return " "
166− '\'' -> return "`"
167− '.' -> return "`"
168− '~' -> return "\160" -- nonbreaking space
169− _ -> escUnknown ['\\',c] "\xFFFD"
154+ '-' -> return [RoffStr "-"]
155+ '_' -> return [RoffStr "_"]
156+ ' ' -> return [RoffStr " "]
157+ '\\' -> return [RoffStr "\\"]
158+ 't' -> return [RoffStr "\t"]
159+ 'e' -> return [RoffStr "\\"]
160+ '`' -> return [RoffStr "`"]
161+ '^' -> return [RoffStr " "]
162+ '|' -> return [RoffStr " "]
163+ '\'' -> return [RoffStr "`"]
164+ '.' -> return [RoffStr "`"]
165+ '~' -> return [RoffStr "\160"] -- nonbreaking space
166+ _ -> escUnknown ['\\',c]
170167
171168 where
172169
173170 twoCharGlyph = do
174171 cs <- count 2 anyChar
175172 case M.lookup cs characterCodeMap of
176− Just c -> return [c]
177− Nothing -> escUnknown ('\\':'(':cs) "\xFFFD"
173+ Just c -> return [RoffStr [c]]
174+ Nothing -> escUnknown ('\\':'(':cs)
178175
179176 bracketedGlyph = unicodeGlyph <|> charGlyph
180177
@@ -184,7 +181,7 @@ escapeLexer = try $ do
184181 [] -> mzero
185182 [s] -> case M.lookup s characterCodeMap of
186183 Nothing -> mzero
187− Just c -> return [c]
184+ Just c -> return [RoffStr [c]]
188185 (s:ss) -> do
189186 basechar <- case M.lookup cs characterCodeMap of
190187 Nothing ->
@@ -200,10 +197,12 @@ escapeLexer = try $ do
200197 case M.lookup a combiningAccentsMap of
201198 Just x -> addAccents as (x:xs)
202199 Nothing -> mzero
203− addAccents ss [basechar])
204− <|> escUnknown ("\\[" ++ cs ++ "]") "\xFFFD"
200+ addAccents ss [basechar] >>= \xs -> return [RoffStr xs])
201+ <|> escUnknown ("\\[" ++ cs ++ "]")
205202
206− unicodeGlyph = try $ ucharCode `sepBy1` (char '_') <* char ']'
203+ unicodeGlyph = try $ do
204+ xs <- ucharCode `sepBy1` (char '_') <* char ']'
205+ return [RoffStr xs]
207206
208207 ucharCode = try $ do
209208 char 'u'
@@ -214,53 +213,66 @@ escapeLexer = try $ do
214213 Nothing -> mzero
215214 Just c -> return c
216215
217− -- \s-1 \s0 -- we ignore these
218− escFontSize :: PandocMonad m => ManLexer m String
219− escFontSize = do
220− pos <- getPosition
221− pm <- option "" $ count 1 (oneOf "+-")
222− ds <- many1 digit
223− report $ SkippedContent ("\\s" ++ pm ++ ds) pos
224− return mempty
225−
226− escFont :: PandocMonad m => ManLexer m String
227− escFont = do
228− font <- choice
229− [ S.singleton <$> letterFontKind
230− , char '(' >> anyChar >> anyChar >> return (S.singleton Regular)
231− , char 'S' >> return (S.singleton Regular)
232− , try lettersFont
233− , digit >> return (S.singleton Regular)
234− ]
235− modifyState (\r -> r {fontKind = font})
236− return mempty
237−
238− lettersFont :: PandocMonad m => ManLexer m Font
239− lettersFont = do
240− char '['
241− fs <- many letterFontKind
242− skipMany letter
243− char ']'
244− return $ S.fromList fs
245−
246− letterFontKind :: PandocMonad m => ManLexer m FontKind
247− letterFontKind = choice [
248− oneOf ['B','b'] >> return Bold
249− , oneOf ['I','i'] >> return Italic
250− , oneOf ['C','c'] >> return Monospace
251− , oneOf ['P','p','R','r'] >> return Regular
252− ]
253−
254− escUnknown :: PandocMonad m => String -> a -> ManLexer m a
255− escUnknown s x = do
216+ escUnknown :: PandocMonad m => String -> ManLexer m [LinePart]
217+ escUnknown s = do
256218 pos <- getPosition
257219 report $ SkippedContent ("Unknown escape sequence " ++ s) pos
258− return x
259−
260−currentFont :: PandocMonad m => ManLexer m Font
261−currentFont = fontKind <$> getState
220+ return [RoffStr "\xFFFD"]
221+
222+-- \s-1 \s0
223+escFontSize :: PandocMonad m => ManLexer m [LinePart]
224+escFontSize = do
225+ let sign = option "" $ count 1 (oneOf "+-")
226+ let toFontSize xs =
227+ case safeRead xs of
228+ Nothing -> mzero
229+ Just n -> return [FontSize n]
230+ choice
231+ [ do char '('
232+ s <- sign
233+ ds <- count 2 digit
234+ toFontSize (s ++ ds)
235+ , do char '['
236+ s <- sign
237+ ds <- many1 digit
238+ char ']'
239+ toFontSize (s ++ ds)
240+ , do s <- sign
241+ ds <- count 1 digit
242+ toFontSize (s ++ ds)
243+ ]
262244
263−-- separate function from lexMacro since real man files sometimes do not follow the rules
245+escFont :: PandocMonad m => ManLexer m [LinePart]
246+escFont = do
247+ font <- choice
248+ [ char 'S' >> return [Regular]
249+ , digit >> return [Regular]
250+ , (:[]) <$> letterFontKind
251+ , char '(' >> anyChar >> anyChar >> return [Regular]
252+ , lettersFont
253+ , digit >> return [Regular]
254+ ]
255+ return [Font font]
256+
257+lettersFont :: PandocMonad m => ManLexer m [FontKind]
258+lettersFont = try $ do
259+ char '['
260+ fs <- many letterFontKind
261+ skipMany letter
262+ char ']'
263+ return fs
264+
265+letterFontKind :: PandocMonad m => ManLexer m FontKind
266+letterFontKind = choice [
267+ oneOf ['B','b'] >> return Bold
268+ , oneOf ['I','i'] >> return Italic
269+ , oneOf ['C','c'] >> return Monospace
270+ , oneOf ['P','p','R','r'] >> return Regular
271+ ]
272+
273+
274+-- separate function from lexMacro since real man files sometimes do not
275+-- follow the rules
264276lexComment :: PandocMonad m => ManLexer m ManTokens
265277lexComment = do
266278 try $ string ".\\\""
@@ -310,11 +322,11 @@ lexTable = do
310322lexConditional :: PandocMonad m => ManLexer m ManTokens
311323lexConditional = do
312324 skipMany spacetab
313− parseNCond <|> skipConditional
325+ lexNCond <|> skipConditional
314326
315327-- n means nroff mode
316−parseNCond :: PandocMonad m => ManLexer m ManTokens
317−parseNCond = do
328+lexNCond :: PandocMonad m => ManLexer m ManTokens
329+lexNCond = do
318330 char '\n'
319331 many1 spacetab
320332 lexGroup <|> manToken
@@ -355,11 +367,11 @@ resolveMacro macroName args pos = do
355367 case M.lookup macroName macros of
356368 Nothing -> return $ singleTok $ MMacro macroName args pos
357369 Just ts -> do
358− let fillLP (RoffStr (x,y)) zs = RoffStr (x,y) : zs
359− fillLP (MacroArg i) zs =
370+ let fillLP (MacroArg i) zs =
360371 case drop (i - 1) args of
361372 [] -> zs
362373 (ys:_) -> ys ++ zs
374+ fillLP z zs = z : zs
363375 let fillMacroArg (MLine lineparts) =
364376 MLine (foldr fillLP [] lineparts)
365377 fillMacroArg x = x
@@ -370,7 +382,7 @@ lexStringDef args = do -- string definition
370382 case args of
371383 [] -> fail "No argument to .ds"
372384 (x:ys) -> do
373− let ts = singleTok $ MLine (intercalate [RoffStr (" ", mempty)] ys)
385+ let ts = singleTok $ MLine (intercalate [RoffStr " " ] ys)
374386 let stringName = linePartsToString x
375387 modifyState $ \st ->
376388 st{ customMacros = M.insert stringName ts (customMacros st) }
@@ -413,21 +425,16 @@ lexArgs = do
413425 plainArg :: PandocMonad m => ManLexer m [LinePart]
414426 plainArg = do
415427 skipMany spacetab
416− mconcat <$> many1
417− (macroArg <|> esc <|> regularText <|> unescapedQuote <|> escStar)
428+ mconcat <$> many1 (macroArg <|> escape <|> regularText <|> unescapedQuote)
418429 where
419− unescapedQuote = do
420− char '"'
421− fonts <- currentFont
422− return [RoffStr ("\"", fonts)]
423−
430+ unescapedQuote = char '"' >> return [RoffStr "\""]
424431
425432 quotedArg :: PandocMonad m => ManLexer m [LinePart]
426433 quotedArg = do
427434 skipMany spacetab
428435 char '"'
429436 xs <- mconcat <$>
430− many (macroArg <|> esc <|> escStar <|> regularText
437+ many (macroArg <|> escape <|> regularText
431438 <|> spaceTabChar <|> escapedQuote)
432439 char '"'
433440 return xs
@@ -435,14 +442,11 @@ lexArgs = do
435442 escapedQuote = try $ do
436443 char '"'
437444 char '"'
438− fonts <- currentFont
439− return [RoffStr ("\"", fonts)]
445+ return [RoffStr "\""]
440446
441447escStar :: PandocMonad m => ManLexer m [LinePart]
442448escStar = try $ do
443449 pos <- getPosition
444− char '\\'
445− char '*'
446450 c <- anyChar
447451 case c of
448452 '(' -> do
@@ -474,11 +478,11 @@ lexLine = do
474478 where -- return empty line if we only have empty strings;
475479 -- this can happen if the line just contains \f[C], for example.
476480 go [] = return mempty
477− go (RoffStr ("",_):xs) = go xs
481+ go (RoffStr "" : xs) = go xs
478482 go xs = return $ singleTok $ MLine xs
479483
480484linePart :: PandocMonad m => ManLexer m [LinePart]
481−linePart = macroArg <|> esc <|> escStar <|>
485+linePart = macroArg <|> escape <|>
482486 regularText <|> quoteChar <|> spaceTabChar
483487
484488macroArg :: PandocMonad m => ManLexer m [LinePart]
@@ -487,29 +491,20 @@ macroArg = try $ do
487491 x <- digit
488492 return [MacroArg $ ord x - ord '0']
489493
490−esc :: PandocMonad m => ManLexer m [LinePart]
491−esc = do
492− s <- escapeLexer
493− font <- currentFont
494− return [RoffStr (s, font)]
495−
496494regularText :: PandocMonad m => ManLexer m [LinePart]
497495regularText = do
498496 s <- many1 $ noneOf "\n\r\t \\\""
499− font <- currentFont
500− return [RoffStr (s, font)]
497+ return [RoffStr s]
501498
502499quoteChar :: PandocMonad m => ManLexer m [LinePart]
503500quoteChar = do
504501 char '"'
505− font <- currentFont
506− return [RoffStr ("\"", font)]
502+ return [RoffStr "\""]
507503
508504spaceTabChar :: PandocMonad m => ManLexer m [LinePart]
509505spaceTabChar = do
510506 c <- spacetab
511− font <- currentFont
512− return [RoffStr ([c], font)]
507+ return [RoffStr [c]]
513508
514509lexEmptyLine :: PandocMonad m => ManLexer m ManTokens
515510lexEmptyLine = char '\n' >> return (singleTok MEmptyLine)
@@ -520,5 +515,5 @@ manToken = lexComment <|> lexMacro <|> lexLine <|> lexEmptyLine
520515linePartsToString :: [LinePart] -> String
521516linePartsToString = mconcat . map go
522517 where
523− go (RoffStr (s, _)) = s
518+ go (RoffStr s) = s
524519 go _ = mempty