aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Text/Pandoc.hs3
-rw-r--r--src/Text/Pandoc/Writers/Muse.hs336
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