diff options
| -rw-r--r-- | src/Text/Pandoc/Writers/Muse.hs | 50 | ||||
| -rw-r--r-- | test/Tests/Writers/Muse.hs | 88 |
2 files changed, 129 insertions, 9 deletions
diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs index 408215602..46aae113b 100644 --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -80,12 +80,14 @@ data WriterEnv = data WriterState = WriterState { stNotes :: Notes + , stNoteNum :: Int , stIds :: Set.Set String , stUseTags :: Bool -- ^ Use tags for emphasis, for example because previous character is a letter } instance Default WriterState where def = WriterState { stNotes = [] + , stNoteNum = 1 , stIds = Set.empty , stUseTags = False } @@ -127,7 +129,7 @@ pandocToMuse (Pandoc meta blocks) = do (fmap render' . inlineListToMuse) meta body <- blockListToMuse blocks - notes <- fmap (reverse . stNotes) get >>= notesToMuse + notes <- currentNotesToMuse let main = render colwidth $ body $+$ notes let context = defField "body" main metadata case writerTemplate opts of @@ -141,7 +143,7 @@ catWithBlankLines :: PandocMonad m -> Int -- ^ Number of blank lines -> Muse m Doc catWithBlankLines (b : bs) n = do - b' <- blockToMuse b + b' <- blockToMuseWithNotes b bs' <- flatBlockListToMuse bs return $ b' <> blanklines n <> bs' catWithBlankLines _ _ = error "Expected at least one block" @@ -290,26 +292,61 @@ blockToMuse (Table caption aligns widths headers rows) = blockToMuse (Div _ bs) = flatBlockListToMuse bs blockToMuse Null = return empty +-- | Return Muse representation of notes collected so far. +currentNotesToMuse :: PandocMonad m + => Muse m Doc +currentNotesToMuse = do + notes <- reverse <$> gets stNotes + modify $ \st -> st { stNotes = mempty } + notesToMuse notes + -- | Return Muse representation of notes. notesToMuse :: PandocMonad m => Notes -> Muse m Doc -notesToMuse notes = vsep <$> zipWithM noteToMuse [1 ..] notes +notesToMuse notes = do + n <- gets stNoteNum + modify $ \st -> st { stNoteNum = stNoteNum st + length notes } + vsep <$> zipWithM noteToMuse [n ..] notes -- | Return Muse representation of a note. noteToMuse :: PandocMonad m => Int -> [Block] -> Muse m Doc -noteToMuse num note = - hang (length marker) (text marker) <$> +noteToMuse num note = do + res <- hang (length marker) (text marker) <$> local (\env -> env { envInsideBlock = True , envInlineStart = True , envAfterSpace = True }) (blockListToMuse note) + return $ res <> blankline where marker = "[" ++ show num ++ "] " +-- | Return Muse representation of block and accumulated notes. +blockToMuseWithNotes :: PandocMonad m + => Block + -> Muse m Doc +blockToMuseWithNotes blk = do + topLevel <- asks envTopLevel + opts <- asks envOptions + let hdrToMuse hdr@(Header{}) = do + b <- blockToMuse hdr + if topLevel && writerReferenceLocation opts == EndOfSection + then do + notes <- currentNotesToMuse + return $ notes $+$ b + else + return b + hdrToMuse b = blockToMuse b + b <- hdrToMuse blk + if topLevel && writerReferenceLocation opts == EndOfBlock + then do + notes <- currentNotesToMuse + return $ b $+$ notes <> blankline + else return b + -- | Escape special characters for Muse. escapeString :: String -> String escapeString s = @@ -659,7 +696,8 @@ inlineToMuse (Note contents) = do modify $ \st -> st { stNotes = contents:notes , stUseTags = False } - let ref = show $ length notes + 1 + n <- gets stNoteNum + let ref = show $ n + length notes return $ "[" <> text ref <> "]" inlineToMuse (Span (anchor,names,_) inlines) = do contents <- inlineListToMuse inlines diff --git a/test/Tests/Writers/Muse.hs b/test/Tests/Writers/Muse.hs index 57fbb3e57..ad4f421a3 100644 --- a/test/Tests/Writers/Muse.hs +++ b/test/Tests/Writers/Muse.hs @@ -9,10 +9,13 @@ import Text.Pandoc import Text.Pandoc.Arbitrary () import Text.Pandoc.Builder +defopts :: WriterOptions +defopts = def{ writerWrapText = WrapPreserve, + writerExtensions = extensionsFromList [Ext_amuse, + Ext_auto_identifiers] } + muse :: (ToPandoc a) => a -> String -muse = museWithOpts def{ writerWrapText = WrapPreserve, - writerExtensions = extensionsFromList [Ext_amuse, - Ext_auto_identifiers] } +muse = museWithOpts defopts museWithOpts :: (ToPandoc a) => WriterOptions -> a -> String museWithOpts opts = unpack . purely (writeMuse opts) . toPandoc @@ -22,6 +25,84 @@ infix 4 =: => String -> (a, String) -> TestTree (=:) = test muse +noteLocationTestDoc :: Blocks +noteLocationTestDoc = + header 1 (text "First Header") <> + para (text "This is a footnote." <> + note (para (text "First note."))) <> + blockQuote (para (text "A note inside a block quote." <> + note (para (text "The second note."))) <> + para (text "A second paragraph.")) <> + header 1 (text "Second Header") <> + para (text "Some more text.") + +noteLocationTests :: TestTree +noteLocationTests = testGroup "note location" + [ test (museWithOpts defopts {writerReferenceLocation=EndOfDocument}) + "footnotes at the end of document" $ + noteLocationTestDoc =?> + (unlines [ "* First Header" + , "" + , "This is a footnote.[1]" + , "" + , "<quote>" + , "A note inside a block quote.[2]" + , "" + , "A second paragraph." + , "</quote>" + , "" + , "* Second Header" + , "" + , "Some more text." + , "" + , "[1] First note." + , "" + , "[2] The second note." + ]) + , test (museWithOpts defopts {writerReferenceLocation=EndOfBlock}) + "footnotes at the end of block" $ + noteLocationTestDoc =?> + (unlines [ "* First Header" + , "" + , "This is a footnote.[1]" + , "" + , "[1] First note." + , "" + , "<quote>" + , "A note inside a block quote.[2]" + , "" + , "[2] The second note." + , "" + , "A second paragraph." + , "</quote>" + , "" + , "* Second Header" + , "" + , "Some more text." + ]) + , test (museWithOpts defopts {writerReferenceLocation=EndOfSection}) + "footnotes at the end of section" $ + noteLocationTestDoc =?> + (unlines [ "* First Header" + , "" + , "This is a footnote.[1]" + , "" + , "<quote>" + , "A note inside a block quote.[2]" + , "" + , "A second paragraph." + , "</quote>" + , "" + , "[1] First note." + , "" + , "[2] The second note." + , "" + , "* Second Header" + , "" + , "Some more text." + ]) + ] + tests :: [TestTree] tests = [ testGroup "block elements" [ "plain" =: plain (text "Foo bar.") =?> "Foo bar." @@ -501,6 +582,7 @@ tests = [ testGroup "block elements" , "" , "[1] Foo" ] + , noteLocationTests , "span with class" =: spanWith ("",["foobar"],[]) (text "Some text") =?> "<class name=\"foobar\">Some text</class>" , "span without class" =: spanWith ("",[],[]) (text "Some text") |