diff options
| -rw-r--r-- | src/Text/Pandoc/Readers/Man.hs | 179 |
1 files changed, 124 insertions, 55 deletions
diff --git a/src/Text/Pandoc/Readers/Man.hs b/src/Text/Pandoc/Readers/Man.hs index dfe1bcdc1..d7be9aee3 100644 --- a/src/Text/Pandoc/Readers/Man.hs +++ b/src/Text/Pandoc/Readers/Man.hs @@ -30,19 +30,20 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of man to 'Pandoc' document. -} -module Text.Pandoc.Readers.Man (readMan) where +module Text.Pandoc.Readers.Man (readMan, testFile) where import Prelude +import Control.Monad (liftM) import Control.Monad.Except (throwError) import Data.Default (Default) -import Data.Functor.Identity (Identity) import Data.Map (insert) -import Data.Maybe (isJust, fromMaybe) +import Data.Maybe (isJust, catMaybes) import Data.List (intersperse, intercalate) import qualified Data.Text as T -import Text.Pandoc.Class (PandocMonad(..)) +import Text.Pandoc.Class (PandocMonad(..), runPure, runIOorExplode) import Text.Pandoc.Definition +import Text.Pandoc.Error (PandocError (PandocParsecError)) import Text.Pandoc.Logging (LogMessage(..)) import Text.Pandoc.Options import Text.Pandoc.Parsing @@ -62,7 +63,7 @@ data MacroKind = KTitle | KCodeBlEnd | KTab | KTabEnd - deriving Show + deriving (Show, Eq) data ManToken = MStr String FontKind | MLine [(String, FontKind)] @@ -95,23 +96,67 @@ instance HasLogMessages ManState where addLogMessage lm mst = mst {pState = addLogMessage lm (pState mst)} getLogMessages mst = getLogMessages $ pState mst +---- +testStrr :: [Char] -> Either PandocError Pandoc +testStrr s = runPure $ readMan def (T.pack s) + +printPandoc :: Pandoc -> [Char] +printPandoc (Pandoc m content) = + let ttl = "Pandoc: " ++ (show $ unMeta m) + cnt = intercalate "\n" $ map show content + in ttl ++ "\n" ++ cnt + +strrepr :: Either PandocError Pandoc -> [Char] +strrepr obj = case obj of + Right x -> printPandoc x + Left y -> show y + +testFile :: FilePath -> IO () +testFile fname = do + cont <- readFile fname + pand <- runIOorExplode $ readMan def (T.pack cont) + putStrLn $ printPandoc pand +---- + + -- | Read man (troff) from an input string and return a Pandoc document. readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc readMan opts txt = do let state = ManState { pState = def{ stateOptions = opts }, rState = def} - parsed <- readWithM parseMan state (T.unpack $ crFilter txt) - case parsed of - Right result -> return result + eithertokens <- readWithM parseMan state (T.unpack $ crFilter txt) + case eithertokens of + Right tokenz -> do + eitherdoc <- readWithMTokens compileMan state tokenz + case eitherdoc of + Right doc -> return doc + Left e -> throwError e Left e -> throwError e + where + + readWithMTokens :: PandocMonad m + => ParserT [ManToken] ManState m a -- ^ parser + -> ManState -- ^ initial state + -> [ManToken] -- ^ input + -> m (Either PandocError a) + readWithMTokens parser state input = + mapLeft (PandocParsecError . concat $ show <$> input) `liftM` runParserT parser state "source" input + + mapLeft :: (a -> c) -> Either a b -> Either c b + mapLeft f (Left x) = Left $ f x + mapLeft _ (Right r) = Right r + -- -- String -> ManToken function -- -parseMan :: PandocMonad m => ManParser m Pandoc -parseMan = do - tokens <- many (parseMacro <|> parseLine <|> parseEmptyLine) - let blocks = [] +parseMan :: PandocMonad m => ManParser m [ManToken] +parseMan = many (parseMacro <|> parseLine <|> parseEmptyLine) + +compileMan :: PandocMonad m => ManCompiler m Pandoc +compileMan = do + let compilers = [compileTitle, compilePara, compileSkippedContent] + blocks <- many $ choice compilers parserst <- pState <$> getState return $ Pandoc (stateMeta parserst) blocks @@ -145,26 +190,6 @@ parseMacro = do where - macroTitle :: PandocMonad m => String -> ManParser m Block - macroTitle mantitle = do - modifyState (changeTitle mantitle) - if null mantitle - then return Null - else return $ Header 1 nullAttr [Str mantitle] - where - changeTitle title mst@ManState{ pState = pst} = - let meta = stateMeta pst - metaUp = Meta $ insert "title" (MetaString title) (unMeta meta) - in - mst { pState = pst {stateMeta = metaUp} } - - macroCodeBlock :: PandocMonad m => Bool -> ManParser m () - macroCodeBlock insideCB = modifyRoffState (\rst -> rst{inCodeBlock = insideCB}) >> return () - - macroBR :: String -> Bool -> Block - macroBR txt inCode | inCode = Plain [Code nullAttr txt] - | otherwise = fromMaybe (Plain [Strong [Str txt]]) (linkToMan txt) - linkToMan :: String -> Maybe Block linkToMan txt = case runParser linkParser () "" txt of Right lnk -> Just $ Plain [lnk] @@ -180,13 +205,6 @@ parseMacro = do -- assuming man pages are generated from Linux-like repository let manurl pagename section = "../"++section++"/"++pagename++"."++section return $ Link nullAttr [Str txt] (manurl mpage [mansect], mpage) - - - unkownMacro :: PandocMonad m => String -> ManParser m Block - unkownMacro mname = do - pos <- getPosition - logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos - return Null parseArgs :: PandocMonad m => ManParser m [String] parseArgs = do @@ -235,29 +253,30 @@ escapeParser = do , string "[]" >> return Regular , char '[' >> many1 letter >> char ']' >> return Regular ] - modifyRoffState (\r -> RoffState {fontKind = font}) + modifyRoffState (\r -> r {fontKind = font}) return $ EFont font parseLine :: PandocMonad m => ManParser m ManToken parseLine = do lnparts <- many1 (esc <|> linePart) - return $ MLine lnparts + newline + return $ MLine $ catMaybes lnparts where - esc :: PandocMonad m => ManParser m (String, FontKind) + esc :: PandocMonad m => ManParser m (Maybe (String, FontKind)) esc = do someesc <- escapeParser font <- currentFont let rv = case someesc of - EChar c -> ([c], font) - _ -> ("", font) + EChar c -> Just ([c], font) + _ -> Nothing return rv - linePart :: PandocMonad m => ManParser m (String, FontKind) + linePart :: PandocMonad m => ManParser m (Maybe (String, FontKind)) linePart = do lnpart <- many1 $ noneOf "\n\\" font <- currentFont - return (lnpart, font) + return $ Just (lnpart, font) currentFont :: PandocMonad m => ManParser m FontKind currentFont = do @@ -273,11 +292,10 @@ parseEmptyLine = char '\n' >> return MEmptyLine -- msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t -msatisfy pred = tokenPrim show nextPos testTok +msatisfy predic = tokenPrim show nextPos testTok where - posFromTok (pos,t) = pos - testTok t = if pred t then Just t else Nothing - nextPos pos x xs = updatePosString pos (show x) + testTok t = if predic t then Just t else Nothing + nextPos pos x _xs = updatePosString pos (show x) mstr :: PandocMonad m => ManCompiler m ManToken mstr = msatisfy isMStr where @@ -304,9 +322,10 @@ mheader = msatisfy isMHeader where isMHeader (MHeader _ _) = True isMHeader _ = False -mmacro :: PandocMonad m => ManCompiler m ManToken -mmacro = msatisfy isMMacro where - isMMacro (MMacro _ _) = True +mmacro :: PandocMonad m => MacroKind -> ManCompiler m ManToken +mmacro mk = msatisfy isMMacro where + isMMacro (MMacro mk' _) | mk == mk' = True + | otherwise = False isMMacro _ = False munknownMacro :: PandocMonad m => ManCompiler m ManToken @@ -323,6 +342,56 @@ mcomment = msatisfy isMComment where -- ManToken -> Block functions -- -compileHeader :: PandocMonad m => ManCompiler m Block -compileHeader = undefined --do +compileTitle :: PandocMonad m => ManCompiler m Block +compileTitle = do + (MMacro _ args) <- mmacro KTitle + if null args + then return Null + else do + let mantitle = head args + modifyState (changeTitle mantitle) + return $ Header 1 nullAttr [Str mantitle] + where + changeTitle title mst@ManState{ pState = pst} = + let meta = stateMeta pst + metaUp = Meta $ insert "title" (MetaString title) (unMeta meta) + in + mst { pState = pst {stateMeta = metaUp} } + +compileSkippedContent :: PandocMonad m => ManCompiler m Block +compileSkippedContent = do + tok <- munknownMacro <|> mcomment <|> memplyLine + onToken tok + return Null + + where + + onToken :: PandocMonad m => ManToken -> ManCompiler m () + onToken (MUnknownMacro mname _) = do + pos <- getPosition + logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos + onToken _ = return () + +strToInline :: String -> FontKind -> Inline +strToInline s Regular = Str s +strToInline s Italic = Emph [Str s] +strToInline s Bold = Strong [Str s] +strToInline s ItalicBold = Strong [Emph [Str s]] + +compilePara :: PandocMonad m => ManCompiler m Block +compilePara = do + inls <- many1 (strInl <|> lineInl) + let withspaces = intersperse [Str " "] inls + return $ Para (concat withspaces) + + where + + strInl :: PandocMonad m => ManCompiler m [Inline] + strInl = do + (MStr str fk) <- mstr + return [strToInline str fk] + lineInl :: PandocMonad m => ManCompiler m [Inline] + lineInl = do + (MLine fragments) <- mline + return $ fmap (\(s,f) -> strToInline s f) fragments |