hsql 1.7.1 → 1.8.1

raw patch · 13 files changed

+982/−748 lines, 13 filesdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog +3/−0
• DB/HSQL/Core.hs +45/−0
• DB/HSQL/Error.hs +60/−0
• DB/HSQL/Type.hs +80/−0
• DB/HSQL/Type/Diverse.hs +43/−0
• DB/HSQL/Type/Geometric.hs +102/−0
• DB/HSQL/Type/NetAddress.hs +64/−0
• DB/HSQL/Type/Numeric.hs +119/−0
• DB/HSQL/Type/Time.hsc +143/−0
• Database/HSQL.hs +235/−0
• Database/HSQL.hsc +0/−607
• Database/HSQL/Types.hs +75/−137
• hsql.cabal +13/−4

@@ -0,0 +1,3 @@+2010-1-24+    1.8.1: exception handling updated from Control.OldException to Control.Exception; +	   refactorings

@@ -0,0 +1,45 @@+module DB.HSQL.Core where++import Prelude hiding(catch)+import Control.Monad(when,unless)+import Control.Exception(Exception,throw,catch,handle)+import Control.Concurrent.MVar(MVar,withMVar,modifyMVar_)+import Data.Dynamic(cast)++import DB.HSQL.Error(SqlError(SqlClosedHandle))++-- | if closed, nothing to do:+closeHandle :: MVar Bool -- ^ closing state ref+            -> IO () -- ^ DB action to do if not closed+            -> IO ()+closeHandle ref action =+	modifyMVar_ ref (\closed -> unless closed action +                         >> return True)++-- | if closed, exception:+checkHandle :: MVar Bool -- ^ closing state ref+            -> IO a -- ^ DB action to do if not closed+            -> IO a+checkHandle ref action =+	withMVar ref (\closed -> when closed (throw SqlClosedHandle) +                      >> action)+++------------------------------------------------------------------------------+-- routines for exception handling+------------------------------------------------------------------------------+-- | Casts, if possible, an Exception to an SqlError:+sqlExceptions :: Exception x +              => x -- ^ the exception thinc to cast to SQLError+              -> Maybe SqlError+sqlExceptions = cast++-- | DEPRECATED: catchSql: Use Control.Exception.catch instead.+{-# DEPRECATED catchSql "Use Control.Exception.catch instead." #-}+catchSql :: IO a -> (SqlError -> IO a) -> IO a+catchSql = catch++-- | DEPRECATED: handleSql: Use Control.Exception.handle instead.+{-# DEPRECATED handleSql "Use Control.Exception.handle instead." #-}+handleSql :: (SqlError -> IO a) -> IO a -> IO a+handleSql = handle

@@ -0,0 +1,60 @@+{-# LANGUAGE CPP,DeriveDataTypeable #-}+{-| Differentiation of DB specific error conditions.+-}+module DB.HSQL.Error(SqlError(..),sqlErrorTc) where++import Control.Exception(Exception(..),SomeException(..))+import Data.Dynamic(Typeable,TyCon,mkTyCon,cast)++import DB.HSQL.Type(SqlType)++-- |   +data SqlError+    = SqlError { seState       :: String+	       , seNativeError :: Int+	       , seErrorMsg    :: String }+    | SqlNoData+    | SqlInvalidHandle+    | SqlStillExecuting+    | SqlNeedData+    | SqlBadTypeCast { seFieldName :: String+   		     , seFieldType :: SqlType }+    | SqlFetchNull { seFieldName :: String }+    | SqlUnknownField { seFieldName :: String }+    | SqlUnsupportedOperation+    | SqlClosedHandle+#ifdef __GLASGOW_HASKELL__+   deriving Typeable+#else++instance Typeable SqlError where+	typeOf _ = mkAppTy sqlErrorTc []+#endif++sqlErrorTc :: TyCon+sqlErrorTc = mkTyCon "Database.HSQL.SqlError"++-- |+instance Show SqlError where+    showsPrec _ (SqlError{seErrorMsg=msg}) = showString msg+    showsPrec _ SqlNoData                  = showString "No data"+    showsPrec _ SqlInvalidHandle           = showString "Invalid handle"+    showsPrec _ SqlStillExecuting          = showString "Stlll executing"+    showsPrec _ SqlNeedData                = showString "Need data"+    showsPrec _ (SqlBadTypeCast name tp)   = +        showString ("The type of "++name++" field can't be converted to " +                    ++show tp++" type")+    showsPrec _ (SqlFetchNull name)        = +        showString ("The value of "++name++" field is null")+    showsPrec _ (SqlUnknownField name)     = +        showString ("Unknown field name: "++name)+    showsPrec _ SqlUnsupportedOperation    = showString "Unsupported operation"+    showsPrec _ SqlClosedHandle = +        showString "The referenced handle is already closed"++-- |+instance Exception SqlError where+    toException = SomeException+    fromException (SomeException exception) =+        cast exception+

@@ -0,0 +1,80 @@+module DB.HSQL.Type where+{-| Differentiation of data types used in DBs.+-}++data SqlType+    -- numeric:         +    = SqlInteger               -- ODBC, MySQL, PostgreSQL, MSI+    | SqlBigInt                -- ODBC, MySQL, PostgreSQL, MSI+    | SqlSmallInt              -- ODBC, MySQL, PostgreSQL+    | SqlTinyInt               -- ODBC, MySQL, PostgreSQL+    | SqlMedInt                --     , MySQL,  +    | SqlDecimal       Int Int -- ODBC, MySQL, PostgreSQL+    | SqlNumeric       Int Int -- ODBC, MySQL, PostgreSQL+    | SqlReal                  -- ODBC, MySQL, PostgreSQL+    | SqlDouble                -- ODBC, MySQL, PostgreSQL+    | SqlFloat                 -- ODBC++    -- monetary:+    | SqlMoney                 --     ,      , PostgreSQL++    -- character:+    | SqlChar          Int     -- ODBC, MySQL, PostgreSQL+    | SqlVarChar       Int     -- ODBC, MySQL, PostgreSQL, MSI+    | SqlLongVarChar   Int     -- ODBC+    | SqlText                  --     ,      , PostgreSQL, MSI+    | SqlWChar         Int     -- ODBC+    | SqlWVarChar      Int     -- ODBC+    | SqlWLongVarChar  Int     -- ODBC++    -- date / time:+    | SqlDate                  -- ODBC, MySQL, PostgreSQL+    | SqlTime                  -- ODBC, MySQL, PostgreSQL+    | SqlTimeTZ                --     ,      , PostgreSQL+    | SqlAbsTime               --     ,      , PostgreSQL+    | SqlRelTime               --     ,      , PostgreSQL+    | SqlTimeInterval          --     ,      , PostgreSQL+    | SqlAbsTimeInterval       --     ,      , PostgreSQL+    | SqlTimeStamp             -- ODBC, MySQL+    | SqlDateTime              --     , MySQL+    | SqlDateTimeTZ            --     , MySQL, PostgreSQL+    | SqlYear                  --     , MySQL++    -- booleans:+    | SqlBit                   -- ODBC,      , PostgreSQL++    -- enums:+    | SqlENUM                  --     , MySQL++    -- geometric types:+    | SqlPoint                 --     ,      , PostgreSQL+    | SqlLSeg                  --     ,      , PostgreSQL+    | SqlPath                  --     ,      , PostgreSQL+    | SqlBox                   --     ,      , PostgreSQL+    | SqlPolygon               --     ,      , PostgreSQL+    | SqlLine                  --     ,      , PostgreSQL  +    | SqlCircle                --     ,      , PostgreSQL++    -- network addresses:+    | SqlINetAddr              --     ,      , PostgreSQL+    | SqlCIDRAddr              --     ,      , PostgreSQL+    | SqlMacAddr               --     ,      , PostgreSQL++    -- bit strings:+    | SqlBinary        Int     -- ODBC,      , PostgreSQL+    | SqlVarBinary     Int     -- ODBC,      , PostgreSQL+    | SqlLongVarBinary Int     -- ODBC++    -- collections:+    | SqlSET                   --     , MySQL+    +    -- lobs:+    | SqlBLOB                  --     , MySQL,           , MSI++    -- unknown:+    | SqlUnknown Int -- ^ HSQL returns @SqlUnknown tp@ for all+	             -- columns for which it cannot determine+	             -- the right type. The @tp@ here is the+	             -- internal type code returned from the+	             -- backend library+    deriving (Eq, Show)

@@ -0,0 +1,43 @@+{-# LANGUAGE TypeSynonymInstances #-}+module DB.HSQL.Type.Diverse where++import Foreign(nullPtr)++import DB.HSQL.Type(SqlType(SqlBit))+import Database.HSQL.Types(SqlBind(..))++-- |+instance SqlBind String where+	fromSqlValue _ = Just++	toSqlValue s = '\'' : foldr mapChar "'" s+		where+			mapChar '\\'   s = '\\':'\\':s+			mapChar '\''   s = '\\':'\'':s+			mapChar '\n'   s = '\\':'n' :s+			mapChar '\r'   s = '\\':'r' :s+			mapChar '\t'   s = '\\':'t' :s+			mapChar '\NUL' s = '\\':'0' :s+			mapChar c      s = c        :s+++-- |+instance SqlBind Bool where+    fromSqlValue SqlBit s = Just (s == "t")+    fromSqlValue _ _ = Nothing++    toSqlValue True  = "'t'"+    toSqlValue False = "'f'"+++-- |+instance SqlBind a => SqlBind (Maybe a) where+  fromSqlCStringLen fieldDef cstr cstrLen+    | cstr == nullPtr = return Nothing+    | otherwise       = do v <- fromSqlCStringLen fieldDef cstr cstrLen+                           return (Just v)+                           +  fromSqlValue tp s   = Just (fromSqlValue tp s)++  toSqlValue (Just v) = toSqlValue v+  toSqlValue Nothing  = "null"

@@ -0,0 +1,102 @@+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   -- closed path+	  ps -> Just (ClosedPath (map  (\(x,y) -> Point x y) ps))+    fromSqlValue SqlPath s = +        case read s of   -- closed path        -- open path+	  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 ++ "'>"+

@@ -0,0 +1,64 @@+module DB.HSQL.Type.NetAddress where++import Data.Char(intToDigit)+import Numeric(readHex,showIntAtBase,readDec)++import DB.HSQL.Type(SqlType(SqlINetAddr,SqlCIDRAddr,SqlMacAddr))+import Database.HSQL.Types(SqlBind(..))++-- | +data INetAddr +    = INetAddr Int Int Int Int Int +    deriving (Eq,Show)++instance SqlBind INetAddr where+    fromSqlValue t s+	| t == SqlINetAddr || t == SqlCIDRAddr =+            case readNum s of+              (x1,s) -> case readNum s of+                (x2,s) -> case readNum s of+                  (x3,s) -> case readNum s of+                    (x4,s) -> case readNum s of+                      (mask,_) -> Just (INetAddr x1 x2 x3 x4 mask)+       | otherwise = Nothing+      where readNum s = case readDec s of+			[(x,'.':s)] -> (x,s)+			[(x,'/':s)] -> (x,s)+			[(x,"")]    -> (x,"")+			_           -> (0,"")++    toSqlValue (INetAddr x1 x2 x3 x4 mask) = +        '\'' : (shows x1 . dot .+		shows x2. dot .+		shows x3 . dot .+		shows x4 . slash .+		shows mask) "'"+      where dot = showChar '.'+	    slash = showChar '/'+++-- | +data MacAddr +    = MacAddr Int Int Int Int Int Int +    deriving (Eq,Show)++instance SqlBind MacAddr where+    fromSqlValue SqlMacAddr s =+        case readHex s of+            [(x1,':':s)] -> case readHex s of+                [(x2,':':s)] -> case readHex s of+                    [(x3,':':s)] -> case readHex s of+                        [(x4,':':s)] -> case readHex s of+                            [(x5,':':s)] -> case readHex s of+                                [(x6,_)] -> Just (MacAddr x1 x2 x3 x4 x5 x6)+    fromSqlValue _ _ = Nothing++    toSqlValue (MacAddr x1 x2 x3 x4 x5 x6) = +        '\'' : (showHex x1 . colon .+		showHex x2 . colon .+		showHex x3 . colon .+		showHex x4 . colon .+		showHex x5 .colon .+		showHex x6) "'"+      where colon = showChar ':'+	    showHex = showIntAtBase 16 intToDigit

@@ -0,0 +1,119 @@+{-# LANGUAGE CPP,ForeignFunctionInterface #-}+module DB.HSQL.Type.Numeric where++import Control.Exception(throw)+import Data.Int(Int64)+import Foreign(Ptr,nullPtr)+import Foreign.C(CString)++import DB.HSQL.Type+    (SqlType(SqlReal,SqlFloat,SqlDouble,SqlNumeric,SqlDecimal+            ,SqlBigInt,SqlTinyInt,SqlInteger,SqlMedInt,SqlSmallInt+            ,SqlText))+import DB.HSQL.Error(SqlError(SqlFetchNull,SqlBadTypeCast))+import Database.HSQL.Types(SqlBind(..))++-- |+foreign import ccall "stdlib.h atoi" +  c_atoi :: CString -> IO Int++#ifdef mingw32_TARGET_OS+foreign import ccall "stdlib.h _atoi64" +  c_atoi64 :: CString -> IO Int64+#else+foreign import ccall "stdlib.h strtoll" +  c_strtoll :: CString -> Ptr CString -> Int -> IO Int64+#endif+++-- |+instance SqlBind Int where+  fromSqlCStringLen (name,sqlType,_) cstr cstrLen+    | cstr == nullPtr        = throw (SqlFetchNull name)+    | sqlType==SqlInteger || +      sqlType==SqlMedInt  ||+      sqlType==SqlTinyInt ||+      sqlType==SqlSmallInt||+      sqlType==SqlBigInt     = c_atoi cstr+    | otherwise = throw (SqlBadTypeCast name sqlType)++  fromSqlValue SqlInteger  s = Just (read s)+  fromSqlValue SqlMedInt   s = Just (read s)+  fromSqlValue SqlTinyInt  s = Just (read s)+  fromSqlValue SqlSmallInt s = Just (read s)+  fromSqlValue SqlBigInt   s = Just (read s)+  fromSqlValue SqlDouble   s = Just (truncate (read s :: Double))+  fromSqlValue SqlText     s = Just (read s)+  fromSqlValue _ _           = Nothing++  toSqlValue s = show s+++-- |+instance SqlBind Int64 where+  fromSqlCStringLen (name,sqlType,_) cstr cstrLen+    | cstr == nullPtr        = throw (SqlFetchNull name)+    | sqlType==SqlInteger ||+      sqlType==SqlMedInt  ||+      sqlType==SqlTinyInt ||+      sqlType==SqlSmallInt||+      sqlType==SqlBigInt     =++#ifdef mingw32_TARGET_OS+       c_atoi64 cstr+#else+       c_strtoll cstr nullPtr 10+#endif++    | otherwise = throw (SqlBadTypeCast name sqlType)++  fromSqlValue SqlInteger s = Just (read s)+  fromSqlValue SqlMedInt s   = Just (read s)+  fromSqlValue SqlTinyInt s  = Just (read s)+  fromSqlValue SqlSmallInt s = Just (read s)+  fromSqlValue SqlBigInt s = Just (read s)+  fromSqlValue SqlDouble s = Just (truncate (read s :: Double))+  fromSqlValue SqlText   s = Just (read s)+  fromSqlValue _ s = Nothing++  toSqlValue val = show val+++-- |+instance SqlBind Integer where+    fromSqlValue SqlInteger  s = Just (read s)+    fromSqlValue SqlMedInt s   = Just (read s)+    fromSqlValue SqlTinyInt s  = Just (read s)+    fromSqlValue SqlSmallInt s = Just (read s)+    fromSqlValue SqlBigInt   s = Just (read s)+    fromSqlValue SqlDouble s = Just (truncate (read s :: Double))+    fromSqlValue SqlText   s = Just (read s)+    fromSqlValue _ _           = Nothing++    toSqlValue s = show s+++-- |+instance SqlBind Double where+    fromSqlValue (SqlDecimal _ _) s = Just (read s)+    fromSqlValue (SqlNumeric _ _) s = Just (read s)+    fromSqlValue SqlDouble  s = Just (read s)+    fromSqlValue SqlReal s = Just (read s)+    fromSqlValue SqlFloat s = Just (read s)+    fromSqlValue SqlText   s = Just (read s)+    fromSqlValue _ _ = Nothing++    toSqlValue d = show d+++-- |+instance SqlBind Float where+    fromSqlValue (SqlDecimal _ _) s = Just (read s)+    fromSqlValue (SqlNumeric _ _) s = Just (read s)+    fromSqlValue SqlDouble  s = Just (read s)+    fromSqlValue SqlReal s = Just (read s)+    fromSqlValue SqlFloat s = Just (read s)+    fromSqlValue SqlText   s = Just (read s)+    fromSqlValue _ _ = Nothing++    toSqlValue d = show d

@@ -0,0 +1,143 @@+{-# LANGUAGE CPP,ForeignFunctionInterface #-}+module DB.HSQL.Type.Time where++import Control.Monad(mplus)+import System.IO.Unsafe(unsafePerformIO)+import System.Time(ClockTime(..),CalendarTime(..)+                  ,getClockTime,toCalendarTime,toUTCTime)+import Text.ParserCombinators.ReadP(ReadP,char,skipSpaces,readP_to_S)+import Text.Read.Lex(readDecP)+import Foreign(Ptr,allocaBytes,pokeByteOff)+import Foreign.C(CTime,CInt)++import DB.HSQL.Type+    (SqlType(SqlTimeTZ,SqlTime,SqlDate,SqlDateTimeTZ,SqlDateTime+            ,SqlTimeStamp,SqlText))+import Database.HSQL.Types(SqlBind(..))++#include <time.h>++-- |+mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime+mkClockTime year mon mday hour min sec tz =+    unsafePerformIO $ do+      allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do+	(#poke struct tm,tm_sec  ) p_tm	(fromIntegral sec  :: CInt)+        (#poke struct tm,tm_min  ) p_tm	(fromIntegral min  :: CInt)+        (#poke struct tm,tm_hour ) p_tm	(fromIntegral hour :: CInt)+        (#poke struct tm,tm_mday ) p_tm	(fromIntegral mday :: CInt)+        (#poke struct tm,tm_mon  ) p_tm	(fromIntegral (mon-1) :: CInt)+        (#poke struct tm,tm_year ) p_tm	(fromIntegral (year-1900) :: CInt)+        (#poke struct tm,tm_isdst) p_tm	(-1 :: CInt)+	t <- mktime p_tm+        let t'=+#if __GLASGOW_HASKELL__ >= 603+                fromEnum t+#else+                t+#endif+        return (TOD (fromIntegral t' + fromIntegral (tz-currTZ)) 0)++foreign import ccall unsafe +  mktime :: Ptr () -> IO CTime++-- |+{-# NOINLINE currTZ #-}+currTZ :: Int+currTZ = +    ctTZ (unsafePerformIO (getClockTime >>= toCalendarTime)) -- Hack++-- |+parseTZ :: ReadP Int+parseTZ =  +    (char '+' >> readDecP) `mplus` (char '-' >> fmap negate readDecP)++-- |+f_read :: ReadP a -> String -> Maybe a+f_read f s = case readP_to_S f s of +               [(x,_)] -> Just x++-- |+readHMS :: ReadP (Int, Int, Int)+readHMS = do+  hour  <- readDecP+  char ':'+  minutes <- readDecP+  char ':'+  seconds <- readDecP+  return (hour, minutes, seconds)++-- |+readYMD :: ReadP (Int, Int, Int)+readYMD = do+  year  <- readDecP+  char '-'+  month <- readDecP+  char '-'+  day   <- readDecP+  return (year, month, day)++-- |+readDateTime :: ReadP (Int, Int, Int, Int, Int, Int)+readDateTime = do+  (year, month, day) <- readYMD+  skipSpaces+  (hour, minutes, seconds) <- readHMS+  return (year, month, day, hour, minutes, seconds)+++-- |+instance SqlBind ClockTime where+    fromSqlValue SqlTimeTZ s = f_read getTimeTZ s+	where getTimeTZ :: ReadP ClockTime+	      getTimeTZ = do+		(hour, minutes, seconds) <- readHMS+		(char '.' >> readDecP) `mplus` (return 0)+		tz <- parseTZ+		return (mkClockTime 1970 1 1 hour minutes seconds (tz*3600))+    fromSqlValue SqlTime s = f_read getTime s+	where getTime :: ReadP ClockTime+	      getTime = do+		(hour, minutes, seconds) <- readHMS+		return (mkClockTime 1970 1 1 hour minutes seconds currTZ)+    fromSqlValue SqlDate s = f_read getDate s+	where getDate :: ReadP ClockTime+	      getDate = do+		(year, month, day) <- readYMD+		return (mkClockTime year month day 0 0 0 currTZ)+    fromSqlValue SqlDateTimeTZ s = f_read getDateTimeTZ s+	where getDateTimeTZ :: ReadP ClockTime+	      getDateTimeTZ = do+	        (year, month, day, hour, minutes, seconds) <- readDateTime+		char '.' >> readDecP -- ) `mplus` (return 0)+                tz <- parseTZ+		return (mkClockTime year month day +                                    hour minutes seconds +                                    (tz*3600))+    -- The only driver which seems to report the type as SqlTimeStamp seems+    -- to be the MySQL driver. MySQL (at least 4.1) uses the same format for+    -- datetime and timestamp columns.+    -- Allow SqlText to support SQLite, which reports everything as SqlText+    fromSqlValue t s +        | t == SqlDateTime || t == SqlTimeStamp || t == SqlText = +            f_read getDateTime s+                where getDateTime :: ReadP ClockTime+		      getDateTime = do+			(year, month, day, hour, minutes, seconds) <- +                            readDateTime+			return (mkClockTime year month day +                                            hour minutes seconds +                                            currTZ)+    fromSqlValue _ _ = Nothing++    toSqlValue ct = +        '\'' : (shows (ctYear t) . score .+                shows (ctMonth t) . score .+                shows (ctDay t) . space .+                shows (ctHour t) . colon .+                shows (ctMin t) . colon .+                shows (ctSec t)) "'"+        where t = toUTCTime ct+              score = showChar '-'+              space = showChar ' '+              colon = showChar ':'

@@ -0,0 +1,235 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-| Module      :  Database.HSQL+    Copyright   :  (c) Krasimir Angelov 2003+    License     :  BSD-style++    Maintainer  :  ka2_mail@yahoo.com+    Stability   :  provisional+    Portability :  portable++    The module provides an abstract database interface+-}+module Database.HSQL+    (+    -- * Connect\/Disconnect+    Connection+    , disconnect        -- :: Connection -> IO ()+    +    -- * Command Execution Functions+    -- | Once a connection to a database has been successfully established, +    -- the functions described here are used to perform+    -- SQL queries and commands.+    , execute           -- :: Connection -> String -> IO ()+    , Statement+    , query             -- :: Connection -> String -> IO Statement+    , closeStatement    -- :: Statement -> IO ()+    , fetch             -- :: Statement -> IO Bool+    +    -- * Retrieving Statement values and types+    , FieldDef, SqlBind(..)+    , getFieldValue     -- :: SqlBind a => Statement -> String -> IO a+    , getFieldValueMB   +    , getFieldValue'    -- :: SqlBind a => Statement -> String -> a -> IO a+    , getFieldValueType -- :: Statement -> String -> (SqlType, Bool)+    , getFieldsTypes    -- :: Statement -> [(String, SqlType, Bool)]+	+    -- * Transactions+    , inTransaction     -- :: Connection -> (Connection -> IO a) -> IO a+    +    -- * Utilities+    , forEachRow        -- :: (Statement -> s -> IO s) -- ^ an action+    , forEachRow'       -- :: (Statement -> IO ()) -> Statement -> IO ()+    , collectRows       -- :: (Statement -> IO a) -> Statement -> IO [a]++    -- * SQL Exceptions handling+    , SqlError(..)+    , catchSql+    , handleSql+    , sqlExceptions     -- :: Exception -> Maybe SqlError+    +    -- * Metadata+    , tables            -- :: Connection -> IO [String]+    , describe          -- :: Connection -> String -> IO [FieldDef]++    -- * Extra types+    , Point(..), Line(..), Path(..), Box(..), Circle(..), Polygon(..)+    , INetAddr(..), MacAddr(..)+    , SqlType(..)+    ) where++import Prelude hiding(catch)+import Control.Monad(when)+import Control.Exception(SomeException,finally,throwIO,throw,catch)++import DB.HSQL.Type+import DB.HSQL.Type.Numeric+import DB.HSQL.Type.Time+import DB.HSQL.Type.Geometric+import DB.HSQL.Type.NetAddress+import DB.HSQL.Type.Diverse()+import DB.HSQL.Error+import DB.HSQL.Core+import Database.HSQL.Types(FieldDef,Connection(..),Statement(..)+                          ,SqlBind(fromSqlCStringLen))++------------------------------------------------------------------------------+-- Operations on the connection+------------------------------------------------------------------------------+-- | Closes the connection. Performing 'disconnect' on a connection that has+-- already been closed has no effect.+-- All other operations on a closed connection will fail.+disconnect :: Connection -> IO ()+disconnect conn = +    closeHandle (connClosed conn) (connDisconnect conn)+	+-- | Submits a command to the database.+execute :: Connection  -- ^ the database connection+        -> String      -- ^ the text of SQL command+        -> IO ()+execute conn query = +    checkHandle (connClosed conn) (connExecute conn query)++-- | Executes a query and returns a result set+query :: Connection    -- ^ the database connection+      -> String        -- ^ the text of SQL query+      -> IO Statement  -- ^ the associated statement. Must be closed with +                       -- the 'closeStatement' function+query conn query = +    checkHandle (connClosed conn) (connQuery conn query)++-- | List all tables in the database.+tables :: Connection   -- ^ Database connection+       -> IO [String]  -- ^ The names of all tables in the database.+tables conn = +    checkHandle (connClosed conn) (connTables conn)++-- | List all columns in a table along with their types and @nullable@ flags+describe :: Connection    -- ^ Database connection+	 -> String        -- ^ Name of a database table+	 -> IO [FieldDef] -- ^ The list of fields in the table+describe conn table = +    checkHandle (connClosed conn) (connDescribe conn table)++------------------------------------------------------------------------------+-- transactions+------------------------------------------------------------------------------++-- | The 'inTransaction' function executes the specified action in transaction+--  mode.+-- If the action completes successfully then the transaction will be commited.+-- If the action completes with an exception then the transaction will be+-- rolled back and the exception will be throw again.+-- A transaction is to catch ANY exception, so 'SomeException' is adequate.+inTransaction :: Connection            -- ^ Database connection+              -> (Connection -> IO a)  -- ^ an action+              -> IO a                  -- ^ the returned value is the result+                                        -- returned from action+inTransaction conn action = do+  checkHandle (connClosed conn) (connBeginTransaction conn)+  r <- catch (action conn) +             (\(err::SomeException) -> do +                checkHandle (connClosed conn) +                            (connRollbackTransaction conn)+	        throwIO err)+  checkHandle (connClosed conn) (connCommitTransaction conn)+  return r++------------------------------------------------------------------------------+-- Operations on the statements+------------------------------------------------------------------------------+-- | 'fetch' fetches the next rowset of data from the result set.+-- The values from columns can be retrieved with 'getFieldValue' function.+fetch :: Statement -> IO Bool+fetch stmt = checkHandle (stmtClosed stmt) (stmtFetch stmt)++-- | 'closeStatement' stops processing associated with a specific statement,+-- closes any open cursors associated with the statement, discards pending+-- results, and frees all resources associated with the statement.+-- Performing 'closeStatement' on a statement that has already been closed+-- has no effect. All other operations on a closed statement will fail.+closeStatement :: Statement -> IO ()+closeStatement stmt = closeHandle (stmtClosed stmt) (stmtClose stmt)++-- | Returns the type and the @nullable@ flag for field with specified name+getFieldValueType :: Statement -> String -> (SqlType, Bool)+getFieldValueType stmt name = (sqlType, nullable)+    where (sqlType,nullable,colNumber) = +              findFieldInfo name (stmtFields stmt) 0++-- | Returns the list of fields with their types and @nullable@ flags+getFieldsTypes :: Statement -> [(String, SqlType, Bool)]+getFieldsTypes stmt = stmtFields stmt++findFieldInfo :: String -> [FieldDef] -> Int -> (SqlType,Bool,Int)+findFieldInfo name [] colNumber = throw (SqlUnknownField name)+findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber+    | name == name' = (sqlType,nullable,colNumber)+    | otherwise = findFieldInfo name fields $! (colNumber+1)+++------------------------------------------------------------------------------+-- binding+------------------------------------------------------------------------------+-- | Retrieves the value of field with the specified name.+getFieldValue :: SqlBind a => Statement    -- ^ result table data+                           -> String       -- ^ field name+                           -> IO a         -- ^ field value+getFieldValue stmt name = do+  stmtGetCol stmt colNumber (name,sqlType,nullable) fromSqlCStringLen+  where (sqlType,nullable,colNumber) = +            findFieldInfo name (stmtFields stmt) 0++{-# DEPRECATED getFieldValueMB "Use getFieldValue instead." #-}+getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)+getFieldValueMB = getFieldValue++-- | Retrieves the value of field with the specified name.+-- If the field value is @null@ then the function will return the default value.+getFieldValue' :: SqlBind a => Statement+                            -> String     -- ^ Field name+                            -> a          -- ^ Default field value+                            -> IO a       -- ^ Field value+getFieldValue' stmt name def = do+  mb_v <- getFieldValue stmt name+  return (case mb_v of { Nothing -> def; Just a -> a })+++------------------------------------------------------------------------------+-- helpers+------------------------------------------------------------------------------+-- | The 'forEachRow' function iterates through the result set in 'Statement'+-- and executes the given action for each row in the set.+-- The function closes the 'Statement' after the last row processing or if+-- the given action raises an exception.+forEachRow :: (Statement -> s -> IO s) -- ^ an action+           -> Statement                -- ^ the statement+           -> s                        -- ^ initial state+           -> IO s                     -- ^ final state+forEachRow f stmt s = loop s `finally` closeStatement stmt+  where loop s = do success <- fetch stmt+                    if success then f stmt s >>= loop else return s++-- | The 'forEachRow\'' function is analogous to 'forEachRow' but doesn't+-- provide state.+-- The function closes the 'Statement' after the last row processing or if the+-- given action raises an exception.+forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()+forEachRow' f stmt = loop `finally` closeStatement stmt+  where loop = do success <- fetch stmt+                  when success (f stmt >> loop)++-- | The 'collectRows' function iterates through the result set in 'Statement'+-- and executes the given action for each row in the set. The values returned+-- from action are collected and returned as list. The function closes the+-- 'Statement' after the last row processing or if the given action raises an+-- exception.+collectRows :: (Statement -> IO a) -> Statement -> IO [a]+collectRows f stmt = loop `finally` closeStatement stmt+  where loop = do success <- fetch stmt+                  if success+                    then do x <- f stmt+                            xs <- loop+                            return (x:xs)+                    else return []++

@@ -1,607 +0,0 @@-------------------------------------------------------------------------------------------{-| Module      :  Database.HSQL.ODBC-    Copyright   :  (c) Krasimir Angelov 2003-    License     :  BSD-style--    Maintainer  :  ka2_mail@yahoo.com-    Stability   :  provisional-    Portability :  portable--    The module provides an abstract database interface--}--------------------------------------------------------------------------------------------module Database.HSQL-	(-	-- * Connect\/Disconnect-	  Connection-	, disconnect        -- :: Connection -> IO ()-	-	-- * Command Execution Functions-	-- | Once a connection to a database has been successfully established, -	-- the functions described here are used to perform SQL queries and commands.-	, execute           -- :: Connection -> String -> IO ()-	, Statement-	, query             -- :: Connection -> String -> IO Statement-	, closeStatement    -- :: Statement -> IO ()-	, fetch             -- :: Statement -> IO Bool-	-	-- * Retrieving Statement values and types-	, FieldDef, SqlType(..), SqlBind(..)-	, getFieldValue     -- :: SqlBind a => Statement -> String -> IO a-	, getFieldValueMB-	, getFieldValue'    -- :: SqlBind a => Statement -> String -> a -> IO a-	, getFieldValueType -- :: Statement -> String -> (SqlType, Bool)-	, getFieldsTypes    -- :: Statement -> [(String, SqlType, Bool)]-	-	-- * Transactions-	, inTransaction     -- :: Connection -> (Connection -> IO a) -> IO a--	-	-- * SQL Exceptions handling-	, SqlError(..)-	, catchSql          -- :: IO a -> (SqlError -> IO a) -> IO a-	, handleSql         -- :: (SqlError -> IO a) -> IO a -> IO a-	, sqlExceptions     -- :: Exception -> Maybe SqlError-	-	-- * Utilities-	, forEachRow        -- :: (Statement -> s -> IO s) -- ^ an action-	, forEachRow'       -- :: (Statement -> IO ()) -> Statement -> IO ()-	, collectRows       -- :: (Statement -> IO a) -> Statement -> IO [a]-	-	-- * Metadata-	, tables            -- :: Connection -> IO [String]-	, describe          -- :: Connection -> String -> IO [FieldDef]--	-- * Extra types-	, Point(..), Line(..), Path(..), Box(..), Circle(..), Polygon(..)-	) where--import Prelude hiding (catch)-import Foreign-import Foreign.C-import Data.Int-import Data.Char-import Data.Dynamic-import System.Time-import System.IO.Unsafe(unsafePerformIO)-import Control.Monad(when,unless,mplus)-import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..), finally, catch, throwIO)-import Control.Concurrent.MVar-import Text.ParserCombinators.ReadP-import Text.Read-import Text.Read.Lex-import Numeric-import Database.HSQL.Types--#include <time.h>---------------------------------------------------------------------------------------------- routines for exception handling--------------------------------------------------------------------------------------------catchSql :: IO a -> (SqlError -> IO a) -> IO a-catchSql = catchDyn--handleSql :: (SqlError -> IO a) -> IO a -> IO a-handleSql h f = catchDyn f h--sqlExceptions :: Exception -> Maybe SqlError-sqlExceptions e = dynExceptions e >>= fromDynamic--checkHandle :: MVar Bool -> IO a -> IO a-checkHandle ref action =-	withMVar ref (\closed -> when closed (throwDyn SqlClosedHandle) >> action)--closeHandle :: MVar Bool -> IO () -> IO ()-closeHandle ref action =-	modifyMVar_ ref (\closed -> unless closed action >> return True)---------------------------------------------------------------------------------------------- Operations on the connection---------------------------------------------------------------------------------------------- | Closes the connection. Performing 'disconnect' on a connection that has already been --- closed has no effect. All other operations on a closed connection will fail.-disconnect :: Connection -> IO ()-disconnect conn = closeHandle (connClosed conn) (connDisconnect conn)-	--- | Submits a command to the database.-execute :: Connection  -- ^ the database connection-        -> String      -- ^ the text of SQL command-        -> IO ()-execute conn query = checkHandle (connClosed conn) (connExecute conn query)---- | Executes a query and returns a result set-query :: Connection    -- ^ the database connection-      -> String        -- ^ the text of SQL query-      -> IO Statement  -- ^ the associated statement. Must be closed with -                       -- the 'closeStatement' function-query conn query = checkHandle (connClosed conn) (connQuery conn query)-	---- | List all tables in the database.-tables :: Connection   -- ^ Database connection-       -> IO [String]  -- ^ The names of all tables in the database.-tables conn = checkHandle (connClosed conn) (connTables conn)---- | List all columns in a table along with their types and @nullable@ flags-describe :: Connection    -- ^ Database connection-	 -> String        -- ^ Name of a database table-	 -> IO [FieldDef] -- ^ The list of fields in the table-describe conn table = checkHandle (connClosed conn) (connDescribe conn table)---------------------------------------------------------------------------------------------- transactions---------------------------------------------------------------------------------------------- | The 'inTransaction' function executes the specified action in transaction mode.--- If the action completes successfully then the transaction will be commited.--- If the action completes with an exception then the transaction will be rolled back--- and the exception will be throw again.-inTransaction :: Connection-              -> (Connection -> IO a)  -- ^ an action-              -> IO a                  -- ^ the returned value is the result returned from action-inTransaction conn action = do-	checkHandle (connClosed conn) (connBeginTransaction conn)-	r <- catch (action conn) (\err -> do-			checkHandle (connClosed conn) (connRollbackTransaction conn)-			throwIO err)-	checkHandle (connClosed conn) (connCommitTransaction conn)-	return r---------------------------------------------------------------------------------------------- Operations on the statements---------------------------------------------------------------------------------------------- | 'fetch' fetches the next rowset of data from the result set.--- The values from columns can be retrieved with 'getFieldValue' function.-fetch :: Statement -> IO Bool-fetch stmt = checkHandle (stmtClosed stmt) (stmtFetch stmt)---- | 'closeStatement' stops processing associated with a specific statement, closes any open cursors--- associated with the statement, discards pending results, and frees all resources associated with--- the statement. Performing 'closeStatement' on a statement that has already been --- closed has no effect. All other operations on a closed statement will fail.-closeStatement :: Statement -> IO ()-closeStatement stmt = closeHandle (stmtClosed stmt) (stmtClose stmt)---- | Returns the type and the @nullable@ flag for field with specified name-getFieldValueType :: Statement -> String -> (SqlType, Bool)-getFieldValueType stmt name = (sqlType, nullable)-	where-		(sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0---- | Returns the list of fields with their types and @nullable@ flags-getFieldsTypes :: Statement -> [(String, SqlType, Bool)]-getFieldsTypes stmt = stmtFields stmt--findFieldInfo :: String -> [FieldDef] -> Int -> (SqlType,Bool,Int)-findFieldInfo name [] colNumber = throwDyn (SqlUnknownField name)-findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber-	| name == name' = (sqlType,nullable,colNumber)-	| otherwise     = findFieldInfo name fields $! (colNumber+1)---------------------------------------------------------------------------------------------- binding--------------------------------------------------------------------------------------------foreign import ccall "stdlib.h atoi" c_atoi :: CString -> IO Int-#ifdef mingw32_TARGET_OS-foreign import ccall "stdlib.h _atoi64" c_atoi64 :: CString -> IO Int64-#else-foreign import ccall "stdlib.h strtoll" c_strtoll :: CString -> Ptr CString -> Int -> IO Int64-#endif--instance SqlBind a => SqlBind (Maybe a) where-  fromSqlCStringLen fieldDef cstr cstrLen-    | cstr == nullPtr = return Nothing-    | otherwise       = do v <- fromSqlCStringLen fieldDef cstr cstrLen-                           return (Just v)-                           -  fromSqlValue tp s   = Just (fromSqlValue tp s)--  toSqlValue (Just v) = toSqlValue v-  toSqlValue Nothing  = "null"--instance SqlBind Int where-  fromSqlCStringLen (name,sqlType,_) cstr cstrLen-    | cstr == nullPtr        = throwDyn (SqlFetchNull name)-    | sqlType==SqlInteger || -      sqlType==SqlMedInt  ||-      sqlType==SqlTinyInt ||-      sqlType==SqlSmallInt||-      sqlType==SqlBigInt     = c_atoi cstr-    | otherwise              = throwDyn (SqlBadTypeCast name sqlType)--  fromSqlValue SqlInteger  s = Just (read s)-  fromSqlValue SqlMedInt   s = Just (read s)-  fromSqlValue SqlTinyInt  s = Just (read s)-  fromSqlValue SqlSmallInt s = Just (read s)-  fromSqlValue SqlBigInt   s = Just (read s)-  fromSqlValue SqlDouble   s = Just (truncate (read s :: Double))-  fromSqlValue SqlText     s = Just (read s)-  fromSqlValue _ _           = Nothing--  toSqlValue s = show s--instance SqlBind Int64 where-  fromSqlCStringLen (name,sqlType,_) cstr cstrLen-    | cstr == nullPtr        = throwDyn (SqlFetchNull name)-    | sqlType==SqlInteger ||-      sqlType==SqlMedInt  ||-      sqlType==SqlTinyInt ||-      sqlType==SqlSmallInt||-      sqlType==SqlBigInt     =-#ifdef mingw32_TARGET_OS-	                       c_atoi64 cstr-#else-	                       c_strtoll cstr nullPtr 10-#endif-    | otherwise              = throwDyn (SqlBadTypeCast name sqlType)--  fromSqlValue SqlInteger s = Just (read s)-  fromSqlValue SqlMedInt s   = Just (read s)-  fromSqlValue SqlTinyInt s  = Just (read s)-  fromSqlValue SqlSmallInt s = Just (read s)-  fromSqlValue SqlBigInt s = Just (read s)-  fromSqlValue SqlDouble s = Just (truncate (read s :: Double))-  fromSqlValue SqlText   s = Just (read s)-  fromSqlValue _ s = Nothing--  toSqlValue val = show val--instance SqlBind Integer where-	fromSqlValue SqlInteger  s = Just (read s)-	fromSqlValue SqlMedInt s   = Just (read s)-	fromSqlValue SqlTinyInt s  = Just (read s)-	fromSqlValue SqlSmallInt s = Just (read s)-	fromSqlValue SqlBigInt   s = Just (read s)-	fromSqlValue SqlDouble s = Just (truncate (read s :: Double))-	fromSqlValue SqlText   s = Just (read s)-	fromSqlValue _ _           = Nothing--	toSqlValue s = show s-instance SqlBind String where-	fromSqlValue _ = Just--	toSqlValue s = '\'' : foldr mapChar "'" s-		where-			mapChar '\\'   s = '\\':'\\':s-			mapChar '\''   s = '\\':'\'':s-			mapChar '\n'   s = '\\':'n' :s-			mapChar '\r'   s = '\\':'r' :s-			mapChar '\t'   s = '\\':'t' :s-			mapChar '\NUL' s = '\\':'0' :s-			mapChar c      s = c        :s--instance SqlBind Bool where-	fromSqlValue SqlBit s = Just (s == "t")-	fromSqlValue _ _ = Nothing--	toSqlValue True  = "'t'"-	toSqlValue False = "'f'"--instance SqlBind Double where-	fromSqlValue (SqlDecimal _ _) s = Just (read s)-	fromSqlValue (SqlNumeric _ _) s = Just (read s)-	fromSqlValue SqlDouble  s = Just (read s)-	fromSqlValue SqlReal s = Just (read s)-	fromSqlValue SqlFloat s = Just (read s)-	fromSqlValue SqlText   s = Just (read s)-	fromSqlValue _ _ = Nothing--	toSqlValue d = show d--instance SqlBind Float where-	fromSqlValue (SqlDecimal _ _) s = Just (read s)-	fromSqlValue (SqlNumeric _ _) s = Just (read s)-	fromSqlValue SqlDouble  s = Just (read s)-	fromSqlValue SqlReal s = Just (read s)-	fromSqlValue SqlFloat s = Just (read s)-	fromSqlValue SqlText   s = Just (read s)-	fromSqlValue _ _ = Nothing--	toSqlValue d = show d--mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime-mkClockTime year mon mday hour min sec tz =-	unsafePerformIO $ do-		allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do-			(#poke struct tm,tm_sec  ) p_tm	(fromIntegral sec  :: CInt)-			(#poke struct tm,tm_min  ) p_tm	(fromIntegral min  :: CInt)-			(#poke struct tm,tm_hour ) p_tm	(fromIntegral hour :: CInt)-			(#poke struct tm,tm_mday ) p_tm	(fromIntegral mday :: CInt)-			(#poke struct tm,tm_mon  ) p_tm	(fromIntegral (mon-1) :: CInt)-			(#poke struct tm,tm_year ) p_tm	(fromIntegral (year-1900) :: CInt)-			(#poke struct tm,tm_isdst) p_tm	(-1 :: CInt)-			t <- mktime p_tm-#if __GLASGOW_HASKELL__ >= 603-			return (TOD (fromIntegral (fromEnum t) + fromIntegral (tz-currTZ)) 0)-#else-			return (TOD (fromIntegral t + fromIntegral (tz-currTZ)) 0)-#endif-foreign import ccall unsafe mktime :: Ptr () -> IO CTime--{-# NOINLINE currTZ #-}-currTZ :: Int-currTZ = ctTZ (unsafePerformIO (getClockTime >>= toCalendarTime))                  -- Hack--parseTZ :: ReadP Int-parseTZ =  (char '+' >> readDecP) `mplus` (char '-' >> fmap negate readDecP)--f_read :: ReadP a -> String -> Maybe a-f_read f s = case readP_to_S f s of {[(x,_)] -> Just x}--readHMS :: ReadP (Int, Int, Int)-readHMS = do-	  hour  <- readDecP-	  char ':'-	  minutes <- readDecP-	  char ':'-	  seconds <- readDecP-	  return (hour, minutes, seconds)--readYMD :: ReadP (Int, Int, Int)-readYMD = do-	  year  <- readDecP-	  char '-'-	  month <- readDecP-	  char '-'-	  day   <- readDecP-	  return (year, month, day)--readDateTime :: ReadP (Int, Int, Int, Int, Int, Int)-readDateTime = do-	       (year, month, day) <- readYMD-	       skipSpaces-	       (hour, minutes, seconds) <- readHMS-	       return (year, month, day, hour, minutes, seconds)--instance SqlBind ClockTime where-	fromSqlValue SqlTimeTZ s = f_read getTimeTZ s-		where-			getTimeTZ :: ReadP ClockTime-			getTimeTZ = do-				    (hour, minutes, seconds) <- readHMS-				    (char '.' >> readDecP) `mplus` (return 0)-				    tz <- parseTZ-				    return (mkClockTime 1970 1 1 hour minutes seconds (tz*3600))--	fromSqlValue SqlTime s = f_read getTime s-		where-			getTime :: ReadP ClockTime-			getTime = do-				  (hour, minutes, seconds) <- readHMS-				  return (mkClockTime 1970 1 1 hour minutes seconds currTZ)--	fromSqlValue SqlDate s = f_read getDate s-		where-			getDate :: ReadP ClockTime-			getDate = do-				  (year, month, day) <- readYMD-				  return (mkClockTime year month day 0 0 0 currTZ)--	fromSqlValue SqlDateTimeTZ s = f_read getDateTimeTZ s-		where-			getDateTimeTZ :: ReadP ClockTime-			getDateTimeTZ = do-				(year, month, day, hour, minutes, seconds) <- readDateTime-				char '.' >> readDecP -- ) `mplus` (return 0)-				tz    <- parseTZ-				return (mkClockTime year month day hour minutes seconds (tz*3600))--        -- The only driver which seems to report the type as SqlTimeStamp seems-	-- to be the MySQL driver. MySQL (at least 4.1) uses the same format for datetime and -	-- timestamp columns.-	-- Allow SqlText to support SQLite, which reports everything as SqlText-        fromSqlValue t s | t == SqlDateTime || t == SqlTimeStamp || t == SqlText = f_read getDateTime s-		where-			getDateTime :: ReadP ClockTime-			getDateTime = do-				(year, month, day, hour, minutes, seconds) <- readDateTime-				return (mkClockTime year month day hour minutes seconds currTZ)--	fromSqlValue _ _ = Nothing--	toSqlValue ct = '\'' : (shows (ctYear t) .-                                score .-                                shows (ctMonth t) .-                                score .-                                shows (ctDay t) .-                                space .-                                shows (ctHour t) .-                                colon .-                                shows (ctMin t) .-                                colon .-                                shows (ctSec t)) "'"-                       where-                         t = toUTCTime ct-                         score = showChar '-'-                         space = showChar ' '-                         colon = showChar ':'--data Point = Point Double Double deriving (Eq, Show)-data Line   = Line Point Point deriving (Eq, Show)-data Path  = OpenPath [Point] | ClosedPath [Point] deriving (Eq, Show)-data Box   = Box Double Double Double Double deriving (Eq, Show)-data Circle = Circle Point Double deriving (Eq, Show)-data Polygon = Polygon [Point] 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) "'"--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)] "'"--instance SqlBind Path where-	fromSqlValue SqlPath ('(':s) = case read ("["++init s++"]") of   -- closed path-		ps -> Just (ClosedPath (map  (\(x,y) -> Point x y) ps))-	fromSqlValue SqlPath s = case read s of   -- closed path        -- open path-		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)) ++ "')"--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)) "'"--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)) ++ "')"--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 ++ "'>"--data INetAddr = INetAddr Int Int Int Int Int deriving (Eq,Show)--instance SqlBind INetAddr where-	fromSqlValue t s-		| t == SqlINetAddr || t == SqlCIDRAddr =-			case readNum s of-				(x1,s) -> case readNum s of-					(x2,s) -> case readNum s of-						(x3,s) -> case readNum s of-							(x4,s) -> case readNum s of-								(mask,_) -> Just (INetAddr x1 x2 x3 x4 mask)-		| otherwise = Nothing-		where-			readNum s = case readDec s of-				[(x,'.':s)] -> (x,s)-				[(x,'/':s)] -> (x,s)-				[(x,"")]    -> (x,"")-				_           -> (0,"")--	toSqlValue (INetAddr x1 x2 x3 x4 mask) = '\'' :-		(shows x1 .-		 dot .-		 shows x2.-		 dot .-		 shows x3 .-		 dot .-		 shows x4 .-		 slash .-		 shows mask) "'"-		where-			dot = showChar '.'-			slash = showChar '/'--data MacAddr = MacAddr Int Int Int Int Int Int deriving (Eq,Show)--instance SqlBind MacAddr where-	fromSqlValue SqlMacAddr s =-		case readHex s of-			[(x1,':':s)] -> case readHex s of-				[(x2,':':s)] -> case readHex s of-					[(x3,':':s)] -> case readHex s of-						[(x4,':':s)] -> case readHex s of-							[(x5,':':s)] -> case readHex s of-								[(x6,_)] -> Just (MacAddr x1 x2 x3 x4 x5 x6)-	fromSqlValue _ _ = Nothing--	toSqlValue (MacAddr x1 x2 x3 x4 x5 x6) = '\'' :-		(showHex x1 .-		 colon .-		 showHex x2 .-		 colon .-		 showHex x3 .-		 colon .-		 showHex x4 .-		 colon .-		 showHex x5 .-		 colon .-		 showHex x6) "'"-		where-			colon = showChar ':'-			showHex = showIntAtBase 16 intToDigit---- | Retrieves the value of field with the specified name.-getFieldValue :: SqlBind a => Statement-                           -> String       -- ^ Field name-                           -> IO a         -- ^ Field value-getFieldValue stmt name = do-  stmtGetCol stmt colNumber (name,sqlType,nullable) fromSqlCStringLen-  where-    (sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0--{-# DEPRECATED getFieldValueMB "Use getFieldValue instead." #-}-getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)-getFieldValueMB = getFieldValue---- | Retrieves the value of field with the specified name.--- If the field value is @null@ then the function will return the default value.-getFieldValue' :: SqlBind a => Statement-                            -> String     -- ^ Field name-                            -> a          -- ^ Default field value-                            -> IO a       -- ^ Field value-getFieldValue' stmt name def = do-  mb_v <- getFieldValue stmt name-  return (case mb_v of { Nothing -> def; Just a -> a })----------------------------------------------------------------------------------------------- helpers---------------------------------------------------------------------------------------------- | The 'forEachRow' function iterates through the result set in 'Statement' and--- executes the given action for each row in the set. The function closes the 'Statement'--- after the last row processing or if the given action raises an exception.-forEachRow :: (Statement -> s -> IO s) -- ^ an action-           -> Statement                -- ^ the statement-           -> s                        -- ^ initial state-           -> IO s                     -- ^ final state-forEachRow f stmt s = loop s `finally` closeStatement stmt-    where-        loop s = do-	        success <- fetch stmt-	        if success then f stmt s >>= loop else return s---- | The 'forEachRow\'' function is analogous to 'forEachRow' but doesn't provide state.--- The function closes the 'Statement' after the last row processing or if the given--- action raises an exception.-forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()-forEachRow' f stmt = loop `finally` closeStatement stmt-    where-        loop = do-	        success <- fetch stmt-	        when success (f stmt >> loop)---- | The 'collectRows' function iterates through the result set in 'Statement' and--- executes the given action for each row in the set. The values returned from action--- are collected and returned as list. The function closes the 'Statement' after the--- last row processing or if the given action raises an exception.-collectRows :: (Statement -> IO a) -> Statement -> IO [a]-collectRows f stmt = loop `finally` closeStatement stmt-	where-		loop = do-			success <- fetch stmt-			if success-				then do-					x <- f stmt-					xs <- loop-					return (x:xs)-				else return []

@@ -1,153 +1,91 @@+{-# LANGUAGE RankNTypes #-} -- #hide-module Database.HSQL.Types where--import Control.Concurrent.MVar-import Control.Exception-import Data.Dynamic-import Foreign-import Foreign.C--type FieldDef = (String, SqlType, Bool)--data SqlType-	= SqlChar          Int               -- ODBC, MySQL, PostgreSQL-	| SqlVarChar       Int               -- ODBC, MySQL, PostgreSQL, MSI-	| SqlLongVarChar   Int               -- ODBC-	| SqlText                            --     ,      , PostgreSQL, MSI-	| SqlWChar         Int               -- ODBC-	| SqlWVarChar      Int               -- ODBC-	| SqlWLongVarChar  Int               -- ODBC-	| SqlDecimal       Int Int           -- ODBC-	| SqlNumeric       Int Int           -- ODBC, MySQL, PostgreSQL-	| SqlSmallInt                        -- ODBC, MySQL, PostgreSQL-	| SqlMedInt                          --     , MySQL,           -	| SqlInteger                         -- ODBC, MySQL, PostgreSQL, MSI-	| SqlReal                            -- ODBC, MySQL, PostgreSQL-	| SqlFloat                           -- ODBC-	| SqlDouble                          -- ODBC, MySQL, PostgreSQL-	| SqlBit                             -- ODBC,      , PostgreSQL-	| SqlTinyInt                         -- ODBC, MySQL, PostgreSQL-	| SqlBigInt                          -- ODBC, MySQL, PostgreSQL, MSI-	| SqlBinary        Int               -- ODBC,      , PostgreSQL-	| SqlVarBinary     Int               -- ODBC,      , PostgreSQL-	| SqlLongVarBinary Int               -- ODBC-	| SqlDate                            -- ODBC, MySQL, PostgreSQL-	| SqlTime                            -- ODBC, MySQL, PostgreSQL-	| SqlTimeTZ                          --     ,      , PostgreSQL-	| SqlAbsTime                         --     ,      , PostgreSQL-	| SqlRelTime                         --     ,      , PostgreSQL-	| SqlTimeInterval                    --     ,      , PostgreSQL-	| SqlAbsTimeInterval                 --     ,      , PostgreSQL-	| SqlTimeStamp                       -- ODBC, MySQL-	| SqlDateTime                        --     , MySQL-	| SqlDateTimeTZ                      --     , MySQL, PostgreSQL-	| SqlYear                            --     , MySQL-	| SqlSET                             --     , MySQL-	| SqlENUM                            --     , MySQL-	| SqlBLOB                            --     , MySQL,           , MSI-	| SqlMoney                           --     ,      , PostgreSQL-	| SqlINetAddr                        --     ,      , PostgreSQL-	| SqlCIDRAddr                        --     ,      , PostgreSQL-	| SqlMacAddr                         --     ,      , PostgreSQL-	| SqlPoint                           --     ,      , PostgreSQL-	| SqlLSeg                            --     ,      , PostgreSQL-	| SqlPath                            --     ,      , PostgreSQL-	| SqlBox                             --     ,      , PostgreSQL-	| SqlPolygon                         --     ,      , PostgreSQL-	| SqlLine                            --     ,      , PostgreSQL-	| SqlCircle                          --     ,      , PostgreSQL-	| SqlUnknown Int                     -- ^ HSQL returns @SqlUnknown tp@ for all-	                                     -- columns for which it cannot determine-	                                     -- the right type. The @tp@ here is the-	                                     -- internal type code returned from the-	                                     -- backend library-	deriving (Eq, Show)--data SqlError-   = SqlError-		{ seState       :: String-		, seNativeError :: Int-		, seErrorMsg    :: String-		}-   | SqlNoData-   | SqlInvalidHandle-   | SqlStillExecuting-   | SqlNeedData-   | SqlBadTypeCast-   		{ seFieldName :: String-   		, seFieldType :: SqlType-   		}-   | SqlFetchNull-   		{ seFieldName :: String-		}-   | SqlUnknownField-		{ seFieldName :: String-		}-   | SqlUnsupportedOperation-   | SqlClosedHandle-#ifdef __GLASGOW_HASKELL__-   deriving Typeable-#endif+{-| Basic type class & type definitions for DB interfacing.+-}+module Database.HSQL.Types+    (FieldDef,SqlType(..),SqlError(..),sqlErrorTc+    ,Connection(..),Statement(..),SqlBind(..)) where -sqlErrorTc :: TyCon-sqlErrorTc = mkTyCon "Database.HSQL.SqlError"+import Control.Concurrent.MVar(MVar)+import Control.Exception(throw)+import Foreign(nullPtr)+import Foreign.C(CString,peekCStringLen) -#ifndef __GLASGOW_HASKELL__-instance Typeable SqlError where-	typeOf _ = mkAppTy sqlErrorTc []-#endif+import DB.HSQL.Type+import DB.HSQL.Error -instance Show SqlError where-	showsPrec _ (SqlError{seErrorMsg=msg}) = showString msg-	showsPrec _ SqlNoData                  = showString "No data"-	showsPrec _ SqlInvalidHandle           = showString "Invalid handle"-	showsPrec _ SqlStillExecuting          = showString "Stlll executing"-	showsPrec _ SqlNeedData                = showString "Need data"-	showsPrec _ (SqlBadTypeCast name tp)   = showString ("The type of " ++ name ++ " field can't be converted to " ++ show tp ++ " type")-	showsPrec _ (SqlFetchNull name)        = showString ("The value of " ++ name ++ " field is null")-	showsPrec _ (SqlUnknownField name)     = showString ("Unknown field name: " ++ name)-	showsPrec _ SqlUnsupportedOperation    = showString "Unsupported operation"-	showsPrec _ SqlClosedHandle            = showString "The referenced handle is already closed"+-- |+type FieldDef = (String, SqlType, Bool) --- | A 'Connection' type represents a connection to a database, through which you can operate on the it.--- In order to create the connection you need to use the @connect@ function from the module for--- your prefered backend.+-- | A 'Connection' type represents a connection to a database,+-- through which you can operate on the it.+-- In order to create the connection you need to use the @connect@ function+-- from the module for your prefered backend. data Connection-  =  Connection-		{ connDisconnect :: IO ()-		, connExecute :: String -> IO ()-		, connQuery :: String -> IO Statement-		, connTables :: IO [String]-		, connDescribe :: String -> IO [FieldDef]-		, connBeginTransaction :: IO ()-		, connCommitTransaction :: IO ()-		, connRollbackTransaction :: IO ()-		, connClosed :: MVar Bool-		}+  = Connection {+      -- | disconnect action+      connDisconnect :: IO (),+      -- | query execution action (without return value)+      connExecute :: String -> IO (),+      -- | query action with return value+      connQuery :: String -> IO Statement,+      -- | retrieval of the names of the tables in reach+      connTables :: IO [String],+      -- | retrieval of the field defs of a table+      connDescribe :: String -> IO [FieldDef],+      -- | begin of a transaction+      connBeginTransaction :: IO (),+      -- | commit of a pending transaction+      connCommitTransaction :: IO (),+      -- | rollback of a pending transaction+      connRollbackTransaction :: IO (),+      -- | closing state of the connection+      connClosed :: MVar Bool } --- | The 'Statement' type represents a result from the execution of given SQL query.++-- | The 'Statement' type represents a result from the execution of given+-- SQL query. data Statement-  =  Statement-		{ stmtConn   :: Connection-		, stmtClose  :: IO ()-		, stmtFetch  :: IO Bool-		, stmtGetCol :: forall a . Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a-		, stmtFields :: [FieldDef]-		, stmtClosed :: MVar Bool-		}+    = Statement { +        -- | field descriptors+        stmtConn :: Connection,+        -- | closing action+        stmtClose :: IO (),+        -- | incrementation of the row pointer and indication+        -- whether this is still in range of available rows+        stmtFetch :: IO Bool,+        -- | extraction of a field from the current result row, with+        -- +        --  * a column index+        -- +        --  * a column field definition+        -- +        --  * a generic field extraction function, specifiable by+        --    a field definition, a C string and its length+        stmtGetCol :: forall a . Int -- column index+                   -> FieldDef   -- column field definition+                   -> (FieldDef->CString->Int->IO a) +                                 -- generic field extraction function,+                                 -- specifiable by field definition, +                                 -- receiving the C string and its length+                   -> IO a,+        -- | field descriptors+        stmtFields :: [FieldDef],+        -- | closing state of the statement+        stmtClosed :: MVar Bool }  +-- | class SqlBind a where-	-- This allows for faster conversion for eq. integral numeric types, etc.-	-- Default version uses fromSqlValue.+	toSqlValue   :: a -> String+	fromSqlValue :: SqlType -> String -> Maybe a+	-- | This allows for faster conversion for eq. integral numeric types,+        -- etc. Default version uses fromSqlValue. 	fromSqlCStringLen :: FieldDef -> CString -> Int -> IO a 	fromSqlCStringLen (name,sqlType,_) cstr cstrLen-	  | cstr == nullPtr = throwDyn (SqlFetchNull name)-	  | otherwise       = do +	  | cstr == nullPtr = throw (SqlFetchNull name)+	  | otherwise = do  	      str <- peekCStringLen (cstr, cstrLen) 	      case fromSqlValue sqlType str of-	        Nothing -> throwDyn (SqlBadTypeCast name sqlType)+	        Nothing -> throw (SqlBadTypeCast name sqlType) 	        Just v  -> return v--	fromSqlValue :: SqlType -> String -> Maybe a-	toSqlValue   :: a -> String

@@ -1,16 +1,25 @@ name:		hsql-version:	1.7.1+version:	1.8.1 license:	BSD3 author:		Krasimir Angelov <ka2_mail@yahoo.com>-maintainer:     Chris Done <chrisdone@gmail.com>+maintainer:     Nick Rudnick <nick.rudnick@googlemail.com> category:	Database synopsis:       Simple library for database access from Haskell. description:	Simple library for database access from Haskell. exposed-modules:+    DB.HSQL.Core,+    DB.HSQL.Error,+    DB.HSQL.Type,+    DB.HSQL.Type.Diverse,+    DB.HSQL.Type.Geometric,+    DB.HSQL.Type.Numeric,+    DB.HSQL.Type.Time,+    DB.HSQL.Type.NetAddress, 	Database.HSQL, 	Database.HSQL.Types-build-depends:	base==3.*,old-time-extensions:     ForeignFunctionInterface, TypeSynonymInstances, CPP, RankNTypes, DeriveDataTypeable+build-depends:	base==4.*, old-time+extensions: CPP, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes,+			ScopedTypeVariables build-type: Simple license-file: LICENSE cabal-version: >= 1.6