packages feed

hsSqlite3 0.0.3 → 0.0.4

raw patch · 3 files changed

+102/−91 lines, 3 files

Files

hsSqlite3.cabal view
@@ -1,5 +1,5 @@ Name: hsSqlite3-Version: 0.0.3+Version: 0.0.4 License: LGPL Maintainer: Evgeny Jukov <masloed@gmail.com> Author: Evgeny Jukov
src/Database/Sqlite3.hs view
@@ -5,8 +5,8 @@  , Val ( IntV, Int64V, DoubleV, TextV, BlobV, NullV )  , fetch  , bind- , fetchOne- , fetchOK+ , row+ , test  , sql  ) where @@ -33,10 +33,10 @@  valID  :: a -> Int  class ValFetch a where- valFetch :: LocalState s StateDb => (Int,Int) -> StateT s IO a+ valFetch :: (Int,Int) -> DbIO a  class ValBind a where- valBind :: LocalState s StateDb => (Int,a) -> StateT s IO ()+ valBind :: (Int,a) -> DbIO ()  class ValID a => ValCast a b where  valCast :: a -> b@@ -94,6 +94,7 @@ 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@@ -136,14 +137,7 @@  -- -fetch ::- forall a s sql .- ( ValFetch a- --, GetCString sql IO- , LocalState s StateDb- --, Show sql- )- => String -> StateT s IO [[a]]+fetch :: ValFetch a => String -> DbIO [[a]] fetch sql = do  liftIO $ putStr $ UTF8.encodeString $ sql++"\n"  prepare sql@@ -168,14 +162,14 @@      xs <- fetchRow ft      return (x:xs) -sql :: ({-Show sql,-} {-GetCString sql IO,-} LocalState s StateDb) => String -> StateT s IO ()+sql :: String -> DbIO () sql sql = do  liftIO $ putStr $ UTF8.encodeString $ sql++"\n"  prepare sql  step  finalize -bind :: ({-Show sql, GetCString sql IO,-} LocalState s StateDb) => String -> [[Val]] -> StateT s IO ()+bind :: String -> [[Val]] -> DbIO () bind sql tab = do  liftIO $ putStr $ UTF8.encodeString $ sql++"\n"  debug tab@@ -183,15 +177,15 @@  mapM_ (\row -> mapM_ (\(v,n) -> valBind (n,v)) (zip row [1..]) >> step >> reset) tab  finalize -fetchOne' :: forall a s .  (ValFetch a, LocalState s StateDb) => String -> Int -> StateT s IO [[a]]+fetchOne' :: ValFetch a => String -> Int -> DbIO [[a]] fetchOne' sql num = fetch sql'  where sql' = concat [sql," LIMIT 1 OFFSET ", show num] -fetchOne :: forall a s .  (ValFetch a, LocalState s StateDb) => String -> Int -> StateT s IO [a]-fetchOne sql num = liftM head $ fetchOne' sql num+row :: ValFetch a => String -> Int -> DbIO [a]+row sql num = liftM head $ fetchOne' sql num -fetchOK :: LocalState s StateDb => String -> StateT s IO Bool-fetchOK sql = do+test :: String -> DbIO Bool+test sql = do  tab :: [[Val]] <- fetchOne' sql 0  case length tab of   1 -> return True
src/Database/Sqlite3/Low.hs view
@@ -12,6 +12,7 @@ import Control.Monad.Trans import Control.Monad.Error import Control.Monad.State.Lazy hiding (get,put)+import qualified Control.Monad.State.Lazy as ST  import qualified Codec.Binary.UTF8.String as UTF8 import qualified Data.ByteString as B@@ -70,8 +71,28 @@ 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)@@ -82,60 +103,55 @@   { dbP = Nothing   , stP = Nothing } -setDB :: (Error e, MonadError e m, LocalState sg StateDb) => Ptr Void -> StateT sg m ()+setDB :: Ptr Void -> DbE () setDB ptr = get >>= \st@(SD { dbP = dbP }) ->  case dbP of    Nothing -> put (st { dbP = Just ptr })-   Just _  -> lift $ throwError $ strMsg-    "Database is allready set"+   Just _  -> err "Database is allready set" -setST :: (Error e, MonadError e m, LocalState sg StateDb) => Ptr Void -> StateT sg m ()+setST :: Ptr Void -> DbE () setST ptr = get >>= \st@(SD { stP = stP }) ->     case stP of       Nothing -> put (st { stP = Just ptr })-      Just _  -> lift $ throwError $ strMsg-        "Statement is allready set"+      Just _  -> err "Statement is allready set" -isSetDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m Bool+isSetDB :: DbE Bool isSetDB = get >>= \(SD { dbP = dbP }) ->     case dbP of       Nothing -> return False       Just _ -> return True -getDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m (Ptr Void)+getDB :: DbE (Ptr Void) getDB = get >>= \(SD { dbP = dbP }) ->     case dbP of       Just a  -> return a-      Nothing -> lift $ throwError $ strMsg-        "Database is not set"+      Nothing -> err "Database is not set" -getST :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m (Ptr Void)+getST :: DbE (Ptr Void) getST = get >>= \(SD { stP = stP }) ->     case stP of       Just a  -> return a-      Nothing -> lift $ throwError $ strMsg-        "Statement is not set"+      Nothing -> err "Statement is not set" -clearDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m ()+clearDB :: DbE () clearDB = get >>= \st@(SD { dbP = dbP }) ->     case dbP of       Just _  -> put (st { dbP = Nothing })-      Nothing -> lift $ throwError $ strMsg-        "Database is allready clear"+      Nothing -> err "Database is allready clear" -clearST :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m ()+clearST :: DbE () clearST = get >>= \st@(SD { stP = stP }) ->     case stP of       Just _  -> put (st { stP = Nothing })-      Nothing -> lift $ throwError $ strMsg-        "Statement is allready clear"+      Nothing -> err "Statement is allready clear"  -- -err :: String -> StateT s IO ()-err = liftIO .  throwError .  strMsg+err :: String -> E x+err a = throwError $ strMsg a -errRc :: LocalState s StateDb => Int -> String -> StateT s IO ()++errRc :: Int -> String -> DbIO () errRc 0 _ = return () errRc rc msg = do  ans <- isSetDB@@ -148,7 +164,7 @@   False ->     err $ "Foreign: "++msg++": (rc="++show rc++")" -errIf :: LocalState s StateDb => Bool -> String -> StateT s IO ()+errIf :: Bool -> String -> DbIO () errIf False _ = return () errIf True msg = do  ans <- isSetDB@@ -161,14 +177,13 @@   False ->     err $ "Foreign: "++msg - --debug a = liftIO $ hPutStr stderr $ "DEBUG: " ++ show a ++ "\n" -debug :: Show a => a -> StateT s IO ()+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+--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) @@ -176,21 +191,22 @@  -- -open :: LocalState s StateDb => String -> StateT s IO ()-open path =- cont alloca $ \pptr ->- cont (withCString path) $ \cstr -> do-  debug (cstr,pptr,"open")-  rc <- liftIO $ c_open cstr pptr-  ptr <- liftIO $ peek pptr-  setDB ptr-  fin (errRc rc "open") $ do-    r <- try close-    case r of-     Left _ -> clearDB+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 :: LocalState s StateDb => StateT s IO ()+close :: DbIO () close = do  ptr <- getDB  debug (ptr,"close")@@ -198,22 +214,23 @@  errRc rc "close"  clearDB -prepare :: LocalState s StateDb => String -> StateT s IO ()-prepare sql =- cont alloca $ \pptr ->- cont (withCStringLen sql) $ \(cstr,len) -> do-  ptr <- getDB-  debug (cstr,len,pptr,"prepare")-  rc <- liftIO $ c_prepare ptr cstr len pptr nullPtr-  sptr <- liftIO $ peek pptr-  setST sptr-  fin (errRc rc "prepare") $ do+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 ()+     Left _ -> clearST+     Right () -> return ()+ where i = liftIO -finalize :: LocalState s StateDb => StateT s IO ()+finalize :: DbIO () finalize = do  ptr <- getST  debug (ptr,"finalize")@@ -221,14 +238,14 @@  errRc rc "finalize"  clearST -reset :: LocalState s StateDb => StateT s IO ()+reset :: DbIO () reset = do  ptr <- getST  debug (ptr,"reset")  rc <- liftIO $ c_reset ptr  errRc rc "reset" -step :: LocalState s StateDb => StateT s IO Bool+step :: DbIO Bool step = do  ptr <- getST  debug (ptr,"step")@@ -236,52 +253,52 @@  errIf (rc /= 100 && rc /= 101) $ "step: "++show rc  return (rc == 101) -bind_int :: LocalState s StateDb => (Int,Int) -> StateT s IO ()+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 :: LocalState s StateDb => (Int,String) -> StateT s IO ()-bind_text (num,val) =- cont (withCStringLen val) $ \(cstr,len) -> do-  ptr <- getST-  debug (ptr,"bind_text")-  rc <- liftIO $ c_bind_text ptr num cstr len (-1)-  errRc rc "bind_text"+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 :: LocalState s StateDb => Int -> StateT s IO Int+column_bytes :: Int -> DbIO Int column_bytes num = do  ptr <- getST  debug (ptr,"column_bytes")  liftIO $ c_column_bytes ptr num -column_count :: LocalState s StateDb => StateT s IO Int+column_count :: DbIO Int column_count = do  ptr <- getST  debug (ptr,"column_count")  liftIO $ c_column_count ptr -column_int :: LocalState s StateDb => Int -> StateT s IO Int+column_int :: Int -> DbIO Int column_int num = do  ptr <- getST  debug (ptr,"column_int")  liftIO $ c_column_int ptr num -column_double :: LocalState s StateDb => Int -> StateT s IO Double+column_double :: Int -> DbIO Double column_double num = do  ptr <- getST  debug (ptr,"column_double")  liftIO $ c_column_double ptr num -column_type :: LocalState s StateDb => Int -> StateT s IO Int+column_type :: Int -> DbIO Int column_type num = do  ptr <- getST  debug (ptr,"column_type")  liftIO $ c_column_type ptr num -column_text :: LocalState s StateDb => Int -> StateT s IO String+column_text :: Int -> DbIO String column_text num = do  ptr <- getST  by <- column_bytes num@@ -290,7 +307,7 @@  utf <- liftIO $ peekCStringLen (tx,by)  return $ UTF8.decodeString utf -column_blob :: LocalState s StateDb => Int -> StateT s IO B.ByteString+column_blob :: Int -> DbIO B.ByteString column_blob num = do  ptr <- getST  debug (ptr,"column_blob")