diff --git a/haskell-postgis.cabal b/haskell-postgis.cabal --- a/haskell-postgis.cabal +++ b/haskell-postgis.cabal @@ -2,9 +2,9 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: haskell-postgis -version: 0.1.0.1 +version: 0.1.0.2 synopsis: A haskell library for PostGIS geometry types. -description: A haskell library for PostGIS geometry types. +description: A collection of types and parsers to use with the PostGIS extesion to PostgreSQL. license: MIT license-file: LICENSE author: Peter diff --git a/src/Database/Postgis.hs b/src/Database/Postgis.hs --- a/src/Database/Postgis.hs +++ b/src/Database/Postgis.hs @@ -6,7 +6,20 @@ , writeGeometry ) where -import Database.Postgis.Geometry -import Database.Postgis.Serialize +import Database.Postgis.Geometry ( + SRID, + Point(..), + LineString(..), + LinearRing, + Polygon(..), + MultiPoint(..), + MultiLineString(..), + MultiPolygon(..), + Geometry(..) + ) +import Database.Postgis.Serialize ( + writeGeometry, + readGeometry + ) diff --git a/src/Database/Postgis/Geometry.hs b/src/Database/Postgis/Geometry.hs --- a/src/Database/Postgis/Geometry.hs +++ b/src/Database/Postgis/Geometry.hs @@ -1,9 +1,12 @@ {-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} module Database.Postgis.Geometry where import qualified Data.Vector as V import Data.Word +import Data.Data +import Data.Typeable {-Linear rings—Rings are simple and closed, which means that linear rings may not self intersect.-} @@ -18,15 +21,14 @@ hasM :: a -> Bool hasZ :: a -> Bool geoType :: a -> Word32 - {-geometry :: a -> InnerGeo-} data Point = Point { - _x :: {-# UNPACK #-} !Double - , _y :: {-# UNPACK #-} !Double + _x :: Double + , _y :: Double , _z :: Maybe Double , _m :: Maybe Double -} deriving (Show, Eq) +} deriving (Data, Typeable, Show, Eq) instance EWKBGeometry Point where hasM (Point x y z m) = m /= Nothing @@ -39,7 +41,7 @@ isClosed v = V.head v == V.last v -data LineString = LineString (V.Vector Point) deriving (Show, Eq) +data LineString = LineString (V.Vector Point) deriving (Data, Typeable, Show, Eq) instance EWKBGeometry LineString where @@ -47,7 +49,7 @@ hasZ (LineString ps) = hasZ . V.head $ ps geoType _ = 2 -data Polygon = Polygon (V.Vector LinearRing) deriving (Show, Eq) +data Polygon = Polygon (V.Vector LinearRing) deriving (Data, Typeable, Show, Eq) hasMLinearRing :: LinearRing -> Bool hasMLinearRing = hasM . V.head @@ -60,21 +62,21 @@ hasZ (Polygon ps) = hasZLinearRing . V.head $ ps geoType _ = 3 -data MultiPoint = MultiPoint (V.Vector Point) deriving (Show, Eq) +data MultiPoint = MultiPoint (V.Vector Point) deriving (Data, Typeable, Show, Eq) instance EWKBGeometry MultiPoint where hasM (MultiPoint ps) = hasM . V.head $ ps hasZ (MultiPoint ps) = hasZ . V.head $ ps geoType _ = 4 -data MultiLineString = MultiLineString (V.Vector LineString) deriving (Show, Eq) +data MultiLineString = MultiLineString (V.Vector LineString) deriving (Data, Typeable, Show, Eq) instance EWKBGeometry MultiLineString where hasM (MultiLineString ps) = hasM . V.head $ ps hasZ (MultiLineString ps) = hasZ . V.head $ ps geoType _ = 5 -data MultiPolygon = MultiPolygon (V.Vector Polygon) deriving (Show, Eq) +data MultiPolygon = MultiPolygon (V.Vector Polygon) deriving (Data, Typeable, Show, Eq) instance EWKBGeometry MultiPolygon where hasM (MultiPolygon ps) = hasM . V.head $ ps @@ -96,4 +98,4 @@ | GeoPolygon SRID Polygon | GeoMultiLineString SRID MultiLineString | GeoMultiPoint SRID MultiPoint - | GeoMultiPolygon SRID MultiPolygon deriving (Show, Eq) + | GeoMultiPolygon SRID MultiPolygon deriving (Data, Typeable, Show, Eq) diff --git a/src/Database/Postgis/JSON.hs b/src/Database/Postgis/JSON.hs --- a/src/Database/Postgis/JSON.hs +++ b/src/Database/Postgis/JSON.hs @@ -103,10 +103,12 @@ sridToJson srid = object ["type" .= ("name" :: T.Text), "properties" .= object ["name" .= ("ESPG:" <> (show srid) :: String)] ] + parseCRS :: Value -> Parser (Maybe Int) parseCRS = withObject "crs" $ \o -> do - ("name" :: T.Text) <- o .: "type" - prop <- o .: "prop" + crs <- o .: "crs" + ("name"::T.Text) <- crs .: "type" + prop <- crs .: "properties" espg <- prop .: "name" let (x:y:xs) = T.split ((==) ':') espg case decimal y of @@ -115,7 +117,7 @@ instance FromJSON Geometry where - parseJSON o + parseJSON o = GeoPoint <$> parseCRS o <*> parseJSON o <|> GeoLineString <$> parseCRS o <*> parseJSON o <|> GeoPolygon <$> parseCRS o <*> parseJSON o diff --git a/src/Database/Postgis/Serialize.hs b/src/Database/Postgis/Serialize.hs --- a/src/Database/Postgis/Serialize.hs +++ b/src/Database/Postgis/Serialize.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies, GADTs, FlexibleInstances, OverloadedStrings #-} -module Database.Postgis.Serialize where +module Database.Postgis.Serialize where import Database.Postgis.Geometry import Data.ByteString.Lex.Integral @@ -209,7 +209,7 @@ getHeader :: Get Header getHeader = do - or <- get + or <- get t <- fromIntegral <$> getInt' or s <- if t .&. wkbSRID > 0 then (Just . fromIntegral) <$> getInt' or else return Nothing return $ Header or t s diff --git a/tests/GeoSpec.hs b/tests/GeoSpec.hs --- a/tests/GeoSpec.hs +++ b/tests/GeoSpec.hs @@ -33,19 +33,15 @@ it "should convert ByteString to Endianness" $ do fromHex be `shouldBe` BigEndian fromHex le `shouldBe` LittleEndian - {-it "should convert int32 to a hex ByteString" $ do-} - {-describe "parseGeometry" $ do-} it "Should correctly parse a bytestring into a Point" $ do readGeometry point1BS `shouldBe` point1 it "Should parse a bytestring into a LineString" $ do readGeometry linestring1BS `shouldBe` linestring1 - {-describe "writeGeometry" $ do-} it "Should correctly write a Point into a bytestring" $ do (toUpperBS $ writeGeometry point1) `shouldBe` point1BS it "Should write a LineString into a bytestring" $ do (toUpperBS $ writeGeometry linestring1) `shouldBe` linestring1BS - {-describe "Json" $ do-} it "Encodes a linestring" $ do encode linestring1 `shouldBe` linestringJSON