geojson-types (empty) → 0.1
raw patch · 8 files changed
+992/−0 lines, 8 filesdep +aesondep +basedep +bsonsetup-changed
Dependencies added: aeson, base, bson, lens, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- geojson-types.cabal +88/−0
- src/Data/GeoJSON.hs +11/−0
- src/Data/GeoJSON/Classes.hs +21/−0
- src/Data/GeoJSON/Features.hs +250/−0
- src/Data/GeoJSON/Intern.hs +38/−0
- src/Data/GeoJSON/Objects.hs +552/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ geojson-types.cabal view
@@ -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 <mbarenh@alios.org>+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+
+ src/Data/GeoJSON.hs view
@@ -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++
+ src/Data/GeoJSON/Classes.hs view
@@ -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 <mbarenh@alios.org>+-- 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)
+ src/Data/GeoJSON/Features.hs view
@@ -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 <mbarenh@alios.org>+-- 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++++
+ src/Data/GeoJSON/Intern.hs view
@@ -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
+ src/Data/GeoJSON/Objects.hs view
@@ -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 <mbarenh@alios.org>+-- 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: <http://geojson.org/geojson-spec.html#positions> +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: <http://geojson.org/geojson-spec.html#point>+data Point++_Point :: Iso' (Position t) (GeoJSON Point t)+_Point = iso Point (\(Point p) -> p)+++-- | see also: <http://geojson.org/geojson-spec.html#multipoint>+data MultiPoint++_MultiPoint :: Iso' [Position t] (GeoJSON MultiPoint t)+_MultiPoint = iso MultiPoint (\(MultiPoint ps) -> ps)+++-- | see also: <http://geojson.org/geojson-spec.html#linestring>+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: <http://geojson.org/geojson-spec.html#linestring>+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 +