Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Roff reader: rename RoffToken constructors so they're shorter.

Browse source
This commit is contained in:
John MacFarlane 2018-10-30 18:16:44 -07:00
parent c46593304c
commit ffd3aa4f09
2 changed files with 50 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

72
src/Text/Pandoc/Readers/Man.hs
View file

@ -115,9 +115,9 @@ parseBlock = choice [ parseList
parseTable :: PandocMonad m => ManParser m Blocks parseTable :: PandocMonad m => ManParser m Blocks
parseTable = do parseTable = do
modifyState $ \st -> st { tableCellsPlain = True } modifyState $ \st -> st { tableCellsPlain = True }
let isRoffTable (RoffTable{}) = True let isTbl (Tbl{}) = True
isRoffTable _ = False isTbl _ = False
RoffTable _opts rows pos <- msatisfy isRoffTable Tbl _opts rows pos <- msatisfy isTbl
case rows of case rows of
((as,_):_) -> try (do ((as,_):_) -> try (do
let as' = map (columnTypeToAlignment . columnType) as let as' = map (columnTypeToAlignment . columnType) as
@ -167,7 +167,7 @@ parseTable = do
isHrule ([cellfmt], _) = columnType cellfmt `elem` ['_','-','='] isHrule ([cellfmt], _) = columnType cellfmt `elem` ['_','-','=']
isHrule (_, [RoffTokens ss]) = isHrule (_, [RoffTokens ss]) =
case Foldable.toList ss of case Foldable.toList ss of
[RoffTextLine [RoffStr [c]]] -> c `elem` ['_','-','='] [TextLine [RoffStr [c]]] -> c `elem` ['_','-','=']
_ -> False _ -> False
isHrule _ = False isHrule _ = False
@ -199,7 +199,7 @@ msatisfy :: Monad m => (RoffToken -> Bool) -> ParserT [RoffToken] st m RoffToken
msatisfy predic = tokenPrim show nextPos testTok msatisfy predic = tokenPrim show nextPos testTok
where where
testTok t = if predic t then Just t else Nothing testTok t = if predic t then Just t else Nothing
nextPos _pos _x (RoffControlLine _ _ pos':_) = pos' nextPos _pos _x (ControlLine _ _ pos':_) = pos'
nextPos pos _x _xs = updatePosString nextPos pos _x _xs = updatePosString
(setSourceColumn (setSourceColumn
(setSourceLine pos $ sourceLine pos + 1) 1) "" (setSourceLine pos $ sourceLine pos + 1) 1) ""
@ -208,25 +208,25 @@ mtoken :: PandocMonad m => ManParser m RoffToken
mtoken = msatisfy (const True) mtoken = msatisfy (const True)
mline :: PandocMonad m => ManParser m RoffToken mline :: PandocMonad m => ManParser m RoffToken
mline = msatisfy isRoffTextLine where mline = msatisfy isTextLine where
isRoffTextLine (RoffTextLine _) = True isTextLine (TextLine _) = True
isRoffTextLine _ = False isTextLine _ = False
memptyLine :: PandocMonad m => ManParser m RoffToken memptyLine :: PandocMonad m => ManParser m RoffToken
memptyLine = msatisfy isRoffEmptyLine where memptyLine = msatisfy isEmptyLine where
isRoffEmptyLine RoffEmptyLine = True isEmptyLine EmptyLine = True
isRoffEmptyLine _ = False isEmptyLine _ = False
mmacro :: PandocMonad m => String -> ManParser m RoffToken mmacro :: PandocMonad m => String -> ManParser m RoffToken
mmacro mk = msatisfy isRoffControlLine where mmacro mk = msatisfy isControlLine where
isRoffControlLine (RoffControlLine mk' _ _) | mk == mk' = True isControlLine (ControlLine mk' _ _) | mk == mk' = True
| otherwise = False | otherwise = False
isRoffControlLine _ = False isControlLine _ = False
mmacroAny :: PandocMonad m => ManParser m RoffToken mmacroAny :: PandocMonad m => ManParser m RoffToken
mmacroAny = msatisfy isRoffControlLine where mmacroAny = msatisfy isControlLine where
isRoffControlLine RoffControlLine{} = True isControlLine ControlLine{} = True
isRoffControlLine _ = False isControlLine _ = False
-- --
-- RoffToken -> Block functions -- RoffToken -> Block functions
@ -234,7 +234,7 @@ mmacroAny = msatisfy isRoffControlLine where
parseTitle :: PandocMonad m => ManParser m Blocks parseTitle :: PandocMonad m => ManParser m Blocks
parseTitle = do parseTitle = do
(RoffControlLine _ args _) <- mmacro "TH" (ControlLine _ args _) <- mmacro "TH"
let adjustMeta = let adjustMeta =
case args of case args of
(x:y:z:_) -> setMeta "title" (linePartsToInlines x) . (x:y:z:_) -> setMeta "title" (linePartsToInlines x) .
@ -305,8 +305,8 @@ parseInline :: PandocMonad m => ManParser m Inlines
parseInline = try $ do parseInline = try $ do
tok <- mtoken tok <- mtoken
case tok of case tok of
RoffTextLine lparts -> return $ linePartsToInlines lparts TextLine lparts -> return $ linePartsToInlines lparts
RoffControlLine mname args pos -> handleInlineMacro mname args pos ControlLine mname args pos -> handleInlineMacro mname args pos
_ -> mzero _ -> mzero
handleInlineMacro :: PandocMonad m handleInlineMacro :: PandocMonad m
@ -337,14 +337,14 @@ handleInlineMacro mname args _pos = do
parseBold :: PandocMonad m => [Arg] -> ManParser m Inlines parseBold :: PandocMonad m => [Arg] -> ManParser m Inlines
parseBold [] = do parseBold [] = do
RoffTextLine lparts <- mline TextLine lparts <- mline
return $ strong $ linePartsToInlines lparts return $ strong $ linePartsToInlines lparts
parseBold args = return $ parseBold args = return $
strong $ mconcat $ intersperse B.space $ map linePartsToInlines args strong $ mconcat $ intersperse B.space $ map linePartsToInlines args
parseItalic :: PandocMonad m => [Arg] -> ManParser m Inlines parseItalic :: PandocMonad m => [Arg] -> ManParser m Inlines
parseItalic [] = do parseItalic [] = do
RoffTextLine lparts <- mline TextLine lparts <- mline
return $ emph $ linePartsToInlines lparts return $ emph $ linePartsToInlines lparts
parseItalic args = return $ parseItalic args = return $
emph $ mconcat $ intersperse B.space $ map linePartsToInlines args emph $ mconcat $ intersperse B.space $ map linePartsToInlines args
@ -358,12 +358,12 @@ parseAlternatingFonts constructors args = return $ mconcat $
lineInl :: PandocMonad m => ManParser m Inlines lineInl :: PandocMonad m => ManParser m Inlines
lineInl = do lineInl = do
(RoffTextLine fragments) <- mline (TextLine fragments) <- mline
return $ linePartsToInlines fragments return $ linePartsToInlines fragments
bareIP :: PandocMonad m => ManParser m RoffToken bareIP :: PandocMonad m => ManParser m RoffToken
bareIP = msatisfy isBareIP where bareIP = msatisfy isBareIP where
isBareIP (RoffControlLine "IP" [] _) = True isBareIP (ControlLine "IP" [] _) = True
isBareIP _ = False isBareIP _ = False
endmacro :: PandocMonad m => String -> ManParser m () endmacro :: PandocMonad m => String -> ManParser m ()
@ -372,8 +372,8 @@ endmacro name = void (mmacro name)
<|> lookAhead eof <|> lookAhead eof
where where
newBlockMacro = msatisfy isNewBlockMacro newBlockMacro = msatisfy isNewBlockMacro
isNewBlockMacro (RoffControlLine "SH" _ _) = True isNewBlockMacro (ControlLine "SH" _ _) = True
isNewBlockMacro (RoffControlLine "SS" _ _) = True isNewBlockMacro (ControlLine "SS" _ _) = True
isNewBlockMacro _ = False isNewBlockMacro _ = False
parseCodeBlock :: PandocMonad m => ManParser m Blocks parseCodeBlock :: PandocMonad m => ManParser m Blocks
@ -390,16 +390,16 @@ parseCodeBlock = try $ do
codeline = do codeline = do
tok <- mtoken tok <- mtoken
case tok of case tok of
RoffControlLine "PP" _ _ -> return $ Just "" -- .PP sometimes used for blank line ControlLine "PP" _ _ -> return $ Just "" -- .PP sometimes used for blank line
RoffControlLine mname args pos -> do ControlLine mname args pos -> do
(Just . query getText <$> handleInlineMacro mname args pos) <|> (Just . query getText <$> handleInlineMacro mname args pos) <|>
do report $ SkippedContent ('.':mname) pos do report $ SkippedContent ('.':mname) pos
return Nothing return Nothing
RoffTable _ _ pos -> do Tbl _ _ pos -> do
report $ SkippedContent "TABLE" pos report $ SkippedContent "TABLE" pos
return $ Just "TABLE" return $ Just "TABLE"
RoffEmptyLine -> return $ Just "" EmptyLine -> return $ Just ""
RoffTextLine ss TextLine ss
| not (null ss) | not (null ss)
, all isFontToken ss -> return Nothing , all isFontToken ss -> return Nothing
| otherwise -> return $ Just $ linePartsToString ss | otherwise -> return $ Just $ linePartsToString ss
@ -417,7 +417,7 @@ parseCodeBlock = try $ do
parseHeader :: PandocMonad m => ManParser m Blocks parseHeader :: PandocMonad m => ManParser m Blocks
parseHeader = do parseHeader = do
RoffControlLine name args _ <- mmacro "SH" <|> mmacro "SS" ControlLine name args _ <- mmacro "SH" <|> mmacro "SS"
contents <- if null args contents <- if null args
then lineInl then lineInl
else return $ mconcat $ intersperse B.space else return $ mconcat $ intersperse B.space
@ -440,7 +440,7 @@ listTypeMatches (Just _) _ = False
listItem :: PandocMonad m => Maybe ListType -> ManParser m (ListType, Blocks) listItem :: PandocMonad m => Maybe ListType -> ManParser m (ListType, Blocks)
listItem mbListType = try $ do listItem mbListType = try $ do
(RoffControlLine _ args _) <- mmacro "IP" (ControlLine _ args _) <- mmacro "IP"
case args of case args of
(arg1 : _) -> do (arg1 : _) -> do
let cs = linePartsToString arg1 let cs = linePartsToString arg1
@ -491,7 +491,7 @@ parseDefinitionList = definitionList <$> many1 definitionListItem
parseLink :: PandocMonad m => [Arg] -> ManParser m Inlines parseLink :: PandocMonad m => [Arg] -> ManParser m Inlines
parseLink args = do parseLink args = do
contents <- mconcat <$> many lineInl contents <- mconcat <$> many lineInl
RoffControlLine _ endargs _ <- mmacro "UE" ControlLine _ endargs _ <- mmacro "UE"
let url = case args of let url = case args of
[] -> "" [] -> ""
(x:_) -> linePartsToString x (x:_) -> linePartsToString x
@ -503,7 +503,7 @@ parseLink args = do
parseEmailLink :: PandocMonad m => [Arg] -> ManParser m Inlines parseEmailLink :: PandocMonad m => [Arg] -> ManParser m Inlines
parseEmailLink args = do parseEmailLink args = do
contents <- mconcat <$> many lineInl contents <- mconcat <$> many lineInl
RoffControlLine _ endargs _ <- mmacro "ME" ControlLine _ endargs _ <- mmacro "ME"
let url = case args of let url = case args of
[] -> "" [] -> ""
(x:_) -> "mailto:" ++ linePartsToString x (x:_) -> "mailto:" ++ linePartsToString x
@ -516,7 +516,7 @@ skipUnkownMacro :: PandocMonad m => ManParser m Blocks
skipUnkownMacro = do skipUnkownMacro = do
tok <- mmacroAny tok <- mmacroAny
case tok of case tok of
RoffControlLine mkind _ pos -> do ControlLine mkind _ pos -> do
report $ SkippedContent ('.':mkind) pos report $ SkippedContent ('.':mkind) pos
return mempty return mempty
_ -> fail "the impossible happened" _ -> fail "the impossible happened"

28
src/Text/Pandoc/Readers/Roff.hs
View file

@ -101,10 +101,10 @@ data CellFormat =
type TableRow = ([CellFormat], [RoffTokens]) type TableRow = ([CellFormat], [RoffTokens])
data RoffToken = RoffTextLine [LinePart] data RoffToken = TextLine [LinePart]
| RoffEmptyLine | EmptyLine
| RoffControlLine String [Arg] SourcePos | ControlLine String [Arg] SourcePos
| RoffTable [TableOption] [TableRow] SourcePos | Tbl [TableOption] [TableRow] SourcePos
deriving Show deriving Show
newtype RoffTokens = RoffTokens { unRoffTokens :: Seq.Seq RoffToken } newtype RoffTokens = RoffTokens { unRoffTokens :: Seq.Seq RoffToken }
@ -128,7 +128,7 @@ instance Default RoffState where
def = RoffState { customMacros = M.fromList def = RoffState { customMacros = M.fromList
$ map (\(n, s) -> $ map (\(n, s) ->
(n, singleTok (n, singleTok
(RoffTextLine [RoffStr s]))) (TextLine [RoffStr s])))
[ ("Tm", "\x2122") [ ("Tm", "\x2122")
, ("lq", "\x201C") , ("lq", "\x201C")
, ("rq", "\x201D") , ("rq", "\x201D")
@ -370,7 +370,7 @@ lexMacro = do
"de1" -> lexMacroDef args "de1" -> lexMacroDef args
"ds" -> lexStringDef args "ds" -> lexStringDef args
"ds1" -> lexStringDef args "ds1" -> lexStringDef args
"sp" -> return $ singleTok RoffEmptyLine "sp" -> return $ singleTok EmptyLine
"so" -> lexIncludeFile args "so" -> lexIncludeFile args
_ -> resolveMacro macroName args pos _ -> resolveMacro macroName args pos
@ -394,7 +394,7 @@ lexTable pos = do
string ".TE" string ".TE"
skipMany spacetab skipMany spacetab
eofline eofline
return $ singleTok $ RoffTable opts (rows ++ concat morerows) pos return $ singleTok $ Tbl opts (rows ++ concat morerows) pos
lexTableRows :: PandocMonad m => RoffLexer m [TableRow] lexTableRows :: PandocMonad m => RoffLexer m [TableRow]
lexTableRows = do lexTableRows = do
@ -531,15 +531,15 @@ resolveMacro :: PandocMonad m
resolveMacro macroName args pos = do resolveMacro macroName args pos = do
macros <- customMacros <$> getState macros <- customMacros <$> getState
case M.lookup macroName macros of case M.lookup macroName macros of
Nothing -> return $ singleTok $ RoffControlLine macroName args pos Nothing -> return $ singleTok $ ControlLine macroName args pos
Just ts -> do Just ts -> do
let fillLP (MacroArg i) zs = let fillLP (MacroArg i) zs =
case drop (i - 1) args of case drop (i - 1) args of
[] -> zs [] -> zs
(ys:_) -> ys ++ zs (ys:_) -> ys ++ zs
fillLP z zs = z : zs fillLP z zs = z : zs
let fillMacroArg (RoffTextLine lineparts) = let fillMacroArg (TextLine lineparts) =
RoffTextLine (foldr fillLP [] lineparts) TextLine (foldr fillLP [] lineparts)
fillMacroArg x = x fillMacroArg x = x
return $ RoffTokens . fmap fillMacroArg . unRoffTokens $ ts return $ RoffTokens . fmap fillMacroArg . unRoffTokens $ ts
@ -548,7 +548,7 @@ lexStringDef args = do -- string definition
case args of case args of
[] -> fail "No argument to .ds" [] -> fail "No argument to .ds"
(x:ys) -> do (x:ys) -> do
let ts = singleTok $ RoffTextLine (intercalate [RoffStr " " ] ys) let ts = singleTok $ TextLine (intercalate [RoffStr " " ] ys)
let stringName = linePartsToString x let stringName = linePartsToString x
modifyState $ \st -> modifyState $ \st ->
st{ customMacros = M.insert stringName ts (customMacros st) } st{ customMacros = M.insert stringName ts (customMacros st) }
@ -631,7 +631,7 @@ escString = try $ do
resolveString stringname pos = do resolveString stringname pos = do
RoffTokens ts <- resolveMacro stringname [] pos RoffTokens ts <- resolveMacro stringname [] pos
case Foldable.toList ts of case Foldable.toList ts of
[RoffTextLine xs] -> return xs [TextLine xs] -> return xs
_ -> do _ -> do
report $ SkippedContent ("unknown string " ++ stringname) pos report $ SkippedContent ("unknown string " ++ stringname) pos
return mempty return mempty
@ -649,7 +649,7 @@ lexLine = do
-- this can happen if the line just contains \f[C], for example. -- this can happen if the line just contains \f[C], for example.
go [] = return mempty go [] = return mempty
go (RoffStr "" : xs) = go xs go (RoffStr "" : xs) = go xs
go xs = return $ singleTok $ RoffTextLine xs go xs = return $ singleTok $ TextLine xs
linePart :: PandocMonad m => RoffLexer m [LinePart] linePart :: PandocMonad m => RoffLexer m [LinePart]
linePart = macroArg <|> escape <|> linePart = macroArg <|> escape <|>
@ -694,7 +694,7 @@ spaceTabChar = do
return [RoffStr [c]] return [RoffStr [c]]
lexEmptyLine :: PandocMonad m => RoffLexer m RoffTokens lexEmptyLine :: PandocMonad m => RoffLexer m RoffTokens
lexEmptyLine = newline >> return (singleTok RoffEmptyLine) lexEmptyLine = newline >> return (singleTok EmptyLine)
manToken :: PandocMonad m => RoffLexer m RoffTokens manToken :: PandocMonad m => RoffLexer m RoffTokens
manToken = lexComment <|> lexMacro <|> lexLine <|> lexEmptyLine manToken = lexComment <|> lexMacro <|> lexLine <|> lexEmptyLine