diff --git a/data/namibia.wkt b/data/namibia.wkt new file mode 100644 --- /dev/null +++ b/data/namibia.wkt @@ -0,0 +1,1 @@ +POLYGON ((19.9998 -25.6092,19.9973 -28.4326,19.8729 -28.4427,19.8082 -28.5074,19.7295 -28.4897,19.6699 -28.5341,19.562 -28.5315,19.4922 -28.6775,19.4047 -28.7397,19.2955 -28.7358,19.241 -28.8158,19.2092 -28.9401,19.1115 -28.9719,19.0024 -28.93,18.9491 -28.864,18.7321 -28.8412,18.5595 -28.8602,18.4352 -28.9008,18.2651 -28.883,18.1789 -28.916,18.0532 -28.8805,17.9111 -28.7676,17.6104 -28.76,17.5977 -28.7003,17.4099 -28.7232,17.4264 -28.5734,17.3769 -28.5722,17.3299 -28.4719,17.4035 -28.411,17.3452 -28.2435,17.2208 -28.2511,17.1929 -28.1293,17.0838 -28.0379,17.0013 -28.0773,16.8998 -28.0722,16.8769 -28.1813,16.8185 -28.2727,16.7487 -28.2892,16.8084 -28.3666,16.7323 -28.4922,16.6713 -28.4732,16.566 -28.5557,16.481 -28.5671,16.4556 -28.6343,16.2729 -28.5036,16.0343 -28.2714,15.8821 -28.1585,15.7031 -27.991,15.674 -27.9009,15.5458 -27.755,15.5217 -27.6522,15.2983 -27.3286,15.2603 -27.1915,15.2209 -26.9276,15.155 -26.873,15.0928 -26.7449,15.0915 -26.6395,15.1486 -26.6434,15.1194 -26.4492,14.9671 -26.3439,14.9773 -26.1028,14.9088 -25.9264,14.9113 -25.8591,14.8288 -25.7449,14.8796 -25.5724,14.8098 -25.3757,14.8009 -25.2957,14.8771 -25.0902,14.8453 -25.0178,14.7933 -24.9125,14.7971 -24.8389,14.726 -24.7044,14.6156 -24.5877,14.603 -24.4417,14.4849 -24.1765,14.4596 -23.9621,14.4976 -23.9253,14.5141 -23.6309,14.4824 -23.5408,14.4393 -23.4177,14.504 -23.3251,14.4088 -23.0104,14.4139 -22.9596,14.5002 -22.9469,14.5408 -22.8974,14.5294 -22.6386,14.3923 -22.2794,14.2921 -22.1386,14.0649 -21.8683,13.952 -21.7744,13.9774 -21.7338,13.8809 -21.5879,13.8568 -21.5041,13.6284 -21.1894,13.5776 -21.1374,13.5155 -20.9851,13.3797 -20.8011,13.3556 -20.6717,13.2401 -20.4636,13.2287 -20.324,13.1894 -20.239,13.0447 -20.093,13.0079 -19.9497,12.8417 -19.6286,12.7072 -19.3951,12.7021 -19.3393,12.5612 -19.0842,12.4711 -18.9916,12.4546 -18.9129,12.296 -18.7124,12.0245 -18.4789,11.9534 -18.2493,11.8633 -18.1439,11.7326 -17.8102,11.7161 -17.5488,11.725 -17.4168,11.7719 -17.2569,11.8202 -17.2633,11.9471 -17.1821,12.0828 -17.144,12.1678 -17.158,12.244 -17.2341,12.4051 -17.2075,12.4419 -17.262,12.565 -17.2417,12.7097 -17.1681,12.9927 -16.9816,13.1754 -16.9664,13.2718 -16.9955,13.348 -16.9752,13.4609 -17.0133,13.5104 -17.1351,13.6779 -17.2468,13.8809 -17.3508,13.9571 -17.4333,14.0941 -17.4422,14.2096 -17.4054,14.2159 -17.3902,14.5433 -17.3902,15.5471 -17.3902,15.7653 -17.3902,17.2792 -17.3902,17.9987 -17.3902,18.3057 -17.3902,18.4187 -17.3902,18.5481 -17.5666,18.7905 -17.7683,18.8996 -17.8191,19.1077 -17.8394,19.2498 -17.8204,19.4047 -17.8711,19.6623 -17.8534,19.7498 -17.9143,19.9122 -17.866,20.114 -17.9117,20.317 -17.8648,20.4528 -17.9168,20.548 -17.9828,20.6457 -17.979,20.8119 -18.0412,20.9439 -17.9676,21.2193 -17.932,21.4248 -18.0259,22.4984 -17.8216,23.3917 -17.644,24.2368 -17.4777,24.4804 -17.4955,24.5096 -17.545,24.7127 -17.5006,24.9665 -17.5615,25.035 -17.5907,25.1581 -17.7404,25.2329 -17.7924,25.1631 -17.781,25.0692 -17.8432,24.9538 -17.7975,24.8066 -17.8572,24.667 -17.9422,24.5756 -18.0653,24.4893 -18.0475,24.4233 -17.9536,24.2013 -18.017,24.1175 -18.1046,24.0592 -18.1148,23.7914 -18.3825,23.6125 -18.5043,23.5719 -18.484,23.5275 -18.2734,23.4044 -18.1998,23.2965 -17.998,23.1036 -17.9993,22.5047 -18.1135,21.4692 -18.3178,20.9985 -18.3178,20.9972 -19.1832,20.9972 -20.3354,20.9972 -20.9927,21.0023 -22.0041,19.9998 -22.0015,19.9998 -23.3086,19.9998 -23.8631,19.9998 -24.7678,19.9998 -25.6092)) diff --git a/hgeos.cabal b/hgeos.cabal --- a/hgeos.cabal +++ b/hgeos.cabal @@ -1,16 +1,20 @@ name: hgeos -version: 0.1.0.1 -synopsis: Haskell bindings to GEOS C API -description: Please see README.md +version: 0.1.1.0 +synopsis: Simple Haskell bindings to GEOS C API +description: + Simple Haskell bindings to the GEOS C API heavily inspired by + homepage: https://github.com/rcook/hgeos#readme +bug-reports: https://github.com/rcook/hgeos/issues license: MIT license-file: LICENSE -author: Richard Cook -maintainer: rcook@rcook.org -copyright: 2016 Richard Cook -category: Web +author: Richard Cook +maintainer: Richard Cook +copyright: (C) 2016 Richard Cook +category: Data, Geography, Geometry, Text build-type: Simple cabal-version: >= 1.10 +data-files: data/namibia.wkt source-repository head type: git @@ -31,19 +35,11 @@ include-dirs: C:/OSGeo4W64/include extra-lib-dirs: C:/OSGeo4W64/lib -executable hgeos +test-suite hgeos-app + type: exitcode-stdio-1.0 hs-source-dirs: src/app main-is: Main.hs default-language: Haskell2010 build-depends: base >= 4.7 && < 5 , hgeos other-modules: Main - -test-suite doctests - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - default-language: Haskell2010 - build-depends: Glob - , base >= 4.7 && < 5 - , doctest diff --git a/src/app/Main.hs b/src/app/Main.hs --- a/src/app/Main.hs +++ b/src/app/Main.hs @@ -5,6 +5,7 @@ import Data.Geolocation.GEOS.Imports import Foreign.C import Foreign.Ptr +import Paths_hgeos -- Demonstrates direct use of imports -- Lifetimes of various GEOS objects, including readers, writers and @@ -23,7 +24,7 @@ withWKTWriter ctx $ \writer -> do str <- bracket (c_GEOSWKTWriter_write_r ctx writer g2) - (c_GEOSFree_r_CChar ctx) + (c_GEOSFree_r_CString ctx) peekCString putStrLn str putStrLn "lowLevelAPIDemo done" @@ -57,7 +58,27 @@ main :: IO () main = do - s <- peekCString c_GEOSversion - putStrLn s - lowLevelAPIDemo - highLevelAPIDemo + --s <- peekCString c_GEOSversion + --putStrLn s + --lowLevelAPIDemo + --highLevelAPIDemo + namibiaDemo + +printGeometry :: Writer -> Geometry -> IO () +printGeometry r g = writeGeometry r g >>= putStrLn + +namibiaDemo :: IO () +namibiaDemo = do + fileName <- getDataFileName "data/namibia.wkt" + wkt <- readFile fileName + withContext $ \ctx -> do + reader <- mkReader ctx + writer <- mkWriter ctx + let p = printGeometry writer + + country <- readGeometry reader wkt + env <- envelope country + shell <- exteriorRing env + coordSeq <- coordinateSequence shell + p shell + return () 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 @@ -17,9 +17,13 @@ module Data.Geolocation.GEOS ( Context () + , CoordinateSequence () , Geometry () , Reader () , Writer () + , coordinateSequence + , envelope + , exteriorRing , intersection , mkReader , mkWriter @@ -33,165 +37,130 @@ import Data.IORef import Foreign.C +-- |Represents a context +data Context = Context ContextStateRef + data ContextState = ContextState { hCtx :: GEOSContextHandle_t , hReaders :: [GEOSWKTReaderPtr] , hWriters :: [GEOSWKTWriterPtr] , hGeometries :: [GEOSGeometryPtr] + , hCoordinateSequences :: [GEOSCoordSequencePtr] } type ContextStateRef = IORef ContextState --- |Represents a context -data Context = Context ContextStateRef +-- |References a coordinate sequence +data CoordinateSequence = CoordinateSequence ContextStateRef GEOSCoordSequencePtr --- |Represents a reader +-- |References a reader data Reader = Reader ContextStateRef GEOSWKTReaderPtr --- |Represents a writer +-- |References a writer data Writer = Writer ContextStateRef GEOSWKTWriterPtr --- |Represents a geometry +-- |References a geometry data Geometry = Geometry ContextStateRef GEOSGeometryPtr +-- |Returns a 'CoordinateSequence' from the supplied 'Geometry' +coordinateSequence :: Geometry -> IO CoordinateSequence +coordinateSequence (Geometry sr hGeometry) = do + ContextState{..} <- readIORef sr + h <- c_GEOSGeom_getCoordSeq_r hCtx hGeometry + -- Do not track + --modifyIORef' sr (\p@ContextState{..} -> p { hCoordinateSequences = h : hCoordinateSequences }) + return $ CoordinateSequence sr h + +doNotTrack :: ContextStateRef -> (GEOSContextHandle_t -> IO GEOSGeometryPtr) -> IO Geometry +doNotTrack sr f = do + ContextState{..} <- readIORef sr + h <- f hCtx + return $ Geometry sr h + +-- |Returns a 'Geometry' instance representing the envelope of the supplied +-- 'Geometry' +envelope :: Geometry -> IO Geometry +envelope (Geometry sr h) = + track sr (\hCtx -> c_GEOSEnvelope_r hCtx h) + +-- |Returns a 'Geometry' instance representing the exterior ring of the +-- supplied 'Geometry' +exteriorRing :: Geometry -> IO Geometry +exteriorRing (Geometry sr h) = + doNotTrack sr (\hCtx -> c_GEOSGetExteriorRing_r hCtx h) + +-- |Returns a 'Geometry' instance representing the intersection of the two +-- supplied 'Geometry' instances: +intersection :: Geometry -> Geometry -> IO Geometry +intersection (Geometry sr0 h0) (Geometry sr1 h1) = + track sr0 (\hCtx -> c_GEOSIntersection_r hCtx h0 h1) + mkContext :: IO Context mkContext = do hCtx <- c_initializeGEOSWithHandlers - sr <- newIORef $ ContextState hCtx [] [] [] + sr <- newIORef $ ContextState hCtx [] [] [] [] return $ Context sr -releaseContext :: Context -> IO () -releaseContext (Context sr) = do - ContextState{..} <- readIORef sr - mapM_ (c_GEOSGeom_destroy_r hCtx) hGeometries - mapM_ (c_GEOSWKTWriter_destroy_r hCtx) hWriters - mapM_ (c_GEOSWKTReader_destroy_r hCtx) hReaders - c_uninitializeGEOS hCtx - --- |Creates a context, passes it to a block --- and releases the context and all associated objects such as readers, writers --- and geometries at the end: --- --- @ --- withContext $ \ctx -> do --- --- -- Use context --- --- return () --- @ -withContext :: (Context -> IO a) -> IO a -withContext = bracket mkContext releaseContext - -- |Creates a reader used to deserialize 'Geometry' instances from -- -format text: --- --- @ --- withContext $ \ctx -> do --- reader <- mkReader ctx --- --- -- Use reader --- --- return () --- @ --- --- The reader is associated with the 'Context' and released when the 'Context' --- is released. mkReader :: Context -> IO Reader mkReader (Context sr) = do ContextState{..} <- readIORef sr - hReader <- c_GEOSWKTReader_create_r hCtx - modifyIORef' sr (\p@ContextState{..} -> p { hReaders = hReader : hReaders }) - return $ Reader sr hReader + h <- c_GEOSWKTReader_create_r hCtx + modifyIORef' sr (\p@ContextState{..} -> p { hReaders = h : hReaders }) + return $ Reader sr h -- |Creates a writer used to serialize 'Geometry' instances to -- -format text: --- --- @ --- withContext $ \ctx -> do --- writer <- mkWriter ctx --- --- -- Use writer --- --- return () --- @ --- --- The writer is associated with the 'Context' and released when the 'Context' --- is released. mkWriter :: Context -> IO Writer mkWriter (Context sr) = do ContextState{..} <- readIORef sr - hWriter <- c_GEOSWKTWriter_create_r hCtx - modifyIORef' sr (\p@ContextState{..} -> p { hWriters = hWriter : hWriters }) - return $ Writer sr hWriter + h <- c_GEOSWKTWriter_create_r hCtx + modifyIORef' sr (\p@ContextState{..} -> p { hWriters = h : hWriters }) + return $ Writer sr h -- |Deserializes a 'Geometry' instance from the given 'String' using the -- supplied 'Reader': --- --- @ --- withContext $ \ctx -> do --- reader <- mkReader ctx --- geometry <- readGeometry read "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" --- --- -- Use geometry --- --- return () --- @ --- --- The geometry is associated with the 'Context' and released when the 'Context' --- is released. readGeometry :: Reader -> String -> IO Geometry -readGeometry (Reader sr hReader) str = withCString str $ \cs -> do +readGeometry (Reader sr h) str = withCString str $ \cs -> do + track sr (\hCtx -> c_GEOSWKTReader_read_r hCtx h cs) + +releaseContext :: Context -> IO () +releaseContext (Context sr) = do ContextState{..} <- readIORef sr - hGeometry <- c_GEOSWKTReader_read_r hCtx hReader cs - modifyIORef' sr (\p@ContextState{..} -> p { hGeometries = hGeometry : hGeometries }) - return $ Geometry sr hGeometry + mapM_ (c_GEOSCoordSeq_destroy_r hCtx) hCoordinateSequences + mapM_ (c_GEOSGeom_destroy_r hCtx) hGeometries + mapM_ (c_GEOSWKTWriter_destroy_r hCtx) hWriters + mapM_ (c_GEOSWKTReader_destroy_r hCtx) hReaders + c_uninitializeGEOS hCtx --- |Serializes a 'Geometry' instance to a 'String' using the supplied 'Writer': +track :: ContextStateRef -> (GEOSContextHandle_t -> IO GEOSGeometryPtr) -> IO Geometry +track sr f = do + ContextState{..} <- readIORef sr + h <- f hCtx + modifyIORef' sr $ (\p@ContextState{..} -> p { hGeometries = h : hGeometries }) + return $ Geometry sr h + +-- |Creates a context, passes it to a block +-- and releases the context and all associated objects such as readers, writers +-- and geometries at the end: -- -- @ -- withContext $ \ctx -> do --- reader <- mkReader ctx --- geometry <- readGeometry read "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" -- --- writer <- mkWriter ctx --- str <- writeGeometry writer geometry --- --- -- Use string +-- -- Use context -- -- return () -- @ --- --- The geometry is associated with the 'Context' and released when the 'Context' --- is released. +withContext :: (Context -> IO a) -> IO a +withContext = bracket mkContext releaseContext + +-- |Serializes a 'Geometry' instance to a 'String' using the supplied 'Writer': writeGeometry :: Writer -> Geometry -> IO String writeGeometry (Writer sr hWriter) (Geometry _ hGeometry) = do ContextState{..} <- readIORef sr str <- bracket (c_GEOSWKTWriter_write_r hCtx hWriter hGeometry) - (c_GEOSFree_r_CChar hCtx) + (c_GEOSFree_r_CString hCtx) peekCString return str - --- |Returns the 'Geometry' instance representing the intersection of the two --- supplied 'Geometry' instances: --- --- @ --- withContext $ \ctx -> do --- reader <- mkReader ctx --- g0 <- readGeometry reader "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" --- g1 <- readGeometry reader "POLYGON (( 11 11, 11 12, 12 12, 12 11, 11 11 ))" --- --- g2 <- intersection g0 g1 --- --- -- Use geometry --- --- putStrLn str --- @ --- --- The geometry is associated with the 'Context' and released when the 'Context' --- is released. -intersection :: Geometry -> Geometry -> IO Geometry -intersection (Geometry sr0 hGeometry0) (Geometry sr1 hGeometry1) = do - ContextState{..} <- readIORef sr0 - hGeometry <- c_GEOSIntersection_r hCtx hGeometry0 hGeometry1 - return $ Geometry sr0 hGeometry 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 @@ -17,11 +17,16 @@ module Data.Geolocation.GEOS.Imports ( GEOSContextHandle_t () + , GEOSCoordSequencePtr () , GEOSGeometryPtr () , GEOSWKTReaderPtr () , GEOSWKTWriterPtr () - , c_GEOSFree_r_CChar + , c_GEOSEnvelope_r + , c_GEOSFree_r_CString + , c_GEOSCoordSeq_destroy_r , c_GEOSGeom_destroy_r + , c_GEOSGeom_getCoordSeq_r + , c_GEOSGetExteriorRing_r , c_GEOSIntersection_r , c_GEOSWKTReader_create_r , c_GEOSWKTReader_destroy_r @@ -40,6 +45,9 @@ -- |Wraps @GEOSContextHandle_t@ newtype GEOSContextHandle_t = GEOSContextHandle_t (Ptr GEOSContextHandle_t) +-- |Wraps @GEOSCoordSequence*@ +newtype GEOSCoordSequencePtr = GEOSCoordSequencePtr (Ptr GEOSCoordSequencePtr) + -- |Wraps @GEOSGeometry*@ newtype GEOSGeometryPtr = GEOSGeometryPtr (Ptr GEOSGeometryPtr) @@ -49,34 +57,34 @@ -- |Wraps @GEOSWKTWriter*@ newtype GEOSWKTWriterPtr = GEOSWKTWriterPtr (Ptr GEOSWKTWriterPtr) --- |Wraps @GEOSversion@ -foreign import ccall "GEOSversion" - c_GEOSversion :: CString +-- |Wraps @GEOSCoordSeq_destroy_r@ +foreign import ccall "GEOSCoordSeq_destroy_r" + c_GEOSCoordSeq_destroy_r :: GEOSContextHandle_t -> GEOSCoordSequencePtr -> IO () +-- |Wraps @GEOSEnvelope_r@ +foreign import ccall "GEOSEnvelope_r" + c_GEOSEnvelope_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO GEOSGeometryPtr + -- |Wraps @GEOSFree_r@ specialized to @const char*@ foreign import ccall "GEOSFree_r" - c_GEOSFree_r_CChar :: GEOSContextHandle_t -> Ptr CChar -> IO () - --- |Wraps @initializeGEOSWithHandlers@ helper function -foreign import ccall "helpers.h initializeGEOSWithHandlers" - c_initializeGEOSWithHandlers :: IO GEOSContextHandle_t - --- |Wraps @uninitializeGEOS@ helper function -foreign import ccall "helpers.h uninitializeGEOS" - c_uninitializeGEOS :: GEOSContextHandle_t -> IO () + c_GEOSFree_r_CString :: GEOSContextHandle_t -> CString -> IO () --- |Wraps @getNoticeMessage@ helper function -foreign import ccall "helpers.h getNoticeMessage" - c_getNoticeMessage :: IO CString +-- |Wraps @GEOSGetExteriorRing_r@ +foreign import ccall "GEOSGetExteriorRing_r" + c_GEOSGetExteriorRing_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO GEOSGeometryPtr --- |Wraps @getErrorMessage@ helper function -foreign import ccall "helpers.h getErrorMessage" - c_getErrorMessage :: IO CString +-- |Wraps @GEOSIntersection_r@ +foreign import ccall "GEOSIntersection_r" + c_GEOSIntersection_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> GEOSGeometryPtr -> IO GEOSGeometryPtr -- |Wraps @GEOSGeom_destroy_r@ foreign import ccall "GEOSGeom_destroy_r" c_GEOSGeom_destroy_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO () +-- |Wraps @GEOSGeom_getCoordSeq_r@ +foreign import ccall "GEOSGeom_getCoordSeq_r" + c_GEOSGeom_getCoordSeq_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO GEOSCoordSequencePtr + -- |Wraps @GEOSWKTReader_create_r@ foreign import ccall "GEOSWKTReader_create_r" c_GEOSWKTReader_create_r :: GEOSContextHandle_t -> IO GEOSWKTReaderPtr @@ -101,6 +109,22 @@ foreign import ccall "GEOSWKTWriter_write_r" c_GEOSWKTWriter_write_r :: GEOSContextHandle_t -> GEOSWKTWriterPtr -> GEOSGeometryPtr -> IO CString --- |Wraps @GEOSIntersection_r@ -foreign import ccall "GEOSIntersection_r" - c_GEOSIntersection_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> GEOSGeometryPtr -> IO GEOSGeometryPtr +-- |Wraps @GEOSversion@ +foreign import ccall "GEOSversion" + c_GEOSversion :: CString + +-- |Wraps @getErrorMessage@ helper function +foreign import ccall "helpers.h getErrorMessage" + c_getErrorMessage :: IO CString + +-- |Wraps @getNoticeMessage@ helper function +foreign import ccall "helpers.h getNoticeMessage" + c_getNoticeMessage :: IO CString + +-- |Wraps @initializeGEOSWithHandlers@ helper function +foreign import ccall "helpers.h initializeGEOSWithHandlers" + c_initializeGEOSWithHandlers :: IO GEOSContextHandle_t + +-- |Wraps @uninitializeGEOS@ helper function +foreign import ccall "helpers.h uninitializeGEOS" + c_uninitializeGEOS :: GEOSContextHandle_t -> IO () diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main (main) where - -import qualified System.FilePath.Glob as Glob -import qualified Test.DocTest as DocTest - -includeDirs :: [String] -includeDirs = [] - -doctestWithIncludeDirs :: [String] -> IO () -doctestWithIncludeDirs fs = DocTest.doctest (map ("-I" ++) includeDirs ++ fs) - -main :: IO () -main = Glob.glob "src/**/*.hs" >>= doctestWithIncludeDirs