diff options
Diffstat (limited to 'src/Text')
| -rw-r--r-- | src/Text/Pandoc.hs | 3 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Muse.hs | 336 |
2 files changed, 339 insertions, 0 deletions
diff --git a/src/Text/Pandoc.hs b/src/Text/Pandoc.hs index 5561c719d..1577491df 100644 --- a/src/Text/Pandoc.hs +++ b/src/Text/Pandoc.hs @@ -136,6 +136,7 @@ module Text.Pandoc , writeCommonMark , writeCustom , writeTEI + , writeMuse -- * Rendering templates and default templates , module Text.Pandoc.Templates -- * Miscellaneous @@ -191,6 +192,7 @@ import Text.Pandoc.Writers.LaTeX import Text.Pandoc.Writers.Man import Text.Pandoc.Writers.Markdown import Text.Pandoc.Writers.MediaWiki +import Text.Pandoc.Writers.Muse import Text.Pandoc.Writers.Native import Text.Pandoc.Writers.ODT import Text.Pandoc.Writers.OpenDocument @@ -307,6 +309,7 @@ writers = [ ,("haddock" , StringWriter writeHaddock) ,("commonmark" , StringWriter writeCommonMark) ,("tei" , StringWriter writeTEI) + ,("muse" , StringWriter writeMuse) ] getDefaultExtensions :: String -> Extensions diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs new file mode 100644 index 000000000..cc88eb762 --- /dev/null +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE OverloadedStrings #-} +{- +Copyright (C) 2017 Alexander Krotov <ilabdsf@gmail.com> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.Muse + Copyright : Copyright (C) 2017 Alexander Krotov + License : GNU GPL, version 2 or above + + Maintainer : Alexander Krotov <ilabdsf@gmail.com> + Stability : stable + Portability : portable + +Conversion of 'Pandoc' documents to Muse. + +This module is mostly intended for <https://amusewiki.org/ Amusewiki> markup support, +as described by <https://amusewiki.org/library/manual Text::Amuse markup manual>. +Original <https://www.gnu.org/software/emacs-muse/ Emacs Muse> markup support +is a secondary goal. + +Where Text::Amuse markup +<https://metacpan.org/pod/Text::Amuse#DIFFERENCES-WITH-THE-ORIGINAL-EMACS-MUSE-MARKUP differs> +from <https://www.gnu.org/software/emacs-muse/manual/ Emacs Muse markup>, +Text::Amuse markup is supported. +For example, native tables are always used instead of Org Mode tables. +However, @\<literal style="html">@ tag is used for HTML raw blocks +even though it is supported only in Emacs Muse. +-} +module Text.Pandoc.Writers.Muse (writeMuse) where +import Control.Monad.State +import Data.List (intersperse, transpose, isInfixOf) +import System.FilePath (takeExtension) +import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Definition +import Text.Pandoc.Options +import Text.Pandoc.Pretty +import Text.Pandoc.Shared +import Text.Pandoc.Templates (renderTemplate') +import Text.Pandoc.Writers.Math +import Text.Pandoc.Writers.Shared + +type Notes = [[Block]] +data WriterState = + WriterState { stNotes :: Notes + , stOptions :: WriterOptions + , stTopLevel :: Bool + , stInsideBlock :: Bool + } + +-- | Convert Pandoc to Muse. +writeMuse :: PandocMonad m + => WriterOptions + -> Pandoc + -> m String +writeMuse opts document = + let st = WriterState { stNotes = [] + , stOptions = opts + , stTopLevel = True + , stInsideBlock = False + } + in evalStateT (pandocToMuse document) st + +-- | Return Muse representation of document. +pandocToMuse :: PandocMonad m + => Pandoc + -> StateT WriterState m String +pandocToMuse (Pandoc meta blocks) = do + opts <- gets stOptions + let colwidth = if writerWrapText opts == WrapAuto + then Just $ writerColumns opts + else Nothing + metadata <- metaToJSON opts + (fmap (render colwidth) . blockListToMuse) + (fmap (render colwidth) . inlineListToMuse) + meta + body <- blockListToMuse blocks + notes <- liftM (reverse . stNotes) get >>= notesToMuse + let main = render colwidth $ body $+$ notes + let context = defField "body" main + $ metadata + case writerTemplate opts of + Nothing -> return main + Just tpl -> return $ renderTemplate' tpl context + +-- | Convert list of Pandoc block elements to Muse. +blockListToMuse :: PandocMonad m + => [Block] -- ^ List of block elements + -> StateT WriterState m Doc +blockListToMuse blocks = do + oldState <- get + modify $ \s -> s { stTopLevel = not $ stInsideBlock s + , stInsideBlock = True + } + contents <- mapM blockToMuse blocks + modify $ \s -> s { stTopLevel = stTopLevel oldState + , stInsideBlock = stInsideBlock oldState + } + return $ cat contents + +-- | Convert Pandoc block element to Muse. +blockToMuse :: PandocMonad m + => Block -- ^ Block element + -> StateT WriterState m Doc +blockToMuse (Plain inlines) = inlineListToMuse inlines +blockToMuse (Para inlines) = do + contents <- inlineListToMuse inlines + return $ contents <> blankline +blockToMuse (LineBlock lns) = do + let splitStanza [] = [] + splitStanza xs = case break (== mempty) xs of + (l, []) -> l : [] + (l, _:r) -> l : splitStanza r + let joinWithLinefeeds = nowrap . mconcat . intersperse cr + let joinWithBlankLines = mconcat . intersperse blankline + let prettyfyStanza ls = joinWithLinefeeds <$> mapM inlineListToMuse ls + contents <- joinWithBlankLines <$> mapM prettyfyStanza (splitStanza lns) + return $ blankline $$ "<verse>" $$ contents $$ "</verse>" <> blankline +blockToMuse (CodeBlock (_,_,_) str) = do + return $ "<example>" $$ text str $$ "</example>" $$ blankline +blockToMuse (RawBlock (Format format) str) = + return $ blankline $$ "<literal style=\"" <> text format <> "\">" $$ + text str $$ "</literal>" $$ blankline +blockToMuse (BlockQuote blocks) = do + contents <- blockListToMuse blocks + return $ blankline + <> "<quote>" + $$ flush contents -- flush to drop blanklines + $$ "</quote>" + <> blankline +blockToMuse (OrderedList (start, style, _) items) = do + let markers = take (length items) $ orderedListMarkers + (start, style, Period) + let maxMarkerLength = maximum $ map length markers + let markers' = map (\m -> let s = maxMarkerLength - length m + in m ++ replicate s ' ') markers + contents <- mapM (\(item, num) -> orderedListItemToMuse item num) $ + zip markers' items + -- ensure that sublists have preceding blank line + topLevel <- gets stTopLevel + return $ cr $$ ((if topLevel then nest 1 else id) $ vcat contents) $$ blankline + where orderedListItemToMuse :: PandocMonad m + => String -- ^ marker for list item + -> [Block] -- ^ list item (list of blocks) + -> StateT WriterState m Doc + orderedListItemToMuse marker item = do + contents <- blockListToMuse item + return $ hang (length marker + 1) (text marker <> space) contents +blockToMuse (BulletList items) = do + contents <- mapM bulletListItemToMuse items + -- ensure that sublists have preceding blank line + topLevel <- gets stTopLevel + return $ cr $$ ((if topLevel then nest 1 else id) $ vcat contents) $$ blankline + where bulletListItemToMuse :: PandocMonad m + => [Block] + -> StateT WriterState m Doc + bulletListItemToMuse item = do + contents <- blockListToMuse item + return $ hang 2 "- " contents +blockToMuse (DefinitionList items) = do + contents <- mapM definitionListItemToMuse items + return $ cr $$ (nest 1 $ vcat $ contents) $$ blankline + where definitionListItemToMuse :: PandocMonad m + => ([Inline], [[Block]]) + -> StateT WriterState m Doc + definitionListItemToMuse (label, defs) = do + label' <- inlineListToMuse label + contents <- liftM vcat $ mapM blockListToMuse defs + let label'' = label' <> " :: " + let ind = offset label'' + return $ hang ind label'' contents +blockToMuse (Header level (ident,_,_) inlines) = do + contents <- inlineListToMuse inlines + let attr' = if null ident + then empty + else "#" <> text ident <> cr + let header' = text $ replicate level '*' + return $ blankline <> nowrap (header' <> space <> contents) + <> blankline <> attr' +-- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors +blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline +blockToMuse (Table caption _ _ headers rows) = do + caption' <- inlineListToMuse caption + headers' <- mapM blockListToMuse headers + rows' <- mapM (mapM blockListToMuse) rows + let noHeaders = all null headers + + let numChars = maximum . map offset + -- FIXME: width is not being used. + let widthsInChars = + map numChars $ transpose (headers' : rows') + -- FIXME: Muse doesn't allow blocks with height more than 1. + let hpipeBlocks sep blocks = hcat $ intersperse sep' blocks + where h = maximum (1 : map height blocks) + sep' = lblock (length sep) $ vcat (map text $ replicate h sep) + let makeRow sep = hpipeBlocks sep . zipWith lblock widthsInChars + let head' = makeRow " || " headers' + let rowSeparator = if noHeaders then " | " else " | " + rows'' <- mapM (\row -> do cols <- mapM blockListToMuse row + return $ makeRow rowSeparator cols) rows + let body = vcat rows'' + return $ (if noHeaders then empty else head') + $$ body + $$ (if null caption then empty else "|+ " <> caption' <> " +|") + $$ blankline +blockToMuse (Div _ bs) = blockListToMuse bs +blockToMuse Null = return empty + +-- | Return Muse representation of notes. +notesToMuse :: PandocMonad m + => Notes + -> StateT WriterState m Doc +notesToMuse notes = + mapM (\(num, note) -> noteToMuse num note) (zip [1..] notes) >>= + return . vsep + +-- | Return Muse representation of a note. +noteToMuse :: PandocMonad m + => Int + -> [Block] + -> StateT WriterState m Doc +noteToMuse num note = do + contents <- blockListToMuse note + let marker = "[" ++ show num ++ "] " + return $ hang (length marker) (text marker) contents + +-- | Escape special characters for Muse. +escapeString :: String -> String +escapeString s = + "<verbatim>" ++ + substitute "</verbatim>" "<</verbatim><verbatim>/verbatim>" s ++ + "</verbatim>" + +-- | Escape special characters for Muse if needed. +conditionalEscapeString :: String -> String +conditionalEscapeString s + | any (`elem` ("*<=>[]|" :: String)) s || + "::" `isInfixOf` s = escapeString s + | otherwise = s + +-- | Convert list of Pandoc inline elements to Muse. +inlineListToMuse :: PandocMonad m + => [Inline] + -> StateT WriterState m Doc +inlineListToMuse lst = mapM inlineToMuse lst >>= return . hcat + +-- | Convert Pandoc inline element to Muse. +inlineToMuse :: PandocMonad m + => Inline + -> StateT WriterState m Doc +inlineToMuse (Str str) = return $ text $ conditionalEscapeString str +inlineToMuse (Emph lst) = do + contents <- inlineListToMuse lst + return $ "<em>" <> contents <> "</em>" +inlineToMuse (Strong lst) = do + contents <- inlineListToMuse lst + return $ "<strong>" <> contents <> "</strong>" +inlineToMuse (Strikeout lst) = do + contents <- inlineListToMuse lst + return $ "<del>" <> contents <> "</del>" +inlineToMuse (Superscript lst) = do + contents <- inlineListToMuse lst + return $ "<sup>" <> contents <> "</sup>" +inlineToMuse (Subscript lst) = do + contents <- inlineListToMuse lst + return $ "<sub>" <> contents <> "</sub>" +inlineToMuse (SmallCaps lst) = inlineListToMuse lst +inlineToMuse (Quoted SingleQuote lst) = do + contents <- inlineListToMuse lst + return $ "'" <> contents <> "'" +inlineToMuse (Quoted DoubleQuote lst) = do + contents <- inlineListToMuse lst + return $ "\"" <> contents <> "\"" +-- Amusewiki does not support <cite> tag, +-- and Emacs Muse citation support is limited +-- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation) +-- so just fallback to expanding inlines. +inlineToMuse (Cite _ lst) = inlineListToMuse lst +inlineToMuse (Code _ str) = return $ + "<code>" <> text (conditionalEscapeString str) <> "</code>" +inlineToMuse (Math InlineMath str) = + lift (texMathToInlines InlineMath str) >>= inlineListToMuse +inlineToMuse (Math DisplayMath str) = do + contents <- lift (texMathToInlines DisplayMath str) >>= inlineListToMuse + return $ "<verse>" <> contents <> "</verse>" <> blankline +inlineToMuse (RawInline (Format f) str) = + return $ "<literal style=\"" <> text f <> "\">" <> text str <> "</literal>" +inlineToMuse LineBreak = return $ "<br>" <> cr +inlineToMuse Space = return space +inlineToMuse SoftBreak = do + wrapText <- gets $ writerWrapText . stOptions + return $ if wrapText == WrapPreserve then cr else space +inlineToMuse (Link _ txt (src, _)) = do + case txt of + [Str x] | escapeURI x == src -> + return $ "[[" <> text (escapeLink x) <> "]]" + _ -> do contents <- inlineListToMuse txt + return $ "[[" <> text (escapeLink src) <> "][" <> contents <> "]]" + where escapeLink lnk = escapeURI (if isImageUrl lnk then "URL:" ++ lnk else lnk) + -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el + imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"] + isImageUrl = (`elem` imageExtensions) . takeExtension +inlineToMuse (Image attr alt (source,'f':'i':'g':':':title)) = + inlineToMuse (Image attr alt (source,title)) +inlineToMuse (Image _ inlines (source, title)) = do + alt <- inlineListToMuse inlines + let title' = if null title + then if null inlines + then "" + else "[" <> alt <> "]" + else "[" <> text title <> "]" + return $ "[[" <> text source <> "]" <> title' <> "]" +inlineToMuse (Note contents) = do + -- add to notes in state + notes <- gets stNotes + modify $ \st -> st { stNotes = contents:notes } + let ref = show $ (length notes) + 1 + return $ "[" <> text ref <> "]" +inlineToMuse (Span (_,name:_,_) inlines) = do + contents <- inlineListToMuse inlines + return $ "<class name=\"" <> text name <> "\">" <> contents <> "</class>" +inlineToMuse (Span _ lst) = inlineListToMuse lst |