~alcinnz/rhapsode

ref: b5f53aef8a6f9d01d0c971187eef8847d2b4084c rhapsode/src/Main.hs -rw-r--r-- 5.7 KiB
b5f53aef — Adrian Cochrane Allow adjusting keyword values. 5 years ago
                                                                                
aea2a653 Adrian Cochrane
7523fb56 Adrian Cochrane
18bd686d Adrian Cochrane
eddbb26a Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
a59899dd Adrian Cochrane
aea2a653 Adrian Cochrane
eddbb26a Adrian Cochrane
a59899dd Adrian Cochrane
10988819 Adrian Cochrane
a59899dd Adrian Cochrane
10988819 Adrian Cochrane
f1a311bd Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
eddbb26a Adrian Cochrane
18bd686d Adrian Cochrane
7523fb56 Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
eddbb26a Adrian Cochrane
a59899dd Adrian Cochrane
aea2a653 Adrian Cochrane
10988819 Adrian Cochrane
53b9d822 Adrian Cochrane
a59899dd Adrian Cochrane
eddbb26a Adrian Cochrane
10988819 Adrian Cochrane
53b9d822 Adrian Cochrane
aea2a653 Adrian Cochrane
10988819 Adrian Cochrane
aea2a653 Adrian Cochrane
afbc3c05 Adrian Cochrane
a59899dd Adrian Cochrane
eddbb26a Adrian Cochrane
10988819 Adrian Cochrane
eddbb26a Adrian Cochrane
b5f53aef Adrian Cochrane
eddbb26a Adrian Cochrane
b5f53aef Adrian Cochrane
eddbb26a Adrian Cochrane
b5f53aef Adrian Cochrane
eddbb26a Adrian Cochrane
b5f53aef Adrian Cochrane
eddbb26a Adrian Cochrane
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
{-# LANGUAGE OverloadedStrings #-}
module Main where

import System.Environment
import Data.Char (isSpace)

import qualified Network.HTTP.Client as HTTP
import           Network.HTTP.Client.Internal
import qualified Network.HTTP.Client.TLS as TLS
import           Network.URI
import qualified Data.ByteString.Lazy.Char8 as C8

import qualified Text.HTML.DOM as HTML
import qualified Text.XML as XML
import           Data.Text as Txt (pack, unpack, Text(..), append,
        words, unwords, head, last, stripStart, stripEnd)

import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Style as Style
import qualified Data.CSS.Syntax.Tokens as CSSTok
import qualified Data.HTML2CSS as H2C

import qualified Data.List as L
import qualified Data.Map as M
import Data.Scientific (toRealFloat)

import DefaultCSS
import StyleTree

main :: IO ()
main = do
    url:_ <- getArgs
    -- TODO support more URI schemes, and do nonblocking networking. This could be it's own module.
    request <- HTTP.parseRequest url
    manager <- HTTP.newManager TLS.tlsManagerSettings
    response <- HTTP.httpLbs request manager
    let html = XML.documentRoot $ HTML.parseLBS $ HTTP.responseBody response
    style <- retreiveStyles html manager request
    let transcript = stylize style html
    C8.putStrLn $ renderElLBS $ styleToSSML transcript

retreiveStyles html manager base = do
    style <- H2C.externalStyles authorStyle testMedia html loadURL
    return style
  where
    emptyStyle :: Style.QueryableStyleSheet StyleTree
    emptyStyle = Style.queryableStyleSheet
    agentStyle = H2C.cssPriorityAgent emptyStyle `CSS.parse` Txt.pack userAgentCSS
    authorStyle = H2C.internalStyles testMedia agentStyle html

    loadURL url = do -- TODO parallelise.
        request <- setUriRelative base url
        response <- HTTP.httpLbs request manager
        return $ Txt.pack $ C8.unpack $ HTTP.responseBody response

testMedia attrs = media == Nothing || media == Just "speech"
    where media = "media" `M.lookup` attrs


stylize styles html = H2C.traverseStyles buildNode buildText styles html
    where
        buildNode self children = self {children = children}
        buildText _ txt = Style.temp {content = txt}

styleToSSML StyleTree {speak = False} =
    XML.Element (XML.Name "blank" Nothing Nothing) M.empty []
styleToSSML self =  buildEl0 "prosody" [
            ("volume", volume self),
            ("rate", rate self),
            ("pitch", serializePitch $ pitch self),
            ("range", serializePitch $ range self)
        ] $ buildEl0 "prosody" [
            ("volume", maybeAdjust $ volumeAdjust self),
            ("rate", maybeAdjust $ rateAdjust self),
            ("pitch", maybeAdjust $ pitchAdjust $ pitch self),
            ("range", maybeAdjust $ pitchAdjust $ range self)
        ] $ buildEl0 "emphasis" [("level", stress self)] $
        buildEl0 "say-as" [("interpret-as", speakAs self)] $
        buildEl0 "tts:style" [
            ("field", maybeBool (punctuation self) "punctuation" "punctuation"),
            ("mode", maybeBool (punctuation self) "all" "none")
        ] $ buildVoices (voice self) (
            XML.NodeContent (content self) :
            map (\node -> XML.NodeElement $ styleToSSML node) (children self)
        )

serializePitch Inherit = Nothing
serializePitch (Pitch kw _) = Just kw
serializePitch (Absolute "khz" n) = serializePitch $ Absolute "hz" (1000 * n)
serializePitch (Absolute _ n) | n < 0 = Nothing
    | otherwise = Just $ Txt.pack (show n ++ "hz")
serializePitch (Relative unit n) = Just $ relativeUnit unit n

relativeUnit "khz" n = relativeUnit "hz" $ 1000 * n
relativeUnit unit n | n < 0 = Txt.pack (show n) `Txt.append` unit
    | otherwise = Txt.pack ('+':show n) `Txt.append` unit

maybeBool (Just True) truthy _ = Just truthy
maybeBool (Just False) _ falsy = Just falsy
maybeBool Nothing _ _ = Nothing

maybeCast (Just n) = Just $ Txt.pack $ show n
maybeCast Nothing = Nothing

maybeAdjust (Just (Unit' unit n)) = Just $ relativeUnit unit n
maybeAdjust Nothing = Nothing

buildVoice (Voice name) children = buildEl "voice" [("name", Just name)] children
buildVoice (VoicePattern age gender variant) children = buildEl "voice" [
        ("age", maybeCast age),
        ("gender", Just gender),
        ("variant", maybeCast variant)
    ] children

buildVoices Nothing = buildEl "blank" []
buildVoices (Just voice) = buildVoice voice

--------
---- XML Output Utils
--------
buildEl name attrs elChildren =
    XML.Element (XML.Name name Nothing Nothing) (attrsFromList attrs) elChildren
buildEl0 name attrs child = buildEl name attrs [XML.NodeElement child]

attrsFromList ((name, Just value):attrs) =
    M.insert (XML.Name name Nothing Nothing) value $ attrsFromList attrs
attrsFromList ((_, Nothing):attrs) = attrsFromList attrs
attrsFromList [] = M.empty

stripEmptyEls (XML.Element name attrs elChildren) =
    XML.Element name attrs $ stripEmptyNodes elChildren
stripEmptyNodes (XML.NodeElement el@(XML.Element _ attrs elChildren ):nodes)
    | M.null attrs = stripEmptyNodes (elChildren ++ nodes)
    | otherwise = XML.NodeElement (stripEmptyEls el) : stripEmptyNodes nodes
stripEmptyNodes (XML.NodeContent txt : nodes) = -- strip whitespace
    XML.NodeContent (collapseSpaces txt) : stripEmptyNodes nodes
stripEmptyNodes (node:nodes) = stripEmptyNodes nodes
stripEmptyNodes [] = []

collapseSpaces txt
    | txt == "" = "" -- Avoids errors from head/tail tests.
    | isSpace $ Txt.head txt = " " `Txt.append` collapseSpaces (Txt.stripStart txt)
    | isSpace $ Txt.last txt = collapseSpaces (Txt.stripEnd txt) `Txt.append` " "
    | otherwise = Txt.unwords $ Txt.words txt

renderElLBS el = XML.renderLBS XML.def $ XML.Document {
        XML.documentPrologue = XML.Prologue [] Nothing [],
        XML.documentRoot = stripEmptyEls el,
        XML.documentEpilogue = []
    }