mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-16 09:51:59 +03:00
97 lines
2.7 KiB
Haskell
97 lines
2.7 KiB
Haskell
module Hasura.SQL.WKT
|
|
( ToWKT(..)
|
|
, WKT(..)
|
|
) where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import Data.List (intersperse)
|
|
|
|
import qualified Hasura.Base.Error as E
|
|
import qualified Hasura.SQL.GeoJSON as G
|
|
|
|
|
|
newtype WKT = WKT { getWKT :: Text }
|
|
|
|
class ToWKT a where
|
|
toWKT :: a -> Either E.QErr WKT
|
|
|
|
instance ToWKT G.Point where
|
|
toWKT = mkWKT "POINT" . positionToText . G.unPoint
|
|
|
|
instance ToWKT G.MultiPoint where
|
|
toWKT = mkWKT "MULTIPOINT" . commaSeparated . G.unMultiPoint
|
|
|
|
instance ToWKT G.LineString where
|
|
toWKT = mkWKT "LINESTRING" . lineStringToText
|
|
|
|
instance ToWKT G.MultiLineString where
|
|
toWKT =
|
|
mkWKT "MULTILINESTRING"
|
|
. fmap (mconcat . intersperse ", ")
|
|
. traverse (fmap parens . lineStringToText)
|
|
. G.unMultiLineString
|
|
|
|
instance ToWKT G.Polygon where
|
|
toWKT =
|
|
mkWKT "POLYGON"
|
|
. fmap (mconcat . intersperse ", ")
|
|
. traverse (fmap parens . linearRingToText)
|
|
. G.unPolygon
|
|
|
|
instance ToWKT G.MultiPolygon where
|
|
toWKT =
|
|
mkWKT "MULTIPOLYGON"
|
|
. fmap (mconcat . intersperse ", ")
|
|
. traverse
|
|
(fmap (parens . mconcat . intersperse ", ")
|
|
. traverse (fmap parens . linearRingToText)
|
|
. G.unPolygon
|
|
)
|
|
. G.unMultiPolygon
|
|
|
|
instance ToWKT G.GeometryCollection where
|
|
toWKT =
|
|
mkWKT "GEOMETRYCOLLECTION"
|
|
. fmap (mconcat . intersperse ", ")
|
|
. traverse (fmap getWKT . toWKT . G._gwcGeom)
|
|
. G.unGeometryCollection
|
|
|
|
instance ToWKT G.Geometry where
|
|
toWKT =
|
|
\case
|
|
G.GPoint p -> toWKT p
|
|
G.GMultiPoint m -> toWKT m
|
|
G.GLineString l -> toWKT l
|
|
G.GMultiLineString m -> toWKT m
|
|
G.GPolygon p -> toWKT p
|
|
G.GMultiPolygon m -> toWKT m
|
|
G.GGeometryCollection g -> toWKT g
|
|
|
|
instance ToWKT G.GeometryWithCRS where
|
|
toWKT = toWKT . G._gwcGeom
|
|
|
|
mkWKT :: Text -> Either E.QErr Text -> Either E.QErr WKT
|
|
mkWKT name args = WKT . wktFormat <$> args
|
|
where
|
|
wktFormat :: Text -> Text
|
|
wktFormat a = name <> " " <> parens a
|
|
|
|
parens :: Text -> Text
|
|
parens t = "(" <> t <> ")"
|
|
|
|
commaSeparated :: [G.Position] -> Either E.QErr Text
|
|
commaSeparated = fmap (mconcat . intersperse ", ") . traverse positionToText
|
|
|
|
positionToText :: G.Position -> Either E.QErr Text
|
|
positionToText (G.Position x y mz) =
|
|
case mz of
|
|
Nothing -> pure $ tshow x <> " " <> tshow y
|
|
Just _ -> Left $ E.err400 E.ParseFailed "3 dimmensional coordinates are not supported"
|
|
|
|
lineStringToText :: G.LineString -> Either E.QErr Text
|
|
lineStringToText (G.LineString ls1 ls2 lsRest) = commaSeparated (ls1 : ls2 : lsRest)
|
|
|
|
linearRingToText :: G.LinearRing -> Either E.QErr Text
|
|
linearRingToText (G.LinearRing p1 p2 p3 pRest) = commaSeparated (p1 : p2 : p3 : pRest <> [p1])
|