diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Markus Barenhoff + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Markus Barenhoff nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/geojson-types.cabal b/geojson-types.cabal new file mode 100644 --- /dev/null +++ b/geojson-types.cabal @@ -0,0 +1,88 @@ +name: geojson-types +version: 0.1 +synopsis: GeoJSON data types including JSON/BSON conversion. +homepage: https://github.com/alios/geosjon-types +bug-reports: https://github.com/alios/geosjon-types/issues +license: BSD3 +license-file: LICENSE +author: Markus Barenhoff +maintainer: Markus Barenhoff +copyright: Copyright (c) 2016 Markus Barenhoff +category: Data +build-type: Simple +stability: provisional +tested-with: GHC == 7.10.3 +cabal-version: >=1.10 + +description: + Provides data types, lens operators and (de)serialization + of GeoJSON data to/from JSON and BSON using aeson and bson. + . + This library uses a the lens library a lot. It provides + 'Iso' / 'Prism' to convert from and to GeoJSON objects. + . + /e.g./ to convert a latitude/longitude given as a pair of + 'Double' to a 'Position', use the '_Position' 'Iso' as a + 'Getter' on that pair: + . + > _Position :: BaseType t => (t, t) -> Position t + > + > pos :: Position Double + > pos = (57.324, 7.2342) ^. _Position + . + to then convert it to a 'Point' object use '_Point': + . + > _Point :: Iso' (Position t) (GeoJSON Point t) + > + > p :: GeoJSON Point Double + > p = pos ^. _Point + > + > ps :: GeoJSON MultiPoint Double + > ps = [p,p,p,p] ^. _MultiPoint + . + The library also provides type classes for working polymorphic + over user defined data types. + . + /e.g./ for a data type: + . + > data Location = + > Location { + > locationName :: String, + > locationLat :: Double, + > locationLon :: Double + > } + . + one can implement the type class 'HasGeoJSON' to provide a + 'Getter' to a any GeoJSON object. In this example a 'Point'. + . + > instance HasGeoJSON Point Double Location where + > geoJSON = to $ \loc -> + > (locationLat loc, locationLon loc) ^. _Position . _Point + + + + +library + exposed-modules: Data.GeoJSON, + Data.GeoJSON.Objects, + Data.GeoJSON.Features, + Data.GeoJSON.Classes + other-modules: Data.GeoJSON.Intern + other-extensions: FlexibleInstances, + TypeSynonymInstances, + GADTs, + OverloadedStrings, + FunctionalDependencies, + MultiParamTypeClasses, + FlexibleContexts, + ConstraintKinds, + RankNTypes, + TypeFamilies + build-depends: base >=4.8 && <4.9, + lens >=4.14, + aeson >=0.11, + bson >=0.3, + text >=1.2 + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/src/Data/GeoJSON.hs b/src/Data/GeoJSON.hs new file mode 100644 --- /dev/null +++ b/src/Data/GeoJSON.hs @@ -0,0 +1,11 @@ +module Data.GeoJSON + ( module Data.GeoJSON.Objects, + module Data.GeoJSON.Features, + module Data.GeoJSON.Classes + ) where + +import Data.GeoJSON.Objects +import Data.GeoJSON.Features +import Data.GeoJSON.Classes + + diff --git a/src/Data/GeoJSON/Classes.hs b/src/Data/GeoJSON/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Data/GeoJSON/Classes.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.GeoJSON.Classes +-- Copyright : (C) 2016 Markus Barenhoff +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Markus Barenhoff +-- Stability : provisional +-- Portability : MultiParamTypeClasses, FunctionalDependencies +-- +---------------------------------------------------------------------------- +module Data.GeoJSON.Classes + ( HasGeoJSON(..) + ) where + +import Control.Lens.Getter +import Data.GeoJSON.Objects + +class (GeoJSONObject a, BaseType t) => HasGeoJSON a t b | b -> t, b -> a where + geoJSON :: Getter b (GeoJSON a t) diff --git a/src/Data/GeoJSON/Features.hs b/src/Data/GeoJSON/Features.hs new file mode 100644 --- /dev/null +++ b/src/Data/GeoJSON/Features.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.GeoJSON.Features +-- Copyright : (C) 2016 Markus Barenhoff +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Markus Barenhoff +-- Stability : provisional +-- Portability : FunctionalDependencies, +-- TypeFamilies, +-- GADTs +-- RankNTypes +-- +---------------------------------------------------------------------------- +module Data.GeoJSON.Features + ( Feature, FeatureJSON, _FeatureJSON, FeatureBSON, _FeatureBSON + , FeatureCollection, fcZero, fcNew, fcInsert + ) where + +import Data.Maybe (fromMaybe, catMaybes) +import Control.Lens.Prism +import Control.Lens.Fold +import Control.Lens.Getter +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (toJSON, parseJSON, (.=), (.:), (.:?)) +import Data.Bson (Field(..), cast', val) +import qualified Data.Bson as Bson +import Data.Text (Text) +import qualified Data.Text as T +import Data.Proxy +import Control.Lens.Iso + +import Data.GeoJSON.Objects +import Data.GeoJSON.Intern + + +-- +-- Feature +-- +class FeatureType v where + toFeatureType :: (GeoJSONObject a, BaseType t) => Feature v a t -> v + +data Feature v a t where + Feature :: (GeoJSONObject a, BaseType t) => + GeoJSON a t -> Maybe v -> v -> Feature v a t + + +_FeatureJSON :: + (GeoJSONObject a, BaseType t) => + Iso' (GeoJSON a t, Maybe Aeson.Value, Aeson.Value) (FeatureJSON a t) +_FeatureJSON = _Feature + +_FeatureBSON :: + (GeoJSONObject a, BaseType t) => + Iso' (GeoJSON a t, Maybe Bson.Value, Bson.Value) (FeatureBSON a t) +_FeatureBSON = _Feature + +_Feature :: + (GeoJSONObject a, BaseType t) => Iso' (GeoJSON a t, Maybe v, v) (Feature v a t) +_Feature = iso (\(a, i, ps) -> Feature a i ps) (\(Feature a i ps) -> (a, i, ps)) + + +instance BaseType t => HasFlatCoordinates (Feature v a t) t where + flatCoordinates = to $ \(Feature a _ _) -> a ^. flatCoordinates + +type FeatureJSON = Feature Aeson.Value + +instance FeatureType Aeson.Value where + toFeatureType = toJSON + +instance (GeoJSONObject a, BaseType t) => Eq (FeatureJSON a t) where + a == b = toJSON a == toJSON b + +instance (GeoJSONObject a, BaseType t) => Show (FeatureJSON a t) where + show = show . toJSON + +instance (GeoJSONObject a, BaseType t) => Aeson.ToJSON (FeatureJSON a t) where + toJSON (Feature g mid props) = Aeson.object $ [ + typeT .= featureT, + geometryT .= g, + propertiesT .= props + ] ++ _id + where + _id = case mid of + Nothing -> [] + Just a -> [ idT .= a ] + +instance (GeoJSONObject a, BaseType t) => Aeson.FromJSON (FeatureJSON a t) where + parseJSON = Aeson.withObject featureT $ \o -> do + t <- o .: typeT + if t /= featureT then fail $ "expected type " ++ show typeT + else Feature <$> o .: geometryT <*> o .:? idT <*> o.: propertiesT + +type FeatureBSON = Feature Bson.Value + +instance FeatureType Bson.Value where + toFeatureType = val + + +instance (GeoJSONObject a, BaseType t) => Eq (FeatureBSON a t) where + a == b = val a == val b + +instance (GeoJSONObject a, BaseType t) => Show (FeatureBSON a t) where + show = show . val + +instance (GeoJSONObject a, BaseType t) => Bson.Val (FeatureBSON a t) where + val (Feature g mid props) = Bson.Doc $ [ + typeT := val featureT, + geometryT := val g, + propertiesT := props + ] ++ maybe [] (\_id -> [idBsonT := _id]) mid + cast' (Bson.Doc d) = Feature + <$> Bson.lookup geometryT d + <*> pure (Bson.look idBsonT d) + <*> Bson.look propertiesT d + + +-- +-- Feature Collection +-- + +data FeatureCollection v t where + FCZero :: FeatureCollection v t + FCCons :: + (GeoJSONObject a, BaseType t) => + Feature v a t -> FeatureCollection v t -> FeatureCollection v t + +type FeatureCollectionJSON = FeatureCollection Aeson.Value + +fcZero :: FeatureCollection v t +fcZero = FCZero + +fcInsert :: (GeoJSONObject a, BaseType t) => FeatureCollection v t -> Feature v a t -> FeatureCollection v t +fcInsert = flip FCCons + +fcNew :: (GeoJSONObject a, BaseType t) => Feature v a t -> FeatureCollection v t +fcNew = fcInsert FCZero + +instance BaseType t => HasFlatCoordinates (FeatureCollection v t) t where + flatCoordinates = to flatCoordinates' + where flatCoordinates' FCZero = mempty + flatCoordinates' (FCCons x xs) = + mappend (x ^. flatCoordinates) (xs ^. flatCoordinates) + + +instance (BaseType t) => Eq (FeatureCollectionJSON t) where + a == b = toJSON a == toJSON b + +instance (BaseType t) => Show (FeatureCollectionJSON t) where + show = show . toJSON + +instance (BaseType t) => Aeson.ToJSON (FeatureCollectionJSON t) where + toJSON fc = Aeson.object [ + typeT .= featureCollectionT, + featuresT .= toValue fc + ] + where toValue FCZero = [] + toValue (FCCons x xs) = toFeatureType x : toValue xs + +instance BaseType t => Aeson.FromJSON (FeatureCollectionJSON t) where + parseJSON = Aeson.withObject featureCollectionT $ \o -> do + t <- o .: typeT + if t /= featureCollectionT then fail $ "expected type " ++ featureCollectionT + else withNamedArray (T.unpack featuresT) o $ \a -> do + fs <- sequence $ parseFC <$> a + return $ foldr ($) FCZero fs + +type FeatureCollectionBSON = FeatureCollection Bson.Value + +instance (BaseType t) => Eq (FeatureCollectionBSON t) where + a == b = val a == val b + +instance (BaseType t) => Show (FeatureCollectionBSON t) where + show = show . val + +instance BaseType t => Bson.Val (FeatureCollectionBSON t) where + val fc = Bson.Doc [ + typeT := val featureCollectionT, + featuresT := val (toValue fc) + ] + where toValue FCZero = [] + toValue (FCCons x xs) = toFeatureType x : toValue xs + cast' (Bson.Doc d) = do + t <- Bson.lookup typeT d + if t /= featureCollectionT then Nothing + else case Bson.look featuresT d of + (Just (Bson.Array a)) -> do + fs <- sequence $ castFC <$> a + return $ foldr ($) FCZero fs + _ -> Nothing + cast' _ = Nothing + + + +-- +-- helpers +-- + +castFC :: + (BaseType t, Monad m) => Bson.Value -> + m (FeatureCollectionBSON t -> FeatureCollectionBSON t) +castFC v = case catMaybes ps of + (x:_) -> return x + _ -> fail "unable to cast BSON FeatureCollection" + where ps = [ + parseFCByType (Proxy :: Proxy Point) v, + parseFCByType (Proxy :: Proxy MultiPoint) v, + parseFCByType (Proxy :: Proxy LineString) v, + parseFCByType (Proxy :: Proxy LinearRing) v, + parseFCByType (Proxy :: Proxy MultiLineString) v, + parseFCByType (Proxy :: Proxy Polygon) v, + parseFCByType (Proxy :: Proxy MultiPolygon) v, + parseFCByType (Proxy :: Proxy Collection) v + ] + parseFCByType p = fmap FCCons . parseFeatureByType p + parseFeatureByType :: (GeoJSONObject a, BaseType t) => + Proxy a -> Bson.Value -> Maybe (FeatureBSON a t) + parseFeatureByType _ = cast' + + +parseFC :: + (BaseType t, Monad m) => Aeson.Value -> + m (FeatureCollectionJSON t -> FeatureCollectionJSON t) +parseFC v = case catMaybes ps of + (x:_) -> return x + _ -> fail "unable to parse JSON FeatureCollection" + where ps = [ + parseFCByType (Proxy :: Proxy Point) v, + parseFCByType (Proxy :: Proxy MultiPoint) v, + parseFCByType (Proxy :: Proxy LineString) v, + parseFCByType (Proxy :: Proxy LinearRing) v, + parseFCByType (Proxy :: Proxy MultiLineString) v, + parseFCByType (Proxy :: Proxy Polygon) v, + parseFCByType (Proxy :: Proxy MultiPolygon) v, + parseFCByType (Proxy :: Proxy Collection) v + ] + parseFCByType p = fmap FCCons . parseFeatureByType p + parseFeatureByType :: (GeoJSONObject a, BaseType t) => + Proxy a -> Aeson.Value -> Maybe (FeatureJSON a t) + parseFeatureByType _ = Aeson.parseMaybe parseJSON + + + + diff --git a/src/Data/GeoJSON/Intern.hs b/src/Data/GeoJSON/Intern.hs new file mode 100644 --- /dev/null +++ b/src/Data/GeoJSON/Intern.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.GeoJSON.Intern where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Aeson (toJSON, parseJSON, (.=), (.:), (.:?)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +typeT, coordinatesT, geometryT, idT, idBsonT, propertiesT, featuresT :: Text +typeT = "type" +geometriesT = "geometries" +geometryT = "geometry" +coordinatesT = "coordinates" +propertiesT = "properties" +idT = "id" +idBsonT = "_id" +featuresT = "features" + +pointT, multiPointT, lineStringT, linearRingT, + multiLineStringT, polygonT, multiPolygonT, + geometryCollectionT, featureT, featureCollectionT :: String +pointT = "Point" +multiPointT = "MultiPoint" +lineStringT = "LineString" +linearRingT = "LinearRing" +multiLineStringT = "MultiLineString" +polygonT = "Polygon" +multiPolygonT = "MultiPolygon" +geometryCollectionT = "GeometryCollection" +featureT = "Feature" +featureCollectionT = "FeatureCollection" + + +withNamedArray :: + String -> Aeson.Object -> (Aeson.Array -> Aeson.Parser a) -> Aeson.Parser a +withNamedArray n o p = (o .: T.pack n) >>= Aeson.withArray n p diff --git a/src/Data/GeoJSON/Objects.hs b/src/Data/GeoJSON/Objects.hs new file mode 100644 --- /dev/null +++ b/src/Data/GeoJSON/Objects.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.GeoJSON.Objects +-- Copyright : (C) 2016 Markus Barenhoff +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Markus Barenhoff +-- Stability : provisional +-- Portability : FunctionalDependencies, +-- TypeFamilies, +-- GADTs +-- RankNTypes +-- +---------------------------------------------------------------------------- +module Data.GeoJSON.Objects + ( -- * GeoJSON Objects + -- ** Position + Position, _Position, + -- ** Point + Point, _Point, + -- ** MultiPoint + MultiPoint, _MultiPoint, + -- ** Line String + LineString, _LineString, + -- ** Linear Ring + LinearRing, _LinearRing, + -- ** MultiLineString + MultiLineString, _MultiLineString, + -- ** Polygon + Polygon, _Polygon, + -- ** MultiPolygon + MultiPolygon, _MultiPolygon, + -- ** Collection + Collection, _GeometryCollection, + -- * Geometry Collection + GeometryCollection, newCollection, insert, + -- * Support types + HasFlatCoordinates(..), boundingBox, + GeoJSON, BaseType, GeoJSONObject + ) where + +import qualified Data.Text as T +import Control.Lens.Fold +import Control.Lens.Review +import Control.Lens.Prism +import Control.Lens.Iso +import Control.Lens.Getter +import Data.Maybe (catMaybes, fromMaybe) +import Data.Typeable (Typeable) +import Data.Aeson (toJSON, parseJSON, (.=), (.:)) +import qualified Data.Aeson.Types as Aeson +import Data.Bson (Field(..), cast', val) +import qualified Data.Bson as Bson +import Control.Monad +import Data.GeoJSON.Intern + +-- +-- BaseType +-- + +-- | type constraint for the base numeric type used in 'Position' +type BaseType t = + (Eq t, Ord t, Num t, Show t, Aeson.FromJSON t, Aeson.ToJSON t, Bson.Val t) + +-- +-- Bounding Box +-- + +-- | A bounding box is represented by a top-left/bottom-right +-- 'Position' pair. +type BoundingBox t = (Position t, Position t) + +-- | Represents datatypes which hold one or more 'Position' objects. +class BaseType t => HasFlatCoordinates a t | a -> t where + flatCoordinates :: Getter a [Position t] + +-- | calculate the bounding box of the the given object. +boundingBox :: (HasFlatCoordinates a t) => Getter a (BoundingBox t) +boundingBox = to $ calcBbox . view flatCoordinates + +-- +-- Position +-- + +-- | Data type to hold a basic x/y lat/lon value. +-- . +-- see also: +data Position t where + Position :: BaseType t => (t, t) -> Position t + +-- | 'Iso' from/to 'Position' +_Position :: BaseType t => Iso' (t, t) (Position t) +_Position = iso toPos fromPos + where fromPos :: BaseType t => Position t -> (t, t) + fromPos (Position p) = p + toPos (lat, lon ) = Position (lat, lon) + +instance (Eq t) => Eq (Position t) where + (Position a) == (Position b) = a == b + +instance BaseType t => Show (Position t) where + show = show . toJSON + +instance BaseType t => Aeson.ToJSON (Position t) where + toJSON = toJSON . view (from _Position) + +instance BaseType t => Aeson.FromJSON (Position t) where + parseJSON = fmap (view _Position) . parseJSON + + +instance BaseType t => Bson.Val (Position t) where + val a = let (lat, lon) = view (from _Position) a + in val [lat,lon] + cast' (Bson.Array [lat', lon']) = do + ll <- (,) <$> cast' lat' <*> cast' lon' + return $ ll ^. _Position + cast' _ = Nothing + +instance (BaseType t) => HasFlatCoordinates (Position t) t where + flatCoordinates = to pure + + +-- +-- GeoJSON Objects +-- + + +-- | see also: +data Point + +_Point :: Iso' (Position t) (GeoJSON Point t) +_Point = iso Point (\(Point p) -> p) + + +-- | see also: +data MultiPoint + +_MultiPoint :: Iso' [Position t] (GeoJSON MultiPoint t) +_MultiPoint = iso MultiPoint (\(MultiPoint ps) -> ps) + + +-- | see also: +data LineString + +_LineString :: Prism' [Position t] (GeoJSON LineString t) +_LineString = prism' (\(LineString ps) -> ps) toLS + where toLS ls@(_ : _ : _) = pure $ LineString ls + toLS _ = Nothing + + +-- | see also: +data LinearRing + +_LinearRing :: BaseType t => Prism' (GeoJSON LineString t) (GeoJSON LinearRing t) +_LinearRing = prism' lrTols lsTolr + where lrTols :: GeoJSON LinearRing t -> GeoJSON LineString t + lrTols (LinearRing ls) = ls + lsTolr :: BaseType t => GeoJSON LineString t -> Maybe (GeoJSON LinearRing t) + lsTolr ls = + let ps = review _LineString ls + in if (head ps == last ps) && (length ps >= 4) + then pure $ LinearRing ls + else Nothing + + +-- | see also: http://geojson.org/geojson-spec.html#multilinestring +data MultiLineString + +_MultiLineString :: Iso' [GeoJSON LineString t] (GeoJSON MultiLineString t) +_MultiLineString = iso MultiLineString (\(MultiLineString lss) -> lss) + + +-- | see also: http://geojson.org/geojson-spec.html#polygon +data Polygon + +_Polygon :: Iso' [GeoJSON LinearRing t] (GeoJSON Polygon t) +_Polygon = iso Polygon (\(Polygon lr) -> lr) + +-- | see also: http://geojson.org/geojson-spec.html#multipolygon +data MultiPolygon + +_MultiPolygon :: Iso' [GeoJSON Polygon t] (GeoJSON MultiPolygon t) +_MultiPolygon = iso MultiPolygon (\(MultiPolygon lr) -> lr) + +-- | see also: http://geojson.org/geojson-spec.html#geometry-collection +data Collection + +_GeometryCollection :: Iso' (GeometryCollection t) (GeoJSON Collection t) +_GeometryCollection = iso GeometryCollection (\(GeometryCollection t) -> t) + + +-- +-- GeoJSON +-- + +data GeoJSON a t where + Point :: Position t -> GeoJSON Point t + MultiPoint :: [Position t] -> GeoJSON MultiPoint t + LineString :: [Position t] -> GeoJSON LineString t + LinearRing :: GeoJSON LineString t -> GeoJSON LinearRing t + MultiLineString :: [GeoJSON LineString t] -> GeoJSON MultiLineString t + Polygon :: [GeoJSON LinearRing t] -> GeoJSON Polygon t + MultiPolygon :: [GeoJSON Polygon t] -> GeoJSON MultiPolygon t + GeometryCollection :: GeometryCollection t -> GeoJSON Collection t + deriving (Typeable) + +instance (GeoJSONObject a, BaseType t) => Eq (GeoJSON a t) where + a == b = toJSON a == toJSON b + +instance (GeoJSONObject a, BaseType t) => Show (GeoJSON a t) where + show = show . toJSON + +instance (GeoJSONObject a, BaseType t) => Aeson.ToJSON (GeoJSON a t) where + toJSON p@(Point _) = mkObject pointT p + toJSON p@(MultiPoint _) = mkObject multiPointT p + toJSON p@(LineString _) = mkObject lineStringT p + toJSON p@(LinearRing _) = mkObject linearRingT p + toJSON p@(MultiLineString _) = mkObject multiLineStringT p + toJSON p@(Polygon _) = mkObject polygonT p + toJSON p@(MultiPolygon _) = mkObject multiPolygonT p + toJSON p@(GeometryCollection c) = toJSON c + +instance (GeoJSONObject a, BaseType t) => Aeson.FromJSON (GeoJSON a t) where + parseJSON = parseGeoJSON + +instance (GeoJSONObject a, BaseType t) => Bson.Val (GeoJSON a t) where + val p@(Point _) = mkBsonObject pointT p + val p@(MultiPoint _) = mkBsonObject multiPointT p + val p@(LineString _) = mkBsonObject lineStringT p + val p@(LinearRing _) = mkBsonObject linearRingT p + val p@(MultiLineString _) = mkBsonObject multiLineStringT p + val p@(Polygon _) = mkBsonObject polygonT p + val p@(MultiPolygon _) = mkBsonObject multiPolygonT p + val p@(GeometryCollection c) = val c + cast' = castBson + +instance (GeoJSONObject a, BaseType t) => HasFlatCoordinates (GeoJSON a t) t where + flatCoordinates = flatCoordinatesGeoJSON + + +-- +-- GeometryCollection +-- + +data GeometryCollection t where + GCZero :: GeometryCollection t + GCCons :: GeoJSONObject a => + GeoJSON a t -> GeometryCollection t -> GeometryCollection t + deriving (Typeable) + +newCollection :: + (GeoJSONObject a) => GeoJSON a t -> GeometryCollection t +newCollection = insert GCZero + +insert :: + (GeoJSONObject a) => GeometryCollection t -> GeoJSON a t -> GeometryCollection t +insert = flip GCCons + +instance BaseType t => Eq (GeometryCollection t) where + a == b = toJSON a == toJSON b + +instance BaseType t => Show (GeometryCollection t) where + show = show . toJSON + +instance (BaseType t) => Aeson.ToJSON (GeometryCollection t) where + toJSON a = Aeson.object + [typeT .= geometryCollectionT, T.pack geometriesT .= toValue a] + where + toValue GCZero = [] + toValue (GCCons a as) = toJSON a : toValue as + +instance (BaseType t) => Aeson.FromJSON (GeometryCollection t) where + parseJSON = Aeson.withObject geometryCollectionT $ \o -> do + t <- o .: typeT + if t /= geometryCollectionT + then fail $ "unable read type : " ++ geometryCollectionT + else withNamedArray geometriesT o foldCollectionJSON + +instance (BaseType t) => Bson.Val (GeometryCollection t) where + val a = Bson.Doc + [ typeT := val geometryCollectionT + , T.pack geometriesT := Bson.Array (toValue a) + ] + where + toValue GCZero = [] + toValue (GCCons a as) = val a : toValue as + cast' (Bson.Doc d) = do + t <- Bson.lookup typeT d + if t /= geometryCollectionT then Nothing + else do + a <- Bson.look (T.pack geometriesT) d + case a of + Bson.Array a' -> foldCollectionBSON a' + _ -> Nothing + cast' _ = Nothing + +-- +-- GeoJSONObject +-- +class (Typeable a) => GeoJSONObject a where + type GeoJSONObjectType a t :: * + _GeoObject :: BaseType t => Prism' (GeoJSONObjectType a t) (GeoJSON a t) + parseGeoJSON :: BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON a t) + castBson :: BaseType t => Bson.Value -> Maybe (GeoJSON a t) + flatCoordinatesGeoJSON :: + (BaseType t) => Getter (GeoJSON a t) [Position t] + +instance GeoJSONObject Point where + type GeoJSONObjectType Point t = Position t + _GeoObject = prism' (view $ from _Point) (pure . view _Point) + castBson = castGeoBSON pointT + parseGeoJSON = parseGeoJSONbyName pointT + flatCoordinatesGeoJSON = to $ pure . view (from _Point) + +instance GeoJSONObject MultiPoint where + type GeoJSONObjectType MultiPoint t = [Position t] + _GeoObject = prism' (view $ from _MultiPoint) (pure . view _MultiPoint) + castBson = castGeoBSON multiPointT + parseGeoJSON = parseGeoJSONbyName multiPointT + flatCoordinatesGeoJSON = to $ view (from _MultiPoint) + +instance GeoJSONObject LineString where + type GeoJSONObjectType LineString t = [Position t] + _GeoObject = prism' (review _LineString) (preview _LineString) + castBson = castGeoBSON lineStringT + parseGeoJSON = parseGeoJSONbyName lineStringT + flatCoordinatesGeoJSON = to $ review _LineString + +instance GeoJSONObject LinearRing where + type GeoJSONObjectType LinearRing t = [Position t] + _GeoObject = prism' + (review _GeoObject . review _LinearRing) + (preview _LineString >=> preview _LinearRing ) + castBson = castGeoBSON linearRingT + parseGeoJSON = parseGeoJSONbyName linearRingT + flatCoordinatesGeoJSON = to $ view flatCoordinatesGeoJSON . review _LinearRing + +instance GeoJSONObject MultiLineString where + type GeoJSONObjectType MultiLineString t = [[Position t]] + _GeoObject = prism' + (traverseObjectsWithIso _MultiLineString) + (traverseGeoObjectsWithGetter _MultiLineString ) + castBson = castGeoBSON multiLineStringT + parseGeoJSON = parseGeoJSONbyName multiLineStringT + flatCoordinatesGeoJSON = to $ + mconcat . fmap (view flatCoordinatesGeoJSON) . view (from _MultiLineString) + +instance GeoJSONObject Polygon where + type GeoJSONObjectType Polygon t = [[Position t]] + _GeoObject = prism' + (traverseObjectsWithIso _Polygon) + (traverseGeoObjectsWithGetter _Polygon ) + castBson = castGeoBSON polygonT + parseGeoJSON = parseGeoJSONbyName polygonT + flatCoordinatesGeoJSON = to $ + mconcat . fmap (view flatCoordinatesGeoJSON) . review _Polygon + +instance GeoJSONObject MultiPolygon where + type GeoJSONObjectType MultiPolygon t = [[[Position t]]] + _GeoObject = prism' + (traverseObjectsWithIso _MultiPolygon) + (traverseGeoObjectsWithGetter _MultiPolygon ) + castBson = castGeoBSON multiPolygonT + parseGeoJSON = parseGeoJSONbyName multiPolygonT + flatCoordinatesGeoJSON = to $ + mconcat . fmap (view flatCoordinatesGeoJSON) . view (from _MultiPolygon) + +instance GeoJSONObject Collection where + type GeoJSONObjectType Collection t = GeometryCollection t + _GeoObject = prism' (view (from _GeometryCollection)) + (pure . view _GeometryCollection) + castBson = fmap (view _GeometryCollection) . cast' + parseGeoJSON = fmap (view _GeometryCollection) . parseJSON + flatCoordinatesGeoJSON = to $ colFlatPs . view (from _GeometryCollection) + where colFlatPs GCZero = mempty + colFlatPs (GCCons x xs) = + mappend (x ^. flatCoordinatesGeoJSON) (colFlatPs xs) + +-- +-- Helpers +-- + +calcBbox :: BaseType t => [Position t] -> BoundingBox t +calcBbox as = + let (xs, ys) = unzip . fmap (view (from _Position)) $ as + minc = (minimum xs, minimum ys) ^. _Position + maxc = (maximum xs, maximum ys) ^. _Position + in (minc, maxc) + + +mkObject :: (BaseType t, Aeson.ToJSON (GeoJSONObjectType a t), GeoJSONObject a) => + String -> GeoJSON a t -> Aeson.Value +mkObject t p = Aeson.object [typeT .= t, coordinatesT .= review _GeoObject p] + +mkBsonObject :: (BaseType t, Bson.Val (GeoJSONObjectType a t), GeoJSONObject a) => + String -> GeoJSON a t -> Bson.Value +mkBsonObject t p = Bson.Doc + [ typeT := val t + , coordinatesT := val (review _GeoObject p) + ] + + +foldCollectionJSON :: + (BaseType t, Functor f, Foldable f, Traversable f, Monad m) => + f Aeson.Value -> m (GeometryCollection t) +foldCollectionJSON a = case sequence . fmap parseGCCons $ a of + Nothing -> fail "unable to read GeometryCollcetion elements" + Just cs -> return . foldr ($) GCZero $ cs + +foldCollectionBSON :: + (BaseType t, Functor f, Foldable f, Traversable f, Monad m) => + f Bson.Value -> m (GeometryCollection t) +foldCollectionBSON a = case sequence . fmap castGCCons $ a of + Nothing -> fail "unable to read GeometryCollcetion elements" + Just cs -> return . foldr ($) GCZero $ cs + +parseGCCons :: + BaseType t => Aeson.Value -> Maybe (GeometryCollection t -> GeometryCollection t) +parseGCCons v = case parseGCCons' v of + (cc:_) -> pure cc + _ -> Nothing + +castGCCons :: + BaseType t => Bson.Value -> Maybe (GeometryCollection t -> GeometryCollection t) +castGCCons v = case castGCCons' v of + (cc:_) -> pure cc + _ -> Nothing + +parseGeoJSONbyName :: + (GeoJSONObject a, Aeson.FromJSON (GeoJSONObjectType a t), BaseType t) => + String -> Aeson.Value -> Aeson.Parser (GeoJSON a t) +parseGeoJSONbyName n = Aeson.withObject pointT $ \o -> do + t <- (o .: typeT) :: Aeson.Parser String + if t /= n then fail $ "unable to parse type " ++ n + else (o .: coordinatesT) >>= + maybe (fail $ "unable to parse coordinates of " ++ n) return . + preview _GeoObject + +castGeoBSON :: + (GeoJSONObject a, Bson.Val (GeoJSONObjectType a t), BaseType t) => + String -> Bson.Value -> Maybe (GeoJSON a t) +castGeoBSON n (Bson.Doc o) = do + t <- Bson.lookup typeT o + if t /= n then fail $ "unable to parse type " ++ n + else do + cs <- Bson.lookup coordinatesT o + preview _GeoObject cs +castGeoBSON _ _ = Nothing + +parseGCCons' :: + (BaseType t) => Aeson.Value -> [GeometryCollection t -> GeometryCollection t] +parseGCCons' v = catMaybes [Aeson.parseMaybe p v | p <- ps] + where ps = + [ fmap GCCons . parsePoint + , fmap GCCons . parseMultiPoint + , fmap GCCons . parseLineString + , fmap GCCons . parseLinearRing + , fmap GCCons . parseMultiLineString + , fmap GCCons . parsePolygon + , fmap GCCons . parseMultiPolygon + , fmap GCCons . parseCollection + ] + parsePoint :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON Point t) + parsePoint = parseGeoJSON + parseMultiPoint :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON MultiPoint t) + parseMultiPoint = parseGeoJSON + parseLineString :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON LineString t) + parseLineString = parseGeoJSON + parseLinearRing :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON LinearRing t) + parseLinearRing = parseGeoJSON + parseMultiLineString :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON MultiLineString t) + parseMultiLineString = parseGeoJSON + parsePolygon :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON Polygon t) + parsePolygon = parseGeoJSON + parseMultiPolygon :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON MultiPolygon t) + parseMultiPolygon = parseGeoJSON + parseCollection :: + BaseType t => Aeson.Value -> Aeson.Parser (GeoJSON Collection t) + parseCollection a = view _GeometryCollection <$> parseJSON a + + +castGCCons' :: + (BaseType t) => Bson.Value -> [GeometryCollection t -> GeometryCollection t] +castGCCons' v = catMaybes [p v | p <- ps] + where ps = + [ fmap GCCons . castPoint + , fmap GCCons . castMultiPoint + , fmap GCCons . castLineString + , fmap GCCons . castLinearRing + , fmap GCCons . castMultiLineString + , fmap GCCons . castPolygon + , fmap GCCons . castMultiPolygon + , fmap GCCons . castCollection + ] + castPoint :: + BaseType t => Bson.Value -> Maybe (GeoJSON Point t) + castPoint = castBson + castMultiPoint :: + BaseType t => Bson.Value -> Maybe (GeoJSON MultiPoint t) + castMultiPoint = castBson + castLineString :: + BaseType t => Bson.Value -> Maybe (GeoJSON LineString t) + castLineString = castBson + castLinearRing :: + BaseType t => Bson.Value -> Maybe (GeoJSON LinearRing t) + castLinearRing = castBson + castMultiLineString :: + BaseType t => Bson.Value -> Maybe (GeoJSON MultiLineString t) + castMultiLineString = castBson + castPolygon :: + BaseType t => Bson.Value -> Maybe (GeoJSON Polygon t) + castPolygon = castBson + castMultiPolygon :: + BaseType t => Bson.Value -> Maybe (GeoJSON MultiPolygon t) + castMultiPolygon = castBson + castCollection :: + BaseType t => Bson.Value -> Maybe (GeoJSON Collection t) + castCollection a = view _GeometryCollection <$> cast' a + +traverseObjectsWithIso :: + (BaseType t, GeoJSONObject b) => + Iso' [GeoJSON b t] (GeoJSON a t) -> GeoJSON a t -> [GeoJSONObjectType b t] +traverseObjectsWithIso i = fmap (review _GeoObject) <$> view (from i) + +traverseGeoObjects :: + (BaseType t, GeoJSONObject a, Traversable tt) => + tt (GeoJSONObjectType a t) -> Maybe (tt (GeoJSON a t)) +traverseGeoObjects = sequence . fmap (preview _GeoObject) + +traverseGeoObjectsWithGetter :: + (BaseType t, Traversable tt, GeoJSONObject a) => + Getting b (tt (GeoJSON a t)) b -> + tt (GeoJSONObjectType a t) -> + Maybe b +traverseGeoObjectsWithGetter g = fmap (view g) . traverseGeoObjects +