postgis-trivial (empty) → 0.0.1.0

raw patch · 24 files changed

+2559/−0 lines, 24 filesdep +HUnitdep +basedep +binarysetup-changed

Dependencies added: HUnit, base, binary, bytestring, bytestring-lexing, containers, cpu, data-binary-ieee754, mtl, postgis-trivial, postgresql-simple, storable-record, vector

Files

ChangeLog.md +3/−0
LICENSE +28/−0
README.md +63/−0
Setup.hs +2/−0
include/pgisConst.h +35/−0
package.yaml +92/−0
postgis-trivial.cabal +108/−0
src/Database/Postgis/Trivial.hs +35/−0
src/Database/Postgis/Trivial/Cast.hs +77/−0
src/Database/Postgis/Trivial/Internal.hs +237/−0
src/Database/Postgis/Trivial/PGISConst.hsc +29/−0
src/Database/Postgis/Trivial/Storable.hs +50/−0
src/Database/Postgis/Trivial/Storable/Geometry.hs +204/−0
src/Database/Postgis/Trivial/Storable/PointND.hs +164/−0
src/Database/Postgis/Trivial/Traversable/Geometry.hs +181/−0
src/Database/Postgis/Trivial/Traversable/PointND.hs +87/−0
src/Database/Postgis/Trivial/Types.hs +103/−0
src/Database/Postgis/Trivial/Unboxed.hs +29/−0
src/Database/Postgis/Trivial/Unboxed/Geometry.hs +204/−0
src/Database/Postgis/Trivial/Unboxed/PointND.hs +315/−0
test/Spec.hs +73/−0
test/Tests/Storable.hs +151/−0
test/Tests/Traversable.hs +186/−0
test/Tests/Unboxed.hs +103/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2024, Igor Chudaev++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,63 @@+# postgis-trivial++Haskell Postgresql/PostGIS DB Driver++This library provides methods which allow direct use of user-defined Haskell data with Postgresql/PostGIS databases. It is based on [postgresql-simple](https://hackage.haskell.org/package/postgresql-simple) and can be used with other postgresql-simple capabilities.++The main interface module `Database.PostGIS.Trivial` allows PostGIS to work with geospatial (point) data enclosed in `Traversable` data structures. If the most inner data structures are `Unboxed` vectors, then use the functions and types defined in `Database.PostGIS.Trivial.Unboxed`. And, if the most inner data structures are `Storable` vectors then use `Database.PostGIS.Trivial.Storable` module.++## Synopsis++### Default types++- P2D for 2D points++- P3DZ, P3DM for 3D points++- P4D for points with z and m coordinates++You can freely use them for your data. Unboxed and Storable types are in the corresponding modules (thay have appending 'U' and 'S' letters in names).++### User-defined types++Ensure that user geometry data points is correctly translated into the internal default points data as in the example.++```haskell+{-# LANGUAGE TypeFamilies #-}++data LatLon =       -- example of 2D geospatial point data+        LatLon !Double !Double+        deriving (Show, Eq)++type instance Cast LatLon = P2D     -- translation to inner 2D point++instance Castable LatLon where      -- specify translation+    toPointND (LatLon y x) = Point2D x y+    fromPointND (Point2D x y) = LatLon y x+```++Then a structure of type `Traversable t => t LatLon` can be interpreted as `LineString` or `MultiPoint`. Any structure of type+`(Traversable t1, Traversable t2) => t2 (t1 LatLon)` can be interpreted as `Polygon` or `MultiLineString`. And any structure of type+`(Traversable t1, Traversable t2, Traversable t3) => t3 (t2 (t1 LatLon))` can be interpreted as `MultiPolygon`. Currently, only following `Traversable`s are supported: `List`, `Data.Vector.Vector`. `Data.IntMap.IntMap` and `Data.Map.Map` have partial support.++By this way you can use these structures in postgresql-simple functions as such:++```haskell+    ls = [LatLon 1 2, LatLon 1.5 2.5, LatLon 2.5 3, LatLon 1 2]+    _ <- execute conn "INSERT INTO linestrings (geom) VALUES (?)"+        (Only (Geo (LineString srid ls)))+    [Only res] <- query_ conn "SELECT * FROM linestrings LIMIT 1"+    let Geo (LineString srid' ls') = res+```++Or the same with suitable helper functions:++```haskell+    _ <- execute conn "INSERT INTO linestrings (geom) VALUES (?)"+        (Only (putLS srid ls))+    [Only res] <- query_ conn "SELECT * FROM linestrings LIMIT 1"+    let (srid', ls') = getLS res+```+++

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ include/pgisConst.h view

@@ -0,0 +1,35 @@+/* -----------------------------------------------------------------------------+ *+ * LWTYPE numbers, used internally by PostGIS+ *+ * ---------------------------------------------------------------------------*/++#define POINTTYPE                1+#define LINETYPE                 2+#define POLYGONTYPE              3+#define MULTIPOINTTYPE           4+#define MULTILINETYPE            5+#define MULTIPOLYGONTYPE         6+#define COLLECTIONTYPE           7+#define CIRCSTRINGTYPE           8+#define COMPOUNDTYPE             9+#define CURVEPOLYTYPE           10+#define MULTICURVETYPE          11+#define MULTISURFACETYPE        12+#define POLYHEDRALSURFACETYPE   13+#define TRIANGLETYPE            14+#define TINTYPE                 15+#define NUMTYPES                16++/* -----------------------------------------------------------------------------+ *+ * Flags applied in EWKB to indicate Z/M dimensions and+ * presence/absence of SRID and bounding boxes+ *+ * ---------------------------------------------------------------------------*/++#define WKBZOFFSET  0x80000000+#define WKBMOFFSET  0x40000000+#define WKBSRIDFLAG 0x20000000+#define WKBBBOXFLAG 0x10000000+

+ package.yaml view

@@ -0,0 +1,92 @@+name:       postgis-trivial+version:    0.0.1.0+github:     "igor720/postgis-trivial"+license:    BSD3+author:     "Igor Chudaev"+maintainer: "igor720@gmail.com"++extra-source-files:+- README.md+- ChangeLog.md+- package.yaml+- include/pgisConst.h++# Metadata used when publishing your package+synopsis:   PostGIS extention driver based on postgresql-simple package+category:   Database driver++# To avoid duplicated efforts in documentation and dealing with the+# complications of embedding Haddock markup inside cabal files, it is+# common to point users to the README.md file.+description: Please see the README on GitHub at <https://github.com/igor720/postgis-trivial#README.md>++dependencies:+  - base >= 4.7 && < 5+  - binary >= 0.7 && < 0.9+  - bytestring > 0.9 && < 0.12+  - bytestring-lexing >= 0.4 && < 0.6+  - containers >= 0.6 && < 0.7+  - cpu >= 0.1 && < 0.2+  - data-binary-ieee754 >= 0.4 && < 0.5+  - mtl >= 2.1 && < 2.4+  - postgresql-simple >= 0.6 && < 0.8+  - storable-record >= 0.0 && < 0.1+  - vector >= 0.12 && < 0.14++library:+  exposed-modules:+    - Database.Postgis.Trivial+    - Database.Postgis.Trivial.Types+    - Database.Postgis.Trivial.Cast+    - Database.Postgis.Trivial.Traversable.PointND+    - Database.Postgis.Trivial.Traversable.Geometry+    - Database.Postgis.Trivial.Unboxed+    - Database.Postgis.Trivial.Unboxed.PointND+    - Database.Postgis.Trivial.Unboxed.Geometry+    - Database.Postgis.Trivial.Storable+    - Database.Postgis.Trivial.Storable.PointND+    - Database.Postgis.Trivial.Storable.Geometry+  other-modules:+    - Database.Postgis.Trivial.PGISConst+    - Database.Postgis.Trivial.Internal+  source-dirs:+    - src+  default-extensions: NoImplicitPrelude+  ghc-options:+    - -Wall+  include-dirs:+    - include+  install-includes:+    - pgisConst.h++### See Spec.hs for instructions of testing on running PostGIS.+tests:+  job-tests:+    main: Spec.hs+    other-modules:+    - Database.Postgis.Trivial+    - Database.Postgis.Trivial.Types+    - Database.Postgis.Trivial.Cast+    - Database.Postgis.Trivial.PGISConst+    - Database.Postgis.Trivial.Internal+    - Database.Postgis.Trivial.Traversable.PointND+    - Database.Postgis.Trivial.Traversable.Geometry+    - Database.Postgis.Trivial.Unboxed+    - Database.Postgis.Trivial.Unboxed.PointND+    - Database.Postgis.Trivial.Unboxed.Geometry+    - Database.Postgis.Trivial.Storable+    - Database.Postgis.Trivial.Storable.PointND+    - Database.Postgis.Trivial.Storable.Geometry+    - Tests.Traversable+    - Tests.Unboxed+    - Tests.Storable+    source-dirs:+    - src+    - test+    default-extensions:+    - NoImplicitPrelude+    ghc-options:+    - -Wall+    dependencies:+    - postgis-trivial+    - HUnit >= 1.6 && < 1.7

+ postgis-trivial.cabal view

@@ -0,0 +1,108 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           postgis-trivial+version:        0.0.1.0+synopsis:       PostGIS extention driver based on postgresql-simple package+description:    Please see the README on GitHub at <https://github.com/igor720/postgis-trivial#README.md>+category:       Database driver+homepage:       https://github.com/igor720/postgis-trivial#readme+bug-reports:    https://github.com/igor720/postgis-trivial/issues+author:         Igor Chudaev+maintainer:     igor720@gmail.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md+    package.yaml+    include/pgisConst.h++source-repository head+  type: git+  location: https://github.com/igor720/postgis-trivial++library+  exposed-modules:+      Database.Postgis.Trivial+      Database.Postgis.Trivial.Types+      Database.Postgis.Trivial.Cast+      Database.Postgis.Trivial.Traversable.PointND+      Database.Postgis.Trivial.Traversable.Geometry+      Database.Postgis.Trivial.Unboxed+      Database.Postgis.Trivial.Unboxed.PointND+      Database.Postgis.Trivial.Unboxed.Geometry+      Database.Postgis.Trivial.Storable+      Database.Postgis.Trivial.Storable.PointND+      Database.Postgis.Trivial.Storable.Geometry+  other-modules:+      Database.Postgis.Trivial.PGISConst+      Database.Postgis.Trivial.Internal+  hs-source-dirs:+      src+  default-extensions:+      NoImplicitPrelude+  ghc-options: -Wall+  include-dirs:+      include+  install-includes:+      pgisConst.h+  build-depends:+      base >=4.7 && <5+    , binary >=0.7 && <0.9+    , bytestring >0.9 && <0.12+    , bytestring-lexing >=0.4 && <0.6+    , containers ==0.6.*+    , cpu ==0.1.*+    , data-binary-ieee754 ==0.4.*+    , mtl >=2.1 && <2.4+    , postgresql-simple >=0.6 && <0.8+    , storable-record ==0.0.*+    , vector >=0.12 && <0.14+  default-language: Haskell2010++test-suite job-tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Database.Postgis.Trivial+      Database.Postgis.Trivial.Types+      Database.Postgis.Trivial.Cast+      Database.Postgis.Trivial.PGISConst+      Database.Postgis.Trivial.Internal+      Database.Postgis.Trivial.Traversable.PointND+      Database.Postgis.Trivial.Traversable.Geometry+      Database.Postgis.Trivial.Unboxed+      Database.Postgis.Trivial.Unboxed.PointND+      Database.Postgis.Trivial.Unboxed.Geometry+      Database.Postgis.Trivial.Storable+      Database.Postgis.Trivial.Storable.PointND+      Database.Postgis.Trivial.Storable.Geometry+      Tests.Traversable+      Tests.Unboxed+      Tests.Storable+  hs-source-dirs:+      src+      test+  default-extensions:+      NoImplicitPrelude+  ghc-options: -Wall+  build-depends:+      HUnit ==1.6.*+    , base >=4.7 && <5+    , binary >=0.7 && <0.9+    , bytestring >0.9 && <0.12+    , bytestring-lexing >=0.4 && <0.6+    , containers ==0.6.*+    , cpu ==0.1.*+    , data-binary-ieee754 ==0.4.*+    , mtl >=2.1 && <2.4+    , postgis-trivial+    , postgresql-simple >=0.6 && <0.8+    , storable-record ==0.0.*+    , vector >=0.12 && <0.14+  default-language: Haskell2010

+ src/Database/Postgis/Trivial.hs view

@@ -0,0 +1,35 @@+-- | Allows PostGIS to work with Traversable geospatial data enclosed in+-- Traversable data structures.+--+-- Example of suitable data types for LineString and Polygon.+--+-- > {-# LANGUAGE TypeFamilies #-}+-- >+-- > data LatLon =+-- >         LatLon !Double !Double+-- >         deriving (Show, Eq)+-- >+-- > type instance Cast LatLon = P2D+-- >+-- > instance Castable LatLon where+-- >     toPointND (LatLon y x) = Point2D x y+-- >     fromPointND (Point2D x y) = LatLon y x+-- >+-- > type LineStringData = [LatLon]+-- > type PolygonData = [[LatLon], [LatLon]]+--++module Database.Postgis.Trivial (+    module Database.Postgis.Trivial.Types+  , module Database.Postgis.Trivial.Cast+  , module Database.Postgis.Trivial.Traversable.PointND+  , module Database.Postgis.Trivial.Traversable.Geometry+) where++import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Cast+import Database.Postgis.Trivial.Traversable.PointND+import Database.Postgis.Trivial.Traversable.Geometry+++

+ src/Database/Postgis/Trivial/Cast.hs view

@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module Database.Postgis.Trivial.Cast where++import GHC.Base hiding ( foldr )+import GHC.Num ( Num((+)) )+import Control.Monad ( replicateM, mapM_ )+import Data.Functor ( (<$>), (<&>) )+import Data.Typeable    ( Typeable )+import Data.Foldable    ( Foldable(..) )+import Data.Traversable ( Traversable(..) )+import qualified Data.Vector as V+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.List (zip)++import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Internal+++-- | 'Type cast' type family+type family Cast p++-- | 'Type cast' procedures+class (Typeable p, PointND (Cast p)) => Castable p where+    toPointND :: p -> Cast p+    fromPointND :: Cast p -> p++-- | Translator of Traversables+class (Castable p, Traversable t, Typeable t) => Trans t p where+    transTo :: t p -> t (Cast p)+    transTo vs = toPointND <$> vs+    transFrom :: t (Cast p) -> t p+    transFrom vs = fromPointND <$> vs++instance Castable p => Trans [] p where+instance Castable p => Trans V.Vector p where+instance (Castable p, Typeable k) => Trans (M.Map k) p where+instance Castable p => Trans IM.IntMap p where++-- | Replication procedure for different Traversables+class (Traversable t, Typeable t) => Repl t b where+    repl :: Int -> HeaderGetter b -> HeaderGetter (t b)++instance Repl [] b where+    repl = replicateM+instance Repl V.Vector b where+    repl = V.replicateM++-- | Point chain is a base structural component of geometries+class Traversable t => GeoChain t where+    count :: t p -> Int+    putChain :: PointND a => Putter (t a)+    putChain vs = do+        putChainLen $ count vs+        mapM_ putPointND vs+    getChain :: (Traversable t, PointND a) => HeaderGetter (t a)+    -- {-# MINIMAL count | putChain #-}++instance GeoChain V.Vector where+    count = V.length+    getChain = getChainLen >>= (`V.replicateM` getPointND)+instance GeoChain [] where+    count = foldr (\_ r->r+1) (0::Int)+    getChain = getChainLen >>= (`replicateM` getPointND)+instance GeoChain (M.Map Int) where+    count = M.size+    getChain = (getChainLen >>= (`replicateM` getPointND)) <&>+        (M.fromList . zip ([0..]::[Int]))+instance GeoChain IM.IntMap where+    count = IM.size+    getChain = (getChainLen >>= (`replicateM` getPointND)) <&>+        (IM.fromList . zip ([0..]::[Int]))+

+ src/Database/Postgis/Trivial/Internal.hs view

@@ -0,0 +1,237 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Database.Postgis.Trivial.Internal+--+-- Low level operations on the Postgis extention of the PostgreSQL Database+--+-----------------------------------------------------------------------------++{- Some techniques in this module were taken from+haskell-postgis <https://hackage.haskell.org/package/haskell-postgis>++Since that package comes with MIT license, we provide it here.++> Copyright (c) 2014 Peter+>+> Permission is hereby granted, free of charge, to any person obtaining+> a copy of this software and associated documentation files (the+> "Software"), to deal in the Software without restriction, including+> without limitation the rights to use, copy, modify, merge, publish,+> distribute, sublicense, and/or sell copies of the Software, and to+> permit persons to whom the Software is furnished to do so, subject to+> the following conditions:+>+> The above copyright notice and this permission notice shall be included+> in all copies or substantial portions of the Software.+>+> THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+> EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+> MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+> IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+> CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+> TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+> SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+-}+++module Database.Postgis.Trivial.Internal where++import GHC.Base hiding ( foldr )+import GHC.Num ( Num(..) )+import GHC.Show ( Show(show) )+import GHC.Real ( fromIntegral, Integral )+import System.Endian ( getSystemEndianness, Endianness(..) )+import Foreign ( Int64, Bits((.&.), (.|.)) )+import Control.Applicative ( (<$>) )+import Control.Monad (void )+import Control.Monad.Reader ( ReaderT(runReaderT), asks, MonadTrans(lift) )+import Control.Exception ( throw )+import Data.Foldable ( Foldable(..) )+import Data.ByteString.Lex.Integral ( packHexadecimal, readHexadecimal )+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC+import Data.Binary ( Word8, Word32, Word64, Get, Put, byteSwap32, byteSwap64,+    Binary(get, put) )+import Data.Binary.Get ( getLazyByteString, lookAhead )+import Data.Binary.Put ( putLazyByteString )+import Data.Maybe ( isJust )+import Data.Binary.IEEE754 ( wordToDouble, doubleToWord )++import Database.Postgis.Trivial.PGISConst+import Database.Postgis.Trivial.Types+++type HeaderGetter = Getter Header++newtype ByteOrder = ByteOrder Endianness deriving Show++-- | Header record+data Header = Header {+    _byteOrder  :: ByteOrder+  , _geoType    :: Word32+  , _srid       :: SRID+} deriving Show++instance Binary ByteOrder where+    get = fromBin <$> getLazyByteString 2+    put = putLazyByteString . toBin++instance Binary Header where+    get = getHeader+    put (Header bo gt s) =+        put bo >> (putInt . fromIntegral) gt  >> putMaybe s putInt++-- | Serializable class+class Serializable a where+    toBin :: a -> BL.ByteString+    fromBin :: BL.ByteString -> a++instance Serializable ByteOrder where+    toBin (ByteOrder BigEndian) = "00" :: BL.ByteString+    toBin (ByteOrder LittleEndian) = "01" :: BL.ByteString+    fromBin bo = case _fromBin bo :: Word8 of+        0 -> ByteOrder BigEndian+        1 -> ByteOrder LittleEndian+        _ -> throw $ GeometryError $ "Incorrect ByteOrder " ++ show bo++instance Serializable Word32 where+    toBin = _toBin 8+    fromBin = _fromBin++instance Serializable Word64 where+    toBin = _toBin 16+    fromBin = _fromBin++_toBin :: Integral a => Int -> a -> BL.ByteString+_toBin l w = case bsRes of+    Just s -> BL.fromChunks [pad l s]+    Nothing -> throw $ GeometryError "toBin: cannot convert word"+    where+        bsRes = packHexadecimal w+        pad l' bs' = BS.append (BC.replicate (l' - BS.length bs') '0') bs'++_fromBin :: Integral a => BL.ByteString -> a+_fromBin bs = case hexRes of+    Just (v, _) -> v+    Nothing -> throw $ GeometryError "fromBin: cannot parse hexadecimal"+    where+        hexRes = readHexadecimal $ BS.concat . BL.toChunks $ bs++{-# INLINE byteSwapFn #-}+byteSwapFn :: ByteOrder -> (a -> a) -> a -> a+byteSwapFn bo f = case bo of+    ByteOrder BigEndian     -> id+    ByteOrder LittleEndian  -> f++makeHeader :: SRID -> Word32 -> (Bool, Bool) -> Header+makeHeader srid geoType (hasM, hasZ) =+    Header (ByteOrder getSystemEndianness) gt srid where+        wOr acc (p, h) = if p then h .|. acc else acc+        gt = foldl wOr geoType+            [(hasM, wkbM), (hasZ, wkbZ), (isJust srid, wkbSRID)]++{-# INLINE lookupType #-}+lookupType :: Header -> Word32+lookupType h = _geoType h .&. ewkbTypeOffset++-- | Putters+putDouble :: Putter Double+putDouble = putLazyByteString . toBin .+    byteSwapFn (ByteOrder getSystemEndianness) byteSwap64 . doubleToWord++putInt :: Putter Int+putInt = putLazyByteString . toBin .+    byteSwapFn (ByteOrder getSystemEndianness) byteSwap32 . fromIntegral++{-# INLINE putMaybe #-}+putMaybe :: Maybe a -> Putter a -> Put+putMaybe mi = case mi of+    Just i -> ($ i)+    Nothing -> \_ -> return ()++{-# INLINE putChainLen #-}+putChainLen :: Putter Int+putChainLen = putInt++putHeader :: SRID -> Word32 -> (Bool, Bool) -> Put+putHeader s geoType (hasMBool, hasZBool) =+    put $ makeHeader s geoType (hasMBool, hasZBool)++putPoint :: Putter (Double, Double, Maybe Double, Maybe Double)+putPoint (x, y, Nothing, Nothing)   = putDouble x >> putDouble y+putPoint (x, y, Just z, Nothing)    = putDouble x >> putDouble y >> putDouble z+putPoint (x, y, Nothing, Just m)    = putDouble x >> putDouble y >> putDouble m+putPoint (x, y, Just z, Just m)     = putDouble x >> putDouble y >> putDouble z+                                        >> putDouble m++{-# INLINE putPointND #-}+putPointND :: PointND a => Putter a+putPointND a = putPoint $ components a++-- | BinGetters+getHeader :: Get Header+getHeader = do+    bo <- get+    t <- fromIntegral <$>  _getInt bo+    s <- if t .&. wkbSRID > 0+        then Just . fromIntegral <$> _getInt bo+        else return Nothing+    return $ Header bo t s++{-# INLINE skipHeader #-}+skipHeader :: HeaderGetter ()+skipHeader = void (lift getHeader)++{-# INLINE getHeaderPre #-}+getHeaderPre :: Get Header+getHeaderPre = lookAhead get++getPoint :: HeaderGetter (Double, Double, Maybe Double, Maybe Double)+getPoint = do+    gt <- asks _geoType+    let hasM = (gt .&. wkbM) > 0+        hasZ = (gt .&. wkbZ) > 0+    x <- getDouble+    y <- getDouble+    zMb <- if hasZ then Just <$> getDouble else return Nothing+    mMb <- if hasM then Just <$> getDouble else return Nothing+    return (x, y, zMb, mMb)++{-# INLINE getPointND #-}+getPointND :: PointND a => HeaderGetter a+getPointND = do+    (x, y, zMb, mMb) <- getPoint+    return $ fromComponents (x, y, zMb, mMb)++{-# INLINE getNumber #-}+getNumber :: (Serializable a) => (a -> a) -> Int64 -> ByteOrder -> Get a+getNumber f l bo  = do+    bs <- getLazyByteString l+    case bo of+        ByteOrder BigEndian     -> return $ fromBin bs+        ByteOrder LittleEndian  -> return . f . fromBin $ bs++_getInt :: ByteOrder -> Get Int+_getInt = fmap fromIntegral . getNumber byteSwap32 8++getInt :: HeaderGetter Int+getInt = asks _byteOrder >>= lift . _getInt++_getDouble :: ByteOrder -> Get Double+_getDouble = fmap wordToDouble . getNumber byteSwap64 16++getDouble :: HeaderGetter Double+getDouble = asks _byteOrder >>= lift . _getDouble++{-# INLINE getChainLen #-}+getChainLen :: HeaderGetter Int+getChainLen = getInt++-- | Geometry returning function+makeResult :: Header -> HeaderGetter a -> Get (a, SRID)+makeResult h getter = (,_srid h) <$> runReaderT getter h+

+ src/Database/Postgis/Trivial/PGISConst.hsc view

@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++module Database.Postgis.Trivial.PGISConst where++import Foreign++#include <pgisConst.h>++wkbZ :: Word32+wkbZ    = #const WKBZOFFSET+wkbM :: Word32+wkbM    = #const WKBMOFFSET+wkbSRID :: Word32+wkbSRID = #const WKBSRIDFLAG+ewkbTypeOffset :: Word32+ewkbTypeOffset = 0x1fffffff++pgisPoint :: Word32+pgisPoint = #const POINTTYPE+pgisLinestring :: Word32+pgisLinestring = #const LINETYPE+pgisPolygon :: Word32+pgisPolygon = #const POLYGONTYPE+pgisMultiPoint :: Word32+pgisMultiPoint = #const MULTIPOINTTYPE+pgisMultiLinestring :: Word32+pgisMultiLinestring = #const MULTILINETYPE+pgisMultiPolygon :: Word32+pgisMultiPolygon = #const MULTIPOLYGONTYPE

+ src/Database/Postgis/Trivial/Storable.hs view

@@ -0,0 +1,50 @@+-- | Allows PostGIS to work with geospatial data enclosed in+-- Traversable data structures with Storable Vectors as the most+-- inner structures.+--+-- Example of suitable data types for LineString and Polygon.+--+-- > {-# LANGUAGE TypeFamilies #-}+-- >+-- > import qualified Data.Vector.Storable as VS+-- > import Foreign.Storable.Record as Store+-- > import Foreign.Storable ( Storable (..) )+-- >+-- > data GeoDuo = GeoDuo+-- >         { dx :: !Double+-- >         , dy :: !Double+-- >         } deriving (Show, Eq)+-- >+-- > storeGeoDuo :: Store.Dictionary GeoDuo+-- > storeGeoDuo = Store.run $+-- >     liftA2 GeoDuo+-- >         (Store.element dx)+-- >         (Store.element dy)+-- >+-- > instance Storable GeoDuo where+-- >    sizeOf = Store.sizeOf storeGeoDuo+-- >    alignment = Store.alignment storeGeoDuo+-- >    peek = Store.peek storeGeoDuo+-- >    poke = Store.poke storeGeoDuo+-- >+-- > type instance Cast GeoDuo = P2D+-- >+-- > instance Castable GeoDuo where+-- >     toPointND (GeoDuo y x) = Point2D x y+-- >     fromPointND (Point2D x y) = GeoDuo y x+-- >+-- > type LineStringData = VS.Vector GeoDuo+-- > type PolygonData = [VS.Vector GeoDuo]+--++module Database.Postgis.Trivial.Storable (+    module Database.Postgis.Trivial.Types+  , module Database.Postgis.Trivial.Cast+  , module Database.Postgis.Trivial.Storable.PointND+  , module Database.Postgis.Trivial.Storable.Geometry+) where++import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Cast+import Database.Postgis.Trivial.Storable.PointND+import Database.Postgis.Trivial.Storable.Geometry

+ src/Database/Postgis/Trivial/Storable/Geometry.hs view

@@ -0,0 +1,204 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}++module Database.Postgis.Trivial.Storable.Geometry where++import GHC.Base hiding ( foldr )+import Control.Monad ( mapM_ )+import Control.Exception ( throw )+import Control.Applicative ( (<$>) )+import qualified Data.Vector.Storable as VS++import Database.Postgis.Trivial.PGISConst+import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Internal+import Database.Postgis.Trivial.Cast+++-- | Translator of Unboxed vectors (direct)+transToS :: (Castable p, VS.Storable p, VS.Storable (Cast p)) =>+        VS.Vector p -> VS.Vector (Cast p)+transToS = VS.map toPointND++-- | Translator of Unboxed vectors (reverse)+transFromS :: (Castable p, VS.Storable p, VS.Storable (Cast p)) =>+        VS.Vector (Cast p) -> VS.Vector p+transFromS = VS.map fromPointND++-- | Chain putter+putChainS :: (PointND a, VS.Storable a) => Putter (VS.Vector a)+putChainS vs = do+        putChainLen $ VS.length vs+        VS.mapM_ putPointND vs++-- | Chain getter+getChainS :: (PointND a, VS.Storable a) => HeaderGetter (VS.Vector a)+getChainS = getChainLen >>= (`VS.replicateM` getPointND)++-- | Point geometry+data Point p = Point SRID p++instance (Castable p, VS.Storable p) => Geometry (Point p) where+    putGeometry (Point srid v) = do+        putHeader srid pgisPoint (dimProps @(Cast p))+        putPointND (toPointND v::Cast p)+    getGeometry = do+        h <- getHeaderPre+        (v::(Cast p), srid) <- if lookupType h==pgisPoint+            then makeResult h (skipHeader >> getPointND)+            else throw $+                GeometryError "invalid data for point geometry"+        return (Point srid (fromPointND v::p))++-- | LineString geometry+data LineString p = LineString SRID (VS.Vector p)++instance (Castable p, VS.Storable p, VS.Storable (Cast p)) =>+        Geometry (LineString p) where+    putGeometry (LineString srid vs) = do+        putHeader srid pgisLinestring (dimProps @(Cast p))+        putChainS (transToS (vs::VS.Vector p)::VS.Vector (Cast p))+    getGeometry = do+        h <- getHeaderPre+        (vs::VS.Vector (Cast p), srid) <-+            if lookupType h==pgisLinestring+            then makeResult h (skipHeader >> getChainS)+            else throw $+                GeometryError "invalid data for linestring geometry"+        return (LineString srid (transFromS vs::VS.Vector p))++-- | Polygon geometry+data Polygon t2 p = Polygon SRID (t2 (VS.Vector p))++instance (Castable p, VS.Storable p, VS.Storable (Cast p), GeoChain t2,+        Repl t2 (VS.Vector (Cast p))) => Geometry (Polygon t2 p) where+    putGeometry (Polygon srid vss) = do+        putHeader srid pgisPolygon (dimProps @(Cast p))+        putChainLen $ count vss+        mapM_ (\vs -> putChainS (transToS vs::VS.Vector (Cast p))) vss+    getGeometry = do+        h <- getHeaderPre+        (vss::t2 (VS.Vector (Cast p)), srid) <- if lookupType h==pgisPolygon+            then makeResult h (skipHeader >> getChainLen >>= (`repl` getChainS))+            else throw $+                GeometryError "invalid data for polygon geometry"+        return (Polygon srid (transFromS <$> vss::t2 (VS.Vector p)))++-- | MultiPoint geometry+data MultiPoint p = MultiPoint SRID (VS.Vector p)++instance (Castable p, VS.Storable p, VS.Storable (Cast p)) =>+        Geometry (MultiPoint p) where+    putGeometry (MultiPoint srid vs) = do+        putHeader srid pgisMultiPoint (dimProps @(Cast p))+        putChainLen $ VS.length vs+        VS.mapM_ (\v -> do+            putGeometry (Point srid v :: Point p)+            ) vs+    getGeometry = do+        h <- getHeaderPre+        (vs::t (Cast p), srid) <- if lookupType h==pgisMultiPoint+            then makeResult h (+                skipHeader >> getChainLen >>=+                    (`VS.replicateM` (skipHeader >> getPointND))+                )+            else throw $+                GeometryError "invalid data for multipoint geometry"+        return (MultiPoint srid (transFromS vs::VS.Vector p))++-- | MultiLineString geometry+data MultiLineString t2 p = MultiLineString SRID (t2 (VS.Vector p))++instance (Castable p, VS.Storable p, VS.Storable (Cast p), GeoChain t2,+        Repl t2 (VS.Vector (Cast p))) => Geometry (MultiLineString t2 p) where+    putGeometry (MultiLineString srid vss) = do+        putHeader srid pgisMultiLinestring (dimProps @(Cast p))+        putChainLen $ count vss+        mapM_ (\vs -> do+            putGeometry (LineString srid vs :: LineString p)+            ) vss+    getGeometry = do+        h <- getHeaderPre+        (vss::t2 (t1 (Cast p)), srid) <- if lookupType h==pgisMultiLinestring+            then makeResult h (+                skipHeader >> getChainLen >>= (`repl` (skipHeader >> getChainS))+                )+            else throw $+                GeometryError "invalid data for multilinestring geometry"+        return (MultiLineString srid (transFromS <$> vss::t2 (VS.Vector p)))++-- | MultiPolygon geometry+data MultiPolygon t3 t2 p = MultiPolygon SRID (t3 (t2 (VS.Vector p)))++instance (Castable p, VS.Storable p, VS.Storable (Cast p),+        Repl t3 (t2 (VS.Vector (Cast p))), Repl t2 (VS.Vector (Cast p)),+        GeoChain t2, GeoChain t3) => Geometry (MultiPolygon t3 t2 p) where+    putGeometry (MultiPolygon srid vsss) = do+        putHeader srid pgisMultiPolygon (dimProps @(Cast p))+        putChainLen $ count vsss+        mapM_ (\vss -> do+            putGeometry (Polygon srid vss :: Polygon t2 p)+            ) vsss+    getGeometry = do+        h <- getHeaderPre+        (vsss::t3 (t2 (VS.Vector (Cast p))), srid) <-+            if lookupType h==pgisMultiPolygon+            then makeResult h (do+                skipHeader >> getChainLen >>= (`repl` (skipHeader >> getChainLen+                    >>= (`repl` getChainS)))+                )+            else throw $+                GeometryError "invalid data for multipolygon geometry"+        return (MultiPolygon srid ((transFromS <$>) <$>+            vsss::t3 (t2 (VS.Vector p))))++-- | Point putter+putPoint :: Castable p => SRID -> p -> Geo (Point p)+putPoint srid p = Geo (Point srid p)++-- | Point getter+getPoint :: Geo (Point p) -> (SRID, p)+getPoint (Geo (Point srid p)) = (srid, p)++-- | Linestring putter+putLS :: SRID -> VS.Vector p -> Geo (LineString p)+putLS srid ps = Geo (LineString srid ps)++-- | LineString getter+getLS :: Geo (LineString p) -> (SRID, VS.Vector p)+getLS (Geo (LineString srid vs)) = (srid, vs)++-- | Polygon putter+putPoly :: SRID -> t2 (VS.Vector p) -> Geo (Polygon t2 p)+putPoly srid pss = Geo (Polygon srid pss)++-- | Polygon getter+getPoly :: Geo (Polygon t2 p) -> (SRID, t2 (VS.Vector p))+getPoly (Geo (Polygon srid vss)) = (srid, vss)++-- | MultiPoint putter+putMPoint :: SRID -> VS.Vector p -> Geo (MultiPoint p)+putMPoint srid ps = Geo (MultiPoint srid ps)++-- | MultiPoint getter+getMPoint :: Geo (MultiPoint p) -> (SRID, VS.Vector p)+getMPoint (Geo (MultiPoint srid vs)) = (srid, vs)++-- | MultiLineString putter+putMLS :: SRID -> t2 (VS.Vector p) -> Geo (MultiLineString t2 p)+putMLS srid pss = Geo (MultiLineString srid pss)++-- | MultiLineString getter+getMLS :: Geo (MultiLineString t2 p) -> (SRID, t2 (VS.Vector p))+getMLS (Geo (MultiLineString srid vs)) = (srid, vs)++-- | MultiPolygon putter+putMPoly :: SRID -> t3 (t2 (VS.Vector p)) -> Geo (MultiPolygon t3 t2 p)+putMPoly srid psss = Geo (MultiPolygon srid psss)++-- | MultiPolygon getter+getMPoly :: Geo (MultiPolygon t3 t2 p) -> (SRID, t3 (t2 (VS.Vector p)))+getMPoly (Geo (MultiPolygon srid vs)) = (srid, vs)+

+ src/Database/Postgis/Trivial/Storable/PointND.hs view

@@ -0,0 +1,164 @@+{-# LANGUAGE TypeFamilies #-}++module Database.Postgis.Trivial.Storable.PointND+( P2DS (..)+, P3DZS (..)+, P3DMS (..)+, P4DS (..)+) where++import GHC.Base+import GHC.Show ( Show )+import Foreign.Storable ( Storable (..) )+import Foreign.Storable.Record as Store+import Control.Exception ( throw )++import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Cast+++-- | Four arguments LiftA+liftA4 :: Applicative f+        => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e+liftA4 f a b c d = liftA3 f a b c <*> d++-- P2DS =========================================================================++-- | Default Storable 2D point+data P2DS = Point2DS+        { xP2DS :: {-# UNPACK #-} !Double+        , yP2DS :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++storeP2DS :: Store.Dictionary P2DS+storeP2DS = Store.run $+    liftA2 Point2DS+        (Store.element xP2DS)+        (Store.element yP2DS)++instance Storable P2DS where+   sizeOf = Store.sizeOf storeP2DS+   alignment = Store.alignment storeP2DS+   peek = Store.peek storeP2DS+   poke = Store.poke storeP2DS++instance PointND P2DS where+    dimProps = (False, False)+    components (Point2DS x y) = (x, y, Nothing, Nothing)+    fromComponents (x, y, Nothing, Nothing) = Point2DS x y+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P2DS"++-- P3DZ ========================================================================++-- | Default Storable 3D point with Z component+data P3DZS = Point3DZS+        { xP3DZ :: {-# UNPACK #-} !Double+        , yP3DZ :: {-# UNPACK #-} !Double+        , zP3DZ :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++storeP3DZ :: Store.Dictionary P3DZS+storeP3DZ = Store.run $+    liftA3 Point3DZS+        (Store.element xP3DZ)+        (Store.element yP3DZ)+        (Store.element zP3DZ)++instance Storable P3DZS where+   sizeOf = Store.sizeOf storeP3DZ+   alignment = Store.alignment storeP3DZ+   peek = Store.peek storeP3DZ+   poke = Store.poke storeP3DZ++instance PointND P3DZS where+    dimProps = (False, True)+    components (Point3DZS x y z) = (x, y, Just z, Nothing)+    fromComponents (x, y, Just z, Nothing) = Point3DZS x y z+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P3DZ"++-- P3DM ========================================================================++-- | Default Storable 3D point with M component+data P3DMS = Point3DMS+        { xP3DM :: {-# UNPACK #-} !Double+        , yP3DM :: {-# UNPACK #-} !Double+        , mP3DM :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++storeP3DM :: Store.Dictionary P3DMS+storeP3DM = Store.run $+    liftA3 Point3DMS+        (Store.element xP3DM)+        (Store.element yP3DM)+        (Store.element mP3DM)++instance Storable P3DMS where+   sizeOf = Store.sizeOf storeP3DM+   alignment = Store.alignment storeP3DM+   peek = Store.peek storeP3DM+   poke = Store.poke storeP3DM++instance PointND P3DMS where+    dimProps = (True, False)+    components (Point3DMS x y m) = (x, y, Just m, Nothing)+    fromComponents (x, y, Just m, Nothing) = Point3DMS x y m+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P3DM"++-- P4D =========================================================================++-- | Default Storable point with Z and M component+data P4DS = Point4DS+        { xP4D :: {-# UNPACK #-} !Double+        , yP4D :: {-# UNPACK #-} !Double+        , zP4D :: {-# UNPACK #-} !Double+        , mP4D :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++storeP4D :: Store.Dictionary P4DS+storeP4D = Store.run $+    liftA4 Point4DS+        (Store.element xP4D)+        (Store.element yP4D)+        (Store.element zP4D)+        (Store.element mP4D)++instance Storable P4DS where+   sizeOf = Store.sizeOf storeP4D+   alignment = Store.alignment storeP4D+   peek = Store.peek storeP4D+   poke = Store.poke storeP4D++instance PointND P4DS where+    dimProps = (True, True)+    components (Point4DS x y z m) = (x, y, Just z, Just m)+    fromComponents (x, y, Just z, Just m) = Point4DS x y z m+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P4D"++-- Cast ========================================================================++type instance Cast P2DS = P2DS+type instance Cast P3DZS = P3DZS+type instance Cast P3DMS = P3DMS+type instance Cast P4DS = P4DS++instance Castable P2DS where+    toPointND = coerce+    fromPointND = coerce+instance Castable P3DZS where+    toPointND = coerce+    fromPointND = coerce+instance Castable P3DMS where+    toPointND = coerce+    fromPointND = coerce+instance Castable P4DS where+    toPointND = coerce+    fromPointND = coerce+++++

+ src/Database/Postgis/Trivial/Traversable/Geometry.hs view

@@ -0,0 +1,181 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}++module Database.Postgis.Trivial.Traversable.Geometry where++import GHC.Base hiding ( foldr )+import Control.Monad ( mapM_ )+import Control.Exception ( throw )+import Control.Applicative ( (<$>) )++import Database.Postgis.Trivial.PGISConst+import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Internal+import Database.Postgis.Trivial.Cast+++-- | Point geometry+data Point p = Point SRID p++instance Castable p => Geometry (Point p) where+    putGeometry (Point srid v) = do+        putHeader srid pgisPoint (dimProps @(Cast p))+        putPointND (toPointND v::Cast p)+    getGeometry = do+        h <- getHeaderPre+        (v::Cast p, srid) <- if lookupType h==pgisPoint+            then makeResult h (skipHeader >> getPointND)+            else throw $+                GeometryError "invalid data for point geometry"+        return (Point srid (fromPointND v::p))++-- | Linestring geometry+data LineString t p = LineString SRID (t p)++instance (GeoChain t, Trans t p) => Geometry (LineString t p) where+    putGeometry (LineString srid vs) = do+        putHeader srid pgisLinestring (dimProps @(Cast p))+        putChain (transTo vs::t (Cast p))+    getGeometry = do+        h <- getHeaderPre+        (vs::t (Cast p), srid) <- if lookupType h==pgisLinestring+            then makeResult h (skipHeader >> getChain)+            else throw $+                GeometryError "invalid data for linestring geometry"+        return (LineString srid (transFrom vs::t p))++-- | Polygon geometry+data Polygon t2 t1 p = Polygon SRID (t2 (t1 p))++instance (Repl t2 (t1 (Cast p)), GeoChain t2, GeoChain t1, Trans t1 p) =>+        Geometry (Polygon t2 t1 p) where+    putGeometry (Polygon srid vss) = do+        putHeader srid pgisPolygon (dimProps @(Cast p))+        putChainLen $ count vss+        mapM_ (\vs -> putChain (transTo vs :: t1 (Cast p))) vss+    getGeometry = do+        h <- getHeaderPre+        (vss::t2 (t1 (Cast p)), srid) <- if lookupType h==pgisPolygon+            then makeResult h (skipHeader >> getChainLen >>= (`repl` getChain))+            else throw $+                GeometryError "invalid data for polygon geometry"+        return (Polygon srid (transFrom <$> vss::t2 (t1 p)))++-- | MultiPoint geometry+data MultiPoint t p = MultiPoint SRID (t p)++instance (Repl t (Cast p), GeoChain t, Trans t p) =>+        Geometry (MultiPoint t p) where+    putGeometry (MultiPoint srid vs) = do+        putHeader srid pgisMultiPoint (dimProps @(Cast p))+        putChainLen $ count vs+        mapM_ (\v -> do+            putGeometry (Point srid v :: Point p)+            ) vs+    getGeometry = do+        h <- getHeaderPre+        (vs::t (Cast p), srid) <- if lookupType h==pgisMultiPoint+            then makeResult h (+                skipHeader >> getChainLen >>= (`repl` (skipHeader >> getPointND))+                )+            else throw $+                GeometryError "invalid data for multipoint geometry"+        return (MultiPoint srid (transFrom vs::t p))++-- | MultiLineString geometry+data MultiLineString t2 t1 p = MultiLineString SRID (t2 (t1 p))++instance (Repl t2 (t1 (Cast p)), GeoChain t2, GeoChain t1, Trans t1 p) =>+        Geometry (MultiLineString t2 t1 p) where+    putGeometry (MultiLineString srid vss) = do+        putHeader srid pgisMultiLinestring (dimProps @(Cast p))+        putChainLen $ count vss+        mapM_ (\vs -> do+            putGeometry (LineString srid vs :: LineString t1 p)+            ) vss+    getGeometry = do+        h <- getHeaderPre+        (vss::t2 (t1 (Cast p)), srid) <- if lookupType h==pgisMultiLinestring+            then makeResult h (+                skipHeader >> getChainLen >>= (`repl` (skipHeader >> getChain))+                )+            else throw $+                GeometryError "invalid data for multilinestring geometry"+        return (MultiLineString srid (transFrom <$> vss::t2 (t1 p)))++-- | MultiPolygon geometry+data MultiPolygon t3 t2 t1 p = MultiPolygon SRID (t3 (t2 (t1 p)))++instance (Repl t3 (t2 (t1 (Cast p))), Repl t2 (t1 (Cast p)), GeoChain t3, GeoChain t2,+        GeoChain t1, Trans t1 p) => Geometry (MultiPolygon t3 t2 t1 p) where+    putGeometry (MultiPolygon srid vsss) = do+        putHeader srid pgisMultiPolygon (dimProps @(Cast p))+        putChainLen $ count vsss+        mapM_ (\vss -> do+            putGeometry (Polygon srid vss :: Polygon t2 t1 p)+            ) vsss+    getGeometry = do+        h <- getHeaderPre+        (vsss::t3 (t2 (t1 (Cast p))), srid) <- if lookupType h==pgisMultiPolygon+            then makeResult h (do+                skipHeader >> getChainLen >>= (`repl` (skipHeader >> getChainLen+                    >>= (`repl` getChain)))+                )+            else throw $+                GeometryError "invalid data for multipolygon geometry"+        return (MultiPolygon srid ((transFrom <$>) <$> vsss::t3 (t2 (t1 p))))++-- | Point putter+putPoint :: Castable p => SRID -> p -> Geo (Point p)+putPoint srid p = Geo (Point srid p)++-- | Point getter+getPoint :: Geo (Point p) -> (SRID, p)+getPoint (Geo (Point srid p)) = (srid, p)++-- | Linestring putter+putLS :: SRID -> t p -> Geo (LineString t p)+putLS srid ps = Geo (LineString srid ps)++-- | LineString getter+getLS :: Geo (LineString t p) -> (SRID, t p)+getLS (Geo (LineString srid vs)) = (srid, vs)++-- | Polygon putter+putPoly :: SRID -> t2 (t1 p) -> Geo (Polygon t2 t1 p)+putPoly srid pss = Geo (Polygon srid pss)++-- | Polygon getter+getPoly :: Geo (Polygon t2 t1 p) -> (SRID, t2 (t1 p))+getPoly (Geo (Polygon srid vss)) = (srid, vss)++-- | MultiPoint putter+putMPoint :: SRID -> t p -> Geo (MultiPoint t p)+putMPoint srid ps = Geo (MultiPoint srid ps)++-- | MultiPoint getter+getMPoint :: Geo (MultiPoint t p) -> (SRID, t p)+getMPoint (Geo (MultiPoint srid vs)) = (srid, vs)++-- | MultiLineString putter+putMLS :: SRID -> t2 (t1 p) -> Geo (MultiLineString t2 t1 p)+putMLS srid pss = Geo (MultiLineString srid pss)++-- | MultiLineString getter+getMLS :: Geo (MultiLineString t2 t1 p) -> (SRID, t2 (t1 p))+getMLS (Geo (MultiLineString srid vs)) = (srid, vs)++-- | MultiPolygon putter+putMPoly :: SRID -> t3 (t2 (t1 p)) -> Geo (MultiPolygon t3 t2 t1 p)+putMPoly srid psss = Geo (MultiPolygon srid psss)++-- | MultiPolygon getter+getMPoly :: Geo (MultiPolygon t3 t2 t1 p) -> (SRID, t3 (t2 (t1 p)))+getMPoly (Geo (MultiPolygon srid vs)) = (srid, vs)+++++

+ src/Database/Postgis/Trivial/Traversable/PointND.hs view

@@ -0,0 +1,87 @@+{-# LANGUAGE TypeFamilies #-}++module Database.Postgis.Trivial.Traversable.PointND where++import GHC.Base+import GHC.Show ( Show )+import Control.Exception ( throw )++import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Cast+++-- | Default 2D point+data P2D = Point2D+        { xP2D :: {-# UNPACK #-} !Double+        , yP2D :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++instance PointND P2D where+    dimProps = (False, False)+    components (Point2D x y) = (x, y, Nothing, Nothing)+    fromComponents (x, y, Nothing, Nothing) = Point2D x y+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to Point2D"++-- | Default 3D point with Z component+data P3DZ = Point3DZ+        { xP3DZ :: {-# UNPACK #-} !Double+        , yP3DZ :: {-# UNPACK #-} !Double+        , zP3DZ :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++instance PointND P3DZ where+    dimProps = (False, True)+    components (Point3DZ x y z) = (x, y, Just z, Nothing)+    fromComponents (x, y, Just z, Nothing) = Point3DZ x y z+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to Point3DZ"++-- | Default 3D point with M component+data P3DM = Point3DM+        { xP3DM :: {-# UNPACK #-} !Double+        , yP3DM :: {-# UNPACK #-} !Double+        , mP3DM :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++instance PointND P3DM where+    dimProps = (True, False)+    components (Point3DM x y m) = (x, y, Just m, Nothing)+    fromComponents (x, y, Just m, Nothing) = Point3DM x y m+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to Point2DM"++-- | Default point with Z and M component+data P4D = Point4D+        { xP4D :: {-# UNPACK #-} !Double+        , yP4D :: {-# UNPACK #-} !Double+        , zP4D :: {-# UNPACK #-} !Double+        , mP4D :: {-# UNPACK #-} !Double+        } deriving (Show, Eq)++instance PointND P4D where+    dimProps = (True, True)+    components (Point4D x y z m) = (x, y, Just z, Just m)+    fromComponents (x, y, Just z, Just m) = Point4D x y z m+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to Point4D"++-- Cast ========================================================================++type instance Cast P2D = P2D+type instance Cast P3DZ = P3DZ+type instance Cast P3DM = P3DM+type instance Cast P4D = P4D++instance Castable P2D where+    toPointND = coerce+    fromPointND = coerce+instance Castable P3DZ where+    toPointND = coerce+    fromPointND = coerce+instance Castable P3DM where+    toPointND = coerce+    fromPointND = coerce+instance Castable P4D where+    toPointND = coerce+    fromPointND = coerce

+ src/Database/Postgis/Trivial/Types.hs view

@@ -0,0 +1,103 @@+++{-# 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 putter = BL.toStrict . runPut . putter++-- | Binary getter+type Getter h = ReaderT h Get++readEWKB :: Get a -> BS.ByteString -> a+readEWKB getter bs = runGet getter (BL.fromStrict 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) = Escape . writeEWKB putGeometry $ g++instance Geometry g => FromField (Geo g) where+    fromField f m = do+        typ <- typename f+        if typ /= "geometry"+            then returnError Incompatible f (show typ)+            else case m of+                Nothing  -> returnError UnexpectedNull f ""+                Just bs -> return $ Geo (readEWKB getGeometry bs)++-- | Geometry exceptions+data SomeGeometryException = forall e. Exception e => SomeGeometryException e+    deriving Typeable++geometryExceptionToException :: Exception e => e -> SomeException+geometryExceptionToException = toException . SomeGeometryException++geometryExceptionFromException :: Exception e => SomeException -> Maybe e+geometryExceptionFromException x = do+    SomeGeometryException a <- fromException x+    cast a++instance Show SomeGeometryException where+    showsPrec :: Int -> SomeGeometryException -> ShowS+    showsPrec p (SomeGeometryException e) = showsPrec p e++instance Exception SomeGeometryException where+    displayException (SomeGeometryException e) = displayException e++-- | Exception for operations with geometries+newtype GeometryError = GeometryError {+    geoMessage :: String+    } deriving (Eq, Show, Typeable)++instance Exception GeometryError where+  toException = geometryExceptionToException+  fromException = geometryExceptionFromException++

+ src/Database/Postgis/Trivial/Unboxed.hs view

@@ -0,0 +1,29 @@+-- | Allows PostGIS to work with geospatial data enclosed in Traversable+-- data structures with Unboxed Vectors as the most inner structures.+--+-- Example of suitable data types for LineString and Polygon.+--+-- > {-# LANGUAGE TypeFamilies #-}+-- >+-- > import qualified Data.Vector.Unboxed as VU+-- >+-- > type instance Cast (Double, Double, Double) = P3DZ+-- >+-- > instance Castable (Double, Double, Double) where+-- >     toPointND (x, y, z) = Point3DZ x y z+-- >     fromPointND (Point3DZ x y z) = (x, y, z)+-- >+-- > type LineStringData = VU.Vector (Double, Double, Double)+-- > type PolygonData = [VU.Vector (Double, Double, Double)]++module Database.Postgis.Trivial.Unboxed (+    module Database.Postgis.Trivial.Types+  , module Database.Postgis.Trivial.Cast+  , module Database.Postgis.Trivial.Unboxed.PointND+  , module Database.Postgis.Trivial.Unboxed.Geometry+) where++import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Cast+import Database.Postgis.Trivial.Unboxed.PointND+import Database.Postgis.Trivial.Unboxed.Geometry

+ src/Database/Postgis/Trivial/Unboxed/Geometry.hs view

@@ -0,0 +1,204 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+++module Database.Postgis.Trivial.Unboxed.Geometry where++import GHC.Base hiding ( foldr )+import Control.Monad ( mapM_ )+import Control.Exception ( throw )+import Control.Applicative ( (<$>) )+import qualified Data.Vector.Unboxed as VU++import Database.Postgis.Trivial.PGISConst+import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Internal+import Database.Postgis.Trivial.Cast+++-- | Translator of Unboxed vectors (direct)+transToU :: (Castable p, VU.Unbox p, VU.Unbox (Cast p)) =>+        VU.Vector p -> VU.Vector (Cast p)+transToU = VU.map toPointND++-- | Translator of Unboxed vectors (reverse)+transFromU :: (Castable p, VU.Unbox p, VU.Unbox (Cast p)) =>+        VU.Vector (Cast p) -> VU.Vector p+transFromU = VU.map fromPointND++-- | Chain putter+putChainU :: (PointND a, VU.Unbox a) => Putter (VU.Vector a)+putChainU vs = do+        putChainLen $ VU.length vs+        VU.mapM_ putPointND vs++-- | Chain getter+getChainU :: (PointND a, VU.Unbox a) => HeaderGetter (VU.Vector a)+getChainU = getChainLen >>= (`VU.replicateM` getPointND)++-- | Point geometry+data Point p = Point SRID p++instance (Castable p, VU.Unbox p) => Geometry (Point p) where+    putGeometry (Point srid v) = do+        putHeader srid pgisPoint (dimProps @(Cast p))+        putPointND (toPointND v::Cast p)+    getGeometry = do+        h <- getHeaderPre+        (v::Cast p, srid) <- if lookupType h==pgisPoint+            then makeResult h (skipHeader >> getPointND)+            else throw $+                GeometryError "invalid data for point geometry"+        return (Point srid (fromPointND v::p))++-- | LineString geometry+data LineString p = LineString SRID (VU.Vector p)++instance (Castable p, VU.Unbox p, VU.Unbox (Cast p)) =>+        Geometry (LineString p) where+    putGeometry (LineString srid vs) = do+        putHeader srid pgisLinestring (dimProps @(Cast p))+        putChainU (transToU (vs::VU.Vector p)::VU.Vector (Cast p))+    getGeometry = do+        h <- getHeaderPre+        (vs::VU.Vector (Cast p), srid) <- if lookupType h==pgisLinestring+            then makeResult h (skipHeader >> getChainU)+            else throw $+                GeometryError "invalid data for linestring geometry"+        return (LineString srid (transFromU vs::VU.Vector p))++-- | Polygon geometry+data Polygon t2 p = Polygon SRID (t2 (VU.Vector p))++instance (Castable p, VU.Unbox p, VU.Unbox (Cast p), GeoChain t2,+        Repl t2 (VU.Vector (Cast p))) => Geometry (Polygon t2 p) where+    putGeometry (Polygon srid vss) = do+        putHeader srid pgisPolygon (dimProps @(Cast p))+        putChainLen $ count vss+        mapM_ (\vs -> putChainU (transToU vs::VU.Vector (Cast p))) vss+    getGeometry = do+        h <- getHeaderPre+        (vss::t2 (VU.Vector (Cast p)), srid) <- if lookupType h==pgisPolygon+            then makeResult h (skipHeader >> getChainLen >>= (`repl` getChainU))+            else throw $+                GeometryError "invalid data for polygon geometry"+        return (Polygon srid (transFromU <$> vss::t2 (VU.Vector p)))++-- | MultiPoint geometry+data MultiPoint p = MultiPoint SRID (VU.Vector p)++instance (Castable p, VU.Unbox p, VU.Unbox (Cast p)) =>+        Geometry (MultiPoint p) where+    putGeometry (MultiPoint srid vs) = do+        putHeader srid pgisMultiPoint (dimProps @(Cast p))+        putChainLen $ VU.length vs+        VU.mapM_ (\v -> do+            putGeometry (Point srid v :: Point p)+            ) vs+    getGeometry = do+        h <- getHeaderPre+        (vs::t (Cast p), srid) <- if lookupType h==pgisMultiPoint+            then makeResult h (+                skipHeader >> getChainLen >>=+                    (`VU.replicateM` (skipHeader >> getPointND))+                )+            else throw $+                GeometryError "invalid data for multipoint geometry"+        return (MultiPoint srid (transFromU vs::VU.Vector p))++-- | MultiLineString geometry+data MultiLineString t2 p = MultiLineString SRID (t2 (VU.Vector p))++instance (Castable p, VU.Unbox p, VU.Unbox (Cast p), GeoChain t2,+        Repl t2 (VU.Vector (Cast p))) => Geometry (MultiLineString t2 p) where+    putGeometry (MultiLineString srid vss) = do+        putHeader srid pgisMultiLinestring (dimProps @(Cast p))+        putChainLen $ count vss+        mapM_ (\vs -> do+            putGeometry (LineString srid vs :: LineString p)+            ) vss+    getGeometry = do+        h <- getHeaderPre+        (vss::t2 (t1 (Cast p)), srid) <- if lookupType h==pgisMultiLinestring+            then makeResult h (+                skipHeader >> getChainLen >>= (`repl` (skipHeader >> getChainU))+                )+            else throw $+                GeometryError "invalid data for multilinestring geometry"+        return (MultiLineString srid (transFromU <$> vss::t2 (VU.Vector p)))++-- | MultiPolygon geometry+data MultiPolygon t3 t2 p = MultiPolygon SRID (t3 (t2 (VU.Vector p)))++instance (Castable p, VU.Unbox p, VU.Unbox (Cast p),+        Repl t3 (t2 (VU.Vector (Cast p))), Repl t2 (VU.Vector (Cast p)),+        GeoChain t2, GeoChain t3) => Geometry (MultiPolygon t3 t2 p) where+    putGeometry (MultiPolygon srid vsss) = do+        putHeader srid pgisMultiPolygon (dimProps @(Cast p))+        putChainLen $ count vsss+        mapM_ (\vss -> do+            putGeometry (Polygon srid vss :: Polygon t2 p)+            ) vsss+    getGeometry = do+        h <- getHeaderPre+        (vsss::t3 (t2 (VU.Vector (Cast p))), srid) <-+            if lookupType h==pgisMultiPolygon+            then makeResult h (do+                skipHeader >> getChainLen >>= (`repl` (skipHeader >> getChainLen+                    >>= (`repl` getChainU)))+                )+            else throw $+                GeometryError "invalid data for multipolygon geometry"+        return (MultiPolygon srid ((transFromU <$>) <$>+            vsss::t3 (t2 (VU.Vector p))))++-- | Point putter+putPoint :: Castable p => SRID -> p -> Geo (Point p)+putPoint srid p = Geo (Point srid p)++-- | Point getter+getPoint :: Castable p => Geo (Point p) -> (SRID, p)+getPoint (Geo (Point srid v)) = (srid, v)++-- | Linestring putter+putLS :: SRID -> VU.Vector p -> Geo (LineString p)+putLS srid ps = Geo (LineString srid ps)++-- | LineString getter+getLS :: Geo (LineString p) -> (SRID, VU.Vector p)+getLS (Geo (LineString srid vs)) = (srid, vs)++-- | Polygon putter+putPoly :: SRID -> t2 (VU.Vector p) -> Geo (Polygon t2 p)+putPoly srid pss = Geo (Polygon srid pss)++-- | Polygon getter+getPoly :: Geo (Polygon t2 p) -> (SRID, t2 (VU.Vector p))+getPoly (Geo (Polygon srid vss)) = (srid, vss)++-- | MultiPoint putter+putMPoint :: SRID -> VU.Vector p -> Geo (MultiPoint p)+putMPoint srid ps = Geo (MultiPoint srid ps)++-- | MultiPoint getter+getMPoint :: Geo (MultiPoint p) -> (SRID, VU.Vector p)+getMPoint (Geo (MultiPoint srid vs)) = (srid, vs)++-- | MultiLineString putter+putMLS :: SRID -> t2 (VU.Vector p) -> Geo (MultiLineString t2 p)+putMLS srid pss = Geo (MultiLineString srid pss)++-- | MultiLineString getter+getMLS :: Geo (MultiLineString t2 p) -> (SRID, t2 (VU.Vector p))+getMLS (Geo (MultiLineString srid vs)) = (srid, vs)++-- | MultiPolygon putter+putMPoly :: SRID -> t3 (t2 (VU.Vector p)) -> Geo (MultiPolygon t3 t2 p)+putMPoly srid psss = Geo (MultiPolygon srid psss)++-- | MultiPolygon getter+getMPoly :: Geo (MultiPolygon t3 t2 p) -> (SRID, t3 (t2 (VU.Vector p)))+getMPoly (Geo (MultiPolygon srid vs)) = (srid, vs)+

+ src/Database/Postgis/Trivial/Unboxed/PointND.hs view

@@ -0,0 +1,315 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Database.Postgis.Trivial.Unboxed.PointND+( P2DU (..)+, P3DZU (..)+, P3DMU (..)+, P4DU (..)+) where++import GHC.Base+import GHC.Show ( Show )+import Control.Applicative ( (<$>) )+import Data.Tuple ( uncurry )+import Control.Exception ( throw )+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Unboxed as VU++import Database.Postgis.Trivial.Types+import Database.Postgis.Trivial.Cast+++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c++uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f (a, b, c, d) = f a b c d++-- P2D =========================================================================++-- | Default Unbox 2D point+data P2DU = Point2DU+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        deriving (Show, Eq)++fromP2D :: P2DU -> (Double, Double)+fromP2D (Point2DU x y) = (x, y)++newtype instance VU.MVector s P2DU = MV_P2D (VU.MVector s (Double, Double))+newtype instance VU.Vector    P2DU = V_P2D  (VU.Vector    (Double, Double))++instance VGM.MVector VU.MVector P2DU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicInitialize #-}+    {-# INLINE basicUnsafeReplicate #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    {-# INLINE basicClear #-}+    {-# INLINE basicSet #-}+    {-# INLINE basicUnsafeCopy #-}+    {-# INLINE basicUnsafeGrow #-}+    basicLength (MV_P2D v) = VGM.basicLength v+    basicUnsafeNew n = MV_P2D <$> VGM.basicUnsafeNew n+    basicUnsafeSlice i n (MV_P2D v) = MV_P2D $ VGM.basicUnsafeSlice i n v+    basicOverlaps (MV_P2D v1) (MV_P2D v2) = VGM.basicOverlaps v1 v2+    basicInitialize (MV_P2D v) = VGM.basicInitialize v+    basicUnsafeReplicate n p = MV_P2D <$> VGM.basicUnsafeReplicate n (fromP2D p)+    basicUnsafeRead (MV_P2D v) i = uncurry Point2DU <$> VGM.basicUnsafeRead v i+    basicUnsafeWrite (MV_P2D v) i p = VGM.basicUnsafeWrite v i (fromP2D p)+    basicClear (MV_P2D v) = VGM.basicClear v+    basicSet (MV_P2D v) p = VGM.basicSet v (fromP2D p)+    basicUnsafeCopy (MV_P2D v1) (MV_P2D v2) = VGM.basicUnsafeCopy v1 v2+    basicUnsafeMove (MV_P2D v1) (MV_P2D v2) = VGM.basicUnsafeMove v1 v2+    basicUnsafeGrow (MV_P2D v) n = MV_P2D <$> VGM.basicUnsafeGrow v n++instance VG.Vector VU.Vector P2DU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicLength (V_P2D v) = VG.basicLength v+    basicUnsafeFreeze (MV_P2D v) = V_P2D <$> VG.basicUnsafeFreeze v+    basicUnsafeThaw (V_P2D v) = MV_P2D <$> VG.basicUnsafeThaw v+    basicUnsafeSlice i n (V_P2D v) = V_P2D $ VG.basicUnsafeSlice i n v+    basicUnsafeIndexM (V_P2D v) i = uncurry Point2DU <$> VG.basicUnsafeIndexM v i+    basicUnsafeCopy (MV_P2D mv) (V_P2D v) = VG.basicUnsafeCopy mv v++instance VU.Unbox P2DU++instance PointND P2DU where+    dimProps = (False, False)+    components (Point2DU x y) = (x, y, Nothing, Nothing)+    fromComponents (x, y, Nothing, Nothing) = Point2DU x y+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P2D"++-- P3DZ ========================================================================++-- | Default Unbox 3D point with Z component+data P3DZU = Point3DZU+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        deriving (Show, Eq)++fromP3DZ :: P3DZU -> (Double, Double, Double)+fromP3DZ (Point3DZU x y z) = (x, y, z)++newtype instance VU.MVector s P3DZU =+    MV_P3DZ (VU.MVector s (Double, Double, Double))+newtype instance VU.Vector    P3DZU =+    V_P3DZ  (VU.Vector    (Double, Double, Double))++instance VGM.MVector VU.MVector P3DZU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicInitialize #-}+    {-# INLINE basicUnsafeReplicate #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    {-# INLINE basicClear #-}+    {-# INLINE basicSet #-}+    {-# INLINE basicUnsafeCopy #-}+    {-# INLINE basicUnsafeGrow #-}+    basicLength (MV_P3DZ v) = VGM.basicLength v+    basicUnsafeNew n = MV_P3DZ <$> VGM.basicUnsafeNew n+    basicUnsafeSlice i n (MV_P3DZ v) = MV_P3DZ $ VGM.basicUnsafeSlice i n v+    basicOverlaps (MV_P3DZ v1) (MV_P3DZ v2) = VGM.basicOverlaps v1 v2+    basicInitialize (MV_P3DZ v) = VGM.basicInitialize v+    basicUnsafeReplicate n p = MV_P3DZ <$> VGM.basicUnsafeReplicate n (fromP3DZ p)+    basicUnsafeRead (MV_P3DZ v) i = uncurry3 Point3DZU <$> VGM.basicUnsafeRead v i+    basicUnsafeWrite (MV_P3DZ v) i p = VGM.basicUnsafeWrite v i (fromP3DZ p)+    basicClear (MV_P3DZ v) = VGM.basicClear v+    basicSet (MV_P3DZ v) p = VGM.basicSet v (fromP3DZ p)+    basicUnsafeCopy (MV_P3DZ v1) (MV_P3DZ v2) = VGM.basicUnsafeCopy v1 v2+    basicUnsafeMove (MV_P3DZ v1) (MV_P3DZ v2) = VGM.basicUnsafeMove v1 v2+    basicUnsafeGrow (MV_P3DZ v) n = MV_P3DZ <$> VGM.basicUnsafeGrow v n++instance VG.Vector VU.Vector P3DZU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicLength (V_P3DZ v) = VG.basicLength v+    basicUnsafeFreeze (MV_P3DZ v) = V_P3DZ <$> VG.basicUnsafeFreeze v+    basicUnsafeThaw (V_P3DZ v) = MV_P3DZ <$> VG.basicUnsafeThaw v+    basicUnsafeSlice i n (V_P3DZ v) = V_P3DZ $ VG.basicUnsafeSlice i n v+    basicUnsafeIndexM (V_P3DZ v) i = uncurry3 Point3DZU <$> VG.basicUnsafeIndexM v i+    basicUnsafeCopy (MV_P3DZ mv) (V_P3DZ v) = VG.basicUnsafeCopy mv v++instance VU.Unbox P3DZU++instance PointND P3DZU where+    dimProps = (False, True)+    components (Point3DZU x y z) = (x, y, Just z, Nothing)+    fromComponents (x, y, Just z, Nothing) = Point3DZU x y z+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P3DZ"++-- P3DM ========================================================================++-- | Default Unbox 3D point with M component+data P3DMU = Point3DMU+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        deriving (Show, Eq)++fromP3DM :: P3DMU -> (Double, Double, Double)+fromP3DM (Point3DMU x y z) = (x, y, z)++newtype instance VU.MVector s P3DMU =+    MV_P3DM (VU.MVector s (Double, Double, Double))+newtype instance VU.Vector    P3DMU =+    V_P3DM  (VU.Vector    (Double, Double, Double))++instance VGM.MVector VU.MVector P3DMU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicInitialize #-}+    {-# INLINE basicUnsafeReplicate #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    {-# INLINE basicClear #-}+    {-# INLINE basicSet #-}+    {-# INLINE basicUnsafeCopy #-}+    {-# INLINE basicUnsafeGrow #-}+    basicLength (MV_P3DM v) = VGM.basicLength v+    basicUnsafeNew n = MV_P3DM <$> VGM.basicUnsafeNew n+    basicUnsafeSlice i n (MV_P3DM v) = MV_P3DM $ VGM.basicUnsafeSlice i n v+    basicOverlaps (MV_P3DM v1) (MV_P3DM v2) = VGM.basicOverlaps v1 v2+    basicInitialize (MV_P3DM v) = VGM.basicInitialize v+    basicUnsafeReplicate n p = MV_P3DM <$> VGM.basicUnsafeReplicate n (fromP3DM p)+    basicUnsafeRead (MV_P3DM v) i = uncurry3 Point3DMU <$> VGM.basicUnsafeRead v i+    basicUnsafeWrite (MV_P3DM v) i p = VGM.basicUnsafeWrite v i (fromP3DM p)+    basicClear (MV_P3DM v) = VGM.basicClear v+    basicSet (MV_P3DM v) p = VGM.basicSet v (fromP3DM p)+    basicUnsafeCopy (MV_P3DM v1) (MV_P3DM v2) = VGM.basicUnsafeCopy v1 v2+    basicUnsafeMove (MV_P3DM v1) (MV_P3DM v2) = VGM.basicUnsafeMove v1 v2+    basicUnsafeGrow (MV_P3DM v) n = MV_P3DM <$> VGM.basicUnsafeGrow v n++instance VG.Vector VU.Vector P3DMU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicLength (V_P3DM v) = VG.basicLength v+    basicUnsafeFreeze (MV_P3DM v) = V_P3DM <$> VG.basicUnsafeFreeze v+    basicUnsafeThaw (V_P3DM v) = MV_P3DM <$> VG.basicUnsafeThaw v+    basicUnsafeSlice i n (V_P3DM v) = V_P3DM $ VG.basicUnsafeSlice i n v+    basicUnsafeIndexM (V_P3DM v) i = uncurry3 Point3DMU <$> VG.basicUnsafeIndexM v i+    basicUnsafeCopy (MV_P3DM mv) (V_P3DM v) = VG.basicUnsafeCopy mv v++instance VU.Unbox P3DMU++instance PointND P3DMU where+    dimProps = (True, False)+    components (Point3DMU x y m) = (x, y, Just m, Nothing)+    fromComponents (x, y, Just m, Nothing) = Point3DMU x y m+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P3DM"++-- P4D =========================================================================++-- | Default Unbox point with Z and M component+data P4DU = Point4DU+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        {-# UNPACK #-} !Double+        deriving (Show, Eq)++fromP4D :: P4DU -> (Double, Double, Double, Double)+fromP4D (Point4DU x y z m) = (x, y, z, m)++newtype instance VU.MVector s P4DU =+    MV_P4D (VU.MVector s (Double, Double, Double, Double))+newtype instance VU.Vector    P4DU =+    V_P4D  (VU.Vector    (Double, Double, Double, Double))++instance VGM.MVector VU.MVector P4DU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicInitialize #-}+    {-# INLINE basicUnsafeReplicate #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    {-# INLINE basicClear #-}+    {-# INLINE basicSet #-}+    {-# INLINE basicUnsafeCopy #-}+    {-# INLINE basicUnsafeGrow #-}+    basicLength (MV_P4D v) = VGM.basicLength v+    basicUnsafeNew n = MV_P4D <$> VGM.basicUnsafeNew n+    basicUnsafeSlice i n (MV_P4D v) = MV_P4D $ VGM.basicUnsafeSlice i n v+    basicOverlaps (MV_P4D v1) (MV_P4D v2) = VGM.basicOverlaps v1 v2+    basicInitialize (MV_P4D v) = VGM.basicInitialize v+    basicUnsafeReplicate n p = MV_P4D <$> VGM.basicUnsafeReplicate n (fromP4D p)+    basicUnsafeRead (MV_P4D v) i = uncurry4 Point4DU <$> VGM.basicUnsafeRead v i+    basicUnsafeWrite (MV_P4D v) i p = VGM.basicUnsafeWrite v i (fromP4D p)+    basicClear (MV_P4D v) = VGM.basicClear v+    basicSet (MV_P4D v) p = VGM.basicSet v (fromP4D p)+    basicUnsafeCopy (MV_P4D v1) (MV_P4D v2) = VGM.basicUnsafeCopy v1 v2+    basicUnsafeMove (MV_P4D v1) (MV_P4D v2) = VGM.basicUnsafeMove v1 v2+    basicUnsafeGrow (MV_P4D v) n = MV_P4D <$> VGM.basicUnsafeGrow v n++instance VG.Vector VU.Vector P4DU where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicLength (V_P4D v) = VG.basicLength v+    basicUnsafeFreeze (MV_P4D v) = V_P4D <$> VG.basicUnsafeFreeze v+    basicUnsafeThaw (V_P4D v) = MV_P4D <$> VG.basicUnsafeThaw v+    basicUnsafeSlice i n (V_P4D v) = V_P4D $ VG.basicUnsafeSlice i n v+    basicUnsafeIndexM (V_P4D v) i = uncurry4 Point4DU <$> VG.basicUnsafeIndexM v i+    basicUnsafeCopy (MV_P4D mv) (V_P4D v) = VG.basicUnsafeCopy mv v++instance VU.Unbox P4DU++instance PointND P4DU where+    dimProps = (True, True)+    components (Point4DU x y z m) = (x, y, Just z, Just m)+    fromComponents (x, y, Just z, Just m) = Point4DU x y z m+    fromComponents _ = throw $+        GeometryError "invalid transition from user data type to P4D"++-- Cast ========================================================================++type instance Cast P2DU = P2DU+type instance Cast P3DZU = P3DZU+type instance Cast P3DMU = P3DMU+type instance Cast P4DU = P4DU++instance Castable P2DU where+    toPointND = coerce+    fromPointND = coerce+instance Castable P3DZU where+    toPointND = coerce+    fromPointND = coerce+instance Castable P3DMU where+    toPointND = coerce+    fromPointND = coerce+instance Castable P4DU where+    toPointND = coerce+    fromPointND = coerce+++++

+ test/Spec.hs view

@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+--+-- Testing database can be created as following:+--      createdb --owner=... --template=template0 test "a postgis testing db"+-- After login as database owner execute next SQLs:+--      CREATE EXTENSION IF NOT EXISTS postgis;+--      CREATE TABLE IF NOT EXISTS points           (geom     geometry(POINT, 3785));+--      CREATE TABLE IF NOT EXISTS linestrings      (geom     geometry(LINESTRING, 3785));+--      CREATE TABLE IF NOT EXISTS linestringZs     (geom     geometry(LINESTRINGZ, 3785));+--      CREATE TABLE IF NOT EXISTS polygons         (geom     geometry(POLYGON, 3785));+--      CREATE TABLE IF NOT EXISTS multipoints      (geom     geometry(MULTIPOINT, 3785));+--      CREATE TABLE IF NOT EXISTS multilinestrings (geom     geometry(MULTILINESTRING, 3785));+--      CREATE TABLE IF NOT EXISTS multipolygons    (geom     geometry(MULTIPOLYGON, 3785));+-- In some cases, you may also need to change `dbconn` function below and/or+-- to set necessary privileges for user and tables+--+-----------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++import GHC.Base+import GHC.Show ( Show(show) )+import System.IO ( putStrLn )+import System.IO.Error ( userError )+import System.Exit ( exitFailure, exitSuccess )+import Control.Exception+import Data.ByteString ( ByteString )+import Database.PostgreSQL.Simple+import Test.HUnit+import qualified Tests.Traversable as T+import qualified Tests.Unboxed as U+import qualified Tests.Storable as S+++dbconn :: ByteString+dbconn = "dbname=test"++checkdb :: IO ()+checkdb = bracket+    (connectPostgreSQL dbconn) close+    (\conn -> do+        [Only res] <- catch (query_ conn "SELECT PostGIS_version()")+            (\(e::SomeException) -> ioError (userError (show e)))+        if res/=(""::ByteString)+            then return ()+            else ioError (userError "No PostGIS detected")+    )++tests :: Test+tests = TestList+    [ TestLabel "Traversable-InsSel" $ T.tInsSel dbconn+    , TestLabel "Unboxed-Mutability" U.tMutability+    , TestLabel "Unboxed-InsSel" $ U.tInsSel dbconn+    , TestLabel "Storable-Mutability" S.tMutability+    , TestLabel "Storable-InsSel" $ S.tInsSel dbconn+    ]++main :: IO ()+main = do+    catch checkdb+        (\(e::IOException) -> do+            putStrLn+                ("\nSkipping tests:"+++                "\n  "++show e+++                "\n  (see Spec.hs header for test instructions)"+                )+            exitSuccess+        )+    cs <- runTestTT tests+    when (errors cs>0 || failures cs>0)+        exitFailure++

+ test/Tests/Storable.hs view

@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Tests.Storable where++import GHC.Base+import GHC.Show ( Show(..) )+import Foreign.Storable.Record as Store+import Foreign.Storable ( Storable (..) )+import Control.Exception ( bracket )+import Data.List ( length )+import qualified Data.Vector.Storable as VS+import Test.HUnit+import Database.PostgreSQL.Simple++import Database.Postgis.Trivial.Storable+import Data.ByteString (ByteString)+++-- type InnerData = VS.Vector P2D++data GeoDuo = GeoDuo+        { dx :: !Double+        , dy :: !Double+        } deriving (Show, Eq)++storeGeoDuo :: Store.Dictionary GeoDuo+storeGeoDuo = Store.run $+    liftA2 GeoDuo+        (Store.element dx)+        (Store.element dy)++instance Storable GeoDuo where+   sizeOf = Store.sizeOf storeGeoDuo+   alignment = Store.alignment storeGeoDuo+   peek = Store.peek storeGeoDuo+   poke = Store.poke storeGeoDuo++type instance Cast GeoDuo = P2DS++instance Castable GeoDuo where+    toPointND (GeoDuo y x) = Point2DS x y+    fromPointND (Point2DS x y) = GeoDuo y x++type SomeData = VS.Vector GeoDuo+++data GeoTrio = GeoTrio+        { tx :: !Double+        , ty :: !Double+        , tz :: !Double+        } deriving (Show, Eq)++storeGeoTrio :: Store.Dictionary GeoTrio+storeGeoTrio = Store.run $+    liftA3 GeoTrio+        (Store.element tx)+        (Store.element ty)+        (Store.element tz)++instance Storable GeoTrio where+   sizeOf = Store.sizeOf storeGeoTrio+   alignment = Store.alignment storeGeoTrio+   peek = Store.peek storeGeoTrio+   poke = Store.poke storeGeoTrio++type instance Cast GeoTrio = P3DZS++instance Castable GeoTrio where+    toPointND (GeoTrio x y z) = Point3DZS x y z+    fromPointND (Point3DZS x y z) = GeoTrio x y z++type SomeDataZ = VS.Vector GeoTrio++tMutability ::Test+tMutability = TestList+    [ "safe update" ~:+        VS.fromList [Point2DS 1 2, Point2DS 1.5 2.5, Point2DS 2.5 3, Point2DS 1 2] VS.//+            [(2, Point2DS 2 13), (0, Point2DS 10 2)]+        ~?= VS.fromList [Point2DS 10 2, Point2DS 1.5 2.5, Point2DS 2 13, Point2DS 1 2]+    , "unsafe update" ~:+        VS.unsafeUpd+            (VS.fromList [Point2DS 1 2, Point2DS 1.5 2.5, Point2DS 2.5 3, Point2DS 1 2])+            [(2, Point2DS 2 13), (0, Point2DS 10 2)]+        ~?= VS.fromList [Point2DS 10 2, Point2DS 1.5 2.5, Point2DS 2 13, Point2DS 1 2]+    ]++tInsSel :: ByteString -> Test+tInsSel dbconn = TestList+    [ "linestring (2D, Unboxed Vector)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = VS.fromList [Point2DS 1 2, Point2DS 1.5 2.5, Point2DS 2.5 3, Point2DS 1 2]+            _ <- execute_ conn "TRUNCATE linestrings"+            _ <- execute conn "INSERT INTO linestrings (geom) VALUES (?)"+                (Only (putLS srid ls0))+            [Only res] <- query_ conn "SELECT * FROM linestrings"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestrings"+            VS.length ls0'==VS.length ls0 && srid'==srid && ls0'==ls0 @?= True+        )+    , "linestring (2D, Unboxed Vector)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = VS.fromList [GeoDuo 1 2, GeoDuo 1.5 2.5, GeoDuo 2.5 3, GeoDuo 1 2]+            _ <- execute_ conn "TRUNCATE linestrings"+            _ <- execute conn "INSERT INTO linestrings (geom) VALUES (?)"+                (Only (putLS srid ls0))+            [Only res] <- query_ conn "SELECT * FROM linestrings"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestrings"+            VS.length ls0'==VS.length ls0 && srid'==srid && ls0'==ls0 @?= True+        )+    , "linestring (3D, Unboxed Vector)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = VS.fromList [GeoTrio 1 2 0, GeoTrio 1.5 2.5 10, GeoTrio 2.5 3 20, GeoTrio 1 2 30]+            _ <- execute_ conn "TRUNCATE linestringZs"+            _ <- execute conn "INSERT INTO linestringZs (geom) VALUES (?)"+                (Only (putLS srid ls0))+            [Only res] <- query_ conn "SELECT * FROM linestringZs"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestringZs"+            VS.length ls0'==VS.length ls0 && srid'==srid && ls0'==ls0 @?= True+        )+    , "multilinestring" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                mls0 =+                    [ VS.fromList [GeoDuo 1 2, GeoDuo 1.5 2.5, GeoDuo 2.5 3, GeoDuo 1 2]+                    , VS.fromList []+                    , VS.fromList [GeoDuo 1 2] ]+            _ <- execute_ conn "TRUNCATE multilinestrings"+            _ <- execute conn "INSERT INTO multilinestrings (geom) VALUES (?)"+                (Only (putMLS srid mls0))+            [Only res] <- query_ conn "SELECT * FROM multilinestrings"+            let (srid', mls0'::[SomeData]) = getMLS res+            _ <- execute_ conn "TRUNCATE multilinestrings"+            length mls0'==length mls0 && srid'==srid && mls0'==mls0 @?= True+        )+    ]+++

+ test/Tests/Traversable.hs view

@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Tests.Traversable where++import GHC.Base+import GHC.Show ( Show(..) )+import Control.Applicative ( (<$>) )+import Control.Exception ( bracket )+import Data.List+import qualified Data.Vector as V+import Test.HUnit+import Database.PostgreSQL.Simple++import Database.Postgis.Trivial+import Data.ByteString (ByteString)+++data LatLon =+        LatLon {-# UNPACK #-} !Double {-# UNPACK #-} !Double+        deriving (Show, Eq)++type instance Cast LatLon = P2D++instance Castable LatLon where+    toPointND (LatLon y x) = Point2D x y+    fromPointND (Point2D x y) = LatLon y x++data LatLonZ =+        LatLonZ {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double+        deriving (Show, Eq)++type instance Cast LatLonZ = P3DZ++instance Castable LatLonZ where+    toPointND (LatLonZ y x z) = Point3DZ x y z+    fromPointND (Point3DZ x y z) = LatLonZ y x z++type instance Cast (Double, Double) = P2D++instance Castable (Double, Double) where+    toPointND (x, y) = Point2D x y+    fromPointND (Point2D x y) = (x, y)++tInsSel :: ByteString -> Test+tInsSel dbconn = TestList+    [ "geometry point (PointND)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                point0 = Point2D 1 2+            _ <- execute_ conn "TRUNCATE points"+            _ <- execute conn "INSERT INTO points (geom) VALUES (?)"+                (Only (putPoint srid point0))+            [Only res] <- query_ conn "SELECT * FROM points"+            let (srid', point0') = getPoint res+            (point0', srid') @?= (point0, srid)+        )+    , "geometry point (Pair)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                point0 = (1, 2) :: (Double, Double)+            _ <- execute_ conn "TRUNCATE points"+            _ <- execute conn "INSERT INTO points (geom) VALUES (?)"+                (Only (putPoint srid point0))+            [Only res] <- query_ conn "SELECT * FROM points"+            let (srid', point0') = getPoint res+            (point0', srid') @?= (point0, srid)+        )+    , "geometry points ([LatLon, LatLon])" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                point0 = LatLon 1 2 :: LatLon+                point1 = LatLon 11 2 :: LatLon+            _ <- execute_ conn "TRUNCATE points"+            _ <- executeMany conn "INSERT INTO points (geom) VALUES (?)"+                (Only <$> [putPoint srid point0, putPoint srid point1])+            res <- map (getPoint . fromOnly) <$> query_ conn "SELECT * FROM points"+            _ <- execute_ conn "TRUNCATE points"+            res @?= [(srid, point0), (srid, point1)]+        )+    , "linestring (3D, Vector)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = V.fromList [Point3DZ 1 2 0, Point3DZ 1.5 2.5 10, Point3DZ 2.5 3 20, Point3DZ 1 2 30]+            _ <- execute_ conn "TRUNCATE linestringZs"+            _ <- execute conn "INSERT INTO linestringZs (geom) VALUES (?)"+                (Only (putLS srid ls0))+            [Only res] <- query_ conn "SELECT * FROM linestringZs"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestringZs"+            length ls0'==length ls0 && srid'==srid && all (==True) (V.zipWith (==) ls0' ls0) @?= True+        )+    , "linestring (3D, Vector), without helpers" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = V.fromList [Point3DZ 1 2 0, Point3DZ 1.5 2.5 10, Point3DZ 2.5 3 20, Point3DZ 1 2 30]+            _ <- execute_ conn "TRUNCATE linestringZs"+            _ <- execute conn "INSERT INTO linestringZs (geom) VALUES (?)"+                (Only (Geo (LineString srid ls0)))+            [Only res] <- query_ conn "SELECT * FROM linestringZs"+            let Geo (LineString srid' ls0') = res+            _ <- execute_ conn "TRUNCATE linestringZs"+            length ls0'==length ls0 && srid'==srid && all (==True) (V.zipWith (==) ls0' ls0) @?= True+        )+    , "linestring (empty)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = [] :: [LatLonZ]+            _ <- execute_ conn "TRUNCATE linestringZs"+            _ <- execute conn "INSERT INTO linestringZs (geom) VALUES (?)"+                (Only (putLS srid ls0))+            [Only res] <- query_ conn "SELECT * FROM linestringZs LIMIT 1"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestringZs"+            length ls0'==length ls0 && srid'==srid && all (==True) (zipWith (==) ls0' ls0) @?= True+        )+    , "polygon" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                polygon0 = [[Point2D 1 2, Point2D 1.5 2.5, Point2D 2.5 3, Point2D 1 2]]+            _ <- execute_ conn "TRUNCATE polygons"+            _ <- execute conn "INSERT INTO polygons (geom) VALUES (?)"+                (Only (putPoly srid polygon0))+            [Only res] <- query_ conn "SELECT * FROM polygons"+            let (srid', polygon0') = getPoly res+            _ <- execute_ conn "TRUNCATE polygons"+            not (null polygon0')+                && length (head polygon0')==length (head polygon0)+                && srid'==srid+                && all (==True) (zipWith (==) (head polygon0') (head polygon0)) @?= True+        )+    , "multipoint" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                mp0 = [Point2D 1 2, Point2D 1.5 2.5, Point2D 2.5 3, Point2D 1 2]+            _ <- execute_ conn "TRUNCATE multipoints"+            _ <- execute conn "INSERT INTO multipoints (geom) VALUES (?)"+                (Only (putMPoint srid mp0))+            [Only res] <- query_ conn "SELECT * FROM multipoints"+            let (srid', mp0') = getMPoint res+            _ <- execute_ conn "TRUNCATE multipoints"+            length mp0'==length mp0 && srid'==srid && all (==True) (zipWith (==) mp0' mp0) @?= True+        )+    , "multilinestring" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                mls0 = [[Point2D 1 2, Point2D 1.5 2.5, Point2D 2.5 3, Point2D 1 2], [], [Point2D 1 2]]+            _ <- execute_ conn "TRUNCATE multilinestrings"+            _ <- execute conn "INSERT INTO multilinestrings (geom) VALUES (?)"+                (Only (putMLS srid mls0))+            [Only res] <- query_ conn "SELECT * FROM multilinestrings"+            let (srid', mls0') = getMLS res+            _ <- execute_ conn "TRUNCATE multilinestrings"+            length mls0'==length mls0 && srid'==srid && all (==True) (zipWith (==) mls0' mls0) @?= True+        )+    , "multipolygon" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                mps0 = [[[Point2D 1 2, Point2D 1.5 2.5, Point2D 2.5 3, Point2D 1 2], []], [[Point2D 1 2]]]+            _ <- execute_ conn "TRUNCATE multipolygons"+            _ <- execute conn "INSERT INTO multipolygons (geom) VALUES (?)"+                (Only (putMPoly srid mps0))+            [Only res] <- query_ conn "SELECT * FROM multipolygons"+            let (srid', mps0') = getMPoly res+            _ <- execute_ conn "TRUNCATE multipolygons"+            length mps0'==length mps0 && srid'==srid && all (==True) (zipWith (==) mps0' mps0) @?= True+        )+    ]+    -- ] where+        -- dbconn = "dbname=test"+++

+ test/Tests/Unboxed.hs view

@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Tests.Unboxed where++import GHC.Base+import Control.Exception ( bracket )+import Data.List+import qualified Data.Vector.Unboxed as VU+import Test.HUnit+import Database.PostgreSQL.Simple++import Database.Postgis.Trivial.Unboxed+import Data.ByteString (ByteString)++-- type InnerData = VU.Vector P2D++type instance Cast (Double, Double, Double) = P3DZU+instance Castable (Double, Double, Double) where+    toPointND (x, y, z) = Point3DZU x y z+    fromPointND (Point3DZU x y z) = (x, y, z)+type SomeDataZ = VU.Vector (Double, Double, Double)++tMutability :: Test+tMutability = TestList+    [ "safe update" ~:+        VU.fromList [Point2DU 1 2, Point2DU 1.5 2.5, Point2DU 2.5 3, Point2DU 1 2] VU.//+            [(2, Point2DU 2 13), (0, Point2DU 10 2)]+        ~?= VU.fromList [Point2DU 10 2, Point2DU 1.5 2.5, Point2DU 2 13, Point2DU 1 2]+    , "unsafe update" ~:+        VU.unsafeUpd+            (VU.fromList [Point2DU 1 2, Point2DU 1.5 2.5, Point2DU 2.5 3, Point2DU 1 2])+            [(2, Point2DU 2 13), (0, Point2DU 10 2)]+        ~?= VU.fromList [Point2DU 10 2, Point2DU 1.5 2.5, Point2DU 2 13, Point2DU 1 2]+    ]++tInsSel :: ByteString -> Test+tInsSel dbconn = TestList+    [ "linestring (2D, Unboxed Vector)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = VU.fromList [Point2DU 1 2, Point2DU 1.5 2.5, Point2DU 2.5 3, Point2DU 1 2]+            _ <- execute_ conn "TRUNCATE linestrings"+            _ <- execute conn "INSERT INTO linestrings (geom) VALUES (?)"+                (Only (putLS srid ls0))+            -- return True+            [Only res] <- query_ conn "SELECT * FROM linestrings"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestrings"+            VU.length ls0'==VU.length ls0 && srid'==srid && ls0'==ls0 @?= True+        )+    , "linestring (2D, Unboxed Vector)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = VU.fromList [Point2DU 1 2, Point2DU 1.5 2.5, Point2DU 2.5 3, Point2DU 1 2]+            _ <- execute_ conn "TRUNCATE linestrings"+            _ <- execute conn "INSERT INTO linestrings (geom) VALUES (?)"+                (Only (putLS srid ls0))+            -- return True+            [Only res] <- query_ conn "SELECT * FROM linestrings"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestrings"+            VU.length ls0'==VU.length ls0 && srid'==srid && ls0'==ls0 @?= True+        )+    , "linestring (3D, Unboxed Vector)" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                ls0 = VU.fromList [(1, 2, 0), (1.5, 2.5, 10), (2.5, 3, 20), (1, 2, 30)] :: SomeDataZ+            _ <- execute_ conn "TRUNCATE linestringZs"+            _ <- execute conn "INSERT INTO linestringZs (geom) VALUES (?)"+                (Only (putLS srid ls0))+            [Only res] <- query_ conn "SELECT * FROM linestringZs"+            let (srid', ls0') = getLS res+            _ <- execute_ conn "TRUNCATE linestringZs"+            VU.length ls0'==VU.length ls0 && srid'==srid && ls0'==ls0 @?= True+        )+    , "multilinestring" ~: bracket+        (connectPostgreSQL dbconn) close+        (\conn -> do+            let srid = Just 3785 :: SRID+                mls0 =+                    [ VU.fromList [Point2DU 1 2, Point2DU 1.5 2.5, Point2DU 2.5 3, Point2DU 1 2]+                    , VU.fromList []+                    , VU.fromList [Point2DU 1 2] ]+            _ <- execute_ conn "TRUNCATE multilinestrings"+            _ <- execute conn "INSERT INTO multilinestrings (geom) VALUES (?)"+                (Only (putMLS srid mls0))+            [Only res] <- query_ conn "SELECT * FROM multilinestrings"+            let (srid', mls0') = getMLS res+            _ <- execute_ conn "TRUNCATE multilinestrings"+            length mls0'==length mls0 && srid'==srid && mls0'==mls0 @?= True+        )+    ]+++