{-# LANGUAGE OverloadedStrings#-} {-# LANGUAGE DeriveFunctor #-} module Data.WKT.Polygon (module Data.WKT.Polygon) where import Data.WKT.Classes import Data.WKT.Point import Data.WKT.LineString import Data.List (intercalate) import Data.WKT.Helpers (generateZMString, zmParser) import Data.Text (pack, Text) import Data.Attoparsec.Text (parseOnly, skipSpace, asciiCI, Parser) import Control.Applicative ((<|>)) newtype Polygon a = Polygon [LineString a] deriving ((forall a b. (a -> b) -> Polygon a -> Polygon b) -> (forall a b. a -> Polygon b -> Polygon a) -> Functor Polygon forall a b. a -> Polygon b -> Polygon a forall a b. (a -> b) -> Polygon a -> Polygon 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) -> Polygon a -> Polygon b fmap :: forall a b. (a -> b) -> Polygon a -> Polygon b $c<$ :: forall a b. a -> Polygon b -> Polygon a <$ :: forall a b. a -> Polygon b -> Polygon a Functor, Polygon a -> Polygon a -> Bool (Polygon a -> Polygon a -> Bool) -> (Polygon a -> Polygon a -> Bool) -> Eq (Polygon a) forall a. Eq a => Polygon a -> Polygon a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: forall a. Eq a => Polygon a -> Polygon a -> Bool == :: Polygon a -> Polygon a -> Bool $c/= :: forall a. Eq a => Polygon a -> Polygon a -> Bool /= :: Polygon a -> Polygon a -> Bool Eq) instance Show a => Show (Polygon a) where show :: Polygon a -> String show (Polygon [LineString a] polygon) = String -> [String] -> String forall a. [a] -> [[a]] -> [a] intercalate String ", " [String] rings where rings :: [String] rings = (LineString a -> String) -> [LineString a] -> [String] forall a b. (a -> b) -> [a] -> [b] map (\(LineString [Point a] ring) -> String "(" String -> ShowS forall a. Semigroup a => a -> a -> a <> String -> [String] -> String forall a. [a] -> [[a]] -> [a] intercalate String ", " (Point a -> String forall a. Show a => a -> String show (Point a -> String) -> [Point a] -> [String] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Point a] ring) String -> ShowS forall a. Semigroup a => a -> a -> a <> String ")") [LineString a] polygon instance Show a => ToWKT (Polygon a) where toWKT :: Polygon a -> Text toWKT Polygon a polygon = Text "Polygon" 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 <> String -> Text pack (Polygon a -> String forall a. Show a => a -> String show Polygon a polygon) Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ")" where Polygon [LineString a] rings = Polygon a polygon (LineString [Point a] firstLine) = [LineString a] -> LineString a forall a. HasCallStack => [a] -> a head [LineString a] rings first :: Point a first = [Point a] -> Point a forall a. HasCallStack => [a] -> a head [Point a] firstLine 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 (Polygon a) where isValid :: Polygon a -> Bool isValid (Polygon [LineString a] lines') = Bool validLines Bool -> Bool -> Bool && Bool validPolygon where validLines :: Bool validLines = (LineString a -> Bool) -> [LineString a] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all LineString a -> Bool forall a. Valid a => a -> Bool isValid [LineString a] lines' validPolygon :: Bool validPolygon = (LineString a -> Bool) -> [LineString a] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all (\(LineString [Point a] line) -> [Point a] -> Point a forall a. HasCallStack => [a] -> a head [Point a] line Point a -> Point a -> Bool forall a. Eq a => a -> a -> Bool == [Point a] -> Point a forall a. HasCallStack => [a] -> a last [Point a] line) [LineString a] lines' instance FromWKT Polygon where fromWKT :: Text -> Polygon Double fromWKT = (String -> Polygon Double) -> (Polygon Double -> Polygon Double) -> Either String (Polygon Double) -> Polygon Double forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (String -> Polygon Double forall a. HasCallStack => String -> a error (String -> Polygon Double) -> ShowS -> String -> Polygon Double forall b c a. (b -> c) -> (a -> b) -> a -> c . ShowS forall a. Show a => a -> String show) Polygon Double -> Polygon Double forall a. a -> a id (Either String (Polygon Double) -> Polygon Double) -> (Text -> Either String (Polygon Double)) -> Text -> Polygon Double forall b c a. (b -> c) -> (a -> b) -> a -> c . Parser (Polygon Double) -> Text -> Either String (Polygon Double) forall a. Parser a -> Text -> Either String a parseOnly Parser (Polygon Double) forall (a :: * -> *). ParseableFromWKT a => Parser (a Double) wktParser instance ParseableFromWKT Polygon where wktParser :: Parser (Polygon Double) wktParser = do Parser () skipSpace Text _ <- Text -> Parser Text Text asciiCI Text "POLYGON" (Text zFlag, Text mFlag) <- Parser (Text, Text) zmParser Text _ <- Parser Text Text "(" Text -> Text -> Parser (Polygon Double) parsePolygon Text zFlag Text mFlag parsePolygon :: Text -> Text -> Parser (Polygon Double) parsePolygon :: Text -> Text -> Parser (Polygon Double) parsePolygon Text zFlag Text mFlag = [LineString Double] -> Polygon Double forall a. [LineString a] -> Polygon a Polygon ([LineString Double] -> Polygon Double) -> Parser Text [LineString Double] -> Parser (Polygon Double) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Text -> Text -> Parser Text [LineString Double] ringsParser Text zFlag Text mFlag where ringsParser :: Text -> Text -> Parser Text [LineString Double] ringsParser Text zFlag' Text mFlag' = do Parser () skipSpace Text _ <- Parser Text Text "(" LineString Double newRing <- Text -> Text -> Parser (LineString Double) parseLineString Text zFlag' Text mFlag' 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 [LineString Double] -> Parser Text [LineString Double] forall a. a -> Parser Text a forall (m :: * -> *) a. Monad m => a -> m a return [LineString Double newRing] else do (LineString Double newRing LineString Double -> [LineString Double] -> [LineString Double] forall a. a -> [a] -> [a] :) ([LineString Double] -> [LineString Double]) -> Parser Text [LineString Double] -> Parser Text [LineString Double] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Parser Text Text "," Parser Text Text -> Parser Text [LineString Double] -> Parser Text [LineString 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 *> Text -> Text -> Parser Text [LineString Double] ringsParser Text zFlag' Text mFlag')