@@ -34,27 +34,27 @@ Conversion of man to 'Pandoc' document.
3434module Text.Pandoc.Readers.Man (readMan) where
3535
3636import Prelude
37−import Control.Monad (liftM, void)
37+import Control.Monad (liftM, void, mzero)
3838import Control.Monad.Except (throwError)
39−import Data.Char (isDigit, isUpper, isLower)
39+import Data.Char (isHexDigit, chr)
4040import Data.Default (Default)
41−import Data.Map (insert)
41+import Data.Maybe (catMaybes)
42+import qualified Data.Map as M
4243import Data.Set (Set, singleton)
4344import qualified Data.Set as S (fromList, toList)
44−import Data.Maybe (catMaybes, fromMaybe, isNothing)
4545import Data.List (intersperse, intercalate)
4646import qualified Data.Text as T
47−
48−import Text.Pandoc.Class (PandocMonad(..))
47+import Text.Pandoc.Class (PandocMonad(..), report)
4948import Text.Pandoc.Builder as B hiding (singleton)
5049import Text.Pandoc.Error (PandocError (PandocParsecError))
5150import Text.Pandoc.Logging (LogMessage(..))
5251import Text.Pandoc.Options
5352import Text.Pandoc.Parsing
54−import Text.Pandoc.Shared (crFilter)
53+import Text.Pandoc.Shared (crFilter, safeRead)
5554import Text.Parsec hiding (tokenPrim, space)
5655import qualified Text.Parsec as Parsec
5756import Text.Parsec.Pos (updatePosString)
57+import Text.Pandoc.GroffChar (characterCodes, combiningAccents)
5858
5959--
6060-- Data Types
@@ -84,11 +84,6 @@ data ManToken = MStr RoffStr
8484 | MComment String
8585 deriving Show
8686
87−data EscapeThing = EFont Font
88− | EChar Char
89− | ENothing
90− deriving Show
91−
9287data RoffState = RoffState { fontKind :: Font
9388 } deriving Show
9489
@@ -113,7 +108,7 @@ testStr str = do
113108 pand <- runIOorExplode $ readMan def (T.pack str)
114109 putStrLn $ printPandoc pand
115110
116−
111+
117112testFile :: FilePath -> IO ()
118113testFile fname = do
119114 cont <- readFile fname
@@ -170,31 +165,81 @@ eofline = void newline <|> eof
170165spacetab :: Stream s m Char => ParsecT s u m Char
171166spacetab = char ' ' <|> char '\t'
172167
173−-- TODO add other sequences from man (7) groff
174−escapeLexer :: PandocMonad m => ManLexer m EscapeThing
168+characterCodeMap :: M.Map String Char
169+characterCodeMap =
170+ M.fromList $ map (\(x,y) -> (y,x)) $ characterCodes ++ combiningAccents
171+
172+escapeLexer :: PandocMonad m => ManLexer m String
175173escapeLexer = do
176174 char '\\'
177− choice [escChar, escFont, escUnknown]
175+ twoCharGlyph <|> bracketedGlyph <|> escFont <|> escStar <|> escSingle
178176 where
179177
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
178+ twoCharGlyph = do
179+ char '('
180+ cs <- count 2 anyChar
181+ case M.lookup cs characterCodeMap of
182+ Just c -> return [c]
183+ Nothing -> escUnknown ('(':cs)
184+
185+ bracketedGlyph =
186+ char '[' *>
187+ ( ucharCode `sepBy1` (char '_')
188+ <|> charCode `sepBy1` (many1 Parsec.space)
189+ ) <* char ']'
190+
191+ ucharCode = do
192+ char 'u'
193+ cs <- many1 (satisfy isHexDigit)
194+ case chr <$> safeRead ('0':'x':cs) of
195+ Nothing -> mzero
196+ Just c -> return c
197+
198+ charCode = do
199+ cs <- many1 (noneOf ['[',']',' ','\t','\n'])
200+ case M.lookup cs characterCodeMap of
201+ Nothing -> mzero
202+ Just c -> return c
203+
204+ escStar = do
205+ char '*'
206+ choice
207+ [ ("\xae" <$ char 'R')
208+ , ("" <$ char 'S') -- switch back to default font size
209+ , ("\x201c" <$ try (string "(lq"))
210+ , ("\x201d" <$ try (string "(rq"))
211+ , ("" <$ try (string "(HF" >>
212+ modifyState (\r -> r {fontKind = singleton Bold})))
213+ , ("\x2122" <$ try (string "(Tm"))
214+ ]
215+
216+ escSingle = do
217+ c <- anyChar
218+ case c of
219+ '"' -> mempty <$ manyTill anyChar newline -- line comment
220+ '#' -> mempty <$ (manyTill anyChar newline >> optional newline)
221+ '%' -> return mempty
222+ '{' -> return mempty
223+ '}' -> return mempty
224+ '&' -> return mempty
225+ '\n' -> return mempty
226+ ':' -> return mempty
227+ '0' -> return mempty
228+ 'c' -> return mempty
229+ '-' -> return "-"
230+ '_' -> return "_"
231+ ' ' -> return " "
232+ '\\' -> return "\\"
233+ 't' -> return "\t"
234+ 'e' -> return "\\"
235+ '`' -> return "`"
236+ '^' -> return " "
237+ '|' -> return " "
238+ '\'' -> return "`"
239+ '.' -> return "`"
240+ _ -> escUnknown [c]
241+
242+ escFont :: PandocMonad m => ManLexer m String
198243 escFont = do
199244 char 'f'
200245 font <- choice [ singleton <$> letterFontKind
@@ -203,32 +248,29 @@ escapeLexer = do
203248 , digit >> return (singleton Regular)
204249 ]
205250 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
251+ return mempty
252+
253+ lettersFont :: PandocMonad m => ManLexer m Font
254+ lettersFont = do
255+ char '['
256+ fs <- many letterFontKind
257+ many letter
258+ char ']'
259+ return $ S.fromList fs
260+
261+ letterFontKind :: PandocMonad m => ManLexer m FontKind
262+ letterFontKind = choice [
263+ char 'B' >> return Bold
264+ , char 'I' >> return Italic
265+ , char 'C' >> return Monospace
266+ , (char 'P' <|> char 'R') >> return Regular
267+ ]
268+
269+ escUnknown :: PandocMonad m => String -> ManLexer m String
270+ escUnknown s = do
229271 pos <- getPosition
230− logOutput $ SkippedContent ("Unknown escape sequence \\" ++ [c]) pos
231− return ENothing
272+ report $ SkippedContent ("Unknown escape sequence " ++ s) pos
273+ return mempty
232274
233275currentFont :: PandocMonad m => ManLexer m Font
234276currentFont = fontKind <$> getState
@@ -291,28 +333,23 @@ lexMacro = do
291333 plainArg :: PandocMonad m => ManLexer m RoffStr
292334 plainArg = do
293335 indents <- many spacetab
294− arg <- many1 $ escChar <|> (Just <$> noneOf " \t\n")
336+ arg <- many1 $ escapeLexer <|> many1 (noneOf " \t\n\\")
295337 f <- currentFont
296− return (indents ++ catMaybes arg, f)
338+ return (indents ++ mconcat arg, f)
297339
298340 quotedArg :: PandocMonad m => ManLexer m RoffStr
299341 quotedArg = do
300342 char '"'
301− val <- many quotedChar
343+ val <- mconcat <$> many quotedChar
302344 char '"'
303− val2 <- many $ escChar <|> (Just <$> noneOf " \t\n")
345+ val2 <- mconcat <$> many (escapeLexer <|> many1 (noneOf " \t\n"))
304346 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 '"'))
347+ return (val ++ val2, f)
309348
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
349+ quotedChar :: PandocMonad m => ManLexer m String
350+ quotedChar = escapeLexer
351+ <|> many1 (noneOf "\"\n\\")
352+ <|> try (string "\"\"" >> return "\"")
316353
317354lexLine :: PandocMonad m => ManLexer m ManToken
318355lexLine = do
@@ -325,10 +362,9 @@ lexLine = do
325362 esc = do
326363 someesc <- escapeLexer
327364 font <- currentFont
328− let rv = case someesc of
329− EChar c -> Just ([c], font)
330− _ -> Nothing
331− return rv
365+ return $ if null someesc
366+ then Nothing
367+ else Just (someesc, font)
332368
333369 linePart :: PandocMonad m => ManLexer m (Maybe (String, Font))
334370 linePart = do
@@ -336,7 +372,7 @@ lexLine = do
336372 font <- currentFont
337373 return $ Just (lnpart, font)
338374
339−
375+
340376lexEmptyLine :: PandocMonad m => ManLexer m ManToken
341377lexEmptyLine = char '\n' >> return MEmptyLine
342378
@@ -412,10 +448,10 @@ parseTitle = do
412448 where
413449 changeTitle title pst =
414450 let meta = stateMeta pst
415− metaUp = Meta $ insert "title" (MetaString title) (unMeta meta)
451+ metaUp = Meta $ M.insert "title" (MetaString title) (unMeta meta)
416452 in
417453 pst {stateMeta = metaUp}
418−
454+
419455parseSkippedContent :: PandocMonad m => ManParser m Blocks
420456parseSkippedContent = do
421457 tok <- munknownMacro <|> mcomment <|> memplyLine