@@ -44,6 +44,7 @@ even though it is supported only in Emacs Muse.
4444-}
4545module Text.Pandoc.Writers.Muse (writeMuse) where
4646import Prelude
47+import Control.Monad.Reader
4748import Control.Monad.State.Strict
4849import Data.Char (isSpace, isDigit, isAsciiUpper, isAsciiLower)
4950import Data.Text (Text)
@@ -61,15 +62,22 @@ import Text.Pandoc.Writers.Shared
6162import qualified Data.Set as Set
6263
6364type Notes = [[Block]]
65+
66+type Muse m = ReaderT WriterEnv (StateT WriterState m)
67+
68+data WriterEnv =
69+ WriterEnv { envOptions :: WriterOptions
70+ , envTopLevel :: Bool
71+ , envInsideBlock :: Bool
72+ }
73+
6474data WriterState =
6575 WriterState { stNotes :: Notes
66− , stOptions :: WriterOptions
67− , stTopLevel :: Bool
68− , stInsideBlock :: Bool
6976 , stIds :: Set.Set String
7077 }
7178
72−type Muse = StateT WriterState
79+evalMuse :: PandocMonad m => Muse m a -> WriterEnv -> WriterState -> m a
80+evalMuse document env st = evalStateT (runReaderT document env) st
7381
7482-- | Convert Pandoc to Muse.
7583writeMuse :: PandocMonad m
@@ -77,20 +85,21 @@ writeMuse :: PandocMonad m
7785 -> Pandoc
7886 -> m Text
7987writeMuse opts document =
80− let st = WriterState { stNotes = []
81− , stOptions = opts
82− , stTopLevel = True
83− , stInsideBlock = False
84− , stIds = Set.empty
85− }
86− in evalStateT (pandocToMuse document) st
88+ evalMuse (pandocToMuse document) env st
89+ where env = WriterEnv { envOptions = opts
90+ , envTopLevel = True
91+ , envInsideBlock = False
92+ }
93+ st = WriterState { stNotes = []
94+ , stIds = Set.empty
95+ }
8796
8897-- | Return Muse representation of document.
8998pandocToMuse :: PandocMonad m
9099 => Pandoc
91100 -> Muse m Text
92101pandocToMuse (Pandoc meta blocks) = do
93− opts <- gets stOptions
102+ opts <- asks envOptions
94103 let colwidth = if writerWrapText opts == WrapAuto
95104 then Just $ writerColumns opts
96105 else Nothing
@@ -121,7 +130,7 @@ catWithBlankLines (b : bs) n = do
121130catWithBlankLines _ _ = error "Expected at least one block"
122131
123132-- | Convert list of Pandoc block elements to Muse
124−-- | without setting stTopLevel.
133+-- | without setting envTopLevel.
125134flatBlockListToMuse :: PandocMonad m
126135 => [Block] -- ^ List of block elements
127136 -> Muse m Doc
@@ -141,16 +150,10 @@ flatBlockListToMuse [] = return mempty
141150blockListToMuse :: PandocMonad m
142151 => [Block] -- ^ List of block elements
143152 -> Muse m Doc
144−blockListToMuse blocks = do
145− oldState <- get
146− modify $ \s -> s { stTopLevel = not $ stInsideBlock s
147− , stInsideBlock = True
148− }
149− result <- flatBlockListToMuse blocks
150− modify $ \s -> s { stTopLevel = stTopLevel oldState
151− , stInsideBlock = stInsideBlock oldState
152− }
153− return result
153+blockListToMuse =
154+ local (\env -> env { envTopLevel = not (envInsideBlock env)
155+ , envInsideBlock = True
156+ }) . flatBlockListToMuse
154157
155158-- | Convert Pandoc block element to Muse.
156159blockToMuse :: PandocMonad m
@@ -180,7 +183,7 @@ blockToMuse (OrderedList (start, style, _) items) = do
180183 (start, style, Period)
181184 contents <- zipWithM orderedListItemToMuse markers items
182185 -- ensure that sublists have preceding blank line
183− topLevel <- gets stTopLevel
186+ topLevel <- asks envTopLevel
184187 return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
185188 where orderedListItemToMuse :: PandocMonad m
186189 => String -- ^ marker for list item
@@ -192,7 +195,7 @@ blockToMuse (OrderedList (start, style, _) items) = do
192195blockToMuse (BulletList items) = do
193196 contents <- mapM bulletListItemToMuse items
194197 -- ensure that sublists have preceding blank line
195− topLevel <- gets stTopLevel
198+ topLevel <- asks envTopLevel
196199 return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
197200 where bulletListItemToMuse :: PandocMonad m
198201 => [Block]
@@ -203,7 +206,7 @@ blockToMuse (BulletList items) = do
203206blockToMuse (DefinitionList items) = do
204207 contents <- mapM definitionListItemToMuse items
205208 -- ensure that sublists have preceding blank line
206− topLevel <- gets stTopLevel
209+ topLevel <- asks envTopLevel
207210 return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
208211 where definitionListItemToMuse :: PandocMonad m
209212 => ([Inline], [[Block]])
@@ -218,7 +221,7 @@ blockToMuse (DefinitionList items) = do
218221 -> Muse m Doc
219222 descriptionToMuse desc = hang 4 " :: " <$> blockListToMuse desc
220223blockToMuse (Header level (ident,_,_) inlines) = do
221− opts <- gets stOptions
224+ opts <- asks envOptions
222225 contents <- inlineListToMuse inlines
223226
224227 ids <- gets stIds
@@ -383,7 +386,7 @@ renderInlineList :: PandocMonad m
383386renderInlineList True [] = pure "<verbatim></verbatim>"
384387renderInlineList False [] = pure ""
385388renderInlineList start (x:xs) = do r <- inlineToMuse x
386− opts <- gets stOptions
389+ opts <- asks envOptions
387390 lst' <- renderInlineList ((x == SoftBreak && writerWrapText opts == WrapPreserve) || x == LineBreak) xs
388391 if start && fixOrEscape x
389392 then pure (text "<verbatim></verbatim>" <> r <> lst')
@@ -443,7 +446,7 @@ inlineToMuse (RawInline (Format f) str) =
443446inlineToMuse LineBreak = return $ "<br>" <> cr
444447inlineToMuse Space = return space
445448inlineToMuse SoftBreak = do
446− wrapText <- gets $ writerWrapText . stOptions
449+ wrapText <- asks $ writerWrapText . envOptions
447450 return $ if wrapText == WrapPreserve then cr else space
448451inlineToMuse (Link _ txt (src, _)) =
449452 case txt of
@@ -458,7 +461,7 @@ inlineToMuse (Link _ txt (src, _)) =
458461inlineToMuse (Image attr alt (source,'f':'i':'g':':':title)) =
459462 inlineToMuse (Image attr alt (source,title))
460463inlineToMuse (Image attr inlines (source, title)) = do
461− opts <- gets stOptions
464+ opts <- asks envOptions
462465 alt <- inlineListToMuse inlines
463466 let title' = if null title
464467 then if null inlines