diff --git a/simplest-sqlite.cabal b/simplest-sqlite.cabal --- a/simplest-sqlite.cabal +++ b/simplest-sqlite.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: simplest-sqlite -version: 0.0.0.10 +version: 0.0.0.11 stability: Experimental author: YoshikuniJujo maintainer: YoshikuniJujo @@ -23,13 +23,16 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/test_haskell - tag: simplest-sqlite-0.0.0.10 + tag: simplest-sqlite-0.0.0.11 library hs-source-dirs: src exposed-modules: Database.SmplstSQLite3 - other-modules: Database.SmplstSQLite3.Constants - build-depends: base == 4.*, bytestring == 0.10.*, text >= 1.1 && < 1.3 + other-modules: + Database.SmplstSQLite3.Constants, Database.SmplstSQLite3.Templates + build-depends: + base == 4.*, bytestring == 0.10.*, text >= 1.1 && < 1.3, + exception-hierarchy == 0.0.0.1, template-haskell == 2.9.* ghc-options: -Wall extra-libraries: sqlite3 extensions: ForeignFunctionInterface diff --git a/src/Database/SmplstSQLite3.hs b/src/Database/SmplstSQLite3.hs --- a/src/Database/SmplstSQLite3.hs +++ b/src/Database/SmplstSQLite3.hs @@ -5,7 +5,7 @@ withSQLite, withPrepared, step, reset, bind, SQLiteData(..), SQLiteDataList(..), columnType, -- * Types - SQLite, Stmt, Result(..), Type(..), + SQLite, Stmt, Result(..), Type(..), SQLiteException(..), ) where import Control.Applicative @@ -18,6 +18,7 @@ import Foreign.C.Types import Foreign.C.String +import Database.SmplstSQLite3.Exception import Database.SmplstSQLite3.Constants data SQLite = SQLite (Ptr SQLite) deriving Show @@ -41,7 +42,7 @@ when (ret /= sQLITE_OK) $ do em <- sqlite3Errmsg sq sqlite3Close sq - ioError . userError $ "Cannot open database: " ++ em + sqliteThrow ("Cannot open database: " ++ em) ret return sq sqlite3Close :: SQLite -> IO () @@ -49,7 +50,7 @@ ret <- c_sqlite3_close db when (ret /= sQLITE_OK) $ do em <- sqlite3Errmsg sq - ioError . userError $ "Cannot close database: " ++ em + sqliteThrow ("Cannot close database: " ++ em) ret sqlite3Errmsg :: SQLite -> IO String sqlite3Errmsg (SQLite db) = peekCString =<< c_sqlite3_errmsg db @@ -74,15 +75,13 @@ when (ret /= sQLITE_OK) $ do em <- sqlite3Errmsg db sqlite3Finalize sm - ioError . userError $ "Cannot prepare: " ++ em + sqliteThrow ("Cannot prepare: " ++ em) ret (sm ,) <$> (peekCString =<< peek pt) sqlite3Finalize :: Stmt -> IO () sqlite3Finalize (Stmt psm) = do ret <- c_sqlite3_finalize psm - when (ret /= sQLITE_OK) $ - ioError . userError $ - "Cannot finalize stmt: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot finalize stmt" ret data Result = Busy | Row | Done deriving (Show, Eq) @@ -93,11 +92,9 @@ step (Stmt psm) = do ret <- c_sqlite3_step psm case ret of - _ | ret == sQLITE_BUSY -> return Busy - | ret == sQLITE_ROW -> return Row + _ | ret == sQLITE_ROW -> return Row | ret == sQLITE_DONE -> return Done - _ -> ioError . userError $ - "Error while step: error code (" ++ show ret ++ ")" + _ -> sqliteThrow "Error while step" ret foreign import ccall unsafe "sqlite3.h sqlite3_column_int" c_sqlite3_column_int :: Ptr Stmt -> CInt -> IO CInt @@ -166,38 +163,32 @@ sqlite3BindNull :: Stmt -> Int -> () -> IO () sqlite3BindNull (Stmt sm) i _ = do ret <- c_sqlite3_bind_null sm (fromIntegral i) - when (ret /= sQLITE_OK) . ioError . userError $ - "Cannot bind null: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot bind null: error code" ret sqlite3BindDouble :: Stmt -> Int -> Double -> IO () sqlite3BindDouble (Stmt sm) i d = do ret <- c_sqlite3_bind_double sm (fromIntegral i) (realToFrac d) - when (ret /= sQLITE_OK) . ioError . userError $ - "Cannot bind double: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot bind double" ret sqlite3BindInt :: Stmt -> Int -> Int -> IO () sqlite3BindInt (Stmt sm) i n = do ret <- c_sqlite3_bind_int sm (fromIntegral i) (fromIntegral n) - when (ret /= sQLITE_OK) . ioError . userError $ - "Cannot bind int: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot bind int" ret sqlite3BindString :: Stmt -> Int -> String -> IO () sqlite3BindString (Stmt sm) i s = withCString s $ \cs -> do ret <- c_sqlite3_bind_text sm (fromIntegral i) cs (- 1) nullPtr - when (ret /= sQLITE_OK) . ioError . userError $ - "Cannot bind text: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot bind text" ret sqlite3BindByteString :: Stmt -> Int -> BS.ByteString -> IO () sqlite3BindByteString (Stmt sm) i s = BS.useAsCString s $ \cs -> do ret <- c_sqlite3_bind_text sm (fromIntegral i) cs (- 1) nullPtr - when (ret /= sQLITE_OK) . ioError . userError $ - "Cannot bind text: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot bind text" ret sqlite3BindBlob :: Stmt -> Int -> BS.ByteString -> IO () sqlite3BindBlob (Stmt sm) i s = BS.useAsCString s $ \cs -> do ret <- c_sqlite3_bind_blob sm (fromIntegral i) cs (- 1) nullPtr - when (ret /= sQLITE_OK) . ioError . userError $ - "Cannot bind text: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot bind text" ret foreign import ccall unsafe "sqlite3.h sqlite3_bind_parameter_index" c_sqlite3_bind_parameter_index :: @@ -206,8 +197,8 @@ sqlite3BindParameterIndex :: Stmt -> String -> IO Int sqlite3BindParameterIndex (Stmt sm) ph = withCString ph $ \cph -> do i <- c_sqlite3_bind_parameter_index sm cph - when (i == 0) . ioError . userError $ - "no such place holder: `" ++ ph ++ "'" + when (i == 0) . + sqliteThrowBindError $ "no such place holder: `" ++ ph ++ "'" return $ fromIntegral i foreign import ccall unsafe "sqlite3.h sqlite3_reset" c_sqlite3_reset :: @@ -216,8 +207,7 @@ reset :: Stmt -> IO () reset (Stmt sm) = do ret <- c_sqlite3_reset sm - when (ret /= sQLITE_OK) . ioError . userError $ - "Cannot reset stmt: error code (" ++ show ret ++ ")" + when (ret /= sQLITE_OK) $ sqliteThrow "Cannot reset stmt" ret data Type = Integer | Float | Text | Blob | Null deriving (Show, Eq) diff --git a/src/Database/SmplstSQLite3/Constants.hsc b/src/Database/SmplstSQLite3/Constants.hsc --- a/src/Database/SmplstSQLite3/Constants.hsc +++ b/src/Database/SmplstSQLite3/Constants.hsc @@ -1,18 +1,212 @@ #include module Database.SmplstSQLite3.Constants ( - sQLITE_OK, sQLITE_ERROR, sQLITE_BUSY, sQLITE_ROW, sQLITE_DONE, - sQLITE_INTEGER, sQLITE_FLOAT, sQLITE_TEXT, sQLITE_BLOB, sQLITE_NULL + sQLITE_INTEGER, sQLITE_FLOAT, sQLITE_TEXT, sQLITE_BLOB, sQLITE_NULL, + + sQLITE_OK, sQLITE_ROW, sQLITE_DONE, + + sQLITE_ERROR, sQLITE_INTERNAL, sQLITE_PERM, + + sQLITE_ABORT_PLAIN, sQLITE_ABORT_ROLLBACK, + + sQLITE_BUSY_PLAIN, sQLITE_BUSY_RECOVERY, sQLITE_BUSY_SNAPSHOT, + + sQLITE_LOCKED_PLAIN, sQLITE_LOCKED_SHAREDCACHE, + + sQLITE_NOMEM, + + sQLITE_READONLY_PLAIN, sQLITE_READONLY_RECOVERY, + sQLITE_READONLY_CANTLOCK, sQLITE_READONLY_ROLLBACK, + sQLITE_READONLY_DBMOVED, + + sQLITE_INTERRUPT, + + sQLITE_IOERR_PLAIN, sQLITE_IOERR_READ, sQLITE_IOERR_SHORT_READ, + sQLITE_IOERR_WRITE, sQLITE_IOERR_FSYNC, sQLITE_IOERR_DIR_FSYNC, + sQLITE_IOERR_TRUNCATE, sQLITE_IOERR_FSTAT, sQLITE_IOERR_UNLOCK, + sQLITE_IOERR_RDLOCK, + sQLITE_IOERR_DELETE, sQLITE_IOERR_BLOCKED, sQLITE_IOERR_NOMEM, + sQLITE_IOERR_ACCESS, sQLITE_IOERR_CHECKRESERVEDLOCK, sQLITE_IOERR_LOCK, + sQLITE_IOERR_CLOSE, sQLITE_IOERR_DIR_CLOSE, + sQLITE_IOERR_SHMOPEN, sQLITE_IOERR_SHMSIZE, sQLITE_IOERR_SHMLOCK, + sQLITE_IOERR_SHMMAP, + sQLITE_IOERR_SEEK, sQLITE_IOERR_DELETE_NOENT, sQLITE_IOERR_MMAP, + sQLITE_IOERR_GETTEMPPATH, sQLITE_IOERR_CONVPATH, + + sQLITE_CORRUPT_PLAIN, sQLITE_CORRUPT_VTAB, + + sQLITE_NOTFOUND, + sQLITE_FULL, + + sQLITE_CANTOPEN_PLAIN, sQLITE_CANTOPEN_NOTEMPDIR, sQLITE_CANTOPEN_ISDIR, + sQLITE_CANTOPEN_FULLPATH, sQLITE_CANTOPEN_CONVPATH, + + sQLITE_PROTOCOL, sQLITE_EMPTY, sQLITE_SCHEMA, sQLITE_TOOBIG, + + sQLITE_CONSTRAINT_PLAIN, sQLITE_CONSTRAINT_CHECK, + sQLITE_CONSTRAINT_COMMITHOOK, sQLITE_CONSTRAINT_FOREIGNKEY, + sQLITE_CONSTRAINT_FUNCTION, sQLITE_CONSTRAINT_NOTNULL, + sQLITE_CONSTRAINT_PRIMARYKEY, sQLITE_CONSTRAINT_TRIGGER, + sQLITE_CONSTRAINT_UNIQUE, sQLITE_CONSTRAINT_VTAB, + sQLITE_CONSTRAINT_ROWID, + + sQLITE_MISMATCH, sQLITE_MISUSE, sQLITE_NOLFS, + + sQLITE_AUTH_PLAIN, sQLITE_AUTH_USER, + + sQLITE_FORMAT, sQLITE_RANGE, sQLITE_NOTADB, + + sQLITE_NOTICE_PLAIN, sQLITE_NOTICE_RECOVER_WAL, + sQLITE_NOTICE_RECOVER_ROLLBACK, + + sQLITE_WARNING_PLAIN, sQLITE_WARNING_AUTOINDEX ) where import Foreign.C.Types -sQLITE_OK, sQLITE_ERROR, sQLITE_BUSY, sQLITE_ROW, sQLITE_DONE :: CInt +sQLITE_OK, sQLITE_ROW, sQLITE_DONE :: CInt sQLITE_OK = #const SQLITE_OK -sQLITE_ERROR = #const SQLITE_ERROR -sQLITE_BUSY = #const SQLITE_BUSY sQLITE_ROW = #const SQLITE_ROW sQLITE_DONE = #const SQLITE_DONE + +sQLITE_ERROR, sQLITE_INTERNAL, sQLITE_PERM :: CInt + +sQLITE_ERROR = #const SQLITE_ERROR +sQLITE_INTERNAL = #const SQLITE_INTERNAL +sQLITE_PERM = #const SQLITE_PERM + +sQLITE_ABORT_PLAIN, sQLITE_ABORT_ROLLBACK :: CInt +sQLITE_ABORT_PLAIN = #const SQLITE_ABORT +sQLITE_ABORT_ROLLBACK = #const SQLITE_ABORT_ROLLBACK + +sQLITE_BUSY_PLAIN, sQLITE_BUSY_RECOVERY, sQLITE_BUSY_SNAPSHOT :: CInt +sQLITE_BUSY_PLAIN = #const SQLITE_BUSY +sQLITE_BUSY_RECOVERY = #const SQLITE_BUSY_RECOVERY +sQLITE_BUSY_SNAPSHOT = #const SQLITE_BUSY_SNAPSHOT + +sQLITE_LOCKED_PLAIN, sQLITE_LOCKED_SHAREDCACHE :: CInt +sQLITE_LOCKED_PLAIN = #const SQLITE_LOCKED +sQLITE_LOCKED_SHAREDCACHE = #const SQLITE_LOCKED_SHAREDCACHE + +sQLITE_NOMEM :: CInt +sQLITE_NOMEM = #const SQLITE_NOMEM + +sQLITE_READONLY_PLAIN, sQLITE_READONLY_RECOVERY, sQLITE_READONLY_CANTLOCK, + sQLITE_READONLY_ROLLBACK, sQLITE_READONLY_DBMOVED + :: CInt +sQLITE_READONLY_PLAIN = #const SQLITE_READONLY +sQLITE_READONLY_RECOVERY = #const SQLITE_READONLY_RECOVERY +sQLITE_READONLY_CANTLOCK = #const SQLITE_READONLY_CANTLOCK +sQLITE_READONLY_ROLLBACK = #const SQLITE_READONLY_ROLLBACK +sQLITE_READONLY_DBMOVED = #const SQLITE_READONLY_DBMOVED + +sQLITE_INTERRUPT :: CInt +sQLITE_INTERRUPT = #const SQLITE_INTERRUPT + +sQLITE_IOERR_PLAIN, sQLITE_IOERR_READ, sQLITE_IOERR_SHORT_READ, + sQLITE_IOERR_WRITE, sQLITE_IOERR_FSYNC, sQLITE_IOERR_DIR_FSYNC, + sQLITE_IOERR_TRUNCATE, sQLITE_IOERR_FSTAT, sQLITE_IOERR_UNLOCK, + sQLITE_IOERR_RDLOCK, sQLITE_IOERR_DELETE, sQLITE_IOERR_BLOCKED, + sQLITE_IOERR_NOMEM, sQLITE_IOERR_ACCESS, sQLITE_IOERR_CHECKRESERVEDLOCK, + sQLITE_IOERR_LOCK, sQLITE_IOERR_CLOSE, sQLITE_IOERR_DIR_CLOSE, + sQLITE_IOERR_SHMOPEN, sQLITE_IOERR_SHMSIZE, sQLITE_IOERR_SHMLOCK, + sQLITE_IOERR_SHMMAP, sQLITE_IOERR_SEEK, sQLITE_IOERR_DELETE_NOENT, + sQLITE_IOERR_MMAP, sQLITE_IOERR_GETTEMPPATH, sQLITE_IOERR_CONVPATH + :: CInt +sQLITE_IOERR_PLAIN = #const SQLITE_IOERR +sQLITE_IOERR_READ = #const SQLITE_IOERR_READ +sQLITE_IOERR_SHORT_READ = #const SQLITE_IOERR_SHORT_READ +sQLITE_IOERR_WRITE = #const SQLITE_IOERR_WRITE +sQLITE_IOERR_FSYNC = #const SQLITE_IOERR_FSYNC +sQLITE_IOERR_DIR_FSYNC = #const SQLITE_IOERR_DIR_FSYNC +sQLITE_IOERR_TRUNCATE = #const SQLITE_IOERR_TRUNCATE +sQLITE_IOERR_FSTAT = #const SQLITE_IOERR_FSTAT +sQLITE_IOERR_UNLOCK = #const SQLITE_IOERR_UNLOCK +sQLITE_IOERR_RDLOCK = #const SQLITE_IOERR_RDLOCK +sQLITE_IOERR_DELETE = #const SQLITE_IOERR_DELETE +sQLITE_IOERR_BLOCKED = #const SQLITE_IOERR_BLOCKED +sQLITE_IOERR_NOMEM = #const SQLITE_IOERR_NOMEM +sQLITE_IOERR_ACCESS = #const SQLITE_IOERR_ACCESS +sQLITE_IOERR_CHECKRESERVEDLOCK = #const SQLITE_IOERR_CHECKRESERVEDLOCK +sQLITE_IOERR_LOCK = #const SQLITE_IOERR_LOCK +sQLITE_IOERR_CLOSE = #const SQLITE_IOERR_CLOSE +sQLITE_IOERR_DIR_CLOSE = #const SQLITE_IOERR_DIR_CLOSE +sQLITE_IOERR_SHMOPEN = #const SQLITE_IOERR_SHMOPEN +sQLITE_IOERR_SHMSIZE = #const SQLITE_IOERR_SHMSIZE +sQLITE_IOERR_SHMLOCK = #const SQLITE_IOERR_SHMLOCK +sQLITE_IOERR_SHMMAP = #const SQLITE_IOERR_SHMMAP +sQLITE_IOERR_SEEK = #const SQLITE_IOERR_SEEK +sQLITE_IOERR_DELETE_NOENT = #const SQLITE_IOERR_DELETE_NOENT +sQLITE_IOERR_MMAP = #const SQLITE_IOERR_MMAP +sQLITE_IOERR_GETTEMPPATH = #const SQLITE_IOERR_GETTEMPPATH +sQLITE_IOERR_CONVPATH = #const SQLITE_IOERR_CONVPATH +-- sQLITE_IOERR_VNODE = #const SQLITE_IOERR_VNODE + +sQLITE_CORRUPT_PLAIN, sQLITE_CORRUPT_VTAB :: CInt +sQLITE_CORRUPT_PLAIN = #const SQLITE_CORRUPT +sQLITE_CORRUPT_VTAB = #const SQLITE_CORRUPT_VTAB + +sQLITE_NOTFOUND, sQLITE_FULL :: CInt +sQLITE_NOTFOUND = #const SQLITE_NOTFOUND +sQLITE_FULL = #const SQLITE_FULL + +sQLITE_CANTOPEN_PLAIN, sQLITE_CANTOPEN_NOTEMPDIR, sQLITE_CANTOPEN_ISDIR, + sQLITE_CANTOPEN_FULLPATH, sQLITE_CANTOPEN_CONVPATH + :: CInt +sQLITE_CANTOPEN_PLAIN = #const SQLITE_CANTOPEN +sQLITE_CANTOPEN_NOTEMPDIR = #const SQLITE_CANTOPEN_NOTEMPDIR +sQLITE_CANTOPEN_ISDIR = #const SQLITE_CANTOPEN_ISDIR +sQLITE_CANTOPEN_FULLPATH = #const SQLITE_CANTOPEN_FULLPATH +sQLITE_CANTOPEN_CONVPATH = #const SQLITE_CANTOPEN_CONVPATH + +sQLITE_PROTOCOL, sQLITE_EMPTY, sQLITE_SCHEMA, sQLITE_TOOBIG :: CInt +sQLITE_PROTOCOL = #const SQLITE_PROTOCOL +sQLITE_EMPTY = #const SQLITE_EMPTY +sQLITE_SCHEMA = #const SQLITE_SCHEMA +sQLITE_TOOBIG = #const SQLITE_TOOBIG + +sQLITE_CONSTRAINT_PLAIN, sQLITE_CONSTRAINT_CHECK, + sQLITE_CONSTRAINT_COMMITHOOK, sQLITE_CONSTRAINT_FOREIGNKEY, + sQLITE_CONSTRAINT_FUNCTION, sQLITE_CONSTRAINT_NOTNULL, + sQLITE_CONSTRAINT_PRIMARYKEY, sQLITE_CONSTRAINT_TRIGGER, + sQLITE_CONSTRAINT_UNIQUE, sQLITE_CONSTRAINT_VTAB, + sQLITE_CONSTRAINT_ROWID + :: CInt +sQLITE_CONSTRAINT_PLAIN = #const SQLITE_CONSTRAINT +sQLITE_CONSTRAINT_CHECK = #const SQLITE_CONSTRAINT_CHECK +sQLITE_CONSTRAINT_COMMITHOOK = #const SQLITE_CONSTRAINT_COMMITHOOK +sQLITE_CONSTRAINT_FOREIGNKEY = #const SQLITE_CONSTRAINT_FOREIGNKEY +sQLITE_CONSTRAINT_FUNCTION = #const SQLITE_CONSTRAINT_FUNCTION +sQLITE_CONSTRAINT_NOTNULL = #const SQLITE_CONSTRAINT_NOTNULL +sQLITE_CONSTRAINT_PRIMARYKEY = #const SQLITE_CONSTRAINT_PRIMARYKEY +sQLITE_CONSTRAINT_TRIGGER = #const SQLITE_CONSTRAINT_TRIGGER +sQLITE_CONSTRAINT_UNIQUE = #const SQLITE_CONSTRAINT_UNIQUE +sQLITE_CONSTRAINT_VTAB = #const SQLITE_CONSTRAINT_VTAB +sQLITE_CONSTRAINT_ROWID = #const SQLITE_CONSTRAINT_ROWID + +sQLITE_MISMATCH, sQLITE_MISUSE, sQLITE_NOLFS :: CInt +sQLITE_MISMATCH = #const SQLITE_MISMATCH +sQLITE_MISUSE = #const SQLITE_MISUSE +sQLITE_NOLFS = #const SQLITE_NOLFS + +sQLITE_AUTH_PLAIN, sQLITE_AUTH_USER :: CInt +sQLITE_AUTH_PLAIN = #const SQLITE_AUTH +sQLITE_AUTH_USER = #const SQLITE_AUTH_USER + +sQLITE_FORMAT, sQLITE_RANGE, sQLITE_NOTADB :: CInt +sQLITE_FORMAT = #const SQLITE_FORMAT +sQLITE_RANGE = #const SQLITE_RANGE +sQLITE_NOTADB = #const SQLITE_NOTADB + +sQLITE_NOTICE_PLAIN, sQLITE_NOTICE_RECOVER_WAL, sQLITE_NOTICE_RECOVER_ROLLBACK + :: CInt +sQLITE_NOTICE_PLAIN = #const SQLITE_NOTICE +sQLITE_NOTICE_RECOVER_WAL = #const SQLITE_NOTICE_RECOVER_WAL +sQLITE_NOTICE_RECOVER_ROLLBACK = #const SQLITE_NOTICE_RECOVER_ROLLBACK + +sQLITE_WARNING_PLAIN, sQLITE_WARNING_AUTOINDEX :: CInt +sQLITE_WARNING_PLAIN = #const SQLITE_WARNING +sQLITE_WARNING_AUTOINDEX = #const SQLITE_WARNING_AUTOINDEX sQLITE_INTEGER, sQLITE_FLOAT, sQLITE_TEXT, sQLITE_BLOB, sQLITE_NULL :: CInt sQLITE_INTEGER = #const SQLITE_INTEGER diff --git a/src/Database/SmplstSQLite3/Templates.hs b/src/Database/SmplstSQLite3/Templates.hs new file mode 100644 --- /dev/null +++ b/src/Database/SmplstSQLite3/Templates.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.SmplstSQLite3.Templates (newException, mkSqliteThrow) where + +import Control.Applicative +import Control.Exception +import Data.Typeable +import Data.Char +import Language.Haskell.TH +import Foreign.C.Types + +newException :: String -> DecQ +newException e = + newtypeD (cxt []) (mkName e) [] + (normalC (mkName e) [strictType notStrict (conT ''String)]) + [''Typeable, ''Show] + +sqliteThrowType :: DecQ +sqliteThrowType = sigD (mkName "sqliteThrow") . + forallT [PlainTV $ mkName "a"] (cxt []) $ + conT ''String `arrT` conT ''CInt `arrT` + (conT ''IO `appT` varT (mkName "a")) + +mkSqliteThrow :: [Name] -> DecsQ +mkSqliteThrow nms = (:) + <$> sqliteThrowType + <*> ((: []) <$> funD (mkName "sqliteThrow") [mc nms]) + where + mc ns = clause [varP $ mkName "em", varP $ mkName "rc"] + (guardedB $ + map gd1 ns ++ [(,) <$> normalG otgd <*> otbd]) + [] + gd1 n = (,) <$> normalG (gd $ nameBase n) <*> bd n + gd n = infixE (Just . varE $ mkName "rc") (varE '(==)) + (Just . varE . mkName $ toLowerH n) + bd n = infixE (Just $ varE 'throwIO) (varE '($)) . Just $ + conE n `appE` varE (mkName "em") + otgd = varE 'otherwise + otbd = infixE (Just $ varE 'throwIO) (varE '($)) . Just $ + conE (mkName "SQLITE_ERROR_OTHER") `appE` varE (mkName "rc") `appE` varE (mkName "em") + +toLowerH :: String -> String +toLowerH (c : cs) = toLower c : cs +toLowerH _ = "" + +infixr `arrT` +arrT :: TypeQ -> TypeQ -> TypeQ +arrT t1 t2 = arrowT `appT` t1 `appT` t2