diff --git a/Database/SQL/Types.hs b/Database/SQL/Types.hs --- a/Database/SQL/Types.hs +++ b/Database/SQL/Types.hs @@ -32,6 +32,9 @@ , SQLDrop(..) , Clause(..) + , ForeignUpdateCondition(..) + , ForeignUpdateAction(..) + , Deferment(..) , Constraint(..) , Table(..) , Column(..) @@ -62,9 +65,31 @@ | DefaultValue String | PrimaryKey Bool -- ^ Auto-increment? | ForeignKey TableName [ColumnName] + [ForeignUpdateCondition] + (Maybe Deferment) | Clustered Bool | Unique +data ForeignUpdateCondition + = OnDelete ForeignUpdateAction + | OnUpdate ForeignUpdateAction + | Match String + +data ForeignUpdateAction + = SetNull + | SetDefault + | Cascade + | Restrict + | NoAction + +data Deferment + = Deferrable + | DeferrableInitiallyDeferred + | DeferrableInitiallyImmediate + | NotDeferrable + | NotDeferrableInitiallyDeferred + | NotDeferrableInitiallyImmediate + data Constraint = TablePrimaryKey [ColumnName] | TableUnique [ColumnName] @@ -106,8 +131,6 @@ (Maybe Int){-digits after dec. point (the scale)-} | SQLFloat (Maybe Int){-total number of digits-} (Maybe Int){-digits following dec. point-} - | SQLEnum [String] - | SQLSet [String] data IntType = TINY | SMALL | MEDIUM | NORMAL | BIG @@ -163,15 +186,7 @@ case sequence [mbDig,mbScale] of Nothing -> "" Just xs -> '(':concat (intersperse "," (map show xs)) ++ ")" - SQLEnum tgs -> - "ENUM(" ++ toTags tgs ++ ")" - SQLSet tgs -> - "SET(" ++ toTags tgs ++ ")" - where - toTags xs = concat $ intersperse "," (map quote xs) - quote nm = '\'':nm ++ "'" - showClause :: Clause -> String showClause c = case c of @@ -180,11 +195,38 @@ | otherwise -> "NOT NULL" DefaultValue x -> "DEFAULT " ++ toSQLString x PrimaryKey auto -> "PRIMARY KEY" ++ if auto then " AUTOINCREMENT" else "" - ForeignKey tb cs -> "FOREIGN KEY " ++ tb ++ '(':concat (intersperse ", " cs) ++ ")" + ForeignKey tb cs fcs mdf -> + "REFERENCES " ++ tb ++ "(" ++ concat (intersperse ", " cs) ++ ")" ++ + concatMap showUpdateCondition fcs ++ showDeferment mdf Clustered flg | flg -> "CLUSTERED" | otherwise -> "NONCLUSTERED" Unique -> "UNIQUE" + where + showUpdateCondition (OnDelete a) = " ON DELETE " ++ showAction a + showUpdateCondition (OnUpdate a) = " ON UPDATE " ++ showAction a + showUpdateCondition (Match n) = " MATCH " ++ n + -- + showAction SetNull = "SET NULL" + showAction SetDefault = "SET DEFAULT" + showAction Cascade = "CASCADE" + showAction Restrict = "RESTRICT" + showAction NoAction = "NO ACTION" + -- + showDeferment Nothing = + "" + showDeferment (Just Deferrable) = + " DEFERRABLE" + showDeferment (Just DeferrableInitiallyDeferred) = + " DEFERRABLE INITIALLY DEFERRED" + showDeferment (Just DeferrableInitiallyImmediate) = + " DEFERRABLE INITIALLY IMMEDATE" + showDeferment (Just NotDeferrable) = + " NOT DEFERRABLE" + showDeferment (Just NotDeferrableInitiallyDeferred) = + " NOT DEFERRABLE INITIALLY DEFERRED" + showDeferment (Just NotDeferrableInitiallyImmediate) = + " NOT DEFERRABLE INITIALLY IMMEDIATE" toSQLString :: String -> String toSQLString "" = "" diff --git a/Database/SQLite.hs b/Database/SQLite.hs --- a/Database/SQLite.hs +++ b/Database/SQLite.hs @@ -19,7 +19,6 @@ -- -- * -- - module Database.SQLite ( module Database.SQLite.Base , module Database.SQLite.Types @@ -63,7 +62,6 @@ import Foreign.Marshal import Foreign.C -import Foreign.C.String (newCStringLen, peekCString) import Foreign.Storable import qualified Foreign.Concurrent as Conc import Foreign.Ptr @@ -71,7 +69,6 @@ import Foreign.ForeignPtr import Data.List import Data.Int -import Data.Char ( isDigit ) import Data.ByteString (ByteString, packCStringLen, useAsCStringLen) import Data.ByteString.Unsafe (unsafePackCStringLen, unsafeUseAsCStringLen) import Control.Monad ((<=<),when) @@ -152,11 +149,15 @@ toVal f p = f p -- ($ f) quote "" = "''" - quote nm@(x:_) - | isDigit x = nm + quote nm + | isNumber nm = nm | otherwise = '\'':toSQLString nm ++ "'" + isNumber x = case reads x of + [(_ :: Float, "")] -> True + _ -> False + -- | Return the rowid (as an Integer) of the most recent -- successful INSERT into the database. -- @@ -266,7 +267,7 @@ then_finalize db m stmt = do e <- m - sqlite3_finalize stmt + _ <- sqlite3_finalize stmt case e of Left _ -> to_error db Right r -> return (Right r) @@ -353,9 +354,9 @@ addRegexpSupport h f = withCString "REGEXP" $ \ zFunctionName -> do xFunc <- mkStepHandler $ regexp_callback f - withPrim h $ \ db -> - sqlite3_create_function db zFunctionName 2 sQLITE_UTF8 nullPtr - xFunc noCallback noCallback + _ <- withPrim h $ \ db -> + sqlite3_create_function db zFunctionName 2 sQLITE_UTF8 nullPtr + xFunc noCallback noCallback addSQLiteHandleFinalizer h (freeCallback xFunc) -- | Internal function to marshall the C types into Haskell types to @@ -497,17 +498,17 @@ createFunctionPrim :: SQLiteHandle -> FunctionName -> Arity -> FunctionHandler -> IO () createFunctionPrim h name arity f = do xFunc <- mkStepHandler $ function_callback f - withPrim h $ \db -> do - withCString name $ \zFunctionName -> do - sqlite3_create_function - db - zFunctionName - (toEnum arity) - sQLITE_UTF8 - nullPtr - xFunc - noCallback - noCallback + _ <- withPrim h $ \db -> do + withCString name $ \zFunctionName -> do + sqlite3_create_function + db + zFunctionName + (toEnum arity) + sQLITE_UTF8 + nullPtr + xFunc + noCallback + noCallback addSQLiteHandleFinalizer h (freeCallback xFunc) finalize_callback :: IsValue v => a -> (a -> IO v) -> FinalizeContextHandler @@ -545,17 +546,17 @@ createAggregatePrim h name arity step x finalize = do stepFunc <- mkStepHandler $ step_callback x step finalizeFunc <- mkFinalizeContextHandler $ finalize_callback x finalize - withPrim h $ \db -> do - withCString name $ \zFunctionName -> do - sqlite3_create_function - db - zFunctionName - (toEnum arity) - sQLITE_UTF8 - nullPtr - noCallback - stepFunc - finalizeFunc + _ <- withPrim h $ \db -> do + withCString name $ \zFunctionName -> do + sqlite3_create_function + db + zFunctionName + (toEnum arity) + sQLITE_UTF8 + nullPtr + noCallback + stepFunc + finalizeFunc addSQLiteHandleFinalizer h (freeCallback stepFunc) addSQLiteHandleFinalizer h (freeCallback finalizeFunc) diff --git a/Database/SQLite/Base.hs b/Database/SQLite/Base.hs --- a/Database/SQLite/Base.hs +++ b/Database/SQLite/Base.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-dodgy-foreign-imports #-} -------------------------------------------------------------------- -- | -- Module : Database.SQLite.Base diff --git a/sqlite.cabal b/sqlite.cabal --- a/sqlite.cabal +++ b/sqlite.cabal @@ -1,5 +1,5 @@ Name: sqlite -Version: 0.4.2.1 +Version: 0.5 Synopsis: Haskell binding to sqlite3 Description: Haskell binding to sqlite3 . @@ -28,14 +28,14 @@ sqlite.buildinfo flag builtin-sqlite3 - default: True + default: False description: Compile sqlite3 as a part of the library. library Build-depends: base >= 3 && < 5, pretty, utf8-string, bytestring, time, directory Extensions: ForeignFunctionInterface, GeneralizedNewtypeDeriving, - TypeSynonymInstances, + TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, UndecidableInstances, OverlappingInstances, IncoherentInstances Ghc-options: -Wall Cc-options: -Wall -DSQLITE_ENABLE_FTS3=1 -O3 -DNDEBUG=1 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -32,19 +32,30 @@ (\ err -> putStrLn ("Error (but ignoring) -- " ++ show err) >> return ()) h <- openConnection dbFile ign $ defineTable h (newTable "names") + -- ign $ insertRow h "Poststed" [("Postnr", "4278"),("Poststed", "Veakrossen")] ls <- execStatement h "SELECT * FROM Poststed WHERE PostNr=4276;" print (ls :: Either String [[Row Value]]) + -- + ign $ insertRow h "names" [("id", "2357"), ("name", "1,5m bis 3,0m"), ("age","35")] + -- This test a bug reported by Nikolas Mayr + ls <- execStatement h "SELECT * FROM names WHERE id=2357;" + print (ls :: Either String [[Row Value]]) + -- ign $ insertRow h "names" [("id", "1"),("name", "foo"), ("age", "30")] ls <- execStatement h "SELECT * FROM names;" print (ls :: Either String [[Row String]]) + -- ls <- execStatement h "SELECT * FROM names where id=1;" print (ls :: Either String [[Row String]]) + -- createFunction h "hi" (sum :: [Int] -> Int) ls <- execStatement h "SELECT hi(1,2,3,4,5) AS greeting" print (ls :: Either String [[Row String]]) + -- createFunction h "say" putStrLn ls <- execStatement h "SELECT say('Hi') AS greeting" print (ls :: Either String [[Row String]]) + -- closeConnection h