diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ebird-api + +## 0.1.0.0 -- 2023-07-30 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2023 Finley McIlwaine + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/ebird-api.cabal b/ebird-api.cabal new file mode 100644 --- /dev/null +++ b/ebird-api.cabal @@ -0,0 +1,74 @@ +cabal-version: 3.0 +name: ebird-api +version: 0.1.0.0 +synopsis: + A Haskell description of the eBird API +description: + [eBird](https://ebird.org/home) is a massive collection of ornithological + science projects developed by the + [Cornell Lab of Ornithology](https://www.birds.cornell.edu/home/). The + [eBird API](https://documenter.getpostman.com/view/664302/S1ENwy59) + offers programmatic access to the incredible dataset backing these + projects. + + This library contains a description of the + eBird API as a + [servant](https://hackage.haskell.org/package/servant) API type. It is + intended for use by those who wish to write their own clients for the + eBird API using + [servant-client](https://hackage.haskell.org/package/servant-client), or do + custom processing of eBird data using the types defined here. + + If you are interested in querying the + eBird API using an existing client, check out the + [ebird-client](https://hackage.haskell.org/package/ebird-client) library. + +license: MIT +license-file: LICENSE +author: Finley McIlwaine +maintainer: finleymcilwaine@gmail.com +copyright: 2023 Finley McIlwaine +category: Web +build-type: Simple +extra-doc-files: CHANGELOG.md +bug-reports: https://github.com/FinleyMcIlwaine/ebird-haskell/issues +homepage: https://github.com/FinleyMcIlwaine/ebird-haskell + +tested-with: + GHC == 8.10.7 + , GHC == 9.2.7 + , GHC == 9.4.5 + , GHC == 9.6.2 + +common common + build-depends: + base >= 4.13.3.0 && < 4.19 + default-extensions: + ImportQualifiedPost + LambdaCase + OverloadedStrings + RecordWildCards + default-language: Haskell2010 + +library + import: common + exposed-modules: + Data.EBird.API + , Data.EBird.API.Checklists + , Data.EBird.API.EBirdString + , Data.EBird.API.Hotspots + , Data.EBird.API.Observations + , Data.EBird.API.Product + , Data.EBird.API.Regions + , Data.EBird.API.Taxonomy + , Data.EBird.API.Util.Time + build-depends: + aeson >= 1.5.6.0 && < 2.2 + , attoparsec >= 0.14.1 && < 0.15 + , attoparsec-iso8601 >= 1.0.2.0 && < 1.2 + , optics >= 0.4 && < 0.5 + , servant >= 0.18.3 && < 0.21 + , text >= 1.2.4.1 && < 2.1 + , time >= 1.9.3 && < 1.13 + hs-source-dirs: + src diff --git a/src/Data/EBird/API.hs b/src/Data/EBird/API.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API.hs @@ -0,0 +1,593 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Data.EBird.API +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- A description of the +-- [eBird API](https://documenter.getpostman.com/view/664302/S1ENwy59) +-- as a [servant](https://hackage.haskell.org/package/servant) API type. +-- +-- Intended for use by those who wish to write their own clients for the +-- [eBird API](https://documenter.getpostman.com/view/664302/S1ENwy59) using +-- [servant-client](https://hackage.haskell.org/package/servant-client). +-- +-- If you are interested in querying the +-- [eBird API](https://documenter.getpostman.com/view/664302/S1ENwy59) using +-- an existing client, check out the +-- [ebird-client](https://hackage.haskell.org/package/ebird-client) library. + +module Data.EBird.API + ( -- * Servant API types + -- + -- | Note: The individual endpoint types are only exported for those who + -- wish to implement partial clients for the eBird API. Comprehensive client + -- implementations should use the 'EBirdAPI' type. + + -- ** Top-level API + EBirdAPI + , WithAPIKey + + -- ** Observations APIs + -- + -- | These endpoints can be found under the [data\/obs + -- section](https://documenter.getpostman.com/view/664302/S1ENwy59#4e020bc2-fc67-4fb6-a926-570cedefcc34) + -- of the eBird API documentation. + , RecentObservationsAPI + , RecentNotableObservationsAPI + , RecentSpeciesObservationsAPI + , RecentNearbyObservationsAPI + , RecentNearbySpeciesObservationsAPI + , RecentNearestSpeciesObservationsAPI + , RecentNearbyNotableObservationsAPI + , HistoricalObservationsAPI + + -- ** Product APIs + -- + -- | These endpoints can be found under the [product + -- section](https://documenter.getpostman.com/view/664302/S1ENwy59#af04604f-e406-4cea-991c-a9baef24cd78) + -- of the eBird API documentation. + , RecentChecklistsAPI + , Top100API + , ChecklistFeedAPI + , RegionalStatisticsAPI + , SpeciesListAPI + , ViewChecklistAPI + + -- ** Hotspot APIs + -- + -- | These endpoints can be found under the [ref\/hotspot + -- section](https://documenter.getpostman.com/view/664302/S1ENwy59#5a1e27e9-128f-4ab5-80ad-88cd6de10026) + -- of the eBird API documentation. + , RegionHotspotsAPI + , NearbyHotspotsAPI + , HotspotInfoAPI + + -- ** Taxonomy APIs + -- + -- | These endpoints can be found under the [ref\/taxonomy + -- section](https://documenter.getpostman.com/view/664302/S1ENwy59#36c95b76-e18e-4788-9c9e-e539045f9166) + -- of the eBird API documentation. + , TaxonomyAPI + , TaxonomicFormsAPI + , TaxaLocaleCodesAPI + , TaxonomyVersionsAPI + , TaxonomicGroupsAPI + + -- ** Region APIs + -- + -- | These endpoints can be found under the [ref\/region + -- section](https://documenter.getpostman.com/view/664302/S1ENwy59#e18ea3b5-e80c-479f-87db-220ce8d9f3b6) + -- of the eBird API documentation, except for the 'AdjacentRegionsAPI', + -- which would be under the [ref\/geo + -- section](https://documenter.getpostman.com/view/664302/S1ENwy59#c9947c5c-2dce-4c6d-9911-7d702235506c) + -- of the eBird API documentation. + , RegionInfoAPI + , SubRegionListAPI + , AdjacentRegionsAPI + + -- * eBird checklists + , module Data.EBird.API.Checklists + + -- * eBird observations + , module Data.EBird.API.Observations + + -- * eBird products + , module Data.EBird.API.Product + + -- * eBird hotspots + , module Data.EBird.API.Hotspots + + -- * eBird regions + , module Data.EBird.API.Regions + + -- * eBird taxonomy + , module Data.EBird.API.Taxonomy + + -- * Date and time utilities + , module Data.EBird.API.Util.Time + + -- * 'EBirdString' class + , module Data.EBird.API.EBirdString + ) where + +import Data.Text (Text) +import Servant.API + +import Data.EBird.API.Checklists +import Data.EBird.API.EBirdString +import Data.EBird.API.Observations +import Data.EBird.API.Product +import Data.EBird.API.Hotspots +import Data.EBird.API.Regions +import Data.EBird.API.Taxonomy +import Data.EBird.API.Util.Time + +{- +Note [dependently typed APIs] + +Some eBird API abservation endpoints (such as the "recent notable observations" +endpoint) allow the caller to specify a detail level ("simple" or "full") for +the observations contained in the response. "Full" detail observations contain +more fields than "simple" detail observations. This means that "simple" and +"full" observations are most accurately represented as different types. +Furthermore, this means that the result type of these endpoints is determined by +the value of the "detail" query parameter. Since the type of the API depends on +the value of an input variable, we say that the API is dependently typed. + +There are two ways we could deal with this. First, we could model this situation +at the value level. To do this, we create a tagged union of simple and full +detail observations and have all of the observation endpoints return this +combined type, regardless of the value of "detail" query parameter. The benefit +of this approach is the simplicity. It requires no fancy type-level voodoo to +model this or to use it. The drawback of this approach is the lack of type +safety. Clients of this API know whether "simple" or "full" detail observations +are being requested, yet they still must do a runtime check of the response to +ensure that the observations in the response are detailed as expected. This is +not an error condition that clients of the API should need to worry about. + +Second, we could model this situation at the type level, much like is done in +the fantastic [Well-Typed article on dependently typed +servers](https://www.well-typed.com/blog/2015/12/dependently-typed-servers/). +The drawback of this approach is the fancy type-level programming overhead it +introduces for both this library and any consumers. + +For now, we model this at the value level. +-} + +-- | The [eBird API](https://documenter.getpostman.com/view/664302/S1ENwy59) as +-- a Haskell type. +type EBirdAPI = + -- Observation APIs + RecentObservationsAPI + :<|> RecentNotableObservationsAPI + :<|> RecentSpeciesObservationsAPI + :<|> RecentNearbyObservationsAPI + :<|> RecentNearbySpeciesObservationsAPI + :<|> RecentNearestSpeciesObservationsAPI + :<|> RecentNearbyNotableObservationsAPI + :<|> HistoricalObservationsAPI + + -- Product APIs + :<|> RecentChecklistsAPI + :<|> Top100API + :<|> ChecklistFeedAPI + :<|> RegionalStatisticsAPI + :<|> SpeciesListAPI + :<|> ViewChecklistAPI + + -- Hotspot APIs + :<|> RegionHotspotsAPI + :<|> NearbyHotspotsAPI + :<|> HotspotInfoAPI + + -- Taxonomy APIs + :<|> TaxonomyAPI + :<|> TaxonomicFormsAPI + :<|> TaxaLocaleCodesAPI + :<|> TaxonomyVersionsAPI + :<|> TaxonomicGroupsAPI + + -- Region APIs + :<|> RegionInfoAPI + :<|> SubRegionListAPI + :<|> AdjacentRegionsAPI + +-- | Convenient synonym for requiring an @x-ebirdapitoken@ on a route +type WithAPIKey = Header' '[Required] "x-ebirdapitoken" Text + +------------------------------------------------------------------------------- +-- Observations APIs +------------------------------------------------------------------------------- + +-- | Recent observations within a region. Note that this endpoint only ever +-- returns 'Simple' detail observations. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#3d2a17c1-2129-475c-b4c8-7d362d6000cd). +type RecentObservationsAPI = + "v2" :> "data" :> "obs" + :> WithAPIKey + :> Capture "regionCode" RegionCode + :> "recent" + :> QueryParam "back" Integer + :> QueryParam "cat" TaxonomyCategories + :> QueryParam "hotspot" Bool + :> QueryParam "includeProvisional" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "r" RegionCode + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [Observation 'Simple] + +-- | Recent /notable/ observations within a region. Since this endpoint can +-- return both 'Simple' and 'Full' detail observations, depending on the value +-- provided for the "detail" query parameter, we existentially quantify the +-- detail level of the resulting observations. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#397b9b8c-4ab9-4136-baae-3ffa4e5b26e4). +type RecentNotableObservationsAPI = + "v2" :> "data" :> "obs" + :> WithAPIKey + :> Capture "regionCode" RegionCode + :> "recent" + :> "notable" + :> QueryParam "back" Integer + :> QueryParam "detail" DetailLevel + :> QueryParam "hotspot" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "r" RegionCode + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [SomeObservation] + +-- | Recent observations of a species within a region. Note that this endpoint +-- only ever returns 'Simple' detail observations. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#755ce9ab-dc27-4cfc-953f-c69fb0f282d9). +type RecentSpeciesObservationsAPI = + "v2" :> "data" :> "obs" + :> WithAPIKey + :> Capture "regionCode" RegionCode + :> "recent" + :> Capture "speciesCode" SpeciesCode + :> QueryParam "back" Integer + :> QueryParam "hotspot" Bool + :> QueryParam "includeProvisional" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "r" RegionCode + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [Observation 'Simple] + +-- | Recent observations within some radius of some latitude/longitude. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#62b5ffb3-006e-4e8a-8e50-21d90d036edc). +type RecentNearbyObservationsAPI = + "v2" :> "data" :> "obs" :> "geo" :> "recent" + :> WithAPIKey + :> QueryParam' '[Required] "lat" Double + :> QueryParam' '[Required] "lng" Double + :> QueryParam "dist" Integer + :> QueryParam "back" Integer + :> QueryParam "cat" TaxonomyCategories + :> QueryParam "hotspot" Bool + :> QueryParam "includeProvisional" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "sort" SortObservationsBy + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [Observation 'Simple] + +-- | Recent observations of a species within some radius of some +-- latitude/longitude. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#20fb2c3b-ee7f-49ae-a912-9c3f16a40397). +type RecentNearbySpeciesObservationsAPI = + "v2" :> "data" :> "obs" :> "geo" :> "recent" + :> WithAPIKey + :> Capture "species" SpeciesCode + :> QueryParam' '[Required] "lat" Double + :> QueryParam' '[Required] "lng" Double + :> QueryParam "dist" Integer + :> QueryParam "back" Integer + :> QueryParam "cat" TaxonomyCategories + :> QueryParam "hotspot" Bool + :> QueryParam "includeProvisional" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "sort" SortObservationsBy + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [Observation 'Simple] + +-- | Nearest recent observations including a species. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#6bded97f-9997-477f-ab2f-94f254954ccb). +type RecentNearestSpeciesObservationsAPI = + "v2" :> "data" :> "nearest" :> "geo" :> "recent" + :> WithAPIKey + :> Capture "species" SpeciesCode + :> QueryParam' '[Required] "lat" Double + :> QueryParam' '[Required] "lng" Double + :> QueryParam "dist" Integer + :> QueryParam "back" Integer + :> QueryParam "hotspot" Bool + :> QueryParam "includeProvisional" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [Observation 'Simple] + +-- | Recent /notable/ observations of a within some radius of some +-- latitude/longitude. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#caa348bb-71f6-471c-b203-9e1643377cbc). +type RecentNearbyNotableObservationsAPI = + "v2" :> "data" :> "obs" :> "geo" :> "recent" :> "notable" + :> WithAPIKey + :> QueryParam' '[Required] "lat" Double + :> QueryParam' '[Required] "lng" Double + :> QueryParam "dist" Integer + :> QueryParam "detail" DetailLevel + :> QueryParam "back" Integer + :> QueryParam "hotspot" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [SomeObservation] + +-- | A list of all observations for each taxa seen in some 'RegionCode' on a +-- specific date. The specific observations returned are determined by the +-- @rank@ parameter - first observation of the species +-- ('SelectFirstObservation', default) or last observation +-- ('SelectLastObservation'). +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#2d8c6ee8-c435-4e91-9f66-6d3eeb09edd2). +type HistoricalObservationsAPI = + "v2" :> "data" :> "obs" + :> WithAPIKey + :> Capture "regionCode" RegionCode + :> "historic" + :> Capture "year" Integer + :> Capture "month" Integer + :> Capture "day" Integer + :> QueryParam "cat" TaxonomyCategories + :> QueryParam "detail" DetailLevel + :> QueryParam "hotspot" Bool + :> QueryParam "includeProvisional" Bool + :> QueryParam "maxResults" Integer + :> QueryParam "rank" SelectObservation + :> QueryParam "r" RegionCode + :> QueryParam "sppLocale" SPPLocale + :> Get '[JSON] [SomeObservation] + +------------------------------------------------------------------------------- +-- Product APIs +------------------------------------------------------------------------------- + +-- | A list of recent checklists submitted in a region. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#95a206d1-a20d-44e0-8c27-acb09ccbea1a). +type RecentChecklistsAPI = + "v2" :> "product" :> "lists" + :> WithAPIKey + :> Capture "regionCode" RegionCode + :> QueryParam "maxResults" Integer + :> Get '[JSON] [ChecklistFeedEntry] + +-- | A list of the top 100 contributors on a given date, ranked by species count +-- or checklist count. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#2d8d3f94-c4b0-42bd-9c8e-71edfa6347ba). +type Top100API = + "v2" :> "product" :> "top100" + :> WithAPIKey + :> Capture "regionCode" Region + :> Capture "year" Integer + :> Capture "month" Integer + :> Capture "day" Integer + :> QueryParam "rankedBy" RankTop100By + :> QueryParam "maxResults" Integer + :> Get '[JSON] [Top100ListEntry] + +-- | A list of checklists submitted in a region on a date. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#4416a7cc-623b-4340-ab01-80c599ede73e). +type ChecklistFeedAPI = + "v2" :> "product" :> "lists" + :> WithAPIKey + :> Capture "regionCode" Region + :> Capture "year" Integer + :> Capture "month" Integer + :> Capture "day" Integer + :> QueryParam "sortKey" SortChecklistsBy + :> QueryParam "maxResults" Integer + :> Get '[JSON] [ChecklistFeedEntry] + +-- | A list of checklists submitted on a date. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#506e63ab-abc0-4256-b74c-cd9e77968329). +type RegionalStatisticsAPI = + "v2" :> "product" :> "stats" + :> WithAPIKey + :> Capture "regionCode" Region + :> Capture "year" Integer + :> Capture "month" Integer + :> Capture "day" Integer + :> Get '[JSON] RegionalStatistics + +-- | A list of all species ever seen in a region. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#55bd1b26-6951-4a88-943a-d3a8aa1157dd). +type SpeciesListAPI = + "v2" :> "product" :> "spplist" + :> WithAPIKey + :> Capture "regionCode" Region + :> Get '[JSON] [SpeciesCode] + +-- | The details and observations for a checklist. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#2ee89672-4211-4fc1-8493-5df884fbb386). +type ViewChecklistAPI = + "v2" :> "product" :> "checklist" :> "view" + :> WithAPIKey + :> Capture "subId" Text + :> Get '[JSON] Checklist + +------------------------------------------------------------------------------- +-- Hotspot APIs +------------------------------------------------------------------------------- + +-- | The hotspots within a list of one or more regions. +-- +-- NOTE: This endpoint switches the content type of the response based on a +-- query parameter, not an \"Accept\" header, and for some reason it chooses to +-- make the default content type CSV. Any client for this endpoint should +-- hardcode the "fmt" parameter to 'JSONFormat'. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#f4f59f90-854e-4ba6-8207-323a8cf0bfe0). +type RegionHotspotsAPI = + "v2" :> "ref" :> "hotspot" + :> Capture "regionCode" RegionCode + :> QueryParam "back" Integer + :> QueryParam "fmt" CSVOrJSONFormat + :> Get '[JSON] [Hotspot] + +-- | The hotspots within a radius of some latitude/longitude. +-- +-- NOTE: This endpoint switches the content type of the response based on a +-- query parameter, not an \"Accept\" header, and for some reason it chooses to +-- make the default content type CSV. Any client for this endpoint should +-- hardcode the "fmt" parameter to 'JSONFormat'. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#674e81c1-6a0c-4836-8a7e-6ea1fe8e6677). +type NearbyHotspotsAPI = + "v2" :> "ref" :> "hotspot" :> "geo" + :> QueryParam' '[Required] "lat" Double + :> QueryParam' '[Required] "lng" Double + :> QueryParam "back" Integer + :> QueryParam "dist" Integer + :> QueryParam "fmt" CSVOrJSONFormat + :> Get '[JSON] [Hotspot] + +-- | Information about a hotspot. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#e25218db-566b-4d8b-81ca-e79a8f68c599). +type HotspotInfoAPI = + "v2" :> "ref" :> "hotspot" :> "info" + :> Capture "locId" Text + :> Get '[JSON] LocationData + +------------------------------------------------------------------------------- +-- Taxonomy API +------------------------------------------------------------------------------- + +-- | The eBird taxonomy, in part or in full. +-- +-- NOTE: This endpoint switches the content type of the response based on a +-- query parameter, not an \"Accept\" header, and for some reason it chooses to +-- make the default content type CSV. Any client for this endpoint should +-- hardcode the "fmt" parameter to 'JSONFormat'. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#952a4310-536d-4ad1-8f3e-77cfb624d1bc). +type TaxonomyAPI = + "v2" :> "ref" :> "taxonomy" :> "ebird" + :> QueryParam "cat" TaxonomyCategories + :> QueryParam "fmt" CSVOrJSONFormat + :> QueryParam "locale" SPPLocale + :> QueryParam "species" SpeciesCodes + :> QueryParam "version" Text + :> Get '[JSON] [Taxon] + +-- | The list of subspecies of a given species recognized in the taxonomy. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#e338e5a6-919d-4603-a7db-6c690fa62371). +type TaxonomicFormsAPI = + "v2" :> "ref" :> "taxon" :> "forms" + :> WithAPIKey + :> Capture "speciesCode" SpeciesCode + :> Get '[JSON] SpeciesCodes + +-- | The supported locale codes and names for species common names. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#3ea8ff71-c254-4811-9e80-b445a39302a6). +type TaxaLocaleCodesAPI = + "v2" :> "ref" :> "taxa-locales" :> "ebird" + :> WithAPIKey + :> Header "Accept-Language" SPPLocale + :> Get '[JSON] [SPPLocaleListEntry] + +-- | The complete list of taxonomy versions, with a flag indicating which is the +-- latest. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#9bba1ff5-6eb2-4f9a-91fd-e5ed34e51500). +type TaxonomyVersionsAPI = + "v2" :> "ref" :> "taxonomy" :> "versions" + :> Get '[JSON] [TaxonomyVersionListEntry] + +-- | The list of species groups, e.g. terns, finches, etc. +-- +-- See [the eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#aa9804aa-dbf9-4a53-bbf4-48e214e4677a). +type TaxonomicGroupsAPI = + "v2" :> "ref" :> "sppgroup" + :> Capture "speciesGrouping" SPPGrouping + :> QueryParam "groupNameLocale" SPPLocale + :> Get '[JSON] [TaxonomicGroupListEntry] + +------------------------------------------------------------------------------- +-- Regions API +------------------------------------------------------------------------------- + +-- | Get a 'RegionInfo' for a 'Region'. +-- +-- See the [eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#07c64240-6359-4688-9c4f-ff3d678a7248). +type RegionInfoAPI = + "v2" :> "ref" :> "region" + :> "info" + :> WithAPIKey + :> Capture "regionCode" Region + :> QueryParam "regionNameFormat" RegionNameFormat + :> Get '[JSON] RegionInfo + +-- | Get a list of subregions of a certain 'RegionType' within a 'RegionCode'. +-- +-- See the [eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#382da1c8-8bff-4926-936a-a1f8b065e7d5). +type SubRegionListAPI = + "v2" :> "ref" :> "region" + :> "list" + :> WithAPIKey + :> Capture "regionType" RegionType + :> Capture "regionCode" RegionCode + :> Get '[JSON] [RegionListEntry] + + +-- | Adjacent regions to a given region. Only 'Subnational2' region codes in the +-- United States, New Zealand, or Mexico are currently supported. +-- +-- See the [eBird API documentation for this +-- route](https://documenter.getpostman.com/view/664302/S1ENwy59#3aca0519-3105-47fc-8611-a4dfd500a32f). +type AdjacentRegionsAPI = + "v2" :> "ref" :> "adjacent" + :> WithAPIKey + :> Capture "regionCode" Region + :> Get '[JSON] [RegionListEntry] diff --git a/src/Data/EBird/API/Checklists.hs b/src/Data/EBird/API/Checklists.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/Checklists.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Data.EBird.API.Checklists +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Types related to eBird checklist API values. + +module Data.EBird.API.Checklists where + +import Control.Arrow +import Data.Aeson +import Data.Attoparsec.Text +import Data.Function +import Data.Functor +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Optics +import Servant.API (ToHttpApiData(..)) + +import Data.EBird.API.EBirdString +import Data.EBird.API.Regions +import Data.EBird.API.Taxonomy +import Data.EBird.API.Util.Time + +------------------------------------------------------------------------------- +-- * Checklist types +------------------------------------------------------------------------------- + +-- | Values returned by the 'Data.EBird.API.ViewChecklistAPI' +data Checklist = + Checklist + { -- | Project ID, e.g. \"EBIRD\" + _checklistProjectId :: Text + + -- | Checklist submission ID, e.g. \"S144646447\" + , _checklistSubId :: Text + + -- | Checklist protocol ID, e.g. \"P21\" + , _checklistProtocolId :: Text + + -- | Checklist location ID + , _checklistLocationId :: Text + + -- | Checklist group ID + , _checklistGroupId :: Text + + -- | Checklist duration, only 'Just' for checklists of appropriate + -- protocols (e.g. not incidentals) + , _checklistDurationHours :: Maybe Double + + -- | Was every bird observed reported? + , _checklistAllObsReported :: Bool + + -- | What date and time was the checklist created (i.e. submitted)? + , _checklistCreationDateTime :: EBirdDateTime + + -- | What date and time what the checklist last edited? + , _checklistLastEditedDateTime :: EBirdDateTime + + -- | What date and time what the checklist started? + , _checklistObsDateTime :: EBirdDateTime + + -- | TODO: Not sure what this is for + , _checklistObsTimeValid :: Bool + + -- | The ID of the checklist, e.g. \"CL24936\" + , _checklistChecklistId :: Text + + -- | The number of observers on this checklist + , _checklistNumObservers :: Integer + + -- | Distance travelled during this checklist in kilometers, only 'Just' + -- for checklists of appropriate protocols (e.g. not incidentals) + , _checklistEffortDistanceKm :: Maybe Double + + -- | The unit of distance used for the checklist submission (e.g. "mi"), + -- only 'Just' for checklists of appropriate protocols (e.g. not + -- incidentals) + , _checklistEffortDistanceEnteredUnit :: Maybe Text + + -- | The subnational1 region (state) that the checklist was submitted in + , _checklistSubnational1Code :: Region + + -- | Method of checklist submission + , _checklistSubmissionMethodCode :: Text + + -- | Version of the method of checklist submission, e.g. "2.13.2_SDK33" + , _checklistSubmissionMethodVersion :: Text + + -- | Display-ready version of the method of checklist submission, e.g. + -- "2.13.2" + , _checklistSubmissionMethodVersionDisp :: Text + + -- | Display name of the user that submitted the checklist + , _checklistUserDisplayName :: Text + + -- | Number of species included in observations on this checklist + , _checklistNumSpecies :: Integer + + -- | Submission auxiliary entry methods + -- + -- TODO: Not sure what these are about + , _checklistSubAux :: [SubAux] + + -- | Submission auxiliary entry methods that use aritificial + -- intelligence + -- + -- TODO: Not sure what these are about + , _checklistSubAuxAI :: [SubAuxAI] + + -- | Observations included in the checklist + , _checklistObs:: [ChecklistObservation] + } + deriving (Show, Read, Eq) + +-- | Observation values included in checklists. +data ChecklistObservation = + ChecklistObservation + { -- | Species code of the species, e.g. "norfli" + _checklistObservationSpeciesCode :: SpeciesCode + + -- | The date and time of the observation. It is not clear when this + -- would not be equal to the 'checklistObsDateTime' field of the enclosing + -- checklist. + , _checklistObservationObsDateTime :: EBirdDateTime + + -- | ID of the observation + , _checklistObservationObsId :: Text + + -- | A string representation of the quantity of the observation. If just + -- the presence is noted, the string will be \"X\" + , _checklistObservationHowManyStr :: Text + } + deriving (Show, Read, Eq) + +-- | Values included in the 'checklistSubAux' field of 'Checklist's. +data SubAux = + SubAux + { -- | Submission ID + _subAuxSubId :: Text + + -- | E.g. "nocturnal" + , _subAuxFieldName :: Text + + -- | E.g. "ebird_nocturnal" + , _subAuxEntryMethodCode :: Text + + -- | E.g. "0" + , _subAuxAuxCode :: Text + } + deriving (Show, Read, Eq) + +-- | Values included in the 'checklistSubAuxAI' field of 'Checklist's. +data SubAuxAI = + SubAuxAI + { -- | Submission ID + _subAuxAISubId :: Text + + -- | E.g. "concurrent" + , _subAuxAIMethod :: Text + + -- | E.g. "sound" + , _subAuxAIType :: Text + + -- | E.g. "merlin" + , _subAuxAISource :: Text + + -- | E.g. 0 + , _subAuxEventId :: Integer + } + deriving (Show, Read, Eq) + +-- | eBird checklists. Note that we do not include some redundant fields of +-- checklist values returned by the API (e.g. @subID@, which is always the same +-- value as @subId@). +data ChecklistFeedEntry = + ChecklistFeedEntry + { -- | The location ID of the checklist + _checklistFeedEntryLocationId :: Text + + -- | Checklist submission ID + , _checklistFeedEntrySubId :: Text + + -- | The display name of the user that submitted this checklist + , _checklistFeedEntryUserDisplayName :: Text + + -- | Number of species included on this checklist + , _checklistFeedEntryNumSpecies :: Integer + + -- | Date that this checklist was started + , _checklistFeedEntryDate :: EBirdDate + + -- | Time that this checklist was started + , _checklistFeedEntryTime :: EBirdTime + + -- | Location data for the checklist + , _checklistFeedEntryLocationData :: LocationData + } + deriving (Show, Read, Eq) + + +-- | eBird checklist or hotspot location data. Note that we do not include some +-- redundant fields of location data values returned by the API (e.g. @locName@, +-- which is always the same value as @name@). +data LocationData = + LocationData + { -- | Name of the location + _locationDataName :: Text + + -- | Latitude of the location + , _locationDataLatitude :: Double + + -- | Longitude of the location + , _locationDataLongitude :: Double + + -- | Country code of the location + , _locationDataCountryCode :: Region + + -- | Country name of the location + , _locationDataCountryName :: Text + + -- | Subnational1 region that this location is in + , _locationDataSubnational1Code :: Region + + -- | Name of the subnational1 region that this location is in + , _locationDataSubnational1Name :: Text + + -- | Subnational2 region that this location is in + , _locationDataSubnational2Code :: Region + + -- | Name of the subnational2 region that this location is in + , _locationDataSubnational2Name :: Text + + -- | Is this location an eBird hotspot? + , _locationDataIsHotspot:: Bool + + -- | A compound name for the location consisting of the location name, + -- county name, state name, and country name. + , _locationDataHeirarchicalName:: Text + } + deriving (Show, Read, Eq) + +------------------------------------------------------------------------------- +-- * Auxiliary eBird checklist-related API types +------------------------------------------------------------------------------- + +-- | How to rank the list returned by the 'Data.EBird.API.Top100API'. +data SortChecklistsBy + -- | Sort checklists by the date of the observations they contain + = SortChecklistsByDateCreated + + -- | Sort checklists by the date they were submitted + | SortChecklistsByDateSubmitted + deriving (Show, Read, Eq) + +------------------------------------------------------------------------------- +-- * Optics for checklist types +------------------------------------------------------------------------------- + +makeLenses ''Checklist +makeFieldLabels ''Checklist +makeLenses ''ChecklistObservation +makeFieldLabels ''ChecklistObservation +makeLenses ''SubAux +makeFieldLabels ''SubAux +makeLenses ''SubAuxAI +makeFieldLabels ''SubAuxAI +makeLenses ''ChecklistFeedEntry +makeFieldLabels ''ChecklistFeedEntry +makeLenses ''LocationData +makeFieldLabels ''LocationData + +------------------------------------------------------------------------------- +-- aeson instances +------------------------------------------------------------------------------- + +-- | Explicit instance for compatibility with their field names +instance FromJSON Checklist where + parseJSON = withObject "Checklist" $ \v -> + Checklist + <$> v .: "projId" + <*> v .: "subId" + <*> v .: "protocolId" + <*> v .: "locId" + <*> v .: "groupId" + <*> v .:? "durationHrs" + <*> v .: "allObsReported" + <*> v .: "creationDt" + <*> v .: "lastEditedDt" + <*> v .: "obsDt" + <*> v .: "obsTimeValid" + <*> v .: "checklistId" + <*> v .: "numObservers" + <*> v .:? "effortDistanceKm" + <*> v .:? "effortDistanceEnteredUnit" + <*> v .: "subnational1Code" + <*> v .: "submissionMethodCode" + <*> v .: "submissionMethodVersion" + <*> v .: "submissionMethodVersionDisp" + <*> v .: "userDisplayName" + <*> v .: "numSpecies" + <*> v .: "subAux" + <*> v .: "subAuxAi" + <*> v .: "obs" + +-- | Explicit instance for compatibility with their field names +instance ToJSON Checklist where + toJSON Checklist{..} = + object $ + [ "projId" .= _checklistProjectId + , "subId" .= _checklistSubId + , "protocolId" .= _checklistProtocolId + , "locId" .= _checklistLocationId + , "groupId" .= _checklistGroupId + , "allObsReported" .= _checklistAllObsReported + , "creationDt" .= _checklistCreationDateTime + , "lastEditedDt" .= _checklistLastEditedDateTime + , "obsDt" .= _checklistObsDateTime + , "obsTimeValid" .= _checklistObsTimeValid + , "checklistId" .= _checklistChecklistId + , "numObservers" .= _checklistNumObservers + , "subnational1Code" .= _checklistSubnational1Code + , "submissionMethodCode" .= _checklistSubmissionMethodCode + , "submissionMethodVersion" .= _checklistSubmissionMethodVersion + , "submissionMethodVersionDisp" .= _checklistSubmissionMethodVersionDisp + , "userDisplayName" .= _checklistUserDisplayName + , "numSpecies" .= _checklistNumSpecies + , "subAux" .= _checklistSubAux + , "subAuxAi" .= _checklistSubAuxAI + , "obs" .= _checklistObs + ] + -- Fields that may or may not be included, depending on the observation + -- data + <> [ "durationHrs" .= duration + | Just duration <- [_checklistDurationHours] + ] + <> [ "effortDistanceKm" .= distance + | Just distance <- [_checklistEffortDistanceKm] + ] + <> [ "effortDistanceEnteredUnit" .= unit + | Just unit <- [_checklistEffortDistanceEnteredUnit] + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON ChecklistObservation where + parseJSON = withObject "ChecklistObservation" $ \v -> + ChecklistObservation + <$> v .: "speciesCode" + <*> v .: "obsDt" + <*> v .: "obsId" + <*> v .: "howManyStr" + +-- | Explicit instance for compatibility with their field names +instance ToJSON ChecklistObservation where + toJSON ChecklistObservation{..} = + object + [ "speciesCode" .= _checklistObservationSpeciesCode + , "obsDt" .= _checklistObservationObsDateTime + , "obsId" .= _checklistObservationObsId + , "howManyStr" .= _checklistObservationHowManyStr + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON SubAux where + parseJSON = withObject "SubAux" $ \v -> + SubAux + <$> v .: "subId" + <*> v .: "fieldName" + <*> v .: "entryMethodCode" + <*> v .: "auxCode" + +-- | Explicit instance for compatibility with their field names +instance ToJSON SubAux where + toJSON SubAux{..} = + object + [ "subId" .= _subAuxSubId + , "fieldName" .= _subAuxFieldName + , "entryMethodCode" .= _subAuxEntryMethodCode + , "auxCode" .= _subAuxAuxCode + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON SubAuxAI where + parseJSON = withObject "SubAuxAI" $ \v -> + SubAuxAI + <$> v .: "subId" + <*> v .: "method" + <*> v .: "aiType" + <*> v .: "source" + <*> v .: "eventId" + +-- | Explicit instance for compatibility with their field names +instance ToJSON SubAuxAI where + toJSON SubAuxAI{..} = + object + [ "subId" .= _subAuxAISubId + , "method" .= _subAuxAIMethod + , "aiType" .= _subAuxAIType + , "eventId" .= _subAuxEventId + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON ChecklistFeedEntry where + parseJSON = withObject "ChecklistFeedEntry" $ \v -> + ChecklistFeedEntry + <$> v .: "locId" + <*> v .: "subId" + <*> v .: "userDisplayName" + <*> v .: "numSpecies" + <*> v .: "obsDt" + <*> v .: "obsTime" + <*> v .: "loc" + +-- | Explicit instance for compatibility with their field names +instance ToJSON ChecklistFeedEntry where + toJSON ChecklistFeedEntry{..} = + object + [ "locId" .= _checklistFeedEntryLocationId + , "subId" .= _checklistFeedEntrySubId + , "userDisplayName" .= _checklistFeedEntryUserDisplayName + , "numSpecies" .= _checklistFeedEntryNumSpecies + , "obsDt" .= _checklistFeedEntryDate + , "obsTime" .= _checklistFeedEntryTime + , "loc" .= _checklistFeedEntryLocationData + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON LocationData where + parseJSON = withObject "LocationData" $ \v -> + LocationData + <$> v .: "name" + <*> v .: "latitude" + <*> v .: "longitude" + <*> v .: "countryCode" + <*> v .: "countryName" + <*> v .: "subnational1Code" + <*> v .: "subnational1Name" + <*> v .: "subnational2Code" + <*> v .: "subnational2Name" + <*> v .: "isHotspot" + <*> v .: "hierarchicalName" + +-- | Explicit instance for compatibility with their field names +instance ToJSON LocationData where + toJSON LocationData{..} = + object + [ "name" .= _locationDataName + , "latitude" .= _locationDataLatitude + , "longitude" .= _locationDataLongitude + , "countryCode" .= _locationDataCountryCode + , "countryName" .= _locationDataCountryName + , "subnational1Code" .= _locationDataSubnational1Code + , "subnational1Name" .= _locationDataSubnational1Name + , "subnational2Code" .= _locationDataSubnational2Code + , "subnational2Name" .= _locationDataSubnational2Name + , "isHotspot" .= _locationDataIsHotspot + , "hierarchicalName" .= _locationDataHeirarchicalName + ] + +------------------------------------------------------------------------------- +-- EBirdString instances +------------------------------------------------------------------------------- + +-- | The eBird string for a 'SortChecklistsBy' value is either "obs_dt" or +-- "creation_dt". +instance EBirdString SortChecklistsBy where + toEBirdString = + \case + SortChecklistsByDateCreated -> "obs_dt" + SortChecklistsByDateSubmitted -> "creation_dt" + + fromEBirdString str = + parseOnly parseSortChecklistsBy str + & left (("Failed to parse SortChecklistsBy: " <>) . Text.pack) + +------------------------------------------------------------------------------- +-- IsString isntances +------------------------------------------------------------------------------- + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString SortChecklistsBy where + fromString = unsafeFromEBirdString . Text.pack + +------------------------------------------------------------------------------- +-- * attoparsec parsers +------------------------------------------------------------------------------- + +-- | Parse a 'SortChecklistsBy' value +parseSortChecklistsBy :: Parser SortChecklistsBy +parseSortChecklistsBy = + choice + [ "obs_dt" $> SortChecklistsByDateCreated + , "creation_dt" $> SortChecklistsByDateSubmitted + ] + where + _casesCovered :: SortChecklistsBy -> () + _casesCovered = + \case + SortChecklistsByDateCreated -> () + SortChecklistsByDateSubmitted -> () + +------------------------------------------------------------------------------- +-- 'ToHttpApiData' instances +------------------------------------------------------------------------------- + +instance ToHttpApiData SortChecklistsBy where + toUrlPiece = toEBirdString diff --git a/src/Data/EBird/API/EBirdString.hs b/src/Data/EBird/API/EBirdString.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/EBirdString.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Data.EBird.API.EBirdString +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- The 'EBirdString' class contains types whose values may be represented as +-- strings compatible with the eBird API. + +module Data.EBird.API.EBirdString + ( -- * The class + EBirdString(..) + + -- * Unsafe interface + , unsafeFromEBirdString + ) where + +import Data.Text (Text) +import GHC.Stack + +-- | A convenience class for converting the litany of eBird API types to and +-- from their respective eBird API compatible string representations. +class EBirdString a where + -- | Convert a value to an eBird string. + toEBirdString :: a -> Text + + -- | Parse a string into an eBird value. If parsing fails, this should result + -- in 'Left' with an error message. + fromEBirdString :: Text -> Either Text a + +-- | Parse a string into an eBird value unsafely. +-- +-- __Be careful!__ This can result in runtime errors if the string is +-- malformatted. +unsafeFromEBirdString :: (HasCallStack, EBirdString a) => Text -> a +unsafeFromEBirdString str = case fromEBirdString str of + Left _ -> error "Failed to parse eBird string" + Right x -> x diff --git a/src/Data/EBird/API/Hotspots.hs b/src/Data/EBird/API/Hotspots.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/Hotspots.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Data.EBird.API.Hotspots +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Types and functions related to eBird hotspot API values. + +module Data.EBird.API.Hotspots where + +import Control.Arrow +import Data.Aeson +import Data.Attoparsec.Text +import Data.Function +import Data.Functor +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Optics +import Servant.API + +import Data.EBird.API.EBirdString +import Data.EBird.API.Regions +import Data.EBird.API.Util.Time + +------------------------------------------------------------------------------- +-- * Hotspot type +------------------------------------------------------------------------------- + +-- | eBird hotspots, as returned by the 'Data.EBird.API.RegionHotspotsAPI' +data Hotspot = + Hotspot + { -- | Location ID of the hotspot + _hotspotLocationId :: Text + + -- | Name of the hotspot + , _hotspotLocationName :: Text + + -- | The country the hotspot is in + , _hotspotCountryCode :: Region + + -- | The state the hotspot is in + , _hotspotSubnational1Code :: Region + + -- | The county the hotspot is in + , _hotspotSubnational2Code :: Region + + -- | The latitude of the hotspot + , _hotspotLatitude :: Double + + -- | The longitude of the hotspot + , _hotspotLongitude :: Double + + -- | The date and time of the latest observation at the hotspot. Could + -- be 'Nothing' if the hotspot has never been birded + , _hotspotLatestObsDateTime :: Maybe EBirdDateTime + + -- | The number of species ever seen at the hotspot. Could be 'Nothing' + -- if the hotspot has never been birded + , _hotspotNumSpeciesAllTime :: Maybe Integer + } + deriving (Show, Read, Eq) + +-- ** Optics for the Hotspot type + +makeLenses ''Hotspot +makeFieldLabels ''Hotspot + +------------------------------------------------------------------------------- +-- * Auxiliary eBird hotspot-related API types +------------------------------------------------------------------------------- + +-- | Used to specify what format hotspot values should be returned in from the +-- hotspots APIs. +data CSVOrJSONFormat = CSVFormat | JSONFormat + deriving (Show, Read, Eq) + +------------------------------------------------------------------------------- +-- aeson instances +------------------------------------------------------------------------------- + +-- | Explicit instance for compatibility with their field names +instance FromJSON Hotspot where + parseJSON = withObject "Hotspot" $ \v -> + Hotspot + <$> v .: "locId" + <*> v .: "locName" + <*> v .: "countryCode" + <*> v .: "subnational1Code" + <*> v .: "subnational2Code" + <*> v .: "lat" + <*> v .: "lng" + <*> v .:? "latestObsDt" + <*> v .:? "numSpeciesAllTime" + +-- | Explicit instance for compatibility with their field names +instance ToJSON Hotspot where + toJSON Hotspot{..} = + object $ + [ "locId" .= _hotspotLocationId + , "locName" .= _hotspotLocationName + , "countryCode" .= _hotspotCountryCode + , "subnational1Code" .= _hotspotSubnational1Code + , "subnational2Code" .= _hotspotSubnational2Code + , "lat" .= _hotspotLatitude + , "lng" .= _hotspotLongitude + ] + -- Fields that may or may not be present depending on the data + <> [ "latestObsDt" .= latestObsDt + | Just latestObsDt <- [_hotspotLatestObsDateTime] + ] + <> [ "numSpeciesAllTime" .= numSpecies + | Just numSpecies <- [_hotspotNumSpeciesAllTime] + ] + +------------------------------------------------------------------------------- +-- EBirdString instances +------------------------------------------------------------------------------- + +-- | The eBird string of a 'CSVOrJSONFormat' value is either "csv" or "json". +instance EBirdString CSVOrJSONFormat where + toEBirdString = + \case + CSVFormat -> "csv" + JSONFormat -> "json" + + fromEBirdString str = + parseOnly parseCSVOrJSONFormat str + & left (("Failed to parse CSVOrJSONFormat: " <>) . Text.pack) + +------------------------------------------------------------------------------- +-- IsString instances +------------------------------------------------------------------------------- + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString CSVOrJSONFormat where + fromString = unsafeFromEBirdString . Text.pack + +------------------------------------------------------------------------------- +-- * attoparsec parsers +------------------------------------------------------------------------------- + +-- | Parse a list of eBird API taxononomy categories. To avoid the partial +-- behavior of converting a 'sepBy1' result into a 'Data.List.NonEmpty', we +-- manually parse the first category followed by an optional tail. +parseCSVOrJSONFormat :: Parser CSVOrJSONFormat +parseCSVOrJSONFormat = + choice + [ "csv" $> CSVFormat + , "json" $> JSONFormat + ] + where + _casesCovered :: CSVOrJSONFormat -> () + _casesCovered = + \case + CSVFormat -> () + JSONFormat -> () + +------------------------------------------------------------------------------- +-- 'ToHttpApiData' instances +------------------------------------------------------------------------------- + +instance ToHttpApiData CSVOrJSONFormat where + toUrlPiece = toEBirdString diff --git a/src/Data/EBird/API/Observations.hs b/src/Data/EBird/API/Observations.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/Observations.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + + +-- | +-- Module : Data.EBird.API.Observations +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Types and functions related to eBird observation API values. + +module Data.EBird.API.Observations where + +import Control.Arrow +import Data.Aeson +import Data.Aeson.KeyMap +import Data.Attoparsec.Text +import Data.Function +import Data.Functor +import Data.Maybe +import Data.String +import Data.Text as Text +import Optics +import Servant.API (ToHttpApiData(..)) + +import Data.EBird.API.EBirdString +import Data.EBird.API.Regions +import Data.EBird.API.Util.Time + +------------------------------------------------------------------------------- +-- * Observation types +------------------------------------------------------------------------------- + +-- | An observation of a species submitted to eBird within a checklist. The +-- 'DetailLevel' index indicates whether the observation data includes "full" +-- details. +data Observation (detail :: DetailLevel) = + Observation + { -- | Species code, e.g. "bohwax" + _observationSpeciesCode :: Text + + -- | Common name, e.g. "Bohemian Waxwing" + , _observationCommonName :: Text + + -- | Scientific name, e.g. "Bombycilla garrulus" + , _observationScientificName :: Text + + -- | Location ID, e.g. \"L7884500\" + , _observationLocationId :: Text + + -- | Location name, e.g. "Frog Pond" + , _observationLocationName :: Text + + -- | Date and time of observation + , _observationDateTime :: EBirdDateTime + + -- | How many were seen? Sometimes omitted. + , _observationHowMany :: Maybe Integer + + -- | Observation latitude + , _observationLatitude :: Double + + -- | Observation longitude + , _observationLongitude :: Double + + -- | Is this observation valid? + , _observationValid :: Bool + + -- | Has this observation been reviewed? + , _observationReviewed :: Bool + + -- | Is the location of this observation private? + , _observationLocationPrivate :: Bool + + -- | Submission ID + , _observationSubId :: Text + + , _observationFullDetail :: ObservationDetails detail + } + +deriving instance Show (Observation 'Simple) +deriving instance Show (Observation 'Full) +deriving instance Eq (Observation 'Simple) +deriving instance Eq (Observation 'Full) + +-- | Extra details that may be attached to an observation. At the moment, it +-- only seems possible to get 'Full' detailed observations from the notable +-- observation endpoints (e.g. 'Data.EBird.API.RecentNotableObservationsAPI'). +data ObservationDetails (detail :: DetailLevel) where + NoDetails :: ObservationDetails 'Simple + FullDetails :: + { -- | The subnational2 region that this observation took place in + _observationDetailsSubnational2Code :: Region + + -- | The name of the subnational2 region that this observation took + -- place in + , _observationDetailsSubnational2Name :: Text + + -- | The subnational1 region that this observation took place in + , _observationDetailsSubnational1Code :: Region + + -- | The name of the subnational1 region that this observation took + -- place in + , _observationDetailsSubnational1Name :: Text + + -- | The country region that this observation took place in + , _observationDetailsCountryCode :: Region + + -- | The name of the country region that this observation took place in + , _observationDetailsCountryName :: Text + + -- | The display name of the user that submitted this observation + , _observationDetailsUserDisplayName :: Text + + -- | The unique ID of this observation + , _observationDetailsObsId :: Text + + -- | The ID of the checklist that this observation was submitted with, + -- e.g. \"CL24936\" + , _observationDetailsChecklistId :: Text + + -- | Whether the count for the observation was provided as just \"X\" + , _observationDetailsPresenceNoted :: Bool + + -- | Whether this observation was submitted with comments + , _observationDetailsHasComments :: Bool + + -- | The last name of the user that submitted this observation + , _observationDetailsLastName :: Text + + -- | The first name of the user that submitted this observation + , _observationDetailsFirstName :: Text + + -- | Whether this observation has media such as photos, videos, or + -- audio attached + , _observationDetailsHasRichMedia :: Bool + } -> ObservationDetails 'Full + +deriving instance Show (ObservationDetails 'Simple) +deriving instance Show (ObservationDetails 'Full) +deriving instance Eq (ObservationDetails 'Simple) +deriving instance Eq (ObservationDetails 'Full) + +-- | 'Observation' values of existentially quantified detail. +data SomeObservation where + SomeObservation :: Observation detail -> SomeObservation + +instance Show SomeObservation where + show (SomeObservation o) = + case _observationFullDetail o of + NoDetails -> show o + FullDetails{} -> show o + +------------------------------------------------------------------------------- +-- * Auxiliary eBird observation API types +------------------------------------------------------------------------------- + +-- | The promoted constructors of this type are used as type-level indices on +-- the 'Observation' type to determine whether an observation is 'Simple' detail +-- or 'Full' detail. +data DetailLevel = Simple | Full + deriving (Show, Read, Eq) + +-- | Values representing the ways that observations may be sorted in responses +-- from the API. +data SortObservationsBy + = SortObservationsByDate + | SortObservationsBySpecies + deriving (Show, Read, Eq) + +-- | Values representing how to pick which 'Observation's are returned from the +-- 'Data.EBird.API.HistoricalObservationsAPI' in the case that there are several +-- observations of the same species on the date. +data SelectObservation + = SelectFirstObservation + | SelectLastObservation + deriving (Show, Read, Eq) + +------------------------------------------------------------------------------- +-- * Optics for observation types +------------------------------------------------------------------------------- + +makeLenses ''Observation +makeFieldLabels ''Observation + +observationDetailsSubnational2Code :: Lens' (ObservationDetails 'Full) Region +observationDetailsSubnational2Code = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsSubnational2Code = c }) + <$> f _observationDetailsSubnational2Code + +observationDetailsSubnational2Name :: Lens' (ObservationDetails 'Full) Text +observationDetailsSubnational2Name = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsSubnational2Name = c }) + <$> f _observationDetailsSubnational2Name + +observationDetailsSubnational1Code :: Lens' (ObservationDetails 'Full) Region +observationDetailsSubnational1Code = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsSubnational1Code = c }) + <$> f _observationDetailsSubnational1Code + +observationDetailsSubnational1Name :: Lens' (ObservationDetails 'Full) Text +observationDetailsSubnational1Name = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsSubnational1Name = c }) + <$> f _observationDetailsSubnational1Name + +observationDetailsCountryCode :: Lens' (ObservationDetails 'Full) Region +observationDetailsCountryCode = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsCountryCode = c }) + <$> f _observationDetailsCountryCode + +observationDetailsCountryName :: Lens' (ObservationDetails 'Full) Text +observationDetailsCountryName = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsCountryName = c }) + <$> f _observationDetailsCountryName + +observationDetailsUserDisplayName :: Lens' (ObservationDetails 'Full) Text +observationDetailsUserDisplayName = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsUserDisplayName = c }) + <$> f _observationDetailsUserDisplayName + +observationDetailsObsId :: Lens' (ObservationDetails 'Full) Text +observationDetailsObsId = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsObsId = c }) + <$> f _observationDetailsObsId + +observationDetailsChecklistId :: Lens' (ObservationDetails 'Full) Text +observationDetailsChecklistId = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsChecklistId = c }) + <$> f _observationDetailsChecklistId + +observationDetailsPresenceNoted :: Lens' (ObservationDetails 'Full) Bool +observationDetailsPresenceNoted = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsPresenceNoted = c }) + <$> f _observationDetailsPresenceNoted + +observationDetailsHasComments :: Lens' (ObservationDetails 'Full) Bool +observationDetailsHasComments = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsHasComments = c }) + <$> f _observationDetailsHasComments + +observationDetailsLastName :: Lens' (ObservationDetails 'Full) Text +observationDetailsLastName = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsLastName = c }) + <$> f _observationDetailsLastName + +observationDetailsFirstName :: Lens' (ObservationDetails 'Full) Text +observationDetailsFirstName = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsFirstName = c }) + <$> f _observationDetailsFirstName + +observationDetailsHasRichMedia :: Lens' (ObservationDetails 'Full) Bool +observationDetailsHasRichMedia = + lensVL $ \f d@FullDetails{..} -> + (\c -> d { _observationDetailsHasRichMedia = c }) + <$> f _observationDetailsHasRichMedia + +instance + k ~ A_Lens + => LabelOptic + "subnational2Code" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Region + Region + where + labelOptic = observationDetailsSubnational2Code + +instance + k ~ A_Lens + => LabelOptic + "subnational2Name" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsSubnational2Name + +instance + k ~ A_Lens + => LabelOptic + "subnational1Code" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Region + Region + where + labelOptic = observationDetailsSubnational1Code + +instance + k ~ A_Lens + => LabelOptic + "subnational1Name" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsSubnational1Name + +instance + k ~ A_Lens + => LabelOptic + "countryCode" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Region + Region + where + labelOptic = observationDetailsCountryCode + +instance + k ~ A_Lens + => LabelOptic + "countryName" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsCountryName + +instance + k ~ A_Lens + => LabelOptic + "userDisplayName" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsUserDisplayName + +instance + k ~ A_Lens + => LabelOptic + "obsId" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsObsId + +instance + k ~ A_Lens + => LabelOptic + "checklistId" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsChecklistId + +instance + k ~ A_Lens + => LabelOptic + "presenceNoted" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Bool + Bool + where + labelOptic = observationDetailsPresenceNoted + +instance + k ~ A_Lens + => LabelOptic + "hasComments" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Bool + Bool + where + labelOptic = observationDetailsHasComments + +instance + k ~ A_Lens + => LabelOptic + "lastName" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsLastName + +instance + k ~ A_Lens + => LabelOptic + "firstName" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Text + Text + where + labelOptic = observationDetailsFirstName + +instance + k ~ A_Lens + => LabelOptic + "hasRichMedia" k + (ObservationDetails 'Full) + (ObservationDetails 'Full) + Bool + Bool + where + labelOptic = observationDetailsHasRichMedia + +------------------------------------------------------------------------------- +-- aeson instances +------------------------------------------------------------------------------- + +-- | Explicit instance for compatibility with their field names +instance FromJSON (Observation 'Simple) where + parseJSON = withObject "Observation 'Simple" $ \v -> + Observation + <$> v .: "speciesCode" + <*> v .: "comName" + <*> v .: "sciName" + <*> v .: "locId" + <*> v .: "locName" + <*> v .: "obsDt" + <*> v .:? "howMany" + <*> v .: "lat" + <*> v .: "lng" + <*> v .: "obsValid" + <*> v .: "obsReviewed" + <*> v .: "locationPrivate" + <*> v .: "subId" + <*> pure NoDetails + +-- | Explicit instance for compatibility with their field names +instance ToJSON (Observation 'Simple) where + toJSON Observation{..} = + object $ + [ "speciesCode" .= _observationSpeciesCode + , "comName" .= _observationCommonName + , "sciName" .= _observationScientificName + , "locId" .= _observationLocationId + , "locName" .= _observationLocationName + , "obsDt" .= _observationDateTime + , "lat" .= _observationLatitude + , "lng" .= _observationLongitude + , "obsValid" .= _observationValid + , "obsReviewed" .= _observationReviewed + , "locationPrivate" .= _observationLocationPrivate + , "subId" .= _observationSubId + ] + -- Fields that may or may not be included, depending on the observation + -- data + <> ["howMany" .= howMany | Just howMany <- [_observationHowMany]] + +-- | Explicit instance for compatibility with their field names +instance FromJSON (Observation 'Full) where + parseJSON = withObject "Observation 'Full" $ \v -> + Observation + <$> v .: "speciesCode" + <*> v .: "comName" + <*> v .: "sciName" + <*> v .: "locId" + <*> v .: "locName" + <*> v .: "obsDt" + <*> v .:? "howMany" + <*> v .: "lat" + <*> v .: "lng" + <*> v .: "obsValid" + <*> v .: "obsReviewed" + <*> v .: "locationPrivate" + <*> v .: "subId" + <*> ( FullDetails + <$> v .: "subnational2Code" + <*> v .: "subnational2Name" + <*> v .: "subnational1Code" + <*> v .: "subnational1Name" + <*> v .: "countryCode" + <*> v .: "countryName" + <*> v .: "userDisplayName" + <*> v .: "obsId" + <*> v .: "checklistId" + <*> v .: "presenceNoted" + <*> v .: "hasComments" + <*> v .: "lastName" + <*> v .: "firstName" + <*> v .: "hasRichMedia" + ) + +-- | Explicit instance for compatibility with their field names +instance ToJSON (Observation 'Full) where + toJSON Observation{..} = + object + [ "speciesCode" .= _observationSpeciesCode + , "comName" .= _observationCommonName + , "sciName" .= _observationScientificName + , "locId" .= _observationLocationId + , "locName" .= _observationLocationName + , "obsDt" .= _observationDateTime + , "howMany" .= _observationHowMany + , "lat" .= _observationLatitude + , "lng" .= _observationLongitude + , "obsValid" .= _observationValid + , "obsReviewed" .= _observationReviewed + , "locationPrivate" .= _observationLocationPrivate + , "subId" .= _observationSubId + , "subnational2Code" .= + _observationDetailsSubnational2Code _observationFullDetail + , "subnational2Name" .= + _observationDetailsSubnational2Name _observationFullDetail + , "subnational1Code" .= + _observationDetailsSubnational1Code _observationFullDetail + , "subnational1Name" .= + _observationDetailsSubnational1Name _observationFullDetail + , "countryCode" .= + _observationDetailsCountryCode _observationFullDetail + , "countryName" .= + _observationDetailsCountryName _observationFullDetail + , "userDisplayName" .= + _observationDetailsUserDisplayName _observationFullDetail + , "obsId" .= + _observationDetailsObsId _observationFullDetail + , "checklistId" .= + _observationDetailsChecklistId _observationFullDetail + , "presenceNoted" .= + _observationDetailsPresenceNoted _observationFullDetail + , "hasComments" .= + _observationDetailsHasComments _observationFullDetail + , "lastName" .= + _observationDetailsLastName _observationFullDetail + , "firstName" .= + _observationDetailsFirstName _observationFullDetail + , "hasRichMedia" .= + _observationDetailsHasRichMedia _observationFullDetail + ] + +-- | Switches between parsing a 'Simple' detail 'Observation' and a 'Full' +-- detail 'Observation' depending on whether the "firstName" key is present. +instance FromJSON SomeObservation where + parseJSON obj = withObject "SomeObservation" + ( \v -> + if isJust (v !? "firstName") then + SomeObservation <$> parseJSON @(Observation 'Full) obj + else + SomeObservation <$> parseJSON @(Observation 'Simple) obj + ) obj + +-- | Switches between encoding a 'Simple' 'Observation' and a 'Full' +-- 'Observation' depending on the evidence introduced by pattern-matching on the +-- 'observationFullDetail' field. +instance ToJSON SomeObservation where + toJSON (SomeObservation obs) = + case _observationFullDetail obs of + NoDetails -> toJSON @(Observation 'Simple) obs + FullDetails {} -> toJSON @(Observation 'Full) obs + +------------------------------------------------------------------------------- +-- 'EBirdString' instances +------------------------------------------------------------------------------- + +-- | The eBird string for a 'DetailLevel' value is simply the lowercase +-- constructor name. +instance EBirdString DetailLevel where + toEBirdString = + \case + Simple -> "simple" + Full -> "full" + + fromEBirdString str = + parseOnly parseDetailLevel str + & left (("Failed to parse DetailLevel: " <>) . Text.pack) + +-- | The eBird string for a 'SortObservationsBy' value is either "date" or +-- "species". +instance EBirdString SortObservationsBy where + toEBirdString = + \case + SortObservationsByDate -> "date" + SortObservationsBySpecies -> "species" + + fromEBirdString str = + parseOnly parseSortObservationsBy str + & left (("Failed to parse SortObservationsBy: " <>) . Text.pack) + +-- | The eBird string for a 'SelectObservation' value is either "create" or +-- "mrec". +instance EBirdString SelectObservation where + toEBirdString = + \case + SelectFirstObservation -> "create" + SelectLastObservation -> "mrec" + + fromEBirdString str = + parseOnly parseSelectObservation str + & left (("Failed to parse SelectObservation: " <>) . Text.pack) + +------------------------------------------------------------------------------- +-- IsString instances +------------------------------------------------------------------------------- + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString DetailLevel where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString SortObservationsBy where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString SelectObservation where + fromString = unsafeFromEBirdString . Text.pack + +------------------------------------------------------------------------------- +-- * attoparsec parsers +------------------------------------------------------------------------------- + +-- | Parse a list of eBird API taxononomy categories. To avoid the partial +-- behavior of converting a 'sepBy1' result into a 'Data.List.NonEmpty', we +-- manually parse the first category followed by an optional tail. +parseDetailLevel :: Parser DetailLevel +parseDetailLevel = + choice + [ "simple" $> Simple + , "full" $> Full + ] + where + _casesCovered :: DetailLevel -> () + _casesCovered = + \case + Simple -> () + Full -> () + +-- | Parse a 'SortObservationsBy' value +parseSortObservationsBy :: Parser SortObservationsBy +parseSortObservationsBy = + choice + [ "date" $> SortObservationsByDate + , "species" $> SortObservationsBySpecies + ] + where + _casesCovered :: SortObservationsBy -> () + _casesCovered = + \case + SortObservationsByDate -> () + SortObservationsBySpecies -> () + +-- | Parse a 'SelectObservation' value +parseSelectObservation :: Parser SelectObservation +parseSelectObservation = + choice + [ "first" $> SelectFirstObservation + , "last" $> SelectLastObservation + ] + where + _casesCovered :: SelectObservation -> () + _casesCovered = + \case + SelectFirstObservation -> () + SelectLastObservation -> () + +------------------------------------------------------------------------------- +-- 'ToHttpApiData' instances +------------------------------------------------------------------------------- + +instance ToHttpApiData DetailLevel where + toUrlPiece = toEBirdString + +instance ToHttpApiData SortObservationsBy where + toUrlPiece = toEBirdString + +instance ToHttpApiData SelectObservation where + toUrlPiece = toEBirdString diff --git a/src/Data/EBird/API/Product.hs b/src/Data/EBird/API/Product.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/Product.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Data.EBird.API.Product +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Types related to eBird product API values. + +module Data.EBird.API.Product where + +import Control.Arrow +import Data.Aeson +import Data.Attoparsec.Text +import Data.Function +import Data.Functor +import Data.String +import Data.Text as Text +import Optics +import Servant.API (ToHttpApiData(..)) + +import Data.EBird.API.EBirdString + +------------------------------------------------------------------------------- +-- * Top 100 contributors API types +------------------------------------------------------------------------------- + +-- | Values held in the top 100 contributors list returned by the eBird API. +data Top100ListEntry = + Top100ListEntry + { -- | The profile handle of the user, whocse profile may be seen at + -- ebird.org/profile/{handle} if they have a profile + _top100ListEntryProfileHandle :: Maybe Text + + -- | The display name of the user (typically their full name) + , _top100ListEntryUserDisplayName :: Text + + -- | The number of species the user observed on the date + , _top100ListEntryNumSpecies :: Integer + + -- | The number of complete checklists the user contributed on the date + , _top100ListEntryNumCompleteChecklists :: Integer + + -- | The ranking of the user + , _top100ListEntryRowNum :: Integer + + -- | The user ID od the user + , _top100ListEntryUserId :: Text + } + deriving (Show, Read, Eq) + +-- ** Optics for the Top100ListEntry type + +makeLenses ''Top100ListEntry +makeFieldLabels ''Top100ListEntry + +-- | How to rank the list returned by the 'Data.EBird.API.Top100API'. +data RankTop100By + -- | Rank the list by the number of species seen + = RankTop100BySpecies + + -- | Rank the list by number of contributed checklists + | RankTop100ByChecklists + deriving (Show, Read, Eq) + +------------------------------------------------------------------------------- +-- * Regional statistics API types +------------------------------------------------------------------------------- + +-- | Values returned by the 'Data.EBird.API.RegionalStatisticsAPI'. +data RegionalStatistics = + RegionalStatistics + { -- | Number of checklists submitted in the region + _regionalStatisticsNumChecklists :: Integer + + -- | Number of contributors who have submitted checklists in the region + , _regionalStatisticsNumContributors :: Integer + + -- | Number of species included in checklists in the region + , _regionalStatisticsNumSpecies :: Integer + } + deriving (Show, Read, Eq) + +-- ** Optics for the RegionalStatistics type + +makeLenses ''RegionalStatistics +makeFieldLabels ''RegionalStatistics + +------------------------------------------------------------------------------- +-- Aeson instances +------------------------------------------------------------------------------- + +-- | Explicit instance for compatibility with their field names +instance FromJSON Top100ListEntry where + parseJSON = withObject "Top100ListEntry" $ \v -> + Top100ListEntry + <$> v .:? "profileHandle" + <*> v .: "userDisplayName" + <*> v .: "numSpecies" + <*> v .: "numCompleteChecklists" + <*> v .: "rowNum" + <*> v .: "userId" + +-- | Explicit instance for compatibility with their field names +instance ToJSON Top100ListEntry where + toJSON Top100ListEntry{..} = + object $ + [ "userDisplayname" .= _top100ListEntryUserDisplayName + , "numSpecies" .= _top100ListEntryNumSpecies + , "numCompleteChecklists" .= _top100ListEntryNumCompleteChecklists + , "rowNum" .= _top100ListEntryRowNum + , "userId" .= _top100ListEntryUserId + ] + -- Fields that may or may not be included, depending on the contributor + -- data + <> ["profileHandle" .= profileHandle + | Just profileHandle <- [_top100ListEntryProfileHandle] + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON RegionalStatistics where + parseJSON = withObject "RegionalStatistics" $ \v -> + RegionalStatistics + <$> v .: "numChecklists" + <*> v .: "numContributors" + <*> v .: "numSpecies" + +-- | Explicit instance for compatibility with their field names +instance ToJSON RegionalStatistics where + toJSON RegionalStatistics{..} = + object + [ "numChecklists" .= _regionalStatisticsNumChecklists + , "numContributors" .= _regionalStatisticsNumContributors + , "numSpecies" .= _regionalStatisticsNumSpecies + ] + +------------------------------------------------------------------------------- +-- 'EBirdString' instances +------------------------------------------------------------------------------- + +-- | The eBird string for a 'RankTop100By' value is either "spp" or "cl". +instance EBirdString RankTop100By where + toEBirdString = + \case + RankTop100BySpecies -> "spp" + RankTop100ByChecklists -> "cl" + + fromEBirdString str = + parseOnly parseRankTop100By str + & left (("Failed to parse RankTop100By: " <>) . Text.pack) + +------------------------------------------------------------------------------- +-- IsString instances +------------------------------------------------------------------------------- + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString RankTop100By where + fromString = unsafeFromEBirdString . Text.pack + +------------------------------------------------------------------------------- +-- * attoparsec parsers +------------------------------------------------------------------------------- + +-- | Parse a 'RankTop100By' value +parseRankTop100By :: Parser RankTop100By +parseRankTop100By = + choice + [ "spp" $> RankTop100BySpecies + , "cl" $> RankTop100ByChecklists + ] + where + _casesCovered :: RankTop100By -> () + _casesCovered = + \case + RankTop100BySpecies -> () + RankTop100ByChecklists -> () + +------------------------------------------------------------------------------- +-- 'ToHttpApiData' instances +------------------------------------------------------------------------------- + +instance ToHttpApiData RankTop100By where + toUrlPiece = toEBirdString diff --git a/src/Data/EBird/API/Regions.hs b/src/Data/EBird/API/Regions.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/Regions.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Data.EBird.API.Regions +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Types related to eBird region API values. + +module Data.EBird.API.Regions where + +import Control.Arrow +import Data.Aeson +import Data.Attoparsec.Text +import Data.Function +import Data.Functor +import Data.List.NonEmpty (NonEmpty(..)) +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Optics +import Servant.API (ToHttpApiData(..)) + +import Data.EBird.API.EBirdString + +------------------------------------------------------------------------------- +-- * Region-related API types +------------------------------------------------------------------------------- + +-- | eBird divides the world into countries, subnational1 regions (states) or +-- subnational2 regions (counties). 'Location' regions are eBird-specific +-- location identifiers. +data Region = + -- | Regions may be specified as location IDs, e.g. @L227544@ + Location Integer + + -- | The world is a region + | World + + -- | At the top level, the world is divided into countries + | Country Text + + -- | Subnational1 regions are states within countries + | Subnational1 + Text -- ^ The country + Text -- ^ The state + + -- | Subnational2 regions are counties within states + | Subnational2 + Text -- ^ The country + Text -- ^ The state + Text -- ^ The county + deriving (Show, Read, Eq) + +-- | One constructor per eBird "region type" (countries, subnational1 (states), +-- or subnational2 (counties)). +data RegionType = + CountryType + | Subnational1Type + | Subnational2Type + deriving (Show, Read, Eq) + +-- | A 'RegionCode' is a list of one or more 'Region's. +newtype RegionCode = RegionCode { regionCodeRegions :: NonEmpty Region } + deriving (Show, Read, Eq) + +-- | 'RegionNameFormat' values specify what format the API should return region +-- names in. See the constructor docs for examples. +data RegionNameFormat = + -- | 'DetailedNameFormat' region name values are fully qualified with only + -- the country abbreviated, e.g. "Madison County, New York, US" + DetailedNameFormat + + -- | 'DetailedNoQualNameFormat' region name values are like + -- 'DetailedNameFormat' but without the country qualifier and no "county" + -- annotation, e.g. "Madison, New York" + | DetailedNoQualNameFormat + + -- | 'FullNameFormat' region name values are fully qualified with no + -- abbreviated country name and no "county" annotation, e.g. "Madison, + -- New York, United States" + | FullNameFormat + + -- | 'NameQualNameFormat' region name values are just the annotated name, + -- e.g. "Madison County" + | NameQualNameFormat + + -- | 'NameOnlyNameFormat' region name values are just the name, e.g. + -- \"Madison\" + | NameOnlyNameFormat + + -- | 'RevDetailedNameFormat' region name values are like + -- 'DetailedNameFormat' but with reverse qualifiers, e.g. "US, New York, + -- Madison County" + | RevDetailedNameFormat + deriving (Show, Read, Eq) + +-- | 'RegionInfo' specifies the name of a region (in some 'RegionNameFormat') +-- and the bounds of that region as 'RegionBounds'. +data RegionInfo = + RegionInfo + { _regionInfoName :: Text + , _regionInfoBounds :: Maybe RegionBounds + } + deriving (Show, Read, Eq) + + +-- | 'RegionBounds' specify the corners of a bounding box around a region. +data RegionBounds = + RegionBounds + { _regionBoundsMinX :: Double + , _regionBoundsMaxX :: Double + , _regionBoundsMinY :: Double + , _regionBoundsMaxY :: Double + } + deriving (Show, Read, Eq) + +-- | The data structure returned by the eBird 'Data.EBird.API.SubRegionListAPI' and +-- 'Data.EBird.API.AdjacentRegionsAPI'. +data RegionListEntry = + RegionListEntry + { _regionListEntryRegion :: Region + , _regionListEntryName :: Text + } + deriving (Show, Read, Eq) + +-- ** Optics for region-related API types + +makeLenses ''RegionInfo +makeFieldLabels ''RegionInfo +makeLenses ''RegionBounds +makeFieldLabels ''RegionBounds +makeLenses ''RegionListEntry +makeFieldLabels ''RegionListEntry + +------------------------------------------------------------------------------- +-- aeson instances +------------------------------------------------------------------------------- + +instance FromJSON RegionCode where + parseJSON = withText "RegionCode" $ \t -> + case parseOnly parseRegionCode t of + Left _ -> fail "failed to parse region code" + Right c -> return c + +instance ToJSON RegionCode where + toJSON = String . toEBirdString + +instance FromJSON Region where + parseJSON = withText "RegionCode" $ \t -> + case parseOnly parseRegion t of + Left _ -> fail "failed to parse region" + Right r -> return r + +instance ToJSON Region where + toJSON = String . toEBirdString + +-- | Explicit instance for compatibility with their field names +instance FromJSON RegionInfo where + parseJSON = withObject "RegionInfo" $ \v -> + RegionInfo + <$> v .: "result" + <*> v .:? "bounds" + +-- | Explicit instance for compatibility with their field names +instance ToJSON RegionInfo where + toJSON RegionInfo{..} = + object $ + [ "result" .= _regionInfoName + ] + <> ["bounds" .= bs | Just bs <- [_regionInfoBounds]] + +-- | Explicit instance for compatibility with their field names +instance FromJSON RegionBounds where + parseJSON = withObject "RegionBounds" $ \v -> + RegionBounds + <$> v .: "minX" + <*> v .: "maxX" + <*> v .: "minY" + <*> v .: "maxY" + +-- | Explicit instance for compatibility with their field names +instance ToJSON RegionBounds where + toJSON RegionBounds{..} = + object + [ "minX" .= _regionBoundsMinX + , "maxX" .= _regionBoundsMaxX + , "minY" .= _regionBoundsMinY + , "maxY" .= _regionBoundsMaxY + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON RegionListEntry where + parseJSON = withObject "RegionListEntry" $ \v -> + RegionListEntry + <$> v .: "code" + <*> v .: "name" + +-- | Explicit instance for compatibility with their field names +instance ToJSON RegionListEntry where + toJSON RegionListEntry{..} = + object + [ "code" .= _regionListEntryRegion + , "name" .= _regionListEntryName + ] + +------------------------------------------------------------------------------- +-- 'EBirdString' instances +------------------------------------------------------------------------------- + +-- | A 'Region' eBird string is either: +-- +-- * \"L227544\" for location regions, where L227544 is the location ID. +-- * "world" for 'World' regions. +-- * The country identifier (e.g. \"US\" for the United States) for 'Country' +-- regions. +-- * The country identifier and the state identifier separated by a hyphen +-- for 'Subnational1' regions (e.g. "US-WY" for Wyoming in the United +-- States). +-- * The county identifier, the state identifier, and the country identifier +-- separated by hyphens for 'Subnational2' regions (e.g. US-WY-013) +instance EBirdString Region where + toEBirdString = + \case + Location n -> "L" <> Text.pack (show n) + World -> "world" + Country cr -> cr + Subnational1 cr st -> cr <> "-" <> st + Subnational2 cr st cy -> cr <> "-" <> st <> "-" <> cy + + fromEBirdString str = + parseOnly parseRegion str + & left (("Failed to parse Region: " <>) . Text.pack) + +-- | Results in +-- [eBird region type format](https://documenter.getpostman.com/view/664302/S1ENwy59#382da1c8-8bff-4926-936a-a1f8b065e7d5) +instance EBirdString RegionType where + toEBirdString = + \case + CountryType -> "country" + Subnational1Type -> "subnational1" + Subnational2Type -> "subnational2" + + fromEBirdString str = + parseOnly parseRegionType str + & left (("Failed to parse RegionType: " <>) . Text.pack) + +-- | A 'RegionCode' eBird string is a comma-separated list of regions. +instance EBirdString RegionCode where + toEBirdString (RegionCode (r :| rs)) = + Text.intercalate "," $ map toEBirdString (r : rs) + + fromEBirdString str = + parseOnly parseRegionCode str + & left (("Failed to parse RegionCode: " <>) . Text.pack) + +-- | A 'RegionNameFormat' is shown as the constructor name without the +-- @NameFormat@ suffix, in all lower-case. +instance EBirdString RegionNameFormat where + toEBirdString = + \case + DetailedNameFormat -> "detailed" + DetailedNoQualNameFormat -> "detailednoqual" + FullNameFormat -> "full" + NameQualNameFormat -> "namequal" + NameOnlyNameFormat -> "nameonly" + RevDetailedNameFormat -> "revdetailed" + + fromEBirdString str = + parseOnly parseRegionNameFormat str + & left (("Failed to parse RegionNameFormat: " <>) . Text.pack) + +------------------------------------------------------------------------------- +-- IsString instances +------------------------------------------------------------------------------- + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString Region where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString RegionType where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString RegionCode where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString RegionNameFormat where + fromString = unsafeFromEBirdString . Text.pack + +------------------------------------------------------------------------------- +-- * attoparsec parsers +------------------------------------------------------------------------------- + +-- | Parse an eBird API region code, which is a comma-separated list of one or +-- more regions. To avoid the partial behavior of converting a 'sepBy1' result +-- into a 'NonEmpty', we manually parse the first region followed by an optional +-- tail. +parseRegionCode :: Parser RegionCode +parseRegionCode = do + r <- parseRegion + rs <- atEnd >>= \case + True -> return [] + False -> do + skip (==',') + parseRegion `sepBy` char ',' + return $ RegionCode (r :| rs) + +-- | Parse an eBird API region. This parser only ensures that the input is +-- somewhat well-formed, in that it is either: +-- +-- * A 'Location' region (an \'L\' followed by an integral number) +-- * The 'World' region (just the string "world") +-- * A 'Subnational2' region (formatted as "LETTERS-LETTERS-NUMBER" where +-- "LETTERS" is one or more letters in any case, and "NUMBERS" is an +-- integral number) +-- * A 'Subnational1' region (formatterd as "LETTERS-LETTERS") +-- * A 'Country' region (just \"LETTERS\") +parseRegion :: Parser Region +parseRegion = + choice + [ parseLocationId + , parseWorld + , parseSubnational2 + , parseSubnational1 + , parseCountry + ] + where + parseLocationId :: Parser Region + parseLocationId = do + "L" *> (Location <$> decimal) + + parseWorld :: Parser Region + parseWorld = do + "world" $> World + + parseCountry :: Parser Region + parseCountry = Country <$> letters + + parseSubnational1 :: Parser Region + parseSubnational1 = do + cr <- letters + skipHyphen + st <- letters + return $ Subnational1 cr st + + parseSubnational2 :: Parser Region + parseSubnational2 = do + cr <- letters + skipHyphen + st <- letters + skipHyphen + cy <- choice [letters, digits] + return $ Subnational2 cr st cy + + letters :: Parser Text + letters = Text.pack <$> many1 letter + + digits :: Parser Text + digits = Text.pack <$> many1 digit + + skipHyphen :: Parser () + skipHyphen = skip (=='-') + +-- | Parse an eBird API 'RegionNameFormat'. +parseRegionNameFormat :: Parser RegionNameFormat +parseRegionNameFormat = + choice + [ "detailednoqual" $> DetailedNoQualNameFormat + , "detailed" $> DetailedNameFormat + , "full" $> FullNameFormat + , "namequal" $> NameQualNameFormat + , "nameonly" $> NameOnlyNameFormat + , "revdetailed" $> RevDetailedNameFormat + ] + where + _casesCovered :: RegionNameFormat -> () + _casesCovered = + \case + DetailedNoQualNameFormat -> () + DetailedNameFormat -> () + FullNameFormat -> () + NameQualNameFormat -> () + NameOnlyNameFormat -> () + RevDetailedNameFormat -> () + +-- | Parse an eBird API 'RegionType'. +parseRegionType :: Parser RegionType +parseRegionType = + choice + [ "country" $> CountryType + , "subnational1" $> Subnational1Type + , "subnational2" $> Subnational2Type + ] + where + _casesCovered :: RegionType -> () + _casesCovered = + \case + CountryType -> () + Subnational1Type -> () + Subnational2Type -> () + +------------------------------------------------------------------------------- +-- 'ToHttpApiData' instances +------------------------------------------------------------------------------- + +instance ToHttpApiData Region where + toUrlPiece = toEBirdString + +instance ToHttpApiData RegionType where + toUrlPiece = toEBirdString + +instance ToHttpApiData RegionCode where + toUrlPiece = toEBirdString + +instance ToHttpApiData RegionNameFormat where + toUrlPiece = toEBirdString diff --git a/src/Data/EBird/API/Taxonomy.hs b/src/Data/EBird/API/Taxonomy.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/Taxonomy.hs @@ -0,0 +1,911 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} + +-- | +-- Module : Data.EBird.API.Internal.Types.Taxonomy +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Types related to eBird taxonomy-related API values. + +module Data.EBird.API.Taxonomy where + +import Control.Arrow +import Data.Aeson +import Data.Attoparsec.Text +import Data.Char +import Data.Function +import Data.Functor +import Data.List.NonEmpty (NonEmpty(..)) +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Optics +import GHC.Exts +import Servant.API (ToHttpApiData(..)) + +import Data.EBird.API.EBirdString + +------------------------------------------------------------------------------- +-- * Taxonomy types +------------------------------------------------------------------------------- + +-- | Taxa in the eBird taxonomy. +data Taxon = + Taxon + { -- | Scientific name, e.g. "Bombycilla garrulus/cedrorum" + _taxonScientificName :: Text + + -- | Common name, e.g. "Bohemian/Cedar Waxwing" + , _taxonCommonName :: Text + + -- | eBird species code, e.g. "waxwin" + , _taxonSpeciesCode :: SpeciesCode + + -- | eBird species category, e.g. "slash" + -- + -- See the [eBird + -- documentation](https://science.ebird.org/en/use-ebird-data/the-ebird-taxonomy) + -- for more information on species categories + , _taxonCategory :: TaxonomyCategory + + -- | A numeric value that determines the location of this taxon in the + -- taxonomy list, e.g. 29257.0 + , _taxonTaxonOrder :: Double + + -- | Banding codes, e.g. [\"BOWA\"] for Bohemian Waxwing. + , _taxonBandingCodes :: [Text] + + -- | Common name codes, e.g. [\"BOWA\",\"CEDW\",\"CEWA\"] + , _taxonCommonNameCodes :: [Text] + + -- | Scientific name codes, e.g. [\"BOCE\",\"BOGA\"] + , _taxonScientificNameCodes :: [Text] + + -- | Order, e.g. \"Passeriformes\" + , _taxonOrder :: Text + + -- | Family code, e.g. "bombyc1" + , _taxonFamilyCode :: Maybe Text + + -- | Family common name, e.g. \"Waxwings\" + , _taxonFamilyCommonName :: Maybe Text + + -- | Family scientific name, e.g. \"Bombycillidae\" + , _taxonFamilyScientificName :: Maybe Text + } + deriving (Show, Read, Eq) + +-- | eBird species codes, simply 'Text'; e.g. Gray Vireo is "gryvir", Field +-- Sparrow is "fiespa". +newtype SpeciesCode = SpeciesCode { speciesCode :: Text } + deriving (Eq, Show, Read) + +-- | A list of eBird 'SpeciesCode's. +newtype SpeciesCodes = SpeciesCodes { speciesCodes :: [SpeciesCode] } + deriving (Eq, Show, Read) + +-- | The taxonomy categories are explained in the +-- [eBird documentation](https://science.ebird.org/en/use-ebird-data/the-ebird-taxonomy). +-- Their examples are echoed in the documentation of the constructors of this +-- type. +data TaxonomyCategory = + -- | The 'Species' category simply identifies species, e.g. "Tundra Swan + -- /Cygnus columbianus/" + Species + + -- | Genus or broad identification, e.g. "swan sp. /Cygnus sp./" + | Spuh + + -- | Identifiable subspecies or group of subspecies, e.g. "Tundra Swan + -- (Bewick’s) /Cygnus columbianus bewickii/" or "Tundra Swan (Whistling) + -- /Cygnus columbianus columbianus/" + | ISSF + + -- | Identification to species pair, e.g. "Tundra/Trumpeter Swan + -- /Cygnus columbianus\/buccinator/" + | Slash + + -- | Hybrid between two species, e.g. "Tundra x Trumpeter Swan (hybrid)" + | Hybrid + + -- | Hybrid between two ISSF (subspecies or subspecies groups), e.g. + -- "Tundra Swan (Whistling x Bewick’s) + -- /Cygnus columbianus columbianus x bewickii/" + | Intergrade + + -- | Distinctly-plumaged domesticated varieties that may be free-flying + -- (these do not count on personal lists), e.g. "Mallard (Domestic type)" + | Domestic + + -- | Miscellaneous other taxa, including recently-described species yet to + -- be accepted or distinctive forms that are not universally accepted, + -- e.g. Red-tailed Hawk (abieticola), Upland Goose (Bar-breasted). + | Form + deriving (Show, Read, Eq) + +-- | 'TaxonomyCategories' values contain a 'NonEmpty' list of +-- 'TaxonomyCategory's. +newtype TaxonomyCategories = + TaxonomyCategories + { taxonomyCategoriesCategories :: NonEmpty TaxonomyCategory + } + deriving (Show, Read, Eq) + +-- ** Optics for taxonomy types + +makeLenses ''Taxon +makeFieldLabels ''Taxon + +------------------------------------------------------------------------------- +-- * Auxiliary eBird taxonomy-related API types +------------------------------------------------------------------------------- + +-- | eBird maintains many common name translations. See their +-- ["Bird Names in eBird"](https://support.ebird.org/en/support/solutions/articles/48000804865-bird-names-in-ebird) +-- documentation for a discussion of the languages they support. +-- +-- This type is an enumeration of those languages, and is used to support the +-- [eBird API](https://documenter.getpostman.com/view/664302/S1ENwy59) +-- endpoints which allow a locale to be specified. +data SPPLocale = + Af -- ^ Afrikaans + | Sq -- ^ Albanians + | Ar -- ^ Arabic + | Hy -- ^ Armenian + | As -- ^ Assamese + | Ast -- ^ Asturian + | Az -- ^ Azerbaijani + | Eu -- ^ Basque + | Bn -- ^ Bengali + | Bg -- ^ Bulgarian + | Ca -- ^ Catalan + | Zh -- ^ Chinese, Mandarin (traditional) + | Zh_SIM -- ^ Chinese, Simple + | Ht_HT -- ^ Creole, Haiti + | Hr -- ^ Croatian + | Cs -- ^ Czech + | Da -- ^ Danish + | Nl -- ^ Dutch + | En -- ^ English + | En_AU -- ^ English, Australia + | En_BD -- ^ English, Bangladesh + | En_HAW -- ^ English, Hawaii + | En_HBW -- ^ English, HBW + | En_IN -- ^ English, India + | En_IOC -- ^ English, IOC + | En_KE -- ^ English, Kenya + | En_MY -- ^ English, Malaysia + | En_NZ -- ^ English, New Zealand + | En_PH -- ^ English, Philippines + | En_ZA -- ^ English, South Africa + | En_AE -- ^ English, UAE + | En_UK -- ^ English, United Kingdon + | En_US -- ^ English, United States + | Fo -- ^ Faroese + | Fi -- ^ Finnish + | Fr -- ^ French + | Fr_AOU -- ^ French, AOU + | Fr_FR -- ^ French, France + | Fr_CA -- ^ French, Canada + | Fr_GF -- ^ French, Guiana + | Fr_GP -- ^ French, Guadeloupe + | Fr_HT -- ^ French, Haiti + | Gl -- ^ Gallegan + | De -- ^ German + | El -- ^ Greek + | Gu -- ^ Gujarati + | He -- ^ Hebrew + | Hi -- ^ Hindi + | Hu -- ^ Hungarian + | Is -- ^ Icelandic + | In -- ^ Indonesian + | It -- ^ Italian + | Ja -- ^ Japanese + | Ko -- ^ Korean + | Lv -- ^ Latvian + | Lt -- ^ Lithuanian + | Ml -- ^ Malayalam + | Mr -- ^ Marathi + | Mn -- ^ Mongolian + | No -- ^ Norwegian + | Or -- ^ Odia + | Fa -- ^ Persian + | Pl -- ^ Polish + | Pt_AO -- ^ Portuguese, Angola + | Pt_RAA -- ^ Portuguese, Azores + | Pt_Br -- ^ Portuguese, Brazil + | Pt_RAM -- ^ Portuguese, Madeira + | Pt_PT -- ^ Portuguese, Portugal + | Ro -- ^ Romanian + | Ru -- ^ Russian + | Sr -- ^ Serbian + | Sk -- ^ Slovak + | Sl -- ^ Slovenian + | Es -- ^ Spanish + | Es_AR -- ^ Spanish, Argentina + | Es_CL -- ^ Spanish, Chile + | Es_CR -- ^ Spanish, Costa Rica + | Es_CU -- ^ Spanish, Cuba + | Es_DO -- ^ Spanish, Dominican Republic + | Es_EC -- ^ Spanish, Ecuador + | Es_HN -- ^ Spanish, Honduras + | Es_MX -- ^ Spanish, Mexico + | Es_PA -- ^ Spanish, Panama + | Es_PY -- ^ Spanish, Paraguay + | Es_PE -- ^ Spanish, Peru + | Es_PR -- ^ Spanish, Puerto Rico + | Es_ES -- ^ Spanish, Spain + | Es_UY -- ^ Spanish, Uruguay + | Es_VE -- ^ Spanish, Venezuela + | Sv -- ^ Swedish + | Te -- ^ Telugu + | Th -- ^ Thai + | Tr -- ^ Turkish + | Uk -- ^ Ukrainian + deriving (Show, Read, Eq) + +-- | Values returned from the 'Data.EBird.API.TaxaLocaleCodesAPI'. +data SPPLocaleListEntry = + SPPLocaleListEntry + { -- | The code of the locale, e.g. 'En_US' + _sppLocaleListEntryCode :: SPPLocale + + -- | The name, e.g. "English (United States)" + , _sppLocaleListEntryName :: Text + + -- | The date and time of the last update for this locale + , _sppLocaleListEntryLastUpdate :: Text + } + deriving (Show, Read, Eq) + +-- | Values represent the different ways that taxonomic groups may be grouped. +-- 'MerlinGrouping' puts like birds together, with falcons next to hawks. +-- 'EBirdGrouping' follows taxonomic order. +data SPPGrouping = MerlinGrouping | EBirdGrouping + deriving (Show, Read, Eq) + +-- | Values returned by the 'Data.EBird.API.TaxonomicGroupsAPI'. +data TaxonomicGroupListEntry = + TaxonomicGroupListEntry + { -- | Name of the group, e.g. \"Waterfowl\" + _taxonomicGroupListEntryName :: Text + + -- | Numeric value determining the location of this group in the list + , _taxonomicGroupListEntryOrder :: Integer + + -- | The bounds of the ordering, depending on the grouping + , _taxonomicGroupListEntryOrderBounds :: [(Integer, Integer)] + } + deriving (Show, Read, Eq) + +-- | Values returned by the 'Data.EBird.API.TaxonomyVersionsAPI'. +data TaxonomyVersionListEntry = + TaxonomyVersionListEntry + { _taxonomyVersionAuthorityVersion :: Double + , _taxonomyVersionLatest :: Bool + } + deriving (Show, Read, Eq) + +-- ** Optics for taxonomy-related types + +makeLenses ''SPPLocaleListEntry +makeFieldLabels ''SPPLocaleListEntry +makeLenses ''TaxonomicGroupListEntry +makeFieldLabels ''TaxonomicGroupListEntry +makeLenses ''TaxonomyVersionListEntry +makeFieldLabels ''TaxonomyVersionListEntry + +------------------------------------------------------------------------------- +-- aeson instances +------------------------------------------------------------------------------- + +-- | Explicit instance for compatibility with their field names +instance FromJSON Taxon where + parseJSON = withObject "Taxon" $ \v -> + Taxon + <$> v .: "sciName" + <*> v .: "comName" + <*> v .: "speciesCode" + <*> v .: "category" + <*> v .: "taxonOrder" + <*> v .: "bandingCodes" + <*> v .: "comNameCodes" + <*> v .: "sciNameCodes" + <*> v .: "order" + <*> v .:? "familyCode" + <*> v .:? "familyComName" + <*> v .:? "familySciName" + + +-- | Explicit instance for compatibility with their field names +instance ToJSON Taxon where + toJSON Taxon{..} = + object $ + [ "sciName" .= _taxonScientificName + , "comName" .= _taxonCommonName + , "speciesCode" .= _taxonSpeciesCode + , "category" .= _taxonCategory + , "taxonOrder" .= _taxonTaxonOrder + , "bandingCodes" .= _taxonBandingCodes + , "comNameCodes" .= _taxonCommonNameCodes + , "sciNameCodes" .= _taxonScientificNameCodes + , "order" .= _taxonOrder + , "familyComName" .= _taxonFamilyCommonName + , "familySciName" .= _taxonFamilyScientificName + ] + -- Fields that may or may not be included + <> [ "familyCode" .= c | Just c <- [_taxonFamilyCode]] + <> [ "familyComName" .= n | Just n <- [_taxonFamilyCommonName]] + <> [ "familySciName" .= n | Just n <- [_taxonFamilyScientificName]] + +instance FromJSON SpeciesCode where + parseJSON = withText "SpeciesCode" (pure . SpeciesCode) + +instance ToJSON SpeciesCode where + toJSON SpeciesCode{..} = String speciesCode + +instance FromJSON SpeciesCodes where + parseJSON = withArray "SpeciesCodes" $ + fmap (SpeciesCodes . toList) . traverse parseJSON + +instance ToJSON SpeciesCodes where + toJSON = Array . fromList . map toJSON . speciesCodes + +instance FromJSON TaxonomyCategory where + parseJSON = withText "TaxonomyCategory" $ \t -> + case parseOnly parseTaxonomyCategory t of + Left _ -> fail "failed to parse taxonomy category" + Right r -> return r + +instance ToJSON TaxonomyCategory where + toJSON = String . toEBirdString + +-- | Explicit instance for compatibility with their field names +instance FromJSON TaxonomyVersionListEntry where + parseJSON = withObject "TaxonomyVersionListEntry" $ \v -> + TaxonomyVersionListEntry + <$> v .: "authorityVer" + <*> v .: "latest" + +-- | Explicit instance for compatibility with their field names +instance ToJSON TaxonomyVersionListEntry where + toJSON TaxonomyVersionListEntry{..} = + object + [ "authorityVer" .= _taxonomyVersionAuthorityVersion + , "latest" .= _taxonomyVersionLatest + ] + +instance FromJSON SPPLocale where + parseJSON = withText "SPPLocale" $ \t -> + case parseOnly parseSPPLocale t of + Left _ -> fail $ "failed to parse spp locale: " <> Text.unpack t + Right r -> return r + +instance ToJSON SPPLocale where + toJSON = String . toEBirdString + +-- | Explicit instance for compatibility with their field names +instance FromJSON SPPLocaleListEntry where + parseJSON = withObject "SPPLocaleListEntry" $ \v -> + SPPLocaleListEntry + <$> v .: "code" + <*> v .: "name" + <*> v .: "lastUpdate" + +-- | Explicit instance for compatibility with their field names +instance ToJSON SPPLocaleListEntry where + toJSON SPPLocaleListEntry{..} = + object + [ "code" .= _sppLocaleListEntryCode + , "name" .= _sppLocaleListEntryName + , "lastUpdate" .= _sppLocaleListEntryLastUpdate + ] + +-- | Explicit instance for compatibility with their field names +instance FromJSON TaxonomicGroupListEntry where + parseJSON = withObject "TaxonomicGroupListEntry" $ \v -> + TaxonomicGroupListEntry + <$> v .: "groupName" + <*> v .: "groupOrder" + <*> v .: "taxonOrderBounds" + +-- | Explicit instance for compatibility with their field names +instance ToJSON TaxonomicGroupListEntry where + toJSON TaxonomicGroupListEntry{..} = + object + [ "groupName" .= _taxonomicGroupListEntryName + , "groupOrder" .= _taxonomicGroupListEntryOrder + , "taxonOrderBounds" .= _taxonomicGroupListEntryOrderBounds + ] + +------------------------------------------------------------------------------- +-- 'EBirdString' instances +------------------------------------------------------------------------------- + +-- | The eBird strings of the taxonomy categories are simply the lowercase +-- constructor names. +instance EBirdString TaxonomyCategory where + toEBirdString = + \case + Species -> "species" + ISSF -> "issf" + Spuh -> "spuh" + Slash -> "slash" + Hybrid -> "hybrid" + Intergrade -> "intergrade" + Domestic -> "domestic" + Form -> "form" + + fromEBirdString str = + parseOnly parseTaxonomyCategory str + & left (("Failed to parse TaxonomyCategory: " <>) . Text.pack) + +-- | The eBird string of a 'TaxonomyCategories' is the comma-separated list of +-- category strings. +instance EBirdString TaxonomyCategories where + toEBirdString (TaxonomyCategories (c :| cs)) = + Text.intercalate "," $ map toEBirdString (c : cs) + + fromEBirdString str = + parseOnly parseTaxonomyCategories str + & left (("Failed to parse TaxonomyCategories: " <>) . Text.pack) + +-- | The eBird string of a 'SpeciesCode' is simply the literal string +instance EBirdString SpeciesCode where + toEBirdString (SpeciesCode c) = c + + fromEBirdString str = + parseOnly parseSpeciesCode str + & left (("Failed to parse SpeciesCode: " <>) . Text.pack) + +-- | The eBird string of a 'SpeciesCodes' is simply the comma-separated +-- 'SpeciesCode's +instance EBirdString SpeciesCodes where + toEBirdString (SpeciesCodes cs) = Text.intercalate "," $ map toEBirdString cs + + fromEBirdString str = + parseOnly parseSpeciesCodes str + & left (("Failed to parse SpeciesCodes: " <>) . Text.pack) + +-- | The eBird strings of the species locales are simply the lowercase +-- constructor names. +instance EBirdString SPPLocale where + toEBirdString = + \case + Af -> "af" + Sq -> "sq" + Ar -> "ar" + Hy -> "hy" + As -> "as" + Ast -> "ast" + Az -> "az" + Eu -> "eu" + Bn -> "bn" + Bg -> "bg" + Ca -> "ca" + Zh -> "zh" + Zh_SIM -> "zh_SIM" + Ht_HT -> "ht_HT" + Hr -> "hr" + Cs -> "cs" + Da -> "da" + Nl -> "nl" + En -> "en" + En_AU -> "en_AU" + En_BD -> "en_BD" + En_HAW -> "en_HAW" + En_HBW -> "en_HBW" + En_IN -> "en_IN" + En_IOC -> "en_IOC" + En_KE -> "en_KE" + En_MY -> "en_MY" + En_NZ -> "en_NZ" + En_PH -> "en_PH" + En_ZA -> "en_ZA" + En_AE -> "en_AE" + En_UK -> "en_UK" + En_US -> "en_US" + Fo -> "fo" + Fi -> "fi" + Fr -> "fr" + Fr_AOU -> "fr_AOU" + Fr_FR -> "fr_FR" + Fr_CA -> "fr_CA" + Fr_GF -> "fr_GF" + Fr_GP -> "fr_GP" + Fr_HT -> "fr_HT" + Gl -> "gl" + De -> "de" + El -> "el" + Gu -> "gu" + He -> "he" + Hi -> "hi" + Hu -> "hu" + Is -> "is" + In -> "in" + It -> "it" + Ja -> "ja" + Ko -> "ko" + Lv -> "lv" + Lt -> "lt" + Ml -> "ml" + Mr -> "mr" + Mn -> "mn" + No -> "no" + Or -> "or" + Fa -> "fa" + Pl -> "pl" + Pt_AO -> "pt_AO" + Pt_RAA -> "pt_RAA" + Pt_Br -> "pt_BR" + Pt_RAM -> "pt_RAM" + Pt_PT -> "pt_PT" + Ro -> "ro" + Ru -> "ru" + Sr -> "sr" + Sk -> "sk" + Sl -> "sl" + Es -> "es" + Es_AR -> "es_AR" + Es_CL -> "es_CL" + Es_CR -> "es_CR" + Es_CU -> "es_CU" + Es_DO -> "es_DO" + Es_EC -> "es_EC" + Es_HN -> "es_HN" + Es_MX -> "es_MX" + Es_PA -> "es_PA" + Es_PY -> "es_PY" + Es_PE -> "es_PE" + Es_PR -> "es_PR" + Es_ES -> "es_ES" + Es_UY -> "es_UY" + Es_VE -> "es_VE" + Sv -> "sv" + Te -> "te" + Th -> "th" + Tr -> "tr" + Uk -> "uk" + + fromEBirdString str = + parseOnly parseSPPLocale str + & left (("Failed to parse SPPLocale: " <>) . Text.pack) + +-- | The eBird string of an 'SPPGrouping' is either "merlin" or "ebird" +instance EBirdString SPPGrouping where + toEBirdString = + \case + MerlinGrouping -> "merlin" + EBirdGrouping -> "ebird" + + fromEBirdString str = + parseOnly parseSPPGrouping str + & left (("Failed to parse SPPGrouping: " <>) . Text.pack) + +------------------------------------------------------------------------------- +-- IsString instances +------------------------------------------------------------------------------- + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString TaxonomyCategory where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString TaxonomyCategories where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString SpeciesCode where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString SpeciesCodes where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString SPPLocale where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString SPPGrouping where + fromString = unsafeFromEBirdString . Text.pack + +------------------------------------------------------------------------------- +-- * attoparsec parsers +------------------------------------------------------------------------------- + +-- | Parse an eBird species code, which we loosely assume is a string of one or +-- more alphanumeric characters. +parseSpeciesCode :: Parser SpeciesCode +parseSpeciesCode = SpeciesCode . Text.pack <$> many1 (satisfy isAlphaNum) + +-- | Parse a comma separated list of zero or more 'SpeciesCode's +parseSpeciesCodes :: Parser SpeciesCodes +parseSpeciesCodes = SpeciesCodes <$> parseSpeciesCode `sepBy` char ',' + +-- | Parse an eBird 'TaxonomyCategory'. +parseTaxonomyCategory :: Parser TaxonomyCategory +parseTaxonomyCategory = + choice + [ "species" $> Species + , "spuh" $> Spuh + , "issf" $> ISSF + , "slash" $> Slash + , "hybrid" $> Hybrid + , "intergrade" $> Intergrade + , "domestic" $> Domestic + , "form" $> Form + ] + where + _casesCovered :: TaxonomyCategory -> () + _casesCovered = + \case + Species -> () + Spuh -> () + ISSF -> () + Slash -> () + Hybrid -> () + Intergrade -> () + Domestic -> () + Form -> () + +-- | Parse a list of eBird API taxononomy categories. To avoid the partial +-- behavior of converting a 'sepBy1' result into a 'NonEmpty', we manually parse +-- the first category followed by an optional tail. +parseTaxonomyCategories :: Parser TaxonomyCategories +parseTaxonomyCategories = do + c <- parseTaxonomyCategory + cs <- atEnd >>= \case + True -> return [] + False -> do + skip (==',') + parseTaxonomyCategory `sepBy` char ',' + return $ TaxonomyCategories (c :| cs) + +-- | Parse an eBird 'SPPLocale'. +parseSPPLocale :: Parser SPPLocale +parseSPPLocale = + choice + [ "af" $> Af + , "sq" $> Sq + , "ar" $> Ar + , "hy" $> Hy + , "as" $> As + , "ast" $> Ast + , "az" $> Az + , "eu" $> Eu + , "bn" $> Bn + , "bg" $> Bg + , "ca" $> Ca + , "zh" $> Zh + , "zh_SIM" $> Zh_SIM + , "ht_HT" $> Ht_HT + , "hr" $> Hr + , "cs" $> Cs + , "da" $> Da + , "nl" $> Nl + , "en" $> En + , "en_AU" $> En_AU + , "en_BD" $> En_BD + , "en_HAW" $> En_HAW + , "en_HBW" $> En_HBW + , "en_IN" $> En_IN + , "en_IOC" $> En_IOC + , "en_KE" $> En_KE + , "en_MY" $> En_MY + , "en_NZ" $> En_NZ + , "en_PH" $> En_PH + , "en_ZA" $> En_ZA + , "en_AE" $> En_AE + , "en_UK" $> En_UK + , "en_US" $> En_US + , "fo" $> Fo + , "fi" $> Fi + , "fr" $> Fr + , "fr_AOU" $> Fr_AOU + , "fr_FR" $> Fr_FR + , "fr_CA" $> Fr_CA + , "fr_GF" $> Fr_GF + , "fr_GP" $> Fr_GP + , "fr_HT" $> Fr_HT + , "gl" $> Gl + , "de" $> De + , "el" $> El + , "gu" $> Gu + , "he" $> He + , "hi" $> Hi + , "hu" $> Hu + , "is" $> Is + , "in" $> In + , "it" $> It + , "ja" $> Ja + , "ko" $> Ko + , "lv" $> Lv + , "lt" $> Lt + , "ml" $> Ml + , "mr" $> Mr + , "mn" $> Mn + , "no" $> No + , "or" $> Or + , "fa" $> Fa + , "pl" $> Pl + , "pt_AO" $> Pt_AO + , "pt_RAA" $> Pt_RAA + , "pt_BR" $> Pt_Br + , "pt_RAM" $> Pt_RAM + , "pt_PT" $> Pt_PT + , "ro" $> Ro + , "ru" $> Ru + , "sr" $> Sr + , "sk" $> Sk + , "sl" $> Sl + , "es" $> Es + , "es_AR" $> Es_AR + , "es_CL" $> Es_CL + , "es_CR" $> Es_CR + , "es_CU" $> Es_CU + , "es_DO" $> Es_DO + , "es_EC" $> Es_EC + , "es_HN" $> Es_HN + , "es_MX" $> Es_MX + , "es_PA" $> Es_PA + , "es_PY" $> Es_PY + , "es_PE" $> Es_PE + , "es_PR" $> Es_PR + , "es_ES" $> Es_ES + , "es_UY" $> Es_UY + , "es_VE" $> Es_VE + , "sv" $> Sv + , "te" $> Te + , "th" $> Th + , "tr" $> Tr + , "uk" $> Uk + ] + where + _casesCovered :: SPPLocale -> () + _casesCovered = + \case + Af -> () + Sq -> () + Ar -> () + Hy -> () + As -> () + Ast -> () + Az -> () + Eu -> () + Bn -> () + Bg -> () + Ca -> () + Zh -> () + Zh_SIM -> () + Ht_HT -> () + Hr -> () + Cs -> () + Da -> () + Nl -> () + En -> () + En_AU -> () + En_BD -> () + En_HAW -> () + En_HBW -> () + En_IN -> () + En_IOC -> () + En_KE -> () + En_MY -> () + En_NZ -> () + En_PH -> () + En_ZA -> () + En_AE -> () + En_UK -> () + En_US -> () + Fo -> () + Fi -> () + Fr -> () + Fr_AOU -> () + Fr_FR -> () + Fr_CA -> () + Fr_GF -> () + Fr_GP -> () + Fr_HT -> () + Gl -> () + De -> () + El -> () + Gu -> () + He -> () + Hi -> () + Hu -> () + Is -> () + In -> () + It -> () + Ja -> () + Ko -> () + Lv -> () + Lt -> () + Ml -> () + Mr -> () + Mn -> () + No -> () + Or -> () + Fa -> () + Pl -> () + Pt_AO -> () + Pt_RAA -> () + Pt_Br -> () + Pt_RAM -> () + Pt_PT -> () + Ro -> () + Ru -> () + Sr -> () + Sk -> () + Sl -> () + Es -> () + Es_AR -> () + Es_CL -> () + Es_CR -> () + Es_CU -> () + Es_DO -> () + Es_EC -> () + Es_HN -> () + Es_MX -> () + Es_PA -> () + Es_PY -> () + Es_PE -> () + Es_PR -> () + Es_ES -> () + Es_UY -> () + Es_VE -> () + Sv -> () + Te -> () + Th -> () + Tr -> () + Uk -> () + +-- | Parse an eBird 'SPPGrouping'. +parseSPPGrouping :: Parser SPPGrouping +parseSPPGrouping = + choice + [ "merlin" $> MerlinGrouping + , "ebird" $> EBirdGrouping + ] + where + _casesCovered :: SPPGrouping -> () + _casesCovered = + \case + MerlinGrouping -> () + EBirdGrouping -> () + +------------------------------------------------------------------------------- +-- 'ToHttpApiData' instances +------------------------------------------------------------------------------- + +instance ToHttpApiData SpeciesCode where + toUrlPiece = toEBirdString + +instance ToHttpApiData SpeciesCodes where + toUrlPiece = Text.intercalate "," . map toEBirdString . speciesCodes + +instance ToHttpApiData TaxonomyCategories where + toUrlPiece = toEBirdString + +instance ToHttpApiData SPPLocale where + toUrlPiece = toEBirdString + +instance ToHttpApiData SPPGrouping where + toUrlPiece = toEBirdString diff --git a/src/Data/EBird/API/Util/Time.hs b/src/Data/EBird/API/Util/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/EBird/API/Util/Time.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | +-- Module : Data.EBird.API.Util.Time +-- Copyright : (c) 2023 Finley McIlwaine +-- License : MIT (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Utilities for parsing and printing dates and times that the eBird API +-- provides. + +module Data.EBird.API.Util.Time ( + -- * Date and time types + EBirdDate(..) + , EBirdTime(..) + , EBirdDateTime(..) + + -- * Conversions + , eBirdDateToGregorian + + -- * attoparsec parsers + , parseEBirdDate + , parseEBirdTime + , parseEBirdDateTime + ) where + +import Control.Applicative +import Control.Arrow +import Data.Aeson +import Data.Attoparsec.Text +import Data.Attoparsec.Time +import Data.Function +import Data.String +import Data.Text qualified as Text +import Data.Time + +import Data.EBird.API.EBirdString + +------------------------------------------------------------------------------- +-- Date and time types +------------------------------------------------------------------------------- + +-- | An 'EBirdDate' is simply a 'Day'. +newtype EBirdDate = EBirdDate { eBirdDate :: Day } + deriving (Show, Read, Eq, Ord) + deriving newtype (Enum) + +-- | Since times that come from the eBird API are not provided with a time zone, +-- an 'EBirdTime' is simply a 'TimeOfDay'. Since eBird times are only provided +-- up to the minute, the 'todSec' value will always be 0. +newtype EBirdTime = EBirdTime { eBirdTime :: TimeOfDay } + deriving (Show, Read, Eq, Ord) + +-- | Dates and times that come from the eBird API are not provided with a time +-- zone. All we can do is track the 'Data.Time.Day' and 'Data.Time.TimeOfDay' +-- with a 'Data.Time.LocalTime'. Comparison of, for example, +-- 'Data.EBird.API.Observation's that happened in different time zones must therefore +-- be done carefully. +newtype EBirdDateTime = EBirdDateTime { eBirdDateTime :: LocalTime } + deriving (Show, Read, Eq, Ord) + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +-- | Convert an 'EBirdDate' to a gregorian representation. The first element is +-- the year, the second is the month in the year (1 - 12), and the third is the +-- day in the month. +eBirdDateToGregorian :: EBirdDate -> (Integer, Integer, Integer) +eBirdDateToGregorian EBirdDate{..} = + (y, fromIntegral m, fromIntegral d) + where + (y, m, d) = toGregorian eBirdDate + +------------------------------------------------------------------------------- +-- aeson instances +------------------------------------------------------------------------------- + +instance FromJSON EBirdDate where + parseJSON = withText "EBirdDate" $ \t -> + case parseOnly parseEBirdDate t of + Left _ -> fail "failed to parse eBird date" + Right r -> return r + +instance ToJSON EBirdDate where + toJSON = String . toEBirdString + +instance FromJSON EBirdTime where + parseJSON = withText "EBirdTime" $ \t -> + case parseOnly parseEBirdTime t of + Left _ -> fail "failed to parse eBird time" + Right r -> return r + +instance ToJSON EBirdTime where + toJSON = String . toEBirdString + +instance FromJSON EBirdDateTime where + parseJSON = withText "EBirdDateTime" $ \t -> + case parseOnly parseEBirdDateTime t of + Left _ -> fail "failed to parse eBird datetime" + Right r -> return r + +instance ToJSON EBirdDateTime where + toJSON = String . toEBirdString + +------------------------------------------------------------------------------- +-- EBirdString instances +------------------------------------------------------------------------------- + +-- | eBird dates are formatted as YYYY-MM-DD, with 0 padding where necessary. +instance EBirdString EBirdDate where + toEBirdString = + Text.pack . formatTime defaultTimeLocale "%04Y-%02m-%02d" . eBirdDate + + fromEBirdString str = + parseOnly parseEBirdDate str + & left (("Failed to parse EBirdDate: " <>) . Text.pack) + +-- | eBird times are formatted as HH:MM, with 0 padding where necessary. +instance EBirdString EBirdTime where + toEBirdString = + Text.pack . formatTime defaultTimeLocale "%02H:%02M" . eBirdTime + + fromEBirdString str = + parseOnly parseEBirdTime str + & left (("Failed to parse EBirdTime: " <>) . Text.pack) + +-- | eBird datetimes are formatted as YYYY-MM-DD HH:MM, with 0 padding where +-- necessary. +instance EBirdString EBirdDateTime where + toEBirdString = + Text.pack + . formatTime defaultTimeLocale "%04Y-%02m-%02d %02H:%02M" + . eBirdDateTime + + fromEBirdString str = + parseOnly parseEBirdDateTime str + & left (("Failed to parse EBirdDateTime: " <>) . Text.pack) + +------------------------------------------------------------------------------- +-- IsString instances +------------------------------------------------------------------------------- + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString EBirdDate where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString EBirdTime where + fromString = unsafeFromEBirdString . Text.pack + +-- | Use this instance carefully! It throws runtime exceptions if the string is +-- malformatted. +instance IsString EBirdDateTime where + fromString = unsafeFromEBirdString . Text.pack + +------------------------------------------------------------------------------- +-- attoparsec parsers +------------------------------------------------------------------------------- + +-- | Parse an eBird date. Most eBird dates are formatted as YYYY-MM-DD, but the +-- 'Data.EBird.API.ChecklistFeedAPI' gives dates in a format like "19 Jul 2023". So, +-- we try parsing the first format using 'day', and then use a custom +-- 'parseTimeM' format for the latter format if that fails. +parseEBirdDate :: Parser EBirdDate +parseEBirdDate = tryDay <|> tryParseTimeM + where + tryDay :: Parser EBirdDate + tryDay = EBirdDate <$> day + + tryParseTimeM :: Parser EBirdDate + tryParseTimeM = do + input <- takeText + d <- parseTimeM + False + defaultTimeLocale + "%e %b %Y" + (Text.unpack input) + return (EBirdDate d) + +-- | Parse an eBird time (just uses 'timeOfDay'). +parseEBirdTime :: Parser EBirdTime +parseEBirdTime = EBirdTime <$> timeOfDay + +-- | Parse an eBird datetime (just uses 'localTime'). +parseEBirdDateTime :: Parser EBirdDateTime +parseEBirdDateTime = EBirdDateTime <$> localTime