module Data.Geolocation.GEOS
( Context ()
, CoordinateSequence ()
, 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.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 Geometry = Geometry
{ geometryStateRef :: ContextStateRef
, geometryDeleteAction :: DeleteAction
, geometryRawPtr :: GEOSGeometryPtr
}
area :: Geometry -> IO (Maybe Double)
area (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
alloca $ \valuePtr -> do
status <- c_GEOSArea_r hCtx h valuePtr
case status of
0 -> return Nothing
_ -> do
value <- peek valuePtr
return $ Just (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
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)
checkAndTrackGeometry :: ContextStateRef -> (GEOSContextHandle -> IO GEOSGeometryPtr) -> IO (Maybe Geometry)
checkAndTrackGeometry sr create = checkAndTrack sr create c_GEOSGeom_destroy_r Geometry
emptyDeleteAction :: DeleteAction
emptyDeleteAction = DeleteAction (ptrToIntPtr nullPtr) (return ())
createCollection :: GeometryType -> [Geometry] -> IO (Maybe Geometry)
createCollection geometryType gs@((Geometry sr _ _) : _) = do
untrack sr (map geometryDeleteAction gs)
withArrayLen (map geometryRawPtr gs) $ \count array ->
checkAndTrackGeometry
sr
(\hCtx -> c_GEOSGeom_createCollection_r hCtx (fromIntegral $ fromEnum geometryType) nullPtr (fromIntegral count))
createCoordSeq :: Context -> Word -> Word -> IO (Maybe CoordinateSequence)
createCoordSeq (Context sr) size dims =
checkAndTrack
sr
(\hCtx -> c_GEOSCoordSeq_create_r hCtx (fromIntegral size) (fromIntegral dims))
c_GEOSCoordSeq_destroy_r
CoordinateSequence
createEmptyPolygon :: Context -> IO (Maybe Geometry)
createEmptyPolygon (Context sr) = do
ContextState{..} <- readIORef sr
checkAndTrackGeometry sr c_GEOSGeom_createEmptyPolygon_r
createLinearRing :: CoordinateSequence -> IO (Maybe Geometry)
createLinearRing (CoordinateSequence sr deleteAction h) = do
untrack sr [deleteAction]
checkAndTrackGeometry sr (\hCtx -> c_GEOSGeom_createLinearRing_r hCtx h)
createPolygon :: Geometry -> [Geometry] -> IO (Maybe Geometry)
createPolygon (Geometry sr deleteAction h) holes = do
untrack sr (deleteAction : map geometryDeleteAction holes)
withArrayLen (map geometryRawPtr holes) $ \count array ->
checkAndTrackGeometry
sr
(\hCtx -> c_GEOSGeom_createPolygon_r hCtx h array (fromIntegral count))
envelope :: Geometry -> IO (Maybe Geometry)
envelope (Geometry sr _ h) =
checkAndTrackGeometry sr (\hCtx -> c_GEOSEnvelope_r hCtx h)
geomTypeId :: Geometry -> IO (Maybe GeometryType)
geomTypeId (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
value <- c_GEOSGeomTypeId_r hCtx h
return $ if value == 1
then Nothing
else Just $ toEnum (fromIntegral value)
getCoordSeq :: Geometry -> IO (Maybe CoordinateSequence)
getCoordSeq (Geometry sr _ hGeometry) = do
ContextState{..} <- readIORef sr
h <- c_GEOSGeom_getCoordSeq_r hCtx hGeometry
return $ if isNullPtr h
then Nothing
else Just $ CoordinateSequence sr emptyDeleteAction h
getErrorMessage :: IO String
getErrorMessage = c_getErrorMessage >>= peekCString
getExteriorRing :: Geometry -> IO (Maybe Geometry)
getExteriorRing (Geometry sr _ h) =
checkAndDoNotTrack sr (\hCtx -> c_GEOSGetExteriorRing_r hCtx h)
getGeometry :: Geometry -> Int -> IO (Maybe Geometry)
getGeometry (Geometry sr _ h) n =
checkAndDoNotTrack sr (\hCtx -> c_GEOSGetGeometryN_r hCtx h (fromIntegral n))
getNumGeometries :: Geometry -> IO (Maybe Int)
getNumGeometries (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
value <- c_GEOSGetNumGeometries_r hCtx h
return $ if value == 1
then Nothing
else Just $ fromIntegral value
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 idx) valuePtr
case status of
0 -> return Nothing
_ -> do
value <- peek valuePtr
return $ Just (realToFrac value)
getSize :: CoordinateSequence -> IO (Maybe Word)
getSize (CoordinateSequence sr _ h) = do
ContextState{..} <- readIORef sr
alloca $ \sizePtr -> do
status <- c_GEOSCoordSeq_getSize_r hCtx h sizePtr
case status of
0 -> return Nothing
_ -> do
size <- peek sizePtr
return $ Just (fromIntegral size)
getX :: CoordinateSequence -> Word -> IO (Maybe Double)
getX = getOrdinateHelper c_GEOSCoordSeq_getX_r
getY :: CoordinateSequence -> Word -> IO (Maybe Double)
getY = getOrdinateHelper c_GEOSCoordSeq_getY_r
getZ :: CoordinateSequence -> Word -> IO (Maybe Double)
getZ = getOrdinateHelper c_GEOSCoordSeq_getZ_r
intersection :: Geometry -> Geometry -> IO (Maybe Geometry)
intersection (Geometry sr0 _ h0) (Geometry sr1 _ h1) =
checkAndTrackGeometry sr0 (\hCtx -> c_GEOSIntersection_r hCtx h0 h1)
isEmpty :: Geometry -> IO (Maybe Bool)
isEmpty (Geometry sr _ h) = do
ContextState{..} <- readIORef sr
value <- c_GEOSisEmpty_r hCtx h
return $ case value of
0 -> Just False
1 -> Just True
_ -> Nothing
mkContext :: IO Context
mkContext = do
hCtx <- c_initializeGEOSWithHandlers
sr <- newIORef $ ContextState hCtx []
return $ Context sr
mkReader :: Context -> IO (Maybe Reader)
mkReader (Context sr) = checkAndTrack sr c_GEOSWKTReader_create_r c_GEOSWKTReader_destroy_r Reader
mkWriter :: Context -> IO (Maybe Writer)
mkWriter (Context sr) = checkAndTrack sr c_GEOSWKTWriter_create_r c_GEOSWKTWriter_destroy_r Writer
readGeometry :: Reader -> String -> IO (Maybe Geometry)
readGeometry (Reader sr _ h) str = withCString str $ \cs -> do
checkAndTrackGeometry 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 (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 ()
setX :: CoordinateSequence -> Word -> Double -> IO (Maybe ())
setX = setOrdinateHelper c_GEOSCoordSeq_setX_r
setY :: CoordinateSequence -> Word -> Double -> IO (Maybe ())
setY = setOrdinateHelper c_GEOSCoordSeq_setY_r
setZ :: CoordinateSequence -> Word -> Double -> IO (Maybe ())
setZ = setOrdinateHelper 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 (Maybe 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 return Nothing else Just <$> peekCString cs)