hsay 1.0.0 → 1.1.0
raw patch · 3 files changed
+153/−143 lines, 3 filesdep +Hclip
Dependencies added: Hclip
Files
- hsay.cabal +14/−11
- src-exec/Hsay.hs +0/−132
- src-exec/hsay.hs +139/−0
hsay.cabal view
@@ -1,8 +1,5 @@--- Initial hsay.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/- name: hsay-version: 1.0.0+version: 1.1.0 synopsis: (ab)Use Google Translate as a speech synthesiser description: (ab)Use Google Translate as a speech synthesiser. @@ -14,15 +11,21 @@ maintainer: alexander@plaimi.net copyright: Alexander Berntsen 2014 category: Accessibility+ build-type: Simple cabal-version: >=1.10 data-files: data/flip.mp3 +source-repository head+ type: git+ location: git://github.com/alexander-b/hsay.git+ executable hsay- hs-source-dirs: src-exec- main-is: Hsay.hs- build-depends: base >=4.7 && <4.8,- HTTP >= 4000.2 && < 4000.3,- process >= 1.2.0.0 && < 1.3.0.0,- unix >= 2.7.0.0 && < 2.8.0.0- default-language: Haskell2010+ default-language: Haskell2010+ hs-source-dirs: src-exec+ main-is: hsay.hs+ build-depends: base >=4.7 && <4.8,+ Hclip >=3 && <4,+ HTTP >= 4000.2 && < 4000.3,+ process >= 1.2.0.0 && < 1.3.0.0,+ unix >= 2.7.0.0 && < 2.8.0.0
− src-exec/Hsay.hs
@@ -1,132 +0,0 @@-{- |-Module : $Header$-Description : hsay.-Copyright : (c) Alexander Berntsen 2014-License : GPL-3--Maintainer : alexander@plaimi.net--} module Main where--import Control.Arrow- (- second,- )-import Data.List- (- intersperse,- )-import Data.Monoid- (- Sum (Sum),- mappend,- mempty,- )-import GHC.IO.Exception- (- ExitCode,- )-import Network.HTTP.Base- (- urlEncode,- )-import System.Environment- (- getArgs,- )-import System.Exit- (- exitWith,- )-import System.IO- (- hFlush,- stdout,- )-import System.Posix.IO- (- stdInput,- )-import System.Posix.Terminal- (- queryTerminal,- )-import System.Process- (- spawnProcess,- waitForProcess,- )--import Paths_hsay--data Language = MkLang {lang :: String}- | DefLang {lang :: String}--defprogopts :: (String, [String])-defprogopts = ("mpg123", ["-q"])--infixr 9 ~+~-(~+~) :: IO a -> IO a -> IO a-f ~+~ g = queryTerminal stdInput >>= \t -> if t then f else g--main :: IO ()-main = do- as <- getArgs- f <- getDataFileName "data/flip.mp3"- uncurry tts (getLang as) f--getLang :: [String] -> (Language, [String])-getLang (('-':l):xs) = (MkLang l, xs)-getLang xs = (DefLang "en", xs)--tts :: Language -> [String] -> FilePath -> IO ()-tts l [] f = resl l f ~+~ (getContents >>= \cs -> run l (words cs) f)-tts l as f = run l as f--run :: Language -> [String] -> FilePath -> IO ()-run l as f = fork (build l as f) >>= exitWith--resl :: Language -> FilePath -> IO ()-resl l f = do- putStr ">"- hFlush stdout- n <- getLine- case take 5 n of- "#LANG" -> resl (MkLang $ drop 6 n) f- _ -> fork (build l (words n) f) >> resl l f- -fork :: (FilePath, [String]) -> IO ExitCode-fork f = uncurry spawnProcess f >>= waitForProcess--build :: Language -> [String] -> FilePath -> (FilePath, [String])-build l xs f = (++ intersperse f [ mkUrl l $ unwords t- | t <- chunk [] xs ]) `second` defprogopts--mkUrl :: Language -> String -> String-mkUrl l us = "http://translate.google.com/translate_tts?ie=UTF-8&tl="- ++ lang l ++ "&q=" ++ urlEncode us--concatInits :: [Sum Int] -> [Sum Int]--- Thanks to ollef for this.-concatInits = go mempty- where- go _ [] = []- go acc (x:xs) = x' : go x' xs where x' = mappend acc x--fit :: [[a]] -> [[a]]--- Thanks to ollef for this.-fit xs = map snd $ takeWhile ((< Sum 101) . fst) $ zip lxs xs- where lxs = concatInits $ map (Sum . (+1) . length) xs--chunk :: Eq a => [[[a]]] -> [[a]] -> [[[a]]]--- The left list is the parsed-to-appropriate-size 'a's.--- The right list is the yet-to-be-parsed-to-appropriate-size 'a's.-chunk xs [] = xs-chunk xs yss@(y:ys) = case fit [y] of- [] -> chunk (xs ++ [[take 99 y]]) (drop 99 y : ys)- _ -> chunk (xs ++ [fit yss]) (diff (fit yss) yss)--diff :: Eq a => [a] -> [a] -> [a]-diff [] ys = ys-diff _ [] = []-diff (x:xs) (y:ys) | x == y = diff xs ys- | otherwise = ys
+ src-exec/hsay.hs view
@@ -0,0 +1,139 @@+{- |+Module : $Header$+Description : hsay.+Copyright : (c) Alexander Berntsen 2014+License : GPL-3++Maintainer : alexander@plaimi.net+-} module Main where++import Control.Arrow+ (+ second,+ )+import Data.List+ (+ intersperse,+ )+import Data.Monoid+ (+ Sum (Sum),+ mappend,+ mempty,+ )+import GHC.IO.Exception+ (+ ExitCode,+ )+import Network.HTTP.Base+ (+ urlEncode,+ )+import System.Environment+ (+ getArgs,+ )+import System.Exit+ (+ exitWith,+ )+import System.Hclip+ (+ getClipboard,+ )+import System.IO+ (+ hFlush,+ stdout,+ )+import System.Posix.IO+ (+ stdInput,+ )+import System.Posix.Terminal+ (+ queryTerminal,+ )+import System.Process+ (+ spawnProcess,+ waitForProcess,+ )++import Paths_hsay++data Language = MkLang {lang :: String}+ | DefLang {lang :: String}++defprogopts :: (String, [String])+defprogopts = ("mpg123", ["-q"])++infixr 9 ~+~+(~+~) :: IO a -> IO a -> IO a+f ~+~ g = queryTerminal stdInput >>= \t -> if t then f else g++main :: IO ()+main = do+ as <- getArgs+ f <- getDataFileName "data/flip.mp3"+ uncurry tts (getLang as) f++getLang :: [String] -> (Language, [String])+getLang (('-':l):xs) = (MkLang l, xs)+getLang xs = (DefLang "en", xs)++tts :: Language -> [String] -> FilePath -> IO ()+tts l [] f = resl l f ~+~ (getContents >>= \cs -> run l (words cs) f)+tts l as f = run l as f++run :: Language -> [String] -> FilePath -> IO ()+run l as f = fork (build l as f) >>= exitWith++resl :: Language -> FilePath -> IO ()+resl l f = do+ putStr ">"+ hFlush stdout+ n <- getLine+ case take 5 n of+ "#LANG" -> resl (MkLang $ drop 6 n) f+ "#CLIP" -> do+ c <- getClipboard+ fork (build l (words c) f) >> resl l f+ _ -> fork (build l (words n) f) >> resl l f+ +fork :: (FilePath, [String]) -> IO ExitCode+fork f = uncurry spawnProcess f >>= waitForProcess++build :: Language -> [String] -> FilePath -> (FilePath, [String])+build l xs f = (++ intersperse f [ mkUrl l $ unwords t+ | t <- chunk [] xs ]) `second` defprogopts++mkUrl :: Language -> String -> String+mkUrl l us = "http://translate.google.com/translate_tts?ie=UTF-8&tl="+ ++ lang l ++ "&q=" ++ urlEncode us++concatInits :: [Sum Int] -> [Sum Int]+-- Thanks to ollef for this.+concatInits = go mempty+ where+ go _ [] = []+ go acc (x:xs) = x' : go x' xs where x' = mappend acc x++fit :: [[a]] -> [[a]]+-- Thanks to ollef for this.+fit xs = map snd $ takeWhile ((< Sum 101) . fst) $ zip lxs xs+ where lxs = concatInits $ map (Sum . (+1) . length) xs++chunk :: Eq a => [[[a]]] -> [[a]] -> [[[a]]]+-- The left list is the parsed-to-appropriate-size 'a's.+-- The right list is the yet-to-be-parsed-to-appropriate-size 'a's.+chunk xs [] = xs+chunk xs yss@(y:ys) = case fit [y] of+ [] -> chunk (xs ++ [[take 99 y]]) (drop 99 y : ys)+ _ -> chunk (xs ++ [fit yss]) (diff (fit yss) yss)++diff :: Eq a => [a] -> [a] -> [a]+diff [] ys = ys+diff _ [] = []+diff (x:xs) (y:ys) | x == y = diff xs ys+ | otherwise = ys