git.iko.soy/typeable/pandoc
on master help sign in
compiling paragraphs
533d450Yan Pas
src/Text/Pandoc/Readers/Man.hs+124−55
compare with master
unifiedsplit
@@ -30,19 +30,20 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
30
30
31Conversion of man to 'Pandoc' document.
31Conversion of man to 'Pandoc' document.
32-}
32-}
33−module Text.Pandoc.Readers.Man (readMan) where
33+module Text.Pandoc.Readers.Man (readMan, testFile) where
34
34
35import Prelude
35import Prelude
36+import Control.Monad (liftM)
36import Control.Monad.Except (throwError)
37import Control.Monad.Except (throwError)
37import Data.Default (Default)
38import Data.Default (Default)
38−import Data.Functor.Identity (Identity)
39import Data.Map (insert)
39import Data.Map (insert)
40−import Data.Maybe (isJust, fromMaybe)
40+import Data.Maybe (isJust, catMaybes)
41import Data.List (intersperse, intercalate)
41import Data.List (intersperse, intercalate)
42import qualified Data.Text as T
42import qualified Data.Text as T
43
43
44−import Text.Pandoc.Class (PandocMonad(..))
44+import Text.Pandoc.Class (PandocMonad(..), runPure, runIOorExplode)
45import Text.Pandoc.Definition
45import Text.Pandoc.Definition
46+import Text.Pandoc.Error (PandocError (PandocParsecError))
46import Text.Pandoc.Logging (LogMessage(..))
47import Text.Pandoc.Logging (LogMessage(..))
47import Text.Pandoc.Options
48import Text.Pandoc.Options
48import Text.Pandoc.Parsing
49import Text.Pandoc.Parsing
@@ -62,7 +63,7 @@ data MacroKind = KTitle
62 | KCodeBlEnd
63 | KCodeBlEnd
63 | KTab
64 | KTab
64 | KTabEnd
65 | KTabEnd
65− deriving Show
66+ deriving (Show, Eq)
66
67
67data ManToken = MStr String FontKind
68data ManToken = MStr String FontKind
68 | MLine [(String, FontKind)]
69 | MLine [(String, FontKind)]
@@ -95,23 +96,67 @@ instance HasLogMessages ManState where
95 addLogMessage lm mst = mst {pState = addLogMessage lm (pState mst)}
96 addLogMessage lm mst = mst {pState = addLogMessage lm (pState mst)}
96 getLogMessages mst = getLogMessages $ pState mst
97 getLogMessages mst = getLogMessages $ pState mst
97
98
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+
98-- | Read man (troff) from an input string and return a Pandoc document.
122-- | Read man (troff) from an input string and return a Pandoc document.
99readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
123readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
100readMan opts txt = do
124readMan opts txt = do
101 let state = ManState { pState = def{ stateOptions = opts }, rState = def}
125 let state = ManState { pState = def{ stateOptions = opts }, rState = def}
102− parsed <- readWithM parseMan state (T.unpack $ crFilter txt)
126+ eithertokens <- readWithM parseMan state (T.unpack $ crFilter txt)
103− case parsed of
127+ case eithertokens of
104− Right result -> return result
128+ Right tokenz -> do
129+ eitherdoc <- readWithMTokens compileMan state tokenz
130+ case eitherdoc of
131+ Right doc -> return doc
132+ Left e -> throwError e
105 Left e -> throwError e
133 Left e -> throwError e
106
134
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+
107--
149--
108-- String -> ManToken function
150-- String -> ManToken function
109--
151--
110
152
111−parseMan :: PandocMonad m => ManParser m Pandoc
153+parseMan :: PandocMonad m => ManParser m [ManToken]
112−parseMan = do
113− tokens <- many (parseMacro <|> parseLine <|> parseEmptyLine)
154+parseMan = many (parseMacro <|> parseLine <|> parseEmptyLine)
114− let blocks = []
155+
156+compileMan :: PandocMonad m => ManCompiler m Pandoc
157+compileMan = do
158+ let compilers = [compileTitle, compilePara, compileSkippedContent]
159+ blocks <- many $ choice compilers
115 parserst <- pState <$> getState
160 parserst <- pState <$> getState
116 return $ Pandoc (stateMeta parserst) blocks
161 return $ Pandoc (stateMeta parserst) blocks
117
162
@@ -145,26 +190,6 @@ parseMacro = do
145
190
146 where
191 where
147
192
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−
168 linkToMan :: String -> Maybe Block
193 linkToMan :: String -> Maybe Block
169 linkToMan txt = case runParser linkParser () "" txt of
194 linkToMan txt = case runParser linkParser () "" txt of
170 Right lnk -> Just $ Plain [lnk]
195 Right lnk -> Just $ Plain [lnk]
@@ -180,13 +205,6 @@ parseMacro = do
180 -- assuming man pages are generated from Linux-like repository
205 -- assuming man pages are generated from Linux-like repository
181 let manurl pagename section = "../"++section++"/"++pagename++"."++section
206 let manurl pagename section = "../"++section++"/"++pagename++"."++section
182 return $ Link nullAttr [Str txt] (manurl mpage [mansect], mpage)
207 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
190
208
191 parseArgs :: PandocMonad m => ManParser m [String]
209 parseArgs :: PandocMonad m => ManParser m [String]
192 parseArgs = do
210 parseArgs = do
@@ -235,29 +253,30 @@ escapeParser = do
235 , string "[]" >> return Regular
253 , string "[]" >> return Regular
236 , char '[' >> many1 letter >> char ']' >> return Regular
254 , char '[' >> many1 letter >> char ']' >> return Regular
237 ]
255 ]
238− modifyRoffState (\r -> RoffState {fontKind = font})
256+ modifyRoffState (\r -> r {fontKind = font})
239 return $ EFont font
257 return $ EFont font
240
258
241parseLine :: PandocMonad m => ManParser m ManToken
259parseLine :: PandocMonad m => ManParser m ManToken
242parseLine = do
260parseLine = do
243 lnparts <- many1 (esc <|> linePart)
261 lnparts <- many1 (esc <|> linePart)
262+ newline
244− return $ MLine lnparts
263+ return $ MLine $ catMaybes lnparts
245 where
264 where
246
265
247− esc :: PandocMonad m => ManParser m (String, FontKind)
266+ esc :: PandocMonad m => ManParser m (Maybe (String, FontKind))
248 esc = do
267 esc = do
249 someesc <- escapeParser
268 someesc <- escapeParser
250 font <- currentFont
269 font <- currentFont
251 let rv = case someesc of
270 let rv = case someesc of
252− EChar c -> ([c], font)
271+ EChar c -> Just ([c], font)
253− _ -> ("", font)
272+ _ -> Nothing
254 return rv
273 return rv
255
274
256− linePart :: PandocMonad m => ManParser m (String, FontKind)
275+ linePart :: PandocMonad m => ManParser m (Maybe (String, FontKind))
257 linePart = do
276 linePart = do
258 lnpart <- many1 $ noneOf "\n\\"
277 lnpart <- many1 $ noneOf "\n\\"
259 font <- currentFont
278 font <- currentFont
260− return (lnpart, font)
279+ return $ Just (lnpart, font)
261
280
262 currentFont :: PandocMonad m => ManParser m FontKind
281 currentFont :: PandocMonad m => ManParser m FontKind
263 currentFont = do
282 currentFont = do
@@ -273,11 +292,10 @@ parseEmptyLine = char '\n' >> return MEmptyLine
273--
292--
274
293
275msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t
294msatisfy :: (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
277 where
296 where
278− posFromTok (pos,t) = pos
279− testTok t = if pred t then Just t else Nothing
297+ testTok t = if predic t then Just t else Nothing
280− nextPos pos x xs = updatePosString pos (show x)
298+ nextPos pos x _xs = updatePosString pos (show x)
281
299
282mstr :: PandocMonad m => ManCompiler m ManToken
300mstr :: PandocMonad m => ManCompiler m ManToken
283mstr = msatisfy isMStr where
301mstr = msatisfy isMStr where
@@ -304,9 +322,10 @@ mheader = msatisfy isMHeader where
304 isMHeader (MHeader _ _) = True
322 isMHeader (MHeader _ _) = True
305 isMHeader _ = False
323 isMHeader _ = False
306
324
307−mmacro :: PandocMonad m => ManCompiler m ManToken
325+mmacro :: PandocMonad m => MacroKind -> ManCompiler m ManToken
308−mmacro = msatisfy isMMacro where
326+mmacro mk = msatisfy isMMacro where
309− isMMacro (MMacro _ _) = True
327+ isMMacro (MMacro mk' _) | mk == mk' = True
328+ | otherwise = False
310 isMMacro _ = False
329 isMMacro _ = False
311
330
312munknownMacro :: PandocMonad m => ManCompiler m ManToken
331munknownMacro :: PandocMonad m => ManCompiler m ManToken
@@ -323,6 +342,56 @@ mcomment = msatisfy isMComment where
323-- ManToken -> Block functions
342-- ManToken -> Block functions
324--
343--
325
344
326−compileHeader :: PandocMonad m => ManCompiler m Block
345+compileTitle :: PandocMonad m => ManCompiler m Block
327−compileHeader = undefined --do
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]
328
393
394+ lineInl :: PandocMonad m => ManCompiler m [Inline]
395+ lineInl = do
396+ (MLine fragments) <- mline
397+ return $ fmap (\(s,f) -> strToInline s f) fragments