graphql-engine/server/src-test/Hasura/SQL/WKTSpec.hs

{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
module Hasura.SQL.WKTSpec
  ( spec
  ) where

import           Hasura.Prelude

import qualified Hasura.SQL.GeoJSON as G

import           Hasura.SQL.WKT

import           Data.Either        (isLeft)
import           Test.Hspec

spec :: Spec
spec = describe "WKT" do
    runSpec "Point" pointSpec
    runSpec "MultiPoint" multiPointSpec
    runSpec "LineString" lineStringSpec
    runSpec "MultiLineString" multiLineStringSpec
    runSpec "Polygon" polygonSpec
    runSpec "MultiPolygon" multiPolygonSpec
    runSpec "GeometryCollection" geometryCollectionSpec
    runNegativeSpec "3D types should error" negativeSpecs

negativeSpecs :: [G.Point]
negativeSpecs =
  [ mkPoint $ mkPosition 1 2 (Just 3)
  , mkPoint $ mkPosition 1 2 (Just (-1))
  ]

runNegativeSpec :: forall a. ToWKT a => String -> [a] -> Spec
runNegativeSpec name = it name . traverse_ go
  where
    go wkt =
      getWKT <$> toWKT wkt `shouldSatisfy` isLeft

runSpec :: forall a. ToWKT a => String -> [(Text, a)] -> Spec
runSpec name = it name . traverse_ go
  where
    go (t, wkt) =
      getWKT <$> toWKT wkt `shouldBe` Right t

pointSpec :: [(Text, G.Point)]
pointSpec =
  [ ( "POINT (1.0 2.0)"
    , mkPoint $ mkPosition 1 2 Nothing
    )
  , ( "POINT (1.1 2.2)"
    , mkPoint $ mkPosition 1.1 2.2 Nothing
    )
  , ( "POINT (1.1 -2.2)"
    , mkPoint $ mkPosition 1.1 (-2.2) Nothing
    )
  ]

multiPointSpec :: [(Text, G.MultiPoint)]
multiPointSpec =
  [ ( "MULTIPOINT (1.0 2.0)"
    , mkMultiPoint [ mkPosition 1 2 Nothing ]
    )
  , ( "MULTIPOINT (1.1 2.2, 4.4 5.5)"
    , mkMultiPoint
        [ mkPosition 1.1 2.2 Nothing
        , mkPosition 4.4 5.5 Nothing
        ]
    )
  ]

lineStringSpec :: [(Text, G.LineString)]
lineStringSpec =
  [ ( "LINESTRING (1.0 2.0, 3.0 4.0)"
    , mkLineString
      [ mkPosition 1 2 Nothing
      , mkPosition 3 4 Nothing
      ]
    )
  , ( "LINESTRING (1.1 2.2, 4.4 5.5, 7.7 8.8)"
    , mkLineString
        [ mkPosition 1.1 2.2 Nothing
        , mkPosition 4.4 5.5 Nothing
        , mkPosition 7.7 8.8 Nothing
        ]
    )
  ]

multiLineStringSpec :: [(Text, G.MultiLineString)]
multiLineStringSpec =
  [ ( "MULTILINESTRING ((1.1 2.2, 4.4 5.5, 7.7 8.8))"
    , mkMultiLineString
        [ mkLineString
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          ]
        ]
    )
  , ( "MULTILINESTRING ((1.1 2.2, 4.4 5.5, 7.7 8.8), (1.1 2.2, 4.4 5.5))"
    , mkMultiLineString
        [ mkLineString
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          ]
        , mkLineString
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          ]
        ]
    )
  ]

polygonSpec :: [(Text, G.Polygon)]
polygonSpec =
  [ ( "POLYGON ((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2))"
    , mkPolygon
        [ mkLinearRing
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          ]
        ]
    )
  , ( "POLYGON ((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2), (1.1 2.2, 4.4 5.5, 7.7 8.8, 1.0 1.0, 1.1 2.2))"
    , mkPolygon
        [ mkLinearRing
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          ]
        , mkLinearRing
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          , mkPosition 1.0 1.0 Nothing
          ]
        ]
    )
  ]

multiPolygonSpec :: [(Text, G.MultiPolygon)]
multiPolygonSpec =
  [ ( "MULTIPOLYGON (((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2)))"
    , mkMultiPolygon
      [ mkPolygon
        [ mkLinearRing
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          ]
        ]
      ]
    )
  , ( "MULTIPOLYGON (((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2)), ((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2), (1.1 2.2, 4.4 5.5, 7.7 8.8, 1.0 1.0, 1.1 2.2)))"
    , mkMultiPolygon
      [ mkPolygon
        [ mkLinearRing
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          ]
        ]
      , mkPolygon
          [ mkLinearRing
            [ mkPosition 1.1 2.2 Nothing
            , mkPosition 4.4 5.5 Nothing
            , mkPosition 7.7 8.8 Nothing
            ]
          , mkLinearRing
            [ mkPosition 1.1 2.2 Nothing
            , mkPosition 4.4 5.5 Nothing
            , mkPosition 7.7 8.8 Nothing
            , mkPosition 1.0 1.0 Nothing
            ]
          ]
      ]
    )
  ]

geometryCollectionSpec :: [(Text, G.GeometryCollection)]
geometryCollectionSpec =
  [ ( "GEOMETRYCOLLECTION (POINT (1.0 2.0), LINESTRING (3.0 4.0, 5.0 6.0))"
    , mkGeometryCollection
      [ G.GPoint $ mkPoint $ mkPosition 1 2 Nothing
      , G.GLineString $ mkLineString
          [ mkPosition 3 4 Nothing
          , mkPosition 5 6 Nothing
          ]
      ]
    )
  , ( "GEOMETRYCOLLECTION (POINT (1.1 -2.2), MULTIPOINT (1.1 2.2, 4.4 5.5), LINESTRING (1.1 2.2, 4.4 5.5, 7.7 8.8), MULTILINESTRING ((1.1 2.2, 4.4 5.5, 7.7 8.8), (1.1 2.2, 4.4 5.5)), POLYGON ((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2), (1.1 2.2, 4.4 5.5, 7.7 8.8, 1.0 1.0, 1.1 2.2)), MULTIPOLYGON (((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2)), ((1.1 2.2, 4.4 5.5, 7.7 8.8, 1.1 2.2), (1.1 2.2, 4.4 5.5, 7.7 8.8, 1.0 1.0, 1.1 2.2))))"
    , mkGeometryCollection
      [ G.GPoint $ mkPoint $ mkPosition 1.1 (-2.2) Nothing
      , G.GMultiPoint $ mkMultiPoint
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          ]
      , G.GLineString $ mkLineString
          [ mkPosition 1.1 2.2 Nothing
          , mkPosition 4.4 5.5 Nothing
          , mkPosition 7.7 8.8 Nothing
          ]
      , G.GMultiLineString $ mkMultiLineString
          [ mkLineString
            [ mkPosition 1.1 2.2 Nothing
            , mkPosition 4.4 5.5 Nothing
            , mkPosition 7.7 8.8 Nothing
            ]
          , mkLineString
            [ mkPosition 1.1 2.2 Nothing
            , mkPosition 4.4 5.5 Nothing
            ]
          ]
      , G.GPolygon $ mkPolygon
          [ mkLinearRing
            [ mkPosition 1.1 2.2 Nothing
            , mkPosition 4.4 5.5 Nothing
            , mkPosition 7.7 8.8 Nothing
            ]
          , mkLinearRing
            [ mkPosition 1.1 2.2 Nothing
            , mkPosition 4.4 5.5 Nothing
            , mkPosition 7.7 8.8 Nothing
            , mkPosition 1.0 1.0 Nothing
            ]
          ]
      , G.GMultiPolygon $ mkMultiPolygon
          [ mkPolygon
            [ mkLinearRing
              [ mkPosition 1.1 2.2 Nothing
              , mkPosition 4.4 5.5 Nothing
              , mkPosition 7.7 8.8 Nothing
              ]
            ]
          , mkPolygon
              [ mkLinearRing
                [ mkPosition 1.1 2.2 Nothing
                , mkPosition 4.4 5.5 Nothing
                , mkPosition 7.7 8.8 Nothing
                ]
              , mkLinearRing
                [ mkPosition 1.1 2.2 Nothing
                , mkPosition 4.4 5.5 Nothing
                , mkPosition 7.7 8.8 Nothing
                , mkPosition 1.0 1.0 Nothing
                ]
              ]
          ]
      ]
    )
  ]

mkGeometryCollection :: [G.Geometry] -> G.GeometryCollection
mkGeometryCollection = G.GeometryCollection . fmap (`G.GeometryWithCRS` Nothing)

mkMultiPolygon :: [G.Polygon] -> G.MultiPolygon
mkMultiPolygon = G.MultiPolygon

mkLinearRing :: [G.Position] -> G.LinearRing
mkLinearRing (x:y:z:xs) = G.LinearRing x y z xs
mkLinearRing _          = error "mkLinearRing requires >2 points"

mkPolygon :: [G.LinearRing] -> G.Polygon
mkPolygon = G.Polygon

mkMultiLineString :: [G.LineString] -> G.MultiLineString
mkMultiLineString = G.MultiLineString

mkLineString :: [G.Position] -> G.LineString
mkLineString (x:y:xs) = G.LineString x y xs
mkLineString _        = error "mkLineString requires >1 points"

mkMultiPoint :: [G.Position] -> G.MultiPoint
mkMultiPoint = G.MultiPoint

mkPoint :: G.Position -> G.Point
mkPoint = G.Point

mkPosition :: Double -> Double -> Maybe Double -> G.Position
mkPosition = G.Position