diff --git a/hsay.cabal b/hsay.cabal --- a/hsay.cabal +++ b/hsay.cabal @@ -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 diff --git a/src-exec/Hsay.hs b/src-exec/Hsay.hs deleted file mode 100644 --- a/src-exec/Hsay.hs +++ /dev/null @@ -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 diff --git a/src-exec/hsay.hs b/src-exec/hsay.hs new file mode 100644 --- /dev/null +++ b/src-exec/hsay.hs @@ -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