~alcinnz/rhapsode

ref: f1a311bde5149ce6abff67f809b4215a04ca5470 rhapsode/src/Main.hs -rw-r--r-- 5.1 KiB
f1a311bd — Adrian Cochrane Implement mappings to SSML <prosody> attributes. 4 years ago 
                                                                                
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
{-# LANGUAGE OverloadedStrings #-}
module Main where

import System.Environment

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)

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

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
    C8.putStrLn $ renderElLBS $ stylizeEl style html

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

retreiveStyles html manager base = do
    style <- H2C.externalStyles authorStyle testMedia html loadURL
    return style
  where
    emptyStyle :: Style.QueryableStyleSheet MapPropertyParser
    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


stylizeEl styles html
        | XML.NodeElement el <- H2C.traverseStyles buildEl buildText styles html = el
        |otherwise = XML.Element name M.empty []
    where
        buildEl (MPP attrs) children = XML.NodeElement $ XML.Element name attrs children
        buildText _ txt = XML.NodeContent txt
        name = XML.Name "prosody" Nothing Nothing

data MapPropertyParser = MPP (M.Map XML.Name Text)
addAttr self name value = Just $ MPP $ M.insert (XML.Name name Nothing Nothing) value self
lowerHz n "khz" absolute = lowerHz (n*1000) "hz" absolute
-- Relative offsets are communicated in SSML by the presence of a sign character.
lowerHz n "hz" True | n < 0 = "0hz"
    | otherwise = Txt.pack (show n ++ "hz")
lowerHz n "hz" False | n < 0 = Txt.pack (show n ++ "hz")
    | otherwise = Txt.pack ('+' : show n ++ "hz")

cssFloat :: CSSTok.NumericValue -> Float
cssFloat (CSSTok.NVInteger i) = fromInteger i
cssFloat (CSSTok.NVNumber n) = toRealFloat n

instance Style.PropertyParser MapPropertyParser where
    temp = MPP M.empty
    inherit _ = Style.temp

    longhand _ (MPP self) "voice-volume" [CSSTok.Ident kw] -- TODO handle offsets
        | kw `elem` ["silent", "x-soft", "soft", "medium", "loud", "x-loud"] = addAttr self "volume" kw
    longhand _ (MPP self) "voice-volume" [CSSTok.Ident "initial"] = addAttr self "volume" "medium"

    longhand _ (MPP self) "voice-rate" [CSSTok.Ident kw] -- TODO handle percentages
        | kw `elem` ["x-slow", "slow", "medium", "fast", "x-fast"] = addAttr self "rate" kw
        | kw `elem` ["initial", "normal"] = addAttr self "rate" "default"

    longhand _ (MPP self) "voice-pitch" [CSSTok.Ident kw] -- TODO handle offsets
        | kw `elem` ["x-low", "low", "medium", "high", "x-high"] = addAttr self "pitch" kw
    longhand _ (MPP self) "voice-pitch" [CSSTok.Ident "initial"] = addAttr self "pitch" "medium"
    longhand _ (MPP self) "voice-pitch" [CSSTok.Dimension _ n unit, CSSTok.Ident "absolute"] =
        addAttr self "pitch" $ lowerHz (cssFloat n) unit True
    longhand _ (MPP self) "voice-pitch" [CSSTok.Ident "absolute", CSSTok.Dimension _ n unit] =
        addAttr self "pitch" $ lowerHz (cssFloat n) unit True
    longhand _ (MPP self) "voice-pitch" [CSSTok.Dimension _ n unit] =
        addAttr self "pitch" $ lowerHz (cssFloat n) unit False

    longhand _ (MPP self) "voice-range" [CSSTok.Ident kw] -- TODO handle offsets
        | kw `elem` ["x-low", "low", "medium", "high", "x-high"] = addAttr self "range" kw
    longhand _ (MPP self) "voice-range" [CSSTok.Ident "initial"] = addAttr self "range" "medium"
    longhand _ (MPP self) "voice-range" [CSSTok.Dimension _ n unit, CSSTok.Ident "absolute"] =
        addAttr self "range" $ lowerHz (cssFloat n) unit True
    longhand _ (MPP self) "voice-range" [CSSTok.Ident "absolute", CSSTok.Dimension _ n unit] =
        addAttr self "range" $ lowerHz (cssFloat n) unit True
    longhand _ (MPP self) "voice-range" [CSSTok.Dimension _ n unit] =
        addAttr self "range" $ lowerHz (cssFloat n) unit False

    longhand _ self _ [CSSTok.Ident "inherit"] = Just self -- Imply the inheritance
    longhand _ _ _ _ = Nothing