{-# LANGUAGE TemplateHaskell #-}
{-|
Module: IHP.Postgres.Point
Description: Adds support for the Postgres Point type
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Postgres.Point 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 Data.Aeson

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

instance FromField Point where
    fromField :: FieldParser Point
fromField Field
f Maybe ByteString
v =
        if Field -> Oid
typeOid Field
f Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
/= $(inlineTypoid TI.point)
        then (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion Point
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 Point
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 Point -> ByteString -> Either String Point
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Point
parsePoint ByteString
bs of
                     Left  String
err -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion Point
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 Point
val -> Point -> Conversion Point
forall (f :: * -> *) a. Applicative f => a -> f a
pure Point
val

parsePoint :: Parser ByteString Point
parsePoint :: Parser Point
parsePoint = do
    ByteString -> Parser ByteString
string ByteString
"("
    Double
x <- Parser ByteString Double
doubleOrNaN
    ByteString -> Parser ByteString
string ByteString
","
    Double
y <- Parser ByteString Double
doubleOrNaN
    ByteString -> Parser ByteString
string ByteString
")"
    Point -> Parser Point
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point -> Parser Point) -> Point -> Parser Point
forall a b. (a -> b) -> a -> b
$ Point :: Double -> Double -> Point
Point { Double
x :: Double
$sel:x:Point :: Double
x, Double
y :: Double
$sel:y:Point :: Double
y }
        where
            -- Postgres supports storing NaN inside a point, so we have to deal
            -- with that here as well
            doubleOrNaN :: Parser ByteString Double
doubleOrNaN = Parser ByteString Double
double Parser ByteString Double
-> Parser ByteString Double -> Parser ByteString Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Parser ByteString
string ByteString
"NaN" Parser ByteString
-> Parser ByteString Double -> Parser ByteString Double
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Double -> Parser ByteString Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Parser ByteString Double)
-> Double -> Parser ByteString Double
forall a b. (a -> b) -> a -> b
$ Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0))


instance ToField Point where
    toField :: Point -> Action
toField = Point -> Action
serializePoint

serializePoint :: Point -> Action
serializePoint :: Point -> Action
serializePoint Point { Double
x :: Double
$sel:x:Point :: Point -> Double
x, Double
y :: Double
$sel:y:Point :: Point -> Double
y } = [Action] -> Action
Many
    [ Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"point(")
    , 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
')')
    ]


instance FromJSON Point where
    parseJSON :: Value -> Parser Point
parseJSON = String -> (Object -> Parser Point) -> Value -> Parser Point
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Point" ((Object -> Parser Point) -> Value -> Parser Point)
-> (Object -> Parser Point) -> Value -> Parser Point
forall a b. (a -> b) -> a -> b
$ \Object
v -> Double -> Double -> Point
Point
        (Double -> Double -> Point)
-> Parser Double -> Parser (Double -> Point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Double
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"x"
        Parser (Double -> Point) -> Parser Double -> Parser Point
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Double
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"y"

instance ToJSON Point where
    toJSON :: Point -> Value
toJSON Point { Double
x :: Double
$sel:x:Point :: Point -> Double
x, Double
y :: Double
$sel:y:Point :: Point -> Double
y } = [Pair] -> Value
object [ Text
"x" Text -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Double
x, Text
"y" Text -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Double
y ]