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/Geometry.hs b/src/Database/PostgreSQL/Simple/Geometry.hs new file mode 100644 index 00000000..8c2ad86a --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Geometry.hs @@ -0,0 +1,71 @@ +{-| +Module : Database.PostgreSQL.Simple.Geometry +Description : Geometry types. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : Leon P Smith +Stability : experimental +-} + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Database.PostgreSQL.Simple.Geometry ( + + Point(..) + , pointX + , pointY + + ) 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 +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) + + + +data Point = Point {-# UNPACK #-} !Double {-# UNPACK #-} !Double + deriving (Eq, Ord, Typeable) + +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 ')')]