From e43a61db10cf2d0f5668e79e7b608b096084f69e Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Tue, 25 Aug 2015 17:18:44 -0400 Subject: [PATCH 1/4] Add To/FromField for (Double, Double), point type --- src/Database/PostgreSQL/Simple/FromField.hs | 19 +++++++++++++++++++ src/Database/PostgreSQL/Simple/ToField.hs | 8 ++++++++ 2 files changed, 27 insertions(+) diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs index 03e10ee3..5d226a38 100644 --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -580,6 +580,25 @@ instance FromField a => FromField (IORef a) where instance FromField a => FromField (MVar a) where fromField f v = liftConversion . newMVar =<< fromField f v +instance FromField (Double, Double) where + fromField f v = + if typeOid f /= $(inlineTypoid TI.point) + then returnError Incompatible f "" + else case v of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case parseOnly parser bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + where + parser = do + string "(" + x <- double + string "," + y <- double + string ")" + return (x, y) + type Compat = PQ.Oid -> Bool okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs index 687f3d73..8ef93647 100644 --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -366,3 +366,11 @@ instance ToRow a => ToField (Values a) where (litC ',') rest vals + +instance ToField (Double, Double) where + toField (x, y) = Many $ + (Plain (byteString "point(")) : + (toField x) : + (Plain (char8 ',')) : + (toField y) : + [Plain (char8 ')')] From 4c37db1b86c8adab39d2a48f51ac5bce4179a6b6 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Tue, 25 Aug 2015 22:12:32 -0400 Subject: [PATCH 2/4] Geometry module with Point type Eliminates To/FromRow instances of (Double, Double), favouring instead the isomorphic Point type. --- postgresql-simple.cabal | 1 + src/Database/PostgreSQL/Simple/FromField.hs | 5 ++-- src/Database/PostgreSQL/Simple/Geometry.hs | 30 +++++++++++++++++++++ src/Database/PostgreSQL/Simple/ToField.hs | 9 ++++--- 4 files changed, 39 insertions(+), 6 deletions(-) create mode 100644 src/Database/PostgreSQL/Simple/Geometry.hs diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal index fd85e186..4965433b 100644 --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -42,6 +42,7 @@ Library Database.PostgreSQL.Simple.TypeInfo.Static Database.PostgreSQL.Simple.Types Database.PostgreSQL.Simple.Errors + Database.PostgreSQL.Simple.Geometry -- Other-modules: Database.PostgreSQL.Simple.Internal diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs index 5d226a38..f8df9ccc 100644 --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -137,6 +137,7 @@ import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI import Database.PostgreSQL.Simple.TypeInfo.Macro as TI import Database.PostgreSQL.Simple.Time import Database.PostgreSQL.Simple.Arrays as Arrays +import Database.PostgreSQL.Simple.Geometry import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 @@ -580,7 +581,7 @@ instance FromField a => FromField (IORef a) where instance FromField a => FromField (MVar a) where fromField f v = liftConversion . newMVar =<< fromField f v -instance FromField (Double, Double) where +instance FromField Point where fromField f v = if typeOid f /= $(inlineTypoid TI.point) then returnError Incompatible f "" @@ -597,7 +598,7 @@ instance FromField (Double, Double) where string "," y <- double string ")" - return (x, y) + return $ point x y type Compat = PQ.Oid -> Bool diff --git a/src/Database/PostgreSQL/Simple/Geometry.hs b/src/Database/PostgreSQL/Simple/Geometry.hs new file mode 100644 index 00000000..c37fcc3e --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Geometry.hs @@ -0,0 +1,30 @@ +{-| +Module : Database.PostgreSQL.Simple.Geometry +Description : Geometry types. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : Leon P Smith +Stability : experimental +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Database.PostgreSQL.Simple.Geometry ( + + Point + , point + , pointX + , pointY + + ) where + +data Point = Point {-# UNPACK #-} !Double {-# UNPACK #-} !Double + +point :: Double -> Double -> Point +point = Point + +pointX :: Point -> Double +pointX (Point x _) = x + +pointY :: Point -> Double +pointY (Point _ y) = y diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs index 8ef93647..75d5ce0e 100644 --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -52,6 +52,7 @@ import Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time +import Database.PostgreSQL.Simple.Geometry import Data.Scientific (Scientific) #if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) @@ -367,10 +368,10 @@ instance ToRow a => ToField (Values a) where rest vals -instance ToField (Double, Double) where - toField (x, y) = Many $ +instance ToField Point where + toField p = Many $ (Plain (byteString "point(")) : - (toField x) : + (toField $ pointX p) : (Plain (char8 ',')) : - (toField y) : + (toField $ pointY p) : [Plain (char8 ')')] From c066c622e08dbffd17f33ddd0236c1b0e3ff04a8 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Wed, 26 Aug 2015 14:44:08 -0400 Subject: [PATCH 3/4] Point is not abstract; instances in same file --- src/Database/PostgreSQL/Simple/FromField.hs | 20 --------- src/Database/PostgreSQL/Simple/Geometry.hs | 49 ++++++++++++++++++--- src/Database/PostgreSQL/Simple/ToField.hs | 9 ---- 3 files changed, 44 insertions(+), 34 deletions(-) diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs index f8df9ccc..03e10ee3 100644 --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -137,7 +137,6 @@ import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI import Database.PostgreSQL.Simple.TypeInfo.Macro as TI import Database.PostgreSQL.Simple.Time import Database.PostgreSQL.Simple.Arrays as Arrays -import Database.PostgreSQL.Simple.Geometry import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 @@ -581,25 +580,6 @@ instance FromField a => FromField (IORef a) where instance FromField a => FromField (MVar a) where fromField f v = liftConversion . newMVar =<< fromField f v -instance FromField Point where - fromField f v = - if typeOid f /= $(inlineTypoid TI.point) - then returnError Incompatible f "" - else case v of - Nothing -> returnError UnexpectedNull f "" - Just bs -> - case parseOnly parser bs of - Left err -> returnError ConversionFailed f err - Right val -> pure val - where - parser = do - string "(" - x <- double - string "," - y <- double - string ")" - return $ point x y - type Compat = PQ.Oid -> Bool okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat diff --git a/src/Database/PostgreSQL/Simple/Geometry.hs b/src/Database/PostgreSQL/Simple/Geometry.hs index c37fcc3e..9248a302 100644 --- a/src/Database/PostgreSQL/Simple/Geometry.hs +++ b/src/Database/PostgreSQL/Simple/Geometry.hs @@ -8,23 +8,62 @@ Stability : experimental -} {-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE TemplateHaskell #-} module Database.PostgreSQL.Simple.Geometry ( - Point - , point + Point(..) , pointX , pointY ) where -data Point = Point {-# UNPACK #-} !Double {-# UNPACK #-} !Double +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 hiding (Result, char8) +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Compat +import Database.PostgreSQL.Simple.Ok +import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.Simple.TypeInfo as TI +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI +import Database.PostgreSQL.Simple.TypeInfo.Macro as TI +import Data.ByteString.Builder (byteString, char8) + + -point :: Double -> Double -> Point -point = Point +data Point = Point {-# UNPACK #-} !Double {-# UNPACK #-} !Double pointX :: Point -> Double pointX (Point x _) = x pointY :: Point -> Double pointY (Point _ y) = y + +instance FromField Point where + fromField f v = + if typeOid f /= $(inlineTypoid TI.point) + then returnError Incompatible f "" + else case v of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case parseOnly parser bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + where + parser = do + string "(" + x <- double + string "," + y <- double + string ")" + return $ Point x y + +instance ToField Point where + toField p = Many $ + (Plain (byteString "point(")) : + (toField $ pointX p) : + (Plain (char8 ',')) : + (toField $ pointY p) : + [Plain (char8 ')')] diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs index 75d5ce0e..687f3d73 100644 --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -52,7 +52,6 @@ import Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time -import Database.PostgreSQL.Simple.Geometry import Data.Scientific (Scientific) #if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) @@ -367,11 +366,3 @@ instance ToRow a => ToField (Values a) where (litC ',') rest vals - -instance ToField Point where - toField p = Many $ - (Plain (byteString "point(")) : - (toField $ pointX p) : - (Plain (char8 ',')) : - (toField $ pointY p) : - [Plain (char8 ')')] From d025405802fae7c5c26b3682888c517f48367ff1 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Fri, 28 Aug 2015 14:28:43 -0400 Subject: [PATCH 4/4] Remove AutoDeriveTypeable, for GHC 7.6 compat Also derive Eq, Ord for Point --- src/Database/PostgreSQL/Simple/Geometry.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Database/PostgreSQL/Simple/Geometry.hs b/src/Database/PostgreSQL/Simple/Geometry.hs index 9248a302..8c2ad86a 100644 --- a/src/Database/PostgreSQL/Simple/Geometry.hs +++ b/src/Database/PostgreSQL/Simple/Geometry.hs @@ -7,8 +7,8 @@ Maintainer : Leon P Smith Stability : experimental -} -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} module Database.PostgreSQL.Simple.Geometry ( @@ -19,6 +19,7 @@ module Database.PostgreSQL.Simple.Geometry ( ) where import Control.Applicative +import Data.Typeable import Data.Attoparsec.ByteString.Char8 hiding (Result, char8) import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField @@ -34,6 +35,7 @@ import Data.ByteString.Builder (byteString, char8) data Point = Point {-# UNPACK #-} !Double {-# UNPACK #-} !Double + deriving (Eq, Ord, Typeable) pointX :: Point -> Double pointX (Point x _) = x