{-# LANGUAGE OverloadedStrings#-}
{-# LANGUAGE DeriveFunctor #-}

module Data.WKT.GeometryCollection (module Data.WKT.GeometryCollection) where

import Data.WKT.Classes
import Data.WKT.Primitives
import Data.WKT.LineString
import Data.WKT.Triangle
import Data.WKT.Polygon
import Data.WKT.Point
import Data.WKT.Helpers (generateZMString)
import Data.List (intercalate)
import qualified Data.Text as T
import Data.Attoparsec.Text (parseOnly, Parser, skipSpace)
import Control.Applicative ((<|>))

newtype GeometryCollection a =  GeometryCollection [Primitives a]
    deriving ((forall a b.
 (a -> b) -> GeometryCollection a -> GeometryCollection b)
-> (forall a b. a -> GeometryCollection b -> GeometryCollection a)
-> Functor GeometryCollection
forall a b. a -> GeometryCollection b -> GeometryCollection a
forall a b.
(a -> b) -> GeometryCollection a -> GeometryCollection b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b.
(a -> b) -> GeometryCollection a -> GeometryCollection b
fmap :: forall a b.
(a -> b) -> GeometryCollection a -> GeometryCollection b
$c<$ :: forall a b. a -> GeometryCollection b -> GeometryCollection a
<$ :: forall a b. a -> GeometryCollection b -> GeometryCollection a
Functor, GeometryCollection a -> GeometryCollection a -> Bool
(GeometryCollection a -> GeometryCollection a -> Bool)
-> (GeometryCollection a -> GeometryCollection a -> Bool)
-> Eq (GeometryCollection a)
forall a.
Eq a =>
GeometryCollection a -> GeometryCollection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
GeometryCollection a -> GeometryCollection a -> Bool
== :: GeometryCollection a -> GeometryCollection a -> Bool
$c/= :: forall a.
Eq a =>
GeometryCollection a -> GeometryCollection a -> Bool
/= :: GeometryCollection a -> GeometryCollection a -> Bool
Eq)

instance Show a => Show (GeometryCollection a) where
    show :: GeometryCollection a -> String
show (GeometryCollection [Primitives a]
collection) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Primitives a -> String
forall a. Show a => a -> String
show (Primitives a -> String) -> [Primitives a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Primitives a]
collection)

instance Show a => ToWKT (GeometryCollection a) where
    toWKT :: GeometryCollection a -> Text
toWKT (GeometryCollection [Primitives a]
collection) = Text
"GeometryCollection" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
zmString Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"( " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (Primitives a -> Text
forall a. ToWKT a => a -> Text
toWKT (Primitives a -> Text) -> [Primitives a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Primitives a]
collection) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        where
            first :: Point a
first = case [Primitives a] -> Primitives a
forall a. HasCallStack => [a] -> a
head [Primitives a]
collection of
                PrimPoint Point a
a                 -> Point a
a
                PrimLine (LineString [Point a]
a)     -> [Point a] -> Point a
forall a. HasCallStack => [a] -> a
head [Point a]
a
                PrimTriangle (Triangle [Point a]
a)   -> [Point a] -> Point a
forall a. HasCallStack => [a] -> a
head [Point a]
a
                PrimPolygon (Polygon [LineString a]
a)     -> (\(LineString [Point a]
a') -> [Point a] -> Point a
forall a. HasCallStack => [a] -> a
head [Point a]
a') (LineString a -> Point a) -> LineString a -> Point a
forall a b. (a -> b) -> a -> b
$ [LineString a] -> LineString a
forall a. HasCallStack => [a] -> a
head [LineString a]
a
            z' :: Maybe a
z' = Point a -> Maybe a
forall a. Point a -> Maybe a
z Point a
first
            m' :: Maybe a
m' = Point a -> Maybe a
forall a. Point a -> Maybe a
m Point a
first

            zmString :: Text
zmString = Maybe a -> Maybe a -> Text
forall a. Maybe a -> Maybe a -> Text
generateZMString Maybe a
z' Maybe a
m'

instance Eq a => Valid (GeometryCollection a) where
    isValid :: GeometryCollection a -> Bool
isValid (GeometryCollection [Primitives a]
collection') = (Primitives a -> Bool) -> [Primitives a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Primitives a -> Bool
forall a. Valid a => a -> Bool
isValid [Primitives a]
collection'

instance FromWKT GeometryCollection where
    fromWKT :: Text -> GeometryCollection Double
fromWKT = (String -> GeometryCollection Double)
-> (GeometryCollection Double -> GeometryCollection Double)
-> Either String (GeometryCollection Double)
-> GeometryCollection Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> GeometryCollection Double
forall a. HasCallStack => String -> a
error (String -> GeometryCollection Double)
-> ShowS -> String -> GeometryCollection Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. Show a => a -> String
show) GeometryCollection Double -> GeometryCollection Double
forall a. a -> a
id (Either String (GeometryCollection Double)
 -> GeometryCollection Double)
-> (Text -> Either String (GeometryCollection Double))
-> Text
-> GeometryCollection Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (GeometryCollection Double)
-> Text -> Either String (GeometryCollection Double)
forall a. Parser a -> Text -> Either String a
parseOnly Parser (GeometryCollection Double)
forall (a :: * -> *). ParseableFromWKT a => Parser (a Double)
wktParser

instance ParseableFromWKT GeometryCollection where
    wktParser :: Parser (GeometryCollection Double)
wktParser = do
        Text
_ <- Parser Text Text
"GEOMETRYCOLLECTION"
        -- (zFlag, mFlag) <- zmParser -- unsure? is ZM an internal or external flag?
        Text
_ <- Parser Text Text
"("
        [Primitives Double] -> GeometryCollection Double
forall a. [Primitives a] -> GeometryCollection a
GeometryCollection ([Primitives Double] -> GeometryCollection Double)
-> Parser Text [Primitives Double]
-> Parser (GeometryCollection Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text [Primitives Double]
primitivesParser
            where
                primitivesParser :: Parser Text [Primitives Double]
primitivesParser = do
                    Parser ()
skipSpace
                    Primitives Double
primitive <- Parser (Primitives Double)
forall (a :: * -> *). ParseableFromWKT a => Parser (a Double)
wktParser :: Parser (Primitives Double)
                    Parser ()
skipSpace
                    Text
closing <- Parser Text Text
")" Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
""
                    if Text
closing Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"" then
                        [Primitives Double] -> Parser Text [Primitives Double]
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return [Primitives Double
primitive]
                    else do
                        (Primitives Double
primitive Primitives Double -> [Primitives Double] -> [Primitives Double]
forall a. a -> [a] -> [a]
:) ([Primitives Double] -> [Primitives Double])
-> Parser Text [Primitives Double]
-> Parser Text [Primitives Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Text
"," Parser Text Text
-> Parser Text [Primitives Double]
-> Parser Text [Primitives Double]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text [Primitives Double]
primitivesParser)