{-# 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
type SRID = Maybe Int
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
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
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)
class Typeable a => Geometry a where
putGeometry :: Putter a
getGeometry :: Get a
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)
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
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