module DB.HSQL.Type.Geometric where
import DB.HSQL.Type
(SqlType(SqlPoint,SqlLSeg,SqlPath,SqlBox,SqlPolygon,SqlCircle))
import Database.HSQL.Types(SqlBind(..))
data Point
= Point Double Double
deriving (Eq, Show)
instance SqlBind Point where
fromSqlValue SqlPoint s = case read s of
(x,y) -> Just (Point x y)
fromSqlValue _ _ = Nothing
toSqlValue (Point x y) =
'\'' : shows (x,y) "'"
data Line
= Line Point Point
deriving (Eq, Show)
instance SqlBind Line where
fromSqlValue SqlLSeg s =
case read s of
[(x1,y1),(x2,y2)] -> Just (Line (Point x1 y1) (Point x2 y2))
fromSqlValue _ _ = Nothing
toSqlValue (Line (Point x1 y1) (Point x2 y2)) =
'\'' : shows [(x1,y1),(x2,y2)] "'"
data Path
= OpenPath [Point]
| ClosedPath [Point]
deriving (Eq, Show)
instance SqlBind Path where
fromSqlValue SqlPath ('(':s) =
case read ("["++init s++"]") of
ps -> Just (ClosedPath (map (\(x,y) -> Point x y) ps))
fromSqlValue SqlPath s =
case read s of
ps -> Just (OpenPath (map (\(x,y) -> Point x y) ps))
fromSqlValue SqlLSeg s =
case read s of
[(x1,y1),(x2,y2)] -> Just (OpenPath [(Point x1 y1), (Point x2 y2)])
fromSqlValue SqlPoint s =
case read s of
(x,y) -> Just (ClosedPath [Point x y])
fromSqlValue _ _ = Nothing
toSqlValue (OpenPath ps) = '\'' : shows ps "'"
toSqlValue (ClosedPath ps) = "'(" ++ init (tail (show ps)) ++ "')"
data Box
= Box Double Double Double Double
deriving (Eq, Show)
instance SqlBind Box where
fromSqlValue SqlBox s = case read ("("++s++")") of
((x1,y1),(x2,y2)) -> Just (Box x1 y1 x2 y2)
fromSqlValue _ _ = Nothing
toSqlValue (Box x1 y1 x2 y2) =
'\'' : shows ((x1,y1),(x2,y2)) "'"
data Polygon
= Polygon [Point]
deriving (Eq, Show)
instance SqlBind Polygon where
fromSqlValue SqlPolygon s =
case read ("["++init (tail s)++"]") of
ps -> Just (Polygon (map (\(x,y) -> Point x y) ps))
fromSqlValue _ _ = Nothing
toSqlValue (Polygon ps) =
"'(" ++ init (tail (show ps)) ++ "')"
data Circle
= Circle Point Double
deriving (Eq, Show)
instance SqlBind Circle where
fromSqlValue SqlCircle s = case read ("("++init (tail s)++")") of
((x,y),r) -> Just (Circle (Point x y) r)
fromSqlValue _ _ = Nothing
toSqlValue (Circle (Point x y) r) =
"'<" ++ show (x,y) ++ "," ++ show r ++ "'>"