Parsing: introduce HasIncludeFiles type class

The `insertIncludeFile` function is generalized to work with all parser
states which are instances of that class.
This commit is contained in:
Albert Krewinkel 2017-05-14 10:00:58 +02:00
parent 7a17c3eb9f
commit 5ff6108b4c
No known key found for this signature in database
GPG key ID: 388DC0B21F631124

View file

@ -83,6 +83,7 @@ module Text.Pandoc.Parsing ( anyLine,
HasMacros (..), HasMacros (..),
HasLogMessages (..), HasLogMessages (..),
HasLastStrPosition (..), HasLastStrPosition (..),
HasIncludeFiles (..),
defaultParserState, defaultParserState,
HeaderType (..), HeaderType (..),
ParserContext (..), ParserContext (..),
@ -1008,6 +1009,9 @@ class HasReaderOptions st where
-- default -- default
getOption f = (f . extractReaderOptions) <$> getState getOption f = (f . extractReaderOptions) <$> getState
instance HasReaderOptions ParserState where
extractReaderOptions = stateOptions
class HasQuoteContext st m where class HasQuoteContext st m where
getQuoteContext :: (Stream s m t) => ParsecT s st m QuoteContext getQuoteContext :: (Stream s m t) => ParsecT s st m QuoteContext
withQuoteContext :: QuoteContext -> ParsecT s st m a -> ParsecT s st m a withQuoteContext :: QuoteContext -> ParsecT s st m a -> ParsecT s st m a
@ -1023,9 +1027,6 @@ instance Monad m => HasQuoteContext ParserState m where
setState newState { stateQuoteContext = oldQuoteContext } setState newState { stateQuoteContext = oldQuoteContext }
return result return result
instance HasReaderOptions ParserState where
extractReaderOptions = stateOptions
class HasHeaderMap st where class HasHeaderMap st where
extractHeaderMap :: st -> M.Map Inlines String extractHeaderMap :: st -> M.Map Inlines String
updateHeaderMap :: (M.Map Inlines String -> M.Map Inlines String) -> updateHeaderMap :: (M.Map Inlines String -> M.Map Inlines String) ->
@ -1067,6 +1068,16 @@ instance HasLogMessages ParserState where
addLogMessage msg st = st{ stateLogMessages = msg : stateLogMessages st } addLogMessage msg st = st{ stateLogMessages = msg : stateLogMessages st }
getLogMessages st = reverse $ stateLogMessages st getLogMessages st = reverse $ stateLogMessages st
class HasIncludeFiles st where
getIncludeFiles :: st -> [String]
addIncludeFile :: String -> st -> st
dropLatestIncludeFile :: st -> st
instance HasIncludeFiles ParserState where
getIncludeFiles = stateContainers
addIncludeFile f s = s{ stateContainers = f : stateContainers s }
dropLatestIncludeFile s = s { stateContainers = drop 1 $ stateContainers s }
defaultParserState :: ParserState defaultParserState :: ParserState
defaultParserState = defaultParserState =
ParserState { stateOptions = def, ParserState { stateOptions = def,
@ -1358,17 +1369,19 @@ extractIdClass (ident, cls, kvs) = (ident', cls', kvs')
Nothing -> cls Nothing -> cls
kvs' = filter (\(k,_) -> k /= "id" || k /= "class") kvs kvs' = filter (\(k,_) -> k /= "id" || k /= "class") kvs
insertIncludedFile :: PandocMonad m -- | Parse content of include file as blocks. Circular includes result in an
=> ParserT String ParserState m Blocks -- @PandocParseError@.
insertIncludedFile :: (PandocMonad m, HasIncludeFiles st)
=> ParserT String st m Blocks
-> [FilePath] -> FilePath -> [FilePath] -> FilePath
-> ParserT String ParserState m Blocks -> ParserT String st m Blocks
insertIncludedFile blocks dirs f = do insertIncludedFile blocks dirs f = do
oldPos <- getPosition oldPos <- getPosition
oldInput <- getInput oldInput <- getInput
containers <- stateContainers <$> getState containers <- getIncludeFiles <$> getState
when (f `elem` containers) $ when (f `elem` containers) $
throwError $ PandocParseError $ "Include file loop at " ++ show oldPos throwError $ PandocParseError $ "Include file loop at " ++ show oldPos
updateState $ \s -> s{ stateContainers = f : stateContainers s } updateState $ addIncludeFile f
mbcontents <- readFileFromDirs dirs f mbcontents <- readFileFromDirs dirs f
contents <- case mbcontents of contents <- case mbcontents of
Just s -> return s Just s -> return s
@ -1380,5 +1393,5 @@ insertIncludedFile blocks dirs f = do
bs <- blocks bs <- blocks
setInput oldInput setInput oldInput
setPosition oldPos setPosition oldPos
updateState $ \s -> s{ stateContainers = drop 1 $ stateContainers s } updateState dropLatestIncludeFile
return bs return bs