groundhog-sqlite 0.2.0 → 0.3.0

raw patch · 3 files changed

+186/−208 lines, 3 filesdep +resource-pooldep −blaze-builderdep −pool-conduitdep ~groundhogPVP ok

version bump matches the API change (PVP)

Dependencies added: resource-pool

Dependencies removed: blaze-builder, pool-conduit

Dependency ranges changed: groundhog

API changes (from Hackage documentation)

Files

• Database/Groundhog/Generic/Sql/Utf8.hs +0/−47
• Database/Groundhog/Sqlite.hs +183/−156
• groundhog-sqlite.cabal +3/−5

@@ -1,47 +0,0 @@-module Database.Groundhog.Generic.Sql.Utf8-    ( module Database.Groundhog.Generic.Sql-    , Utf8 (..)-    , fromUtf8-    ) where--import Database.Groundhog.Core-import Database.Groundhog.Generic.Sql-import Blaze.ByteString.Builder-import qualified Blaze.ByteString.Builder.Char.Utf8 as B-import Data.ByteString-import Data.Monoid-import Data.String--newtype Utf8 = Utf8 Builder--fromUtf8 :: Utf8 -> ByteString-fromUtf8 (Utf8 a) = toByteString a--instance Monoid Utf8 where-  mempty = Utf8 mempty-  mappend (Utf8 a) (Utf8 b) = Utf8 (mappend a b)--instance IsString Utf8 where-  fromString = Utf8 . B.fromString--instance StringLike Utf8 where-  fromChar = Utf8 . B.fromChar--{-# SPECIALIZE (<>) :: RenderS Utf8 -> RenderS Utf8 -> RenderS Utf8 #-}--{-# SPECIALIZE renderArith :: (PersistEntity v, Constructor c, DbDescriptor db) => Proxy db -> (Utf8 -> Utf8) -> Arith v c a -> RenderS Utf8 #-}--{-# SPECIALIZE renderCond :: (PersistEntity v, Constructor c, DbDescriptor db)-  => Proxy db-  -> (Utf8 -> Utf8)-  -> (Utf8 -> Utf8 -> Utf8)-  -> (Utf8 -> Utf8 -> Utf8)-  -> Cond v c -> Maybe (RenderS Utf8) #-}--{-# SPECIALIZE renderOrders :: (PersistEntity v, Constructor c) => (Utf8 -> Utf8) -> [Order v c] -> Utf8 #-}--{-# SPECIALIZE renderUpdates :: (PersistEntity v, Constructor c, DbDescriptor db) => Proxy db -> (Utf8 -> Utf8) -> [Update v c] -> Maybe (RenderS Utf8) #-}--{-# SPECIALIZE renderFields :: (Utf8 -> Utf8) -> [(String, DbType)] -> Utf8 #-}--{-# SPECIALIZE renderChain :: (Utf8 -> Utf8) -> FieldChain -> [Utf8] -> [Utf8] #-}

@@ -1,11 +1,11 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types, MultiParamTypeClasses #-} module Database.Groundhog.Sqlite     ( withSqlitePool     , withSqliteConn-    , runSqlitePool-    , runSqliteConn+    , runDbConn     , Sqlite     , module Database.Groundhog+    , module Database.Groundhog.Generic.Sql.Functions     ) where  import Database.Groundhog@@ -13,7 +13,8 @@ import Database.Groundhog.Generic import Database.Groundhog.Generic.Migration hiding (MigrationPack(..)) import qualified Database.Groundhog.Generic.Migration as GM-import Database.Groundhog.Generic.Sql.Utf8+import Database.Groundhog.Generic.Sql+import Database.Groundhog.Generic.Sql.Functions import qualified Database.Groundhog.Generic.PersistBackendHelpers as H  import qualified Database.Sqlite as S@@ -23,15 +24,15 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask)-import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS import Data.Char (toUpper) import Data.Function (on) import Data.Int (Int64) import Data.List (groupBy, intercalate, isInfixOf, partition, sort) import Data.IORef import qualified Data.HashMap.Strict as Map-import Data.Maybe (maybeToList)-import Data.Conduit.Pool+import Data.Maybe (fromMaybe)+import Data.Pool import qualified Data.Text as T  import GHC.Exts (inline)@@ -41,11 +42,17 @@  instance DbDescriptor Sqlite where   type AutoKeyType Sqlite = Int64+  type QueryRaw Sqlite = Snippet Sqlite+  backendName _ = "sqlite" +instance SqlDb Sqlite where+  append a b = Expr $ operator 50 "||" a b+ instance (MonadBaseControl IO m, MonadIO m) => PersistBackend (DbPersist Sqlite m) where   {-# SPECIALIZE instance PersistBackend (DbPersist Sqlite IO) #-}   type PhantomDb (DbPersist Sqlite m) = Sqlite   insert v = insert' v+  insert_ v = insert_' v   insertBy u v = H.insertBy escapeS queryRawTyped u v   insertByAll v = H.insertByAll escapeS queryRawTyped v   replace k v = H.replace escapeS queryRawTyped executeRawCached' insertIntoConstructorTable k v@@ -69,9 +76,17 @@   insertList l = insertList' l   getList k = getList' k ---{-# SPECIALIZE INLINE H.get :: (MonadBaseControl IO m, MonadIO m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a) -> Key v BackendSpecific -> DbPersist Sqlite m (Maybe v) #-}+instance (MonadBaseControl IO m, MonadIO m) => SchemaAnalyzer (DbPersist Sqlite m) where+  listTables _ = queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] (mapAllRows $ return . fst . fromPurePersistValues proxy)+  listTableTriggers _ name = queryRaw' "SELECT name FROM sqlite_master WHERE type='trigger' AND tbl_name=?" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)+  analyzeTable = analyzeTable'+  analyzeTrigger _ name = do+    x <- queryRaw' "SELECT sql FROM sqlite_master WHERE type='trigger' AND name=?" [toPrimitivePersistValue proxy name] id+    case x of+      Nothing  -> return Nothing+      Just src -> return (fst $ fromPurePersistValues proxy src)+  analyzeFunction = error "analyzeFunction: is not supported by Sqlite" ---{-# SPECIALIZE withSqlitePool :: String -> Int -> (Pool Sqlite -> IO a) -> IO a #-} withSqlitePool :: (MonadBaseControl IO m, MonadIO m)                => String                -> Int -- ^ number of connections to open@@ -87,20 +102,30 @@                -> m a withSqliteConn s = bracket (liftIO $ open' s) (liftIO . close') -{-# SPECIALIZE runSqlitePool :: DbPersist Sqlite IO a -> Pool Sqlite -> IO a #-}-runSqlitePool :: (MonadBaseControl IO m, MonadIO m) => DbPersist Sqlite m a -> Pool Sqlite -> m a-runSqlitePool f pconn = withResource pconn $ runSqliteConn f+instance Savepoint Sqlite where+  withConnSavepoint name m (Sqlite c _) = do+    let runStmt query = S.prepare c query >>= \stmt -> S.step stmt >> S.finalize stmt+    let name' = fromString name+    liftIO $ runStmt $ "SAVEPOINT " <> name'+    x <- onException m (liftIO $ runStmt $ "ROLLBACK TO " <> name')+    liftIO $ runStmt $ "RELEASE " <> name'+    return x -{-# SPECIALIZE runSqliteConn :: DbPersist Sqlite IO a -> Sqlite -> IO a #-}-{-# INLINE runSqliteConn #-}-runSqliteConn :: (MonadBaseControl IO m, MonadIO m) => DbPersist Sqlite m a -> Sqlite -> m a-runSqliteConn f conn@(Sqlite c _) = do-  let runStmt query = S.prepare c query >>= \stmt -> S.step stmt >> S.finalize stmt-  liftIO $ runStmt "BEGIN"-  x <- onException (runDbPersist f conn) (liftIO $ runStmt "ROLLBACK")-  liftIO $ runStmt "COMMIT"-  return x+instance ConnectionManager Sqlite Sqlite where+  withConn f conn@(Sqlite c _) = do+    let runStmt query = S.prepare c query >>= \stmt -> S.step stmt >> S.finalize stmt+    liftIO $ runStmt "BEGIN"+    x <- onException (f conn) (liftIO $ runStmt "ROLLBACK")+    liftIO $ runStmt "COMMIT"+    return x+  withConnNoTransaction f conn = f conn +instance ConnectionManager (Pool Sqlite) Sqlite where+  withConn f pconn = withResource pconn (withConn f)+  withConnNoTransaction f pconn = withResource pconn (withConnNoTransaction f)++instance SingleConnectionManager Sqlite Sqlite+ open' :: String -> IO Sqlite open' s = do   conn <- S.open s@@ -121,12 +146,12 @@   compareTypes   compareRefs   compareUniqs-  checkTable   migTriggerOnDelete   migTriggerOnUpdate   GM.defaultMigConstr   escape-  "INTEGER PRIMARY KEY"+  DbInt64+  "INTEGER PRIMARY KEY NOT NULL"   "INTEGER"   mainTableId   defaultPriority@@ -136,87 +161,75 @@  addUniquesReferences :: [UniqueDef'] -> [Reference] -> ([String], [AlterTable]) addUniquesReferences uniques refs = (map sqlUnique constraints ++ map sqlReference refs, map AddUnique indexes) where-  (constraints, indexes) = partition (\(UniqueDef' _ uType _) -> uType == UniqueConstraint) uniques+  (constraints, indexes) = partition ((/= UniqueIndex) . uniqueDefType) uniques --- it handles only delete operations. So far when list replace is not allowed, it is ok-migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => String -> [(String, String)] -> DbPersist Sqlite m (Bool, [AlterDB])-migTriggerOnDelete name deletes = do-  let addTrigger = AddTriggerOnDelete name name (concatMap snd deletes)-  x <- checkTrigger name+migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m (Bool, [AlterDB])+migTriggerOnDelete schema name deletes = do+  let addTrigger = AddTriggerOnDelete Nothing name Nothing name (concatMap snd deletes)+  x <- analyzeTrigger schema name   return $ case x of     Nothing | null deletes -> (False, [])     Nothing -> (False, [addTrigger])     Just sql -> (True, if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types-      then [DropTrigger name name]+      then [DropTrigger Nothing name Nothing name]       else if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger         then []         -- this can happen when an ephemeral field was added or removed.-        else [DropTrigger name name, addTrigger])+        else [DropTrigger Nothing name Nothing name, addTrigger])         --- | Table name and a  list of field names and according delete statements+-- | Schema name, table name and a list of field names and according delete statements -- assume that this function is called only for ephemeral fields-migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => String -> String -> String -> DbPersist Sqlite m (Bool, [AlterDB])-migTriggerOnUpdate name fieldName del = do+migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m [(Bool, [AlterDB])]+migTriggerOnUpdate schema name dels = forM dels $ \(fieldName, del) -> do   let trigName = name ++ delim : fieldName-  let addTrigger = AddTriggerOnUpdate trigName name fieldName del-  x <- checkTrigger trigName+  let addTrigger = AddTriggerOnUpdate Nothing trigName Nothing name (Just fieldName) del+  x <- analyzeTrigger schema trigName   return $ case x of     Nothing -> (False, [addTrigger])     Just sql -> (True, if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger         then []-        else [DropTrigger trigName name, addTrigger])-  -checkTrigger :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String)-checkTrigger = checkSqliteMaster "trigger"--checkSqliteMaster :: (MonadBaseControl IO m, MonadIO m) => String -> String -> DbPersist Sqlite m (Maybe String)-checkSqliteMaster vtype name = do-  let query = "SELECT sql FROM sqlite_master WHERE type = ? AND name = ?"-  x <- queryRawTyped query [DbString] [toPrimitivePersistValue proxy vtype, toPrimitivePersistValue proxy name] id-  let throwErr = error . ("Unexpected result from sqlite_master: " ++)-  case x of-    Nothing -> return Nothing-    Just [hsql] -> case hsql of-      PersistString sql -> return $ Just sql-      err               -> throwErr $ "column sql is not string: " ++ show err-    Just xs -> throwErr $ "requested 1 column, returned " ++ show xs+        else [DropTrigger Nothing trigName Nothing name, addTrigger]) -checkTable :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe (Either [String] TableInfo))-checkTable tableName = do+analyzeTable' :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Sqlite m (Either [String] (Maybe TableInfo))+analyzeTable' _ tName = do   let fromName = escapeS . fromString-  tableInfo <- queryRaw' ("pragma table_info(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)+  tableInfo <- queryRaw' ("pragma table_info(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)   case tableInfo of-    [] -> return Nothing-    xs -> liftM Just $ do-      let rawColumns = filter (\(_ , (_, _, _, _, isPrimary)) -> isPrimary == 0) xs+    [] -> return $ Right Nothing+    rawColumns -> do       let mkColumn :: (Int, (String, String, Int, Maybe String, Int)) -> Column           mkColumn (_, (name, typ, isNotNull, defaultValue, _)) = Column name (isNotNull == 0) (readSqlType typ) defaultValue+      let primaryKeyColumnNames = foldr (\(_ , (name, _, _, _, isPrimary)) xs -> if isPrimary == 1 then name:xs else xs) [] rawColumns       let columns = map mkColumn rawColumns-      indexList <- queryRaw' ("pragma index_list(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)+      indexList <- queryRaw' ("pragma index_list(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)       let uniqueNames = map (\(_ :: Int, name, _) -> name) $ filter (\(_, _, isUnique) -> isUnique) indexList       uniques <- forM uniqueNames $ \name -> do         uFields <- queryRaw' ("pragma index_info(" <> fromName name <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)         sql <- queryRaw' ("select sql from sqlite_master where type = 'index' and name = ?") [toPrimitivePersistValue proxy name] id-        let uType = if sql == Just [PersistNull] then UniqueConstraint else UniqueIndex-        return $ UniqueDef' name uType $ map (\(_, _, columnName) -> columnName) (uFields :: [(Int, Int, String)])-      foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)+        let columnNames = map (\(_, _, columnName) -> columnName) (uFields :: [(Int, Int, String)])+        let uType = if sql == Just [PersistNull]+              then if sort columnNames == sort primaryKeyColumnNames then UniquePrimary else UniqueConstraint+              else UniqueIndex+        return $ UniqueDef' (Just name) uType columnNames+      foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)       (foreigns :: [(Maybe String, Reference)]) <- do           let foreigns :: [[(Int, (Int, String, (String, Maybe String), (String, String, String)))]]               foreigns = groupBy ((==) `on` fst) . sort $ foreignKeyList -- sort by foreign key number and column number inside key (first and second integers)+              mkAction c = Just $ fromMaybe (error $ "unknown reference action type: " ++ c) $ readReferenceAction c           forM foreigns $ \rows -> do -            let (_, (_, foreignTable, _, _)) = head rows+            let (_, (_, foreignTable, _, (onUpdate, onDelete, _))) = head rows             refs <- forM rows $ \(_, (_, _, (child, parent), _)) -> case parent of-              Nothing -> checkPrimaryKey foreignTable >>= \x -> case x of+              Nothing -> analyzePrimaryKey foreignTable >>= \x -> case x of                 Just primaryKeyName -> return (child, primaryKeyName)-                Nothing -> error $ "checkTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names"+                Nothing -> error $ "analyzeTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names"               Just columnName -> return (child, columnName)-            return (Nothing, (foreignTable, refs))-      primaryKey <- checkPrimaryKey tableName-      return $ Right $ TableInfo primaryKey columns uniques foreigns+            return (Nothing, Reference Nothing foreignTable refs (mkAction onDelete) (mkAction onUpdate))+      let uniques' = uniques ++ if length primaryKeyColumnNames == 1 then [UniqueDef' Nothing UniquePrimary primaryKeyColumnNames] else []+      return $ Right $ Just $ TableInfo columns uniques' foreigns -checkPrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String)-checkPrimaryKey tableName = do-  tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tableName) <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)+analyzePrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String)+analyzePrimaryKey tName = do+  tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tName) <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)   let rawColumns :: [(Int, (String, String, Int, Maybe String, Int))]       rawColumns = filter (\(_ , (_, _, _, _, isPrimary)) -> isPrimary == 1) tableInfo   return $ case rawColumns of@@ -254,10 +267,10 @@ showSqlType DbDayTime = "TIMESTAMP" showSqlType DbDayTimeZoned = "TIMESTAMP WITH TIME ZONE" showSqlType DbBlob = "BLOB"-showSqlType (DbOther name) = name+showSqlType (DbOther (OtherTypeDef f)) = f showSqlType showSqlType (DbMaybe t) = showSqlType t showSqlType (DbList _ _) = showSqlType DbInt64-showSqlType (DbEntity Nothing _) = showSqlType DbInt64+showSqlType (DbEntity Nothing _ _ _) = showSqlType DbInt64 showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t  readSqlType :: String -> DbType@@ -270,26 +283,12 @@ readSqlType "TIMESTAMP" = DbDayTime readSqlType "TIMESTAMP WITH TIME ZONE" = DbDayTimeZoned readSqlType "BLOB" = DbBlob-readSqlType typ = DbOther typ+readSqlType typ = DbOther $ OtherTypeDef $ const typ  data Affinity = TEXT | NUMERIC | INTEGER | REAL | NONE deriving (Eq, Show)  dbTypeAffinity :: DbType -> Affinity-dbTypeAffinity DbString = TEXT-dbTypeAffinity DbInt32 = INTEGER-dbTypeAffinity DbInt64 = INTEGER-dbTypeAffinity DbReal = REAL-dbTypeAffinity DbBool = NUMERIC-dbTypeAffinity DbDay = NUMERIC-dbTypeAffinity DbTime = NUMERIC-dbTypeAffinity DbDayTime = NUMERIC-dbTypeAffinity DbDayTimeZoned = NUMERIC-dbTypeAffinity DbBlob = NONE-dbTypeAffinity (DbOther name) = readSqlTypeAffinity name-dbTypeAffinity (DbMaybe t) = dbTypeAffinity t-dbTypeAffinity (DbList _ _) = INTEGER-dbTypeAffinity (DbEntity Nothing _) = INTEGER-dbTypeAffinity t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t+dbTypeAffinity = readSqlTypeAffinity . showSqlType  readSqlTypeAffinity :: String -> Affinity readSqlTypeAffinity typ = affinity where@@ -308,18 +307,23 @@            else ""  sqlReference :: Reference -> String-sqlReference (tname, columns) = "FOREIGN KEY(" ++ our ++ ") REFERENCES " ++ escape tname ++ "(" ++ foreign ++ ")" where-  (our, foreign) = f *** f $ unzip columns+sqlReference Reference{..} = "FOREIGN KEY(" ++ our ++ ") REFERENCES " ++ escape referencedTableName ++ "(" ++ foreign ++ ")" ++ actions where+  actions = maybe "" ((" ON DELETE " ++) . showReferenceAction) referenceOnDelete+         ++ maybe "" ((" ON UPDATE " ++) . showReferenceAction) referenceOnUpdate+  (our, foreign) = f *** f $ unzip referencedColumns   f = intercalate ", " . map escape  sqlUnique :: UniqueDef' -> String-sqlUnique (UniqueDef' name _ cols) = concat-    [ "CONSTRAINT "-    , escape name-    , " UNIQUE ("-    , intercalate "," $ map escape cols-    , ")"-    ]+sqlUnique (UniqueDef' name typ cols) = concat [+    maybe "" ((" CONSTRAINT " ++) . escape) name+  , constraintType+  , intercalate "," $ map escape cols+  , ")"+  ] where+    constraintType = case typ of+      UniquePrimary -> " PRIMARY KEY("+      UniqueConstraint -> " UNIQUE("+      UniqueIndex -> error "sqlUnique: does not handle indexes"  {-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Sqlite IO (AutoKey v) #-} insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Sqlite m (AutoKey v)@@ -327,35 +331,55 @@   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v   let e = entityDef v-  let name = persistName v   let constructorNum = fromPrimitivePersistValue proxy (head vals)    liftM fst $ if isSimple (constructors e)     then do       let constr = head $ constructors e-      let query = insertIntoConstructorTable False name constr-      executeRawCached' query (tail vals)+      let RenderS query vals' = insertIntoConstructorTable False (tableName escapeS e constr) constr (tail vals)+      executeRawCached' query (vals' [])       case constrAutoKeyName constr of         Nothing -> pureFromPersistValue []         Just _  -> getLastInsertRowId >>= \rowid -> pureFromPersistValue [rowid]     else do       let constr = constructors e !! constructorNum-      let cName = name ++ [delim] ++ constrName constr-      let query = "INSERT INTO " <> escapeS (fromString name) <> "(discr)VALUES(?)"+      let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)"       executeRawCached' query $ take 1 vals       rowid <- getLastInsertRowId-      let cQuery = insertIntoConstructorTable True cName constr-      executeRawCached' cQuery $ rowid:(tail vals)+      let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid:tail vals)+      executeRawCached' cQuery (vals' [])       pureFromPersistValue [rowid] +{-# SPECIALIZE insert_' :: PersistEntity v => v -> DbPersist Sqlite IO () #-}+insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Sqlite m ()+insert_' v = do+  -- constructor number and the rest of the field values+  vals <- toEntityPersistValues' v+  let e = entityDef v+  let constructorNum = fromPrimitivePersistValue proxy (head vals)++  if isSimple (constructors e)+    then do+      let constr = head $ constructors e+      let RenderS query vals' = insertIntoConstructorTable False (tableName escapeS e constr) constr (tail vals)+      executeRawCached' query (vals' [])+    else do+      let constr = constructors e !! constructorNum+      let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)"+      executeRawCached' query $ take 1 vals+      rowid <- getLastInsertRowId+      let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid:tail vals)+      executeRawCached' cQuery (vals' [])+ -- TODO: In Sqlite we can insert null to the id column. If so, id will be generated automatically. Check performance change from this.-insertIntoConstructorTable :: Bool -> String -> ConstructorDef -> Utf8-insertIntoConstructorTable withId tName c = "INSERT INTO " <> escapeS (fromString tName) <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")" where+insertIntoConstructorTable :: Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r+insertIntoConstructorTable withId tName c vals = RenderS query vals' where+  query = "INSERT INTO " <> tName <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")"   fields = case constrAutoKeyName c of     Just idName | withId -> (idName, dbType (0 :: Int64)):constrParams c     _                    -> constrParams c   fieldNames   = renderFields escapeS fields-  placeholders = renderFields (const $ fromChar '?') fields+  RenderS placeholders vals' = commasJoin $ map renderPersistValue vals  insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist Sqlite m Int64 insertList' l = do@@ -398,16 +422,17 @@   go _ [] = return ()   go i (x:xs) = do     case x of-      PersistInt64 int64     -> S.bindInt64 stmt i int64-      PersistString text     -> S.bindText stmt i $ T.pack text-      PersistDouble double   -> S.bindDouble stmt i double-      PersistBool b          -> S.bindInt64 stmt i $ if b then 1 else 0-      PersistByteString blob -> S.bindBlob stmt i blob-      PersistNull            -> S.bindNull stmt i-      PersistDay d           -> S.bindText stmt i $ T.pack $ show d-      PersistTimeOfDay d     -> S.bindText stmt i $ T.pack $ show d-      PersistUTCTime d       -> S.bindText stmt i $ T.pack $ show d-      PersistZonedTime (ZT d)-> S.bindText stmt i $ T.pack $ show d+      PersistInt64 int64      -> S.bindInt64 stmt i int64+      PersistString text      -> S.bindText stmt i $ T.pack text+      PersistDouble double    -> S.bindDouble stmt i double+      PersistBool b           -> S.bindInt64 stmt i $ if b then 1 else 0+      PersistByteString blob  -> S.bindBlob stmt i blob+      PersistNull             -> S.bindNull stmt i+      PersistDay d            -> S.bindText stmt i $ T.pack $ show d+      PersistTimeOfDay d      -> S.bindText stmt i $ T.pack $ show d+      PersistUTCTime d        -> S.bindText stmt i $ T.pack $ show d+      PersistZonedTime (ZT d) -> S.bindText stmt i $ T.pack $ show d+      PersistCustom _ _       -> error "bind: unexpected PersistCustom"     go (i + 1) xs  executeRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m ()@@ -475,13 +500,13 @@ typeToSqlite (DbOther _) = Nothing typeToSqlite (DbMaybe _) = Nothing typeToSqlite (DbList _ _) = Just S.IntegerColumn-typeToSqlite (DbEntity Nothing _) = Just S.IntegerColumn+typeToSqlite (DbEntity Nothing _ _ _) = Just S.IntegerColumn typeToSqlite t = error $ "typeToSqlite: DbType does not have corresponding database type: " ++ show t  getDbTypes :: DbType -> [DbType] -> [DbType] getDbTypes typ acc = case typ of   DbEmbedded (EmbeddedDef _ ts) -> foldr (getDbTypes . snd) acc ts-  DbEntity (Just (EmbeddedDef _ ts, _)) _ -> foldr (getDbTypes . snd) acc ts+  DbEntity (Just (EmbeddedDef _ ts, _)) _ _ _ -> foldr (getDbTypes . snd) acc ts   t               -> t:acc  pFromSql :: S.SQLData -> PersistValue@@ -498,15 +523,13 @@ escapeS :: Utf8 -> Utf8 escapeS a = let q = fromChar '"' in q <> a <> q -renderCond' :: (PersistEntity v, Constructor c) => Cond v c -> Maybe (RenderS Utf8)-renderCond' = renderCond proxy escapeS renderEquals renderNotEquals where+renderCond' :: Cond Sqlite r -> Maybe (RenderS Sqlite r)+renderCond' = renderCond escapeS renderEquals renderNotEquals where   renderEquals a b = a <> " IS " <> b   renderNotEquals a b = a <> " IS NOT " <> b -defaultPriority :: Int+defaultPriority, triggerPriority :: Int defaultPriority = 0--triggerPriority :: Int triggerPriority = 1  proxy :: Proxy Sqlite@@ -519,10 +542,17 @@ toEntityPersistValues' = liftM ($ []) . toEntityPersistValues  compareUniqs :: UniqueDef' -> UniqueDef' -> Bool+compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2+-- only one of the uniques is primary+compareUniqs (UniqueDef' _ type1 _) (UniqueDef' _ type2 _) | UniquePrimary `elem` [type1, type2] = False compareUniqs (UniqueDef' _ type1 cols1) (UniqueDef' _ type2 cols2) = haveSameElems (==) cols1 cols2 && type1 == type2  compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool-compareRefs (_, (tbl1, pairs1)) (_, (tbl2, pairs2)) = unescape tbl1 == unescape tbl2 && haveSameElems (==) pairs1 pairs2 where+compareRefs (_, Reference _ tbl1 pairs1 onDel1 onUpd1) (_, Reference _ tbl2 pairs2 onDel2 onUpd2) =+     unescape tbl1 == unescape tbl2+  && haveSameElems (==) pairs1 pairs2+  && fromMaybe NoAction onDel1 == fromMaybe NoAction onDel2+  && fromMaybe NoAction onUpd1 == fromMaybe NoAction onUpd2 where   unescape name = if head name == '"' && last name == '"' then tail $ init name else name  compareTypes :: DbType -> DbType -> Bool@@ -534,7 +564,7 @@  showAlterDb :: AlterDB -> SingleMigration showAlterDb (AddTable s) = Right [(False, defaultPriority, s)]-showAlterDb (AlterTable table createTable (TableInfo oldId oldCols _ _) (TableInfo newId newCols _ _) alts) = case mapM (showAlterTable table) alts of+showAlterDb (AlterTable _ table createTable (TableInfo oldCols _ _) (TableInfo newCols _ _) alts) = case mapM (showAlterTable table) alts of   Just alts' -> Right alts'   Nothing -> (Right     [ (False, defaultPriority, "CREATE TEMP TABLE " ++ escape tableTmp ++ "(" ++ columnsTmp ++ ")")@@ -547,20 +577,37 @@       tableTmp = table ++ "_backup"       copy (from, fromCols) (to, toCols) = "INSERT INTO " ++ escape to ++ "(" ++ toCols ++ ") SELECT " ++ fromCols ++ " FROM " ++ escape from       (oldOnlyColumns, _, commonColumns) = matchElements ((==) `on` colName) oldCols newCols-      columnsTmp = intercalate "," $ map escape $ maybeToList (newId >> oldId) ++ map (colName . snd) commonColumns-      columnsNew = intercalate "," $ map escape $ maybeToList (oldId >> newId) ++ map (colName . snd) commonColumns-showAlterDb (DropTrigger name _) = Right [(False, triggerPriority, "DROP TRIGGER " ++ escape name)]-showAlterDb (AddTriggerOnDelete trigName tableName body) = Right [(False, triggerPriority,-  "CREATE TRIGGER " ++ escape trigName ++ " DELETE ON " ++ escape tableName ++ " BEGIN " ++ body ++ "END")]-showAlterDb (AddTriggerOnUpdate trigName tableName fieldName body) = Right [(False, triggerPriority,-  "CREATE TRIGGER " ++ escape trigName ++ " UPDATE OF " ++ escape fieldName ++ " ON " ++ escape tableName ++ " BEGIN " ++ body ++ "END")]+      columnsTmp = intercalate "," $ map (escape . colName . snd) commonColumns+      columnsNew = intercalate "," $ map (escape . colName . snd) commonColumns+showAlterDb (DropTrigger _ name _ _) = Right [(False, triggerPriority, "DROP TRIGGER " ++ escape name)]+showAlterDb (AddTriggerOnDelete _ trigName _ tName body) = Right [(False, triggerPriority,+  "CREATE TRIGGER " ++ escape trigName ++ " DELETE ON " ++ escape tName ++ " BEGIN " ++ body ++ "END")]+showAlterDb (AddTriggerOnUpdate _ trigName _ tName fieldName body) = Right [(False, triggerPriority,+  "CREATE TRIGGER " ++ escape trigName ++ " UPDATE OF " ++ fieldName' ++ " ON " ++ escape tName ++ " BEGIN " ++ body ++ "END")] where+    fieldName' = maybe (error $ "showAlterDb: AddTriggerOnUpdate does not have fieldName for trigger " ++ trigName) escape fieldName showAlterDb alt = error $ "showAlterDb: does not support " ++ show alt  showAlterTable :: String -> AlterTable -> Maybe (Bool, Int, String)-showAlterTable table (AlterColumn alt) = showAlterColumn table alt+showAlterTable table (AddColumn col) = Just (False, defaultPriority, concat+  [ "ALTER TABLE "+  , escape table+  , " ADD COLUMN "+  , showColumn col+  ])+showAlterTable table (AlterColumn col [UpdateValue s]) = Just (False, defaultPriority, concat+  [ "UPDATE "+  , escape table+  , " SET "+  , escape (colName col)+  , "="+  , s+  , " WHERE "+  , escape (colName col)+  , " IS NULL"+  ]) showAlterTable table (AddUnique (UniqueDef' uName UniqueIndex cols)) = Just (False, defaultPriority, concat   [ "CREATE UNIQUE INDEX "-  , escape uName+  , maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName   , " ON "   , escape table   , "("@@ -572,23 +619,3 @@   , escape uName   ]) showAlterTable _ _ = Nothing--showAlterColumn :: String -> AlterColumn' -> Maybe (Bool, Int, String)-showAlterColumn table (_, Add col) = Just (False, defaultPriority, concat-    [ "ALTER TABLE "-    , escape table-    , " ADD COLUMN "-    , showColumn col-    ])-showAlterColumn table (n, UpdateValue s) = Just (False, defaultPriority, concat-    [ "UPDATE "-    , escape table-    , " SET "-    , escape n-    , "="-    , s-    , " WHERE "-    , escape n-    , " IS NULL"-    ])-showAlterColumn _ _ = Nothing

@@ -1,5 +1,5 @@ name:            groundhog-sqlite-version:         0.2.0+version:         0.3.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -19,16 +19,14 @@     build-depends:   base                    >= 4         && < 5                    , bytestring              >= 0.9                    , transformers            >= 0.2.1     && < 0.4-                   , groundhog               >= 0.2.0     && < 0.3.0+                   , groundhog               >= 0.3.0     && < 0.4.0                    , monad-control           >= 0.3       && < 0.4                    , containers              >= 0.2                    , text                    >= 0.8       && < 0.12-                   , blaze-builder           >= 0.3.0.0   && < 0.4-                   , pool-conduit            >= 0.1       && < 0.2+                   , resource-pool           >= 0.2.1     && < 0.3                    , unordered-containers     exposed-modules: Database.Sqlite                      Database.Groundhog.Sqlite-    other-modules:   Database.Groundhog.Generic.Sql.Utf8     ghc-options:     -Wall -fno-warn-unused-do-bind     if flag(systemlib)         extra-libraries: sqlite3