diff options
author | John MacFarlane <fiddlosopher@gmail.com> | 2013-11-17 08:45:21 -0800 |
---|---|---|
committer | John MacFarlane <fiddlosopher@gmail.com> | 2013-11-17 08:45:21 -0800 |
commit | d5660275a38a58334372326a79a9ce0153fede43 (patch) | |
tree | defaa310188ad142ed797873913764fa56665ae7 /src/Text | |
parent | 9b0378b939f46183fc152b1a49a69f3007de295a (diff) | |
download | pandoc-d5660275a38a58334372326a79a9ce0153fede43.tar.gz |
Parsing: Generalized type of registerHeader, using new typeclasses.
New type classes HasReadeOptions, HasIdentifierList, HasHeaderMap.
These allow certain common functions to be reused even in parsers
that use custom state (instead of ParserState), such as the MediaWiki
reader.
Minor API bump.
Diffstat (limited to 'src/Text')
-rw-r--r-- | src/Text/Pandoc/Parsing.hs | 54 |
1 files changed, 42 insertions, 12 deletions
diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index 701b2ef84..9687d7712 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, + FlexibleInstances#-} {- Copyright (C) 2006-2010 John MacFarlane <jgm@berkeley.edu> @@ -65,6 +66,9 @@ module Text.Pandoc.Parsing ( (>>~), guardEnabled, guardDisabled, ParserState (..), + HasReaderOptions (..), + HasHeaderMap (..), + HasIdentifierList (..), defaultParserState, HeaderType (..), ParserContext (..), @@ -826,6 +830,34 @@ instance HasMeta ParserState where deleteMeta field st = st{ stateMeta = deleteMeta field $ stateMeta st } +class Monad m => HasReaderOptions m where + askReaderOption :: (ReaderOptions -> b) -> m b + +class Monad m => HasHeaderMap m where + getHeaderMap :: m (M.Map Inlines String) + putHeaderMap :: M.Map Inlines String -> m () + modifyHeaderMap :: (M.Map Inlines String -> M.Map Inlines String) -> m () + -- default + modifyHeaderMap f = getHeaderMap >>= putHeaderMap . f + +class Monad m => HasIdentifierList m where + getIdentifierList :: m [String] + putIdentifierList :: [String] -> m () + modifyIdentifierList :: ([String] -> [String]) -> m () + -- default + modifyIdentifierList f = getIdentifierList >>= putIdentifierList . f + +instance HasReaderOptions (Parser s ParserState) where + askReaderOption = getOption + +instance HasHeaderMap (Parser s ParserState) where + getHeaderMap = fmap stateHeaders getState + putHeaderMap hm = updateState $ \st -> st{ stateHeaders = hm } + +instance HasIdentifierList (Parser s ParserState) where + getIdentifierList = fmap stateIdentifiers getState + putIdentifierList l = updateState $ \st -> st{ stateIdentifiers = l } + defaultParserState :: ParserState defaultParserState = ParserState { stateOptions = def, @@ -895,10 +927,11 @@ type SubstTable = M.Map Key Inlines -- and the auto_identifers extension is set, generate a new -- unique identifier, and update the list of identifiers -- in state. -registerHeader :: Attr -> Inlines -> Parser s ParserState Attr +registerHeader :: (HasReaderOptions m, HasHeaderMap m, HasIdentifierList m) + => Attr -> Inlines -> m Attr registerHeader (ident,classes,kvs) header' = do - ids <- stateIdentifiers `fmap` getState - exts <- getOption readerExtensions + ids <- getIdentifierList + exts <- askReaderOption readerExtensions let insert' = M.insertWith (\_new old -> old) if null ident && Ext_auto_identifiers `Set.member` exts then do @@ -906,16 +939,13 @@ registerHeader (ident,classes,kvs) header' = do let id'' = if Ext_ascii_identifiers `Set.member` exts then catMaybes $ map toAsciiChar id' else id' - updateState $ \st -> st{ - stateIdentifiers = if id' == id'' - then id' : ids - else id' : id'' : ids, - stateHeaders = insert' header' id' $ stateHeaders st } + putIdentifierList $ if id' == id'' + then id' : ids + else id' : id'' : ids + modifyHeaderMap $ insert' header' id' return (id'',classes,kvs) else do - unless (null ident) $ - updateState $ \st -> st{ - stateHeaders = insert' header' ident $ stateHeaders st } + unless (null ident) $ modifyHeaderMap $ insert' header' ident return (ident,classes,kvs) -- | Fail unless we're in "smart typography" mode. |