@@ -30,19 +30,20 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
3030
3131Conversion of man to 'Pandoc' document.
3232-}
33−module Text.Pandoc.Readers.Man (readMan) where
33+module Text.Pandoc.Readers.Man (readMan, testFile) where
3434
3535import Prelude
36+import Control.Monad (liftM)
3637import Control.Monad.Except (throwError)
3738import Data.Default (Default)
38−import Data.Functor.Identity (Identity)
3939import Data.Map (insert)
40−import Data.Maybe (isJust, fromMaybe)
40+import Data.Maybe (isJust, catMaybes)
4141import Data.List (intersperse, intercalate)
4242import qualified Data.Text as T
4343
44−import Text.Pandoc.Class (PandocMonad(..))
44+import Text.Pandoc.Class (PandocMonad(..), runPure, runIOorExplode)
4545import Text.Pandoc.Definition
46+import Text.Pandoc.Error (PandocError (PandocParsecError))
4647import Text.Pandoc.Logging (LogMessage(..))
4748import Text.Pandoc.Options
4849import Text.Pandoc.Parsing
@@ -62,7 +63,7 @@ data MacroKind = KTitle
6263 | KCodeBlEnd
6364 | KTab
6465 | KTabEnd
65− deriving Show
66+ deriving (Show, Eq)
6667
6768data ManToken = MStr String FontKind
6869 | MLine [(String, FontKind)]
@@ -95,23 +96,67 @@ instance HasLogMessages ManState where
9596 addLogMessage lm mst = mst {pState = addLogMessage lm (pState mst)}
9697 getLogMessages mst = getLogMessages $ pState mst
9798
99+----
100+testStrr :: [Char] -> Either PandocError Pandoc
101+testStrr s = runPure $ readMan def (T.pack s)
102+
103+printPandoc :: Pandoc -> [Char]
104+printPandoc (Pandoc m content) =
105+ let ttl = "Pandoc: " ++ (show $ unMeta m)
106+ cnt = intercalate "\n" $ map show content
107+ in ttl ++ "\n" ++ cnt
108+
109+strrepr :: Either PandocError Pandoc -> [Char]
110+strrepr obj = case obj of
111+ Right x -> printPandoc x
112+ Left y -> show y
113+
114+testFile :: FilePath -> IO ()
115+testFile fname = do
116+ cont <- readFile fname
117+ pand <- runIOorExplode $ readMan def (T.pack cont)
118+ putStrLn $ printPandoc pand
119+----
120+
121+
98122-- | Read man (troff) from an input string and return a Pandoc document.
99123readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
100124readMan opts txt = do
101125 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
126+ eithertokens <- readWithM parseMan state (T.unpack $ crFilter txt)
127+ case eithertokens of
128+ Right tokenz -> do
129+ eitherdoc <- readWithMTokens compileMan state tokenz
130+ case eitherdoc of
131+ Right doc -> return doc
132+ Left e -> throwError e
105133 Left e -> throwError e
106134
135+ where
136+
137+ readWithMTokens :: PandocMonad m
138+ => ParserT [ManToken] ManState m a -- ^ parser
139+ -> ManState -- ^ initial state
140+ -> [ManToken] -- ^ input
141+ -> m (Either PandocError a)
142+ readWithMTokens parser state input =
143+ mapLeft (PandocParsecError . concat $ show <$> input) `liftM` runParserT parser state "source" input
144+
145+ mapLeft :: (a -> c) -> Either a b -> Either c b
146+ mapLeft f (Left x) = Left $ f x
147+ mapLeft _ (Right r) = Right r
148+
107149--
108150-- String -> ManToken function
109151--
110152
111−parseMan :: PandocMonad m => ManParser m Pandoc
112−parseMan = do
113− tokens <- many (parseMacro <|> parseLine <|> parseEmptyLine)
114− let blocks = []
153+parseMan :: PandocMonad m => ManParser m [ManToken]
154+parseMan = many (parseMacro <|> parseLine <|> parseEmptyLine)
155+
156+compileMan :: PandocMonad m => ManCompiler m Pandoc
157+compileMan = do
158+ let compilers = [compileTitle, compilePara, compileSkippedContent]
159+ blocks <- many $ choice compilers
115160 parserst <- pState <$> getState
116161 return $ Pandoc (stateMeta parserst) blocks
117162
@@ -145,26 +190,6 @@ parseMacro = do
145190
146191 where
147192
148− macroTitle :: PandocMonad m => String -> ManParser m Block
149− macroTitle mantitle = do
150− modifyState (changeTitle mantitle)
151− if null mantitle
152− then return Null
153− else return $ Header 1 nullAttr [Str mantitle]
154− where
155− changeTitle title mst@ManState{ pState = pst} =
156− let meta = stateMeta pst
157− metaUp = Meta $ insert "title" (MetaString title) (unMeta meta)
158− in
159− mst { pState = pst {stateMeta = metaUp} }
160−
161− macroCodeBlock :: PandocMonad m => Bool -> ManParser m ()
162− macroCodeBlock insideCB = modifyRoffState (\rst -> rst{inCodeBlock = insideCB}) >> return ()
163−
164− macroBR :: String -> Bool -> Block
165− macroBR txt inCode | inCode = Plain [Code nullAttr txt]
166− | otherwise = fromMaybe (Plain [Strong [Str txt]]) (linkToMan txt)
167−
168193 linkToMan :: String -> Maybe Block
169194 linkToMan txt = case runParser linkParser () "" txt of
170195 Right lnk -> Just $ Plain [lnk]
@@ -180,13 +205,6 @@ parseMacro = do
180205 -- assuming man pages are generated from Linux-like repository
181206 let manurl pagename section = "../"++section++"/"++pagename++"."++section
182207 return $ Link nullAttr [Str txt] (manurl mpage [mansect], mpage)
183−
184−
185− unkownMacro :: PandocMonad m => String -> ManParser m Block
186− unkownMacro mname = do
187− pos <- getPosition
188− logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos
189− return Null
190208
191209 parseArgs :: PandocMonad m => ManParser m [String]
192210 parseArgs = do
@@ -235,29 +253,30 @@ escapeParser = do
235253 , string "[]" >> return Regular
236254 , char '[' >> many1 letter >> char ']' >> return Regular
237255 ]
238− modifyRoffState (\r -> RoffState {fontKind = font})
256+ modifyRoffState (\r -> r {fontKind = font})
239257 return $ EFont font
240258
241259parseLine :: PandocMonad m => ManParser m ManToken
242260parseLine = do
243261 lnparts <- many1 (esc <|> linePart)
244− return $ MLine lnparts
262+ newline
263+ return $ MLine $ catMaybes lnparts
245264 where
246265
247− esc :: PandocMonad m => ManParser m (String, FontKind)
266+ esc :: PandocMonad m => ManParser m (Maybe (String, FontKind))
248267 esc = do
249268 someesc <- escapeParser
250269 font <- currentFont
251270 let rv = case someesc of
252− EChar c -> ([c], font)
253− _ -> ("", font)
271+ EChar c -> Just ([c], font)
272+ _ -> Nothing
254273 return rv
255274
256− linePart :: PandocMonad m => ManParser m (String, FontKind)
275+ linePart :: PandocMonad m => ManParser m (Maybe (String, FontKind))
257276 linePart = do
258277 lnpart <- many1 $ noneOf "\n\\"
259278 font <- currentFont
260− return (lnpart, font)
279+ return $ Just (lnpart, font)
261280
262281 currentFont :: PandocMonad m => ManParser m FontKind
263282 currentFont = do
@@ -273,11 +292,10 @@ parseEmptyLine = char '\n' >> return MEmptyLine
273292--
274293
275294msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t
276−msatisfy pred = tokenPrim show nextPos testTok
295+msatisfy predic = tokenPrim show nextPos testTok
277296 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)
297+ testTok t = if predic t then Just t else Nothing
298+ nextPos pos x _xs = updatePosString pos (show x)
281299
282300mstr :: PandocMonad m => ManCompiler m ManToken
283301mstr = msatisfy isMStr where
@@ -304,9 +322,10 @@ mheader = msatisfy isMHeader where
304322 isMHeader (MHeader _ _) = True
305323 isMHeader _ = False
306324
307−mmacro :: PandocMonad m => ManCompiler m ManToken
308−mmacro = msatisfy isMMacro where
309− isMMacro (MMacro _ _) = True
325+mmacro :: PandocMonad m => MacroKind -> ManCompiler m ManToken
326+mmacro mk = msatisfy isMMacro where
327+ isMMacro (MMacro mk' _) | mk == mk' = True
328+ | otherwise = False
310329 isMMacro _ = False
311330
312331munknownMacro :: PandocMonad m => ManCompiler m ManToken
@@ -323,6 +342,56 @@ mcomment = msatisfy isMComment where
323342-- ManToken -> Block functions
324343--
325344
326−compileHeader :: PandocMonad m => ManCompiler m Block
327−compileHeader = undefined --do
345+compileTitle :: PandocMonad m => ManCompiler m Block
346+compileTitle = do
347+ (MMacro _ args) <- mmacro KTitle
348+ if null args
349+ then return Null
350+ else do
351+ let mantitle = head args
352+ modifyState (changeTitle mantitle)
353+ return $ Header 1 nullAttr [Str mantitle]
354+ where
355+ changeTitle title mst@ManState{ pState = pst} =
356+ let meta = stateMeta pst
357+ metaUp = Meta $ insert "title" (MetaString title) (unMeta meta)
358+ in
359+ mst { pState = pst {stateMeta = metaUp} }
360+
361+compileSkippedContent :: PandocMonad m => ManCompiler m Block
362+compileSkippedContent = do
363+ tok <- munknownMacro <|> mcomment <|> memplyLine
364+ onToken tok
365+ return Null
366+
367+ where
368+
369+ onToken :: PandocMonad m => ManToken -> ManCompiler m ()
370+ onToken (MUnknownMacro mname _) = do
371+ pos <- getPosition
372+ logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos
373+ onToken _ = return ()
374+
375+strToInline :: String -> FontKind -> Inline
376+strToInline s Regular = Str s
377+strToInline s Italic = Emph [Str s]
378+strToInline s Bold = Strong [Str s]
379+strToInline s ItalicBold = Strong [Emph [Str s]]
380+
381+compilePara :: PandocMonad m => ManCompiler m Block
382+compilePara = do
383+ inls <- many1 (strInl <|> lineInl)
384+ let withspaces = intersperse [Str " "] inls
385+ return $ Para (concat withspaces)
386+
387+ where
388+
389+ strInl :: PandocMonad m => ManCompiler m [Inline]
390+ strInl = do
391+ (MStr str fk) <- mstr
392+ return [strToInline str fk]
328393
394+ lineInl :: PandocMonad m => ManCompiler m [Inline]
395+ lineInl = do
396+ (MLine fragments) <- mline
397+ return $ fmap (\(s,f) -> strToInline s f) fragments