M rhapsode.cabal => rhapsode.cabal +1 -1
@@ 54,7 54,7 @@ library
exposed-modules: CExports, Input, Links, Render, Types
-- Modules included in this library.
- other-modules: SSML, SpeechStyle
+ other-modules: SSML, SpeechStyle, MimeInfo
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
M src/Links.hs => src/Links.hs +7 -0
@@ 9,6 9,7 @@ import qualified Data.Text.Foreign as FTxt
import Data.Maybe
import Types
+import MimeInfo
import Foreign.StablePtr
import Foreign.C.String
import Foreign.Marshal.Array
@@ 59,6 60,12 @@ extractEl path el@(Element (Name "details" _ _) _ childs) =
extractEl _ (Element "{https://specifications.freedesktop.org/metainfo/1.0}url" attrs childs)
| Just label <- "{https://specifications.freedesktop.org/metainfo/1.0}type" `M.lookup` attrs,
Just url <- parseAbsoluteURI $ unpack $ nodesText childs "" = [Link label "" url]
+extractEl _ el@(Element _ attrs [])
+ | Just "alternae" <- "rel" `M.lookup` attrs', Just typ <- "type" `M.lookup` attrs',
+ Just val <- "href" `M.lookup` attrs', Just uri <- parseURIReference $ unpack val =
+ let Application name _ title _ = mimeInfoCached $ unpack typ
+ in [Link (pack name) (pack title) uri]
+ where attrs' = M.mapKeys nameLocalName attrs
extractEl path el@(Element _ _ children) =
extractElAttr el "href" ++
extractElAttr el "longdesc" ++
M src/MimeInfo.hs => src/MimeInfo.hs +47 -7
@@ 1,7 1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module MimeInfo(readMimeInfo, mimeInfoCached) where
-import Types (Application(..))
+import Network.URI.Fetch (Application(..))
import Network.URI
import Text.XML as XML
@@ 14,12 14,13 @@ import System.Directory (doesFileExist)
import System.IO (hPrint, stderr)
import Control.Monad (forM)
import Control.Exception (catch)
-import Data.Maybe (catMaybes, maybeToList, fromMaybe)
+import Data.Maybe (catMaybes, maybeToList, fromMaybe, mapMaybe)
import qualified Data.Trie.Text as Trie
import Data.Trie.Text (Trie)
import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
import System.IO.Unsafe (unsafePerformIO)
+import Data.Char (toLower)
readMimeInfo :: [String] -> String -> IO Application
readMimeInfo locales mime = do
@@ 95,12 96,51 @@ replace _ _ [] = []
---- Pseudo-pure, caching API
--------
-mimeInfoCached :: [String] -> IO (String -> Application)
-mimeInfoCached locales = do
+{-# NOINLINE mimeInfoCached #-}
+mimeInfoCached :: String -> Application
+mimeInfoCached = unsafePerformIO $ do
+ (locales, _) <- rfc2616Locale
cache <- newMVar Trie.empty :: IO (MVar (Trie Application))
- return $ \mime -> unsafePerformIO $ modifyMVar cache $ inner (pack mime)
+ return $ \mime -> unsafePerformIO $ modifyMVar cache $ inner (pack mime) locales
where
- inner mime cache | Just val <- mime `Trie.lookup` cache = return (cache, val)
- inner mime cache = do
+ inner mime _ cache | Just val <- mime `Trie.lookup` cache = return (cache, val)
+ inner mime locales cache = do
ret <- readMimeInfo locales $ unpack mime
return (Trie.insert mime ret cache, ret)
+
+--------
+---- Locales
+--------
+
+rfc2616Locale :: IO ([String], [String])
+rfc2616Locale = do
+ locales <- forM ["LANGUAGE", "LC_ALL", "LC_MESSAGES", "LANG"] lookupEnv
+ let posix = split ':' $ firstJust locales "en_US"
+ let ietf = mapMaybe toRFC2616Lang posix
+ return (explode ietf, explode posix)
+
+toRFC2616Lang "C" = Nothing
+toRFC2616Lang ('C':'.':_) = Nothing
+toRFC2616Lang ('C':'@':_) = Nothing
+toRFC2616Lang lang = case toRFC2616Lang' lang of
+ "" -> Nothing
+ lang' -> Just lang'
+
+toRFC2616Lang' ('_':cs) = '-' : toRFC2616Lang' cs
+toRFC2616Lang' ('.':_) = []
+toRFC2616Lang' ('@':_) = []
+toRFC2616Lang' (c:cs) = toLower c : toRFC2616Lang' cs
+toRFC2616Lang' [] = []
+
+-- Makes sure to include the raw languages, and not just localized variants.
+extractLangs :: [String] -> [String]
+extractLangs (locale:locales) | (lang:_) <- split '-' locale = lang : extractLangs locales
+extractLangs (_:locales) = extractLangs locales
+extractLangs [] = []
+
+explode :: [String] -> [String]
+explode locales = locales ++ [l | l <- extractLangs locales, l `notElem` locales]
+
+firstJust (Just a:_) _ | a /= "" = a
+firstJust (_:maybes) fallback = firstJust maybes fallback
+firstJust [] fallback = fallback
M src/SpeechStyle.hs => src/SpeechStyle.hs +4 -0
@@ 9,6 9,8 @@ import Data.Scientific (toRealFloat)
import Data.Maybe (isJust, catMaybes, fromMaybe)
import Text.Read (readMaybe) -- to parse <progress> into a more international textual representation.
+import MimeInfo (mimeInfoCached) -- to correct label of rel=alternate links.
+import Network.URI.Fetch as App (Application(..))
data Unit' = Unit' Text Float
data SpeechStyle = SpeechStyle {
@@ 196,6 198,8 @@ parseStrings (Function "-rhaps-percentage":String num:String denom:RightParen:to
frac = round (readNum num / readNum denom * 100)
readNum :: Text -> Float
readNum = fromMaybe (0.0) . readMaybe . unpack
+parseStrings (Function "-rhaps-filetype":String mime:RightParen:toks) =
+ append (pack $ App.name $ mimeInfoCached $ unpack mime) <$> parseStrings toks
parseStrings [] = Just ""
parseStrings _ = Nothing
M useragent.css => useragent.css +3 -1
@@ 54,7 54,9 @@ p, pre, samp, blockquote {pause: strong; -rhaps-marker: -rhaps-paragraph}
pre, address, samp {speak-as: literal-punctuation}
pre, samp, code {voice: neutral 2; white-space: pre;}
:link {cue-after: url(about:link.wav) !important; voice-pitch: low}
-link[rel] {content: attr(rel)} link[title] {content: attr(title)} /* [title] overrides [rel] */
+link[rel] {content: attr(rel)}
+link[rel=alternate][type] {content: -rhaps-filetype(attr(type))}
+link[title] {content: attr(title)} /* [title] overrides [rel] */
:visited {cue-after: url(about:link.wav) -0.1db !important}
img {content: "Image " attr(src)}
img:lang(hu):not([alt]) {content: "kép " attr(src)}