@@ -1,4 +1,7 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE StandaloneDeriving #-}
25{-# LANGUAGE GeneralizedNewtypeDeriving #-}
36{-
47 Copyright (C) 2018 Yan Pashkovsky <yanp.bugz@gmail.com>
@@ -48,8 +51,9 @@ where
4851
4952import Prelude
5053import Safe (lastDef)
51−import Control.Monad (void, mzero, mplus)
54+import Control.Monad (void, mzero, mplus, guard)
5255import Control.Monad.Except (throwError)
56+import Control.Monad.State.Strict (StateT(..), evalStateT, get, modify, put)
5357import Text.Pandoc.Class
5458 (getResourcePath, readFileFromDirs, PandocMonad(..), report)
5559import Data.Char (isLower, toLower, toUpper, chr,
@@ -117,8 +121,7 @@ data RoffMode = NormalMode
117121 | CopyMode
118122 deriving Show
119123
120−data RoffState = RoffState { customMacros :: M.Map String RoffTokens
121− , prevFont :: FontSpec
124+data RoffState = RoffState { prevFont :: FontSpec
122125 , currentFont :: FontSpec
123126 , tableTabChar :: Char
124127 , roffMode :: RoffMode
@@ -126,7 +129,17 @@ data RoffState = RoffState { customMacros :: M.Map String RoffTokens
126129 } deriving Show
127130
128131instance Default RoffState where
129− def = RoffState { customMacros = M.fromList
132+ def = RoffState { prevFont = defaultFontSpec
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
130143 $ map (\(n, s) ->
131144 (n, singleTok
132145 (TextLine [RoffStr s])))
@@ -134,14 +147,19 @@ instance Default RoffState where
134147 , ("lq", "\x201C")
135148 , ("rq", "\x201D")
136149 , ("R", "\x00AE") ]
137− , prevFont = defaultFontSpec
138− , currentFont = defaultFontSpec
139− , tableTabChar = '\t'
140− , roffMode = NormalMode
141− , lastExpression = Nothing
142− }
143150
144−type RoffLexer m = ParserT [Char] RoffState m
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)
145163
146164--
147165-- Lexer: String -> RoffToken
@@ -212,14 +230,14 @@ readUnicodeChar _ = Nothing
212230escapeNormal :: PandocMonad m => RoffLexer m [LinePart]
213231escapeNormal = do
214232 c <- anyChar
215− case c of
233+ (case c of
216234 ' ' -> return [RoffStr " "]
217235 '"' -> mempty <$ skipMany (satisfy (/='\n')) -- line comment
218236 '#' -> mempty <$ manyTill anyChar newline
219237 '%' -> return mempty -- optional hyphenation
220238 '&' -> return mempty -- nonprintable zero-width
221239 ')' -> return mempty -- nonprintable zero-width
222− '*' -> escString
240+ '*' -> escString <|> escIgnore '*' []
223241 ',' -> return mempty -- to fix spacing after roman
224242 '-' -> return [RoffStr "-"]
225243 '.' -> return [RoffStr "`"]
@@ -283,7 +301,7 @@ escapeNormal = do
283301 CopyMode -> char '\\'
284302 NormalMode -> return '\\'
285303 return [RoffStr "\\"]
286− _ -> return [RoffStr [c]]
304+ _ -> return [RoffStr [c]]) <|> escIgnore c []
287305 -- man 7 groff: "If a backslash is followed by a character that
288306 -- does not constitute a defined escape sequence, the backslash
289307 -- is silently ignored and the character maps to itself."
@@ -294,7 +312,8 @@ escIgnore :: PandocMonad m
294312 -> RoffLexer m [LinePart]
295313escIgnore c argparsers = do
296314 pos <- getPosition
297− arg <- snd <$> withRaw (choice argparsers) <|> return ""
315+ pos' <- (optional (choice argparsers) >> getPosition)
316+ arg <- manyTill anyChar (getPosition >>= guard . (== pos'))
298317 report $ SkippedContent ('\\':c:arg) pos
299318 return mempty
300319
@@ -496,17 +515,20 @@ lexConditional mname = do
496515 then fmap not . lastExpression <$> getState
497516 else expression
498517 skipMany spacetab
499− st <- getState -- save state, so we can reset it
518+ macros <- get -- save macro state, so we can reset it
519+ st <- getState
500520 ifPart <- lexGroup
501521 <|> (char '\\' >> newline >> manToken)
502522 <|> manToken
503523 case mbtest of
504524 Nothing -> do
505− putState st -- reset state, so we don't record macros in skipped section
525+ put macros -- reset state, so we don't record macros in skipped section
526+ putState st
506527 report $ SkippedContent ('.':mname) pos
507528 return mempty
508529 Just True -> return ifPart
509530 Just False -> do
531+ put macros
510532 putState st
511533 return mempty
512534
@@ -543,14 +565,14 @@ lexIncludeFile args = do
543565 result <- readFileFromDirs dirs fp
544566 case result of
545567 Nothing -> report $ CouldNotLoadIncludeFile fp pos
546− Just s -> getInput >>= setInput . (s ++)
568+ Just s -> getInput >>= setInput . (RoffStream s <>) -- TODO sourcepos!
547569 return mempty
548570 [] -> return mempty
549571
550572resolveMacro :: PandocMonad m
551573 => String -> [Arg] -> SourcePos -> RoffLexer m RoffTokens
552574resolveMacro macroName args pos = do
553− macros <- customMacros <$> getState
575+ macros <- get
554576 case M.lookup macroName macros of
555577 Nothing -> return $ singleTok $ ControlLine macroName args pos
556578 Just ts -> do
@@ -571,8 +593,7 @@ lexStringDef args = do -- string definition
571593 (x:ys) -> do
572594 let ts = singleTok $ TextLine (intercalate [RoffStr " " ] ys)
573595 let stringName = linePartsToString x
574− modifyState $ \st ->
575− st{ customMacros = M.insert stringName ts (customMacros st) }
596+ modify (M.insert stringName ts)
576597 return mempty
577598
578599lexMacroDef :: PandocMonad m => [Arg] -> RoffLexer m RoffTokens
@@ -591,9 +612,8 @@ lexMacroDef args = do -- macro definition
591612 _ <- lexArgs
592613 return ()
593614 ts <- mconcat <$> manyTill manToken stop
594− modifyState $ \st ->
595− st{ customMacros = M.insert macroName ts (customMacros st)
596− , roffMode = NormalMode }
615+ modify (M.insert macroName ts)
616+ modifyState $ \st -> st{ roffMode = NormalMode }
597617 return mempty
598618
599619lexArgs :: PandocMonad m => RoffLexer m [Arg]
@@ -635,7 +655,7 @@ lexArgs = do
635655
636656checkDefined :: PandocMonad m => String -> RoffLexer m [LinePart]
637657checkDefined name = do
638− macros <- customMacros <$> getState
658+ macros <- get
639659 case M.lookup name macros of
640660 Just _ -> return [RoffStr "1"]
641661 Nothing -> return [RoffStr "0"]
@@ -729,8 +749,12 @@ linePartsToString = mconcat . map go
729749-- | Tokenize a string as a sequence of roff tokens.
730750lexRoff :: PandocMonad m => SourcePos -> T.Text -> m RoffTokens
731751lexRoff pos txt = do
732− eithertokens <- readWithM (do setPosition pos
733− mconcat <$> many manToken) def (T.unpack txt)
752+ eithertokens <- evalStateT
753+ (readWithM
754+ (do setPosition pos
755+ mconcat <$> many manToken) def
756+ (RoffStream (T.unpack txt)))
757+ initialMacroState
734758 case eithertokens of
735759 Left e -> throwError e
736760 Right tokenz -> return tokenz