@@ -0,0 +1,427 @@
1+{-# OPTIONS_GHC -fwarn-unused-imports #-}
4+ by xyne.archlinux.com - released under GPL 2
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.
14+ To produce audio on the fly:
16+ $ festival --tts <sable file>
18+ To generate .wav and .mp3 files (text2wave is included with festival):
20+ $ text2wav <sable file>
21+ $ lame -V2 <wav file>
24+ * [Sable version 1.0](http://www.bell-labs.com/project/tts/sable.html)
27+module Text.Pandoc.Writers.Sable
32+import Text.Pandoc.Definition hiding (Attr)
33+import Text.Pandoc.Options
36+------------------------------------- XML --------------------------------------
38+-- | Sable DOCTYPE string.
40+doctype = "<!DOCTYPE SABLE PUBLIC \"-//SABLE//DTD SABLE speech mark up//EN\" \"Sable.v0_2.dtd\" []>"
44+-- | Convert the document to a string with the XML header and DOCTYPE.
45+pp :: [Element] -> String
50+ (ppElement $ node (unqual "SABLE") e)
55+-- | Convert a key-value pair to an unqualified Attr.
56+unqualAttr :: String -> String -> Attr
65+-- | The tag used to wrap plain text.
71+-- | Wrap a node type in a dummy element.
72+dummyElement :: (Node t) => t -> Element
73+dummyElement = node (unqual dummyTag)
77+-- | Concat plaintext elements.
78+concat' :: [Element] -> [Element]
81+ extract ~(Text (CData {cdData = s})) = s
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
89+ else (naiveBreaks [] s) ++ (e : (f [] es))
93+ else naiveBreaks [] s
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
106+-- | Internal function for naiveBreaks.
107+punctuationBreak :: Char -> String -> ([Element] -> [Element])
108+punctuationBreak c s =
117+ ((node (unqual "BREAK") [unqualAttr "LEVEL" "Medium", unqualAttr "TYPE" typ]) :)
121+-- | Insert raw text.
122+rawText :: String -> Element
123+rawText s = dummyElement $ CData
125+ cdVerbatim = CDataText,
133+url :: String -> Element
134+url u = node (unqual "SAYAS") ([unqualAttr "MODE" "net", unqualAttr "MODETYPE" "URL"], u)
139+ Spoken metadata delimiters, such as "begin title level 1" and "end title level
142+speakMeta :: [Element] -> [Element] -> [Element]
147+ node (unqual "VOLUME") ([unqualAttr "LEVEL" "quiet"], concat' $ tag),
148+ node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]
155+ [unqualAttr "LEVEL" "quiet"],
156+ concat' $ (rawText "begin ") : tag
159+ (node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"]) :
165+ [unqualAttr "LEVEL" "quiet"],
166+ concat' $ (rawText "end ") : tag
169+ node (unqual "BREAK") [unqualAttr "LEVEL" "Small", unqualAttr "TYPE" "!"] :
175+ Speak all characters (including whitespace) literally and slowly. This is
176+ meant for code and raw data.
178+speakAllLiteral :: String -> Element
180+ node (unqual "RATE") ([unqualAttr "SPEED" "slow"], handleNotWhitespace s)
182+ whitespace = " \t\r\n"
184+ isWhitespace = (`elem` whitespace)
186+ spokenWhitespace ' ' = " space "
187+ spokenWhitespace '\t' = " tab "
188+ spokenWhitespace '\r' = " carriage return "
189+ spokenWhitespace '\n' = " newline "
190+ spokenWhitespace c = ' ':c:' ':[]
192+ handleWhitespace :: String -> [Element]
193+ handleWhitespace [] = []
194+ handleWhitespace string@(c:rest)
196+ (rawText $ spokenWhitespace c) :
197+ (node (unqual "BREAK") (unqualAttr "LEVEL" "Medium")) :
198+ (handleWhitespace rest)
199+ | otherwise = handleNotWhitespace string
201+ handleNotWhitespace :: String -> [Element]
202+ handleNotWhitespace [] = []
203+ handleNotWhitespace string =
205+ (nws, ws) = break isWhitespace string
207+ (node (unqual "SAYAS") ((unqualAttr "MODE" "literal"), nws)) :
208+ (handleWhitespace ws)
212+-- | Join a list of string with intercalated breaks.
216+ -> (a -> ([Element] -> [Element]))
218+ A function to convert items of the given list to functions that prepend
219+ elements onto another list.
223+insertBreaks _ _ [] = []
224+insertBreaks _ f (x:[]) = f x []
225+insertBreaks level f (x:xs) =
227+ (node (unqual "BREAK") (unqualAttr "LEVEL" level)) :
228+ (insertBreaks level f xs)
232+------------------------------------ Pandoc ------------------------------------
234+-- | Pandoc writer for Sable.
235+writeSable :: WriterOptions -> Pandoc -> String
236+writeSable _ (Pandoc meta blocks) =
238+ (formatMeta meta) ++
239+ (formatBlocks blocks)
243+-- | Extract document title, authors and date from Meta.
244+formatMeta :: Meta -> [Element]
247+ title = docTitle meta
248+ authors = docAuthors meta
254+ else ((speakMeta [rawText "document title"] $ formatInlines title) ++)
259+ (a:[]) -> ((speakMeta [rawText "document author"] $ formatInlines a) ++)
262+ speakMeta [rawText "document authors"] $
263+ insertBreaks "Medium" (++) $
264+ map formatInlines authors
272+ [rawText "document date"]
276+ -- TODO: detect date format and set MODETYPE accordingly.
277+ ([unqualAttr "MODE" "date", unqualAttr "MODETYPE" "YMD"], formatInlines date)
283+-- | Format a list of blocks.
284+formatBlocks :: [Block] -> [Element]
285+formatBlocks = (insertBreaks "Large" (++)) . (map formatBlock)
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) =
302+ (rawText "header level "),
303+ node (unqual "SAYAS") (unqualAttr "MODE" "cardinal", show n)
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) = []
313+-- | Format lists of inline elements.
314+formatInlines :: [Inline] -> [Element]
315+formatInlines = concat' . concat . (map formatInline)
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)
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) ++
341+ node (unqual "BREAK") (unqualAttr "LEVEL" "Medium"),
344+formatInline (Image alt (u, _)) =
345+ speakMeta [rawText "image"] $
346+ (formatInlines alt) ++
348+ node (unqual "BREAK") (unqualAttr "LEVEL" "Medium"),
351+formatInline (Note bs) = speakMeta [rawText "note"] (formatBlocks bs)
352+formatInline (Span _ ss) = formatInlines ss
357+formatList :: (Maybe ListAttributes) -> [[Block]] -> [Element]
358+formatList attr items =
360+ f :: (Show s) => String -> s => Maybe Element
361+ f s x = Just $ node (unqual "SAYAS") ((unqualAttr "MODE" s), show x)
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
371+ speakMeta [rawText "list"] $
372+ insertBreaks "Medium" (++) (map formatListItem (zip enumeration items))
376+-- | Format a list item.
377+formatListItem :: (Maybe Element, [Block]) -> [Element]
378+formatListItem (Nothing, i) = formatBlocks i
379+formatListItem (Just e, i) =
381+ (node (unqual "BREAK") (unqualAttr "LEVEL" "Small")) :
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
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)
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)
413+formatHeaderRow :: [TableCell] -> [Element]
414+formatHeaderRow hcs =
415+ speakMeta [rawText "headers"] (concat' $ concat $ map formatHeaderCell hcs)
417+formatHeaderCell :: TableCell -> [Element]
418+formatHeaderCell hc = speakMeta [rawText "header"] (formatBlocks hc)
420+formatBodyRows :: [[TableCell]] -> [Element]
421+formatBodyRows = (insertBreaks "Small" (++)) . (map formatBodyRow)
423+formatBodyRow :: [TableCell] -> [Element]
424+formatBodyRow hcs = speakMeta [rawText "row"] (concat' $ concat $ map formatBodyCell hcs)
426+formatBodyCell :: TableCell -> [Element]
427+formatBodyCell bc = speakMeta [rawText "cell"] (formatBlocks bc)