June 2002 - Haskell - Haskell.org

Haskell 98 Report: May release
by Simon Peyton-Jones 07 Jun '02

07 Jun '02

Folks, I've finally managed to push out the May 2002 release of the Haskell 98 report. http://research.microsoft.com/~simonpj/h98-revised As far as I know there are no outstanding issues, so I hope that there will be blissful silence for a month and I can freeze it. I'd have done so this time if it weren't for some non-trivial changes to the specification of 'derving' for Read and Show. As ever, the bugs list makes it easy to find the changes since last time Happy reading. A big thank you to those who have spotted errors and contributed fixes. SImon

2 1

FFI and ODBC connectivity
by Krasimir Angelov 06 Jun '02

06 Jun '02

Hello all, HaskellDB is a nice, combinator library but there are two main disadvantages. * HaskellDB uses 'Trex' module which is Hugs specific. Both GHC and NHC doesn't support 'Trex'. * HaskellDB cann't execute stored SQL procedures and doesn't allow to execute plain SQL statements. I use HSQL (see mail attachment) for data access. HSQL works with ODBC but its user interface isn't ODBC specific. The module can be rewriten to use native drivers for specific databases (MySQL,PostgresSQL,Oracle,Sybase,...). If there is somebody interested in using of HSQL I will place it on CVS. Krasimir Angelov __________________________________________________ Do You Yahoo!? Yahoo! - Official partner of 2002 FIFA World Cup http://fifaworldcup.yahoo.com module HSQL ( SqlBind(..), SqlError(..), SqlType(..), Connection, Statement , catchSql -- :: IO a -> (SqlError -> IO a) -> IO a , connect -- :: String -> String -> String -> IO Connection , disconnect -- :: Connection -> IO () , execute -- :: Connection -> String -> IO Statement , closeStatement -- :: Statement -> IO () , fetch -- :: Statement -> IO Bool , inTransaction -- :: Connection -> (Connection -> IO a) -> IO a , getFieldValue -- :: SqlBind a => Statement -> String -> IO a , getFieldValueType -- :: Statement -> String -> (SqlType, Bool) , getFieldsTypes -- :: Statement -> (String, SqlType, Bool) , forEachRow -- :: (Statement -> s -> IO s) -> Statement -> s -> IO s , forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO () , collectRows -- :: (Statement -> IO s) -> Statement -> IO [s] ) where import Word(Word32, Word16) import Int(Int32, Int16) import Foreign import CString import IORef import Monad(when) import Exception (throwDyn, catchDyn, Exception(..)) import Dynamic #include <HSQLStructs.h> type SQLHANDLE = Ptr () type HENV = SQLHANDLE type HDBC = SQLHANDLE type HSTMT = SQLHANDLE type HENVRef = ForeignPtr () type SQLSMALLINT = Int16 type SQLUSMALLINT = Word16 type SQLINTEGER = Int32 type SQLUINTEGER = Word32 type SQLRETURN = SQLSMALLINT type SQLLEN = SQLINTEGER type SQLULEN = SQLINTEGER foreign import stdcall "sqlext.h SQLAllocEnv" sqlAllocEnv :: Ptr HENV -> IO SQLRETURN foreign import stdcall "sqlext.h SQLFreeEnv" sqlFreeEnv :: HENV -> IO SQLRETURN foreign import stdcall "sqlext.h SQLAllocConnect" sqlAllocConnect :: HENV -> Ptr HDBC -> IO SQLRETURN foreign import stdcall "sqlext.h SQLFreeConnect" sqlFreeConnect:: HDBC -> IO SQLRETURN foreign import stdcall "sqlext.h SQLConnect" sqlConnect :: HDBC -> CString -> Int -> CString -> Int -> CString -> Int -> IO SQLRETURN foreign import stdcall "sqlext.h SQLDisconnect" sqlDisconnect :: HDBC -> IO SQLRETURN foreign import stdcall "sqlext.h SQLAllocStmt" sqlAllocStmt :: HDBC -> Ptr HSTMT -> IO SQLRETURN foreign import stdcall "sqlext.h SQLFreeStmt" sqlFreeStmt :: HSTMT -> SQLUSMALLINT -> IO SQLRETURN foreign import stdcall "sqlext.h SQLNumResultCols" sqlNumResultCols :: HSTMT -> Ptr SQLUSMALLINT -> IO SQLRETURN foreign import stdcall "sqlext.h SQLDescribeCol" sqlDescribeCol :: HSTMT -> SQLUSMALLINT -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLULEN -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import stdcall "sqlext.h SQLBindCol" sqlBindCol :: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr a -> SQLLEN -> Ptr SQLINTEGER -> IO SQLRETURN foreign import stdcall "sqlext.h SQLFetch" sqlFetch :: HSTMT -> IO SQLRETURN foreign import stdcall "sqlext.h SQLGetDiagRec" sqlGetDiagRec :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> CString -> Ptr SQLINTEGER -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import stdcall "sqlext.h SQLExecDirect" sqlExecDirect :: HSTMT -> CString -> Int -> IO SQLRETURN foreign import stdcall "sqlext.h SQLSetConnectOption" sqlSetConnectOption :: HDBC -> SQLUSMALLINT -> SQLULEN -> IO SQLRETURN foreign import stdcall "sqlext.h SQLTransact" sqlTransact :: HENV -> HDBC -> SQLUSMALLINT -> IO SQLRETURN data Connection = Connection { hDBC :: HDBC , environment :: HENVRef } type FieldDef = (String, SqlType, Bool, Int) data Statement = Statement { hSTMT :: HSTMT , connection :: Connection , fields :: [FieldDef] , fetchBuffer :: Ptr () } data SqlType = SqlChar Int | SqlVarChar Int | SqlLongVarChar Int | SqlDecimal Int Int | SqlNumeric Int Int | SqlSmallInt | SqlInteger | SqlReal | SqlDouble | SqlBit | SqlTinyInt | SqlBigInt | SqlBinary Int | SqlVarBinary Int | SqlLongVarBinary Int | SqlDate | SqlTime | SqlTimeStamp deriving (Eq, Show) data SqlError = SqlError { seState :: String , seNativeError :: Int , seErrorMsg :: String } | SqlNoData | SqlInvalidHandle | SqlStillExecuting | SqlNeedData deriving Show ----------------------------------------------------------------------------------------- -- routines for handling exceptions ----------------------------------------------------------------------------------------- {-# NOINLINE sqlErrorTy #-} sqlErrorTy = mkAppTy (mkTyCon "SqlError") [] instance Typeable SqlError where typeOf x = sqlErrorTy catchSql :: IO a -> (SqlError -> IO a) -> IO a catchSql = catchDyn sqlSuccess :: SQLRETURN -> Bool sqlSuccess res = (res == (#const SQL_SUCCESS)) || (res == (#const SQL_SUCCESS_WITH_INFO)) || (res == (#const SQL_NO_DATA)) handleSqlResult :: SQLSMALLINT -> SQLHANDLE -> SQLRETURN -> IO () handleSqlResult handleType handle res | sqlSuccess res = return () | res == (#const SQL_INVALID_HANDLE) = throwDyn SqlInvalidHandle | res == (#const SQL_STILL_EXECUTING) = throwDyn SqlStillExecuting | res == (#const SQL_NEED_DATA) = throwDyn SqlNeedData | res == (#const SQL_ERROR) = do pState <- mallocBytes 256 pNative <- malloc pMsg <- mallocBytes 256 pTextLen <- malloc sqlGetDiagRec handleType handle 1 pState pNative pMsg 256 pTextLen state <- peekCString pState free pState native <- peek pNative free pNative msg <- peekCString pMsg free pMsg free pTextLen throwDyn (SqlError {seState=state, seNativeError=fromIntegral native, seErrorMsg=msg}) | otherwise = error (show res) ----------------------------------------------------------------------------------------- -- keeper of HENV ----------------------------------------------------------------------------------------- {-# NOINLINE myEnvironment #-} myEnvironment :: HENVRef myEnvironment = unsafePerformIO $ do (phEnv :: Ptr HENV) <- malloc res <- sqlAllocEnv phEnv hEnv <- peek phEnv free phEnv handleSqlResult 0 nullPtr res newForeignPtr hEnv (closeEnvironment hEnv) where closeEnvironment :: HENV -> IO () closeEnvironment hEnv = sqlFreeEnv hEnv >>= handleSqlResult (#const SQL_HANDLE_ENV) hEnv ----------------------------------------------------------------------------------------- -- Connect/Disconnect ----------------------------------------------------------------------------------------- connect :: String -> String -> String -> IO Connection connect server user authentication = withForeignPtr myEnvironment $ \hEnv -> do (phDBC :: Ptr HDBC) <- malloc res <- sqlAllocConnect hEnv phDBC hDBC <- peek phDBC free phDBC handleSqlResult (#const SQL_HANDLE_ENV) hEnv res pServer <- newCString server pUser <- newCString user pAuthentication <- newCString authentication res <- sqlConnect hDBC pServer (length server) pUser (length user) pAuthentication (length authentication) free pServer free pUser free pAuthentication handleSqlResult (#const SQL_HANDLE_ENV) hEnv res return (Connection {hDBC=hDBC, environment=myEnvironment}) disconnect :: Connection -> IO () disconnect (Connection {hDBC=hDBC}) = do sqlDisconnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC sqlFreeConnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC return () ----------------------------------------------------------------------------------------- -- queries ----------------------------------------------------------------------------------------- execute :: Connection -> String -> IO Statement execute conn@(Connection {hDBC=hDBC}) query = do pFIELD <- mallocBytes (#const sizeof(FIELD)) res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD) when (not (sqlSuccess res)) (free pFIELD) handleSqlResult (#const SQL_HANDLE_DBC) hDBC res hSTMT <- (#peek FIELD, hSTMT) pFIELD let handleResult res = do when (not (sqlSuccess res)) (free pFIELD) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res pQuery <- newCString query res <- sqlExecDirect hSTMT pQuery (length query) free pQuery handleResult res sqlNumResultCols hSTMT ((#ptr FIELD, fieldsCount) pFIELD) >>= handleResult count <- (#peek FIELD, fieldsCount) pFIELD (fields, offs) <- createBindState hSTMT pFIELD 0 1 count free pFIELD buffer <- mallocBytes offs let statement = Statement {hSTMT=hSTMT, connection=conn, fields=fields, fetchBuffer=buffer} catchSql (bindFields hSTMT buffer 1 fields) (errHandler statement) return statement where errHandler statement err = do closeStatement statement throwDyn err createBindState :: HSTMT -> Ptr a -> Int -> SQLUSMALLINT -> SQLUSMALLINT -> IO ([FieldDef], Int) createBindState hSTMT pFIELD offs n count | n > count = return ([], offs) | otherwise = do res <- sqlDescribeCol hSTMT n ((#ptr FIELD, fieldName) pFIELD) (#const FIELD_NAME_LENGTH) ((#ptr FIELD, NameLength) pFIELD) ((#ptr FIELD, DataType) pFIELD) ((#ptr FIELD, ColumnSize) pFIELD) ((#ptr FIELD, DecimalDigits) pFIELD) ((#ptr FIELD, Nullable) pFIELD) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res name <- peekCString ((#ptr FIELD, fieldName) pFIELD) dataType <- (#peek FIELD, DataType) pFIELD columnSize <- (#peek FIELD, ColumnSize) pFIELD decimalDigits <- (#peek FIELD, DecimalDigits) pFIELD (nullable :: SQLSMALLINT) <- (#peek FIELD, Nullable) pFIELD let (sqlType, offs') = mkSqlType dataType columnSize decimalDigits (offs+(#const sizeof(SQLINTEGER))) (fields, offs'') <- createBindState hSTMT pFIELD offs' (n+1) count return ((name,sqlType,toBool nullable,offs):fields, offs'') bindFields :: HSTMT -> Ptr () -> SQLUSMALLINT -> [FieldDef] -> IO () bindFields hSTMT fetchBuffer n [] = return () bindFields hSTMT fetchBuffer n ((name,SqlChar size, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_CHAR) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (fromIntegral (size+1) * (#const sizeof(SQLCHAR))) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlVarChar size, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_CHAR) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (fromIntegral (size+1) * (#const sizeof(SQLCHAR))) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlLongVarChar size, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_CHAR) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (fromIntegral (size+1) * (#const sizeof(SQLCHAR))) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlDecimal size prec,nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_DOUBLE) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLDOUBLE)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlNumeric size prec,nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_DOUBLE) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLDOUBLE)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlSmallInt, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_SHORT) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLSMALLINT)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlInteger, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_LONG) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLINTEGER)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlReal, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_DOUBLE) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLDOUBLE)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlDouble, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_DOUBLE) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLDOUBLE)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlBit, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_LONG) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLINTEGER)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlTinyInt, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_SHORT) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLSMALLINT)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlBigInt, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_LONG) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQLINTEGER)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlBinary size, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_CHAR) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (fromIntegral size * (#const sizeof(SQLCHAR))) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlVarBinary size, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_CHAR) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (fromIntegral size * (#const sizeof(SQLCHAR))) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlLongVarBinary size,nullable,offs):fields)= do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_CHAR) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (fromIntegral size * (#const sizeof(SQLCHAR))) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlDate, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_TYPE_DATE) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQL_DATE_STRUCT)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlTime, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_TYPE_TIME) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQL_TIME_STRUCT)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields bindFields hSTMT fetchBuffer n ((name,SqlTimeStamp, nullable,offs):fields) = do let buffer = fetchBuffer `plusPtr` offs res <- sqlBindCol hSTMT n (#const SQL_C_TYPE_TIMESTAMP) ((castPtr buffer) `plusPtr` (#const sizeof(SQLINTEGER))) (#const sizeof(SQL_TIMESTAMP_STRUCT)) (castPtr buffer) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res bindFields hSTMT fetchBuffer (n+1) fields mkSqlType :: SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> Int -> (SqlType, Int) mkSqlType (#const SQL_CHAR) size _ offs = (SqlChar (fromIntegral size), offs + (#const sizeof(SQLCHAR))*(fromIntegral size+1)) mkSqlType (#const SQL_VARCHAR) size _ offs = (SqlVarChar (fromIntegral size), offs + (#const sizeof(SQLCHAR))*(fromIntegral size+1)) mkSqlType (#const SQL_LONGVARCHAR) size _ offs = (SqlLongVarChar (fromIntegral size), offs + (#const sizeof(SQLCHAR))*(fromIntegral size+1)) mkSqlType (#const SQL_DECIMAL) size prec offs = (SqlDecimal (fromIntegral size) (fromIntegral prec), offs + (#const sizeof(SQLDOUBLE))) mkSqlType (#const SQL_NUMERIC) size prec offs = (SqlNumeric (fromIntegral size) (fromIntegral prec), offs + (#const sizeof(SQLDOUBLE))) mkSqlType (#const SQL_SMALLINT) _ _ offs = (SqlSmallInt, offs + (#const sizeof(SQLSMALLINT))) mkSqlType (#const SQL_INTEGER) _ _ offs = (SqlInteger, offs + (#const sizeof(SQLINTEGER))) mkSqlType (#const SQL_REAL) _ _ offs = (SqlReal, offs + (#const sizeof(SQLDOUBLE))) mkSqlType (#const SQL_DOUBLE) _ _ offs = (SqlDouble, offs + (#const sizeof(SQLDOUBLE))) mkSqlType (#const SQL_BIT) _ _ offs = (SqlBit, offs + (#const sizeof(SQLINTEGER))) mkSqlType (#const SQL_TINYINT) _ _ offs = (SqlTinyInt, offs + (#const sizeof(SQLSMALLINT))) mkSqlType (#const SQL_BIGINT) _ _ offs = (SqlBigInt, offs + (#const sizeof(SQLINTEGER))) mkSqlType (#const SQL_BINARY) size _ offs = (SqlBinary (fromIntegral size), offs + (#const sizeof(SQLCHAR))*(fromIntegral size+1)) mkSqlType (#const SQL_VARBINARY) size _ offs = (SqlVarBinary (fromIntegral size), offs + (#const sizeof(SQLCHAR))*(fromIntegral size+1)) mkSqlType (#const SQL_LONGVARBINARY)size _ offs = (SqlLongVarBinary (fromIntegral size), offs + (#const sizeof(SQLCHAR))*(fromIntegral size+1)) mkSqlType (#const SQL_DATE) _ _ offs = (SqlDate, offs + (#const sizeof(SQL_DATE_STRUCT))) mkSqlType (#const SQL_TIME) _ _ offs = (SqlTime, offs + (#const sizeof(SQL_TIME_STRUCT))) mkSqlType (#const SQL_TIMESTAMP) _ _ offs = (SqlTimeStamp, offs + (#const sizeof(SQL_TIMESTAMP_STRUCT))) {-# NOINLINE fetch #-} fetch :: Statement -> IO Bool fetch stmt = do res <- sqlFetch (hSTMT stmt) handleSqlResult (#const SQL_HANDLE_STMT) (hSTMT stmt) res return (res /= (#const SQL_NO_DATA)) closeStatement :: Statement -> IO () closeStatement stmt = do sqlFreeStmt (hSTMT stmt) 0 >>= handleSqlResult (#const SQL_HANDLE_STMT) (hSTMT stmt) free (fetchBuffer stmt) ----------------------------------------------------------------------------------------- -- transactions ----------------------------------------------------------------------------------------- inTransaction :: Connection -> (Connection -> IO a) -> IO a inTransaction conn@(Connection {hDBC=hDBC, environment=envRef}) action = withForeignPtr envRef $ \hEnv -> do sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_OFF) r <- catchSql (action conn) (\err -> do sqlTransact hEnv hDBC (#const SQL_ROLLBACK) sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON) throwDyn err) sqlTransact hEnv hDBC (#const SQL_COMMIT) sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON) return r ----------------------------------------------------------------------------------------- -- binding ----------------------------------------------------------------------------------------- class SqlBind a where getValue :: SqlType -> Ptr () -> IO a instance SqlBind Int where getValue SqlInteger ptr = peek (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER)))) getValue SqlSmallInt ptr = do (n :: Int16) <- peek (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER)))) return (fromIntegral n) instance SqlBind String where getValue (SqlChar size) ptr = do len <- peek (castPtr ptr) peekCStringLen (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER))), len) getValue (SqlVarChar size) ptr = do len <- peek (castPtr ptr) peekCStringLen (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER))), len) getValue (SqlLongVarChar size) ptr = do len <- peek (castPtr ptr) peekCStringLen (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER))), len) instance SqlBind Double where getValue (SqlDecimal size prec) ptr = peek (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER)))) getValue (SqlNumeric size prec) ptr = peek (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER)))) getValue SqlDouble ptr = peek (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER)))) getValue SqlReal ptr = peek (castPtr (ptr `plusPtr` (#const sizeof(SQLINTEGER)))) getFieldValue :: SqlBind a => Statement -> String -> IO a getFieldValue stmt name = getValue sqlType ((fetchBuffer stmt) `plusPtr` offs) where (_,sqlType,nullable,offs) = findField name (fields stmt) getFieldValueType :: Statement -> String -> (SqlType, Bool) getFieldValueType stmt name = (sqlType, nullable) where (_,sqlType,nullable,offs) = findField name (fields stmt) getFieldsTypes :: Statement -> [(String, SqlType, Bool)] getFieldsTypes stmt = map (\(name,sqlType,nullable,_) -> (name,sqlType,nullable)) (fields stmt) findField :: String -> [FieldDef] -> FieldDef findField name [] = error (name ++ "??") findField name (fieldDef@(name',_,_,_):fields) | name == name' = fieldDef | otherwise = findField name fields ----------------------------------------------------------------------------------------- -- helpers ----------------------------------------------------------------------------------------- forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s forEachRow f stmt s = do success <- fetch stmt if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s forEachRow' :: (Statement -> IO ()) -> Statement -> IO () forEachRow' f stmt = do success <- fetch stmt if success then f stmt >> forEachRow' f stmt else closeStatement stmt collectRows :: (Statement -> IO a) -> Statement -> IO [a] collectRows f stmt = loop where loop = do success <- fetch stmt if success then do x <- f stmt xs <- loop return (x:xs) else closeStatement stmt >> return []

1 0

FFI and ODBC connectivity
by Jamie Love 06 Jun '02

06 Jun '02

Hello all, Currently I am investigating the availability of haskell to ODBC connectivity and have been excited by the possibilities. Downloading the HaskellDB package (http://haskell.cs.yale.edu/haskellDB/) and having it run was fantastic. In the interests of continuing the work of HaskellDB, I wish to have this system work under Linux. Before attempting to extend HaskellDB to support ODBC (and work through unixODBC - http://www.unixodbc.org) I wish to ensure that my efforts are not misdirected. My questions include: Is HaskellDB dead? Is it worth extending? (I very much wish to keep the type safety HaskellDB has). Is HaskellDirect dead or superseeded by the Haskell FFI? I am having difficulty discovering which FFI technology/package is still useful, viable and alive, the same applies to ODBC connectivity packages. The second set of libraries I am interested in is HTML/CGI libraries. I have yet to investigate those available, so any direction on which library package is currently live and well would also be useful. The reason for these queries is that I wish to write pure Haskell software based heavily around both a database backend and HTML frontend. Thankyou, -- Jamie Love Phone: +64 4 9393425 "If possible, try to find a way to come downstairs that doesn't involve going bump, bump, bump, on the back of your head. - " Pooh in Winnie the Pooh

5 5

��ʦ��ǻۣ��ȡ��ҵ�ҵ��ţ�ֱ��ɹ��ʿ��Ľ��
by ��Ż�չЭ�� 06 Jun '02

06 Jun '02

1 0

�𾴵��Ͽͻ��
by syhua3000 06 Jun '02

06 Jun '02

�𾴵��Ͽͻ�� ã� ӯͨԶ��(www.9dns.net)Ϊ�˴�л��Լ��ͻ��˾��֧�ֺ��Σ��ٴ��¾ɷ��ܣ��վ�ռ��졢�� ȶ��ȫ��ͬʱ��ǻ��˲�Ʒ �۸��ܸ��ʵķ��񡣣��˾��վ��ȫ�¸İ棺www.8dns.net�� 200M HTML�ռ�+1��۸�150Ԫ/�� 100M�ռ�(֧��ASP)+100M��ҵ�ʾ�+20M ACCESS��ݿ�+1�� 288Ԫ/�� 200M�ռ�(֧��ASP)+200M��ҵ�ʾ�+30M Access��ݿ�+1�� 338Ԫ/�� ֻ��ۼ۸񡣻�ӭѡ��Ҳ��ӭ��Ϊ��ǵĴ��! ��ǻ��и��Żݼ۸�� http://www.8dns.net �� ӯͨԶ��ӿƼ��޹�˾ --------------------------------------------------------------- �е�Ⱥ��ʼ�,��ר��(http://www.21cmm.com) ��CMM��У(http://www.21cmm.com)��Ŀ��ר��

1 0

Re: ANNOUNCE: Haddock version 0.3
by Ashley Yakeley 06 Jun '02

06 Jun '02

At 2002-06-03 09:04, Simon Marlow wrote: >I'm pleased to announce version 0.3 of Haddock, a documentation >generation tool for Haskell source code. Has trouble with this: -- haddock -h -o Doc/ HaddockTest.hs module HaddockTest where { -- |comment class C a where { }; } ...gives this HaddockTest.hs:5:5: Parse error -- Ashley Yakeley, Seattle WA

1 0

RE: FFI and ODBC connectivity
by Simon Peyton-Jones 06 Jun '02

06 Jun '02

HaskellDirect (or HDirect for short) is very much alive and being actively maintained by Sigbjorn Finne. http://www.haskell.org/hdirect/ It's built on top of the Haskell FFI, but it is much higher level. Simon | -----Original Message----- | From: Jamie Love [mailto:jlove@eservglobal.co.nz] | Sent: 05 June 2002 06:30 | To: Haskell Mailing List | Subject: FFI and ODBC connectivity | | | Hello all, | | Currently I am investigating the availability of haskell to | ODBC connectivity and have been excited by the possibilities. | Downloading the HaskellDB package | (http://haskell.cs.yale.edu/haskellDB/) | and having it run was fantastic. | | In the interests of continuing the work of HaskellDB, I wish | to have this system work under Linux. Before attempting to | extend HaskellDB to support ODBC (and work through unixODBC - http://www.unixodbc.org) I wish to ensure that my efforts are not misdirected. My questions include: Is HaskellDB dead? Is it worth extending? (I very much wish to keep the type safety HaskellDB has). Is HaskellDirect dead or superseeded by the Haskell FFI? I am having difficulty discovering which FFI technology/package is still useful, viable and alive, the same applies to ODBC connectivity packages. The second set of libraries I am interested in is HTML/CGI libraries. I have yet to investigate those available, so any direction on which library package is currently live and well would also be useful. The reason for these queries is that I wish to write pure Haskell software based heavily around both a database backend and HTML frontend. Thankyou, -- Jamie Love Phone: +64 4 9393425 "If possible, try to find a way to come downstairs that doesn't involve going bump, bump, bump, on the back of your head. - " Pooh in Winnie the Pooh _______________________________________________ Haskell mailing list Haskell(a)haskell.org http://www.haskell.org/mailman/listinfo/haskell

3 2

FW: cvs commit: hugs98/lib IO.hs Prelude.hs
by Simon Peyton-Jones 05 Jun '02

05 Jun '02

Folks I plan to push out a new draft H98 report this week. Here is one suggested clarification from Sigbjorn, arising from recent uncertainty about the true meaning of getLine. I'll incorporate it unless anyone yells. Simon -----Original Message----- From: Simon Marlow Sent: 05 June 2002 10:27 To: Sigbjorn Finne; Simon Peyton-Jones Subject: RE: cvs commit: hugs98/lib IO.hs Prelude.hs Agree with everything Sigbjorn says below. Also: change the definition of getLine (section A.3) to be getLine = hGetLine stdin Cheers, Simon -----Original Message----- From: Sigbjorn Finne [mailto:sof@galois.com] Sent: 04 June 2002 16:17 To: Simon Peyton-Jones Cc: Simon Marlow Subject: Re: cvs commit: hugs98/lib IO.hs Prelude.hs How about the following: * change the Report (7.1) to say something along the lines of: getChar raises an exception (Section <http://research.microsoft.com/Users/simonpj/haskell98-revised/haskell98 -report-html/io-13.html#io-exceptions> 7.3) on end-of-file; a predicate isEOFError that identifies this exception is defined in the IO library. getLine raises an end-of-file exception under the same conditions as hGetLine in the IO library. * in the Library Report, say when hGetLine raises an exception: Computation hGetLine hdl reads a line from the file or channel managed by hdl. The Prelude's getLine is a shorthand for hGetLine stdin. Error reporting: the hWaitForInput, hReady and hGetChar computations may fail with: isEOFError if the end of file has been reached. hGetLine will also fail with isEOFError if end-of-file is encountered when reading the first character of the line. If hGetLine encounters end-of-file at any other point while reading in a line, it is treated as a line terminator and the (partial) line is returned. Actually, I'd prefer if 11.7.1 only dealt with hWaitForInput and hReady (as they're the "checking for input" operations). A second section, named "Reading input", would then be concerned with hGetChar and hGetLine. --sigbjorn ----- Original Message ----- From: "Simon Peyton-Jones" < <mailto:simonpj@microsoft.com> simonpj(a)microsoft.com> To: "Sigbjorn Finne" < <mailto:sof@glass.cse.ogi.edu> sof(a)glass.cse.ogi.edu>; < <mailto:simonmar@microsoft.com> simonmar(a)microsoft.com> Sent: Tuesday, June 04, 2002 04:03 Subject: RE: cvs commit: hugs98/lib IO.hs Prelude.hs > Should I change the Report wording to be clearer? > > Simon > > | -----Original Message----- > | From: Sigbjorn Finne [mailto:sof@glass.cse.ogi.edu] > | Sent: 03 June 2002 15:49 > | To: <mailto:cvs-hugs@haskell.org> cvs-hugs(a)haskell.org > | Subject: cvs commit: hugs98/lib IO.hs Prelude.hs > | > | > | sof 2002/06/03 07:49:12 PDT > | > | Modified files: > | lib IO.hs Prelude.hs > | Log: > | Interpret Report wording for Prelude.getLine and IO.hGetLine > | to mean the Right Thing. If EOF is encountered for a partial > | line (>= 1 chars), interpret this as '\n'. > | > | Revision Changes Path > | 1.4 +25 -8 hugs98/lib/IO.hs > | 1.25 +23 -5 hugs98/lib/Prelude.hs > | _______________________________________________ > | Cvs-hugs mailing list > | <mailto:Cvs-hugs@haskell.org> Cvs-hugs(a)haskell.org <http://www.haskell.org/mailman/listinfo/cvs-hugs> http://www.haskell.org/mailman/listinfo/cvs-hugs > |

1 0

Beginner's question: Memo functions in Haskell
by Matthias Heiler 05 Jun '02

05 Jun '02

Hello, In a machine learning application I am currently playing with string kernels which are recursively defined functions operating on strings. In Haskell the implementation of these functions is very pleasing as it is a one-to-one translation of the mathematical definition (see code below [2] and reference [1], p.424). However, the runtime performance is less pleasing as certain subexpressions are computed over and over again (profiling with ghc showed that the function k' (see code below) is called 1425291 times in a toy example). In a non-functional implementation I would now set up an auxillary data structure (e.g. a hash table) for caching/memorizing some intermediate results. How would this be done (elegantly, efficiently, by a Haskell-beginner) in Haskell? So far, I have seen code using lists to speed up fib(n). In my case the arguments of k' are Int -> String -> String, and I don't expect a simple list of tuples (Int, String, String, RESULT) to be efficient. Thank you very much for you help, Matthias [1] Huma Lodhi, Craig Saunders, John Shawe-Taylor, Nello Cristianini, Chris Watkins: "Text Classification using String Kernels", Journal of Machine Learning Research, 2(Feb):419-444, 2002. Available online at http://www.ai.mit.edu/projects/jmlr/papers/volume2.html [2] My code (actually the first 'real' piece of code I wrote in Haskell) is the following: ------------------------------------------------------------ module SKernel where k' :: Double -> Int -> String -> String -> Double k' lambda 0 s t = 1 k' lambda i s t = if min (length s) (length t) < i then 0 else (lambda * (k' lambda i s' t)) + sum [ lambda^((length t) - j + 2) * (k' lambda (i-1) s' t') | j <- [1..length t], t!!(j-1) == last s, t' <- [take (j-1) t] ] where s' = take ((length s) - 1) s k :: Double -> Int -> String -> String -> Double k lambda i s t = if min (length s) (length t) < i then 0 else k lambda i s' t + sum [ lambda^2 * (k' lambda (i-1) s' t') | j <- [1..length t], t!!(j-1) == last s, t' <- [take (j-1) t] ] where s' = take ((length s) - 1) s nk :: Double -> Int -> String -> String -> Double nk lambda n s t = (k lambda n s t) / sqrt ((k lambda n s s) * (k lambda n t t)) -- a toy example would be the call nk 0.5 5 "This is a string." "Here we have another string." ------------------------------------------------------------

6 6

Bilgisayar Egitiminde Bir Numara
by Sertifikam.Com 05 Jun '02

05 Jun '02

1 0