packages feed

google-dictionary (empty) → 0.1.0.0

raw patch · 6 files changed

+303/−0 lines, 6 filesdep +HTTPdep +aesondep +basesetup-changed

Dependencies added: HTTP, aeson, base, bytestring

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Mitchell Rosen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Mitchell Rosen nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/API/GoogleDictionary.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell #-}++module Network.API.GoogleDictionary+    ( Entry(..)+    , lookupWord+    , module Network.API.GoogleDictionary.Types+    ) where++import Data.Maybe  (catMaybes)+import Data.Monoid (First(..), mconcat)++import Network.API.GoogleDictionary.Internal+import Network.API.GoogleDictionary.Types++type PartOfSpeech = String+type Definition = String++data Entry = Entry+    { entryWord :: !String+    , entryData :: [(PartOfSpeech, Definition)]+    }++instance Show Entry where+    show = unlines . show' 1 . entryData+      where+        show' :: Int -> [(PartOfSpeech, Definition)] -> [String]+        show' n ((pos,def):xs) = (show n ++ ". (" ++ pos ++ ") " ++ def) : show' (n+1) xs+        show' _ [] = []++lookupWord :: String -> IO (Maybe Entry)+lookupWord word = lookupWord' (const Nothing) (Just . makeEntry word) word++lookupWordDebug :: String -> IO (Either String Entry)+lookupWordDebug word = lookupWord' Left (Right . makeEntry word) word++lookupWord' :: (String -> a) -> (Response -> a) -> String -> IO a+lookupWord' left right = fmap (either left right) . getResponse++makeEntry :: String -> Response -> Entry+makeEntry word = makeEntryFromPrimaries word . responsePrimaries++makeEntryFromPrimaries :: String -> [Primary] -> Entry+makeEntryFromPrimaries word = foldr step (Entry word [])+  where+    step :: Primary -> Entry -> Entry+    step (Primary pentries terms _) =+        let pos = primaryTermsToPartOfSpeech terms+            defs = pentriesToDefinitions pentries+            s = [(pos,d) | d <- defs]+        in (\(Entry w dat) -> Entry w (dat++s))++primaryTermsToPartOfSpeech :: [Term] -> PartOfSpeech+primaryTermsToPartOfSpeech = maybe (error "primaryTermsToPartOfSpeech: no part of speech found") id . f+  where+    f :: [Term] -> Maybe PartOfSpeech+    f = getFirst . mconcat . map (First . primaryTermToPartOfSpeech)++    primaryTermToPartOfSpeech :: Term -> Maybe PartOfSpeech+    primaryTermToPartOfSpeech (Term (Just labels) _ _ TText) = Just (labelsToPartOfSpeech labels)+    primaryTermToPartOfSpeech _ = Nothing++labelsToPartOfSpeech :: [Label] -> PartOfSpeech+labelsToPartOfSpeech = maybe (error "labelsToPartOfSpeech: no part of speech found") id . f+  where+    f :: [Label] -> Maybe PartOfSpeech+    f = getFirst . mconcat . map (First . labelToPartOfSpeech)++    labelToPartOfSpeech :: Label -> Maybe PartOfSpeech+    labelToPartOfSpeech (Label pos (Just "Part-of-speech")) = Just pos+    labelToPartOfSpeech _ = Nothing++pentriesToDefinitions :: [PEntry] -> [Definition]+pentriesToDefinitions = concatMap f+  where+    f :: PEntry -> [Definition]+    f (PEntry _ terms PEMeaning) = pentryTermsToDefinitions terms+    f _ = []++pentryTermsToDefinitions :: [Term] -> [Definition]+pentryTermsToDefinitions = catMaybes . map f+  where+    f :: Term -> Maybe Definition+    f (Term _ _ def TText) = Just def+    f _ = Nothing
+ Network/API/GoogleDictionary/Internal.hs view
@@ -0,0 +1,46 @@+module Network.API.GoogleDictionary.Internal where++import           Control.Applicative+import           Data.Aeson                 (eitherDecode)+import           Data.Char                  (chr)+import           Data.List                  (dropWhileEnd)+import           Network.HTTP               (getRequest, getResponseBody, simpleHTTP)+import           Numeric                    (readHex)+import qualified Data.ByteString.Lazy.Char8 as BS++import Network.API.GoogleDictionary.Types++getResponse :: String -> IO (Either String Response)+getResponse word = do+    let url = "http://www.google.com/dictionary/json?callback=a&sl=en&tl=en&q=" ++ word+    fmap (decodeHex . trimResponse) (getJson url) >>= maybe badContents goodContents+  where+    -- | Trim off the boiler plate callback characters, because JSONP is returned.+    -- Hard-code "2" because "callback=a" is also hard-coded, so the first two+    -- characters are "a("+    trimResponse :: String -> String+    trimResponse = dropWhileEnd (/= '}') . drop 2++    badContents :: IO (Either String Response)+    badContents = return (Left "invalid hex code encountered")++    goodContents :: String -> IO (Either String Response)+    goodContents = return . eitherDecode . BS.pack++getJson :: String -> IO String+getJson url = simpleHTTP (getRequest url) >>= getResponseBody++decodeHex :: String -> Maybe String+decodeHex ('\\':'x':x:y:ys) =+    case readHex [x,y] of+        [(n,"")] -> fmap (chr n :) (decodeHex ys)+        _ -> Nothing+decodeHex (x:xs) = fmap (x:) (decodeHex xs)+decodeHex [] = Just []++-- | Write response json to the specified file for inspection.+writeResponseDebug :: String -> FilePath -> IO ()+writeResponseDebug word path = do+    let url = "http://www.google.com/dictionary/json?callback=a&sl=en&tl=en&q=" ++ word+    contents <- dropWhileEnd (/= '}') . drop 2 <$> getJson url+    writeFile path contents
+ Network/API/GoogleDictionary/Types.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.API.GoogleDictionary.Types where++import Control.Applicative+import Control.Monad (mzero)+import Data.Aeson++data Response = Response+    { responsePrimaries      :: [Primary]+    , responseQuery          :: String+    , responseSourceLanguage :: String+    , responseTargetLanguage :: String+    } deriving Show++instance FromJSON Response where+    parseJSON (Object o) = Response <$>+        o .: "primaries"      <*>+        o .: "query"          <*>+        o .: "sourceLanguage" <*>+        o .: "targetLanguage"+    parseJSON _ = mzero++data Primary = Primary+    { primaryEntries :: [PEntry]+    , primaryTerms   :: [Term]+    , primaryType    :: PrimaryType+    } deriving Show++instance FromJSON Primary where+    parseJSON (Object o) = Primary <$>+        o .: "entries" <*>+        o .: "terms"   <*>+        o .: "type"+    parseJSON _ = mzero++data PEntry = PEntry+    { pentryEntries :: Maybe [EEntry]+    , pentryTerms   :: [Term] -- Do these ever have labels?+    , pentryType    :: PEntryType+    } deriving Show++instance FromJSON PEntry where+    parseJSON (Object o) = PEntry <$>+        o .:? "entries" <*>+        o .:  "terms"   <*>+        o .:  "type"+    parseJSON _ = mzero++data EEntry = EEntry+    { eentryTerms :: [Term]+    , eentryType  :: EEntryType+    } deriving Show++instance FromJSON EEntry where+    parseJSON (Object o) = EEntry <$>+        o .: "terms"   <*>+        o .: "type"+    parseJSON _ = mzero++data Term = Term+    { termLabels   :: Maybe [Label]+    , termLanguage :: String+    , termText     :: String+    , termType     :: TermType+    } deriving Show++instance FromJSON Term where+    parseJSON (Object o) = Term <$>+        o .:? "labels"   <*>+        o .:  "language" <*>+        o .:  "text"     <*>+        o .:  "type"+    parseJSON _ = mzero++data Label = Label+    { labelText  :: String+    , labelTitle :: Maybe String+    } deriving Show++instance FromJSON Label where+    parseJSON (Object o) = Label <$>+        o .:  "text" <*>+        o .:? "title"+    parseJSON _ = mzero++data PrimaryType = PHeadword+                 deriving Show++instance FromJSON PrimaryType where+    parseJSON (String "headword") = pure PHeadword+    parseJSON _ = mzero++data PEntryType = PEMeaning+                | PERelated+                deriving Show++instance FromJSON PEntryType where+    parseJSON (String "meaning") = pure PEMeaning+    parseJSON (String "related") = pure PERelated+    parseJSON _ = mzero++data EEntryType = EEExample+                deriving Show++instance FromJSON EEntryType where+    parseJSON (String "example") = pure EEExample+    parseJSON _ = mzero++data TermType = TText+              | TPhonetic+              | TSound+              deriving Show++instance FromJSON TermType where+    parseJSON (String "text")     = pure TText+    parseJSON (String "phonetic") = pure TPhonetic+    parseJSON (String "sound")    = pure TSound+    parseJSON _ = mzero+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ google-dictionary.cabal view
@@ -0,0 +1,21 @@+name:                google-dictionary+version:             0.1.0.0+synopsis:            Simple interface to the google.com/dictionary API+homepage:            https://github.com/mitchellwrosen/google-dictionary-api+license:             BSD3+license-file:        LICENSE+author:              Mitchell Rosen+maintainer:          mitchellwrosen@gmail.com+category:            Data+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Network.API.GoogleDictionary, Network.API.GoogleDictionary.Types+  other-modules:       Network.API.GoogleDictionary.Internal+  other-extensions:    TemplateHaskell, OverloadedStrings+  build-depends:       base ==4.*,+                       aeson,+                       HTTP,+                       bytestring+  default-language:    Haskell2010