@@ -0,0 +1,427 @@
1+{-# OPTIONS_GHC -fwarn-unused-imports #-}
2+
3+{- |
4+ by xyne.archlinux.com - released under GPL 2
5+ # About
6+ This is a Pandoc writer for generating Sable output. Sable is an XML-based
7+ document format speech synthesis. This module can be used to generate spoken
8+ versions of any input format that Pandoc understands. When compiled as a
9+ stand-alone application it will create an executable that converts Markdown
10+ on STDIN to Sable on STDOUT.
11+
12+ # Example
13+
14+ To produce audio on the fly:
15+
16+ $ festival --tts <sable file>
17+
18+ To generate .wav and .mp3 files (text2wave is included with festival):
19+
20+ $ text2wav <sable file>
21+ $ lame -V2 <wav file>
22+
23+ # References
24+ * [Sable version 1.0](http://www.bell-labs.com/project/tts/sable.html)
25+-}
26+
27+module Text.Pandoc.Writers.Sable
28+ (
29+ writeSable
30+ ) where
31+
32+import Text.Pandoc.Definition hiding (Attr)
33+import Text.Pandoc.Options
34+import Text.XML.Light
35+
36+------------------------------------- XML --------------------------------------
37+
38+-- | Sable DOCTYPE string.
39+doctype :: String
40+doctype = "<!DOCTYPE SABLE PUBLIC \"-//SABLE//DTD SABLE speech mark up//EN\" \"Sable.v0_2.dtd\" []>"
41+
42+
43+
44+-- | Convert the document to a string with the XML header and DOCTYPE.
45+pp :: [Element] -> String
46+pp e = unlines
47+ [
48+ xml_header,
49+ doctype,
50+ (ppElement $ node (unqual "SABLE") e)
51+ ]
52+
53+
54+
55+-- | Convert a key-value pair to an unqualified Attr.
56+unqualAttr :: String -> String -> Attr
57+unqualAttr k v = Attr
58+ {
59+ attrKey = unqual k,
60+ attrVal = v
61+ }
62+
63+
64+
65+-- | The tag used to wrap plain text.
66+dummyTag :: String
67+dummyTag = "DIV"
68+
69+
70+
71+-- | Wrap a node type in a dummy element.
72+dummyElement :: (Node t) => t -> Element
73+dummyElement = node (unqual dummyTag)
74+
75+
76+
77+-- | Concat plaintext elements.
78+concat' :: [Element] -> [Element]
79+concat' = (f [])
80+ where
81+ extract ~(Text (CData {cdData = s})) = s
82+
83+ f :: String -> [Element] -> [Element]
84+ f s ((Element { elName = name, elAttribs = [], elContent = cs }):es)
85+ | name == (unqual dummyTag) = f (s ++ (concat $ map extract cs)) es
86+ f s (e:es) =
87+ if null s
88+ then e : (f [] es)
89+ else (naiveBreaks [] s) ++ (e : (f [] es))
90+ f s [] =
91+ if null s
92+ then []
93+ else naiveBreaks [] s
94+
95+
96+
97+-- | Naively insert breaks in the text.
98+naiveBreaks :: String -> String -> [Element]
99+naiveBreaks s [] = (rawText s) : []
100+naiveBreaks s (c:' ':cs) | elem c "?!.,:;" = punctuationBreak c s (naiveBreaks [] cs)
101+naiveBreaks s (c:[]) | elem c "?!.,:;" = punctuationBreak c s []
102+naiveBreaks s (c:cs) = naiveBreaks (s ++ [c]) cs
103+
104+
105+
106+-- | Internal function for naiveBreaks.
107+punctuationBreak :: Char -> String -> ([Element] -> [Element])
108+punctuationBreak c s =
109+ let
110+ typ =
111+ case c of
112+ ':' -> "."
113+ ';' -> ","
114+ _ -> c:[]
115+ in
116+ ((rawText s) :) .
117+ ((node (unqual "BREAK") [unqualAttr "LEVEL" "Medium", unqualAttr "TYPE" typ]) :)
118+
119+
120+
121+-- | Insert raw text.
122+rawText :: String -> Element
123+rawText s = dummyElement $ CData
124+ {
125+ cdVerbatim = CDataText,
126+ cdData = s,
127+ cdLine = Nothing
128+ }
129+
130+
131+
132+-- | Insert URL.
133+url :: String -> Element
134+url u = node (unqual "SAYAS") ([unqualAttr "MODE" "net", unqualAttr "MODETYPE" "URL"], u)
135+
136+
137+
138+{- |
139+ Spoken metadata delimiters, such as "begin title level 1" and "end title level
140+ 1".
141+-}
142+speakMeta :: [Element] -> [Element] -> [Element]
143+speakMeta tag es =
144+ if null es
145+ then
146+ [
147+ node (unqual "VOLUME") ([unqualAttr "LEVEL" "quiet"], concat' $ tag),
148+ node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]
149+ ]
150+ else
151+ (
152+ node
153+ (unqual "VOLUME")
154+ (
155+ [unqualAttr "LEVEL" "quiet"],
156+ concat' $ (rawText "begin ") : tag
157+ )
158+ ) :
159+ (node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]) :
160+ es ++
161+ (
162+ node
163+ (unqual "VOLUME")
164+ (
165+ [unqualAttr "LEVEL" "quiet"],
166+ concat' $ (rawText "end ") : tag
167+ )
168+ ) :
169+ node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"] :
170+ []
171+
172+
173+
174+{- |
175+ Speak all characters (including whitespace) literally and slowly. This is
176+ meant for code and raw data.
177+-}
178+speakAllLiteral :: String -> Element
179+speakAllLiteral s =
180+ node (unqual "RATE") ([unqualAttr "SPEED" "slow"], handleNotWhitespace s)
181+ where
182+ whitespace = " \t\r\n"
183+
184+ isWhitespace = (`elem` whitespace)
185+
186+ spokenWhitespace ' ' = " space "
187+ spokenWhitespace '\t' = " tab "
188+ spokenWhitespace '\r' = " carriage return "
189+ spokenWhitespace '\n' = " newline "
190+ spokenWhitespace c = ' ':c:' ':[]
191+
192+ handleWhitespace :: String -> [Element]
193+ handleWhitespace [] = []
194+ handleWhitespace string@(c:rest)
195+ | isWhitespace c =
196+ (rawText $ spokenWhitespace c) :
197+ (node (unqual "BREAK") (unqualAttr "LEVEL" "Medium")) :
198+ (handleWhitespace rest)
199+ | otherwise = handleNotWhitespace string
200+
201+ handleNotWhitespace :: String -> [Element]
202+ handleNotWhitespace [] = []
203+ handleNotWhitespace string =
204+ let
205+ (nws, ws) = break isWhitespace string
206+ in
207+ (node (unqual "SAYAS") ((unqualAttr "MODE" "literal"), nws)) :
208+ (handleWhitespace ws)
209+
210+
211+
212+-- | Join a list of string with intercalated breaks.
213+insertBreaks
214+ :: String
215+ -- ^ Break level.
216+ -> (a -> ([Element] -> [Element]))
217+ {- ^
218+ A function to convert items of the given list to functions that prepend
219+ elements onto another list.
220+ -}
221+ -> [a]
222+ -> [Element]
223+insertBreaks _ _ [] = []
224+insertBreaks _ f (x:[]) = f x []
225+insertBreaks level f (x:xs) =
226+ (f x) $
227+ (node (unqual "BREAK") (unqualAttr "LEVEL" level)) :
228+ (insertBreaks level f xs)
229+
230+
231+
232+------------------------------------ Pandoc ------------------------------------
233+
234+-- | Pandoc writer for Sable.
235+writeSable :: WriterOptions -> Pandoc -> String
236+writeSable _ (Pandoc meta blocks) =
237+ pp $
238+ (formatMeta meta) ++
239+ (formatBlocks blocks)
240+
241+
242+
243+-- | Extract document title, authors and date from Meta.
244+formatMeta :: Meta -> [Element]
245+formatMeta meta =
246+ let
247+ title = docTitle meta
248+ authors = docAuthors meta
249+ date = docDate meta
250+ in
251+ (
252+ if null title
253+ then id
254+ else ((speakMeta [rawText "document title"] $ formatInlines title) ++)
255+ ) $
256+ (
257+ case authors of
258+ [] -> id
259+ (a:[]) -> ((speakMeta [rawText "document author"] $ formatInlines a) ++)
260+ _ ->
261+ ((
262+ speakMeta [rawText "document authors"] $
263+ insertBreaks "Medium" (++) $
264+ map formatInlines authors
265+ ) ++)
266+ ) $
267+ (
268+ if null date
269+ then []
270+ else
271+ speakMeta
272+ [rawText "document date"]
273+ [
274+ node
275+ (unqual "SAYAS")
276+ -- TODO: detect date format and set MODETYPE accordingly.
277+ ([unqualAttr "MODE" "date", unqualAttr "MODETYPE" "YMD"], formatInlines date)
278+ ]
279+ )
280+
281+
282+
283+-- | Format a list of blocks.
284+formatBlocks :: [Block] -> [Element]
285+formatBlocks = (insertBreaks "Large" (++)) . (map formatBlock)
286+
287+
288+
289+-- | Format a block.
290+formatBlock :: Block -> [Element]
291+formatBlock (Plain ss) = formatInlines ss
292+formatBlock (Para ss) = [node (unqual "DIV") ([unqualAttr "TYPE" "paragraph"], formatInlines ss)]
293+formatBlock (CodeBlock _ string) = speakMeta [rawText "code"] [speakAllLiteral string]
294+formatBlock (RawBlock (Format t) string) = speakMeta [rawText ("raw " ++ t)] [speakAllLiteral string]
295+formatBlock (BlockQuote blocks) = speakMeta [rawText "quote"] (formatBlocks blocks)
296+formatBlock (OrderedList attr bss) = formatList (Just attr) bss
297+formatBlock (BulletList bss) = formatList Nothing bss
298+formatBlock (DefinitionList defs) = formatDefinitionList defs
299+formatBlock (Header n _ ss) =
300+ speakMeta
301+ [
302+ (rawText "header level "),
303+ node (unqual "SAYAS") (unqualAttr "MODE" "cardinal", show n)
304+ ]
305+ (formatInlines ss)
306+formatBlock (HorizontalRule) = speakMeta [rawText "horizontal rule"] []
307+formatBlock (Table caption _ _ headerRow rows) = formatTable caption headerRow rows
308+formatBlock (Div _ bs) = formatBlocks bs
309+formatBlock (Null) = []
310+
311+
312+
313+-- | Format lists of inline elements.
314+formatInlines :: [Inline] -> [Element]
315+formatInlines = concat' . concat . (map formatInline)
316+
317+
318+
319+-- | Format inline elements.
320+formatInline :: Inline -> [Element]
321+formatInline (Str s) = [rawText s]
322+formatInline (Emph ss) = [node (unqual "EMPH") ([unqualAttr "LEVEL" "Moderate"], formatInlines ss)]
323+formatInline (Strong ss) = [node (unqual "EMPH") ([unqualAttr "LEVEL" "Strong"], formatInlines ss)]
324+formatInline (Strikeout ss) = speakMeta [rawText "strikeout"] (formatInlines ss)
325+formatInline (Superscript ss) = speakMeta [rawText "superscript"] (formatInlines ss)
326+formatInline (Subscript ss) = speakMeta [rawText "subscript"] (formatInlines ss)
327+formatInline (SmallCaps ss) = speakMeta [rawText "small caps"] (formatInlines ss)
328+formatInline (Quoted SingleQuote ss) = speakMeta [rawText "single quote"] (formatInlines ss)
329+formatInline (Quoted DoubleQuote ss) = speakMeta [rawText "double quote"] (formatInlines ss)
330+-- TODO: implement
331+formatInline (Cite _ _) = speakMeta [rawText "citation"] [rawText "citations are not yet supported"]
332+formatInline (Code _ s) = speakMeta [rawText "code"] [speakAllLiteral s]
333+formatInline (Space) = [rawText " "]
334+formatInline (LineBreak) = speakMeta [rawText "line break"] []
335+formatInline (Math _ s) = [node (unqual "SAYAS") ((unqualAttr "MODE" "math"), s)]
336+formatInline (RawInline (Format t) s) = speakMeta [rawText ("raw " ++ t)] [speakAllLiteral s]
337+formatInline (Link ss (u, _)) =
338+ speakMeta [rawText "link"] $
339+ (formatInlines ss) ++
340+ [
341+ node (unqual "BREAK") (unqualAttr "LEVEL" "Medium"),
342+ url u
343+ ]
344+formatInline (Image alt (u, _)) =
345+ speakMeta [rawText "image"] $
346+ (formatInlines alt) ++
347+ [
348+ node (unqual "BREAK") (unqualAttr "LEVEL" "Medium"),
349+ url u
350+ ]
351+formatInline (Note bs) = speakMeta [rawText "note"] (formatBlocks bs)
352+formatInline (Span _ ss) = formatInlines ss
353+
354+
355+
356+-- | Format a list.
357+formatList :: (Maybe ListAttributes) -> [[Block]] -> [Element]
358+formatList attr items =
359+ let
360+ f :: (Show s) => String -> s => Maybe Element
361+ f s x = Just $ node (unqual "SAYAS") ((unqualAttr "MODE" s), show x)
362+
363+ enumeration :: [Maybe Element]
364+ enumeration = case attr of
365+ Just (_, LowerAlpha, _) -> map (f "literal") ['a'..]
366+ Just (_, UpperAlpha, _) -> map (f "literal") ['A'..]
367+ Just _ -> map (f "cardinal") [(1 :: Int) ..]
368+ Nothing -> map (f "ordinal") [(1 :: Int) ..]
369+-- Nothing -> repeat Nothing
370+ in
371+ speakMeta [rawText "list"] $
372+ insertBreaks "Medium" (++) (map formatListItem (zip enumeration items))
373+
374+
375+
376+-- | Format a list item.
377+formatListItem :: (Maybe Element, [Block]) -> [Element]
378+formatListItem (Nothing, i) = formatBlocks i
379+formatListItem (Just e, i) =
380+ e :
381+ (node (unqual "BREAK") (unqualAttr "LEVEL" "Small")) :
382+ (rawText "\n") :
383+ (formatBlocks i)
384+
385+
386+
387+-- | Format a definition list.
388+formatDefinitionList :: [([Inline], [[Block]])] -> [Element]
389+formatDefinitionList defs =
390+ speakMeta [rawText "definition list"] $
391+ insertBreaks "Medium" (++) $
392+ map formatDefinition defs
393+
394+
395+
396+-- | Format a definition.
397+formatDefinition :: ([Inline], [[Block]]) -> [Element]
398+formatDefinition (header, body) =
399+ (node (unqual "EMPH") ([unqualAttr "LEVEL" "Moderate"], formatInlines header)) :
400+ (node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]) :
401+ (insertBreaks "Medium" (++) $ map formatBlocks body)
402+
403+
404+
405+-- | Fromat a table.
406+formatTable :: [Inline] -> [TableCell] -> [[TableCell]] -> [Element]
407+formatTable caption headerRow rows =
408+ speakMeta [rawText "table"] $
409+ (speakMeta [rawText "caption"] (formatInlines caption)) ++
410+ (formatHeaderRow headerRow) ++
411+ (formatBodyRows rows)
412+
413+formatHeaderRow :: [TableCell] -> [Element]
414+formatHeaderRow hcs =
415+ speakMeta [rawText "headers"] (concat' $ concat $ map formatHeaderCell hcs)
416+
417+formatHeaderCell :: TableCell -> [Element]
418+formatHeaderCell hc = speakMeta [rawText "header"] (formatBlocks hc)
419+
420+formatBodyRows :: [[TableCell]] -> [Element]
421+formatBodyRows = (insertBreaks "Small" (++)) . (map formatBodyRow)
422+
423+formatBodyRow :: [TableCell] -> [Element]
424+formatBodyRow hcs = speakMeta [rawText "row"] (concat' $ concat $ map formatBodyCell hcs)
425+
426+formatBodyCell :: TableCell -> [Element]
427+formatBodyCell bc = speakMeta [rawText "cell"] (formatBlocks bc)