{-# LANGUAGE TemplateHaskell #-}

module Hasura.SQL.GeoJSON
  ( Position (..),
    Point (..),
    MultiPoint (..),
    LineString (..),
    LinearRing (..),
    MultiLineString (..),
    Polygon (..),
    MultiPolygon (..),
    Geometry (..),
    GeometryCollection (..),
    GeometryWithCRS (..),
  )
where

import Control.Monad
import Data.Aeson qualified as J
import Data.Aeson.Casing qualified as J
import Data.Aeson.TH qualified as J
import Data.Aeson.Types qualified as J
import Data.Vector qualified as V
import Hasura.Prelude

-- Positions

data Position
  = Position !Double !Double !(Maybe Double)
  deriving (Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
(Int -> Position -> ShowS)
-> (Position -> String) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show, Position -> Position -> Bool
(Position -> Position -> Bool)
-> (Position -> Position -> Bool) -> Eq Position
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq)

withParsedArray ::
  (J.FromJSON a) =>
  String ->
  (V.Vector a -> J.Parser b) ->
  J.Value ->
  J.Parser b
withParsedArray :: String -> (Vector a -> Parser b) -> Value -> Parser b
withParsedArray String
s Vector a -> Parser b
fn =
  String -> (Array -> Parser b) -> Value -> Parser b
forall a. String -> (Array -> Parser a) -> Value -> Parser a
J.withArray String
s ((Value -> Parser a) -> Array -> Parser (Vector a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser a
forall a. FromJSON a => Value -> Parser a
J.parseJSON (Array -> Parser (Vector a))
-> (Vector a -> Parser b) -> Array -> Parser b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Vector a -> Parser b
fn)

instance J.FromJSON Position where
  parseJSON :: Value -> Parser Position
parseJSON = String
-> (Vector Double -> Parser Position) -> Value -> Parser Position
forall a b.
FromJSON a =>
String -> (Vector a -> Parser b) -> Value -> Parser b
withParsedArray String
"Position" ((Vector Double -> Parser Position) -> Value -> Parser Position)
-> (Vector Double -> Parser Position) -> Value -> Parser Position
forall a b. (a -> b) -> a -> b
$ \Vector Double
arr ->
    if Vector Double -> Int
forall a. Vector a -> Int
V.length Vector Double
arr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
      then String -> Parser Position
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"A Position needs at least 2 elements"
      else -- here we are ignoring anything past 3 elements

        Position -> Parser Position
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Parser Position) -> Position -> Parser Position
forall a b. (a -> b) -> a -> b
$
          Double -> Double -> Maybe Double -> Position
Position
            (Vector Double
arr Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
0)
            (Vector Double
arr Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
1)
            (Vector Double
arr Vector Double -> Int -> Maybe Double
forall a. Vector a -> Int -> Maybe a
V.!? Int
2)

instance J.ToJSON Position where
  toJSON :: Position -> Value
toJSON (Position Double
a Double
b Maybe Double
c) =
    [Double] -> Value
forall a. ToJSON a => a -> Value
J.toJSON ([Double] -> Value) -> [Double] -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: Double
b Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: Maybe Double -> [Double]
forall a. Maybe a -> [a]
maybeToList Maybe Double
c

-- Point, Multipoint

newtype Point = Point {Point -> Position
unPoint :: Position}
  deriving (Int -> Point -> ShowS
[Point] -> ShowS
Point -> String
(Int -> Point -> ShowS)
-> (Point -> String) -> ([Point] -> ShowS) -> Show Point
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Point] -> ShowS
$cshowList :: [Point] -> ShowS
show :: Point -> String
$cshow :: Point -> String
showsPrec :: Int -> Point -> ShowS
$cshowsPrec :: Int -> Point -> ShowS
Show, Point -> Point -> Bool
(Point -> Point -> Bool) -> (Point -> Point -> Bool) -> Eq Point
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Point -> Point -> Bool
$c/= :: Point -> Point -> Bool
== :: Point -> Point -> Bool
$c== :: Point -> Point -> Bool
Eq, [Point] -> Value
[Point] -> Encoding
Point -> Value
Point -> Encoding
(Point -> Value)
-> (Point -> Encoding)
-> ([Point] -> Value)
-> ([Point] -> Encoding)
-> ToJSON Point
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Point] -> Encoding
$ctoEncodingList :: [Point] -> Encoding
toJSONList :: [Point] -> Value
$ctoJSONList :: [Point] -> Value
toEncoding :: Point -> Encoding
$ctoEncoding :: Point -> Encoding
toJSON :: Point -> Value
$ctoJSON :: Point -> Value
J.ToJSON, Value -> Parser [Point]
Value -> Parser Point
(Value -> Parser Point)
-> (Value -> Parser [Point]) -> FromJSON Point
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Point]
$cparseJSONList :: Value -> Parser [Point]
parseJSON :: Value -> Parser Point
$cparseJSON :: Value -> Parser Point
J.FromJSON)

newtype MultiPoint = MultiPoint {MultiPoint -> [Position]
unMultiPoint :: [Position]}
  deriving (Int -> MultiPoint -> ShowS
[MultiPoint] -> ShowS
MultiPoint -> String
(Int -> MultiPoint -> ShowS)
-> (MultiPoint -> String)
-> ([MultiPoint] -> ShowS)
-> Show MultiPoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultiPoint] -> ShowS
$cshowList :: [MultiPoint] -> ShowS
show :: MultiPoint -> String
$cshow :: MultiPoint -> String
showsPrec :: Int -> MultiPoint -> ShowS
$cshowsPrec :: Int -> MultiPoint -> ShowS
Show, MultiPoint -> MultiPoint -> Bool
(MultiPoint -> MultiPoint -> Bool)
-> (MultiPoint -> MultiPoint -> Bool) -> Eq MultiPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiPoint -> MultiPoint -> Bool
$c/= :: MultiPoint -> MultiPoint -> Bool
== :: MultiPoint -> MultiPoint -> Bool
$c== :: MultiPoint -> MultiPoint -> Bool
Eq, [MultiPoint] -> Value
[MultiPoint] -> Encoding
MultiPoint -> Value
MultiPoint -> Encoding
(MultiPoint -> Value)
-> (MultiPoint -> Encoding)
-> ([MultiPoint] -> Value)
-> ([MultiPoint] -> Encoding)
-> ToJSON MultiPoint
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MultiPoint] -> Encoding
$ctoEncodingList :: [MultiPoint] -> Encoding
toJSONList :: [MultiPoint] -> Value
$ctoJSONList :: [MultiPoint] -> Value
toEncoding :: MultiPoint -> Encoding
$ctoEncoding :: MultiPoint -> Encoding
toJSON :: MultiPoint -> Value
$ctoJSON :: MultiPoint -> Value
J.ToJSON, Value -> Parser [MultiPoint]
Value -> Parser MultiPoint
(Value -> Parser MultiPoint)
-> (Value -> Parser [MultiPoint]) -> FromJSON MultiPoint
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MultiPoint]
$cparseJSONList :: Value -> Parser [MultiPoint]
parseJSON :: Value -> Parser MultiPoint
$cparseJSON :: Value -> Parser MultiPoint
J.FromJSON)

-- LineString, MultiLineString

data LineString = LineString
  { LineString -> Position
_lsFirst :: !Position,
    LineString -> Position
_lsSecond :: !Position,
    LineString -> [Position]
_lsRest :: ![Position]
  }
  deriving (Int -> LineString -> ShowS
[LineString] -> ShowS
LineString -> String
(Int -> LineString -> ShowS)
-> (LineString -> String)
-> ([LineString] -> ShowS)
-> Show LineString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineString] -> ShowS
$cshowList :: [LineString] -> ShowS
show :: LineString -> String
$cshow :: LineString -> String
showsPrec :: Int -> LineString -> ShowS
$cshowsPrec :: Int -> LineString -> ShowS
Show, LineString -> LineString -> Bool
(LineString -> LineString -> Bool)
-> (LineString -> LineString -> Bool) -> Eq LineString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineString -> LineString -> Bool
$c/= :: LineString -> LineString -> Bool
== :: LineString -> LineString -> Bool
$c== :: LineString -> LineString -> Bool
Eq)

instance J.ToJSON LineString where
  toJSON :: LineString -> Value
toJSON (LineString Position
a Position
b [Position]
rest) =
    [Position] -> Value
forall a. ToJSON a => a -> Value
J.toJSON ([Position] -> Value) -> [Position] -> Value
forall a b. (a -> b) -> a -> b
$ Position
a Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: Position
b Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: [Position]
rest

instance J.FromJSON LineString where
  parseJSON :: Value -> Parser LineString
parseJSON = String
-> (Vector Position -> Parser LineString)
-> Value
-> Parser LineString
forall a b.
FromJSON a =>
String -> (Vector a -> Parser b) -> Value -> Parser b
withParsedArray String
"LineString" ((Vector Position -> Parser LineString)
 -> Value -> Parser LineString)
-> (Vector Position -> Parser LineString)
-> Value
-> Parser LineString
forall a b. (a -> b) -> a -> b
$ \Vector Position
arr ->
    if Vector Position -> Int
forall a. Vector a -> Int
V.length Vector Position
arr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
      then String -> Parser LineString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"A LineString needs at least 2 Positions"
      else -- here we are ignoring anything past 3 elements

        let fstPos :: Position
fstPos = Vector Position
arr Vector Position -> Int -> Position
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
0
            sndPos :: Position
sndPos = Vector Position
arr Vector Position -> Int -> Position
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
1
            rest :: [Position]
rest = Vector Position -> [Position]
forall a. Vector a -> [a]
V.toList (Vector Position -> [Position]) -> Vector Position -> [Position]
forall a b. (a -> b) -> a -> b
$ Int -> Vector Position -> Vector Position
forall a. Int -> Vector a -> Vector a
V.drop Int
2 Vector Position
arr
         in LineString -> Parser LineString
forall (m :: * -> *) a. Monad m => a -> m a
return (LineString -> Parser LineString)
-> LineString -> Parser LineString
forall a b. (a -> b) -> a -> b
$ Position -> Position -> [Position] -> LineString
LineString Position
fstPos Position
sndPos [Position]
rest

newtype MultiLineString = MultiLineString {MultiLineString -> [LineString]
unMultiLineString :: [LineString]}
  deriving (Int -> MultiLineString -> ShowS
[MultiLineString] -> ShowS
MultiLineString -> String
(Int -> MultiLineString -> ShowS)
-> (MultiLineString -> String)
-> ([MultiLineString] -> ShowS)
-> Show MultiLineString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultiLineString] -> ShowS
$cshowList :: [MultiLineString] -> ShowS
show :: MultiLineString -> String
$cshow :: MultiLineString -> String
showsPrec :: Int -> MultiLineString -> ShowS
$cshowsPrec :: Int -> MultiLineString -> ShowS
Show, MultiLineString -> MultiLineString -> Bool
(MultiLineString -> MultiLineString -> Bool)
-> (MultiLineString -> MultiLineString -> Bool)
-> Eq MultiLineString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiLineString -> MultiLineString -> Bool
$c/= :: MultiLineString -> MultiLineString -> Bool
== :: MultiLineString -> MultiLineString -> Bool
$c== :: MultiLineString -> MultiLineString -> Bool
Eq, [MultiLineString] -> Value
[MultiLineString] -> Encoding
MultiLineString -> Value
MultiLineString -> Encoding
(MultiLineString -> Value)
-> (MultiLineString -> Encoding)
-> ([MultiLineString] -> Value)
-> ([MultiLineString] -> Encoding)
-> ToJSON MultiLineString
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MultiLineString] -> Encoding
$ctoEncodingList :: [MultiLineString] -> Encoding
toJSONList :: [MultiLineString] -> Value
$ctoJSONList :: [MultiLineString] -> Value
toEncoding :: MultiLineString -> Encoding
$ctoEncoding :: MultiLineString -> Encoding
toJSON :: MultiLineString -> Value
$ctoJSON :: MultiLineString -> Value
J.ToJSON, Value -> Parser [MultiLineString]
Value -> Parser MultiLineString
(Value -> Parser MultiLineString)
-> (Value -> Parser [MultiLineString]) -> FromJSON MultiLineString
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MultiLineString]
$cparseJSONList :: Value -> Parser [MultiLineString]
parseJSON :: Value -> Parser MultiLineString
$cparseJSON :: Value -> Parser MultiLineString
J.FromJSON)

-- Polygon, MultiPolygon

data LinearRing = LinearRing
  { LinearRing -> Position
_pFirst :: !Position,
    LinearRing -> Position
_pSecond :: !Position,
    LinearRing -> Position
_pThird :: !Position,
    LinearRing -> [Position]
_pRest :: ![Position]
  }
  deriving (Int -> LinearRing -> ShowS
[LinearRing] -> ShowS
LinearRing -> String
(Int -> LinearRing -> ShowS)
-> (LinearRing -> String)
-> ([LinearRing] -> ShowS)
-> Show LinearRing
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinearRing] -> ShowS
$cshowList :: [LinearRing] -> ShowS
show :: LinearRing -> String
$cshow :: LinearRing -> String
showsPrec :: Int -> LinearRing -> ShowS
$cshowsPrec :: Int -> LinearRing -> ShowS
Show, LinearRing -> LinearRing -> Bool
(LinearRing -> LinearRing -> Bool)
-> (LinearRing -> LinearRing -> Bool) -> Eq LinearRing
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinearRing -> LinearRing -> Bool
$c/= :: LinearRing -> LinearRing -> Bool
== :: LinearRing -> LinearRing -> Bool
$c== :: LinearRing -> LinearRing -> Bool
Eq)

instance J.FromJSON LinearRing where
  parseJSON :: Value -> Parser LinearRing
parseJSON = String
-> (Vector Position -> Parser LinearRing)
-> Value
-> Parser LinearRing
forall a b.
FromJSON a =>
String -> (Vector a -> Parser b) -> Value -> Parser b
withParsedArray String
"LinearRing" ((Vector Position -> Parser LinearRing)
 -> Value -> Parser LinearRing)
-> (Vector Position -> Parser LinearRing)
-> Value
-> Parser LinearRing
forall a b. (a -> b) -> a -> b
$ \Vector Position
arr ->
    if Vector Position -> Int
forall a. Vector a -> Int
V.length Vector Position
arr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4
      then String -> Parser LinearRing
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"A LinearRing needs at least 4 Positions"
      else -- here we are ignoring anything past 3 elements
      do
        let fstPos :: Position
fstPos = Vector Position
arr Vector Position -> Int -> Position
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
0
            sndPos :: Position
sndPos = Vector Position
arr Vector Position -> Int -> Position
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
1
            thrPos :: Position
thrPos = Vector Position
arr Vector Position -> Int -> Position
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
2
            rest :: Vector Position
rest = Int -> Vector Position -> Vector Position
forall a. Int -> Vector a -> Vector a
V.drop Int
3 Vector Position
arr
        let lastPos :: Position
lastPos = Vector Position -> Position
forall a. Vector a -> a
V.last Vector Position
rest
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Position
fstPos Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
lastPos) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
          String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"the first and last locations have to be equal for a LinearRing"
        LinearRing -> Parser LinearRing
forall (m :: * -> *) a. Monad m => a -> m a
return (LinearRing -> Parser LinearRing)
-> LinearRing -> Parser LinearRing
forall a b. (a -> b) -> a -> b
$ Position -> Position -> Position -> [Position] -> LinearRing
LinearRing Position
fstPos Position
sndPos Position
thrPos ([Position] -> LinearRing) -> [Position] -> LinearRing
forall a b. (a -> b) -> a -> b
$ Vector Position -> [Position]
forall a. Vector a -> [a]
V.toList (Vector Position -> [Position]) -> Vector Position -> [Position]
forall a b. (a -> b) -> a -> b
$ Vector Position -> Vector Position
forall a. Vector a -> Vector a
V.init Vector Position
rest

instance J.ToJSON LinearRing where
  toJSON :: LinearRing -> Value
toJSON (LinearRing Position
a Position
b Position
c [Position]
rest) =
    Vector Position -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Vector Position -> Value) -> Vector Position -> Value
forall a b. (a -> b) -> a -> b
$ ([Position] -> Vector Position
forall a. [a] -> Vector a
V.fromList [Position
a, Position
b, Position
c] Vector Position -> Vector Position -> Vector Position
forall a. Semigroup a => a -> a -> a
<> [Position] -> Vector Position
forall a. [a] -> Vector a
V.fromList [Position]
rest) Vector Position -> Position -> Vector Position
forall a. Vector a -> a -> Vector a
`V.snoc` Position
a

newtype Polygon = Polygon {Polygon -> [LinearRing]
unPolygon :: [LinearRing]}
  deriving (Int -> Polygon -> ShowS
[Polygon] -> ShowS
Polygon -> String
(Int -> Polygon -> ShowS)
-> (Polygon -> String) -> ([Polygon] -> ShowS) -> Show Polygon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Polygon] -> ShowS
$cshowList :: [Polygon] -> ShowS
show :: Polygon -> String
$cshow :: Polygon -> String
showsPrec :: Int -> Polygon -> ShowS
$cshowsPrec :: Int -> Polygon -> ShowS
Show, Polygon -> Polygon -> Bool
(Polygon -> Polygon -> Bool)
-> (Polygon -> Polygon -> Bool) -> Eq Polygon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Polygon -> Polygon -> Bool
$c/= :: Polygon -> Polygon -> Bool
== :: Polygon -> Polygon -> Bool
$c== :: Polygon -> Polygon -> Bool
Eq, [Polygon] -> Value
[Polygon] -> Encoding
Polygon -> Value
Polygon -> Encoding
(Polygon -> Value)
-> (Polygon -> Encoding)
-> ([Polygon] -> Value)
-> ([Polygon] -> Encoding)
-> ToJSON Polygon
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Polygon] -> Encoding
$ctoEncodingList :: [Polygon] -> Encoding
toJSONList :: [Polygon] -> Value
$ctoJSONList :: [Polygon] -> Value
toEncoding :: Polygon -> Encoding
$ctoEncoding :: Polygon -> Encoding
toJSON :: Polygon -> Value
$ctoJSON :: Polygon -> Value
J.ToJSON, Value -> Parser [Polygon]
Value -> Parser Polygon
(Value -> Parser Polygon)
-> (Value -> Parser [Polygon]) -> FromJSON Polygon
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Polygon]
$cparseJSONList :: Value -> Parser [Polygon]
parseJSON :: Value -> Parser Polygon
$cparseJSON :: Value -> Parser Polygon
J.FromJSON)

newtype MultiPolygon = MultiPolygon {MultiPolygon -> [Polygon]
unMultiPolygon :: [Polygon]}
  deriving (Int -> MultiPolygon -> ShowS
[MultiPolygon] -> ShowS
MultiPolygon -> String
(Int -> MultiPolygon -> ShowS)
-> (MultiPolygon -> String)
-> ([MultiPolygon] -> ShowS)
-> Show MultiPolygon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultiPolygon] -> ShowS
$cshowList :: [MultiPolygon] -> ShowS
show :: MultiPolygon -> String
$cshow :: MultiPolygon -> String
showsPrec :: Int -> MultiPolygon -> ShowS
$cshowsPrec :: Int -> MultiPolygon -> ShowS
Show, MultiPolygon -> MultiPolygon -> Bool
(MultiPolygon -> MultiPolygon -> Bool)
-> (MultiPolygon -> MultiPolygon -> Bool) -> Eq MultiPolygon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiPolygon -> MultiPolygon -> Bool
$c/= :: MultiPolygon -> MultiPolygon -> Bool
== :: MultiPolygon -> MultiPolygon -> Bool
$c== :: MultiPolygon -> MultiPolygon -> Bool
Eq, [MultiPolygon] -> Value
[MultiPolygon] -> Encoding
MultiPolygon -> Value
MultiPolygon -> Encoding
(MultiPolygon -> Value)
-> (MultiPolygon -> Encoding)
-> ([MultiPolygon] -> Value)
-> ([MultiPolygon] -> Encoding)
-> ToJSON MultiPolygon
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MultiPolygon] -> Encoding
$ctoEncodingList :: [MultiPolygon] -> Encoding
toJSONList :: [MultiPolygon] -> Value
$ctoJSONList :: [MultiPolygon] -> Value
toEncoding :: MultiPolygon -> Encoding
$ctoEncoding :: MultiPolygon -> Encoding
toJSON :: MultiPolygon -> Value
$ctoJSON :: MultiPolygon -> Value
J.ToJSON, Value -> Parser [MultiPolygon]
Value -> Parser MultiPolygon
(Value -> Parser MultiPolygon)
-> (Value -> Parser [MultiPolygon]) -> FromJSON MultiPolygon
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MultiPolygon]
$cparseJSONList :: Value -> Parser [MultiPolygon]
parseJSON :: Value -> Parser MultiPolygon
$cparseJSON :: Value -> Parser MultiPolygon
J.FromJSON)

-- GeometryCollection

data CRSNameProps = CRSNameProps
  { CRSNameProps -> Text
_cnpName :: !Text
  }
  deriving (Int -> CRSNameProps -> ShowS
[CRSNameProps] -> ShowS
CRSNameProps -> String
(Int -> CRSNameProps -> ShowS)
-> (CRSNameProps -> String)
-> ([CRSNameProps] -> ShowS)
-> Show CRSNameProps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CRSNameProps] -> ShowS
$cshowList :: [CRSNameProps] -> ShowS
show :: CRSNameProps -> String
$cshow :: CRSNameProps -> String
showsPrec :: Int -> CRSNameProps -> ShowS
$cshowsPrec :: Int -> CRSNameProps -> ShowS
Show, CRSNameProps -> CRSNameProps -> Bool
(CRSNameProps -> CRSNameProps -> Bool)
-> (CRSNameProps -> CRSNameProps -> Bool) -> Eq CRSNameProps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CRSNameProps -> CRSNameProps -> Bool
$c/= :: CRSNameProps -> CRSNameProps -> Bool
== :: CRSNameProps -> CRSNameProps -> Bool
$c== :: CRSNameProps -> CRSNameProps -> Bool
Eq)

data CRSLinkProps = CRSLinkProps
  { CRSLinkProps -> Text
_clpHref :: !Text,
    CRSLinkProps -> Maybe Text
_clpType :: !(Maybe Text)
  }
  deriving (Int -> CRSLinkProps -> ShowS
[CRSLinkProps] -> ShowS
CRSLinkProps -> String
(Int -> CRSLinkProps -> ShowS)
-> (CRSLinkProps -> String)
-> ([CRSLinkProps] -> ShowS)
-> Show CRSLinkProps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CRSLinkProps] -> ShowS
$cshowList :: [CRSLinkProps] -> ShowS
show :: CRSLinkProps -> String
$cshow :: CRSLinkProps -> String
showsPrec :: Int -> CRSLinkProps -> ShowS
$cshowsPrec :: Int -> CRSLinkProps -> ShowS
Show, CRSLinkProps -> CRSLinkProps -> Bool
(CRSLinkProps -> CRSLinkProps -> Bool)
-> (CRSLinkProps -> CRSLinkProps -> Bool) -> Eq CRSLinkProps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CRSLinkProps -> CRSLinkProps -> Bool
$c/= :: CRSLinkProps -> CRSLinkProps -> Bool
== :: CRSLinkProps -> CRSLinkProps -> Bool
$c== :: CRSLinkProps -> CRSLinkProps -> Bool
Eq)

data CRS
  = CRSName !CRSNameProps
  | CRSLink !CRSLinkProps
  deriving (Int -> CRS -> ShowS
[CRS] -> ShowS
CRS -> String
(Int -> CRS -> ShowS)
-> (CRS -> String) -> ([CRS] -> ShowS) -> Show CRS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CRS] -> ShowS
$cshowList :: [CRS] -> ShowS
show :: CRS -> String
$cshow :: CRS -> String
showsPrec :: Int -> CRS -> ShowS
$cshowsPrec :: Int -> CRS -> ShowS
Show, CRS -> CRS -> Bool
(CRS -> CRS -> Bool) -> (CRS -> CRS -> Bool) -> Eq CRS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CRS -> CRS -> Bool
$c/= :: CRS -> CRS -> Bool
== :: CRS -> CRS -> Bool
$c== :: CRS -> CRS -> Bool
Eq)

$(J.deriveJSON (J.aesonPrefix J.camelCase) ''CRSNameProps)
$(J.deriveJSON (J.aesonPrefix J.camelCase) ''CRSLinkProps)
$( J.deriveJSON
     J.defaultOptions
       { J.constructorTagModifier = J.camelCase . drop 3,
         J.sumEncoding = J.TaggedObject "type" "properties"
       }
     ''CRS
 )

data GeometryWithCRS = GeometryWithCRS
  { GeometryWithCRS -> Geometry
_gwcGeom :: !Geometry,
    GeometryWithCRS -> Maybe CRS
_gwcCrs :: !(Maybe CRS)
  }
  deriving (Int -> GeometryWithCRS -> ShowS
[GeometryWithCRS] -> ShowS
GeometryWithCRS -> String
(Int -> GeometryWithCRS -> ShowS)
-> (GeometryWithCRS -> String)
-> ([GeometryWithCRS] -> ShowS)
-> Show GeometryWithCRS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GeometryWithCRS] -> ShowS
$cshowList :: [GeometryWithCRS] -> ShowS
show :: GeometryWithCRS -> String
$cshow :: GeometryWithCRS -> String
showsPrec :: Int -> GeometryWithCRS -> ShowS
$cshowsPrec :: Int -> GeometryWithCRS -> ShowS
Show, GeometryWithCRS -> GeometryWithCRS -> Bool
(GeometryWithCRS -> GeometryWithCRS -> Bool)
-> (GeometryWithCRS -> GeometryWithCRS -> Bool)
-> Eq GeometryWithCRS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GeometryWithCRS -> GeometryWithCRS -> Bool
$c/= :: GeometryWithCRS -> GeometryWithCRS -> Bool
== :: GeometryWithCRS -> GeometryWithCRS -> Bool
$c== :: GeometryWithCRS -> GeometryWithCRS -> Bool
Eq)

encToCoords :: (J.ToJSON a) => Text -> a -> Maybe CRS -> J.Value
encToCoords :: Text -> a -> Maybe CRS -> Value
encToCoords Text
ty a
a Maybe CRS
Nothing =
  [Pair] -> Value
J.object [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= Text
ty, Key
"coordinates" Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= a
a]
encToCoords Text
ty a
a (Just CRS
crs) =
  [Pair] -> Value
J.object [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= Text
ty, Key
"coordinates" Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= a
a, Key
"crs" Key -> CRS -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= CRS
crs]

instance J.ToJSON GeometryWithCRS where
  toJSON :: GeometryWithCRS -> Value
toJSON (GeometryWithCRS Geometry
geom Maybe CRS
crsM) = case Geometry
geom of
    GPoint Point
o -> Text -> Point -> Maybe CRS -> Value
forall a. ToJSON a => Text -> a -> Maybe CRS -> Value
encToCoords Text
"Point" Point
o Maybe CRS
crsM
    GMultiPoint MultiPoint
o -> Text -> MultiPoint -> Maybe CRS -> Value
forall a. ToJSON a => Text -> a -> Maybe CRS -> Value
encToCoords Text
"MultiPoint" MultiPoint
o Maybe CRS
crsM
    GLineString LineString
o -> Text -> LineString -> Maybe CRS -> Value
forall a. ToJSON a => Text -> a -> Maybe CRS -> Value
encToCoords Text
"LineString" LineString
o Maybe CRS
crsM
    GMultiLineString MultiLineString
o -> Text -> MultiLineString -> Maybe CRS -> Value
forall a. ToJSON a => Text -> a -> Maybe CRS -> Value
encToCoords Text
"MultiLineString" MultiLineString
o Maybe CRS
crsM
    GPolygon Polygon
o -> Text -> Polygon -> Maybe CRS -> Value
forall a. ToJSON a => Text -> a -> Maybe CRS -> Value
encToCoords Text
"Polygon" Polygon
o Maybe CRS
crsM
    GMultiPolygon MultiPolygon
o -> Text -> MultiPolygon -> Maybe CRS -> Value
forall a. ToJSON a => Text -> a -> Maybe CRS -> Value
encToCoords Text
"MultiPolygon" MultiPolygon
o Maybe CRS
crsM
    GGeometryCollection GeometryCollection
o ->
      [Pair] -> Value
J.object
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= (Text
"GeometryCollection" :: Text),
          Key
"geometries" Key -> GeometryCollection -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= GeometryCollection
o
        ]

instance J.FromJSON GeometryWithCRS where
  parseJSON :: Value -> Parser GeometryWithCRS
parseJSON = String
-> (Object -> Parser GeometryWithCRS)
-> Value
-> Parser GeometryWithCRS
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"Geometry" ((Object -> Parser GeometryWithCRS)
 -> Value -> Parser GeometryWithCRS)
-> (Object -> Parser GeometryWithCRS)
-> Value
-> Parser GeometryWithCRS
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    String
ty <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"type"
    Geometry
geom <- case String
ty of
      String
"Point" -> Point -> Geometry
GPoint (Point -> Geometry) -> Parser Point -> Parser Geometry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Point
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"coordinates"
      String
"MultiPoint" -> MultiPoint -> Geometry
GMultiPoint (MultiPoint -> Geometry) -> Parser MultiPoint -> Parser Geometry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser MultiPoint
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"coordinates"
      String
"LineString" -> LineString -> Geometry
GLineString (LineString -> Geometry) -> Parser LineString -> Parser Geometry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser LineString
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"coordinates"
      String
"MultiLineString" -> MultiLineString -> Geometry
GMultiLineString (MultiLineString -> Geometry)
-> Parser MultiLineString -> Parser Geometry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser MultiLineString
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"coordinates"
      String
"Polygon" -> Polygon -> Geometry
GPolygon (Polygon -> Geometry) -> Parser Polygon -> Parser Geometry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Polygon
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"coordinates"
      String
"MultiPolygon" -> MultiPolygon -> Geometry
GMultiPolygon (MultiPolygon -> Geometry)
-> Parser MultiPolygon -> Parser Geometry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser MultiPolygon
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"coordinates"
      String
"GeometryCollection" -> GeometryCollection -> Geometry
GGeometryCollection (GeometryCollection -> Geometry)
-> Parser GeometryCollection -> Parser Geometry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser GeometryCollection
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"geometries"
      String
_ -> String -> Parser Geometry
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Geometry) -> String -> Parser Geometry
forall a b. (a -> b) -> a -> b
$ String
"unexpected geometry type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ty
    Maybe CRS
crsM <- Object
o Object -> Key -> Parser (Maybe CRS)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"crs"
    GeometryWithCRS -> Parser GeometryWithCRS
forall (m :: * -> *) a. Monad m => a -> m a
return (GeometryWithCRS -> Parser GeometryWithCRS)
-> GeometryWithCRS -> Parser GeometryWithCRS
forall a b. (a -> b) -> a -> b
$ Geometry -> Maybe CRS -> GeometryWithCRS
GeometryWithCRS Geometry
geom Maybe CRS
crsM

newtype GeometryCollection = GeometryCollection {GeometryCollection -> [GeometryWithCRS]
unGeometryCollection :: [GeometryWithCRS]}
  deriving (Int -> GeometryCollection -> ShowS
[GeometryCollection] -> ShowS
GeometryCollection -> String
(Int -> GeometryCollection -> ShowS)
-> (GeometryCollection -> String)
-> ([GeometryCollection] -> ShowS)
-> Show GeometryCollection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GeometryCollection] -> ShowS
$cshowList :: [GeometryCollection] -> ShowS
show :: GeometryCollection -> String
$cshow :: GeometryCollection -> String
showsPrec :: Int -> GeometryCollection -> ShowS
$cshowsPrec :: Int -> GeometryCollection -> ShowS
Show, GeometryCollection -> GeometryCollection -> Bool
(GeometryCollection -> GeometryCollection -> Bool)
-> (GeometryCollection -> GeometryCollection -> Bool)
-> Eq GeometryCollection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GeometryCollection -> GeometryCollection -> Bool
$c/= :: GeometryCollection -> GeometryCollection -> Bool
== :: GeometryCollection -> GeometryCollection -> Bool
$c== :: GeometryCollection -> GeometryCollection -> Bool
Eq, [GeometryCollection] -> Value
[GeometryCollection] -> Encoding
GeometryCollection -> Value
GeometryCollection -> Encoding
(GeometryCollection -> Value)
-> (GeometryCollection -> Encoding)
-> ([GeometryCollection] -> Value)
-> ([GeometryCollection] -> Encoding)
-> ToJSON GeometryCollection
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [GeometryCollection] -> Encoding
$ctoEncodingList :: [GeometryCollection] -> Encoding
toJSONList :: [GeometryCollection] -> Value
$ctoJSONList :: [GeometryCollection] -> Value
toEncoding :: GeometryCollection -> Encoding
$ctoEncoding :: GeometryCollection -> Encoding
toJSON :: GeometryCollection -> Value
$ctoJSON :: GeometryCollection -> Value
J.ToJSON, Value -> Parser [GeometryCollection]
Value -> Parser GeometryCollection
(Value -> Parser GeometryCollection)
-> (Value -> Parser [GeometryCollection])
-> FromJSON GeometryCollection
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [GeometryCollection]
$cparseJSONList :: Value -> Parser [GeometryCollection]
parseJSON :: Value -> Parser GeometryCollection
$cparseJSON :: Value -> Parser GeometryCollection
J.FromJSON)

-- Geometry

data Geometry
  = GPoint !Point
  | GMultiPoint !MultiPoint
  | GLineString !LineString
  | GMultiLineString !MultiLineString
  | GPolygon !Polygon
  | GMultiPolygon !MultiPolygon
  | GGeometryCollection !GeometryCollection
  deriving (Int -> Geometry -> ShowS
[Geometry] -> ShowS
Geometry -> String
(Int -> Geometry -> ShowS)
-> (Geometry -> String) -> ([Geometry] -> ShowS) -> Show Geometry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Geometry] -> ShowS
$cshowList :: [Geometry] -> ShowS
show :: Geometry -> String
$cshow :: Geometry -> String
showsPrec :: Int -> Geometry -> ShowS
$cshowsPrec :: Int -> Geometry -> ShowS
Show, Geometry -> Geometry -> Bool
(Geometry -> Geometry -> Bool)
-> (Geometry -> Geometry -> Bool) -> Eq Geometry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Geometry -> Geometry -> Bool
$c/= :: Geometry -> Geometry -> Bool
== :: Geometry -> Geometry -> Bool
$c== :: Geometry -> Geometry -> Bool
Eq)