@@ -18,8 +18,6 @@ You should have received a copy of the GNU General Public License
1818along with this program; if not, write to the Free Software
1919Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2020
21−
22−
2321-}
2422
2523{- |
@@ -36,76 +34,25 @@ Conversion of man to 'Pandoc' document.
3634module Text.Pandoc.Readers.Man (readMan) where
3735
3836import Prelude
39−import Control.Monad (liftM, void, mzero, guard, when)
40−import Control.Monad.Except (throwError)
41−import Text.Pandoc.Class
42− (getResourcePath, readFileFromDirs, PandocMonad(..), report)
43−import Data.Char (isHexDigit, chr, ord, isAscii, isAlphaNum, isSpace)
4437import Data.Default (Default)
38+import Control.Monad (liftM, mzero, guard)
39+import Control.Monad.Except (throwError)
40+import Text.Pandoc.Class (PandocMonad(..), report)
4541import Data.Maybe (catMaybes)
46−import qualified Data.Map as M
47−import Data.Set (Set)
4842import qualified Data.Set as S
49−import Data.List (intersperse, intercalate, isSuffixOf)
43+import Data.List (intersperse, intercalate)
5044import qualified Data.Text as T
5145import Text.Pandoc.Builder as B
5246import Text.Pandoc.Error (PandocError (PandocParsecError))
5347import Text.Pandoc.Logging (LogMessage(..))
5448import Text.Pandoc.Options
5549import Text.Pandoc.Parsing
56−import Text.Pandoc.Shared (crFilter, safeRead)
50+import Text.Pandoc.Shared (crFilter)
51+import Text.Pandoc.Readers.Groff -- TODO explicit imports
5752import Text.Parsec hiding (tokenPrim)
5853import qualified Text.Parsec as Parsec
5954import Text.Parsec.Pos (updatePosString)
60−import Text.Pandoc.GroffChar (characterCodes, combiningAccents)
61−import qualified Data.Sequence as Seq
6255import qualified Data.Foldable as Foldable
63−import qualified Data.Text.Normalize as Normalize
64−
65−-- import Debug.Trace (traceShowId)
66−
67−--
68−-- Data Types
69−--
70−data FontKind = Bold | Italic | Monospace | Regular deriving (Show, Eq, Ord)
71−
72−type MacroKind = String
73−
74−type Font = Set FontKind
75−
76−data LinePart = RoffStr (String, Font)
77− | MacroArg Int
78− deriving Show
79−
80−type Arg = [LinePart]
81−
82−-- TODO parse tables (see man tbl)
83−data ManToken = MLine [LinePart]
84− | MEmptyLine
85− | MMacro MacroKind [Arg] SourcePos
86− | MTable [Alignment] ManTokens [ManTokens] [[ManTokens]]
87− deriving Show
88−
89−newtype ManTokens = ManTokens { unManTokens :: Seq.Seq ManToken }
90− deriving (Show, Semigroup, Monoid)
91−
92−singleTok :: ManToken -> ManTokens
93−singleTok t = ManTokens (Seq.singleton t)
94−
95−data RoffState = RoffState { fontKind :: Font
96− , customMacros :: M.Map String ManTokens
97− } deriving Show
98−
99−instance Default RoffState where
100− def = RoffState { customMacros = M.fromList
101− $ map (\(n, s) ->
102− (n, singleTok
103− (MLine [RoffStr (s, mempty)])))
104− [ ("Tm", "\x2122")
105− , ("lq", "\x201C")
106− , ("rq", "\x201D")
107− , ("R", "\x00AE") ]
108− , fontKind = S.singleton Regular }
10956
11057data ManState = ManState { readerOptions :: ReaderOptions
11158 , metadata :: Meta
@@ -115,7 +62,6 @@ instance Default ManState where
11562 def = ManState { readerOptions = def
11663 , metadata = nullMeta }
11764
118−type ManLexer m = ParserT [Char] RoffState m
11965type ManParser m = ParserT [ManToken] ManState m
12066
12167
@@ -147,405 +93,6 @@ readMan opts txt = do
14793 mapLeft f (Left x) = Left $ f x
14894 mapLeft _ (Right r) = Right r
14995
150−--
151−-- Lexer: String -> ManToken
152−--
153−
154−eofline :: Stream s m Char => ParsecT s u m ()
155−eofline = void newline <|> eof
156−
157−spacetab :: Stream s m Char => ParsecT s u m Char
158−spacetab = char ' ' <|> char '\t'
159−
160−characterCodeMap :: M.Map String Char
161−characterCodeMap =
162− M.fromList $ map (\(x,y) -> (y,x)) characterCodes
163−
164−combiningAccentsMap :: M.Map String Char
165−combiningAccentsMap =
166− M.fromList $ map (\(x,y) -> (y,x)) combiningAccents
167−
168−escapeLexer :: PandocMonad m => ManLexer m String
169−escapeLexer = try $ do
170− char '\\'
171− c <- noneOf ['*','$'] -- see escStar, macroArg
172− case c of
173− '(' -> twoCharGlyph
174− '[' -> bracketedGlyph
175− 'f' -> escFont
176− 's' -> escFontSize
177− '"' -> mempty <$ skipMany (satisfy (/='\n')) -- line comment
178− '#' -> mempty <$ manyTill anyChar newline
179− '%' -> return mempty
180− '{' -> return mempty
181− '}' -> return mempty
182− '&' -> return mempty
183− '\n' -> return mempty
184− ':' -> return mempty
185− '0' -> return mempty
186− 'c' -> return mempty
187− '-' -> return "-"
188− '_' -> return "_"
189− ' ' -> return " "
190− '\\' -> return "\\"
191− 't' -> return "\t"
192− 'e' -> return "\\"
193− '`' -> return "`"
194− '^' -> return " "
195− '|' -> return " "
196− '\'' -> return "`"
197− '.' -> return "`"
198− '~' -> return "\160" -- nonbreaking space
199− _ -> escUnknown ['\\',c] "\xFFFD"
200−
201− where
202−
203− twoCharGlyph = do
204− cs <- count 2 anyChar
205− case M.lookup cs characterCodeMap of
206− Just c -> return [c]
207− Nothing -> escUnknown ('\\':'(':cs) "\xFFFD"
208−
209− bracketedGlyph = unicodeGlyph <|> charGlyph
210−
211− charGlyph = do
212− cs <- manyTill (noneOf ['[',']','\n']) (char ']')
213− (case words cs of
214− [] -> mzero
215− [s] -> case M.lookup s characterCodeMap of
216− Nothing -> mzero
217− Just c -> return [c]
218− (s:ss) -> do
219− basechar <- case M.lookup cs characterCodeMap of
220− Nothing ->
221− case s of
222− [ch] | isAscii ch && isAlphaNum ch ->
223− return ch
224− _ -> mzero
225− Just c -> return c
226− let addAccents [] xs = return $ T.unpack .
227− Normalize.normalize Normalize.NFC .
228− T.pack $ reverse xs
229− addAccents (a:as) xs =
230− case M.lookup a combiningAccentsMap of
231− Just x -> addAccents as (x:xs)
232− Nothing -> mzero
233− addAccents ss [basechar])
234− <|> escUnknown ("\\[" ++ cs ++ "]") "\xFFFD"
235−
236− unicodeGlyph = try $ ucharCode `sepBy1` (char '_') <* char ']'
237−
238− ucharCode = try $ do
239− char 'u'
240− cs <- many1 (satisfy isHexDigit)
241− let lcs = length cs
242− guard $ lcs >= 4 && lcs <= 6
243− case chr <$> safeRead ('0':'x':cs) of
244− Nothing -> mzero
245− Just c -> return c
246−
247− -- \s-1 \s0 -- we ignore these
248− escFontSize :: PandocMonad m => ManLexer m String
249− escFontSize = do
250− pos <- getPosition
251− pm <- option "" $ count 1 (oneOf "+-")
252− ds <- many1 digit
253− report $ SkippedContent ("\\s" ++ pm ++ ds) pos
254− return mempty
255−
256− escFont :: PandocMonad m => ManLexer m String
257− escFont = do
258− font <- choice
259− [ S.singleton <$> letterFontKind
260− , char '(' >> anyChar >> anyChar >> return (S.singleton Regular)
261− , char 'S' >> return (S.singleton Regular)
262− , try lettersFont
263− , digit >> return (S.singleton Regular)
264− ]
265− modifyState (\r -> r {fontKind = font})
266− return mempty
267−
268− lettersFont :: PandocMonad m => ManLexer m Font
269− lettersFont = do
270− char '['
271− fs <- many letterFontKind
272− skipMany letter
273− char ']'
274− return $ S.fromList fs
275−
276− letterFontKind :: PandocMonad m => ManLexer m FontKind
277− letterFontKind = choice [
278− oneOf ['B','b'] >> return Bold
279− , oneOf ['I','i'] >> return Italic
280− , oneOf ['C','c'] >> return Monospace
281− , oneOf ['P','p','R','r'] >> return Regular
282− ]
283−
284− escUnknown :: PandocMonad m => String -> a -> ManLexer m a
285− escUnknown s x = do
286− pos <- getPosition
287− report $ SkippedContent ("Unknown escape sequence " ++ s) pos
288− return x
289−
290−currentFont :: PandocMonad m => ManLexer m Font
291−currentFont = fontKind <$> getState
292−
293−-- separate function from lexMacro since real man files sometimes do not follow the rules
294−lexComment :: PandocMonad m => ManLexer m ManTokens
295−lexComment = do
296− try $ string ".\\\""
297− many Parsec.space
298− skipMany $ noneOf "\n"
299− char '\n'
300− return mempty
301−
302−lexMacro :: PandocMonad m => ManLexer m ManTokens
303−lexMacro = do
304− pos <- getPosition
305− char '.' <|> char '\''
306− many spacetab
307− macroName <- many (satisfy (not . isSpace))
308− case macroName of
309− "nop" -> return mempty
310− "ie" -> lexConditional
311− "if" -> lexConditional
312− "el" -> skipConditional
313− "TS" -> lexTable
314−
315− _ -> do
316− args <- lexArgs
317− case macroName of
318− "" -> return mempty
319− "\\\"" -> return mempty
320− "\\#" -> return mempty
321− "de" -> lexMacroDef args
322− "de1" -> lexMacroDef args
323− "ds" -> lexStringDef args
324− "ds1" -> lexStringDef args
325− "sp" -> return $ singleTok MEmptyLine
326− "so" -> lexIncludeFile args
327− _ -> resolveMacro macroName args pos
328−
329−-- | TODO placeholder
330−lexTable :: PandocMonad m => ManLexer m ManTokens
331−lexTable = do
332− pos <- getPosition
333− manyTill anyLine (try (string ".TE" >> many spacetab >> eofline))
334− report $ SkippedContent "table" pos
335− return mempty
336−
337−-- We don't fully handle the conditional. But we do
338−-- include everything under '.ie n', which occurs commonly
339−-- in man pages. We always skip the '.el' part.
340−lexConditional :: PandocMonad m => ManLexer m ManTokens
341−lexConditional = do
342− skipMany spacetab
343− parseNCond <|> skipConditional
344−
345−-- n means nroff mode
346−parseNCond :: PandocMonad m => ManLexer m ManTokens
347−parseNCond = do
348− char '\n'
349− many1 spacetab
350− lexGroup <|> manToken
351−
352−lexGroup :: PandocMonad m => ManLexer m ManTokens
353−lexGroup = do
354− groupstart
355− mconcat <$> manyTill manToken groupend
356− where
357− groupstart = try $ string "\\{\\" >> newline
358− groupend = try $ string "\\}" >> eofline
359−
360−skipConditional :: PandocMonad m => ManLexer m ManTokens
361−skipConditional = do
362− rest <- anyLine
363− when ("\\{\\" `isSuffixOf` rest) $
364− void $ manyTill anyChar (try (string "\\}"))
365− return mempty
366−
367−lexIncludeFile :: PandocMonad m => [Arg] -> ManLexer m ManTokens
368−lexIncludeFile args = do
369− pos <- getPosition
370− case args of
371− (f:_) -> do
372− let fp = linePartsToString f
373− dirs <- getResourcePath
374− result <- readFileFromDirs dirs fp
375− case result of
376− Nothing -> report $ CouldNotLoadIncludeFile fp pos
377− Just s -> getInput >>= setInput . (s ++)
378− return mempty
379− [] -> return mempty
380−
381−resolveMacro :: PandocMonad m
382− => String -> [Arg] -> SourcePos -> ManLexer m ManTokens
383−resolveMacro macroName args pos = do
384− macros <- customMacros <$> getState
385− case M.lookup macroName macros of
386− Nothing -> return $ singleTok $ MMacro macroName args pos
387− Just ts -> do
388− let fillLP (RoffStr (x,y)) zs = RoffStr (x,y) : zs
389− fillLP (MacroArg i) zs =
390− case drop (i - 1) args of
391− [] -> zs
392− (ys:_) -> ys ++ zs
393− let fillMacroArg (MLine lineparts) =
394− MLine (foldr fillLP [] lineparts)
395− fillMacroArg x = x
396− return $ ManTokens . fmap fillMacroArg . unManTokens $ ts
397−
398−lexStringDef :: PandocMonad m => [Arg] -> ManLexer m ManTokens
399−lexStringDef args = do -- string definition
400− case args of
401− [] -> fail "No argument to .ds"
402− (x:ys) -> do
403− let ts = singleTok $ MLine (intercalate [RoffStr (" ", mempty)] ys)
404− let stringName = linePartsToString x
405− modifyState $ \st ->
406− st{ customMacros = M.insert stringName ts (customMacros st) }
407− return mempty
408−
409−lexMacroDef :: PandocMonad m => [Arg] -> ManLexer m ManTokens
410−lexMacroDef args = do -- macro definition
411− (macroName, stopMacro) <-
412− case args of
413− (x : y : _) -> return (linePartsToString x, linePartsToString y)
414− -- optional second arg
415− (x:_) -> return (linePartsToString x, ".")
416− [] -> fail "No argument to .de"
417− let stop = try $ do
418− char '.' <|> char '\''
419− many spacetab
420− string stopMacro
421− _ <- lexArgs
422− return ()
423− ts <- mconcat <$> manyTill manToken stop
424− modifyState $ \st ->
425− st{ customMacros = M.insert macroName ts (customMacros st) }
426− return mempty
427−
428−lexArgs :: PandocMonad m => ManLexer m [Arg]
429−lexArgs = do
430− args <- many $ try oneArg
431− skipMany spacetab
432− eofline
433− return args
434−
435− where
436−
437− oneArg :: PandocMonad m => ManLexer m [LinePart]
438− oneArg = do
439− skipMany $ try $ string "\\\n" -- continuation line
440− try quotedArg <|> plainArg
441− -- try, because there are some erroneous files, e.g. linux/bpf.2
442−
443− plainArg :: PandocMonad m => ManLexer m [LinePart]
444− plainArg = do
445− skipMany spacetab
446− mconcat <$> many1
447− (macroArg <|> esc <|> regularText <|> unescapedQuote <|> escStar)
448− where
449− unescapedQuote = do
450− char '"'
451− fonts <- currentFont
452− return [RoffStr ("\"", fonts)]
453−
454−
455− quotedArg :: PandocMonad m => ManLexer m [LinePart]
456− quotedArg = do
457− skipMany spacetab
458− char '"'
459− xs <- mconcat <$>
460− many (macroArg <|> esc <|> escStar <|> regularText
461− <|> spaceTabChar <|> escapedQuote)
462− char '"'
463− return xs
464− where
465− escapedQuote = try $ do
466− char '"'
467− char '"'
468− fonts <- currentFont
469− return [RoffStr ("\"", fonts)]
470−
471−escStar :: PandocMonad m => ManLexer m [LinePart]
472−escStar = try $ do
473− pos <- getPosition
474− char '\\'
475− char '*'
476− c <- anyChar
477− case c of
478− '(' -> do
479− cs <- count 2 anyChar
480− resolveString cs pos
481− '[' -> do
482− cs <- many (noneOf "\t\n\r ]")
483− char ']'
484− resolveString cs pos
485− 'S' -> return mempty -- switch back to default font size
486− _ -> resolveString [c] pos
487−
488− where
489−
490− -- strings and macros share namespace
491− resolveString stringname pos = do
492− ManTokens ts <- resolveMacro stringname [] pos
493− case Foldable.toList ts of
494− [MLine xs] -> return xs
495− _ -> do
496− report $ SkippedContent ("unknown string " ++ stringname) pos
497− return mempty
498−
499−lexLine :: PandocMonad m => ManLexer m ManTokens
500−lexLine = do
501− lnparts <- mconcat <$> many1 linePart
502− eofline
503− go lnparts
504− where -- return empty line if we only have empty strings;
505− -- this can happen if the line just contains \f[C], for example.
506− go [] = return mempty
507− go (RoffStr ("",_):xs) = go xs
508− go xs = return $ singleTok $ MLine xs
509−
510−linePart :: PandocMonad m => ManLexer m [LinePart]
511−linePart = macroArg <|> esc <|> escStar <|>
512− regularText <|> quoteChar <|> spaceTabChar
513−
514−macroArg :: PandocMonad m => ManLexer m [LinePart]
515−macroArg = try $ do
516− string "\\\\$"
517− x <- digit
518− return [MacroArg $ ord x - ord '0']
519−
520−esc :: PandocMonad m => ManLexer m [LinePart]
521−esc = do
522− s <- escapeLexer
523− font <- currentFont
524− return [RoffStr (s, font)]
525−
526−regularText :: PandocMonad m => ManLexer m [LinePart]
527−regularText = do
528− s <- many1 $ noneOf "\n\r\t \\\""
529− font <- currentFont
530− return [RoffStr (s, font)]
531−
532−quoteChar :: PandocMonad m => ManLexer m [LinePart]
533−quoteChar = do
534− char '"'
535− font <- currentFont
536− return [RoffStr ("\"", font)]
537−
538−spaceTabChar :: PandocMonad m => ManLexer m [LinePart]
539−spaceTabChar = do
540− c <- spacetab
541− font <- currentFont
542− return [RoffStr ([c], font)]
543−
544−lexEmptyLine :: PandocMonad m => ManLexer m ManTokens
545−lexEmptyLine = char '\n' >> return (singleTok MEmptyLine)
546−
547−manToken :: PandocMonad m => ManLexer m ManTokens
548−manToken = lexComment <|> lexMacro <|> lexLine <|> lexEmptyLine
54996
55097parseMan :: PandocMonad m => ManParser m Pandoc
55198parseMan = do
@@ -656,12 +203,6 @@ linePartsToInlines = go
656203 isItalic (RoffStr (_,f)) = Italic `S.member` f
657204 isItalic _ = False
658205
659−linePartsToString :: [LinePart] -> String
660−linePartsToString = mconcat . map go
661− where
662− go (RoffStr (s, _)) = s
663− go _ = mempty
664−
665206parsePara :: PandocMonad m => ManParser m Blocks
666207parsePara = para . trimInlines <$> parseInlines
667208