@@ -0,0 +1,429 @@
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+ -- This is correct, but Festival doesn't seem to unescape the text.
126+ -- cdVerbatim = CDataText,
127+ cdVerbatim = CDataRaw,
128+ cdData = s,
129+ cdLine = Nothing
130+ }
131+
132+
133+
134+-- | Insert URL.
135+url :: String -> Element
136+url u = node (unqual "SAYAS") ([unqualAttr "MODE" "net", unqualAttr "MODETYPE" "URL"], u)
137+
138+
139+
140+{- |
141+ Spoken metadata delimiters, such as "begin title level 1" and "end title level
142+ 1".
143+-}
144+speakMeta :: [Element] -> [Element] -> [Element]
145+speakMeta tag es =
146+ if null es
147+ then
148+ [
149+ node (unqual "VOLUME") ([unqualAttr "LEVEL" "quiet"], concat' $ tag),
150+ node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]
151+ ]
152+ else
153+ (
154+ node
155+ (unqual "VOLUME")
156+ (
157+ [unqualAttr "LEVEL" "quiet"],
158+ concat' $ (rawText "begin ") : tag
159+ )
160+ ) :
161+ (node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]) :
162+ es ++
163+ (
164+ node
165+ (unqual "VOLUME")
166+ (
167+ [unqualAttr "LEVEL" "quiet"],
168+ concat' $ (rawText "end ") : tag
169+ )
170+ ) :
171+ node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"] :
172+ []
173+
174+
175+
176+{- |
177+ Speak all characters (including whitespace) literally and slowly. This is
178+ meant for code and raw data.
179+-}
180+speakAllLiteral :: String -> Element
181+speakAllLiteral s =
182+ node (unqual "RATE") ([unqualAttr "SPEED" "slow"], handleNotWhitespace s)
183+ where
184+ whitespace = " \t\r\n"
185+
186+ isWhitespace = (`elem` whitespace)
187+
188+ spokenWhitespace ' ' = " space "
189+ spokenWhitespace '\t' = " tab "
190+ spokenWhitespace '\r' = " carriage return "
191+ spokenWhitespace '\n' = " newline "
192+ spokenWhitespace c = ' ':c:' ':[]
193+
194+ handleWhitespace :: String -> [Element]
195+ handleWhitespace [] = []
196+ handleWhitespace string@(c:rest)
197+ | isWhitespace c =
198+ (rawText $ spokenWhitespace c) :
199+ (node (unqual "BREAK") (unqualAttr "LEVEL" "Medium")) :
200+ (handleWhitespace rest)
201+ | otherwise = handleNotWhitespace string
202+
203+ handleNotWhitespace :: String -> [Element]
204+ handleNotWhitespace [] = []
205+ handleNotWhitespace string =
206+ let
207+ (nws, ws) = break isWhitespace string
208+ in
209+ (node (unqual "SAYAS") ((unqualAttr "MODE" "literal"), nws)) :
210+ (handleWhitespace ws)
211+
212+
213+
214+-- | Join a list of string with intercalated breaks.
215+insertBreaks
216+ :: String
217+ -- ^ Break level.
218+ -> (a -> ([Element] -> [Element]))
219+ {- ^
220+ A function to convert items of the given list to functions that prepend
221+ elements onto another list.
222+ -}
223+ -> [a]
224+ -> [Element]
225+insertBreaks _ _ [] = []
226+insertBreaks _ f (x:[]) = f x []
227+insertBreaks level f (x:xs) =
228+ (f x) $
229+ (node (unqual "BREAK") (unqualAttr "LEVEL" level)) :
230+ (insertBreaks level f xs)
231+
232+
233+
234+------------------------------------ Pandoc ------------------------------------
235+
236+-- | Pandoc writer for Sable.
237+writeSable :: WriterOptions -> Pandoc -> String
238+writeSable _ (Pandoc meta blocks) =
239+ pp $
240+ (formatMeta meta) ++
241+ (formatBlocks blocks)
242+
243+
244+
245+-- | Extract document title, authors and date from Meta.
246+formatMeta :: Meta -> [Element]
247+formatMeta meta =
248+ let
249+ title = docTitle meta
250+ authors = docAuthors meta
251+ date = docDate meta
252+ in
253+ (
254+ if null title
255+ then id
256+ else ((speakMeta [rawText "document title"] $ formatInlines title) ++)
257+ ) $
258+ (
259+ case authors of
260+ [] -> id
261+ (a:[]) -> ((speakMeta [rawText "document author"] $ formatInlines a) ++)
262+ _ ->
263+ ((
264+ speakMeta [rawText "document authors"] $
265+ insertBreaks "Medium" (++) $
266+ map formatInlines authors
267+ ) ++)
268+ ) $
269+ (
270+ if null date
271+ then []
272+ else
273+ speakMeta
274+ [rawText "document date"]
275+ [
276+ node
277+ (unqual "SAYAS")
278+ -- TODO: detect date format and set MODETYPE accordingly.
279+ ([unqualAttr "MODE" "date", unqualAttr "MODETYPE" "YMD"], formatInlines date)
280+ ]
281+ )
282+
283+
284+
285+-- | Format a list of blocks.
286+formatBlocks :: [Block] -> [Element]
287+formatBlocks = (insertBreaks "Large" (++)) . (map formatBlock)
288+
289+
290+
291+-- | Format a block.
292+formatBlock :: Block -> [Element]
293+formatBlock (Plain ss) = formatInlines ss
294+formatBlock (Para ss) = [node (unqual "DIV") ([unqualAttr "TYPE" "paragraph"], formatInlines ss)]
295+formatBlock (CodeBlock _ string) = speakMeta [rawText "code"] [speakAllLiteral string]
296+formatBlock (RawBlock (Format t) string) = speakMeta [rawText ("raw " ++ t)] [speakAllLiteral string]
297+formatBlock (BlockQuote blocks) = speakMeta [rawText "quote"] (formatBlocks blocks)
298+formatBlock (OrderedList attr bss) = formatList (Just attr) bss
299+formatBlock (BulletList bss) = formatList Nothing bss
300+formatBlock (DefinitionList defs) = formatDefinitionList defs
301+formatBlock (Header n _ ss) =
302+ speakMeta
303+ [
304+ (rawText "header level "),
305+ node (unqual "SAYAS") (unqualAttr "MODE" "cardinal", show n)
306+ ]
307+ (formatInlines ss)
308+formatBlock (HorizontalRule) = speakMeta [rawText "horizontal rule"] []
309+formatBlock (Table caption _ _ headerRow rows) = formatTable caption headerRow rows
310+formatBlock (Div _ bs) = formatBlocks bs
311+formatBlock (Null) = []
312+
313+
314+
315+-- | Format lists of inline elements.
316+formatInlines :: [Inline] -> [Element]
317+formatInlines = concat' . concat . (map formatInline)
318+
319+
320+
321+-- | Format inline elements.
322+formatInline :: Inline -> [Element]
323+formatInline (Str s) = [rawText s]
324+formatInline (Emph ss) = [node (unqual "EMPH") ([unqualAttr "LEVEL" "Moderate"], formatInlines ss)]
325+formatInline (Strong ss) = [node (unqual "EMPH") ([unqualAttr "LEVEL" "Strong"], formatInlines ss)]
326+formatInline (Strikeout ss) = speakMeta [rawText "strikeout"] (formatInlines ss)
327+formatInline (Superscript ss) = speakMeta [rawText "superscript"] (formatInlines ss)
328+formatInline (Subscript ss) = speakMeta [rawText "subscript"] (formatInlines ss)
329+formatInline (SmallCaps ss) = speakMeta [rawText "small caps"] (formatInlines ss)
330+formatInline (Quoted SingleQuote ss) = speakMeta [rawText "single quote"] (formatInlines ss)
331+formatInline (Quoted DoubleQuote ss) = speakMeta [rawText "double quote"] (formatInlines ss)
332+-- TODO: implement
333+formatInline (Cite _ _) = speakMeta [rawText "citation"] [rawText "citations are not yet supported"]
334+formatInline (Code _ s) = speakMeta [rawText "code"] [speakAllLiteral s]
335+formatInline (Space) = [rawText " "]
336+formatInline (LineBreak) = speakMeta [rawText "line break"] []
337+formatInline (Math _ s) = [node (unqual "SAYAS") ((unqualAttr "MODE" "math"), s)]
338+formatInline (RawInline (Format t) s) = speakMeta [rawText ("raw " ++ t)] [speakAllLiteral s]
339+formatInline (Link ss (u, _)) =
340+ speakMeta [rawText "link"] $
341+ (formatInlines ss) ++
342+ [
343+ node (unqual "BREAK") (unqualAttr "LEVEL" "Medium"),
344+ url u
345+ ]
346+formatInline (Image alt (u, _)) =
347+ speakMeta [rawText "image"] $
348+ (formatInlines alt) ++
349+ [
350+ node (unqual "BREAK") (unqualAttr "LEVEL" "Medium"),
351+ url u
352+ ]
353+formatInline (Note bs) = speakMeta [rawText "note"] (formatBlocks bs)
354+formatInline (Span _ ss) = formatInlines ss
355+
356+
357+
358+-- | Format a list.
359+formatList :: (Maybe ListAttributes) -> [[Block]] -> [Element]
360+formatList attr items =
361+ let
362+ f :: (Show s) => String -> s => Maybe Element
363+ f s x = Just $ node (unqual "SAYAS") ((unqualAttr "MODE" s), show x)
364+
365+ enumeration :: [Maybe Element]
366+ enumeration = case attr of
367+ Just (_, LowerAlpha, _) -> map (f "literal") ['a'..]
368+ Just (_, UpperAlpha, _) -> map (f "literal") ['A'..]
369+ Just _ -> map (f "cardinal") [(1 :: Int) ..]
370+ Nothing -> map (f "ordinal") [(1 :: Int) ..]
371+-- Nothing -> repeat Nothing
372+ in
373+ speakMeta [rawText "list"] $
374+ insertBreaks "Medium" (++) (map formatListItem (zip enumeration items))
375+
376+
377+
378+-- | Format a list item.
379+formatListItem :: (Maybe Element, [Block]) -> [Element]
380+formatListItem (Nothing, i) = formatBlocks i
381+formatListItem (Just e, i) =
382+ e :
383+ (node (unqual "BREAK") (unqualAttr "LEVEL" "Small")) :
384+ (rawText "\n") :
385+ (formatBlocks i)
386+
387+
388+
389+-- | Format a definition list.
390+formatDefinitionList :: [([Inline], [[Block]])] -> [Element]
391+formatDefinitionList defs =
392+ speakMeta [rawText "definition list"] $
393+ insertBreaks "Medium" (++) $
394+ map formatDefinition defs
395+
396+
397+
398+-- | Format a definition.
399+formatDefinition :: ([Inline], [[Block]]) -> [Element]
400+formatDefinition (header, body) =
401+ (node (unqual "EMPH") ([unqualAttr "LEVEL" "Moderate"], formatInlines header)) :
402+ (node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]) :
403+ (insertBreaks "Medium" (++) $ map formatBlocks body)
404+
405+
406+
407+-- | Fromat a table.
408+formatTable :: [Inline] -> [TableCell] -> [[TableCell]] -> [Element]
409+formatTable caption headerRow rows =
410+ speakMeta [rawText "table"] $
411+ (speakMeta [rawText "caption"] (formatInlines caption)) ++
412+ (formatHeaderRow headerRow) ++
413+ (formatBodyRows rows)
414+
415+formatHeaderRow :: [TableCell] -> [Element]
416+formatHeaderRow hcs =
417+ speakMeta [rawText "headers"] (concat' $ concat $ map formatHeaderCell hcs)
418+
419+formatHeaderCell :: TableCell -> [Element]
420+formatHeaderCell hc = speakMeta [rawText "header"] (formatBlocks hc)
421+
422+formatBodyRows :: [[TableCell]] -> [Element]
423+formatBodyRows = (insertBreaks "Small" (++)) . (map formatBodyRow)
424+
425+formatBodyRow :: [TableCell] -> [Element]
426+formatBodyRow hcs = speakMeta [rawText "row"] (concat' $ concat $ map formatBodyCell hcs)
427+
428+formatBodyCell :: TableCell -> [Element]
429+formatBodyCell bc = speakMeta [rawText "cell"] (formatBlocks bc)