beam-sqlite 0.4.0.0 → 0.5.0.0

raw patch · 10 files changed

+437/−57 lines, 10 filesdep +beam-sqlitedep +tastydep +tasty-expected-failuredep ~basedep ~beam-coredep ~beam-migratePVP ok

version bump matches the API change (PVP)

Dependencies added: beam-sqlite, tasty, tasty-expected-failure, tasty-hunit

Dependency ranges changed: base, beam-core, beam-migrate, hashable, sqlite-simple, text, time

API changes (from Hackage documentation)

Files

• ChangeLog.md +21/−0
• Database/Beam/Sqlite/Connection.hs +133/−20
• Database/Beam/Sqlite/Migrate.hs +8/−4
• Database/Beam/Sqlite/Syntax.hs +43/−22
• README.md +1/−1
• beam-sqlite.cabal +44/−10
• test/Database/Beam/Sqlite/Test.hs +9/−0
• test/Database/Beam/Sqlite/Test/Migrate.hs +74/−0
• test/Database/Beam/Sqlite/Test/Select.hs +92/−0
• test/Main.hs +12/−0

@@ -1,3 +1,24 @@+# 0.5.0.0++=======+## Interface changes++ * Removed instances for machine-dependent ambiguous integer types `Int` and `Word`++## Added features++ * Support for `in_` on row values+ * Upsert support using `HasInsertOnConflict`+ * Fix build on Android and OpenBSD++## Bug fixes++ * Fix emitting and detection of `DECIMAL` and `DOUBLE PRECISION` types+ * Fix `bitLength`, `charLength_`, and `octectLength_` by emulating with `CAST` and `LENGTH`+ * Fix `runInsertReturningList` for when the database column order and beam column order disagree.++# 0.4.0.0+ # 0.3.2.0  Add `Semigroup` instances to prepare for GHC 8.4 and Stackage nightly

@@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -15,22 +16,32 @@   , insertReturning, runInsertReturningList   ) where +import           Prelude hiding (fail)+ import           Database.Beam.Backend+import           Database.Beam.Backend.Internal.Compat import qualified Database.Beam.Backend.SQL.BeamExtensions as Beam import           Database.Beam.Backend.URI import           Database.Beam.Migrate.Generics import           Database.Beam.Migrate.SQL ( BeamMigrateOnlySqlBackend, FieldReturnType(..) ) import qualified Database.Beam.Migrate.SQL as Beam import           Database.Beam.Migrate.SQL.BeamExtensions-import           Database.Beam.Query ( QExpr, SqlInsert(..), SqlInsertValues(..)+import           Database.Beam.Query ( SqlInsert(..), SqlInsertValues(..)                                      , HasQBuilder(..), HasSqlEqualityCheck                                      , HasSqlQuantifiedEqualityCheck                                      , DataType(..)-                                     , insert )+                                     , HasSqlInTable(..)+                                     , insert, current_ )+import           Database.Beam.Query.Internal import           Database.Beam.Query.SQL92 import           Database.Beam.Schema.Tables ( Beamable+                                             , Columnar'(..)                                              , DatabaseEntity(..)-                                             , TableEntity)+                                             , DatabaseEntityDescriptor(..)+                                             , TableEntity+                                             , TableField(..)+                                             , allBeamValues+                                             , changeBeamRep ) import           Database.Beam.Sqlite.Syntax  import           Database.SQLite.Simple ( Connection, ToRow(..), FromRow(..)@@ -46,13 +57,14 @@  import           Control.Exception (SomeException(..), bracket_, onException, mask) import           Control.Monad (forM_)-import           Control.Monad.Fail (MonadFail)+import           Control.Monad.Fail (MonadFail(..)) import           Control.Monad.Free.Church import           Control.Monad.IO.Class (MonadIO(..)) import           Control.Monad.Identity (Identity) import           Control.Monad.Reader (ReaderT(..), MonadReader(..), runReaderT) import           Control.Monad.State.Strict (MonadState(..), StateT(..), runStateT) import           Control.Monad.Trans (lift)+import           Control.Monad.Writer (tell, execWriter)  import           Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as BS@@ -66,13 +78,12 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T (decodeUtf8) import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL (decodeUtf8) import           Data.Time ( LocalTime, UTCTime, Day                            , ZonedTime, utc, utcToLocalTime ) import           Data.Typeable (cast) import           Data.Word-#if !MIN_VERSION_base(4,11,0)-import           Data.Semigroup-#endif+import           GHC.TypeLits  import           Network.URI @@ -88,7 +99,7 @@  -- | The SQLite backend. Used to parameterize 'MonadBeam' and 'FromBackendRow' -- to provide support for SQLite databases. See the documentation for--- 'MonadBeam' and the <https://tathougies.github.io/beam/ user guide> for more+-- 'MonadBeam' and the <https://haskell-beam.github.io/beam/ user guide> for more -- information on how to use this backend. data Sqlite = Sqlite @@ -98,19 +109,24 @@ instance HasQBuilder Sqlite where   buildSqlQuery = buildSql92Query' False -- SQLite does not support arbitrarily nesting UNION, INTERSECT, and EXCEPT +instance HasSqlInTable Sqlite where+  inRowValuesE Proxy e es = SqliteExpressionSyntax $ mconcat+    [ parens $ fromSqliteExpression e+    , emit " IN "+    , parens $ emit "VALUES " <> commas (map fromSqliteExpression es)+    ]+ instance BeamSqlBackendIsString Sqlite T.Text instance BeamSqlBackendIsString Sqlite String  instance FromBackendRow Sqlite Bool instance FromBackendRow Sqlite Double instance FromBackendRow Sqlite Float-instance FromBackendRow Sqlite Int instance FromBackendRow Sqlite Int8 instance FromBackendRow Sqlite Int16 instance FromBackendRow Sqlite Int32 instance FromBackendRow Sqlite Int64 instance FromBackendRow Sqlite Integer-instance FromBackendRow Sqlite Word instance FromBackendRow Sqlite Word8 instance FromBackendRow Sqlite Word16 instance FromBackendRow Sqlite Word32@@ -137,6 +153,9 @@   fromBackendRow = unSqliteScientific <$> fromBackendRow instance FromBackendRow Sqlite SqliteScientific +instance TypeError (PreferExplicitSize Int Int32) => FromBackendRow Sqlite Int+instance TypeError (PreferExplicitSize Word Word32) => FromBackendRow Sqlite Word+ newtype SqliteScientific = SqliteScientific { unSqliteScientific :: Scientific } instance FromField SqliteScientific where   fromField f =@@ -168,7 +187,7 @@   genericSerial nm = Beam.field nm (DataType sqliteSerialType) SqliteHasDefault  -- | 'MonadBeam' instance inside whiche SQLite queries are run. See the--- <https://tathougies.github.io/beam/ user guide> for more information+-- <https://haskell-beam.github.io/beam/ user guide> for more information newtype SqliteM a   = SqliteM   { runSqliteM :: ReaderT (String -> IO (), Connection) IO a@@ -234,12 +253,10 @@   instance HasSqlEqualityCheck Sqlite (ty); \   instance HasSqlQuantifiedEqualityCheck Sqlite (ty); -HAS_SQLITE_EQUALITY_CHECK(Int) HAS_SQLITE_EQUALITY_CHECK(Int8) HAS_SQLITE_EQUALITY_CHECK(Int16) HAS_SQLITE_EQUALITY_CHECK(Int32) HAS_SQLITE_EQUALITY_CHECK(Int64)-HAS_SQLITE_EQUALITY_CHECK(Word) HAS_SQLITE_EQUALITY_CHECK(Word8) HAS_SQLITE_EQUALITY_CHECK(Word16) HAS_SQLITE_EQUALITY_CHECK(Word32)@@ -259,7 +276,17 @@ HAS_SQLITE_EQUALITY_CHECK(Integer) HAS_SQLITE_EQUALITY_CHECK(Scientific) -instance HasDefaultSqlDataType Sqlite (SqlSerial Int) where+instance TypeError (PreferExplicitSize Int Int32) => HasSqlEqualityCheck Sqlite Int+instance TypeError (PreferExplicitSize Int Int32) => HasSqlQuantifiedEqualityCheck Sqlite Int+instance TypeError (PreferExplicitSize Word Word32) => HasSqlEqualityCheck Sqlite Word+instance TypeError (PreferExplicitSize Word Word32) => HasSqlQuantifiedEqualityCheck Sqlite Word++class HasDefaultSqlDataType Sqlite a => IsSqliteSerialIntegerType a+instance IsSqliteSerialIntegerType Int32+instance IsSqliteSerialIntegerType Int64+instance TypeError (PreferExplicitSize Int Int32) => IsSqliteSerialIntegerType Int++instance IsSqliteSerialIntegerType a => HasDefaultSqlDataType Sqlite (SqlSerial a) where   defaultSqlDataType _ _ False = sqliteSerialType   defaultSqlDataType _ _ True = intType @@ -322,18 +349,18 @@   runInsertReturningList = runInsertReturningList  runSqliteInsert :: (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO ()-runSqliteInsert logger conn (SqliteInsertSyntax tbl fields vs)+runSqliteInsert logger conn (SqliteInsertSyntax tbl fields vs onConflict)     -- If all expressions are simple expressions (no default), then just    | SqliteInsertExpressions es <- vs, any (any (== SqliteExpressionDefault)) es =       forM_ es $ \row -> do         let (fields', row') = unzip $ filter ((/= SqliteExpressionDefault) . snd) $ zip fields row-            SqliteSyntax cmd vals = formatSqliteInsert tbl fields' (SqliteInsertExpressions [ row' ])+            SqliteSyntax cmd vals = formatSqliteInsertOnConflict tbl fields' (SqliteInsertExpressions [ row' ]) onConflict             cmdString = BL.unpack (toLazyByteString (withPlaceholders cmd))         logger (cmdString ++ ";\n-- With values: " ++ show (D.toList vals))         execute conn (fromString cmdString) (D.toList vals)   | otherwise = do-      let SqliteSyntax cmd vals = formatSqliteInsert tbl fields vs+      let SqliteSyntax cmd vals = formatSqliteInsertOnConflict tbl fields vs onConflict           cmdString = BL.unpack (toLazyByteString (withPlaceholders cmd))       logger (cmdString ++ ";\n-- With values: " ++ show (D.toList vals))       execute conn (fromString cmdString) (D.toList vals)@@ -350,11 +377,11 @@  -- | Runs a 'SqliteInsertReturning' statement and returns a result for each -- inserted row.-runInsertReturningList :: FromBackendRow Sqlite (table Identity)+runInsertReturningList :: (Beamable table, FromBackendRow Sqlite (table Identity))                        => SqlInsert Sqlite table                        -> SqliteM [ table Identity ] runInsertReturningList SqlInsertNoRows = pure []-runInsertReturningList (SqlInsert _ insertStmt_@(SqliteInsertSyntax nm _ _)) =+runInsertReturningList (SqlInsert tblSettings insertStmt_@(SqliteInsertSyntax nm _ _ _)) =   do (logger, conn) <- SqliteM ask      SqliteM . liftIO $ do @@ -393,6 +420,92 @@            x <- bracket_ createInsertedValuesTable dropInsertedValuesTable $                 bracket_ createInsertTrigger dropInsertTrigger $ do                 runSqliteInsert logger conn insertStmt_-                fmap (\(BeamSqliteRow r) -> r) <$> query_ conn (Query ("SELECT * FROM inserted_values_" <> processId))++                let columns = TL.toStrict $ TL.decodeUtf8 $+                              sqliteRenderSyntaxScript $ commas $+                              allBeamValues (\(Columnar' projField) -> quotedIdentifier (_fieldName projField)) $+                              tblSettings++                fmap (\(BeamSqliteRow r) -> r) <$> query_ conn (Query ("SELECT " <> columns <> " FROM inserted_values_" <> processId))            releaseSavepoint            return x++instance Beam.BeamHasInsertOnConflict Sqlite where+  newtype SqlConflictTarget Sqlite table = SqliteConflictTarget+    { unSqliteConflictTarget :: table (QExpr Sqlite QInternal) -> SqliteSyntax }+  newtype SqlConflictAction Sqlite table = SqliteConflictAction+    { unSqliteConflictAction :: forall s. table (QField s) -> SqliteSyntax }++  insertOnConflict+    :: forall db table s. Beamable table+    => DatabaseEntity Sqlite db (TableEntity table)+    -> SqlInsertValues Sqlite (table (QExpr Sqlite s))+    -> Beam.SqlConflictTarget Sqlite table+    -> Beam.SqlConflictAction Sqlite table+    -> SqlInsert Sqlite table+  insertOnConflict (DatabaseEntity dt) values target action = case values of+    SqlInsertValuesEmpty -> SqlInsertNoRows+    SqlInsertValues vs -> SqlInsert (dbTableSettings dt) $+      let getFieldName+            :: forall a+            .  Columnar' (TableField table) a+            -> Columnar' (QField QInternal) a+          getFieldName (Columnar' fd) =+            Columnar' $ QField False (dbTableCurrentName dt) $ _fieldName fd+          tableFields = changeBeamRep getFieldName $ dbTableSettings dt+          tellFieldName _ _ f = tell [f] >> pure f+          fieldNames = execWriter $+            project' (Proxy @AnyType) (Proxy @((), T.Text)) tellFieldName tableFields+          currentField+            :: forall a+            .  Columnar' (QField QInternal) a+            -> Columnar' (QExpr Sqlite QInternal) a+          currentField (Columnar' f) = Columnar' $ current_ f+          tableCurrent = changeBeamRep currentField tableFields+      in SqliteInsertSyntax (tableNameFromEntity dt) fieldNames vs $ Just $+           SqliteOnConflictSyntax $ mconcat+             [ emit "ON CONFLICT "+             , unSqliteConflictTarget target tableCurrent+             , emit " DO "+             , unSqliteConflictAction action tableFields+             ]++  anyConflict = SqliteConflictTarget $ const mempty+  conflictingFields makeProjection = SqliteConflictTarget $ \table ->+    parens $ commas $ map fromSqliteExpression $+      project (Proxy @Sqlite) (makeProjection table) "t"+  conflictingFieldsWhere makeProjection makeWhere =+    SqliteConflictTarget $ \table -> mconcat+      [ unSqliteConflictTarget (Beam.conflictingFields makeProjection) table+      , emit " WHERE "+      , let QExpr mkE = makeWhere table+        in fromSqliteExpression $ mkE "t"+      ]++  onConflictDoNothing = SqliteConflictAction $ const $ emit "NOTHING"+  onConflictUpdateSet makeAssignments = SqliteConflictAction $ \table -> mconcat+    [ emit "UPDATE SET "+    , let QAssignment assignments = makeAssignments table $ excluded table+          emitAssignment (fieldName, expr) = mconcat+            [ fromSqliteFieldNameSyntax fieldName+            , emit " = "+            , fromSqliteExpression expr+            ]+      in commas $ map emitAssignment assignments+    ]+  onConflictUpdateSetWhere makeAssignments makeWhere =+    SqliteConflictAction $ \table -> mconcat+      [ unSqliteConflictAction (Beam.onConflictUpdateSet makeAssignments) table+      , emit " WHERE "+      , let QExpr mkE = makeWhere table $ excluded table+        in fromSqliteExpression $ mkE "t"+      ]++excluded+  :: forall table s+  .  Beamable table+  => table (QField s)+  -> table (QExpr Sqlite s)+excluded table = changeBeamRep excludedField table+  where excludedField (Columnar' (QField _ _ name)) =+          Columnar' $ QExpr $ const $ fieldE $ qualifiedField "excluded" name

@@ -41,7 +41,7 @@ import           Data.Int (Int64) import           Data.List (sortBy) import           Data.Maybe (mapMaybe, isJust)-import           Data.Monoid (Endo(..), (<>))+import           Data.Monoid (Endo(..)) import           Data.Ord (comparing) import           Data.String (fromString) import qualified Data.Text as T@@ -135,7 +135,7 @@   where     dtParser = charP <|> varcharP <|>                ncharP <|> nvarcharP <|>-               bitP <|> varbitP <|> numericP <|>+               bitP <|> varbitP <|> numericP <|> decimalP <|>                doubleP <|> integerP <|>                smallIntP <|> bigIntP <|> floatP <|>                doubleP <|> realP <|> dateP <|>@@ -170,12 +170,16 @@     numericP = do       asciiCI "NUMERIC"       numericType <$> numericPrecP-    doubleP = do-      asciiCI "DOUBLE" <|> asciiCI "DECIMAL"+    decimalP = do+      asciiCI "DECIMAL"       decimalType <$> numericPrecP     floatP = do       asciiCI "FLOAT"       floatType <$> precP+    doubleP = do+      asciiCI "DOUBLE"+      optional $ skipSpace >> asciiCI "PRECISION"+      pure doubleType     realP = realType <$ asciiCI "REAL"      intTypeP =

@@ -19,10 +19,12 @@   , SqliteSelectSyntax(..), SqliteInsertSyntax(..)   , SqliteUpdateSyntax(..), SqliteDeleteSyntax(..) +  , SqliteOnConflictSyntax(..)   , SqliteInsertValuesSyntax(..)   , SqliteColumnSchemaSyntax(..)   , SqliteExpressionSyntax(..), SqliteValueSyntax(..)   , SqliteTableNameSyntax(..)+  , SqliteFieldNameSyntax(..)   , SqliteAggregationSetQuantifierSyntax(..)    , fromSqliteExpression@@ -33,14 +35,15 @@   , sqliteBigIntType, sqliteSerialType      -- * Building and consuming 'SqliteSyntax'-  , fromSqliteCommand, formatSqliteInsert+  , fromSqliteCommand, formatSqliteInsert, formatSqliteInsertOnConflict -  , emit, emitValue, parens+  , emit, emitValue, parens, commas, quotedIdentifier    , sqliteEscape, withPlaceholders   , sqliteRenderSyntaxScript   ) where +import           Database.Beam.Backend.Internal.Compat import           Database.Beam.Backend.SQL import           Database.Beam.Backend.SQL.AST (ExtractField(..)) import           Database.Beam.Haskell.Syntax@@ -69,6 +72,7 @@ #if !MIN_VERSION_base(4, 11, 0) import           Data.Semigroup #endif+import           GHC.TypeLits  import           Database.SQLite.Simple (SQLData(..)) @@ -176,21 +180,25 @@ -- | Convert a 'SqliteCommandSyntax' into a renderable 'SqliteSyntax' fromSqliteCommand :: SqliteCommandSyntax -> SqliteSyntax fromSqliteCommand (SqliteCommandSyntax s) = s-fromSqliteCommand (SqliteCommandInsert (SqliteInsertSyntax tbl fields values)) =-    formatSqliteInsert tbl fields values+fromSqliteCommand (SqliteCommandInsert (SqliteInsertSyntax tbl fields values onConflict)) =+    formatSqliteInsertOnConflict tbl fields values onConflict  -- | SQLite @SELECT@ syntax newtype SqliteSelectSyntax = SqliteSelectSyntax { fromSqliteSelect :: SqliteSyntax } +-- | SQLite @ON CONFLICT@ syntax+newtype SqliteOnConflictSyntax = SqliteOnConflictSyntax { fromSqliteOnConflict :: SqliteSyntax }+ -- | SQLite @INSERT@ syntax. This doesn't directly wrap 'SqliteSyntax' because -- we need to do some processing on @INSERT@ statements to deal with @AUTO -- INCREMENT@ columns. Use 'formatSqliteInsert' to turn 'SqliteInsertSyntax' -- into 'SqliteSyntax'. data SqliteInsertSyntax   = SqliteInsertSyntax-  { sqliteInsertTable  :: !SqliteTableNameSyntax-  , sqliteInsertFields :: [ T.Text ]-  , sqliteInsertValues :: !SqliteInsertValuesSyntax+  { sqliteInsertTable      :: !SqliteTableNameSyntax+  , sqliteInsertFields     :: [ T.Text ]+  , sqliteInsertValues     :: !SqliteInsertValuesSyntax+  , sqliteInsertOnConflict :: !(Maybe SqliteOnConflictSyntax)   }  -- | SQLite @UPDATE@ syntax@@ -295,12 +303,23 @@ -- | Format a SQLite @INSERT@ expression for the given table name, fields, and values. formatSqliteInsert :: SqliteTableNameSyntax -> [ T.Text ] -> SqliteInsertValuesSyntax -> SqliteSyntax formatSqliteInsert tblNm fields values =-  emit "INSERT INTO " <> fromSqliteTableName tblNm <> parens (commas (map quotedIdentifier fields)) <> emit " " <>-  case values of-    SqliteInsertFromSql (SqliteSelectSyntax select) -> select-    SqliteInsertExpressions es ->-      emit "VALUES " <> commas (map (\row -> parens (commas (map fromSqliteExpression row)) ) es)+  formatSqliteInsertOnConflict tblNm fields values Nothing +-- | Format a SQLite @INSERT@ expression for the given table name, fields,+-- values, and optionally an @ON CONFLICT@ clause.+formatSqliteInsertOnConflict :: SqliteTableNameSyntax -> [ T.Text ] -> SqliteInsertValuesSyntax -> Maybe SqliteOnConflictSyntax -> SqliteSyntax+formatSqliteInsertOnConflict tblNm fields values onConflict = mconcat+  [ emit "INSERT INTO "+  , fromSqliteTableName tblNm+  , parens (commas (map quotedIdentifier fields))+  , emit " "+  , case values of+      SqliteInsertFromSql (SqliteSelectSyntax select) -> select+      SqliteInsertExpressions es ->+        emit "VALUES " <> commas (map (\row -> parens (commas (map fromSqliteExpression row)) ) es)+  , maybe mempty ((emit " " <>) . fromSqliteOnConflict) onConflict+  ]+ instance IsSql92Syntax SqliteCommandSyntax where   type Sql92SelectSyntax SqliteCommandSyntax = SqliteSelectSyntax   type Sql92InsertSyntax SqliteCommandSyntax = SqliteInsertSyntax@@ -504,7 +523,7 @@   varBitType prec = SqliteDataTypeSyntax (emit "BIT VARYING" <> sqliteOptPrec prec) (varBitType prec) (varBitType prec) False    numericType prec = SqliteDataTypeSyntax (emit "NUMERIC" <> sqliteOptNumericPrec prec) (numericType prec) (numericType prec) False-  decimalType prec = SqliteDataTypeSyntax (emit "DOUBLE" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec) False+  decimalType prec = SqliteDataTypeSyntax (emit "DECIMAL" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec) False    intType = SqliteDataTypeSyntax (emit "INTEGER") intType intType False   smallIntType = SqliteDataTypeSyntax (emit "SMALLINT") smallIntType smallIntType False@@ -671,8 +690,6 @@   ascOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " ASC")   descOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " DESC") -instance HasSqlValueSyntax SqliteValueSyntax Int where-  sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int8 where   sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int16 where@@ -681,8 +698,6 @@   sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int64 where   sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i)))-instance HasSqlValueSyntax SqliteValueSyntax Word where-  sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word8 where   sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word16 where@@ -698,7 +713,7 @@ instance HasSqlValueSyntax SqliteValueSyntax Double where   sqlValueSyntax f = SqliteValueSyntax (emitValue (SQLFloat f)) instance HasSqlValueSyntax SqliteValueSyntax Bool where-  sqlValueSyntax = sqlValueSyntax . (\b -> if b then 1 else 0 :: Int)+  sqlValueSyntax = sqlValueSyntax . (\b -> if b then 1 else 0 :: Int32) instance HasSqlValueSyntax SqliteValueSyntax SqlNull where   sqlValueSyntax _ = SqliteValueSyntax (emit "NULL") instance HasSqlValueSyntax SqliteValueSyntax String where@@ -712,6 +727,12 @@   sqlValueSyntax (Just x) = sqlValueSyntax x   sqlValueSyntax Nothing = sqlValueSyntax SqlNull +instance TypeError (PreferExplicitSize Int Int32) => HasSqlValueSyntax SqliteValueSyntax Int where+  sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i)))++instance TypeError (PreferExplicitSize Word Word32) => HasSqlValueSyntax SqliteValueSyntax Word where+  sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i)))+ instance IsCustomSqlSyntax SqliteExpressionSyntax where   newtype CustomSqlSyntax SqliteExpressionSyntax =     SqliteCustomExpressionSyntax { fromSqliteCustomExpression :: SqliteSyntax }@@ -773,9 +794,9 @@     SqliteExpressionSyntax $     emit "NULLIF" <> parens (fromSqliteExpression a <> emit ", " <> fromSqliteExpression b)   absE x = SqliteExpressionSyntax (emit "ABS" <> parens (fromSqliteExpression x))-  bitLengthE x = SqliteExpressionSyntax (emit "BIT_LENGTH" <> parens (fromSqliteExpression x))-  charLengthE x = SqliteExpressionSyntax (emit "CHAR_LENGTH" <> parens (fromSqliteExpression x))-  octetLengthE x = SqliteExpressionSyntax (emit "OCTET_LENGTH" <> parens (fromSqliteExpression x))+  bitLengthE x = SqliteExpressionSyntax (emit "8 * LENGTH" <> parens (emit "CAST" <> parens (parens (fromSqliteExpression x) <> emit " AS BLOB")))+  charLengthE x = SqliteExpressionSyntax (emit "LENGTH" <> parens (fromSqliteExpression x))+  octetLengthE x = SqliteExpressionSyntax (emit "LENGTH" <> parens (emit "CAST" <> parens (parens (fromSqliteExpression x) <> emit " AS BLOB")))   lowerE x = SqliteExpressionSyntax (emit "LOWER" <> parens (fromSqliteExpression x))   upperE x = SqliteExpressionSyntax (emit "UPPER" <> parens (fromSqliteExpression x))   trimE x = SqliteExpressionSyntax (emit "TRIM" <> parens (fromSqliteExpression x))@@ -851,7 +872,7 @@   type Sql92InsertTableNameSyntax SqliteInsertSyntax = SqliteTableNameSyntax   type Sql92InsertValuesSyntax SqliteInsertSyntax = SqliteInsertValuesSyntax -  insertStmt = SqliteInsertSyntax+  insertStmt table fields values = SqliteInsertSyntax table fields values Nothing  instance IsSql92InsertValuesSyntax SqliteInsertValuesSyntax where   type Sql92InsertValuesExpressionSyntax SqliteInsertValuesSyntax = SqliteExpressionSyntax

@@ -6,7 +6,7 @@ SQLite is mostly standards compliant, but there are a few cases that beam-sqlite cannot handle. These cases may result in run-time errors. For more information, see-[the documentation](http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/).+[the documentation](https://haskell-beam.github.io/beam/user-guide/backends/beam-sqlite/). Due to SQLite's embedded nature, there are currently no plans to get rid of these. However, proposals and PRs to fix these corner cases are welcome, where appropriate.

@@ -1,20 +1,20 @@ name:                beam-sqlite-version:             0.4.0.0+version:             0.5.0.0 synopsis:            Beam driver for SQLite description:         Beam driver for the <https://sqlite.org/ SQLite> embedded database.-                     See <http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/ here>+                     See <https://haskell-beam.github.io/beam/user-guide/backends/beam-sqlite/ here>                      for more information-homepage:            http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/+homepage:            https://haskell-beam.github.io/beam/user-guide/backends/beam-sqlite/ license:             MIT license-file:        LICENSE author:              Travis Athougies maintainer:          travis@athougies.net copyright:           (C) 2017-2018 Travis Athougies-category:            Web+category:            Database build-type:          Simple extra-source-files:  README.md extra-doc-files:     ChangeLog.md-bug-reports:          https://github.com/tathougies/beam/issues+bug-reports:          https://github.com/haskell-beam/beam/issues cabal-version:       1.18  library@@ -25,13 +25,13 @@   other-modules:      Database.Beam.Sqlite.SqliteSpecific   build-depends:      base          >=4.7  && <5, -                      beam-core     >=0.8  && <0.9,-                      beam-migrate  >=0.4  && <0.5,+                      beam-core     >=0.9  && <0.10,+                      beam-migrate  >=0.5  && <0.6,                        sqlite-simple >=0.4  && <0.5,                       text          >=1.0  && <1.3,                       bytestring    >=0.10 && <0.11,-                      hashable      >=1.2  && <1.3,+                      hashable      >=1.2  && <1.4,                       time          >=1.6  && <1.10,                       dlist         >=0.8  && <0.9,                       mtl           >=2.1  && <2.3,@@ -51,10 +51,44 @@   if os(windows)     cpp-options:      -DWINDOWS     build-depends:    Win32         >=2.4 && <2.8-  if os(freebsd) || os(netbsd) || os(darwin) || os(linux) || os(solaris)+  if os(freebsd) || os(netbsd) || os(openbsd) || os(darwin) || os(linux) || os(solaris) || os(android)     cpp-options:      -DUNIX     build-depends:    unix          >=2.0 && <2.8 +test-suite beam-sqlite-tests+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    base,+    beam-core,+    beam-migrate,+    beam-sqlite,+    sqlite-simple,+    tasty,+    tasty-expected-failure,+    tasty-hunit,+    text,+    time+  other-modules:+    Database.Beam.Sqlite.Test+    Database.Beam.Sqlite.Test.Migrate+    Database.Beam.Sqlite.Test.Select+  default-language: Haskell2010+  default-extensions:+    DeriveAnyClass,+    DeriveGeneric,+    FlexibleContexts,+    FlexibleInstances,+    LambdaCase,+    MultiParamTypeClasses,+    OverloadedStrings,+    RankNTypes,+    ScopedTypeVariables,+    StandaloneDeriving,+    TypeApplications,+    TypeFamilies+ flag werror   description: Enable -Werror during development   default:     False@@ -62,5 +96,5 @@  source-repository head   type: git-  location: https://github.com/tathougies/beam.git+  location: https://github.com/haskell-beam/beam.git   subdir: beam-sqlite

@@ -0,0 +1,9 @@+module Database.Beam.Sqlite.Test where++import Control.Exception+import Database.SQLite.Simple+import Test.Tasty.HUnit++withTestDb :: (Connection -> IO a) -> IO a+withTestDb = flip catch asFailure . bracket (open ":memory:") close+  where asFailure (e :: SomeException) = assertFailure $ show e

@@ -0,0 +1,74 @@+module Database.Beam.Sqlite.Test.Migrate (tests) where++import Database.SQLite.Simple+import Test.Tasty+import Test.Tasty.HUnit++import Database.Beam+import Database.Beam.Sqlite+import Database.Beam.Sqlite.Migrate+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple++import Database.Beam.Sqlite.Test++tests :: TestTree+tests = testGroup "Migration tests"+  [ verifiesPrimaryKey+  , verifiesNoPrimaryKey+  ]++newtype WithPkT f = WithPkT+  { _with_pk_value :: C f Bool+  } deriving (Generic, Beamable)++instance Table WithPkT where+  newtype PrimaryKey WithPkT f = Pk (C f Bool)+    deriving (Generic, Beamable)++  primaryKey = Pk . _with_pk_value++data WithPkDb entity = WithPkDb+  { _with_pk :: entity (TableEntity WithPkT)+  } deriving (Generic, Database Sqlite)++withPkDbChecked :: CheckedDatabaseSettings Sqlite WithPkDb+withPkDbChecked = defaultMigratableDbSettings++newtype WithoutPkT f = WithoutPkT+  { _without_pk_value :: C f Bool+  } deriving (Generic, Beamable)++instance Table WithoutPkT where+  data PrimaryKey WithoutPkT f = NoPk+    deriving (Generic, Beamable)++  primaryKey _ = NoPk++data WithoutPkDb entity = WithoutPkDb+  { _without_pk :: entity (TableEntity WithoutPkT)+  } deriving (Generic, Database Sqlite)++withoutPkDbChecked :: CheckedDatabaseSettings Sqlite WithoutPkDb+withoutPkDbChecked = defaultMigratableDbSettings++verifiesPrimaryKey :: TestTree+verifiesPrimaryKey = testCase "verifySchema correctly detects primary key" $+  withTestDb $ \conn -> do+    execute_ conn "create table with_pk (with_pk_value bool not null primary key)"+    testVerifySchema conn withPkDbChecked++verifiesNoPrimaryKey :: TestTree+verifiesNoPrimaryKey = testCase "verifySchema correctly handles table with no primary key" $+  withTestDb $ \conn -> do+    execute_ conn "create table without_pk (without_pk_value bool not null)"+    testVerifySchema conn withoutPkDbChecked++testVerifySchema+  :: Database Sqlite db+  => Connection -> CheckedDatabaseSettings Sqlite db -> Assertion+testVerifySchema conn db =+  runBeamSqlite conn (verifySchema migrationBackend db) >>= \case+    VerificationSucceeded -> return ()+    VerificationFailed failures ->+      fail $ "Verification failed: " ++ show failures

@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Beam.Sqlite.Test.Select (tests) where++import Control.Exception+import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.HUnit++import Data.Int (Int32)+import Data.Text (Text)+import Data.Time (LocalTime)++import Database.Beam+import Database.Beam.Sqlite++import Database.Beam.Sqlite.Test++import Database.SQLite.Simple (execute_)++tests :: TestTree+tests = testGroup "Selection tests"+  [ expectFail testExceptValues+  , testInRowValues+  , testInsertReturningColumnOrder -- In select tests because the bug was with the selects+  ]++data Pair f = Pair+  { _left :: C f Bool+  , _right :: C f Bool+  } deriving (Generic, Beamable)++testInRowValues :: TestTree+testInRowValues = testCase "IN with row values works" $+  withTestDb $ \conn -> do+    result <- runBeamSqlite conn $ runSelectReturningList $ select $ do+      let p :: forall ctx s. Pair (QGenExpr ctx Sqlite s)+          p = val_ $ Pair False False+      return $ p `in_` [p, p]+    assertEqual "result" [True] result++-- | Regression test for <https://github.com/haskell-beam/beam/issues/326 #326>+testExceptValues :: TestTree+testExceptValues = testCase "EXCEPT with VALUES works" $+  withTestDb $ \conn -> do+    result <- runBeamSqlite conn $ runSelectReturningList $ select $+      values_ [as_ @Bool $ val_ True, val_ False] `except_` values_ [val_ False]+    assertEqual "result" [True] result++data TestTableT f+  = TestTable+  { ttId :: C f Int32+  , ttFirstName :: C f Text+  , ttLastName  :: C f Text+  , ttAge       :: C f Int32+  , ttDateJoined :: C f LocalTime+  } deriving (Generic, Beamable)++deriving instance Show (TestTableT Identity)+deriving instance Eq (TestTableT Identity)++instance Table TestTableT where+  data PrimaryKey TestTableT f = TestTableKey (C f Int32)+    deriving (Generic, Beamable)+  primaryKey = TestTableKey <$> ttId++data TestTableDb entity+  = TestTableDb+  { dbTestTable :: entity (TableEntity TestTableT)+  } deriving (Generic, Database Sqlite)++testDatabase :: DatabaseSettings be TestTableDb+testDatabase = defaultDbSettings++testInsertReturningColumnOrder :: TestTree+testInsertReturningColumnOrder = testCase "runInsertReturningList with mismatching column order" $ do+  withTestDb $ \conn -> do+    execute_ conn "CREATE TABLE test_table ( date_joined TIMESTAMP NOT NULL, first_name TEXT NOT NULL, id INT PRIMARY KEY, age INT NOT NULL, last_name TEXT NOT NULL )"+    inserted <-+      runBeamSqlite conn $ runInsertReturningList $+      insert (dbTestTable testDatabase) $+      insertExpressions [ TestTable 0 (concat_ [ "j", "im" ]) "smith" 19 currentTimestamp_+                        , TestTable 1 "sally" "apple" ((val_ 56 + val_ 109) `div_` 5) currentTimestamp_+                        , TestTable 4 "blah" "blah" (-1) currentTimestamp_ ]++    let dateJoined = ttDateJoined (head inserted)++        expected = [ TestTable 0 "jim" "smith" 19 dateJoined+                   , TestTable 1 "sally" "apple" 33 dateJoined+                   , TestTable 4 "blah" "blah" (-1) dateJoined ]++    assertEqual "insert values" inserted expected

@@ -0,0 +1,12 @@+module Main where++import Test.Tasty++import qualified Database.Beam.Sqlite.Test.Migrate as Migrate+import qualified Database.Beam.Sqlite.Test.Select as Select++main :: IO ()+main = defaultMain $ testGroup "beam-sqlite tests"+  [ Migrate.tests+  , Select.tests+  ]