aca87bb · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Revert "Revert "Revert "Roff reader: custom Stream type."""

aca87bbJohn MacFarlane8 years ago

src/Text/Pandoc/Readers/Roff.hs+27−51

compare with master

unifiedsplit

@@ -1,7 +1,4 @@

1{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-

3{-

@@ -51,9 +48,8 @@ where

52import Prelude

49import Prelude

53import Safe (lastDef)

50import Safe (lastDef)

54−import Control.Monad (void, mzero, mplus, guard)

51+import Control.Monad (void, mzero, mplus)

55import Control.Monad.Except (throwError)

52import Control.Monad.Except (throwError)

56−import Control.Monad.State (StateT(..), evalStateT, get, modify, put)

57import Text.Pandoc.Class

53import Text.Pandoc.Class

58 (getResourcePath, readFileFromDirs, PandocMonad(..), report)

54 (getResourcePath, readFileFromDirs, PandocMonad(..), report)

59import Data.Char (isLower, toLower, toUpper, chr,

55import Data.Char (isLower, toLower, toUpper, chr,

@@ -121,7 +117,8 @@ data RoffMode = NormalMode

121 | CopyMode

117 | CopyMode

122 deriving Show

118 deriving Show

123

119

120+data RoffState = RoffState { customMacros :: M.Map String RoffTokens

124−data RoffState = RoffState { prevFont :: FontSpec

121+ , prevFont :: FontSpec

125 , currentFont :: FontSpec

122 , currentFont :: FontSpec

126 , tableTabChar :: Char

123 , tableTabChar :: Char

127 , roffMode :: RoffMode

124 , roffMode :: RoffMode

@@ -129,17 +126,7 @@ data RoffState = RoffState { prevFont :: FontSpec

129 } deriving Show

126 } deriving Show

130

127

131instance Default RoffState where

128instance Default RoffState where

132− def = RoffState { prevFont = defaultFontSpec

129+ def = RoffState { customMacros = M.fromList

133− , currentFont = defaultFontSpec

134− , tableTabChar = '\t'

135− , roffMode = NormalMode

136− , lastExpression = Nothing

137− }

138−

139−type MacroState = M.Map String RoffTokens

140−

141−initialMacroState :: MacroState

142−initialMacroState = M.fromList

143 $ map (\(n, s) ->

130 $ map (\(n, s) ->

144 (n, singleTok

131 (n, singleTok

145 (TextLine [RoffStr s])))

132 (TextLine [RoffStr s])))

@@ -147,19 +134,14 @@ initialMacroState = M.fromList

147 , ("lq", "\x201C")

134 , ("lq", "\x201C")

148 , ("rq", "\x201D")

135 , ("rq", "\x201D")

149 , ("R", "\x00AE") ]

136 , ("R", "\x00AE") ]

137+ , prevFont = defaultFontSpec

138+ , currentFont = defaultFontSpec

139+ , tableTabChar = '\t'

140+ , roffMode = NormalMode

141+ , lastExpression = Nothing

142+ }

150

143

151−newtype RoffStream = RoffStream{ unRoffStream :: [Char] }

152− deriving (Show)

153−

154−deriving instance Semigroup RoffStream

155−deriving instance Monoid RoffStream

156−

157−instance Monad m => Stream RoffStream (StateT MacroState m) Char

158− where

159− uncons (RoffStream []) = return Nothing

160− uncons (RoffStream (c:cs)) = return (Just (c, RoffStream cs))

161−

162−type RoffLexer m = ParserT RoffStream RoffState (StateT MacroState m)

144+type RoffLexer m = ParserT [Char] RoffState m

163

145

164--

146--

165-- Lexer: String -> RoffToken

147-- Lexer: String -> RoffToken

@@ -230,14 +212,14 @@ readUnicodeChar _ = Nothing

230escapeNormal :: PandocMonad m => RoffLexer m [LinePart]

212escapeNormal :: PandocMonad m => RoffLexer m [LinePart]

231escapeNormal = do

213escapeNormal = do

232 c <- anyChar

214 c <- anyChar

233− (case c of

215+ case c of

234 ' ' -> return [RoffStr " "]

216 ' ' -> return [RoffStr " "]

235 '"' -> mempty <$ skipMany (satisfy (/='\n')) -- line comment

217 '"' -> mempty <$ skipMany (satisfy (/='\n')) -- line comment

236 '#' -> mempty <$ manyTill anyChar newline

218 '#' -> mempty <$ manyTill anyChar newline

237 '%' -> return mempty -- optional hyphenation

219 '%' -> return mempty -- optional hyphenation

238 '&' -> return mempty -- nonprintable zero-width

220 '&' -> return mempty -- nonprintable zero-width

239 ')' -> return mempty -- nonprintable zero-width

221 ')' -> return mempty -- nonprintable zero-width

240− '*' -> escString <|> escIgnore '*' []

222+ '*' -> escString

241 ',' -> return mempty -- to fix spacing after roman

223 ',' -> return mempty -- to fix spacing after roman

242 '-' -> return [RoffStr "-"]

224 '-' -> return [RoffStr "-"]

243 '.' -> return [RoffStr "`"]

225 '.' -> return [RoffStr "`"]

@@ -301,7 +283,7 @@ escapeNormal = do

301 CopyMode -> char '\\'

283 CopyMode -> char '\\'

302 NormalMode -> return '\\'

284 NormalMode -> return '\\'

303 return [RoffStr "\\"]

285 return [RoffStr "\\"]

304− _ -> return [RoffStr [c]]) <|> escIgnore c []

286+ _ -> return [RoffStr [c]]

305 -- man 7 groff: "If a backslash is followed by a character that

287 -- man 7 groff: "If a backslash is followed by a character that

306 -- does not constitute a defined escape sequence, the backslash

288 -- does not constitute a defined escape sequence, the backslash

307 -- is silently ignored and the character maps to itself."

289 -- is silently ignored and the character maps to itself."

@@ -312,8 +294,7 @@ escIgnore :: PandocMonad m

312 -> RoffLexer m [LinePart]

294 -> RoffLexer m [LinePart]

313escIgnore c argparsers = do

295escIgnore c argparsers = do

314 pos <- getPosition

296 pos <- getPosition

315− pos' <- (optional (choice argparsers) >> getPosition)

297+ arg <- snd <$> withRaw (choice argparsers) <|> return ""

316− arg <- manyTill anyChar (getPosition >>= guard . (== pos'))

317 report $ SkippedContent ('\\':c:arg) pos

298 report $ SkippedContent ('\\':c:arg) pos

318 return mempty

299 return mempty

319

300

@@ -515,20 +496,17 @@ lexConditional mname = do

515 then fmap not . lastExpression <$> getState

496 then fmap not . lastExpression <$> getState

516 else expression

497 else expression

517 skipMany spacetab

498 skipMany spacetab

518− macros <- get -- save macro state, so we can reset it

499+ st <- getState -- save state, so we can reset it

519− st <- getState

520 ifPart <- lexGroup

500 ifPart <- lexGroup

521 <|> (char '\\' >> newline >> manToken)

501 <|> (char '\\' >> newline >> manToken)

522 <|> manToken

502 <|> manToken

523 case mbtest of

503 case mbtest of

524 Nothing -> do

504 Nothing -> do

525− put macros -- reset state, so we don't record macros in skipped section

505+ putState st -- reset state, so we don't record macros in skipped section

526− putState st

527 report $ SkippedContent ('.':mname) pos

506 report $ SkippedContent ('.':mname) pos

528 return mempty

507 return mempty

529 Just True -> return ifPart

508 Just True -> return ifPart

530 Just False -> do

509 Just False -> do

531− put macros

532 putState st

510 putState st

533 return mempty

511 return mempty

534

512

@@ -565,14 +543,14 @@ lexIncludeFile args = do

565 result <- readFileFromDirs dirs fp

543 result <- readFileFromDirs dirs fp

566 case result of

544 case result of

567 Nothing -> report $ CouldNotLoadIncludeFile fp pos

545 Nothing -> report $ CouldNotLoadIncludeFile fp pos

568− Just s -> getInput >>= setInput . (RoffStream s <>) -- TODO sourcepos!

546+ Just s -> getInput >>= setInput . (s ++)

569 return mempty

547 return mempty

570 [] -> return mempty

548 [] -> return mempty

571

549

572resolveMacro :: PandocMonad m

550resolveMacro :: PandocMonad m

573 => String -> [Arg] -> SourcePos -> RoffLexer m RoffTokens

551 => String -> [Arg] -> SourcePos -> RoffLexer m RoffTokens

574resolveMacro macroName args pos = do

552resolveMacro macroName args pos = do

575− macros <- get

553+ macros <- customMacros <$> getState

576 case M.lookup macroName macros of

554 case M.lookup macroName macros of

577 Nothing -> return $ singleTok $ ControlLine macroName args pos

555 Nothing -> return $ singleTok $ ControlLine macroName args pos

578 Just ts -> do

556 Just ts -> do

@@ -593,7 +571,8 @@ lexStringDef args = do -- string definition

593 (x:ys) -> do

571 (x:ys) -> do

594 let ts = singleTok $ TextLine (intercalate [RoffStr " " ] ys)

572 let ts = singleTok $ TextLine (intercalate [RoffStr " " ] ys)

595 let stringName = linePartsToString x

573 let stringName = linePartsToString x

574+ modifyState $ \st ->

596− modify (M.insert stringName ts)

575+ st{ customMacros = M.insert stringName ts (customMacros st) }

597 return mempty

576 return mempty

598

577

599lexMacroDef :: PandocMonad m => [Arg] -> RoffLexer m RoffTokens

578lexMacroDef :: PandocMonad m => [Arg] -> RoffLexer m RoffTokens

@@ -612,8 +591,9 @@ lexMacroDef args = do -- macro definition

612 _ <- lexArgs

591 _ <- lexArgs

613 return ()

592 return ()

614 ts <- mconcat <$> manyTill manToken stop

593 ts <- mconcat <$> manyTill manToken stop

594+ modifyState $ \st ->

615− modify (M.insert macroName ts)

595+ st{ customMacros = M.insert macroName ts (customMacros st)

616− modifyState $ \st -> st{ roffMode = NormalMode }

596+ , roffMode = NormalMode }

617 return mempty

597 return mempty

618

598

619lexArgs :: PandocMonad m => RoffLexer m [Arg]

599lexArgs :: PandocMonad m => RoffLexer m [Arg]

@@ -655,7 +635,7 @@ lexArgs = do

655

635

656checkDefined :: PandocMonad m => String -> RoffLexer m [LinePart]

636checkDefined :: PandocMonad m => String -> RoffLexer m [LinePart]

657checkDefined name = do

637checkDefined name = do

658− macros <- get

638+ macros <- customMacros <$> getState

659 case M.lookup name macros of

639 case M.lookup name macros of

660 Just _ -> return [RoffStr "1"]

640 Just _ -> return [RoffStr "1"]

661 Nothing -> return [RoffStr "0"]

641 Nothing -> return [RoffStr "0"]

@@ -749,12 +729,8 @@ linePartsToString = mconcat . map go

749-- | Tokenize a string as a sequence of roff tokens.

729-- | Tokenize a string as a sequence of roff tokens.

750lexRoff :: PandocMonad m => SourcePos -> T.Text -> m RoffTokens

730lexRoff :: PandocMonad m => SourcePos -> T.Text -> m RoffTokens

751lexRoff pos txt = do

731lexRoff pos txt = do

752− eithertokens <- evalStateT

753− (readWithM

754− (do setPosition pos

732+ eithertokens <- readWithM (do setPosition pos

755− mconcat <$> many manToken) def

733+ mconcat <$> many manToken) def (T.unpack txt)

756− (RoffStream (T.unpack txt)))

757− initialMacroState

758 case eithertokens of

734 case eithertokens of

759 Left e -> throwError e

735 Left e -> throwError e

760 Right tokenz -> return tokenz

736 Right tokenz -> return tokenz