diff --git a/MicrosoftTranslator.cabal b/MicrosoftTranslator.cabal --- a/MicrosoftTranslator.cabal +++ b/MicrosoftTranslator.cabal @@ -2,20 +2,21 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: MicrosoftTranslator -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Interface for Microsoft Translator description: - A simple library to use Microsoft Translator - () in Haskell. + A simple library to use in Haskell. It provides an easy to use interface to the free translation service from Microsoft so one can easily add language translation to a Haskell program as long as there is internet connection available. - + . The easiest way to use the program is via the toplevel translate function: + . > translate :: ClientId -> ClientSecret -> Text -> BingLanguage -> BingLanguage -> IO (Either BingError Text) - - To use this library one must have an account for Microsoft Translator in the - Azure Data Market. More information about this package available at: (). + . + To use this library one must have an account for Microsoft Translator in the + Azure Data Market. More information about this package available + . license: BSD3 license-file: LICENSE diff --git a/src/Language/Bing.hs b/src/Language/Bing.hs --- a/src/Language/Bing.hs +++ b/src/Language/Bing.hs @@ -1,13 +1,18 @@ {-# Language RecordWildCards, OverloadedStrings, DeriveDataTypeable #-} module Language.Bing( BingLanguage(..), + BingContext, BingError(..), ClientId, ClientSecret, checkToken, evalBing, + execBing, getAccessToken, + getAccessTokenEither, + getBingCtx, runBing, + runExceptT, translate, translateM) where @@ -41,6 +46,8 @@ import qualified Data.Text.Encoding as TE import qualified Data.Text.IO as TIO import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans.Class +import Control.Monad.IO.Class type ClientId = ByteString @@ -74,11 +81,11 @@ inception :: DateTime, clientId :: ByteString, clientSecret :: ByteString - } deriving Show + } deriving (Show,Typeable) -newtype BingMonad a = BM {runBing :: BingContext -> ExceptT BingError IO a} +newtype BingMonad m a = BM {runBing :: BingContext -> ExceptT BingError m a} -instance Monad BingMonad where +instance (Monad m, MonadIO m) => Monad (BingMonad m) where m >>= f = BM (\ctx' -> do ctx <- checkToken ctx' res <- runBing m ctx @@ -86,18 +93,24 @@ return a = BM $ \ctx -> return a -instance Functor BingMonad where +instance (Monad m, MonadIO m) => Functor (BingMonad m) where fmap f bm = do v <- bm return $ f v -instance Applicative BingMonad where +instance (Monad m, MonadIO m) => Applicative (BingMonad m) where pure a = return a a <*> b = do a' <- a b' <- b return (a' b') +instance MonadTrans BingMonad where + lift m = BM $ \ctx -> lift m + +instance MonadIO m => MonadIO (BingMonad m) where + liftIO io = BM $ \ctx -> liftIO io + instance FromJSON AccessToken where parseJSON (Object v) = build <$> v .: "token_type" <*> @@ -134,9 +147,9 @@ ("to" N.:= (toSym to :: ByteString)) ] -bingAction :: IO (N.Response BL.ByteString) -> ExceptT BingError IO (N.Response BL.ByteString) +bingAction :: MonadIO m => IO (N.Response BL.ByteString) -> ExceptT BingError m (N.Response BL.ByteString) bingAction action = do - res <- lift $ (E.try action :: IO (Either HttpException (N.Response BL.ByteString))) + res <- lift $ (liftIO $ (E.try action :: IO (Either HttpException (N.Response BL.ByteString)))) case res of Right res -> return res Left ex -> throwE $ BingError $ pack $ show ex @@ -151,7 +164,7 @@ -- | Request a new access token from Azure using the specified client -- id and client secret -getAccessToken :: ByteString -> ByteString -> ExceptT BingError IO BingContext +getAccessToken :: MonadIO m => ByteString -> ByteString -> ExceptT BingError m BingContext getAccessToken clientId clientSecret = do req <- post tokenAuthPage [ "client_id" N.:= clientId, @@ -159,7 +172,7 @@ scopeArg, grantType ] - r <- N.asJSON req + r <- liftIO $ N.asJSON req let t = r ^. N.responseBody t' <- liftIO $ getCurrentTime return $ BCTX{ @@ -171,7 +184,7 @@ -- | Check if the access token of the running BingAction is still -- valid. If the token has expired, renews the token automatically -checkToken :: BingContext -> ExceptT BingError IO BingContext +checkToken :: MonadIO m => BingContext -> ExceptT BingError m BingContext checkToken ctx@BCTX{..} = do t <- liftIO $ getCurrentTime if diffSeconds t inception > expires accessToken - 100 then do @@ -184,7 +197,7 @@ withContext = BM -- | Action that translates text inside a BingMonad context. -translateM :: Text -> BingLanguage -> BingLanguage -> BingMonad Text +translateM :: MonadIO m => Text -> BingLanguage -> BingLanguage -> BingMonad m Text translateM text from to = do let opts = N.defaults & N.param "from" .~ [toSym from :: Text] & N.param "to" .~ [toSym to] @@ -201,10 +214,23 @@ -- | Helper function that evaluates a BingMonad action. It simply -- requests and access token and uses the token for evaluation. -evalBing :: ClientId -> ClientSecret -> BingMonad a -> IO (Either BingError a) +evalBing :: MonadIO m => ClientId -> ClientSecret -> BingMonad m a -> m (Either BingError a) evalBing clientId clientSecret action = runExceptT $ do t <- getAccessToken clientId clientSecret runBing action t + +getBingCtx :: Monad m => BingMonad m BingContext +getBingCtx = BM {runBing = \ctx -> return ctx} + +execBing :: MonadIO m => BingContext -> BingMonad m a -> m (Either BingError (a,BingContext)) +execBing ctx action = runExceptT $ do + flip runBing ctx $ do + res <- action + ctx <- getBingCtx + return (res,ctx) + +getAccessTokenEither :: ClientId -> ClientSecret -> IO (Either BingError BingContext) +getAccessTokenEither clientId clientSecret = runExceptT $ getAccessToken clientId clientSecret -- | Toplevel wrapper that translates a text. It is only recommended if translation -- is invoked less often than every 10 minutes since it always