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
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
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
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