module Hasura.SQL.WKT
  ( ToWKT (..),
    WKT (..),
  )
where

import Data.List (intersperse)
import Hasura.Base.Error qualified as E
import Hasura.Prelude
import Hasura.SQL.GeoJSON qualified as G

newtype WKT = WKT {WKT -> Text
getWKT :: Text}

class ToWKT a where
  toWKT :: a -> Either E.QErr WKT

instance ToWKT G.Point where
  toWKT :: Point -> Either QErr WKT
toWKT = Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
"POINT" (Either QErr Text -> Either QErr WKT)
-> (Point -> Either QErr Text) -> Point -> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Either QErr Text
positionToText (Position -> Either QErr Text)
-> (Point -> Position) -> Point -> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Position
G.unPoint

instance ToWKT G.MultiPoint where
  toWKT :: MultiPoint -> Either QErr WKT
toWKT = Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
"MULTIPOINT" (Either QErr Text -> Either QErr WKT)
-> (MultiPoint -> Either QErr Text)
-> MultiPoint
-> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Position] -> Either QErr Text
commaSeparated ([Position] -> Either QErr Text)
-> (MultiPoint -> [Position]) -> MultiPoint -> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiPoint -> [Position]
G.unMultiPoint

instance ToWKT G.LineString where
  toWKT :: LineString -> Either QErr WKT
toWKT = Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
"LINESTRING" (Either QErr Text -> Either QErr WKT)
-> (LineString -> Either QErr Text)
-> LineString
-> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineString -> Either QErr Text
lineStringToText

instance ToWKT G.MultiLineString where
  toWKT :: MultiLineString -> Either QErr WKT
toWKT =
    Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
"MULTILINESTRING"
      (Either QErr Text -> Either QErr WKT)
-> (MultiLineString -> Either QErr Text)
-> MultiLineString
-> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> Either QErr [Text] -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", ")
      (Either QErr [Text] -> Either QErr Text)
-> (MultiLineString -> Either QErr [Text])
-> MultiLineString
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineString -> Either QErr Text)
-> [LineString] -> Either QErr [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Text -> Text) -> Either QErr Text -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
parens (Either QErr Text -> Either QErr Text)
-> (LineString -> Either QErr Text)
-> LineString
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineString -> Either QErr Text
lineStringToText)
      ([LineString] -> Either QErr [Text])
-> (MultiLineString -> [LineString])
-> MultiLineString
-> Either QErr [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiLineString -> [LineString]
G.unMultiLineString

instance ToWKT G.Polygon where
  toWKT :: Polygon -> Either QErr WKT
toWKT =
    Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
"POLYGON"
      (Either QErr Text -> Either QErr WKT)
-> (Polygon -> Either QErr Text) -> Polygon -> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> Either QErr [Text] -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", ")
      (Either QErr [Text] -> Either QErr Text)
-> (Polygon -> Either QErr [Text]) -> Polygon -> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LinearRing -> Either QErr Text)
-> [LinearRing] -> Either QErr [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Text -> Text) -> Either QErr Text -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
parens (Either QErr Text -> Either QErr Text)
-> (LinearRing -> Either QErr Text)
-> LinearRing
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinearRing -> Either QErr Text
linearRingToText)
      ([LinearRing] -> Either QErr [Text])
-> (Polygon -> [LinearRing]) -> Polygon -> Either QErr [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> [LinearRing]
G.unPolygon

instance ToWKT G.MultiPolygon where
  toWKT :: MultiPolygon -> Either QErr WKT
toWKT =
    Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
"MULTIPOLYGON"
      (Either QErr Text -> Either QErr WKT)
-> (MultiPolygon -> Either QErr Text)
-> MultiPolygon
-> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> Either QErr [Text] -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", ")
      (Either QErr [Text] -> Either QErr Text)
-> (MultiPolygon -> Either QErr [Text])
-> MultiPolygon
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Polygon -> Either QErr Text) -> [Polygon] -> Either QErr [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
        ( ([Text] -> Text) -> Either QErr [Text] -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
parens (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", ")
            (Either QErr [Text] -> Either QErr Text)
-> (Polygon -> Either QErr [Text]) -> Polygon -> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LinearRing -> Either QErr Text)
-> [LinearRing] -> Either QErr [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Text -> Text) -> Either QErr Text -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
parens (Either QErr Text -> Either QErr Text)
-> (LinearRing -> Either QErr Text)
-> LinearRing
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinearRing -> Either QErr Text
linearRingToText)
            ([LinearRing] -> Either QErr [Text])
-> (Polygon -> [LinearRing]) -> Polygon -> Either QErr [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> [LinearRing]
G.unPolygon
        )
      ([Polygon] -> Either QErr [Text])
-> (MultiPolygon -> [Polygon])
-> MultiPolygon
-> Either QErr [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiPolygon -> [Polygon]
G.unMultiPolygon

instance ToWKT G.GeometryCollection where
  toWKT :: GeometryCollection -> Either QErr WKT
toWKT =
    Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
"GEOMETRYCOLLECTION"
      (Either QErr Text -> Either QErr WKT)
-> (GeometryCollection -> Either QErr Text)
-> GeometryCollection
-> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> Either QErr [Text] -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", ")
      (Either QErr [Text] -> Either QErr Text)
-> (GeometryCollection -> Either QErr [Text])
-> GeometryCollection
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GeometryWithCRS -> Either QErr Text)
-> [GeometryWithCRS] -> Either QErr [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((WKT -> Text) -> Either QErr WKT -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WKT -> Text
getWKT (Either QErr WKT -> Either QErr Text)
-> (GeometryWithCRS -> Either QErr WKT)
-> GeometryWithCRS
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Geometry -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT (Geometry -> Either QErr WKT)
-> (GeometryWithCRS -> Geometry)
-> GeometryWithCRS
-> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GeometryWithCRS -> Geometry
G._gwcGeom)
      ([GeometryWithCRS] -> Either QErr [Text])
-> (GeometryCollection -> [GeometryWithCRS])
-> GeometryCollection
-> Either QErr [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GeometryCollection -> [GeometryWithCRS]
G.unGeometryCollection

instance ToWKT G.Geometry where
  toWKT :: Geometry -> Either QErr WKT
toWKT =
    \case
      G.GPoint Point
p -> Point -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT Point
p
      G.GMultiPoint MultiPoint
m -> MultiPoint -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT MultiPoint
m
      G.GLineString LineString
l -> LineString -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT LineString
l
      G.GMultiLineString MultiLineString
m -> MultiLineString -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT MultiLineString
m
      G.GPolygon Polygon
p -> Polygon -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT Polygon
p
      G.GMultiPolygon MultiPolygon
m -> MultiPolygon -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT MultiPolygon
m
      G.GGeometryCollection GeometryCollection
g -> GeometryCollection -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT GeometryCollection
g

instance ToWKT G.GeometryWithCRS where
  toWKT :: GeometryWithCRS -> Either QErr WKT
toWKT = Geometry -> Either QErr WKT
forall a. ToWKT a => a -> Either QErr WKT
toWKT (Geometry -> Either QErr WKT)
-> (GeometryWithCRS -> Geometry)
-> GeometryWithCRS
-> Either QErr WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GeometryWithCRS -> Geometry
G._gwcGeom

mkWKT :: Text -> Either E.QErr Text -> Either E.QErr WKT
mkWKT :: Text -> Either QErr Text -> Either QErr WKT
mkWKT Text
name Either QErr Text
args = Text -> WKT
WKT (Text -> WKT) -> (Text -> Text) -> Text -> WKT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
wktFormat (Text -> WKT) -> Either QErr Text -> Either QErr WKT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either QErr Text
args
  where
    wktFormat :: Text -> Text
    wktFormat :: Text -> Text
wktFormat Text
a = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens Text
a

parens :: Text -> Text
parens :: Text -> Text
parens Text
t = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

commaSeparated :: [G.Position] -> Either E.QErr Text
commaSeparated :: [Position] -> Either QErr Text
commaSeparated = ([Text] -> Text) -> Either QErr [Text] -> Either QErr Text
forall a b. (a -> b) -> Either QErr a -> Either QErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", ") (Either QErr [Text] -> Either QErr Text)
-> ([Position] -> Either QErr [Text])
-> [Position]
-> Either QErr Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Either QErr Text) -> [Position] -> Either QErr [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Position -> Either QErr Text
positionToText

positionToText :: G.Position -> Either E.QErr Text
positionToText :: Position -> Either QErr Text
positionToText (G.Position Double
x Double
y Maybe Double
mz) =
  case Maybe Double
mz of
    Maybe Double
Nothing -> Text -> Either QErr Text
forall a. a -> Either QErr a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either QErr Text) -> Text -> Either QErr Text
forall a b. (a -> b) -> a -> b
$ Double -> Text
forall a. Show a => a -> Text
tshow Double
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall a. Show a => a -> Text
tshow Double
y
    Just Double
_ -> QErr -> Either QErr Text
forall a b. a -> Either a b
Left (QErr -> Either QErr Text) -> QErr -> Either QErr Text
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
E.err400 Code
E.ParseFailed Text
"3 dimmensional coordinates are not supported"

lineStringToText :: G.LineString -> Either E.QErr Text
lineStringToText :: LineString -> Either QErr Text
lineStringToText (G.LineString Position
ls1 Position
ls2 [Position]
lsRest) = [Position] -> Either QErr Text
commaSeparated (Position
ls1 Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: Position
ls2 Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: [Position]
lsRest)

linearRingToText :: G.LinearRing -> Either E.QErr Text
linearRingToText :: LinearRing -> Either QErr Text
linearRingToText (G.LinearRing Position
p1 Position
p2 Position
p3 [Position]
pRest) = [Position] -> Either QErr Text
commaSeparated (Position
p1 Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: Position
p2 Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: Position
p3 Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: [Position]
pRest [Position] -> [Position] -> [Position]
forall a. Semigroup a => a -> a -> a
<> [Position
p1])