packages feed

hsSqlite3 0.0.5.20081031 → 0.0.6

raw patch · 6 files changed

+591/−537 lines, 6 filesdep +bindings-sqlite3dep +utf8-string

Dependencies added: bindings-sqlite3, utf8-string

Files

LICENSE view
@@ -1,5 +1,5 @@ Copyright (c) 2007, Evgeny Jukov-Copyright (c) 2008, Maurício C. Antunes+Copyright (c) 2008-2009, Maurício C. Antunes All rights reserved.  Redistribution and use in source and binary forms, with or without@@ -14,14 +14,14 @@       the documentation and/or other materials provided with the       distribution. -    * Neither the name of the <ORGANIZATION> nor the names of its+    * Neither the name of the authors nor the names of their       contributors may be used to endorse or promote products derived       from this software without specific prior written permission.  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A-PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
− README 
@@ -1,46 +0,0 @@--** 0.0.5 **--As  of this  release,  maintainer changed  from  original author  Evgeny-to Maurício.--The  new plan  is  to build  a  compreensive binding  to  all sqlite3  C-library, and then rewrite the  high level code after that, following the-original ideas.--A new  example was  added, '5minutes.hs', a  close translation of  the C-example  code found  in sqlite3  site at  page “SQLite  In 5  Minutes Or-Less”.--This is an experimental  release, important only for maintainer, license-and  repository  change. For  the  sake  of  documentation, here  is  an-abridgement  of the  exchange of  messages  between the  author and  new-maintainer:--    M> Dear Evgeny,-    M>-    M> I've tried  your package in hackage, 'hsSqlite3',  and from darcs-    M> list of changes  it seems you have no longer update  it for a lot-    M> of time. Would  you like to give me  maintenance of that project?-    M> I'll need sqlite3 in my job  work, so I'll have to write at least-    M> enough to get  it running, but it seems you already  did a lot of-    M> nice  work  there  and  I  think that  package  should  be  keept-    M> alive. (...)-    M>-    M> Thanks,-    M> Maurício-    -    E> I agree :) What is required?-    -    M> Great. I'll check what is needed and let you know. I think I just-    M> need to get  a password for hackagedb (I've  just applied to one)-    M> and upload a new package, (...)-    M>-    M> About   the  license:   (...)   sqlite3   itself  is   in  public-    M> domain. Since this is a wrapper, although a high level one, would-    M> you mind changing the license  for public domain?  (Or (...) BSD3-    M> (...))?-    M>-    M> (...)-    -    E> GPL or BSD is ok :)
hsSqlite3.cabal view
@@ -1,30 +1,17 @@-cabal-version: >= 1.2-build-type: Custom name: hsSqlite3-version: 0.0.5.20081031+cabal-version: >= 1.2.3+version: 0.0.6+build-type: Simple+synopsis: Database package using sqlite3. author: Evgeny Jukov maintainer: Maurício C. Antunes <mauricio.antunes@gmail.com>-stability: experimental-homepage: http://code.haskell.org/hsSqlite3-synopsis: sqlite3 bindings-data-files: README, src/Examples/hs_sqlite3_test.sql+stability: experimental, not usable yet+homepage: http://bitbucket.org/mauricio/hssqlite3 license: BSD3 license-file: LICENSE category: database-extra-source-files: src/Examples/hs_sqlite3_test.hs-flag examples-  description: build example programs-  default: False library   hs-source-dirs: src-  extensions: ForeignFunctionInterface-  build-depends: base-  exposed-modules: Database.Sqlite3.Low-  pkgconfig-depends: sqlite3-executable 5minutes-  hs-source-dirs: src/Examples-  main-is: 5minutes.hs---  build-depends: base---  other-modules: Database.Sqlite3.Low-  buildable: False-+  build-depends: base, bindings-sqlite3, utf8-string+  exposed-modules:+    Database.HsSqlite3
+ src/Database/HsSqlite3.hs view
@@ -0,0 +1,579 @@++module Database.HsSqlite3+ ( module Database.Sqlite3.Low+ , Val ( IntV, Int64V, DoubleV, TextV, BlobV, NullV )+ , fetch+ , bind+ , row+ , test+ , sql+ ) where++import Data.Char+import Control.Monad+import Data.Int+import Database.Sqlite3.Low+import qualified Data.ByteString as B+import Control.Arrow+import Data.Typeable++import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad.State.Lazy++import Data.Monoid++import Data.State hiding (fetch)++import qualified Codec.Binary.UTF8.String as UTF8++--++class ValID a where+ valID  :: a -> Int++class ValFetch a where+ valFetch :: (Int,Int) -> DbIO a++class ValBind a where+ valBind :: (Int,a) -> DbIO ()++class ValID a => ValCast a b where+ valCast :: a -> b++data Val+ = IntV    Int+ | Int64V  Int64+ | DoubleV Double+ | TextV   String+ | BlobV   B.ByteString+ | NullV+ deriving Show++instance ValID Val where+ valID (IntV    _) = 1+ valID (Int64V  _) = 1+ valID (DoubleV _) = 2+ valID (TextV   _) = 3+ valID (BlobV   _) = 4+ valID  NullV      = 5++instance ValFetch Val where+ valFetch (t,n) = do+  case t of+   1 -> liftM IntV    $ column_int n+   2 -> liftM DoubleV $ column_double n+   3 -> liftM TextV   $ column_text n+   4 -> liftM BlobV   $ column_blob n+   5 -> return NullV++instance ValBind Val where+ valBind (t,v) = do+  case v of+   IntV a -> bind_int (t,a)+   TextV a -> bind_text (t,a)++instance ValCast Val Int where+ valCast (IntV a) = a++instance ValCast Val Double where+ valCast (DoubleV a) = a++instance ValCast Val String where+ valCast (TextV a) = a++instance ValCast Val B.ByteString where+ valCast (BlobV a) = a++instance ValCast Val () where+ valCast NullV = ()++instance ValID Int          where valID _ = 1+instance ValID Double       where valID _ = 2+instance ValID String       where valID _ = 3+instance ValID B.ByteString where valID _ = 4+instance ValID ()           where valID _ = 5++reqType :: Int -> (Int -> DbIO a) -> (Int,Int) -> DbIO a+reqType t' a (t,v) =  do+ errIf (t'/=t) "ValFetch"+ a v++instance ValFetch Int where+ valFetch = reqType 1 column_int++instance ValFetch Double where+ valFetch = reqType 2 column_double++instance ValFetch String where+ valFetch = reqType 3 column_text++instance ValFetch B.ByteString where+ valFetch = reqType 4 column_blob++instance ValFetch () where+ valFetch = reqType 5 (\_ -> return ())++instance ValBind Int where+ valBind = bind_int++instance ValBind String where+ valBind = bind_text++instance ValCast Int Val where+ valCast a = IntV a++instance ValCast Double Val where+ valCast a = DoubleV a++instance ValCast String Val where+ valCast a = TextV a++instance ValCast B.ByteString Val where+ valCast a = BlobV a++instance ValCast () Val where+ valCast a = NullV++--++fetch :: ValFetch a => String -> DbIO [[a]]+fetch sql = do+ liftIO $ putStr $ UTF8.encodeString $ sql++"\n"+ prepare sql+ stat <- step+ case stat of+  True -> finalize >> return []+  False -> do+   cn <- column_count+   ty <- mapM column_type [0..cn-1]+   let ft = mapM valFetch (zip ty [0..])+   x <- ft+   xs <- fetchRow ft+   finalize+   return (x:xs)+ where+  fetchRow ft = do+   end <- step+   case end of+    True -> return []+    False -> do+     x <- ft+     xs <- fetchRow ft+     return (x:xs)++sql :: String -> DbIO ()+sql sql = do+ liftIO $ putStr $ UTF8.encodeString $ sql++"\n"+ prepare sql+ step+ finalize++bind :: String -> [[Val]] -> DbIO ()+bind sql tab = do+ liftIO $ putStr $ UTF8.encodeString $ sql++"\n"+ debug tab+ prepare sql+ mapM_ (\row -> mapM_ (\(v,n) -> valBind (n,v)) (zip row [1..]) >> step >> reset) tab+ finalize++fetchOne' :: ValFetch a => String -> Int -> DbIO [[a]]+fetchOne' sql num = fetch sql'+ where sql' = concat [sql," LIMIT 1 OFFSET ", show num]++row :: ValFetch a => String -> Int -> DbIO [a]+row sql num = liftM head $ fetchOne' sql num++test :: String -> DbIO Bool+test sql = do+ tab :: [[Val]] <- fetchOne' sql 0+ case length tab of+  1 -> return True+  _ -> return False++++Patch from Evgeny:++Utilization of types+For fetch+> tab :: [Nil :. Int :. Int :. Double] <- fetch "SELECT * FROM test01"+>  liftIO $ mapM print tab++And for bind+> bind "INSERT INTO test01 VALUES(?,?,?)" $+>  replicate 7 $+>    Nil :. (1::Int) :. (2::Int) :. (3.0::Double)++This is stack with different types+> Nil :. (1::Int) :. (2::Int) :. (3.0::Double)++Definition of stack+> data Stack a where+>    Nil  :: Stack ()+>    (:.) :: Stack a -> b -> Stack (Stack a, b)++This is class for new kinds of values.+"T" means used in type stack ... type manipulations ...+> class Cell a where+>   bindT   :: Int -> a -> Db ()+>   columnT :: Int -> Db a+>   idT     :: a -> Int++> instance Cell Int where+>   idT _    = 1+>   columnT  = columnInt+>   bindT    = bindInt++> instance Cell Double where+>  idT _    = 2+>  columnT  = columnDouble+>  bindT    = bindDouble++Equality test of derived types and database types+> fetchBody derived = do+>  cn <- columnCount+>  dbTypes <- mapM columnType $ enumFromThenTo (cn-1) (cn-2) 0+>  case dbTypes == derived of+   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+>   False -> fail "different database and haskell types"+>   True  -> return ()+>  x  <- columnStack+>  xs <- fetchTail+>  finalize+>  return (x:xs)++Middle level:++Abstract away from state and errors+> class DbError e where+>  makeErr :: CInt -> e+>  castErr :: e -> Maybe CInt++> class MonadIO m => MonadDb m where+>  getDb     :: m (Ptr L.Sqlite3)+>  putDb     :: Ptr L.Sqlite3 -> m ()+>  cleanDb   :: m ()+>  isDbReady :: m Bool+>  getSt     :: m (Ptr L.Stmt)+>  putSt     :: Ptr L.Stmt -> m ()+>  cleanSt   :: m ()+>  isStReady :: m Bool++Simple instance for MonadDb (in Sqlite3.hs)+> data SimpleState = SimpleState+> { database  :: Maybe (Ptr L.Sqlite3)+> , statement :: Maybe (Ptr L.Stmt ) }+> ...+> instance MonadDb (StateT SimpleState (ErrorT (Either CInt String) IO)) where++ > getDb = get >>= maybe (fail "Empty database")  return . database+ > getSt = get >>= maybe (fail "Empty statement") return . statement++ > putDb x = modify $ \a -> a { database  = Just x }+ > putSt x = modify $ \a -> a { statement = Just x }++ > cleanDb = modify $ \a -> a { database  = Nothing }+ > cleanSt = modify $ \a -> a { statement = Nothing }++ > isDbReady = get >>= return . maybe False (const True) . database+ > isStReady = get >>= return . maybe False (const True) . statement+++++++type Void = Word8++foreign import ccall unsafe "sqlite3_open" c_open+ :: CString -> Ptr (Ptr Void) -> IO Int++foreign import ccall unsafe "sqlite3_close" c_close+ :: Ptr Void -> IO Int++foreign import ccall unsafe "sqlite3_errmsg" c_errmsg+ :: Ptr Void -> IO CString++foreign import ccall unsafe "sqlite3_prepare_v2" c_prepare+ :: Ptr Void -> CString -> Int -> Ptr (Ptr Void) -> Ptr CString -> IO Int++foreign import ccall unsafe "sqlite3_finalize" c_finalize+ :: Ptr Void -> IO Int++foreign import ccall unsafe "sqlite3_reset" c_reset+ :: Ptr Void -> IO Int++foreign import ccall unsafe "sqlite3_bind_int" c_bind_int+ :: Ptr Void -> Int -> Int -> IO Int++foreign import ccall unsafe "sqlite3_bind_text" c_bind_text+ :: Ptr Void -> Int -> CString -> Int -> Int -> IO Int++foreign import ccall unsafe "sqlite3_step" c_step+ :: Ptr Void -> IO Int++foreign import ccall unsafe "sqlite3_column_blob" c_column_blob+ :: Ptr Void -> Int -> IO CString++foreign import ccall unsafe "sqlite3_column_bytes" c_column_bytes+ :: Ptr Void -> Int -> IO Int++foreign import ccall unsafe "sqlite3_column_count" c_column_count+ :: Ptr Void -> IO Int++foreign import ccall unsafe "sqlite3_column_int" c_column_int+ :: Ptr Void -> Int -> IO Int++foreign import ccall unsafe "sqlite3_column_double" c_column_double+ :: Ptr Void -> Int -> IO Double++foreign import ccall unsafe "sqlite3_column_text" c_column_text+ :: Ptr Void -> Int -> IO CString++foreign import ccall unsafe "sqlite3_column_type" c_column_type+ :: Ptr Void -> Int -> IO Int++type DbE a =+ (Error e+ ,MonadError e m+ ,MonadState sg m+ ,LocalState sg StateDb+ ,Monad m+ ) => m a++type DbIO a =+ (LocalState sg StateDb+ ,MonadIO m+ ,MonadState sg m+ ,MonadError e m+ ,Error e+ ,Monad m+ ) => m a++type E a =+ (MonadError e m+ ,Error e+ ) => m a++data StateDb = SD+ { dbP :: Maybe (Ptr Void)+ , stP :: Maybe (Ptr Void)+ } deriving (Show, Typeable)++instance ZeroState StateDb where+ zeroState = SD+  { dbP = Nothing+  , stP = Nothing }++setDB :: Ptr Void -> DbE ()+setDB ptr = get >>= \st@(SD { dbP = dbP }) ->+ case dbP of+   Nothing -> put (st { dbP = Just ptr })+   Just _  -> err "Database is allready set"++setST :: Ptr Void -> DbE ()+setST ptr = get >>= \st@(SD { stP = stP }) ->+    case stP of+      Nothing -> put (st { stP = Just ptr })+      Just _  -> err "Statement is allready set"++isSetDB :: DbE Bool+isSetDB = get >>= \(SD { dbP = dbP }) ->+    case dbP of+      Nothing -> return False+      Just _ -> return True++getDB :: DbE (Ptr Void)+getDB = get >>= \(SD { dbP = dbP }) ->+    case dbP of+      Just a  -> return a+      Nothing -> err "Database is not set"++getST :: DbE (Ptr Void)+getST = get >>= \(SD { stP = stP }) ->+    case stP of+      Just a  -> return a+      Nothing -> err "Statement is not set"++clearDB :: DbE ()+clearDB = get >>= \st@(SD { dbP = dbP }) ->+    case dbP of+      Just _  -> put (st { dbP = Nothing })+      Nothing -> err "Database is allready clear"++clearST :: DbE ()+clearST = get >>= \st@(SD { stP = stP }) ->+    case stP of+      Just _  -> put (st { stP = Nothing })+      Nothing -> err "Statement is allready clear"++--++err :: String -> E x+err a = throwError $ strMsg a+++errRc :: Int -> String -> DbIO ()+errRc 0 _ = return ()+errRc rc msg = do+ ans <- isSetDB+ case ans of+  True -> do+    ptr <- getDB+    cstr <- liftIO $ c_errmsg ptr+    reason <- liftIO $ peekCString cstr+    err $ "Foreign: "++msg++": (rc="++show rc++") "++reason+  False ->+    err $ "Foreign: "++msg++": (rc="++show rc++")"++errIf :: Bool -> String -> DbIO ()+errIf False _ = return ()+errIf True msg = do+ ans <- isSetDB+ case ans of+  True -> do+    ptr <- getDB+    cstr <- liftIO $ c_errmsg ptr+    reason <- liftIO $ peekCString cstr+    err $ "Foreign: "++msg++": "++reason+  False ->+    err $ "Foreign: "++msg++--debug a = liftIO $ hPutStr stderr $ "DEBUG: " ++ show a ++ "\n"++debug :: Show a => a -> DbIO ()+debug a = liftIO $ hPutStr stderr ("DEBUG: " ++ show a ++ "\n")++--cont :: ((a -> IO (b,s)) -> IO (b,s)) -> (a -> StateT s IO b) -> StateT s IO b+--cont f g = StateT $ \st -> liftIO $ f $ \a -> (runStateT (g a)) st++fin a b = catchError a (\e -> b >> throwError e)++try a = catchError (liftM Right a) (\e -> return $ Left e)++--++open :: String -> DbIO ()+open path = do+ pptr <- i malloc+ cstr <- i$ newCString path+ debug (path,cstr,pptr,"open")+ rc <- i$ c_open cstr pptr+ ptr <- i$ peek pptr+ setDB ptr+ fin (errRc rc "open") $ do+   r <- try close+   case r of+     Left _   -> clearDB+     Right () -> return ()+ where i = liftIO++close :: DbIO ()+close = do+ ptr <- getDB+ debug (ptr,"close")+ rc <- liftIO $ c_close ptr+ errRc rc "close"+ clearDB++prepare :: String -> DbIO ()+prepare sql = do+ pptr <- i malloc+ (cstr,len) <- i$ newCStringLen sql+ debug (sql,cstr,len,pptr,"prepare")+ ptr <- getDB+ rc <- i$ c_prepare ptr cstr len pptr nullPtr+ sptr <- i$ peek pptr+ setST sptr+ fin (errRc rc "prepare") $ do+   r <- try finalize+   case r of+     Left _ -> clearST+     Right () -> return ()+ where i = liftIO++finalize :: DbIO ()+finalize = do+ ptr <- getST+ debug (ptr,"finalize")+ rc <- liftIO $ c_finalize ptr+ errRc rc "finalize"+ clearST++reset :: DbIO ()+reset = do+ ptr <- getST+ debug (ptr,"reset")+ rc <- liftIO $ c_reset ptr+ errRc rc "reset"++step :: DbIO Bool+step = do+ ptr <- getST+ debug (ptr,"step")+ rc <- liftIO $ c_step ptr+ errIf (rc /= 100 && rc /= 101) $ "step: "++show rc+ return (rc == 101)++bind_int :: (Int,Int) -> DbIO ()+bind_int (num,val) = do+ ptr <- getST+ debug (ptr,"bind_int")+ rc <- liftIO $ c_bind_int ptr num val+ errRc rc "bind_int"++bind_text :: (Int,String) -> DbIO ()+bind_text (num,val) = do+ (cstr,len) <- liftIO $ newCStringLen val+ ptr <- getST+ debug (ptr,"bind_text")+ rc <- liftIO $ c_bind_text ptr num cstr len (-1)+ errRc rc "bind_text"++column_bytes :: Int -> DbIO Int+column_bytes num = do+ ptr <- getST+ debug (ptr,"column_bytes")+ liftIO $ c_column_bytes ptr num++column_count :: DbIO Int+column_count = do+ ptr <- getST+ debug (ptr,"column_count")+ liftIO $ c_column_count ptr++column_int :: Int -> DbIO Int+column_int num = do+ ptr <- getST+ debug (ptr,"column_int")+ liftIO $ c_column_int ptr num++column_double :: Int -> DbIO Double+column_double num = do+ ptr <- getST+ debug (ptr,"column_double")+ liftIO $ c_column_double ptr num++column_type :: Int -> DbIO Int+column_type num = do+ ptr <- getST+ debug (ptr,"column_type")+ liftIO $ c_column_type ptr num++column_text :: Int -> DbIO String+column_text num = do+ ptr <- getST+ by <- column_bytes num+ debug (ptr,by,"column_text")+ tx <- liftIO $ c_column_text ptr num+ utf <- liftIO $ peekCStringLen (tx,by)+ return $ UTF8.decodeString utf++column_blob :: Int -> DbIO B.ByteString+column_blob num = do+ ptr <- getST+ debug (ptr,"column_blob")+ by <- column_bytes num+ bl <- liftIO $ c_column_blob ptr num+ return $ B.packCStringLen (bl,by)
− src/Database/Sqlite3/Low.hs 
@@ -1,460 +0,0 @@--- | This is intended to be a low level wrapper over sqlite3--- library. These design decisions guide this module:------ * Portability.------ * It is meant to be as  close as possible to a bijection over sqlite3--- objects, constants and functions.  The original documentation for any--- sqlite3 name should be sufficient to understand its wrapper.------ * Everything not UTF-8 has been removed in favor of UTF-8.------ * @sqlite3_@  prefix has  been removed from  all object  and function--- names since it can be mapped to a qualified module import.------ * Mutex related  names are not wrapped, as  they would just duplicate--- existing functionality.------ * All  sqlite3 experimental  or obsolete code  (marked with  @exp@ or--- @obs@ in the official documentation) has not been wrapped, as well as--- the testing interface (@sqlite3_test_control@ and related constants).------ *  Preprocessor  constant definitions  have  been  replaced by  equal--- values.  All  were  typed  to  CInt,  except  for  SQLITE_STATIC  and--- SQLITE_TRANSIENT (mapped  to sqliteStatic and  sqliteTransient) which--- were  typed as  function pointers  as faithfully  as possible  to the--- underline C  code. Version information  constants are not  mapped for--- portability,  and   the  user  can   always  call  the   mappings  of--- sqlite3_libversion and sqlite3_libversion_number functions instead.--module Database.Sqlite3.Low where-import Foreign-import Foreign.C-import Data.Bits---- * Objects--data Sqlite3 = Sqlite3-data Blob = Blob-data Context = Context-data File = File-data Int64 = Int64-data Uint64 = Uint64-data IoMethods = IoMethods-data Stmt = Stmt-data Value = Value-data Vfs = Vfs--foreign import ccall "&sqlite3_temp_directory" tempDirectory- :: Ptr CString---- * Constants---- | Error codes--[sqliteOk, sqliteError, sqliteInternal, sqlitePerm, sqliteAbort,- sqliteBusy, sqliteLocked, sqliteNoMem, sqliteReadOnly,- sqliteInterrupt, sqliteIoErr, sqliteCorrupt, sqliteNotFound,- sqliteFull, sqliteCantOpen, sqliteProtocol, sqliteEmpty,- sqliteSchema, sqliteTooBig, sqliteConstraint, sqliteMismatch,- sqliteMisuse, sqliteNoLfs, sqliteAuth, sqliteFormat, sqliteRange,- sqliteNotADb, sqliteRow, sqliteDone] = [0..26] ++ [100,101] ::- [CInt]---- | Flags for the xAccess VFS method--[sqliteAccessExists, sqliteAccessReadWrite, sqliteAccessRead] =- [0..2] :: [CInt]---- | Authorizer Action Codes--[sqliteCreateIndex, sqliteCreateTable, sqliteCreateTempIndex,- sqliteCreateTempTable, sqliteCreateTempTrigger,- sqliteCreateTempView, sqliteCreateTrigger, sqliteCreateView,- sqliteDelete, sqliteDropIndex, sqliteDropTable,- sqliteDropTempIndex, sqliteDropTempTable, sqliteDropTempTrigger,- sqliteDropTempView, sqliteDropTrigger, sqliteDropView,- sqliteInsert, sqlitePragma, sqliteRead, sqliteSelect,- sqliteTransaction, sqliteUpdate, sqliteAttach, sqliteDetach,- sqliteAlterTable, sqliteReindex, sqliteAnalyze,- sqliteCreateVtable, sqliteDropVtable, sqliteFunction] = [1..31] ::- [CInt]---- | Text Encodings--sqliteUtf8 = 1 :: CInt---- | Fundamental Datatypes--[sqliteInteger, sqliteFloat, sqliteText, sqliteBlob, sqliteNull] =- [1..5] :: [CInt]---- | Authorizer Return Codes--[sqliteDeny, sqliteIgnore] = [1,2] :: [CInt]---- | Standard File Control Opcodes--sqliteFcntlLockstate = 1 :: CInt---- | Device Characteristics--[sqliteIocapAtomic, sqliteIocapAtomic512, sqliteIocapAtomic1K,- sqliteIocapAtomic2K, sqliteIocapAtomic4K, sqliteIocapAtomic8K,- sqliteIocapAtomic16K, sqliteIocapAtomic32K, sqliteIocapAtomic64K,- sqliteIocapSafeAppend, sqliteIocapSequential] = map bit [0..10] ::- [CInt]---- | Extended Result Codes--[sqliteIoErrRead, sqliteIoErrShortRead, sqliteIoErrWrite,- sqliteIoErrFsync, sqliteIoErrDirFsync, sqliteIoErrTruncate,- sqliteIoErrFstat, sqliteIoErrUnlock, sqliteIoErrRdlock,- sqliteIoErrDelete, sqliteIoErrBlocked, sqliteIoErrNomem,- sqliteIoErrAccess, sqliteIoErrCheckreservedlock, sqliteIoErrLock]- = map ( (sqliteIoErr .|.) . (flip shift $ 8) ) [1..15] :: [CInt]---- | Run-Time Limit Categories--[sqliteLimitLength, sqliteLimitSqlLength, sqliteLimitColumn,- sqliteLimitExprDepth, sqliteLimitCompoundSelect,- sqliteLimitVdbeOp, sqliteLimitFunctionArg, sqliteLimitAttached,- sqliteLimitLikePatternLength, sqliteLimitVariableNumber] = [0..9]- :: [CInt]---- | File Locking Levels--[sqliteLockNone, sqliteLockShared, sqliteLockReserved,- sqliteLockPending, sqliteLockExclusive] = [0..4] :: [CInt]---- | Flags For File Open Operations--[sqliteOpenReadOnly, sqliteOpenReadWrite, sqliteOpenCreate,- sqliteOpenDeleteOnClose, sqliteOpenExclusive, sqliteOpenMainDb,- sqliteOpenTempDb, sqliteOpenTransientDb, sqliteOpenMainJournal,- sqliteOpenTempJournal, sqliteOpenSubjournal,- sqliteOpenMasterJournal, sqliteOpenNoMutex, sqliteOpenFullMutex] =- map bit $ [0..4] ++ [8..16] :: [CInt]---- | Constants Defining Special Destructor Behavior--[sqliteStatic, sqliteTransient] = map cast [0,-1]-  where-    cast :: IntPtr -> FunPtr (Ptr () -> ())-    cast n = (castPtrToFunPtr . intPtrToPtr) n---- | Synchronization Type Flags--[sqliteSyncNormal, sqliteSyncFull, sqliteSyncDataonly] = [0x2,- 0x3, 0x10] :: [CInt]---- * Functions--foreign import ccall "sqlite3_close" close- :: Ptr Sqlite3 -> IO CInt--foreign import ccall "sqlite3_exec" exec- :: Ptr Sqlite3 -> CString -> FunPtr (Ptr () -> CInt -> Ptr CString-        -> Ptr CString -> IO CInt) -> Ptr () -> Ptr CString -> IO CInt--foreign import ccall "sqlite3_free" free- :: Ptr a -> IO ()--foreign import ccall "sqlite3_open" open- :: CString -> (Ptr (Ptr Sqlite3)) -> IO CInt--------{- Code not yet adapted to new version--foreign import ccall unsafe "sqlite3_errmsg" c_errmsg- :: Ptr Void -> IO CString--foreign import ccall unsafe "sqlite3_prepare_v2" c_prepare- :: Ptr Void -> CString -> Int -> Ptr (Ptr Void) -> Ptr CString -> IO Int--foreign import ccall unsafe "sqlite3_finalize" c_finalize- :: Ptr Void -> IO Int--foreign import ccall unsafe "sqlite3_reset" c_reset- :: Ptr Void -> IO Int--foreign import ccall unsafe "sqlite3_bind_int" c_bind_int- :: Ptr Void -> Int -> Int -> IO Int--foreign import ccall unsafe "sqlite3_bind_text" c_bind_text- :: Ptr Void -> Int -> CString -> Int -> Int -> IO Int--foreign import ccall unsafe "sqlite3_step" c_step- :: Ptr Void -> IO Int--foreign import ccall unsafe "sqlite3_column_blob" c_column_blob- :: Ptr Void -> Int -> IO CString--foreign import ccall unsafe "sqlite3_column_bytes" c_column_bytes- :: Ptr Void -> Int -> IO Int--foreign import ccall unsafe "sqlite3_column_count" c_column_count- :: Ptr Void -> IO Int--foreign import ccall unsafe "sqlite3_column_int" c_column_int- :: Ptr Void -> Int -> IO Int--foreign import ccall unsafe "sqlite3_column_double" c_column_double- :: Ptr Void -> Int -> IO Double--foreign import ccall unsafe "sqlite3_column_text" c_column_text- :: Ptr Void -> Int -> IO CString--foreign import ccall unsafe "sqlite3_column_type" c_column_type- :: Ptr Void -> Int -> IO Int--type DbE a =- (Error e- ,MonadError e m- ,MonadState sg m- ,LocalState sg StateDb- ,Monad m- ) => m a--type DbIO a =- (LocalState sg StateDb- ,MonadIO m- ,MonadState sg m- ,MonadError e m- ,Error e- ,Monad m- ) => m a--type E a =- (MonadError e m- ,Error e- ) => m a--data StateDb = SD- { dbP :: Maybe (Ptr Void)- , stP :: Maybe (Ptr Void)- } deriving (Show, Typeable)--instance ZeroState StateDb where- zeroState = SD-  { dbP = Nothing-  , stP = Nothing }--setDB :: Ptr Void -> DbE ()-setDB ptr = get >>= \st@(SD { dbP = dbP }) ->- case dbP of-   Nothing -> put (st { dbP = Just ptr })-   Just _  -> err "Database is allready set"--setST :: Ptr Void -> DbE ()-setST ptr = get >>= \st@(SD { stP = stP }) ->-    case stP of-      Nothing -> put (st { stP = Just ptr })-      Just _  -> err "Statement is allready set"--isSetDB :: DbE Bool-isSetDB = get >>= \(SD { dbP = dbP }) ->-    case dbP of-      Nothing -> return False-      Just _ -> return True--getDB :: DbE (Ptr Void)-getDB = get >>= \(SD { dbP = dbP }) ->-    case dbP of-      Just a  -> return a-      Nothing -> err "Database is not set"--getST :: DbE (Ptr Void)-getST = get >>= \(SD { stP = stP }) ->-    case stP of-      Just a  -> return a-      Nothing -> err "Statement is not set"--clearDB :: DbE ()-clearDB = get >>= \st@(SD { dbP = dbP }) ->-    case dbP of-      Just _  -> put (st { dbP = Nothing })-      Nothing -> err "Database is allready clear"--clearST :: DbE ()-clearST = get >>= \st@(SD { stP = stP }) ->-    case stP of-      Just _  -> put (st { stP = Nothing })-      Nothing -> err "Statement is allready clear"------err :: String -> E x-err a = throwError $ strMsg a---errRc :: Int -> String -> DbIO ()-errRc 0 _ = return ()-errRc rc msg = do- ans <- isSetDB- case ans of-  True -> do-    ptr <- getDB-    cstr <- liftIO $ c_errmsg ptr-    reason <- liftIO $ peekCString cstr-    err $ "Foreign: "++msg++": (rc="++show rc++") "++reason-  False ->-    err $ "Foreign: "++msg++": (rc="++show rc++")"--errIf :: Bool -> String -> DbIO ()-errIf False _ = return ()-errIf True msg = do- ans <- isSetDB- case ans of-  True -> do-    ptr <- getDB-    cstr <- liftIO $ c_errmsg ptr-    reason <- liftIO $ peekCString cstr-    err $ "Foreign: "++msg++": "++reason-  False ->-    err $ "Foreign: "++msg----debug a = liftIO $ hPutStr stderr $ "DEBUG: " ++ show a ++ "\n"--debug :: Show a => a -> DbIO ()-debug a = liftIO $ hPutStr stderr ("DEBUG: " ++ show a ++ "\n")----cont :: ((a -> IO (b,s)) -> IO (b,s)) -> (a -> StateT s IO b) -> StateT s IO b---cont f g = StateT $ \st -> liftIO $ f $ \a -> (runStateT (g a)) st--fin a b = catchError a (\e -> b >> throwError e)--try a = catchError (liftM Right a) (\e -> return $ Left e)------open :: String -> DbIO ()-open path = do- pptr <- i malloc- cstr <- i$ newCString path- debug (path,cstr,pptr,"open")- rc <- i$ c_open cstr pptr- ptr <- i$ peek pptr- setDB ptr- fin (errRc rc "open") $ do-   r <- try close-   case r of-     Left _   -> clearDB-     Right () -> return ()- where i = liftIO--close :: DbIO ()-close = do- ptr <- getDB- debug (ptr,"close")- rc <- liftIO $ c_close ptr- errRc rc "close"- clearDB--prepare :: String -> DbIO ()-prepare sql = do- pptr <- i malloc- (cstr,len) <- i$ newCStringLen $ UTF8.encodeString sql- debug (sql,cstr,len,pptr,"prepare")- ptr <- getDB- rc <- i$ c_prepare ptr cstr len pptr nullPtr- sptr <- i$ peek pptr- setST sptr- fin (errRc rc "prepare") $ do-   r <- try finalize-   case r of-     Left _ -> clearST-     Right () -> return ()- where i = liftIO--finalize :: DbIO ()-finalize = do- ptr <- getST- debug (ptr,"finalize")- rc <- liftIO $ c_finalize ptr- errRc rc "finalize"- clearST--reset :: DbIO ()-reset = do- ptr <- getST- debug (ptr,"reset")- rc <- liftIO $ c_reset ptr- errRc rc "reset"--step :: DbIO Bool-step = do- ptr <- getST- debug (ptr,"step")- rc <- liftIO $ c_step ptr- errIf (rc /= 100 && rc /= 101) $ "step: "++show rc- return (rc == 101)--bind_int :: (Int,Int) -> DbIO ()-bind_int (num,val) = do- ptr <- getST- debug (ptr,"bind_int")- rc <- liftIO $ c_bind_int ptr num val- errRc rc "bind_int"--bind_text :: (Int,String) -> DbIO ()-bind_text (num,val) = do- (cstr,len) <- liftIO $ newCStringLen val- ptr <- getST- debug (ptr,"bind_text")- rc <- liftIO $ c_bind_text ptr num cstr len (-1)- errRc rc "bind_text"--column_bytes :: Int -> DbIO Int-column_bytes num = do- ptr <- getST- debug (ptr,"column_bytes")- liftIO $ c_column_bytes ptr num--column_count :: DbIO Int-column_count = do- ptr <- getST- debug (ptr,"column_count")- liftIO $ c_column_count ptr--column_int :: Int -> DbIO Int-column_int num = do- ptr <- getST- debug (ptr,"column_int")- liftIO $ c_column_int ptr num--column_double :: Int -> DbIO Double-column_double num = do- ptr <- getST- debug (ptr,"column_double")- liftIO $ c_column_double ptr num--column_type :: Int -> DbIO Int-column_type num = do- ptr <- getST- debug (ptr,"column_type")- liftIO $ c_column_type ptr num--column_text :: Int -> DbIO String-column_text num = do- ptr <- getST- by <- column_bytes num- debug (ptr,by,"column_text")- tx <- liftIO $ c_column_text ptr num- utf <- liftIO $ peekCStringLen (tx,by)- return $ UTF8.decodeString utf--column_blob :: Int -> DbIO B.ByteString-column_blob num = do- ptr <- getST- debug (ptr,"column_blob")- by <- column_bytes num- bl <- liftIO $ c_column_blob ptr num- return $ B.packCStringLen (bl,by)---}
− src/Examples/hs_sqlite3_test.sql 
@@ -1,6 +0,0 @@-CREATE TABLE IF NOT EXISTS test_tab (- --id INTEGER PRIMARY KEY AUTOINCREMENT,- a TEXT NOT NULL,- b TEXT NOT NULL,- c TEXT NOT NULL-);