module Data.Geolocation.GEOS
( Context ()
, CoordinateSequence ()
, GEOSError ()
, Geometry ()
, GeometryType (..)
, Reader ()
, Writer ()
, area
, createCollection
, createCoordSeq
, createEmptyPolygon
, createLinearRing
, createPolygon
, envelope
, geomTypeId
, getCoordSeq
, getErrorMessage
, getExteriorRing
, getGeometry
, getNumGeometries
, getOrdinate
, getSize
, getX
, getY
, getZ
, intersection
, isEmpty
, mkReader
, mkWriter
, readGeometry
, setOrdinate
, setX
, setY
, setZ
, version
, withGEOS
, writeGeometry
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.Geolocation.GEOS.Imports
import Data.IORef
import Data.Typeable
import Data.Word
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
data Context = Context ContextStateRef
data ContextState = ContextState
{ hCtx :: GEOSContextHandle
, deleteActions :: [DeleteAction]
}
type ContextStateRef = IORef ContextState
data CoordinateSequence = CoordinateSequence ContextStateRef DeleteAction GEOSCoordSequencePtr
data DeleteAction = DeleteAction IntPtr (IO ())
data GeometryType =
Point |
LineString |
LinearRing |
Polygon |
MultiPoint |
MultlLineString |
MultiPolygon |
GeometryCollection deriving (Enum, Show)
data Reader = Reader ContextStateRef DeleteAction GEOSWKTReaderPtr
data Writer = Writer ContextStateRef DeleteAction GEOSWKTWriterPtr
data GEOSError = GEOSError
{ context :: String
, message :: String
} deriving (Show, Typeable)
instance Exception GEOSError
data Geometry = Geometry
{ geometryStateRef :: ContextStateRef
, geometryDeleteAction :: DeleteAction
, geometryRawPtr :: GEOSGeometryPtr
}
throwGEOSError :: String -> IO a
throwGEOSError context = do
m <- c_getErrorMessage
message <- peekCString m
throw $ GEOSError context message
area :: Geometry -> IO Double
area (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
alloca $ \valuePtr -> do
status <- c_GEOSArea_r hCtx h valuePtr
case status of
0 -> throwGEOSError "GEOSArea_r"
_ -> do
value <- peek valuePtr
return $ realToFrac value
checkAndDoNotTrack :: ContextStateRef -> (GEOSContextHandle -> IO GEOSGeometryPtr) -> IO (Maybe Geometry)
checkAndDoNotTrack sr f = do
ContextState{..} <- readIORef sr
h <- f hCtx
return $ if isNullPtr h
then Nothing
else Just $ Geometry sr emptyDeleteAction h
checkAndDoNotTrack2 :: String -> ContextStateRef -> (GEOSContextHandle -> IO GEOSGeometryPtr) -> IO Geometry
checkAndDoNotTrack2 context sr f = do
ContextState{..} <- readIORef sr
h <- f hCtx
if isNullPtr h
then throwGEOSError context
else return $ Geometry sr emptyDeleteAction h
checkAndTrack :: NullablePtr a =>
ContextStateRef ->
(GEOSContextHandle -> IO a) ->
(GEOSContextHandle -> a -> IO ()) ->
(ContextStateRef -> DeleteAction -> a -> b) ->
IO (Maybe b)
checkAndTrack sr create destroy wrap = do
ContextState{..} <- readIORef sr
h <- create hCtx
if isNullPtr h
then return Nothing
else do
let deleteAction = DeleteAction (rawIntPtr h) (destroy hCtx h)
modifyIORef' sr (\p@ContextState{..} -> p { deleteActions = deleteAction : deleteActions })
return $ Just (wrap sr deleteAction h)
checkAndTrack2 :: NullablePtr a =>
String ->
ContextStateRef ->
(GEOSContextHandle -> IO a) ->
(GEOSContextHandle -> a -> IO ()) ->
(ContextStateRef -> DeleteAction -> a -> b) ->
IO b
checkAndTrack2 context sr create destroy wrap = do
ContextState{..} <- readIORef sr
h <- create hCtx
if isNullPtr h
then throwGEOSError context
else do
let deleteAction = DeleteAction (rawIntPtr h) (destroy hCtx h)
modifyIORef' sr (\p@ContextState{..} -> p { deleteActions = deleteAction : deleteActions })
return $ wrap sr deleteAction h
checkAndTrackGeometry :: ContextStateRef -> (GEOSContextHandle -> IO GEOSGeometryPtr) -> IO (Maybe Geometry)
checkAndTrackGeometry sr create = checkAndTrack sr create c_GEOSGeom_destroy_r Geometry
checkAndTrackGeometry2 :: String -> ContextStateRef -> (GEOSContextHandle -> IO GEOSGeometryPtr) -> IO Geometry
checkAndTrackGeometry2 context sr create = checkAndTrack2 context sr create c_GEOSGeom_destroy_r Geometry
emptyDeleteAction :: DeleteAction
emptyDeleteAction = DeleteAction (ptrToIntPtr nullPtr) (return ())
createCollection :: GeometryType -> [Geometry] -> IO Geometry
createCollection geometryType gs@((Geometry sr _ _) : _) = do
untrack sr (map geometryDeleteAction gs)
withArrayLen (map geometryRawPtr gs) $ \count array ->
checkAndTrackGeometry2
"GEOSGeom_createCollection_r"
sr
(\hCtx -> c_GEOSGeom_createCollection_r hCtx (fromIntegral $ fromEnum geometryType) array (fromIntegral count))
createCoordSeq :: Context -> Word -> Word -> IO CoordinateSequence
createCoordSeq (Context sr) size dims =
checkAndTrack2
"GEOSCoordSeq_create_r"
sr
(\hCtx -> c_GEOSCoordSeq_create_r hCtx (fromIntegral size) (fromIntegral dims))
c_GEOSCoordSeq_destroy_r
CoordinateSequence
createEmptyPolygon :: Context -> IO Geometry
createEmptyPolygon (Context sr) = do
ContextState{..} <- readIORef sr
checkAndTrackGeometry2
"GEOSGeom_createEmptyPolygon_r"
sr
c_GEOSGeom_createEmptyPolygon_r
createLinearRing :: CoordinateSequence -> IO Geometry
createLinearRing (CoordinateSequence sr deleteAction h) = do
untrack sr [deleteAction]
checkAndTrackGeometry2
"GEOSGeom_createLinearRing_r"
sr
(\hCtx -> c_GEOSGeom_createLinearRing_r hCtx h)
createPolygon :: Geometry -> [Geometry] -> IO Geometry
createPolygon (Geometry sr deleteAction h) holes = do
untrack sr (deleteAction : map geometryDeleteAction holes)
withArrayLen (map geometryRawPtr holes) $ \count array ->
checkAndTrackGeometry2
"GEOSGeom_createPolygon_r"
sr
(\hCtx -> c_GEOSGeom_createPolygon_r hCtx h array (fromIntegral count))
envelope :: Geometry -> IO Geometry
envelope (Geometry sr _ h) =
checkAndTrackGeometry2
"GEOSEnvelope_r"
sr
(\hCtx -> c_GEOSEnvelope_r hCtx h)
geomTypeId :: Geometry -> IO GeometryType
geomTypeId (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
value <- c_GEOSGeomTypeId_r hCtx h
if value == 1
then throwGEOSError "GEOSGeomTypeId_r"
else return $ toEnum (fromIntegral value)
getCoordSeq :: Geometry -> IO CoordinateSequence
getCoordSeq (Geometry sr _ hGeometry) = do
ContextState{..} <- readIORef sr
h <- c_GEOSGeom_getCoordSeq_r hCtx hGeometry
if isNullPtr h
then throwGEOSError "GEOSGeom_getCoordSeq_r"
else return $ CoordinateSequence sr emptyDeleteAction h
getErrorMessage :: IO String
getErrorMessage = c_getErrorMessage >>= peekCString
getExteriorRing :: Geometry -> IO Geometry
getExteriorRing (Geometry sr _ h) =
checkAndDoNotTrack2
"GEOSGetExteriorRing_r"
sr
(\hCtx -> c_GEOSGetExteriorRing_r hCtx h)
getGeometry :: Geometry -> Int -> IO Geometry
getGeometry (Geometry sr _ h) n =
checkAndDoNotTrack2
"GEOSGetGeometryN_r"
sr
(\hCtx -> c_GEOSGetGeometryN_r hCtx h (fromIntegral n))
getNumGeometries :: Geometry -> IO Int
getNumGeometries (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
value <- c_GEOSGetNumGeometries_r hCtx h
if value == 1
then throwGEOSError "GEOSGetNumGeometries_r"
else return $ fromIntegral value
getOrdinate :: CoordinateSequence -> Word -> Word -> IO Double
getOrdinate coords idx dim =
getOrdinateHelper
"GEOSCoordSeq_getOrdinate_r"
(\hCtx h idx' -> c_GEOSCoordSeq_getOrdinate_r hCtx h idx' (fromIntegral dim))
coords
idx
getOrdinateHelper :: String -> (GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt) ->
CoordinateSequence ->
Word ->
IO Double
getOrdinateHelper context f (CoordinateSequence sr _ h) idx = do
ContextState{..} <- readIORef sr
alloca $ \valuePtr -> do
status <- f hCtx h (fromIntegral idx) valuePtr
case status of
0 -> throwGEOSError context
_ -> do
value <- peek valuePtr
return $ realToFrac value
getSize :: CoordinateSequence -> IO Word
getSize (CoordinateSequence sr _ h) = do
ContextState{..} <- readIORef sr
alloca $ \sizePtr -> do
status <- c_GEOSCoordSeq_getSize_r hCtx h sizePtr
case status of
0 -> throwGEOSError "GEOSCoordSeq_getSize_r"
_ -> do
size <- peek sizePtr
return $ fromIntegral size
getX :: CoordinateSequence -> Word -> IO Double
getX = getOrdinateHelper "GEOSCoordSeq_getX_r" c_GEOSCoordSeq_getX_r
getY :: CoordinateSequence -> Word -> IO Double
getY = getOrdinateHelper "GEOSCoordSeq_getY_r" c_GEOSCoordSeq_getY_r
getZ :: CoordinateSequence -> Word -> IO Double
getZ = getOrdinateHelper "GEOSCoordSeq_getZ_r" c_GEOSCoordSeq_getZ_r
intersection :: Geometry -> Geometry -> IO Geometry
intersection (Geometry sr0 _ h0) (Geometry sr1 _ h1) =
checkAndTrackGeometry2
"GEOSIntersection_r"
sr0
(\hCtx -> c_GEOSIntersection_r hCtx h0 h1)
isEmpty :: Geometry -> IO Bool
isEmpty (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
value <- c_GEOSisEmpty_r hCtx h
case value of
0 -> return False
1 -> return True
_ -> throwGEOSError "GEOSisEmpty_r"
mkContext :: IO Context
mkContext = do
hCtx <- c_initializeGEOSWithHandlers
sr <- newIORef $ ContextState hCtx []
return $ Context sr
mkReader :: Context -> IO Reader
mkReader (Context sr) =
checkAndTrack2
"GEOSWKTReader_create_r"
sr
c_GEOSWKTReader_create_r
c_GEOSWKTReader_destroy_r
Reader
mkWriter :: Context -> IO Writer
mkWriter (Context sr) =
checkAndTrack2
"GEOSWKTWriter_destroy_r"
sr
c_GEOSWKTWriter_create_r
c_GEOSWKTWriter_destroy_r
Writer
readGeometry :: Reader -> String -> IO Geometry
readGeometry (Reader sr _ h) str = withCString str $ \cs -> do
checkAndTrackGeometry2
"GEOSWKTReader_read_r"
sr
(\hCtx -> c_GEOSWKTReader_read_r hCtx h cs)
releaseContext :: Context -> IO ()
releaseContext (Context sr) = do
ContextState{..} <- readIORef sr
mapM_ (\(DeleteAction _ f) -> f) deleteActions
c_finishGEOS_r hCtx
setOrdinate :: CoordinateSequence -> Word -> Word -> Double -> IO ()
setOrdinate coords idx dim =
setOrdinateHelper
"GEOSCoordSeq_setOrdinate_r"
(\hCtx h idx' -> c_GEOSCoordSeq_setOrdinate_r hCtx h idx' (fromIntegral dim))
coords
idx
setOrdinateHelper :: String -> (GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> CDouble -> IO CInt ) -> CoordinateSequence -> Word -> Double -> IO ()
setOrdinateHelper context f (CoordinateSequence sr _ h) idx val = do
ContextState{..} <- readIORef sr
status <- f hCtx h (fromIntegral idx) (realToFrac val)
if status == 0
then throwGEOSError context
else return ()
setX :: CoordinateSequence -> Word -> Double -> IO ()
setX = setOrdinateHelper "GEOSCoordSeq_setX_r" c_GEOSCoordSeq_setX_r
setY :: CoordinateSequence -> Word -> Double -> IO ()
setY = setOrdinateHelper "GEOSCoordSeq_setY_r" c_GEOSCoordSeq_setY_r
setZ :: CoordinateSequence -> Word -> Double -> IO ()
setZ = setOrdinateHelper "GEOSCoordSeq_setZ_r" c_GEOSCoordSeq_setZ_r
untrack :: ContextStateRef -> [DeleteAction] -> IO ()
untrack sr deleteActions = do
let rawPtrs = map (\(DeleteAction rawPtr _) -> rawPtr) deleteActions
modifyIORef' sr $ \p@ContextState{..} -> p { deleteActions = filter (\(DeleteAction rawPtr _) -> not (rawPtr `elem` rawPtrs)) deleteActions }
version :: IO String
version = c_GEOSversion >>= peekCString
withGEOS :: (Context -> IO a) -> IO a
withGEOS = bracket mkContext releaseContext
writeGeometry :: Writer -> Geometry -> IO String
writeGeometry (Writer sr _ hWriter) (Geometry _ _ hGeometry) = do
ContextState{..} <- readIORef sr
bracket
(c_GEOSWKTWriter_write_r hCtx hWriter hGeometry)
(c_GEOSFree_r_CString hCtx)
(\cs -> if cs == nullPtr then throwGEOSError "GEOSWKTWriter_write_r" else peekCString cs)