Sqlite3.hs

{-# options -fglasgow-exts -farrows #-}

module Database.Sqlite3
 ( 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 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