{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification                            #-}
{-# LANGUAGE InstanceSigs #-}

module Database.Postgis.Trivial.Types
    ( SRID
    , PointND (..)
    , Putter
    , Getter
    , Geo (..)
    , Geometry (..)
    , GeometryError (..)
    ) where

import GHC.Base
import GHC.Show ( Show(..), ShowS )
import Control.Monad.Reader ( ReaderT )
import Control.Exception ( SomeException, Exception(..) )
import Data.Typeable ( Typeable, cast )
import Data.Binary ( Get, Put )
import Data.Binary.Get ( runGet )
import Data.Binary.Put ( runPut )
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.FromField


-- | Spatial reference identifier
type SRID = Maybe Int

-- | Inner point type class
class Typeable a => PointND a where
    dimProps :: (Bool, Bool)
    components :: a -> (Double, Double, Maybe Double, Maybe Double)
    fromComponents :: (Double, Double, Maybe Double, Maybe Double) -> a

-- | Binary putter
type Putter a = a -> Put

writeEWKB :: Putter a -> a -> BS.ByteString
writeEWKB :: forall a. Putter a -> a -> ByteString
writeEWKB Putter a
putter = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> Putter a -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Putter a
putter

-- | Binary getter
type Getter h = ReaderT h Get

readEWKB :: Get a -> BS.ByteString -> a
readEWKB :: forall a. Get a -> ByteString -> a
readEWKB Get a
getter ByteString
bs = Get a -> ByteString -> a
forall a. Get a -> ByteString -> a
runGet Get a
getter (ByteString -> ByteString
BL.fromStrict ByteString
bs)

-- | Type class which defines geometry to/from binary form convertions
class Typeable a => Geometry a where
    putGeometry :: Putter a
    getGeometry :: Get a

-- | Wrapper for geomety types (prevents collisions with default instances)
newtype Geo g = Geo g

instance Geometry g => ToField (Geo g) where
    toField :: Geo g -> Action
toField (Geo g
g) = ByteString -> Action
Escape (ByteString -> Action) -> (g -> ByteString) -> g -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Putter g -> g -> ByteString
forall a. Putter a -> a -> ByteString
writeEWKB Putter g
forall a. Geometry a => Putter a
putGeometry (g -> Action) -> g -> Action
forall a b. (a -> b) -> a -> b
$ g
g

instance Geometry g => FromField (Geo g) where
    fromField :: FieldParser (Geo g)
fromField Field
f Maybe ByteString
m = do
        ByteString
typ <- Field -> Conversion ByteString
typename Field
f
        if ByteString
typ ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"geometry"
            then (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion (Geo g)
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 (ByteString -> String
forall a. Show a => a -> String
show ByteString
typ)
            else case Maybe ByteString
m of
                Maybe ByteString
Nothing  -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion (Geo g)
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 -> Geo g -> Conversion (Geo g)
forall a. a -> Conversion a
forall (m :: * -> *) a. Monad m => a -> m a
return (Geo g -> Conversion (Geo g)) -> Geo g -> Conversion (Geo g)
forall a b. (a -> b) -> a -> b
$ g -> Geo g
forall g. g -> Geo g
Geo (Get g -> ByteString -> g
forall a. Get a -> ByteString -> a
readEWKB Get g
forall a. Geometry a => Get a
getGeometry ByteString
bs)

-- | Geometry exceptions
data SomeGeometryException = forall e. Exception e => SomeGeometryException e
    deriving Typeable

geometryExceptionToException :: Exception e => e -> SomeException
geometryExceptionToException :: forall e. Exception e => e -> SomeException
geometryExceptionToException = SomeGeometryException -> SomeException
forall e. Exception e => e -> SomeException
toException (SomeGeometryException -> SomeException)
-> (e -> SomeGeometryException) -> e -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeGeometryException
forall e. Exception e => e -> SomeGeometryException
SomeGeometryException

geometryExceptionFromException :: Exception e => SomeException -> Maybe e
geometryExceptionFromException :: forall e. Exception e => SomeException -> Maybe e
geometryExceptionFromException SomeException
x = do
    SomeGeometryException e
a <- SomeException -> Maybe SomeGeometryException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
    e -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
a

instance Show SomeGeometryException where
    showsPrec :: Int -> SomeGeometryException -> ShowS
    showsPrec :: Int -> SomeGeometryException -> ShowS
showsPrec Int
p (SomeGeometryException e
e) = Int -> e -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p e
e

instance Exception SomeGeometryException where
    displayException :: SomeGeometryException -> String
displayException (SomeGeometryException e
e) = e -> String
forall e. Exception e => e -> String
displayException e
e

-- | Exception for operations with geometries
newtype GeometryError = GeometryError {
    GeometryError -> String
geoMessage :: String
    } deriving (GeometryError -> GeometryError -> Bool
(GeometryError -> GeometryError -> Bool)
-> (GeometryError -> GeometryError -> Bool) -> Eq GeometryError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GeometryError -> GeometryError -> Bool
== :: GeometryError -> GeometryError -> Bool
$c/= :: GeometryError -> GeometryError -> Bool
/= :: GeometryError -> GeometryError -> Bool
Eq, Int -> GeometryError -> ShowS
[GeometryError] -> ShowS
GeometryError -> String
(Int -> GeometryError -> ShowS)
-> (GeometryError -> String)
-> ([GeometryError] -> ShowS)
-> Show GeometryError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GeometryError -> ShowS
showsPrec :: Int -> GeometryError -> ShowS
$cshow :: GeometryError -> String
show :: GeometryError -> String
$cshowList :: [GeometryError] -> ShowS
showList :: [GeometryError] -> ShowS
Show, Typeable)

instance Exception GeometryError where
  toException :: GeometryError -> SomeException
toException = GeometryError -> SomeException
forall e. Exception e => e -> SomeException
geometryExceptionToException
  fromException :: SomeException -> Maybe GeometryError
fromException = SomeException -> Maybe GeometryError
forall e. Exception e => SomeException -> Maybe e
geometryExceptionFromException