{-# LANGUAGE TemplateHaskell #-}
{-|
Module: IHP.Postgres.Polygon
Description: Adds support for the Postgres Polygon type
Copyright: (c) digitally induced GmbH, 2022
-}
module IHP.Postgres.Polygon where

import GHC.Float
import BasicPrelude

import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.FromField
import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
import           Database.PostgreSQL.Simple.TypeInfo.Macro as TI
import           Data.ByteString.Builder (byteString, char8)
import           Data.Attoparsec.ByteString.Char8 hiding (Result, char8, Parser(..))
import Data.Attoparsec.Internal.Types (Parser)
import IHP.Postgres.Point

-- | Represents a Postgres Polygon
--
-- See https://www.postgresql.org/docs/9.5/datatype-geometric.html
data Polygon = Polygon { Polygon -> [Point]
points :: [Point] }
    deriving (Polygon -> Polygon -> Bool
(Polygon -> Polygon -> Bool)
-> (Polygon -> Polygon -> Bool) -> Eq Polygon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Polygon -> Polygon -> Bool
$c/= :: Polygon -> Polygon -> Bool
== :: Polygon -> Polygon -> Bool
$c== :: Polygon -> Polygon -> Bool
Eq, Int -> Polygon -> ShowS
[Polygon] -> ShowS
Polygon -> String
(Int -> Polygon -> ShowS)
-> (Polygon -> String) -> ([Polygon] -> ShowS) -> Show Polygon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Polygon] -> ShowS
$cshowList :: [Polygon] -> ShowS
show :: Polygon -> String
$cshow :: Polygon -> String
showsPrec :: Int -> Polygon -> ShowS
$cshowsPrec :: Int -> Polygon -> ShowS
Show, Eq Polygon
Eq Polygon
-> (Polygon -> Polygon -> Ordering)
-> (Polygon -> Polygon -> Bool)
-> (Polygon -> Polygon -> Bool)
-> (Polygon -> Polygon -> Bool)
-> (Polygon -> Polygon -> Bool)
-> (Polygon -> Polygon -> Polygon)
-> (Polygon -> Polygon -> Polygon)
-> Ord Polygon
Polygon -> Polygon -> Bool
Polygon -> Polygon -> Ordering
Polygon -> Polygon -> Polygon
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Polygon -> Polygon -> Polygon
$cmin :: Polygon -> Polygon -> Polygon
max :: Polygon -> Polygon -> Polygon
$cmax :: Polygon -> Polygon -> Polygon
>= :: Polygon -> Polygon -> Bool
$c>= :: Polygon -> Polygon -> Bool
> :: Polygon -> Polygon -> Bool
$c> :: Polygon -> Polygon -> Bool
<= :: Polygon -> Polygon -> Bool
$c<= :: Polygon -> Polygon -> Bool
< :: Polygon -> Polygon -> Bool
$c< :: Polygon -> Polygon -> Bool
compare :: Polygon -> Polygon -> Ordering
$ccompare :: Polygon -> Polygon -> Ordering
$cp1Ord :: Eq Polygon
Ord)

instance FromField Polygon where
    fromField :: FieldParser Polygon
fromField Field
f Maybe ByteString
v =
        if Field -> Oid
typeOid Field
f Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
/= $(inlineTypoid TI.polygon)
        then (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion Polygon
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
Incompatible Field
f String
""
        else case Maybe ByteString
v of
               Maybe ByteString
Nothing -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion Polygon
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
UnexpectedNull Field
f String
""
               Just ByteString
bs ->
                   case Parser Polygon -> ByteString -> Either String Polygon
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Polygon
parsePolygon ByteString
bs of
                     Left  String
err -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion Polygon
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
ConversionFailed Field
f String
err
                     Right Polygon
val -> Polygon -> Conversion Polygon
forall (f :: * -> *) a. Applicative f => a -> f a
pure Polygon
val

parsePolygon :: Parser ByteString Polygon
parsePolygon :: Parser Polygon
parsePolygon = do
    ByteString -> Parser ByteString
string ByteString
"("
    [Point]
points <- Parser ByteString Point
parsePoint Parser ByteString Point
-> Parser ByteString Char -> Parser ByteString [Point]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` (Char -> Parser ByteString Char
char Char
',')
    ByteString -> Parser ByteString
string ByteString
")"
    Polygon -> Parser Polygon
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Polygon -> Parser Polygon) -> Polygon -> Parser Polygon
forall a b. (a -> b) -> a -> b
$ [Point] -> Polygon
Polygon [Point]
points

instance ToField Polygon where
    toField :: Polygon -> Action
toField = Polygon -> Action
serializePolygon

serializePolygon :: Polygon -> Action
serializePolygon :: Polygon -> Action
serializePolygon Polygon { [Point]
points :: [Point]
$sel:points:Polygon :: Polygon -> [Point]
points } = [Action] -> Action
Many ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$
    (Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"polygon'"))Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:
    ( (Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
intersperse (Builder -> Action
Plain (Builder -> Action) -> Builder -> Action
forall a b. (a -> b) -> a -> b
$ Char -> Builder
char8 Char
',') ([Action] -> [Action]) -> [Action] -> [Action]
forall a b. (a -> b) -> a -> b
$ (Point -> Action) -> [Point] -> [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Point -> Action
serializePoint' [Point]
points)
      [Action] -> [Action] -> [Action]
forall w. Monoid w => w -> w -> w
++ [ Builder -> Action
Plain (Char -> Builder
char8 Char
'\'') ])
    where
        serializePoint' :: Point -> Action
        serializePoint' :: Point -> Action
serializePoint' Point { Double
$sel:x:Point :: Point -> Double
x :: Double
x, Double
$sel:y:Point :: Point -> Double
y :: Double
y } = [Action] -> Action
Many ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$
            [ Builder -> Action
Plain (Char -> Builder
char8 Char
'(')
            , Double -> Action
forall a. ToField a => a -> Action
toField Double
x
            , Builder -> Action
Plain (Char -> Builder
char8 Char
',')
            , Double -> Action
forall a. ToField a => a -> Action
toField Double
y
            , Builder -> Action
Plain (Char -> Builder
char8 Char
')')
            ]