aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc')
-rw-r--r--src/Text/Pandoc/Readers/Man.hs306
1 files changed, 175 insertions, 131 deletions
diff --git a/src/Text/Pandoc/Readers/Man.hs b/src/Text/Pandoc/Readers/Man.hs
index fe66bb61c..dfe1bcdc1 100644
--- a/src/Text/Pandoc/Readers/Man.hs
+++ b/src/Text/Pandoc/Readers/Man.hs
@@ -35,6 +35,7 @@ module Text.Pandoc.Readers.Man (readMan) where
import Prelude
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.List (intersperse, intercalate)
@@ -46,11 +47,38 @@ import Text.Pandoc.Logging (LogMessage(..))
import Text.Pandoc.Options
import Text.Pandoc.Parsing
import Text.Pandoc.Shared (crFilter)
-import Text.Parsec
+import Text.Parsec hiding (tokenPrim)
import Text.Parsec.Char ()
+import Text.Parsec.Pos (updatePosString)
+
+--
+-- Data Types
+--
data FontKind = Regular | Italic | Bold | ItalicBold deriving Show
+data MacroKind = KTitle
+ | KCodeBlStart
+ | KCodeBlEnd
+ | KTab
+ | KTabEnd
+ deriving Show
+
+data ManToken = MStr String FontKind
+ | MLine [(String, FontKind)]
+ | MLink String Target
+ | MEmptyLine
+ | MHeader Integer String
+ | MMacro MacroKind [String]
+ | MUnknownMacro String [String]
+ | MComment String
+ deriving Show
+
+data EscapeThing = EFont FontKind
+ | EChar Char
+ | ENothing
+ deriving Show
+
data RoffState = RoffState { inCodeBlock :: Bool
, fontKind :: FontKind
} deriving Show
@@ -60,48 +88,60 @@ instance Default RoffState where
data ManState = ManState {pState :: ParserState, rState :: RoffState}
+type ManParser m = ParserT [Char] ManState m
+type ManCompiler m = ParserT [ManToken] ManState m
+
instance HasLogMessages ManState where
addLogMessage lm mst = mst {pState = addLogMessage lm (pState mst)}
getLogMessages mst = getLogMessages $ pState mst
+-- | 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
+ Left e -> throwError e
+
+--
+-- String -> ManToken function
+--
+
+parseMan :: PandocMonad m => ManParser m Pandoc
+parseMan = do
+ tokens <- many (parseMacro <|> parseLine <|> parseEmptyLine)
+ let blocks = []
+ parserst <- pState <$> getState
+ return $ Pandoc (stateMeta parserst) blocks
+
modifyRoffState :: PandocMonad m => (RoffState -> RoffState) -> ParsecT a ManState m ()
modifyRoffState f = do
mst <- getState
setState mst { rState = f $ rState mst }
-type ManParser m = ParserT [Char] ManState m
-
-parseMacro :: PandocMonad m => ManParser m Block
+parseMacro :: PandocMonad m => ManParser m ManToken
parseMacro = do
char '.' <|> char '\''
many space
macroName <- many1 (letter <|> oneOf ['\\', '"'])
args <- parseArgs
let joinedArgs = concat $ intersperse " " args
- ManState { rState = rst } <- getState
- let toTextF transf = if inCodeBlock rst then [Code nullAttr joinedArgs] else transf [Str joinedArgs]
- let toText = return . Plain . toTextF
- let toBold = toText (\s -> [Strong s])
- let toItalic = toText (\s -> [Emph s])
- let toBoldItalic = toText (\s -> [Strong [Emph s]])
-
- case macroName of
- "\\\"" -> return Null -- comment
- "TH" -> macroTitle (if null args then "" else head args) -- man-title
- "TP" -> return Null -- tab-indented paragraph
- "PP" -> return Null -- end of tab-indented paragraphs
- "nf" -> macroCodeBlock True >> return Null
- "fi" -> macroCodeBlock False >> return Null
- "B" -> toBold
- "BR" -> return $ macroBR joinedArgs (inCodeBlock rst)
- "BI" -> toBoldItalic
- "IB" -> toBoldItalic
- "I" -> toItalic
- "IR" -> toItalic
- "RI" -> toItalic
- "SH" -> return $ Header 2 nullAttr [Str joinedArgs]
- "sp" -> return $ if inCodeBlock rst then Null else Plain [LineBreak]
- _ -> unkownMacro macroName
+
+ let tok = case macroName of
+ x | x `elem` ["\\\"", "\\#"] -> MComment joinedArgs
+ "TH" -> MMacro KTitle args
+ "TP" -> MMacro KTab []
+ "PP" -> MMacro KTabEnd []
+ "nf" -> MMacro KCodeBlStart []
+ "fi" -> MMacro KCodeBlEnd []
+ x | x `elem` ["B", "BR"] -> MStr joinedArgs Bold -- "BR" is often used as a link to another man
+ x | x `elem` ["BI", "IB"] -> MStr joinedArgs ItalicBold
+ x | x `elem` ["I", "IR", "RI"] -> MStr joinedArgs Italic
+ "SH" -> MHeader 2 joinedArgs
+ "sp" -> MEmptyLine
+ _ -> MUnknownMacro macroName args
+ return tok
where
@@ -174,111 +214,115 @@ parseMacro = do
quotedChar :: PandocMonad m => ManParser m Char
quotedChar = noneOf "\"\n" <|> try (string "\"\"" >> return '"')
-roffInline :: RoffState -> String -> [Inline]
-roffInline rst str
- | null str && (not $ inCodeBlock rst) = []
- | inCodeBlock rst = [Code nullAttr str]
- | otherwise = case fontKind rst of
- Regular -> [Str str]
- Italic -> [Emph [Str str]]
- Bold -> [Strong [Str str]]
- ItalicBold -> [Emph [Strong [Str str]]]
-
-parseLine :: PandocMonad m => ManParser m Block
+escapeParser :: PandocMonad m => ManParser m EscapeThing
+escapeParser = do
+ char '\\'
+ choice [escChar, escFont]
+ where
+
+ escChar :: PandocMonad m => ManParser m EscapeThing
+ escChar = choice [ char '-' >> return (EChar '-')
+ , oneOf ['%', '{', '}'] >> return ENothing
+ ]
+
+ escFont :: PandocMonad m => ManParser m EscapeThing
+ escFont = do
+ char 'f'
+ font <- choice [ char 'B' >> return Bold
+ , char 'I' >> return Italic
+ , (char 'P' <|> anyChar) >> return Regular
+ , char '(' >> anyChar >> anyChar >> return Regular
+ , string "[]" >> return Regular
+ , char '[' >> many1 letter >> char ']' >> return Regular
+ ]
+ modifyRoffState (\r -> RoffState {fontKind = font})
+ return $ EFont font
+
+parseLine :: PandocMonad m => ManParser m ManToken
parseLine = do
- parts <- parseLineParts
- newline
- return $ if null parts
- then Null
- else Plain parts
+ lnparts <- many1 (esc <|> linePart)
+ return $ MLine lnparts
where
- parseLineParts :: PandocMonad m => ManParser m [Inline]
- parseLineParts = do
- lnpart <- many $ noneOf "\n\\"
- ManState {rState = roffSt} <- getState
- let inls = roffInline roffSt lnpart
- others <- backSlash <|> return []
- return $ inls ++ others
+
+ esc :: PandocMonad m => ManParser m (String, FontKind)
+ esc = do
+ someesc <- escapeParser
+ font <- currentFont
+ let rv = case someesc of
+ EChar c -> ([c], font)
+ _ -> ("", font)
+ return rv
+
+ linePart :: PandocMonad m => ManParser m (String, FontKind)
+ linePart = do
+ lnpart <- many1 $ noneOf "\n\\"
+ font <- currentFont
+ return (lnpart, font)
+
+ currentFont :: PandocMonad m => ManParser m FontKind
+ currentFont = do
+ RoffState {fontKind = fk} <- rState <$> getState
+ return fk
+
- backSlash :: PandocMonad m => ManParser m [Inline]
- backSlash = do
- char '\\'
- esc <- choice [ char 'f' >> fEscape
- , char '-' >> return (Just '-')
- , char '%' >> return Nothing
- , Just <$> noneOf "\n"
- ]
- ManState {rState = roffSt} <- getState
- case esc of
- Just c -> let inls = roffInline roffSt [c]
- in parseLineParts >>= (\oth -> return $ inls ++ oth)
- Nothing -> parseLineParts
- where
-
- fEscape :: PandocMonad m => ManParser m (Maybe Char)
- fEscape = choice [ char 'B' >> modifyRoffState (\rst -> rst {fontKind = Bold})
- , char 'I' >> modifyRoffState (\rst -> rst {fontKind = Italic})
- , (char 'P' <|> anyChar) >> modifyRoffState (\rst -> rst {fontKind = Regular})
- ]
- >> return Nothing
-
-finds :: (a -> Bool) -> [a] -> ([a], [a])
-finds predic els = let matched = finds' els
- in (matched, drop (length matched) els) where
- finds' [] = []
- finds' (e:es) | predic e = e : finds' es
- | otherwise = []
-
--- | return (matched, notmatched, others)
-findsBoth :: (a -> Bool) -> [a] -> ([a], [a], [a])
-findsBoth predic els =
- let (matched, els') = finds predic els
- (notmatched, els'') = finds (not . predic) els'
- in (matched, notmatched, els'')
-
-createParas :: [Block] -> [Block]
-createParas bs = inner bs [] where
- inner :: [Block] -> [Inline] -> [Block]
- inner [] inls = plainInlinesToPara inls
- inner (Plain einls : oth) inls = inner oth (inls ++ joinCode einls)
- inner (block : oth) inls = (plainInlinesToPara inls ++ [block]) ++ inner oth []
-
- joinCode :: [Inline] -> [Inline]
- joinCode inls =
- let (codes, notcodes) = finds isCode inls
- codeStr (Code _ s) = s
- codeStr _ = ""
- joined = Code nullAttr (concat $ codeStr <$> codes)
- in if null codes
- then notcodes
- else joined : notcodes
-
- plainInlinesToPara :: [Inline] -> [Block]
- plainInlinesToPara [] = []
- plainInlinesToPara inls =
- let (cds, ncds, oth) = findsBoth isCode inls
- codeToStr (Code _ s) = s
- codeToStr _ = ""
- cbs = if null cds
- then []
- else [CodeBlock nullAttr (intercalate "\n" $ codeToStr <$> cds)]
- paras = [Para (intersperse (Str " ") ncds)]
- in cbs ++ paras ++ plainInlinesToPara oth
-
- isCode (Code _ _) = True
- isCode _ = False
+parseEmptyLine :: PandocMonad m => ManParser m ManToken
+parseEmptyLine = char '\n' >> return MEmptyLine
-parseMan :: PandocMonad m => ManParser m Pandoc
-parseMan = do
- blocks <- createParas <$> many (parseMacro <|> parseLine)
- parserst <- pState <$> getState
- return $ Pandoc (stateMeta parserst) blocks
+--
+-- ManToken parsec functions
+--
+
+msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t
+msatisfy pred = 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)
+
+mstr :: PandocMonad m => ManCompiler m ManToken
+mstr = msatisfy isMStr where
+ isMStr (MStr _ _) = True
+ isMStr _ = False
+
+mline :: PandocMonad m => ManCompiler m ManToken
+mline = msatisfy isMLine where
+ isMLine (MLine _) = True
+ isMLine _ = False
+
+mlink :: PandocMonad m => ManCompiler m ManToken
+mlink = msatisfy isMLink where
+ isMLink (MLink _ _) = True
+ isMLink _ = False
+
+memplyLine :: PandocMonad m => ManCompiler m ManToken
+memplyLine = msatisfy isMEmptyLine where
+ isMEmptyLine MEmptyLine = True
+ isMEmptyLine _ = False
+
+mheader :: PandocMonad m => ManCompiler m ManToken
+mheader = msatisfy isMHeader where
+ isMHeader (MHeader _ _) = True
+ isMHeader _ = False
+
+mmacro :: PandocMonad m => ManCompiler m ManToken
+mmacro = msatisfy isMMacro where
+ isMMacro (MMacro _ _) = True
+ isMMacro _ = False
+
+munknownMacro :: PandocMonad m => ManCompiler m ManToken
+munknownMacro = msatisfy isMUnknownMacro where
+ isMUnknownMacro (MUnknownMacro _ _) = True
+ isMUnknownMacro _ = False
+
+mcomment :: PandocMonad m => ManCompiler m ManToken
+mcomment = msatisfy isMComment where
+ isMComment (MComment _) = True
+ isMComment _ = False
+
+--
+-- ManToken -> Block functions
+--
+
+compileHeader :: PandocMonad m => ManCompiler m Block
+compileHeader = undefined --do
--- | 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
- Left e -> throwError e
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 19:06:23 +0000