diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,51 @@ language: haskell + +env: + matrix: + - GHCVER=7.4.2 + - GHCVER=7.6.3 + - GHCVER=7.8.3 USE_COVERALLS=1 + - GHCVER=head + +matrix: + allow_failures: + - env: GHCVER=head + before_install: - - cabal install hpc-coveralls + - | + if [ $GHCVER = `ghc --numeric-version` ]; then + echo "use system ghc: `which ghc` `ghc --numeric-version`" + else + travis_retry sudo add-apt-repository -y ppa:hvr/ghc + travis_retry sudo apt-get update + travis_retry sudo apt-get install -y --force-yes cabal-install-1.18 ghc-$GHCVER + export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH + echo "use ppa:hvr/ghc: `which ghc` `ghc --numeric-version`" + fi + +install: + - export PATH=$HOME/.cabal/bin:$PATH + - which cabal + - travis_retry cabal update + - cabal install happy + - cabal install --only-dependencies --enable-tests + - "[ -n \"$USE_COVERALLS\" ] && travis_retry cabal install hpc-coveralls || true" + - ghc-pkg list + script: - - cabal configure --enable-tests --enable-library-coverage && cabal build - - run-cabal-test + - | + if [ -n "$USE_COVERALLS" ]; then + cabal configure --enable-tests --enable-library-coverage $CABAL_FLAGS + else + cabal configure --enable-tests $CABAL_FLAGS + fi + - cabal build + - | + if [ -n "$USE_COVERALLS" ]; then + run-cabal-test --show-details=always + else + cabal test --show-details=always + fi + after_script: - - hpc-coveralls tests + - "[ -n \"$USE_COVERALLS\" ] && hpc-coveralls --exclude-dir=tests tests || true" diff --git a/Web/Twitter/Types.hs b/Web/Twitter/Types.hs --- a/Web/Twitter/Types.hs +++ b/Web/Twitter/Types.hs @@ -31,6 +31,7 @@ , Coordinates(..) , Place(..) , BoundingBox(..) + , Contributor(..) , checkError ) where @@ -61,180 +62,197 @@ checkError :: Object -> Parser () checkError o = do - err <- o .:? "error" - case err of - Just msg -> fail msg - Nothing -> return () + err <- o .:? "error" + case err of + Just msg -> fail msg + Nothing -> return () instance FromJSON StreamingAPI where - parseJSON v@(Object o) = - SRetweetedStatus <$> js <|> - SStatus <$> js <|> - SEvent <$> js <|> - SDelete <$> js <|> - SFriends <$> (o .: "friends") <|> - return (SUnknown v) - where - js :: FromJSON a => Parser a - js = parseJSON v - parseJSON _ = mzero + parseJSON v@(Object o) = + SRetweetedStatus <$> js <|> + SStatus <$> js <|> + SEvent <$> js <|> + SDelete <$> js <|> + SFriends <$> (o .: "friends") <|> + return (SUnknown v) + where + js :: FromJSON a => Parser a + js = parseJSON v + parseJSON _ = mzero -data Status = - Status - { statusCreatedAt :: DateString - , statusId :: StatusId - , statusText :: Text - , statusSource :: Text - , statusTruncated :: Bool - , statusEntities :: Maybe Entities - , statusExtendedEntities :: Maybe Entities - , statusInReplyTo :: Maybe StatusId - , statusInReplyToUser :: Maybe UserId - , statusFavorite :: Maybe Bool - , statusRetweetCount :: Maybe Integer - , statusUser :: User - , statusRetweet :: Maybe Status - , statusPlace :: Maybe Place - , statusFavoriteCount :: Integer - , statusLang :: Maybe Text - , statusPossiblySensitive :: Maybe Bool - , statusCoordinates :: Maybe Coordinates - } deriving (Show, Eq) +data Status = Status + { statusContributors :: Maybe [Contributor] + , statusCoordinates :: Maybe Coordinates + , statusCreatedAt :: DateString + , statusCurrentUserRetweet :: Maybe UserId + , statusEntities :: Maybe Entities + , statusExtendedEntities :: Maybe Entities + , statusFavoriteCount :: Integer + , statusFavorited :: Maybe Bool + , statusFilterLevel :: Maybe Text + , statusId :: StatusId + , statusInReplyToScreenName :: Maybe Text + , statusInReplyToStatusId :: Maybe StatusId + , statusInReplyToUserId :: Maybe UserId + , statusLang :: Maybe LanguageCode + , statusPlace :: Maybe Place + , statusPossiblySensitive :: Maybe Bool + , statusScopes :: Maybe Object + , statusRetweetCount :: Integer + , statusRetweeted :: Maybe Bool + , statusRetweetedStatus :: Maybe Status + , statusSource :: Text + , statusText :: Text + , statusTruncated :: Bool + , statusUser :: User + , statusWithheldCopyright :: Maybe Bool + , statusWithheldInCountries :: Maybe [Text] + , statusWithheldScope :: Maybe Text + } deriving (Show, Eq) instance FromJSON Status where - parseJSON (Object o) = checkError o >> - Status <$> o .: "created_at" - <*> o .: "id" - <*> o .: "text" - <*> o .: "source" - <*> o .: "truncated" - <*> o .:? "entities" - <*> o .:? "extended_entities" - <*> o .:? "in_reply_to_status_id" - <*> o .:? "in_reply_to_user_id" - <*> o .:? "favorited" - <*> o .:? "retweet_count" - <*> o .: "user" - <*> o .:? "retweeted_status" - <*> o .:? "place" - <*> o .:? "favorite_count" .!= 0 - <*> o .:? "lang" - <*> o .:? "possibly_sensitive" - <*> o .:? "coordinates" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + Status <$> o .:? "contributors" + <*> o .:? "coordinates" + <*> o .: "created_at" + <*> ((o .: "current_user_retweet" >>= (.: "id")) <|> return Nothing) + <*> o .:? "entities" + <*> o .:? "extended_entities" + <*> o .:? "favorite_count" .!= 0 + <*> o .:? "favorited" + <*> o .:? "filter_level" + <*> o .: "id" + <*> o .:? "in_reply_to_screen_name" + <*> o .:? "in_reply_to_status_id" + <*> o .:? "in_reply_to_user_id" + <*> o .:? "lang" + <*> o .:? "place" + <*> o .:? "possibly_sensitive" + <*> o .:? "scopes" + <*> o .:? "retweet_count" .!= 0 + <*> o .:? "retweeted" + <*> o .:? "retweeted_status" + <*> o .: "source" + <*> o .: "text" + <*> o .: "truncated" + <*> o .: "user" + <*> o .:? "withheld_copyright" + <*> o .:? "withheld_in_countries" + <*> o .:? "withheld_scope" + parseJSON _ = mzero data SearchResult body = - SearchResult - { searchResultStatuses :: body - , searchResultSearchMetadata :: SearchMetadata - } deriving (Show, Eq) + SearchResult + { searchResultStatuses :: body + , searchResultSearchMetadata :: SearchMetadata + } deriving (Show, Eq) instance FromJSON body => FromJSON (SearchResult body) where - parseJSON (Object o) = checkError o >> - SearchResult <$> o .: "statuses" - <*> o .: "search_metadata" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + SearchResult <$> o .: "statuses" + <*> o .: "search_metadata" + parseJSON _ = mzero data SearchStatus = - SearchStatus - { searchStatusCreatedAt :: DateString - , searchStatusId :: StatusId - , searchStatusText :: Text - , searchStatusSource :: Text - , searchStatusUser :: User - , searchStatusCoordinates :: Maybe Coordinates - } deriving (Show, Eq) + SearchStatus + { searchStatusCreatedAt :: DateString + , searchStatusId :: StatusId + , searchStatusText :: Text + , searchStatusSource :: Text + , searchStatusUser :: User + , searchStatusCoordinates :: Maybe Coordinates + } deriving (Show, Eq) instance FromJSON SearchStatus where - parseJSON (Object o) = checkError o >> - SearchStatus <$> o .: "created_at" - <*> o .: "id" - <*> o .: "text" - <*> o .: "source" - <*> o .: "user" - <*> o .:? "coordinates" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + SearchStatus <$> o .: "created_at" + <*> o .: "id" + <*> o .: "text" + <*> o .: "source" + <*> o .: "user" + <*> o .:? "coordinates" + parseJSON _ = mzero data SearchMetadata = - SearchMetadata - { searchMetadataMaxId :: StatusId - , searchMetadataSinceId :: StatusId - , searchMetadataRefreshUrl :: URIString - , searchMetadataNextResults :: Maybe URIString - , searchMetadataCount :: Int - , searchMetadataCompletedIn :: Maybe Float - , searchMetadataSinceIdStr :: String - , searchMetadataQuery :: String - , searchMetadataMaxIdStr :: String - } deriving (Show, Eq) + SearchMetadata + { searchMetadataMaxId :: StatusId + , searchMetadataSinceId :: StatusId + , searchMetadataRefreshURL :: URIString + , searchMetadataNextResults :: Maybe URIString + , searchMetadataCount :: Int + , searchMetadataCompletedIn :: Maybe Float + , searchMetadataSinceIdStr :: String + , searchMetadataQuery :: String + , searchMetadataMaxIdStr :: String + } deriving (Show, Eq) instance FromJSON SearchMetadata where - parseJSON (Object o) = checkError o >> - SearchMetadata <$> o .: "max_id" - <*> o .: "since_id" - <*> o .: "refresh_url" - <*> o .:? "next_results" - <*> o .: "count" - <*> o .:? "completed_in" - <*> o .: "since_id_str" - <*> o .: "query" - <*> o .: "max_id_str" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + SearchMetadata <$> o .: "max_id" + <*> o .: "since_id" + <*> o .: "refresh_url" + <*> o .:? "next_results" + <*> o .: "count" + <*> o .:? "completed_in" + <*> o .: "since_id_str" + <*> o .: "query" + <*> o .: "max_id_str" + parseJSON _ = mzero data RetweetedStatus = - RetweetedStatus - { rsCreatedAt :: DateString - , rsId :: StatusId - , rsText :: Text - , rsSource :: Text - , rsTruncated :: Bool - , rsEntities :: Maybe Entities - , rsUser :: User - , rsRetweetedStatus :: Status - , rsCoordinates :: Maybe Coordinates - } deriving (Show, Eq) + RetweetedStatus + { rsCreatedAt :: DateString + , rsId :: StatusId + , rsText :: Text + , rsSource :: Text + , rsTruncated :: Bool + , rsEntities :: Maybe Entities + , rsUser :: User + , rsRetweetedStatus :: Status + , rsCoordinates :: Maybe Coordinates + } deriving (Show, Eq) instance FromJSON RetweetedStatus where - parseJSON (Object o) = checkError o >> - RetweetedStatus <$> o .: "created_at" - <*> o .: "id" - <*> o .: "text" - <*> o .: "source" - <*> o .: "truncated" - <*> o .:? "entities" - <*> o .: "user" - <*> o .: "retweeted_status" - <*> o .:? "coordinates" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + RetweetedStatus <$> o .: "created_at" + <*> o .: "id" + <*> o .: "text" + <*> o .: "source" + <*> o .: "truncated" + <*> o .:? "entities" + <*> o .: "user" + <*> o .: "retweeted_status" + <*> o .:? "coordinates" + parseJSON _ = mzero data DirectMessage = - DirectMessage - { dmCreatedAt :: DateString - , dmSenderScreenName :: Text - , dmSender :: User - , dmText :: Text - , dmRecipientScreeName :: Text - , dmId :: StatusId - , dmRecipient :: User - , dmRecipientId :: UserId - , dmSenderId :: UserId - , dmCoordinates :: Maybe Coordinates - } deriving (Show, Eq) + DirectMessage + { dmCreatedAt :: DateString + , dmSenderScreenName :: Text + , dmSender :: User + , dmText :: Text + , dmRecipientScreeName :: Text + , dmId :: StatusId + , dmRecipient :: User + , dmRecipientId :: UserId + , dmSenderId :: UserId + , dmCoordinates :: Maybe Coordinates + } deriving (Show, Eq) instance FromJSON DirectMessage where - parseJSON (Object o) = checkError o >> - DirectMessage <$> o .: "created_at" - <*> o .: "sender_screen_name" - <*> o .: "sender" - <*> o .: "text" - <*> o .: "recipient_screen_name" - <*> o .: "id" - <*> o .: "recipient" - <*> o .: "recipient_id" - <*> o .: "sender_id" - <*> o .:? "coordinates" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + DirectMessage <$> o .: "created_at" + <*> o .: "sender_screen_name" + <*> o .: "sender" + <*> o .: "text" + <*> o .: "recipient_screen_name" + <*> o .: "id" + <*> o .: "recipient" + <*> o .: "recipient_id" + <*> o .: "sender_id" + <*> o .:? "coordinates" + parseJSON _ = mzero data EventType = Favorite | Unfavorite | ListCreated | ListUpdated | ListMemberAdded @@ -245,238 +263,291 @@ deriving (Show, Eq) instance FromJSON EventTarget where - parseJSON v@(Object o) = checkError o >> - ETUser <$> parseJSON v <|> - ETStatus <$> parseJSON v <|> - ETList <$> parseJSON v <|> - return (ETUnknown v) - parseJSON _ = mzero + parseJSON v@(Object o) = checkError o >> + ETUser <$> parseJSON v <|> + ETStatus <$> parseJSON v <|> + ETList <$> parseJSON v <|> + return (ETUnknown v) + parseJSON _ = mzero data Event = - Event - { evCreatedAt :: DateString - , evTargetObject :: Maybe EventTarget - , evEvent :: Text - , evTarget :: EventTarget - , evSource :: EventTarget - } deriving (Show, Eq) + Event + { evCreatedAt :: DateString + , evTargetObject :: Maybe EventTarget + , evEvent :: Text + , evTarget :: EventTarget + , evSource :: EventTarget + } deriving (Show, Eq) instance FromJSON Event where - parseJSON (Object o) = checkError o >> - Event <$> o .: "created_at" - <*> o .:? "target_object" - <*> o .: "event" - <*> o .: "target" - <*> o .: "source" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + Event <$> o .: "created_at" + <*> o .:? "target_object" + <*> o .: "event" + <*> o .: "target" + <*> o .: "source" + parseJSON _ = mzero data Delete = - Delete - { delId :: StatusId - , delUserId :: UserId - } deriving (Show, Eq) + Delete + { delId :: StatusId + , delUserId :: UserId + } deriving (Show, Eq) instance FromJSON Delete where - parseJSON (Object o) = checkError o >> do - s <- o .: "delete" >>= (.: "status") - Delete <$> s .: "id" - <*> s .: "user_id" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> do + s <- o .: "delete" >>= (.: "status") + Delete <$> s .: "id" + <*> s .: "user_id" + parseJSON _ = mzero -data User = - User - { userId :: UserId - , userName :: UserName - , userScreenName :: Text - , userDescription :: Maybe Text - , userLocation :: Maybe Text - , userProfileImageURL :: Maybe URIString - , userURL :: Maybe URIString - , userProtected :: Maybe Bool - , userFollowers :: Maybe Int - , userFriends :: Maybe Int - , userTweets :: Maybe Int - , userLangCode :: Maybe LanguageCode - , userCreatedAt :: Maybe DateString - } deriving (Show, Eq) +data User = User + { userContributorsEnabled :: Bool + , userCreatedAt :: DateString + , userDefaultProfile :: Bool + , userDefaultProfileImage :: Bool + , userDescription :: Maybe Text + , userFavoritesCount :: Int + , userFollowRequestSent :: Maybe Bool + , userFollowing :: Maybe Bool + , userFollowersCount :: Int + , userFriendsCount :: Int + , userGeoEnabled :: Bool + , userId :: UserId + , userIsTranslator :: Bool + , userLang :: LanguageCode + , userListedCount :: Int + , userLocation :: Maybe Text + , userName :: Text + , userNotifications :: Maybe Bool + , userProfileBackgroundColor :: Maybe Text + , userProfileBackgroundImageURL :: Maybe URIString + , userProfileBackgroundImageURLHttps :: Maybe URIString + , userProfileBackgroundTile :: Maybe Bool + , userProfileBannerURL :: Maybe URIString + , userProfileImageURL :: Maybe URIString + , userProfileImageURLHttps :: Maybe URIString + , userProfileLinkColor :: Text + , userProfileSidebarBorderColor :: Text + , userProfileSidebarFillColor :: Text + , userProfileTextColor :: Text + , userProfileUseBackgroundImage :: Bool + , userProtected :: Bool + , userScreenName :: Text + , userShowAllInlineMedia :: Maybe Bool + , userStatusesCount :: Int + , userTimeZone :: Maybe Text + , userURL :: Maybe URIString + , userUtcOffset :: Maybe Int + , userVerified :: Bool + , userWithheldInCountries :: Maybe Text + , userWithheldScope :: Maybe Text + } deriving (Show, Eq) instance FromJSON User where - parseJSON (Object o) = checkError o >> - User <$> o .: "id" - <*> o .: "name" - <*> o .: "screen_name" - <*> o .:? "description" - <*> o .:? "location" - <*> o .:? "profile_image_url" - <*> o .:? "url" - <*> o .:? "protected" - <*> o .:? "followers_count" - <*> o .:? "friends_count" - <*> o .:? "statuses_count" - <*> o .:? "lang" - <*> o .:? "created_at" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + User <$> o .: "contributors_enabled" + <*> o .: "created_at" + <*> o .: "default_profile" + <*> o .: "default_profile_image" + <*> o .:? "description" + <*> o .: "favourites_count" + <*> o .:? "follow_request_sent" + <*> o .:? "following" + <*> o .: "followers_count" + <*> o .: "friends_count" + <*> o .: "geo_enabled" + <*> o .: "id" + <*> o .: "is_translator" + <*> o .: "lang" + <*> o .: "listed_count" + <*> o .:? "location" + <*> o .: "name" + <*> o .:? "notifications" + <*> o .:? "profile_background_color" + <*> o .:? "profile_background_image_url" + <*> o .:? "profile_background_image_url_https" + <*> o .:? "profile_background_tile" + <*> o .:? "profile_banner_url" + <*> o .:? "profile_image_url" + <*> o .:? "profile_image_url_https" + <*> o .: "profile_link_color" + <*> o .: "profile_sidebar_border_color" + <*> o .: "profile_sidebar_fill_color" + <*> o .: "profile_text_color" + <*> o .: "profile_use_background_image" + <*> o .: "protected" + <*> o .: "screen_name" + <*> o .:? "show_all_inline_media" + <*> o .: "statuses_count" + <*> o .:? "time_zone" + <*> o .:? "url" + <*> o .:? "utc_offset" + <*> o .: "verified" + <*> o .:? "withheld_in_countries" + <*> o .:? "withheld_scope" + parseJSON _ = mzero data List = - List - { listId :: Int - , listName :: Text - , listFullName :: Text - , listMemberCount :: Int - , listSubscriberCount :: Int - , listMode :: Text - , listUser :: User - } deriving (Show, Eq) + List + { listId :: Int + , listName :: Text + , listFullName :: Text + , listMemberCount :: Int + , listSubscriberCount :: Int + , listMode :: Text + , listUser :: User + } deriving (Show, Eq) instance FromJSON List where - parseJSON (Object o) = checkError o >> - List <$> o .: "id" - <*> o .: "name" - <*> o .: "full_name" - <*> o .: "member_count" - <*> o .: "subscriber_count" - <*> o .: "mode" - <*> o .: "user" - parseJSON _ = mzero + parseJSON (Object o) = checkError o >> + List <$> o .: "id" + <*> o .: "name" + <*> o .: "full_name" + <*> o .: "member_count" + <*> o .: "subscriber_count" + <*> o .: "mode" + <*> o .: "user" + parseJSON _ = mzero data HashTagEntity = - HashTagEntity - { hashTagText :: Text -- ^ The Hashtag text - } deriving (Show, Eq) + HashTagEntity + { hashTagText :: Text -- ^ The Hashtag text + } deriving (Show, Eq) instance FromJSON HashTagEntity where - parseJSON (Object o) = - HashTagEntity <$> o .: "text" - parseJSON _ = mzero + parseJSON (Object o) = + HashTagEntity <$> o .: "text" + parseJSON _ = mzero data UserEntity = - UserEntity - { userEntityUserId :: UserId - , userEntityUserName :: UserName - , userEntityUserScreenName :: Text - } deriving (Show, Eq) + UserEntity + { userEntityUserId :: UserId + , userEntityUserName :: UserName + , userEntityUserScreenName :: Text + } deriving (Show, Eq) instance FromJSON UserEntity where - parseJSON (Object o) = - UserEntity <$> o .: "id" - <*> o .: "name" - <*> o .: "screen_name" - parseJSON _ = mzero + parseJSON (Object o) = + UserEntity <$> o .: "id" + <*> o .: "name" + <*> o .: "screen_name" + parseJSON _ = mzero data URLEntity = - URLEntity - { ueURL :: URIString -- ^ The URL that was extracted - , ueExpanded :: URIString -- ^ The fully resolved URL (only for t.co links) - , ueDisplay :: Text -- ^ Not a URL but a string to display instead of the URL (only for t.co links) - } deriving (Show, Eq) + URLEntity + { ueURL :: URIString -- ^ The URL that was extracted + , ueExpanded :: URIString -- ^ The fully resolved URL (only for t.co links) + , ueDisplay :: Text -- ^ Not a URL but a string to display instead of the URL (only for t.co links) + } deriving (Show, Eq) instance FromJSON URLEntity where - parseJSON (Object o) = - URLEntity <$> o .: "url" - <*> o .: "expanded_url" - <*> o .: "display_url" - parseJSON _ = mzero + parseJSON (Object o) = + URLEntity <$> o .: "url" + <*> o .: "expanded_url" + <*> o .: "display_url" + parseJSON _ = mzero data MediaEntity = - MediaEntity - { meType :: Text - , meId :: StatusId - , meSizes :: HashMap Text MediaSize - , meMediaURL :: URIString - , meMediaURLHttps :: URIString - , meURL :: URLEntity - } deriving (Show, Eq) + MediaEntity + { meType :: Text + , meId :: StatusId + , meSizes :: HashMap Text MediaSize + , meMediaURL :: URIString + , meMediaURLHttps :: URIString + , meURL :: URLEntity + } deriving (Show, Eq) instance FromJSON MediaEntity where - parseJSON v@(Object o) = - MediaEntity <$> o .: "type" - <*> o .: "id" - <*> o .: "sizes" - <*> o .: "media_url" - <*> o .: "media_url_https" - <*> parseJSON v - parseJSON _ = mzero + parseJSON v@(Object o) = + MediaEntity <$> o .: "type" + <*> o .: "id" + <*> o .: "sizes" + <*> o .: "media_url" + <*> o .: "media_url_https" + <*> parseJSON v + parseJSON _ = mzero data MediaSize = - MediaSize - { msWidth :: Int - , msHeight :: Int - , msResize :: Text - } deriving (Show, Eq) + MediaSize + { msWidth :: Int + , msHeight :: Int + , msResize :: Text + } deriving (Show, Eq) instance FromJSON MediaSize where - parseJSON (Object o) = - MediaSize <$> o .: "w" - <*> o .: "h" - <*> o .: "resize" - parseJSON _ = mzero + parseJSON (Object o) = + MediaSize <$> o .: "w" + <*> o .: "h" + <*> o .: "resize" + parseJSON _ = mzero data Coordinates = - Coordinates - { coordinates :: [Double] - , coordinatesType :: Text - } deriving (Show, Eq) + Coordinates + { coordinates :: [Double] + , coordinatesType :: Text + } deriving (Show, Eq) instance FromJSON Coordinates where - parseJSON (Object o) = - Coordinates <$> o .: "coordinates" - <*> o .: "type" - parseJSON _ = mzero + parseJSON (Object o) = + Coordinates <$> o .: "coordinates" + <*> o .: "type" + parseJSON _ = mzero data Place = - Place - { placeAttributes :: HashMap Text Text - , placeBoundingBox :: BoundingBox - , placeCountry :: Text - , placeCountryCode :: Text - , placeFullName :: Text - , placeId :: Text - , placeName :: Text - , placeType :: Text - , placeUrl :: Text - } deriving (Show, Eq) + Place + { placeAttributes :: HashMap Text Text + , placeBoundingBox :: BoundingBox + , placeCountry :: Text + , placeCountryCode :: Text + , placeFullName :: Text + , placeId :: Text + , placeName :: Text + , placeType :: Text + , placeURL :: Text + } deriving (Show, Eq) instance FromJSON Place where - parseJSON (Object o) = - Place <$> o .: "attributes" - <*> o .: "bounding_box" - <*> o .: "country" - <*> o .: "country_code" - <*> o .: "full_name" - <*> o .: "id" - <*> o .: "name" - <*> o .: "place_type" - <*> o .: "url" - parseJSON _ = mzero + parseJSON (Object o) = + Place <$> o .: "attributes" + <*> o .: "bounding_box" + <*> o .: "country" + <*> o .: "country_code" + <*> o .: "full_name" + <*> o .: "id" + <*> o .: "name" + <*> o .: "place_type" + <*> o .: "url" + parseJSON _ = mzero data BoundingBox = - BoundingBox - { boundingBoxCoordinates :: [[[Double]]] - , boundingBoxType :: Text - } deriving (Show, Eq) + BoundingBox + { boundingBoxCoordinates :: [[[Double]]] + , boundingBoxType :: Text + } deriving (Show, Eq) instance FromJSON BoundingBox where - parseJSON (Object o) = - BoundingBox <$> o .: "coordinates" - <*> o .: "type" - parseJSON _ = mzero + parseJSON (Object o) = + BoundingBox <$> o .: "coordinates" + <*> o .: "type" + parseJSON _ = mzero -- | Entity handling. data Entities = - Entities - { enHashTags :: [Entity HashTagEntity] - , enUserMentions :: [Entity UserEntity] - , enURLs :: [Entity URLEntity] - , enMedia :: [Entity MediaEntity] - } deriving (Show, Eq) + Entities + { enHashTags :: [Entity HashTagEntity] + , enUserMentions :: [Entity UserEntity] + , enURLs :: [Entity URLEntity] + , enMedia :: [Entity MediaEntity] + } deriving (Show, Eq) instance FromJSON Entities where - parseJSON (Object o) = - Entities <$> o .:? "hashtags" .!= [] - <*> o .:? "user_mentions" .!= [] - <*> o .:? "urls" .!= [] - <*> o .:? "media" .!= [] - parseJSON _ = mzero + parseJSON (Object o) = + Entities <$> o .:? "hashtags" .!= [] + <*> o .:? "user_mentions" .!= [] + <*> o .:? "urls" .!= [] + <*> o .:? "media" .!= [] + parseJSON _ = mzero -- | The character positions the Entity was extracted from -- @@ -485,13 +556,24 @@ type EntityIndices = [Int] data Entity a = - Entity - { entityBody :: a -- ^ The detail information of the specific entity types (HashTag, URL, User) - , entityIndices :: EntityIndices -- ^ The character positions the Entity was extracted from - } deriving (Show, Eq) + Entity + { entityBody :: a -- ^ The detail information of the specific entity types (HashTag, URL, User) + , entityIndices :: EntityIndices -- ^ The character positions the Entity was extracted from + } deriving (Show, Eq) instance FromJSON a => FromJSON (Entity a) where - parseJSON v@(Object o) = - Entity <$> parseJSON v - <*> o .: "indices" - parseJSON _ = mzero + parseJSON v@(Object o) = + Entity <$> parseJSON v + <*> o .: "indices" + parseJSON _ = mzero + +data Contributor = Contributor + { contributorId :: UserId + , contributorScreenName :: Text + } deriving (Show, Eq) + +instance FromJSON Contributor where + parseJSON (Object o) = + Contributor <$> o .: "id" + <*> o .: "screen_name" + parseJSON _ = mzero diff --git a/Web/Twitter/Types/Lens.hs b/Web/Twitter/Types/Lens.hs --- a/Web/Twitter/Types/Lens.hs +++ b/Web/Twitter/Types/Lens.hs @@ -1,55 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, RankNTypes, CPP, FlexibleInstances #-} module Web.Twitter.Types.Lens - ( DateString - , UserId - , Friends - , URIString - , UserName - , StatusId - , LanguageCode - , StreamingAPI(..) - , Status - , SearchResult - , SearchStatus - , SearchMetadata - , RetweetedStatus - , DirectMessage - , EventTarget(..) - , Event - , Delete - , User - , List - , Entities - , EntityIndices - , Entity - , HashTagEntity - , UserEntity - , URLEntity - , MediaEntity - , MediaSize - , Coordinates - , Place - , BoundingBox + ( TT.DateString + , TT.UserId + , TT.Friends + , TT.URIString + , TT.UserName + , TT.StatusId + , TT.LanguageCode + , TT.StreamingAPI(..) + , TT.Status + , TT.SearchResult + , TT.SearchStatus + , TT.SearchMetadata + , TT.RetweetedStatus + , TT.DirectMessage + , TT.EventTarget(..) + , TT.Event + , TT.Delete + , TT.User + , TT.List + , TT.Entities + , TT.EntityIndices + , TT.Entity + , TT.HashTagEntity + , TT.UserEntity + , TT.URLEntity + , TT.MediaEntity + , TT.MediaSize + , TT.Coordinates + , TT.Place + , TT.BoundingBox + , statusContributors + , statusCoordinates , statusCreatedAt - , statusId - , statusText - , statusSource - , statusTruncated + , statusCurrentUserRetweet , statusEntities , statusExtendedEntities - , statusInReplyTo - , statusInReplyToUser - , statusFavorite - , statusRetweetCount - , statusRetweet - , statusUser - , statusPlace , statusFavoriteCount + , statusFavorited + , statusFilterLevel + , statusId + , statusInReplyToScreenName + , statusInReplyToStatusId + , statusInReplyToUserId , statusLang + , statusPlace , statusPossiblySensitive - , statusCoordinates + , statusScopes + , statusRetweetCount + , statusRetweeted + , statusRetweetedStatus + , statusSource + , statusText + , statusTruncated + , statusUser + , statusWithheldCopyright + , statusWithheldInCountries + , statusWithheldScope , searchResultStatuses , searchResultSearchMetadata @@ -63,7 +73,7 @@ , searchMetadataMaxId , searchMetadataSinceId - , searchMetadataRefreshUrl + , searchMetadataRefreshURL , searchMetadataNextResults , searchMetadataCount , searchMetadataCompletedIn @@ -101,19 +111,46 @@ , delId , delUserId - , userId - , userName - , userScreenName + , userContributorsEnabled + , userCreatedAt + , userDefaultProfile + , userDefaultProfileImage , userDescription + , userFavoritesCount + , userFollowRequestSent + , userFollowing + , userFollowersCount + , userFriendsCount + , userGeoEnabled + , userId + , userIsTranslator + , userLang + , userListedCount , userLocation + , userName + , userNotifications + , userProfileBackgroundColor + , userProfileBackgroundImageURL + , userProfileBackgroundImageURLHttps + , userProfileBackgroundTile + , userProfileBannerURL , userProfileImageURL - , userURL + , userProfileImageURLHttps + , userProfileLinkColor + , userProfileSidebarBorderColor + , userProfileSidebarFillColor + , userProfileTextColor + , userProfileUseBackgroundImage , userProtected - , userFollowers - , userFriends - , userTweets - , userLangCode - , userCreatedAt + , userScreenName + , userShowAllInlineMedia + , userStatusesCount + , userTimeZone + , userURL + , userUtcOffset + , userVerified + , userWithheldInCountries + , userWithheldScope , listId , listName @@ -155,7 +192,7 @@ , placeId , placeName , placeType - , placeUrl + , placeURL , boundingBoxCoordinates , boundingBoxType @@ -173,221 +210,61 @@ ) where -import Data.Functor +import Web.Twitter.Types.Lens.Types import qualified Web.Twitter.Types as TT -import Web.Twitter.Types - ( DateString - , UserId - , Friends - , URIString - , UserName - , StatusId - , LanguageCode - , StreamingAPI - , Status - , SearchResult - , SearchStatus - , SearchMetadata - , RetweetedStatus - , DirectMessage - , EventTarget - , Event - , Delete - , User - , List - , Entities - , EntityIndices - , Entity - , HashTagEntity - , UserEntity - , URLEntity - , MediaEntity - , MediaSize - , Coordinates - , Place - , BoundingBox - ) import Data.Text (Text) -import Data.HashMap.Strict (HashMap) - -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t -type SimpleLens s a = Lens s s a a - -#define HASHSIGN # -#define SIMPLE_LENS(name, s, a) \ -name :: SimpleLens (s) (a);\ -name f record = (\newVal -> record { TT.name = newVal }) <$> (f (TT.name record));\ -{-HASHSIGN INLINE name HASHSIGN-} - -#define TYPECHANGE_LENS(name, s) \ -name :: Lens ((s) a) ((s) b) (a) (b);\ -name f record = (\newVal -> record { TT.name = newVal }) <$> (f (TT.name record)) - -SIMPLE_LENS(statusCreatedAt , Status, DateString ) -SIMPLE_LENS(statusId , Status, StatusId ) -SIMPLE_LENS(statusText , Status, Text ) -SIMPLE_LENS(statusSource , Status, Text ) -SIMPLE_LENS(statusTruncated , Status, Bool ) -SIMPLE_LENS(statusEntities , Status, Maybe Entities ) -SIMPLE_LENS(statusExtendedEntities , Status, Maybe Entities ) -SIMPLE_LENS(statusInReplyTo , Status, Maybe StatusId ) -SIMPLE_LENS(statusInReplyToUser , Status, Maybe UserId ) -SIMPLE_LENS(statusFavorite , Status, Maybe Bool ) -SIMPLE_LENS(statusRetweetCount , Status, Maybe Integer ) -SIMPLE_LENS(statusRetweet , Status, Maybe Status ) -SIMPLE_LENS(statusUser , Status, User ) -SIMPLE_LENS(statusPlace , Status, Maybe Place ) -SIMPLE_LENS(statusFavoriteCount , Status, Integer ) -SIMPLE_LENS(statusLang , Status, Maybe Text ) -SIMPLE_LENS(statusPossiblySensitive , Status, Maybe Bool ) -SIMPLE_LENS(statusCoordinates , Status, Maybe Coordinates ) - -TYPECHANGE_LENS(searchResultStatuses , SearchResult ) -SIMPLE_LENS(searchResultSearchMetadata, SearchResult body, SearchMetadata ) - -SIMPLE_LENS(searchStatusCreatedAt , SearchStatus, DateString ) -SIMPLE_LENS(searchStatusId , SearchStatus, StatusId ) -SIMPLE_LENS(searchStatusText , SearchStatus, Text ) -SIMPLE_LENS(searchStatusSource , SearchStatus, Text ) -SIMPLE_LENS(searchStatusUser , SearchStatus, User ) -SIMPLE_LENS(searchStatusCoordinates , SearchStatus, Maybe Coordinates ) - -SIMPLE_LENS(searchMetadataMaxId , SearchMetadata, StatusId ) -SIMPLE_LENS(searchMetadataSinceId , SearchMetadata, StatusId ) -SIMPLE_LENS(searchMetadataRefreshUrl , SearchMetadata, URIString ) -SIMPLE_LENS(searchMetadataNextResults , SearchMetadata, Maybe URIString ) -SIMPLE_LENS(searchMetadataCount , SearchMetadata, Int ) -SIMPLE_LENS(searchMetadataCompletedIn , SearchMetadata, Maybe Float ) -SIMPLE_LENS(searchMetadataSinceIdStr , SearchMetadata, String ) -SIMPLE_LENS(searchMetadataQuery , SearchMetadata, String ) -SIMPLE_LENS(searchMetadataMaxIdStr , SearchMetadata, String ) - -SIMPLE_LENS(rsCreatedAt , RetweetedStatus, DateString ) -SIMPLE_LENS(rsId , RetweetedStatus, StatusId ) -SIMPLE_LENS(rsText , RetweetedStatus, Text ) -SIMPLE_LENS(rsSource , RetweetedStatus, Text ) -SIMPLE_LENS(rsTruncated , RetweetedStatus, Bool ) -SIMPLE_LENS(rsEntities , RetweetedStatus, Maybe Entities ) -SIMPLE_LENS(rsUser , RetweetedStatus, User ) -SIMPLE_LENS(rsRetweetedStatus , RetweetedStatus, Status ) -SIMPLE_LENS(rsCoordinates , RetweetedStatus, Maybe Coordinates ) - -SIMPLE_LENS(dmCreatedAt , DirectMessage, DateString ) -SIMPLE_LENS(dmSenderScreenName , DirectMessage, Text ) -SIMPLE_LENS(dmSender , DirectMessage, User ) -SIMPLE_LENS(dmText , DirectMessage, Text ) -SIMPLE_LENS(dmRecipientScreeName , DirectMessage, Text ) -SIMPLE_LENS(dmId , DirectMessage, StatusId ) -SIMPLE_LENS(dmRecipient , DirectMessage, User ) -SIMPLE_LENS(dmRecipientId , DirectMessage, UserId ) -SIMPLE_LENS(dmSenderId , DirectMessage, UserId ) -SIMPLE_LENS(dmCoordinates , DirectMessage, Maybe Coordinates ) - -SIMPLE_LENS(evCreatedAt , Event, DateString ) -SIMPLE_LENS(evTargetObject , Event, Maybe EventTarget ) -SIMPLE_LENS(evEvent , Event, Text ) -SIMPLE_LENS(evTarget , Event, EventTarget ) -SIMPLE_LENS(evSource , Event, EventTarget ) - -SIMPLE_LENS(delId , Delete, StatusId ) -SIMPLE_LENS(delUserId , Delete, UserId ) - -SIMPLE_LENS(userId , User, UserId ) -SIMPLE_LENS(userName , User, UserName ) -SIMPLE_LENS(userScreenName , User, Text ) -SIMPLE_LENS(userDescription , User, Maybe Text ) -SIMPLE_LENS(userLocation , User, Maybe Text ) -SIMPLE_LENS(userProfileImageURL , User, Maybe URIString ) -SIMPLE_LENS(userURL , User, Maybe URIString ) -SIMPLE_LENS(userProtected , User, Maybe Bool ) -SIMPLE_LENS(userFollowers , User, Maybe Int ) -SIMPLE_LENS(userFriends , User, Maybe Int ) -SIMPLE_LENS(userTweets , User, Maybe Int ) -SIMPLE_LENS(userLangCode , User, Maybe LanguageCode ) -SIMPLE_LENS(userCreatedAt , User, Maybe DateString ) - -SIMPLE_LENS(listId , List, Int ) -SIMPLE_LENS(listName , List, Text ) -SIMPLE_LENS(listFullName , List, Text ) -SIMPLE_LENS(listMemberCount , List, Int ) -SIMPLE_LENS(listSubscriberCount , List, Int ) -SIMPLE_LENS(listMode , List, Text ) -SIMPLE_LENS(listUser , List, User ) - -SIMPLE_LENS(hashTagText , HashTagEntity, Text ) - -SIMPLE_LENS(userEntityUserId , UserEntity, UserId ) -SIMPLE_LENS(userEntityUserName , UserEntity, UserName ) -SIMPLE_LENS(userEntityUserScreenName , UserEntity, Text ) - -SIMPLE_LENS(ueURL , URLEntity, URIString ) -SIMPLE_LENS(ueExpanded , URLEntity, URIString ) -SIMPLE_LENS(ueDisplay , URLEntity, Text ) - -SIMPLE_LENS(meType , MediaEntity, Text ) -SIMPLE_LENS(meId , MediaEntity, StatusId ) -SIMPLE_LENS(meSizes , MediaEntity, HashMap Text MediaSize ) -SIMPLE_LENS(meMediaURL , MediaEntity, URIString ) -SIMPLE_LENS(meMediaURLHttps , MediaEntity, URIString ) -SIMPLE_LENS(meURL , MediaEntity, URLEntity ) - -SIMPLE_LENS(msWidth , MediaSize, Int ) -SIMPLE_LENS(msHeight , MediaSize, Int ) -SIMPLE_LENS(msResize , MediaSize, Text ) - -SIMPLE_LENS(coordinates , Coordinates, [Double] ) -SIMPLE_LENS(coordinatesType , Coordinates, Text ) - -SIMPLE_LENS(placeAttributes , Place, HashMap Text Text ) -SIMPLE_LENS(placeBoundingBox , Place, BoundingBox ) -SIMPLE_LENS(placeCountry , Place, Text ) -SIMPLE_LENS(placeCountryCode , Place, Text ) -SIMPLE_LENS(placeFullName , Place, Text ) -SIMPLE_LENS(placeId , Place, Text ) -SIMPLE_LENS(placeName , Place, Text ) -SIMPLE_LENS(placeType , Place, Text ) -SIMPLE_LENS(placeUrl , Place, Text ) - -SIMPLE_LENS(boundingBoxCoordinates , BoundingBox, [[[Double]]] ) -SIMPLE_LENS(boundingBoxType , BoundingBox, Text ) - -SIMPLE_LENS(enHashTags , Entities, [Entity HashTagEntity] ) -SIMPLE_LENS(enUserMentions , Entities, [Entity UserEntity] ) -SIMPLE_LENS(enURLs , Entities, [Entity URLEntity] ) -SIMPLE_LENS(enMedia , Entities, [Entity MediaEntity] ) +import Web.Twitter.Types.Lens.TH -TYPECHANGE_LENS(entityBody , Entity ) -SIMPLE_LENS(entityIndices , Entity a, EntityIndices ) +makeLenses ''TT.Status +makeLenses ''TT.SearchResult +makeLenses ''TT.SearchStatus +makeLenses ''TT.SearchMetadata +makeLenses ''TT.RetweetedStatus +makeLenses ''TT.DirectMessage +makeLenses ''TT.Event +makeLenses ''TT.Delete +makeLenses ''TT.User +makeLenses ''TT.List +makeLenses ''TT.HashTagEntity +makeLenses ''TT.UserEntity +makeLenses ''TT.URLEntity +makeLenses ''TT.MediaEntity +makeLenses ''TT.MediaSize +makeLenses ''TT.Coordinates +makeLenses ''TT.Place +makeLenses ''TT.BoundingBox +makeLenses ''TT.Entities +makeLenses ''TT.Entity class AsStatus s where - status_id :: SimpleLens s StatusId - text :: SimpleLens s Text - user :: SimpleLens s User - created_at :: SimpleLens s DateString - geolocation :: SimpleLens s (Maybe Coordinates) + status_id :: Lens' s TT.StatusId + text :: Lens' s Text + user :: Lens' s TT.User + created_at :: Lens' s TT.DateString + geolocation :: Lens' s (Maybe TT.Coordinates) -instance AsStatus Status where +instance AsStatus TT.Status where status_id = statusId text = statusText user = statusUser created_at = statusCreatedAt geolocation = statusCoordinates -instance AsStatus SearchStatus where +instance AsStatus TT.SearchStatus where status_id = searchStatusId text = searchStatusText user = searchStatusUser created_at = searchStatusCreatedAt geolocation = searchStatusCoordinates -instance AsStatus RetweetedStatus where +instance AsStatus TT.RetweetedStatus where status_id = rsId text = rsText user = rsUser created_at = rsCreatedAt geolocation = rsCoordinates -instance AsStatus DirectMessage where +instance AsStatus TT.DirectMessage where status_id = dmId text = dmText user = dmSender @@ -395,21 +272,21 @@ geolocation = dmCoordinates class AsUser u where - user_id :: SimpleLens u UserId - name :: SimpleLens u UserName - screen_name :: SimpleLens u Text + user_id :: Lens' u TT.UserId + name :: Lens' u TT.UserName + screen_name :: Lens' u Text -instance AsUser User where +instance AsUser TT.User where user_id = userId name = userName screen_name = userScreenName -instance AsUser UserEntity where +instance AsUser TT.UserEntity where user_id = userEntityUserId name = userEntityUserName screen_name = userEntityUserScreenName -instance AsUser (Entity UserEntity) where +instance AsUser (TT.Entity TT.UserEntity) where user_id = entityBody.userEntityUserId name = entityBody.userEntityUserName screen_name = entityBody.userEntityUserScreenName diff --git a/Web/Twitter/Types/Lens/TH.hs b/Web/Twitter/Types/Lens/TH.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Types/Lens/TH.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +module Web.Twitter.Types.Lens.TH + where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Web.Twitter.Types.Lens.Types + +makeLenses :: Name -> Q [Dec] +makeLenses typename = do + typeinfo <- reify typename + case typeinfo of + TyConI (DataD _cxt _name tyVarBndr [RecC _dataConName fields] _names) -> + makeFieldLenses typename tyVarBndr fields + _ -> error $ "unknown type info: reify " ++ show typename + +makeFieldLenses :: Name -> [TyVarBndr] -> [VarStrictType] -> Q [Dec] +makeFieldLenses tyConName tyVarBndr fields = do + fieldsDec <- mapM (eachField tyConName tyVarBndr) fields + return $ concat fieldsDec + +eachField :: Name -> [TyVarBndr] -> (Name, Strict, Type) -> Q [Dec] +eachField tyConName tyVarBndr (fieldName, _, fieldType) = do + let funN = mkName (nameBase fieldName) + sigdef <- eachFieldSigD funN tyConName tyVarBndr fieldType + f <- newName "f" + record <- newName "record" + newVal <- newName "newVal" + recUpdVal <- varE newVal + let expr = [|fmap|] + `appE` (lamE [varP newVal] (recUpdE (varE record) [return (fieldName, recUpdVal)])) + `appE` (varE f `appE` (varE fieldName `appE` varE record)) + bind <- funD funN [clause [varP f, varP record] (normalB expr) []] +#if MIN_VERSION_template_haskell(2,8,0) + -- GHC 7.6 + pragD <- pragInlD funN Inline FunLike AllPhases + return [sigdef, bind, pragD] +#elif MIN_VERSION_template_haskell(2,6,0) + -- GHC 7.4 + pragD <- pragInlD funN (inlineSpecNoPhase True False) + return [sigdef, bind, pragD] +#else + return [sigdef, bind] +#endif + +eachFieldSigD :: Name -> Name -> [TyVarBndr] -> Type -> DecQ +eachFieldSigD funN tyConName [_] (VarT _fieldTypeVal) = do + a <- newName "a" + b <- newName "b" + let typ = forallT [PlainTV a, PlainTV b] (return []) (conT ''Lens `appT` (conT tyConName `appT` varT a) `appT` (conT tyConName `appT` varT b) `appT` varT a `appT` varT b) + sigD funN typ +eachFieldSigD funN tyConName [PlainTV a] fieldType = do + let typ = forallT [PlainTV a] (return []) (conT ''Lens' `appT` (conT tyConName `appT` varT a) `appT` return fieldType) + sigD funN typ +eachFieldSigD funN tyConName [] fieldType = do + sigD funN (conT ''Lens' `appT` conT tyConName `appT` return fieldType) +eachFieldSigD funN tyConName tyVarBndr fieldType = + error $ "Unknown TH : " ++ show funN ++ " " ++ show tyConName ++ " " ++ show tyVarBndr ++ " " ++ show fieldType diff --git a/Web/Twitter/Types/Lens/Types.hs b/Web/Twitter/Types/Lens/Types.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Types/Lens/Types.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE RankNTypes #-} + +module Web.Twitter.Types.Lens.Types + ( Lens + , Lens' + ) where + +-- | A type alias of the lens. +-- It is the same definition as the lens which introduced in +-- +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | Same as Lens' +type Lens' s a = Lens s s a a diff --git a/tests/Fixtures.hs b/tests/Fixtures.hs --- a/tests/Fixtures.hs +++ b/tests/Fixtures.hs @@ -1,29 +1,39 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Fixtures where +import Language.Haskell.TH import Data.Aeson import Data.Attoparsec.ByteString -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Maybe (fromJust) -import Text.Shakespeare.Text - -fj :: T.Text -> Value -fj = fromJust . maybeResult . parse json . T.encodeUtf8 +import qualified Data.ByteString as S +import Data.Maybe +import System.Directory +import System.FilePath +import System.IO.Unsafe (unsafePerformIO) +import Control.Applicative -errorMsgJson :: Value -errorMsgJson = fj [st|{"request":"\/1\/statuses\/user_timeline.json","error":"Not authorized"}|] +parseJSONValue :: S.ByteString -> Value +parseJSONValue = fromJust . maybeResult . parse json -statusJson :: Value -statusJson = fj [st|{"created_at":"Sat Sep 10 22:23:38 +0000 2011","id":112652479837110273,"id_str":"112652479837110273","text":"@twitter meets @seepicturely at #tcdisrupt cc.@boscomonkey @episod http:\/\/t.co\/6J2EgYM","source":"\u003ca href=\"http:\/\/instagr.am\" rel=\"nofollow\"\u003eInstagram\u003c\/a\u003e","truncated":false,"in_reply_to_status_id":null,"in_reply_to_status_id_str":null,"in_reply_to_user_id":783214,"in_reply_to_user_id_str":"783214","in_reply_to_screen_name":"twitter","user":{"id":299862462,"id_str":"299862462","name":"Eoin McMillan ","screen_name":"imeoin","location":"Twitter","description":"Eoin's photography account. See @mceoin for tweets.","url":"http:\/\/www.eoin.me","protected":false,"followers_count":6,"friends_count":0,"listed_count":0,"created_at":"Mon May 16 20:07:59 +0000 2011","favourites_count":0,"utc_offset":null,"time_zone":null,"geo_enabled":false,"verified":false,"statuses_count":277,"lang":"en","contributors_enabled":false,"is_translator":false,"profile_background_color":"131516","profile_background_image_url":"http:\/\/a0.twimg.com\/images\/themes\/theme14\/bg.gif","profile_background_image_url_https":"https:\/\/si0.twimg.com\/images\/themes\/theme14\/bg.gif","profile_background_tile":true,"profile_image_url":"http:\/\/a0.twimg.com\/profile_images\/1380912173\/Screen_shot_2011-06-03_at_7.35.36_PM_normal.png","profile_image_url_https":"https:\/\/si0.twimg.com\/profile_images\/1380912173\/Screen_shot_2011-06-03_at_7.35.36_PM_normal.png","profile_link_color":"009999","profile_sidebar_border_color":"EEEEEE","profile_sidebar_fill_color":"EFEFEF","profile_text_color":"333333","profile_use_background_image":true,"show_all_inline_media":false,"default_profile":false,"default_profile_image":false,"following":null,"follow_request_sent":null,"notifications":null},"geo":null,"coordinates":null,"place":null,"contributors":null,"retweet_count":0,"favorited":false,"retweeted":false,"possibly_sensitive":false}|] +fixturePath :: String +fixturePath = takeDirectory __FILE__ "fixtures" -statusEntityJson :: Value -statusEntityJson = fj [st|{"created_at":"Sat Sep 10 22:23:38 +0000 2011","id":112652479837110273,"id_str":"112652479837110273","text":"@twitter meets @seepicturely at #tcdisrupt cc.@boscomonkey @episod http:\/\/t.co\/6J2EgYM","source":"\u003ca href=\"http:\/\/instagr.am\" rel=\"nofollow\"\u003eInstagram\u003c\/a\u003e","truncated":false,"in_reply_to_status_id":null,"in_reply_to_status_id_str":null,"in_reply_to_user_id":783214,"in_reply_to_user_id_str":"783214","in_reply_to_screen_name":"twitter","user":{"id":299862462,"id_str":"299862462","name":"Eoin McMillan ","screen_name":"imeoin","location":"Twitter","description":"Eoin's photography account. See @mceoin for tweets.","url":"http:\/\/www.eoin.me","protected":false,"followers_count":6,"friends_count":0,"listed_count":0,"created_at":"Mon May 16 20:07:59 +0000 2011","favourites_count":0,"utc_offset":null,"time_zone":null,"geo_enabled":false,"verified":false,"statuses_count":277,"lang":"en","contributors_enabled":false,"is_translator":false,"profile_background_color":"131516","profile_background_image_url":"http:\/\/a0.twimg.com\/images\/themes\/theme14\/bg.gif","profile_background_image_url_https":"https:\/\/si0.twimg.com\/images\/themes\/theme14\/bg.gif","profile_background_tile":true,"profile_image_url":"http:\/\/a0.twimg.com\/profile_images\/1380912173\/Screen_shot_2011-06-03_at_7.35.36_PM_normal.png","profile_image_url_https":"https:\/\/si0.twimg.com\/profile_images\/1380912173\/Screen_shot_2011-06-03_at_7.35.36_PM_normal.png","profile_link_color":"009999","profile_sidebar_border_color":"EEEEEE","profile_sidebar_fill_color":"EFEFEF","profile_text_color":"333333","profile_use_background_image":true,"show_all_inline_media":false,"default_profile":false,"default_profile_image":false,"following":null,"follow_request_sent":null,"notifications":null},"geo":null,"coordinates":null,"place":null,"contributors":null,"retweet_count":0,"entities":{"hashtags":[{"text":"tcdisrupt","indices":[32,42]}],"urls":[{"url":"http:\/\/t.co\/6J2EgYM","expanded_url":"http:\/\/instagr.am\/p\/MuW67\/","display_url":"instagr.am\/p\/MuW67\/","indices":[67,86]}],"user_mentions":[{"screen_name":"twitter","name":"Twitter","id":783214,"id_str":"783214","indices":[0,8]},{"screen_name":"boscomonkey","name":"Bosco So","id":14792670,"id_str":"14792670","indices":[46,58]},{"screen_name":"episod","name":"Taylor Singletary","id":819797,"id_str":"819797","indices":[59,66]}]},"favorited":false,"retweeted":false,"possibly_sensitive":false}|] +loadFixture :: (S.ByteString -> a) -> String -> IO a +loadFixture conv filename = conv <$> S.readFile (fixturePath filename) -mediaEntityJson :: Value -mediaEntityJson = fj [st|{"created_at":"Wed Sep 14 20:58:04 +0000 2011","id":114080493036773378,"id_str":"114080493036773378","text":"Hello America! http:\/\/t.co\/rJC5Pxsu","source":"web","truncated":false,"in_reply_to_status_id":null,"in_reply_to_status_id_str":null,"in_reply_to_user_id":null,"in_reply_to_user_id_str":null,"in_reply_to_screen_name":null,"user":{"id":373487136,"id_str":"373487136","name":"Y U No @rno?","screen_name":"yunorno","location":"Paris, France","url":"http:\/\/twitter.com\/rno","description":"Oui oui!","protected":false,"followers_count":32,"friends_count":3,"listed_count":2,"created_at":"Wed Sep 14 17:24:54 +0000 2011","favourites_count":0,"utc_offset":null,"time_zone":null,"geo_enabled":false,"verified":false,"statuses_count":27,"lang":"en","contributors_enabled":false,"is_translator":false,"profile_background_color":"C0DEED","profile_background_image_url":"http:\/\/a0.twimg.com\/images\/themes\/theme1\/bg.png","profile_background_image_url_https":"https:\/\/si0.twimg.com\/images\/themes\/theme1\/bg.png","profile_background_tile":false,"profile_image_url":"http:\/\/a0.twimg.com\/profile_images\/1542800106\/oui_normal.png","profile_image_url_https":"https:\/\/si0.twimg.com\/profile_images\/1542800106\/oui_normal.png","profile_link_color":"0084B4","profile_sidebar_border_color":"C0DEED","profile_sidebar_fill_color":"DDEEF6","profile_text_color":"333333","profile_use_background_image":true,"default_profile":true,"default_profile_image":false,"following":false,"follow_request_sent":false,"notifications":false},"geo":null,"coordinates":null,"place":null,"contributors":null,"retweet_count":4,"entities":{"hashtags":[],"urls":[],"user_mentions":[],"media":[{"id":114080493040967680,"id_str":"114080493040967680","indices":[15,35],"media_url":"http:\/\/pbs.twimg.com\/media\/AZVLmp-CIAAbkyy.jpg","media_url_https":"https:\/\/pbs.twimg.com\/media\/AZVLmp-CIAAbkyy.jpg","url":"http:\/\/t.co\/rJC5Pxsu","display_url":"pic.twitter.com\/rJC5Pxsu","expanded_url":"http:\/\/twitter.com\/yunorno\/status\/114080493036773378\/photo\/1","type":"photo","sizes":{"large":{"w":226,"h":238,"resize":"fit"},"thumb":{"w":150,"h":150,"resize":"crop"},"medium":{"w":226,"h":238,"resize":"fit"},"small":{"w":226,"h":238,"resize":"fit"}}}]},"favorited":false,"retweeted":false,"possibly_sensitive":false}|] +fixture :: (S.ByteString -> a) -> String -> a +fixture conv = unsafePerformIO . loadFixture conv -mediaExtendedEntityJson :: Value -mediaExtendedEntityJson = fj [st|{"in_reply_to_status_id":null,"id_str":"479666034073296896","truncated":false,"possibly_sensitive":false,"in_reply_to_screen_name":null,"extended_entities":{"media":[{"id_str":"479665892922376192","expanded_url":"http://twitter.com/thimura_test/status/479666034073296896/photo/1","url":"http://t.co/qOjPwmgLKO","media_url_https":"https://pbs.twimg.com/media/BqgdlpaCQAA5OSu.jpg","indices":[36,58],"id":479665892922376192,"media_url":"http://pbs.twimg.com/media/BqgdlpaCQAA5OSu.jpg","type":"photo","sizes":{"small":{"w":340,"resize":"fit","h":604},"large":{"w":576,"resize":"fit","h":1024},"medium":{"w":576,"resize":"fit","h":1024},"thumb":{"w":150,"resize":"crop","h":150}},"display_url":"pic.twitter.com/qOjPwmgLKO"},{"id_str":"479665897150234624","expanded_url":"http://twitter.com/thimura_test/status/479666034073296896/photo/1","url":"http://t.co/qOjPwmgLKO","media_url_https":"https://pbs.twimg.com/media/Bqgdl5KCQAA9g9V.jpg","indices":[36,58],"id":479665897150234624,"media_url":"http://pbs.twimg.com/media/Bqgdl5KCQAA9g9V.jpg","type":"photo","sizes":{"small":{"w":339,"resize":"fit","h":191},"large":{"w":1024,"resize":"fit","h":576},"medium":{"w":599,"resize":"fit","h":337},"thumb":{"w":150,"resize":"crop","h":150}},"display_url":"pic.twitter.com/qOjPwmgLKO"},{"id_str":"479665901545852929","expanded_url":"http://twitter.com/thimura_test/status/479666034073296896/photo/1","url":"http://t.co/qOjPwmgLKO","media_url_https":"https://pbs.twimg.com/media/BqgdmJiCEAEp0EI.jpg","indices":[36,58],"id":479665901545852929,"media_url":"http://pbs.twimg.com/media/BqgdmJiCEAEp0EI.jpg","type":"photo","sizes":{"small":{"w":339,"resize":"fit","h":225},"large":{"w":1024,"resize":"fit","h":678},"medium":{"w":599,"resize":"fit","h":397},"thumb":{"w":150,"resize":"crop","h":150}},"display_url":"pic.twitter.com/qOjPwmgLKO"},{"id_str":"479665905375256576","expanded_url":"http://twitter.com/thimura_test/status/479666034073296896/photo/1","url":"http://t.co/qOjPwmgLKO","media_url_https":"https://pbs.twimg.com/media/BqgdmXzCIAAa2lU.jpg","indices":[36,58],"id":479665905375256576,"media_url":"http://pbs.twimg.com/media/BqgdmXzCIAAa2lU.jpg","type":"photo","sizes":{"small":{"w":339,"resize":"fit","h":225},"large":{"w":1024,"resize":"fit","h":678},"medium":{"w":599,"resize":"fit","h":397},"thumb":{"w":150,"resize":"crop","h":150}},"display_url":"pic.twitter.com/qOjPwmgLKO"}]},"entities":{"symbols":[],"urls":[],"media":[{"id_str":"479665892922376192","expanded_url":"http://twitter.com/thimura_test/status/479666034073296896/photo/1","url":"http://t.co/qOjPwmgLKO","media_url_https":"https://pbs.twimg.com/media/BqgdlpaCQAA5OSu.jpg","indices":[36,58],"id":479665892922376192,"media_url":"http://pbs.twimg.com/media/BqgdlpaCQAA5OSu.jpg","type":"photo","sizes":{"small":{"w":340,"resize":"fit","h":604},"large":{"w":576,"resize":"fit","h":1024},"medium":{"w":576,"resize":"fit","h":1024},"thumb":{"w":150,"resize":"crop","h":150}},"display_url":"pic.twitter.com/qOjPwmgLKO"}],"user_mentions":[],"hashtags":[{"text":"testnyan","indices":[26,35]}]},"text":"multiple image tweet test #testnyan http://t.co/qOjPwmgLKO","in_reply_to_user_id_str":null,"favorited":false,"coordinates":null,"retweeted":false,"user":{"screen_name":"thimura_test","is_translation_enabled":false,"default_profile":true,"profile_image_url":"http://abs.twimg.com/sticky/default_profile_images/default_profile_6_normal.png","default_profile_image":true,"id_str":"2418883074","profile_background_image_url_https":"https://abs.twimg.com/images/themes/theme1/bg.png","protected":false,"location":"","entities":{"description":{"urls":[]}},"profile_background_color":"C0DEED","utc_offset":null,"url":null,"profile_text_color":"333333","profile_image_url_https":"https://abs.twimg.com/sticky/default_profile_images/default_profile_6_normal.png","verified":false,"statuses_count":5,"profile_background_tile":false,"following":false,"lang":"ja","follow_request_sent":false,"profile_sidebar_fill_color":"DDEEF6","time_zone":null,"name":"thimura test","profile_sidebar_border_color":"C0DEED","geo_enabled":false,"listed_count":0,"contributors_enabled":false,"created_at":"Sun Mar 30 11:47:17 +0000 2014","id":2418883074,"friends_count":2,"is_translator":false,"favourites_count":0,"notifications":false,"profile_background_image_url":"http://abs.twimg.com/images/themes/theme1/bg.png","profile_use_background_image":true,"description":"","profile_link_color":"0084B4","followers_count":2},"lang":"et","retweet_count":0,"in_reply_to_user_id":null,"created_at":"Thu Jun 19 16:44:28 +0000 2014","source":"\u003ca href=\"https://twitter.com/thimura\" rel=\"nofollow\"\u003e二階堂真紅\u003c/a\u003e","geo":null,"id":479666034073296896,"in_reply_to_status_id_str":null,"favorite_count":0,"contributors":null,"place":null}|] +loadFixturesTH :: Name -> Q [Dec] +loadFixturesTH convFn = do + files <- runIO $ filter (\fn -> takeExtension fn == ".json") <$> getDirectoryContents fixturePath + concat <$> mapM genEachDefs files + where + genEachDefs filename = do + let funN = mkName $ "fixture_" ++ dropExtension filename + sigdef <- sigD funN (conT ''Value) + bind <- valD (varP funN) (normalB [|fixture $(varE convFn) $(litE (stringL filename))|]) [] + return [ sigdef, bind ] diff --git a/tests/TypesTest.hs b/tests/TypesTest.hs --- a/tests/TypesTest.hs +++ b/tests/TypesTest.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Main where @@ -8,7 +8,6 @@ import Test.Framework.TH.Prime import Test.Framework.Providers.HUnit import Test.HUnit -import Text.Shakespeare.Text import Data.Aeson hiding (Error) import Data.Aeson.Types (parseEither) @@ -16,6 +15,7 @@ import Data.Maybe import Fixtures +loadFixturesTH 'parseJSONValue main :: IO () main = $(defaultMainGenerator) @@ -25,57 +25,185 @@ -> (a -> Assertion) -> Assertion withJSON js f = either assertFailure id $ do - o <- parseEither parseJSON js - return $ f o + o <- parseEither parseJSON js + return $ f o case_parseStatus :: Assertion -case_parseStatus = withJSON statusJson $ \obj -> do - statusId obj @?= 112652479837110273 - statusRetweetCount obj @?= Just 0 - (userScreenName . statusUser) obj @?= "imeoin" - statusEntities obj @?= Nothing +case_parseStatus = withJSON fixture_status01 $ \obj -> do + statusCreatedAt obj @?= "Sat Sep 10 22:23:38 +0000 2011" + statusId obj @?= 112652479837110273 + statusText obj @?= "@twitter meets @seepicturely at #tcdisrupt cc.@boscomonkey @episod http://t.co/6J2EgYM" + statusSource obj @?= "Instagram" + statusTruncated obj @?= False + statusEntities obj @?= Nothing + statusExtendedEntities obj @?= Nothing + statusInReplyToStatusId obj @?= Nothing + statusInReplyToUserId obj @?= Just 783214 + statusFavorited obj @?= Just False + statusRetweetCount obj @?= 0 + (userScreenName . statusUser) obj @?= "imeoin" + statusRetweetedStatus obj @?= Nothing + statusPlace obj @?= Nothing + statusFavoriteCount obj @?= 0 + statusLang obj @?= Nothing + statusPossiblySensitive obj @?= Just False + statusCoordinates obj @?= Nothing +case_parseStatusWithPhoto :: Assertion +case_parseStatusWithPhoto = withJSON fixture_status_thimura_with_photo $ \obj -> do + statusId obj @?= 491143410770657280 + statusText obj @?= "近所の海です http://t.co/FjSOU8dDoD" + statusTruncated obj @?= False + + let ent = fromJust $ statusEntities obj + enHashTags ent @?= [] + enUserMentions ent @?= [] + enURLs ent @?= [] + length (enMedia ent) @?= 1 + map (meMediaURLHttps . entityBody) (enMedia ent) @?= ["https://pbs.twimg.com/media/BtDkUVaCQAIpWBU.jpg"] + + let exent = fromJust $ statusExtendedEntities obj + enHashTags exent @?= [] + enUserMentions exent @?= [] + enURLs exent @?= [] + length (enMedia ent) @?= 1 + + statusInReplyToStatusId obj @?= Nothing + statusInReplyToUserId obj @?= Nothing + statusFavorited obj @?= Just False + statusRetweetCount obj @?= 4 + (userScreenName . statusUser) obj @?= "thimura" + statusRetweetedStatus obj @?= Nothing + statusPlace obj @?= Nothing + statusFavoriteCount obj @?= 9 + statusLang obj @?= Just "ja" + statusPossiblySensitive obj @?= Just False + statusCoordinates obj @?= Nothing + case_parseStatusIncludeEntities :: Assertion -case_parseStatusIncludeEntities = withJSON statusEntityJson $ \obj -> do - statusId obj @?= 112652479837110273 - statusRetweetCount obj @?= Just 0 - (userScreenName . statusUser) obj @?= "imeoin" - let ent = fromMaybe (Entities [] [] [] []) $ statusEntities obj - (map entityIndices . enHashTags) ent @?= [[32,42]] - (hashTagText . entityBody . head . enHashTags) ent @?= "tcdisrupt" +case_parseStatusIncludeEntities = withJSON fixture_status_with_entity $ \obj -> do + statusId obj @?= 112652479837110273 + statusRetweetCount obj @?= 0 + (userScreenName . statusUser) obj @?= "imeoin" + let ent = fromMaybe (Entities [] [] [] []) $ statusEntities obj + (map entityIndices . enHashTags) ent @?= [[32,42]] + (hashTagText . entityBody . head . enHashTags) ent @?= "tcdisrupt" +case_parseSearchStatusMetadata :: Assertion +case_parseSearchStatusMetadata = withJSON fixture_search_haskell $ \obj -> do + let status = (searchResultStatuses obj) :: [Status] + length status @?= 1 + + let metadata = searchResultSearchMetadata obj + searchMetadataMaxId metadata @?= 495597397733433345 + searchMetadataSinceId metadata @?= 0 + searchMetadataRefreshURL metadata @?= "?since_id=495597397733433345&q=haskell&include_entities=1" + searchMetadataNextResults metadata @?= Just "?max_id=495594369802440705&q=haskell&include_entities=1" + searchMetadataCount metadata @?= 1 + searchMetadataCompletedIn metadata @?= Just 0.043 + searchMetadataSinceIdStr metadata @?= "0" + searchMetadataQuery metadata @?= "haskell" + searchMetadataMaxIdStr metadata @?= "495597397733433345" + +case_parseSearchStatusBodyStatus :: Assertion +case_parseSearchStatusBodyStatus = withJSON fixture_search_haskell $ \obj -> do + let status = (searchResultStatuses obj) :: [Status] + length status @?= 1 + statusText (head status) @?= "haskell" + +case_parseSearchStatusBodySearchStatus :: Assertion +case_parseSearchStatusBodySearchStatus = withJSON fixture_search_haskell $ \obj -> do + let status = (searchResultStatuses obj) :: [SearchStatus] + length status @?= 1 + searchStatusText (head status) @?= "haskell" + +case_parseDirectMessage :: Assertion +case_parseDirectMessage = withJSON fixture_direct_message_thimura $ \obj -> do + dmCreatedAt obj @?= "Sat Aug 02 16:10:04 +0000 2014" + dmSenderScreenName obj @?= "thimura_shinku" + (userScreenName . dmSender) obj @?= "thimura_shinku" + dmText obj @?= "おまえの明日が、今日よりもずっと、楽しい事で溢れているようにと、祈っているよ" + dmRecipientScreeName obj @?= "thimura" + dmId obj @?= 495602442466123776 + (userScreenName . dmRecipient) obj @?= "thimura" + dmRecipientId obj @?= 69179963 + dmSenderId obj @?= 2566877347 + dmCoordinates obj @?= Nothing + +case_parseEventFavorite :: Assertion +case_parseEventFavorite = withJSON fixture_event_favorite_thimura $ \obj -> do + evCreatedAt obj @?= "Sat Aug 02 16:32:01 +0000 2014" + evEvent obj @?= "favorite" + let Just (ETStatus targetObj) = evTargetObject obj + statusId targetObj @?= 495597326736449536 + statusText targetObj @?= "haskell" + + let ETUser targetUser = evTarget obj + userScreenName targetUser @?= "thimura" + + let ETUser sourceUser = evSource obj + userScreenName sourceUser @?= "thimura_shinku" + +case_parseEventUnfavorite :: Assertion +case_parseEventUnfavorite = withJSON fixture_event_unfavorite_thimura $ \obj -> do + evCreatedAt obj @?= "Sat Aug 02 16:32:10 +0000 2014" + evEvent obj @?= "unfavorite" + let Just (ETStatus targetObj) = evTargetObject obj + statusId targetObj @?= 495597326736449536 + statusText targetObj @?= "haskell" + + let ETUser targetUser = evTarget obj + userScreenName targetUser @?= "thimura" + + let ETUser sourceUser = evSource obj + userScreenName sourceUser @?= "thimura_shinku" + +case_parseDelete :: Assertion +case_parseDelete = withJSON fixture_delete $ \obj -> do + delId obj @?= 495607981833064448 + delUserId obj @?= 2566877347 + case_parseErrorMsg :: Assertion case_parseErrorMsg = - case parseStatus errorMsgJson of - Left str -> "Not authorized" @=? str - Right _ -> assertFailure "errorMsgJson should be parsed as an error." + case parseStatus fixture_error_not_authorized of + Left str -> "Not authorized" @=? str + Right _ -> assertFailure "errorMsgJson should be parsed as an error." where parseStatus :: Value -> Either String Status parseStatus = parseEither parseJSON case_parseMediaEntity :: Assertion -case_parseMediaEntity = withJSON mediaEntityJson $ \obj -> do - let entities = statusEntities obj - assert $ isJust entities - let Just ent = entities - media = enMedia ent - length media @?= 1 - let me = entityBody $ head media - ueURL (meURL me) @?= "http://t.co/rJC5Pxsu" - meMediaURLHttps me @?= "https://pbs.twimg.com/media/AZVLmp-CIAAbkyy.jpg" - let sizes = meSizes me - assert $ M.member "thumb" sizes - assert $ M.member "large" sizes +case_parseMediaEntity = withJSON fixture_media_entity $ \obj -> do + let entities = statusEntities obj + assert $ isJust entities + let Just ent = entities + media = enMedia ent + length media @?= 1 + let me = entityBody $ head media + meType me @?= "photo" + meId me @?= 114080493040967680 + let sizes = meSizes me + assert $ M.member "thumb" sizes + assert $ M.member "large" sizes + let Just mediaSize = M.lookup "large" sizes + + msWidth mediaSize @?= 226 + msHeight mediaSize @?= 238 + msResize mediaSize @?= "fit" + + ueURL (meURL me) @?= "http://t.co/rJC5Pxsu" + meMediaURLHttps me @?= "https://pbs.twimg.com/media/AZVLmp-CIAAbkyy.jpg" + case_parseEmptyEntity :: Assertion -case_parseEmptyEntity = withJSON (fj [st|{}|]) $ \entity -> do +case_parseEmptyEntity = withJSON (parseJSONValue "{}") $ \entity -> do length (enHashTags entity) @?= 0 length (enUserMentions entity) @?= 0 length (enURLs entity) @?= 0 length (enMedia entity) @?= 0 case_parseEntityHashTag :: Assertion -case_parseEntityHashTag = withJSON (fj [st|{"symbols":[],"urls":[{"indices":[32,52], "url":"http://t.co/IOwBrTZR", "display_url":"youtube.com/watch?v=oHg5SJ\u2026", "expanded_url":"http://www.youtube.com/watch?v=oHg5SJYRHA0"}],"user_mentions":[{"name":"Twitter API", "indices":[4,15], "screen_name":"twitterapi", "id":6253282, "id_str":"6253282"}],"hashtags":[{"indices":[32,36],"text":"lol"}]}|]) $ \entity -> do +case_parseEntityHashTag = withJSON fixture_entity01 $ \entity -> do length (enHashTags entity) @?= 1 length (enUserMentions entity) @?= 1 length (enURLs entity) @?= 1 @@ -95,7 +223,7 @@ hashtag @?= "lol" case_parseExtendedEntities :: Assertion -case_parseExtendedEntities = withJSON mediaExtendedEntityJson $ \obj -> do +case_parseExtendedEntities = withJSON fixture_media_extended_entity $ \obj -> do let entities = statusExtendedEntities obj assert $ isJust entities let Just ent = entities @@ -104,3 +232,30 @@ let me = entityBody $ head media ueURL (meURL me) @?= "http://t.co/qOjPwmgLKO" meMediaURL me @?= "http://pbs.twimg.com/media/BqgdlpaCQAA5OSu.jpg" + +case_parseUser :: Assertion +case_parseUser = withJSON fixture_user_thimura $ \obj -> do + userId obj @?= 69179963 + userName obj @?= "ちむら" + userScreenName obj @?= "thimura" + userDescription obj @?= Just "真紅かわいい" + userLocation obj @?= Just "State# Irotoridori.No.World" + userProfileImageURL obj @?= Just "http://pbs.twimg.com/profile_images/414044387346116609/VNMfLpY7_normal.png" + userURL obj @?= Just "http://t.co/TFUAsAffX0" + userProtected obj @?= False + userFollowersCount obj @?= 754 + userFriendsCount obj @?= 780 + userStatusesCount obj @?= 24709 + userLang obj @?= "en" + userCreatedAt obj @?= "Thu Aug 27 02:48:06 +0000 2009" + userFavoritesCount obj @?= 17313 + +case_parseList :: Assertion +case_parseList = withJSON fixture_list_thimura_haskell $ \obj -> do + listId obj @?= 20849097 + listName obj @?= "haskell" + listFullName obj @?= "@thimura/haskell" + listMemberCount obj @?= 50 + listSubscriberCount obj @?= 1 + listMode obj @?= "public" + (userScreenName . listUser) obj @?= "thimura" diff --git a/twitter-types.cabal b/twitter-types.cabal --- a/twitter-types.cabal +++ b/twitter-types.cabal @@ -1,12 +1,12 @@ name: twitter-types -version: 0.3.20140801 +version: 0.4.20140809 license: BSD3 license-file: LICENSE author: Takahiro HIMURA maintainer: Takahiro HIMURA synopsis: Twitter JSON parser and types description: This package uses enumerator package for access Twitter API. -category: Web, Enumerator +category: Web stability: Experimental cabal-version: >= 1.8 build-type: Simple @@ -29,11 +29,17 @@ , aeson >= 0.3.2.2 , text , unordered-containers + , template-haskell exposed-modules: Web.Twitter.Types Web.Twitter.Types.Lens + -- for documentation + Web.Twitter.Types.Lens.Types + other-modules: + Web.Twitter.Types.Lens.TH + test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests, . @@ -45,12 +51,14 @@ , test-framework-th-prime , test-framework-hunit , HUnit - , shakespeare >= 2.0 , http-types , aeson , attoparsec + , bytestring , text , unordered-containers + , filepath + , directory other-modules: Fixtures