@@ -0,0 +1,336 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-
3+Copyright (C) 2017 Alexander Krotov <ilabdsf@gmail.com>
4+
5+This program is free software; you can redistribute it and/or modify
6+it under the terms of the GNU General Public License as published by
7+the Free Software Foundation; either version 2 of the License, or
8+(at your option) any later version.
9+
10+This program is distributed in the hope that it will be useful,
11+but WITHOUT ANY WARRANTY; without even the implied warranty of
12+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+GNU General Public License for more details.
14+
15+You should have received a copy of the GNU General Public License
16+along with this program; if not, write to the Free Software
17+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18+-}
19+
20+{- |
21+ Module : Text.Pandoc.Writers.Muse
22+ Copyright : Copyright (C) 2017 Alexander Krotov
23+ License : GNU GPL, version 2 or above
24+
25+ Maintainer : Alexander Krotov <ilabdsf@gmail.com>
26+ Stability : stable
27+ Portability : portable
28+
29+Conversion of 'Pandoc' documents to Muse.
30+
31+This module is mostly intended for <https://amusewiki.org/ Amusewiki> markup support,
32+as described by <https://amusewiki.org/library/manual Text::Amuse markup manual>.
33+Original <https://www.gnu.org/software/emacs-muse/ Emacs Muse> markup support
34+is a secondary goal.
35+
36+Where Text::Amuse markup
37+<https://metacpan.org/pod/Text::Amuse#DIFFERENCES-WITH-THE-ORIGINAL-EMACS-MUSE-MARKUP differs>
38+from <https://www.gnu.org/software/emacs-muse/manual/ Emacs Muse markup>,
39+Text::Amuse markup is supported.
40+For example, native tables are always used instead of Org Mode tables.
41+However, @\<literal style="html">@ tag is used for HTML raw blocks
42+even though it is supported only in Emacs Muse.
43+-}
44+module Text.Pandoc.Writers.Muse (writeMuse) where
45+import Control.Monad.State
46+import Data.List (intersperse, transpose, isInfixOf)
47+import System.FilePath (takeExtension)
48+import Text.Pandoc.Class (PandocMonad)
49+import Text.Pandoc.Definition
50+import Text.Pandoc.Options
51+import Text.Pandoc.Pretty
52+import Text.Pandoc.Shared
53+import Text.Pandoc.Templates (renderTemplate')
54+import Text.Pandoc.Writers.Math
55+import Text.Pandoc.Writers.Shared
56+
57+type Notes = [[Block]]
58+data WriterState =
59+ WriterState { stNotes :: Notes
60+ , stOptions :: WriterOptions
61+ , stTopLevel :: Bool
62+ , stInsideBlock :: Bool
63+ }
64+
65+-- | Convert Pandoc to Muse.
66+writeMuse :: PandocMonad m
67+ => WriterOptions
68+ -> Pandoc
69+ -> m String
70+writeMuse opts document =
71+ let st = WriterState { stNotes = []
72+ , stOptions = opts
73+ , stTopLevel = True
74+ , stInsideBlock = False
75+ }
76+ in evalStateT (pandocToMuse document) st
77+
78+-- | Return Muse representation of document.
79+pandocToMuse :: PandocMonad m
80+ => Pandoc
81+ -> StateT WriterState m String
82+pandocToMuse (Pandoc meta blocks) = do
83+ opts <- gets stOptions
84+ let colwidth = if writerWrapText opts == WrapAuto
85+ then Just $ writerColumns opts
86+ else Nothing
87+ metadata <- metaToJSON opts
88+ (fmap (render colwidth) . blockListToMuse)
89+ (fmap (render colwidth) . inlineListToMuse)
90+ meta
91+ body <- blockListToMuse blocks
92+ notes <- liftM (reverse . stNotes) get >>= notesToMuse
93+ let main = render colwidth $ body $+$ notes
94+ let context = defField "body" main
95+ $ metadata
96+ case writerTemplate opts of
97+ Nothing -> return main
98+ Just tpl -> return $ renderTemplate' tpl context
99+
100+-- | Convert list of Pandoc block elements to Muse.
101+blockListToMuse :: PandocMonad m
102+ => [Block] -- ^ List of block elements
103+ -> StateT WriterState m Doc
104+blockListToMuse blocks = do
105+ oldState <- get
106+ modify $ \s -> s { stTopLevel = not $ stInsideBlock s
107+ , stInsideBlock = True
108+ }
109+ contents <- mapM blockToMuse blocks
110+ modify $ \s -> s { stTopLevel = stTopLevel oldState
111+ , stInsideBlock = stInsideBlock oldState
112+ }
113+ return $ cat contents
114+
115+-- | Convert Pandoc block element to Muse.
116+blockToMuse :: PandocMonad m
117+ => Block -- ^ Block element
118+ -> StateT WriterState m Doc
119+blockToMuse (Plain inlines) = inlineListToMuse inlines
120+blockToMuse (Para inlines) = do
121+ contents <- inlineListToMuse inlines
122+ return $ contents <> blankline
123+blockToMuse (LineBlock lns) = do
124+ let splitStanza [] = []
125+ splitStanza xs = case break (== mempty) xs of
126+ (l, []) -> l : []
127+ (l, _:r) -> l : splitStanza r
128+ let joinWithLinefeeds = nowrap . mconcat . intersperse cr
129+ let joinWithBlankLines = mconcat . intersperse blankline
130+ let prettyfyStanza ls = joinWithLinefeeds <$> mapM inlineListToMuse ls
131+ contents <- joinWithBlankLines <$> mapM prettyfyStanza (splitStanza lns)
132+ return $ blankline $$ "<verse>" $$ contents $$ "</verse>" <> blankline
133+blockToMuse (CodeBlock (_,_,_) str) = do
134+ return $ "<example>" $$ text str $$ "</example>" $$ blankline
135+blockToMuse (RawBlock (Format format) str) =
136+ return $ blankline $$ "<literal style=\"" <> text format <> "\">" $$
137+ text str $$ "</literal>" $$ blankline
138+blockToMuse (BlockQuote blocks) = do
139+ contents <- blockListToMuse blocks
140+ return $ blankline
141+ <> "<quote>"
142+ $$ flush contents -- flush to drop blanklines
143+ $$ "</quote>"
144+ <> blankline
145+blockToMuse (OrderedList (start, style, _) items) = do
146+ let markers = take (length items) $ orderedListMarkers
147+ (start, style, Period)
148+ let maxMarkerLength = maximum $ map length markers
149+ let markers' = map (\m -> let s = maxMarkerLength - length m
150+ in m ++ replicate s ' ') markers
151+ contents <- mapM (\(item, num) -> orderedListItemToMuse item num) $
152+ zip markers' items
153+ -- ensure that sublists have preceding blank line
154+ topLevel <- gets stTopLevel
155+ return $ cr $$ ((if topLevel then nest 1 else id) $ vcat contents) $$ blankline
156+ where orderedListItemToMuse :: PandocMonad m
157+ => String -- ^ marker for list item
158+ -> [Block] -- ^ list item (list of blocks)
159+ -> StateT WriterState m Doc
160+ orderedListItemToMuse marker item = do
161+ contents <- blockListToMuse item
162+ return $ hang (length marker + 1) (text marker <> space) contents
163+blockToMuse (BulletList items) = do
164+ contents <- mapM bulletListItemToMuse items
165+ -- ensure that sublists have preceding blank line
166+ topLevel <- gets stTopLevel
167+ return $ cr $$ ((if topLevel then nest 1 else id) $ vcat contents) $$ blankline
168+ where bulletListItemToMuse :: PandocMonad m
169+ => [Block]
170+ -> StateT WriterState m Doc
171+ bulletListItemToMuse item = do
172+ contents <- blockListToMuse item
173+ return $ hang 2 "- " contents
174+blockToMuse (DefinitionList items) = do
175+ contents <- mapM definitionListItemToMuse items
176+ return $ cr $$ (nest 1 $ vcat $ contents) $$ blankline
177+ where definitionListItemToMuse :: PandocMonad m
178+ => ([Inline], [[Block]])
179+ -> StateT WriterState m Doc
180+ definitionListItemToMuse (label, defs) = do
181+ label' <- inlineListToMuse label
182+ contents <- liftM vcat $ mapM blockListToMuse defs
183+ let label'' = label' <> " :: "
184+ let ind = offset label''
185+ return $ hang ind label'' contents
186+blockToMuse (Header level (ident,_,_) inlines) = do
187+ contents <- inlineListToMuse inlines
188+ let attr' = if null ident
189+ then empty
190+ else "#" <> text ident <> cr
191+ let header' = text $ replicate level '*'
192+ return $ blankline <> nowrap (header' <> space <> contents)
193+ <> blankline <> attr'
194+-- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors
195+blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline
196+blockToMuse (Table caption _ _ headers rows) = do
197+ caption' <- inlineListToMuse caption
198+ headers' <- mapM blockListToMuse headers
199+ rows' <- mapM (mapM blockListToMuse) rows
200+ let noHeaders = all null headers
201+
202+ let numChars = maximum . map offset
203+ -- FIXME: width is not being used.
204+ let widthsInChars =
205+ map numChars $ transpose (headers' : rows')
206+ -- FIXME: Muse doesn't allow blocks with height more than 1.
207+ let hpipeBlocks sep blocks = hcat $ intersperse sep' blocks
208+ where h = maximum (1 : map height blocks)
209+ sep' = lblock (length sep) $ vcat (map text $ replicate h sep)
210+ let makeRow sep = hpipeBlocks sep . zipWith lblock widthsInChars
211+ let head' = makeRow " || " headers'
212+ let rowSeparator = if noHeaders then " | " else " | "
213+ rows'' <- mapM (\row -> do cols <- mapM blockListToMuse row
214+ return $ makeRow rowSeparator cols) rows
215+ let body = vcat rows''
216+ return $ (if noHeaders then empty else head')
217+ $$ body
218+ $$ (if null caption then empty else "|+ " <> caption' <> " +|")
219+ $$ blankline
220+blockToMuse (Div _ bs) = blockListToMuse bs
221+blockToMuse Null = return empty
222+
223+-- | Return Muse representation of notes.
224+notesToMuse :: PandocMonad m
225+ => Notes
226+ -> StateT WriterState m Doc
227+notesToMuse notes =
228+ mapM (\(num, note) -> noteToMuse num note) (zip [1..] notes) >>=
229+ return . vsep
230+
231+-- | Return Muse representation of a note.
232+noteToMuse :: PandocMonad m
233+ => Int
234+ -> [Block]
235+ -> StateT WriterState m Doc
236+noteToMuse num note = do
237+ contents <- blockListToMuse note
238+ let marker = "[" ++ show num ++ "] "
239+ return $ hang (length marker) (text marker) contents
240+
241+-- | Escape special characters for Muse.
242+escapeString :: String -> String
243+escapeString s =
244+ "<verbatim>" ++
245+ substitute "</verbatim>" "<</verbatim><verbatim>/verbatim>" s ++
246+ "</verbatim>"
247+
248+-- | Escape special characters for Muse if needed.
249+conditionalEscapeString :: String -> String
250+conditionalEscapeString s
251+ | any (`elem` ("*<=>[]|" :: String)) s ||
252+ "::" `isInfixOf` s = escapeString s
253+ | otherwise = s
254+
255+-- | Convert list of Pandoc inline elements to Muse.
256+inlineListToMuse :: PandocMonad m
257+ => [Inline]
258+ -> StateT WriterState m Doc
259+inlineListToMuse lst = mapM inlineToMuse lst >>= return . hcat
260+
261+-- | Convert Pandoc inline element to Muse.
262+inlineToMuse :: PandocMonad m
263+ => Inline
264+ -> StateT WriterState m Doc
265+inlineToMuse (Str str) = return $ text $ conditionalEscapeString str
266+inlineToMuse (Emph lst) = do
267+ contents <- inlineListToMuse lst
268+ return $ "<em>" <> contents <> "</em>"
269+inlineToMuse (Strong lst) = do
270+ contents <- inlineListToMuse lst
271+ return $ "<strong>" <> contents <> "</strong>"
272+inlineToMuse (Strikeout lst) = do
273+ contents <- inlineListToMuse lst
274+ return $ "<del>" <> contents <> "</del>"
275+inlineToMuse (Superscript lst) = do
276+ contents <- inlineListToMuse lst
277+ return $ "<sup>" <> contents <> "</sup>"
278+inlineToMuse (Subscript lst) = do
279+ contents <- inlineListToMuse lst
280+ return $ "<sub>" <> contents <> "</sub>"
281+inlineToMuse (SmallCaps lst) = inlineListToMuse lst
282+inlineToMuse (Quoted SingleQuote lst) = do
283+ contents <- inlineListToMuse lst
284+ return $ "'" <> contents <> "'"
285+inlineToMuse (Quoted DoubleQuote lst) = do
286+ contents <- inlineListToMuse lst
287+ return $ "\"" <> contents <> "\""
288+-- Amusewiki does not support <cite> tag,
289+-- and Emacs Muse citation support is limited
290+-- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation)
291+-- so just fallback to expanding inlines.
292+inlineToMuse (Cite _ lst) = inlineListToMuse lst
293+inlineToMuse (Code _ str) = return $
294+ "<code>" <> text (conditionalEscapeString str) <> "</code>"
295+inlineToMuse (Math InlineMath str) =
296+ lift (texMathToInlines InlineMath str) >>= inlineListToMuse
297+inlineToMuse (Math DisplayMath str) = do
298+ contents <- lift (texMathToInlines DisplayMath str) >>= inlineListToMuse
299+ return $ "<verse>" <> contents <> "</verse>" <> blankline
300+inlineToMuse (RawInline (Format f) str) =
301+ return $ "<literal style=\"" <> text f <> "\">" <> text str <> "</literal>"
302+inlineToMuse LineBreak = return $ "<br>" <> cr
303+inlineToMuse Space = return space
304+inlineToMuse SoftBreak = do
305+ wrapText <- gets $ writerWrapText . stOptions
306+ return $ if wrapText == WrapPreserve then cr else space
307+inlineToMuse (Link _ txt (src, _)) = do
308+ case txt of
309+ [Str x] | escapeURI x == src ->
310+ return $ "[[" <> text (escapeLink x) <> "]]"
311+ _ -> do contents <- inlineListToMuse txt
312+ return $ "[[" <> text (escapeLink src) <> "][" <> contents <> "]]"
313+ where escapeLink lnk = escapeURI (if isImageUrl lnk then "URL:" ++ lnk else lnk)
314+ -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el
315+ imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"]
316+ isImageUrl = (`elem` imageExtensions) . takeExtension
317+inlineToMuse (Image attr alt (source,'f':'i':'g':':':title)) =
318+ inlineToMuse (Image attr alt (source,title))
319+inlineToMuse (Image _ inlines (source, title)) = do
320+ alt <- inlineListToMuse inlines
321+ let title' = if null title
322+ then if null inlines
323+ then ""
324+ else "[" <> alt <> "]"
325+ else "[" <> text title <> "]"
326+ return $ "[[" <> text source <> "]" <> title' <> "]"
327+inlineToMuse (Note contents) = do
328+ -- add to notes in state
329+ notes <- gets stNotes
330+ modify $ \st -> st { stNotes = contents:notes }
331+ let ref = show $ (length notes) + 1
332+ return $ "[" <> text ref <> "]"
333+inlineToMuse (Span (_,name:_,_) inlines) = do
334+ contents <- inlineListToMuse inlines
335+ return $ "<class name=\"" <> text name <> "\">" <> contents <> "</class>"
336+inlineToMuse (Span _ lst) = inlineListToMuse lst