diff --git a/hgeos.cabal b/hgeos.cabal --- a/hgeos.cabal +++ b/hgeos.cabal @@ -1,5 +1,5 @@ name: hgeos -version: 0.1.6.0 +version: 0.1.7.0 synopsis: Simple Haskell bindings to GEOS C API description: Simple Haskell bindings to the diff --git a/src/lib/Data/Geolocation/GEOS.hs b/src/lib/Data/Geolocation/GEOS.hs --- a/src/lib/Data/Geolocation/GEOS.hs +++ b/src/lib/Data/Geolocation/GEOS.hs @@ -31,6 +31,7 @@ , area , createCoordSeq , createLinearRing + , createPolygon , envelope , geomTypeId , getCoordSeq @@ -38,6 +39,7 @@ , getExteriorRing , getGeometry , getNumGeometries + , getOrdinate , getSize , getX , getY @@ -47,6 +49,7 @@ , mkReader , mkWriter , readGeometry + , setOrdinate , setX , setY , setZ @@ -62,6 +65,7 @@ import Data.Word import Foreign.C import Foreign.Marshal.Alloc +import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable @@ -154,10 +158,20 @@ -- |Returns a linear ring 'Geometry' instance from the given coordinate -- sequence createLinearRing :: CoordinateSequence -> IO (Maybe Geometry) -createLinearRing (CoordinateSequence sr (DeleteAction rawPtr _) h) = do - modifyIORef' sr $ \p@ContextState{..} -> p { deleteActions = filter (\(DeleteAction r _) -> r /= rawPtr) deleteActions } +createLinearRing (CoordinateSequence sr deleteAction h) = do + untrack sr deleteAction checkAndTrackGeometry sr (\hCtx -> c_GEOSGeom_createLinearRing_r hCtx h) +-- |Returns a polygon 'Geometry' instance from the given shell and optional +-- array of holes +createPolygon :: Geometry -> [Geometry] -> IO (Maybe Geometry) +createPolygon (Geometry sr deleteAction h) holes = do + untrack sr deleteAction + withArrayLen (map (\(Geometry _ _ h') -> h') holes) $ \count array -> + checkAndTrackGeometry + sr + (\hCtx -> c_GEOSGeom_createPolygon_r hCtx h array (fromIntegral count)) + -- |Returns a 'Geometry' instance representing the envelope of the supplied -- 'Geometry' envelope :: Geometry -> IO (Maybe Geometry) @@ -194,8 +208,8 @@ -- |Returns child 'Geometry' at given index getGeometry :: Geometry -> Int -> IO (Maybe Geometry) -getGeometry (Geometry sr _ h) index = - checkAndDoNotTrack sr (\hCtx -> c_GEOSGetGeometryN_r hCtx h (fromIntegral index)) +getGeometry (Geometry sr _ h) n = + checkAndDoNotTrack sr (\hCtx -> c_GEOSGetGeometryN_r hCtx h (fromIntegral n)) -- |Gets the number of geometries in a 'Geometry' instance getNumGeometries :: Geometry -> IO (Maybe Int) @@ -206,12 +220,22 @@ then Nothing else Just $ fromIntegral value -getOrdinate :: (GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt) -> - CoordinateSequence -> Word -> IO (Maybe Double) -getOrdinate f (CoordinateSequence sr _ h) index = do +-- |Gets an ordinate value from a coordinate sequence +getOrdinate :: CoordinateSequence -> Word -> Word -> IO (Maybe Double) +getOrdinate coords idx dim = + getOrdinateHelper + (\hCtx h idx' -> c_GEOSCoordSeq_getOrdinate_r hCtx h idx' (fromIntegral dim)) + coords + idx + +getOrdinateHelper :: (GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt) -> + CoordinateSequence -> + Word -> + IO (Maybe Double) +getOrdinateHelper f (CoordinateSequence sr _ h) idx = do ContextState{..} <- readIORef sr alloca $ \valuePtr -> do - status <- f hCtx h (fromIntegral index) valuePtr + status <- f hCtx h (fromIntegral idx) valuePtr case status of 0 -> return Nothing _ -> do @@ -230,17 +254,17 @@ size <- peek sizePtr return $ Just (fromIntegral size) --- |Gets an "x" ordinate value from a coordinate sequence +-- |Gets an x-ordinate value from a coordinate sequence getX :: CoordinateSequence -> Word -> IO (Maybe Double) -getX = getOrdinate c_GEOSCoordSeq_getX_r +getX = getOrdinateHelper c_GEOSCoordSeq_getX_r --- |Gets a "y" ordinate value from a coordinate sequence +-- |Gets a y-ordinate value from a coordinate sequence getY :: CoordinateSequence -> Word -> IO (Maybe Double) -getY = getOrdinate c_GEOSCoordSeq_getY_r +getY = getOrdinateHelper c_GEOSCoordSeq_getY_r --- |Gets a "z" ordinate value from a coordinate sequence +-- |Gets a z-ordinate value from a coordinate sequence getZ :: CoordinateSequence -> Word -> IO (Maybe Double) -getZ = getOrdinate c_GEOSCoordSeq_getZ_r +getZ = getOrdinateHelper c_GEOSCoordSeq_getZ_r -- |Returns a 'Geometry' instance representing the intersection of the two -- supplied 'Geometry' instances: @@ -286,25 +310,37 @@ mapM_ (\(DeleteAction _ f) -> f) deleteActions c_finishGEOS_r hCtx -setOrdinate :: (GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> CDouble -> IO CInt ) -> CoordinateSequence -> Word -> Double -> IO (Maybe ()) -setOrdinate f (CoordinateSequence sr _ h) idx val = do +-- |Sets an x-ordinate value within a coordinate sequence +setOrdinate :: CoordinateSequence -> Word -> Word -> Double -> IO (Maybe ()) +setOrdinate coords idx dim = + setOrdinateHelper + (\hCtx h idx' -> c_GEOSCoordSeq_setOrdinate_r hCtx h idx' (fromIntegral dim)) + coords + idx + +setOrdinateHelper :: (GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> CDouble -> IO CInt ) -> CoordinateSequence -> Word -> Double -> IO (Maybe ()) +setOrdinateHelper f (CoordinateSequence sr _ h) idx val = do ContextState{..} <- readIORef sr status <- f hCtx h (fromIntegral idx) (realToFrac val) return $ case status of 0 -> Nothing _ -> Just () --- |Sets an "x" ordinate value within a coordinate sequence +-- |Sets an x-ordinate value within a coordinate sequence setX :: CoordinateSequence -> Word -> Double -> IO (Maybe ()) -setX = setOrdinate c_GEOSCoordSeq_setX_r +setX = setOrdinateHelper c_GEOSCoordSeq_setX_r --- |Sets an "y" ordinate value within a coordinate sequence +-- |Sets a y-ordinate value within a coordinate sequence setY :: CoordinateSequence -> Word -> Double -> IO (Maybe ()) -setY = setOrdinate c_GEOSCoordSeq_setY_r +setY = setOrdinateHelper c_GEOSCoordSeq_setY_r --- |Sets an "z" ordinate value within a coordinate sequence +-- |Sets a z-ordinate value within a coordinate sequence setZ :: CoordinateSequence -> Word -> Double -> IO (Maybe ()) -setZ = setOrdinate c_GEOSCoordSeq_setZ_r +setZ = setOrdinateHelper c_GEOSCoordSeq_setZ_r + +untrack :: ContextStateRef -> DeleteAction -> IO () +untrack sr (DeleteAction rawPtr _) = + modifyIORef' sr $ \p@ContextState{..} -> p { deleteActions = filter (\(DeleteAction r _) -> r /= rawPtr) deleteActions } -- |Reports version of GEOS API version :: IO String diff --git a/src/lib/Data/Geolocation/GEOS/Imports.hs b/src/lib/Data/Geolocation/GEOS/Imports.hs --- a/src/lib/Data/Geolocation/GEOS/Imports.hs +++ b/src/lib/Data/Geolocation/GEOS/Imports.hs @@ -19,6 +19,8 @@ -} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Data.Geolocation.GEOS.Imports ( GEOSContextHandle () , GEOSCoordSequencePtr () @@ -29,10 +31,12 @@ , c_GEOSArea_r , c_GEOSCoordSeq_create_r , c_GEOSCoordSeq_destroy_r + , c_GEOSCoordSeq_getOrdinate_r , c_GEOSCoordSeq_getSize_r , c_GEOSCoordSeq_getX_r , c_GEOSCoordSeq_getY_r , c_GEOSCoordSeq_getZ_r + , c_GEOSCoordSeq_setOrdinate_r , c_GEOSCoordSeq_setX_r , c_GEOSCoordSeq_setY_r , c_GEOSCoordSeq_setZ_r @@ -40,6 +44,7 @@ , c_GEOSFree_r_CString , c_GEOSGeomTypeId_r , c_GEOSGeom_createLinearRing_r + , c_GEOSGeom_createPolygon_r , c_GEOSGeom_destroy_r , c_GEOSGeom_getCoordSeq_r , c_GEOSGetExteriorRing_r @@ -61,6 +66,7 @@ import Foreign.C import Foreign.Ptr +import Foreign.Storable -- |Determines if given pointer is null class NullablePtr a where @@ -78,7 +84,7 @@ rawIntPtr (GEOSCoordSequencePtr p) = ptrToIntPtr p -- |Wraps @GEOSGeometry*@ -newtype GEOSGeometryPtr = GEOSGeometryPtr (Ptr GEOSGeometryPtr) +newtype GEOSGeometryPtr = GEOSGeometryPtr (Ptr GEOSGeometryPtr) deriving Storable instance NullablePtr GEOSGeometryPtr where isNullPtr (GEOSGeometryPtr p) = p == nullPtr rawIntPtr (GEOSGeometryPtr p) = ptrToIntPtr p @@ -107,6 +113,10 @@ foreign import ccall "GEOSCoordSeq_destroy_r" c_GEOSCoordSeq_destroy_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> IO () +-- |Wraps @GEOSCoordSeq_getOrdinate_r@ +foreign import ccall "GEOSCoordSeq_getOrdinate_r" + c_GEOSCoordSeq_getOrdinate_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> CUInt -> Ptr CDouble -> IO CInt + -- |Wraps @GEOSCoordSeq_getSize_r@ foreign import ccall "GEOSCoordSeq_getSize_r" c_GEOSCoordSeq_getSize_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> Ptr CUInt -> IO CInt @@ -123,6 +133,10 @@ foreign import ccall "GEOSCoordSeq_getZ_r" c_GEOSCoordSeq_getZ_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt +-- |Wraps @GEOSCoordSeq_setOrdinate_r@ +foreign import ccall "GEOSCoordSeq_setOrdinate_r" + c_GEOSCoordSeq_setOrdinate_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> CUInt -> CDouble -> IO CInt + -- |Wraps @GEOSCoordSeq_setX_r@ foreign import ccall "GEOSCoordSeq_setX_r" c_GEOSCoordSeq_setX_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> CDouble -> IO CInt @@ -150,6 +164,10 @@ -- |Wraps @GEOSGeom_createLinearRing_r@ foreign import ccall "GEOSGeom_createLinearRing_r" c_GEOSGeom_createLinearRing_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> IO GEOSGeometryPtr + +-- |Wraps @GEOSGeom_createPolygon_r@ +foreign import ccall "GEOSGeom_createPolygon_r" + c_GEOSGeom_createPolygon_r :: GEOSContextHandle -> GEOSGeometryPtr -> Ptr GEOSGeometryPtr -> CUInt -> IO GEOSGeometryPtr -- |Wraps @GEOSGeom_destroy_r@ foreign import ccall "GEOSGeom_destroy_r" diff --git a/src/lib/Data/Geolocation/GEOS/Trans.hs b/src/lib/Data/Geolocation/GEOS/Trans.hs --- a/src/lib/Data/Geolocation/GEOS/Trans.hs +++ b/src/lib/Data/Geolocation/GEOS/Trans.hs @@ -21,12 +21,14 @@ ( areaM , createCoordSeqM , createLinearRingM + , createPolygonM , envelopeM , geomTypeIdM , getCoordSeqM , getExteriorRingM , getGeometryM , getNumGeometriesM + , getOrdinateM , getSizeM , getXM , getYM @@ -38,6 +40,7 @@ , readGeometryM , runGEOS , runGEOSEither + , setOrdinateM , setXM , setYM , setZM @@ -56,6 +59,9 @@ ternaryGEOSFunc :: (a -> b -> c -> IO (Maybe d)) -> a -> b -> c -> MaybeT IO d ternaryGEOSFunc f a b c = MaybeT (f a b c) +quaternaryGEOSFunc :: (a -> b -> c -> d -> IO (Maybe e)) -> a -> b -> c -> d -> MaybeT IO e +quaternaryGEOSFunc f a b c d = MaybeT (f a b c d) + -- |@MaybeT@-wrapped version of 'area' areaM :: Geometry -> MaybeT IO Double areaM = unaryGEOSFunc area @@ -68,6 +74,10 @@ createLinearRingM :: CoordinateSequence -> MaybeT IO Geometry createLinearRingM = unaryGEOSFunc createLinearRing +-- |@MaybeT@-wrapped version of 'createPolygon' +createPolygonM :: Geometry -> [Geometry] -> MaybeT IO Geometry +createPolygonM = binaryGEOSFunc createPolygon + -- |@MaybeT@-wrapped version of 'envelope' envelopeM :: Geometry -> MaybeT IO Geometry envelopeM = unaryGEOSFunc envelope @@ -92,6 +102,10 @@ getNumGeometriesM :: Geometry -> MaybeT IO Int getNumGeometriesM = unaryGEOSFunc getNumGeometries +-- |@MaybeT@-wrapped version of 'getOrdinate' +getOrdinateM :: CoordinateSequence -> Word -> Word -> MaybeT IO Double +getOrdinateM = ternaryGEOSFunc getOrdinate + -- |@MaybeT@-wrapped version of 'getSize' getSizeM :: CoordinateSequence -> MaybeT IO Word getSizeM = unaryGEOSFunc getSize @@ -163,6 +177,9 @@ case result of Nothing -> Left <$> getErrorMessage Just r -> return $ Right r + +-- |@MaybeT@-wrapped version of 'setOrdinate' +setOrdinateM = quaternaryGEOSFunc setOrdinate -- |@MaybeT@-wrapped version of 'setX' setXM = ternaryGEOSFunc setX diff --git a/src/lib/Data/Geolocation/GEOS/helpers.c b/src/lib/Data/Geolocation/GEOS/helpers.c --- a/src/lib/Data/Geolocation/GEOS/helpers.c +++ b/src/lib/Data/Geolocation/GEOS/helpers.c @@ -3,8 +3,11 @@ #include #include -//#define TRACE(message) printf(message "\n") +#ifdef ENABLE_TRACE +#define TRACE(message) printf(message "\n") +#else #define TRACE(message) do {} while (0) +#endif __thread char g_noticeMessage[256]; static const size_t s_noticeMessageLen = sizeof(g_noticeMessage) / sizeof(g_noticeMessage[0]); @@ -13,6 +16,8 @@ static void noticeHandler(const char* format, ...) { + TRACE("noticeHandler"); + va_list args; va_start(args, format); vsnprintf(g_noticeMessage, s_noticeMessageLen, format, args); @@ -21,6 +26,8 @@ static void errorHandler(const char* format, ...) { + TRACE("errorHandler"); + va_list args; va_start(args, format); vsnprintf(g_errorMessage, s_errorMessageLen, format, args); @@ -29,15 +36,21 @@ GEOSContextHandle_t initializeGEOSWithHandlers() { + TRACE("initializeGEOSWithHandlers"); + return initGEOS_r(noticeHandler, errorHandler); } const char* getNoticeMessage() { + TRACE("getNoticeMessage"); + return g_noticeMessage; } const char* getErrorMessage() { + TRACE("getErrorMessage"); + return g_errorMessage; } diff --git a/src/test/GEOSTest/TransAPI.hs b/src/test/GEOSTest/TransAPI.hs --- a/src/test/GEOSTest/TransAPI.hs +++ b/src/test/GEOSTest/TransAPI.hs @@ -6,6 +6,10 @@ import Data.Geolocation.GEOS.Trans import Data.Maybe +check :: Bool -> MaybeT IO () +check True = return () +check False = error "Check failed" + -- Demonstrates use of monad transformer API -- Lifetimes of GEOS objects are automatically managed by the context objects -- which guarantees that they are released when the context goes out of scope @@ -24,15 +28,33 @@ coords <- createCoordSeqM ctx 10 3 size <- getSizeM coords forM_ [0..size - 2] $ \i -> do - setXM coords i (fromIntegral i * 10.0) - setYM coords i (fromIntegral i * 20.0) - setZM coords i (fromIntegral i * 30.0) - setXM coords (size - 1) 0.0 - setYM coords (size - 1) 0.0 - setZM coords (size - 1) 0.0 + setXM coords i (fromIntegral (i + 1) * 10.0) + setYM coords i (fromIntegral (i + 1) * 20.0) + setZM coords i (fromIntegral (i + 1) * 30.0) + setOrdinateM coords (size - 1) 0 10.0 + setOrdinateM coords (size - 1) 1 20.0 + setOrdinateM coords (size - 1) 2 30.0 g3 <- createLinearRingM coords str1 <- writeGeometryM writer g3 lift $ putStrLn str1 + + x0 <- getXM coords 0 + check $ x0 == 10.0 + y0 <- getYM coords 0 + check $ y0 == 20.0 + z0 <- getZM coords 0 + check $ z0 == 30.0 + + x1 <- getOrdinateM coords 1 0 + check $ x1 == 20.0 + y1 <- getOrdinateM coords 1 1 + check $ y1 == 40.0 + z1 <- getOrdinateM coords 1 2 + check $ z1 == 60.0 + + p <- createPolygonM g3 [] + str2 <- writeGeometryM writer p + lift $ putStrLn str2 case result of Left m -> error $ "TransAPI.demo failed: " ++ m