beam-sqlite 0.3.2.4 → 0.4.0.0

raw patch · 5 files changed

+257/−194 lines, 5 filesdep ~beam-coredep ~beam-migratePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: beam-core, beam-migrate

API changes (from Hackage documentation)

Files

• Database/Beam/Sqlite/Connection.hs +145/−65
• Database/Beam/Sqlite/Migrate.hs +19/−18
• Database/Beam/Sqlite/SqliteSpecific.hs +20/−22
• Database/Beam/Sqlite/Syntax.hs +70/−85
• beam-sqlite.cabal +3/−4

@@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -10,17 +12,24 @@   , runBeamSqlite, runBeamSqliteDebug      -- * Emulated @INSERT RETURNING@ support-  , SqliteInsertReturning   , insertReturning, runInsertReturningList   ) where  import           Database.Beam.Backend-import           Database.Beam.Backend.SQL import qualified Database.Beam.Backend.SQL.BeamExtensions as Beam import           Database.Beam.Backend.URI-import           Database.Beam.Query (QExpr, SqlInsert(..), SqlInsertValues(..), insert)-import           Database.Beam.Schema.Tables ( DatabaseEntity(..)-                                             , DatabaseEntityDescriptor(..)+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(..)+                                     , HasQBuilder(..), HasSqlEqualityCheck+                                     , HasSqlQuantifiedEqualityCheck+                                     , DataType(..)+                                     , insert )+import           Database.Beam.Query.SQL92+import           Database.Beam.Schema.Tables ( Beamable+                                             , DatabaseEntity(..)                                              , TableEntity) import           Database.Beam.Sqlite.Syntax @@ -35,26 +44,31 @@ import           Database.SQLite.Simple.Ok (Ok(..)) import           Database.SQLite.Simple.Types (Null) -import           Control.Exception (bracket_, onException, mask)-import           Control.Monad (forM_, replicateM_)+import           Control.Exception (SomeException(..), bracket_, onException, mask)+import           Control.Monad (forM_) 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(..), runStateT)+import           Control.Monad.Reader (ReaderT(..), MonadReader(..), runReaderT)+import           Control.Monad.State.Strict (MonadState(..), StateT(..), runStateT)+import           Control.Monad.Trans (lift) -import qualified Data.ByteString.Char8 as BS import           Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.DList as D import           Data.Int+import           Data.Maybe (mapMaybe)+import           Data.Proxy (Proxy(..)) import           Data.Scientific (Scientific) import           Data.String (fromString) import qualified Data.Text as T+import qualified Data.Text.Encoding as T (decodeUtf8) import qualified Data.Text.Lazy as TL import           Data.Time ( LocalTime, UTCTime, Day-                           , utc, utcToLocalTime )+                           , ZonedTime, utc, utcToLocalTime )+import           Data.Typeable (cast) import           Data.Word #if !MIN_VERSION_base(4,11,0) import           Data.Semigroup@@ -81,6 +95,12 @@ instance BeamBackend Sqlite where   type BackendFromField Sqlite = FromField +instance HasQBuilder Sqlite where+  buildSqlQuery = buildSql92Query' False -- SQLite does not support arbitrarily nesting UNION, INTERSECT, and EXCEPT++instance BeamSqlBackendIsString Sqlite T.Text+instance BeamSqlBackendIsString Sqlite String+ instance FromBackendRow Sqlite Bool instance FromBackendRow Sqlite Double instance FromBackendRow Sqlite Float@@ -135,8 +155,18 @@           Just s'  -> pure s'  instance BeamSqlBackend Sqlite-instance BeamSql92Backend Sqlite+instance BeamMigrateOnlySqlBackend Sqlite+type instance BeamSqlBackendSyntax Sqlite = SqliteCommandSyntax +data SqliteHasDefault = SqliteHasDefault+instance FieldReturnType 'True 'False Sqlite resTy a =>+         FieldReturnType 'False 'False Sqlite resTy (SqliteHasDefault -> a) where+  field' _ _ nm ty _ collation constraints SqliteHasDefault =+    field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints++instance BeamSqlBackendHasSerial Sqlite where+  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 newtype SqliteM a@@ -152,36 +182,100 @@  newtype BeamSqliteRow a = BeamSqliteRow a instance FromBackendRow Sqlite a => FromRow (BeamSqliteRow a) where-  fromRow = BeamSqliteRow <$> runF (fromBackendRow :: FromBackendRowM Sqlite a) finish step+  fromRow = BeamSqliteRow <$> runF fromBackendRow' finish step       where+        FromBackendRowM fromBackendRow' = fromBackendRow :: FromBackendRowM Sqlite a++        translateErrors :: Maybe Int -> SomeException -> Maybe SomeException+        translateErrors col (SomeException e) =+          case cast e of+            Just (ConversionFailed { errSQLType     = typeString+                                   , errHaskellType = hsString+                                   , errMessage     = msg }) ->+              Just (SomeException (BeamRowReadError col (ColumnTypeMismatch hsString typeString ("conversion failed: " ++ msg))))+            Just (UnexpectedNull {}) ->+              Just (SomeException (BeamRowReadError col ColumnUnexpectedNull))+            Just (Incompatible { errSQLType     = typeString+                               , errHaskellType = hsString+                               , errMessage     = msg }) ->+              Just (SomeException (BeamRowReadError col (ColumnTypeMismatch hsString typeString ("incompatible: " ++ msg))))+            Nothing -> Nothing+         finish = pure -        step :: FromBackendRowF Sqlite (RowParser a) -> RowParser a+        step :: forall a'. FromBackendRowF Sqlite (RowParser a') -> RowParser a'         step (ParseOneField next) =-            field >>= next-        step (PeekField next) =-            RP $ do-              ro <- ask-              st <- get-              case runStateT (runReaderT (unRP field) ro) st of-                Ok (a, _) -> unRP (next (Just a))-                _ -> unRP (next Nothing)-        step (CheckNextNNull n next) =-            RP $ do-              ro <- ask-              st <- get-              case runStateT (runReaderT (unRP (replicateM_ n (field :: RowParser Null))) ro) st of-                Ok ((), st') ->-                  do put st'-                     unRP (next True)-                _ -> unRP (next False)+            RP $ ReaderT $ \ro -> StateT $ \st@(col, _) ->+            case runStateT (runReaderT (unRP field) ro) st of+              Ok (x, st') -> runStateT (runReaderT (unRP (next x)) ro) st'+              Errors errs -> Errors (mapMaybe (translateErrors (Just col)) errs)+        step (Alt (FromBackendRowM a) (FromBackendRowM b) next) = do+          RP $ do+            let RP a' = runF a finish step+                RP b' = runF b finish step +            st <- get+            ro <- ask+            case runStateT (runReaderT a' ro) st of+              Ok (ra, st') -> do+                put st'+                unRP (next ra)+              Errors aErrs ->+                case runStateT (runReaderT b' ro) st of+                  Ok (rb, st') -> do+                    put st'+                    unRP (next rb)+                  Errors bErrs ->+                    lift (lift (Errors (aErrs ++ bErrs)))+        step (FailParseWith err) = RP (lift (lift (Errors [SomeException err])))++-- * Equality checks+#define HAS_SQLITE_EQUALITY_CHECK(ty)                       \+  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)+HAS_SQLITE_EQUALITY_CHECK(Word64)+HAS_SQLITE_EQUALITY_CHECK(Double)+HAS_SQLITE_EQUALITY_CHECK(Float)+HAS_SQLITE_EQUALITY_CHECK(Bool)+HAS_SQLITE_EQUALITY_CHECK(String)+HAS_SQLITE_EQUALITY_CHECK(T.Text)+HAS_SQLITE_EQUALITY_CHECK(TL.Text)+HAS_SQLITE_EQUALITY_CHECK(BS.ByteString)+HAS_SQLITE_EQUALITY_CHECK(BL.ByteString)+HAS_SQLITE_EQUALITY_CHECK(UTCTime)+HAS_SQLITE_EQUALITY_CHECK(LocalTime)+HAS_SQLITE_EQUALITY_CHECK(ZonedTime)+HAS_SQLITE_EQUALITY_CHECK(Char)+HAS_SQLITE_EQUALITY_CHECK(Integer)+HAS_SQLITE_EQUALITY_CHECK(Scientific)++instance HasDefaultSqlDataType Sqlite (SqlSerial Int) where+  defaultSqlDataType _ _ False = sqliteSerialType+  defaultSqlDataType _ _ True = intType++instance HasDefaultSqlDataType Sqlite BS.ByteString where+  -- TODO we should somehow allow contsraints based on backend+  defaultSqlDataType _ _ _ = sqliteBlobType++instance HasDefaultSqlDataType Sqlite LocalTime where+  defaultSqlDataType _ _ _ = timestampType Nothing False+ -- | URI syntax for use with 'withDbConnection'. See documentation for -- 'BeamURIOpeners' for more information.-sqliteUriSyntax :: c SqliteCommandSyntax Sqlite Connection SqliteM+sqliteUriSyntax :: c Sqlite Connection SqliteM                 -> BeamURIOpeners c sqliteUriSyntax =-  mkUriOpener "sqlite:"+  mkUriOpener runBeamSqlite "sqlite:"     (\uri -> do         let sqliteName = if null (uriPath uri) then ":memory:" else uriPath uri         hdl <- open sqliteName@@ -193,10 +287,7 @@ runBeamSqlite :: Connection -> SqliteM a -> IO a runBeamSqlite = runBeamSqliteDebug (\_ -> pure ()) -instance MonadBeam SqliteCommandSyntax Sqlite Connection SqliteM where-  withDatabase = runBeamSqlite-  withDatabaseDebug = runBeamSqliteDebug-+instance MonadBeam Sqlite SqliteM where   runNoReturn (SqliteCommandSyntax (SqliteSyntax cmd vals)) =     SqliteM $ do       (logger, conn) <- ask@@ -227,14 +318,13 @@       , "rows from an insert, use Database.Beam.Sqlite.insertReturning "       , "for emulation" ] -instance Beam.MonadBeamInsertReturning SqliteCommandSyntax Sqlite Connection SqliteM where-  runInsertReturningList tbl values =-    runInsertReturningList (insertReturning tbl values)+instance Beam.MonadBeamInsertReturning Sqlite SqliteM where+  runInsertReturningList = runInsertReturningList  runSqliteInsert :: (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO () runSqliteInsert logger conn (SqliteInsertSyntax tbl fields vs)     -- If all expressions are simple expressions (no default), then just-    -- run the INSERT normally+   | SqliteInsertExpressions es <- vs, any (any (== SqliteExpressionDefault)) es =       forM_ es $ \row -> do         let (fields', row') = unzip $ filter ((/= SqliteExpressionDefault) . snd) $ zip fields row@@ -250,33 +340,21 @@  -- * emulated INSERT returning support --- | Represents an @INSERT@ statement, from which we can retrieve inserted rows.--- Beam also offers a backend-agnostic way of using this functionality in the--- 'MonadBeamInsertReturning' extension. This functionality is emulated in--- SQLite using a temporary table and a trigger.-data SqliteInsertReturning (table :: (* -> *) -> *)-  = SqliteInsertReturning T.Text SqliteInsertSyntax-  | SqliteInsertReturningNoRows- -- | Build a 'SqliteInsertReturning' representing inserting the given values -- into the given table. Use 'runInsertReturningList'-insertReturning :: DatabaseEntity be db (TableEntity table)-                -> SqlInsertValues SqliteInsertValuesSyntax (table (QExpr SqliteExpressionSyntax s))-                -> SqliteInsertReturning table-insertReturning tbl@(DatabaseEntity (DatabaseTable tblNm _)) vs =-  case insert tbl vs of-    SqlInsert s ->-      SqliteInsertReturning tblNm s-    SqlInsertNoRows ->-      SqliteInsertReturningNoRows+insertReturning :: Beamable table+                => DatabaseEntity Sqlite db (TableEntity table)+                -> SqlInsertValues Sqlite (table (QExpr Sqlite s))+                -> SqlInsert Sqlite table+insertReturning = insert  -- | Runs a 'SqliteInsertReturning' statement and returns a result for each -- inserted row. runInsertReturningList :: FromBackendRow Sqlite (table Identity)-                       => SqliteInsertReturning table+                       => SqlInsert Sqlite table                        -> SqliteM [ table Identity ]-runInsertReturningList SqliteInsertReturningNoRows = pure []-runInsertReturningList (SqliteInsertReturning nm insertStmt_) =+runInsertReturningList SqlInsertNoRows = pure []+runInsertReturningList (SqlInsert _ insertStmt_@(SqliteInsertSyntax nm _ _)) =   do (logger, conn) <- SqliteM ask      SqliteM . liftIO $ do @@ -288,7 +366,9 @@ #error Need either POSIX or Win32 API for MonadBeamInsertReturning #endif -       let startSavepoint =+       let tableNameTxt = T.decodeUtf8 (BL.toStrict (sqliteRenderSyntaxScript (fromSqliteTableName nm)))++           startSavepoint =              execute_ conn (Query ("SAVEPOINT insert_savepoint_" <> processId))            rollbackToSavepoint =              execute_ conn (Query ("ROLLBACK TRANSACTION TO SAVEPOINT insert_savepoint_" <> processId))@@ -296,13 +376,13 @@              execute_ conn (Query ("RELEASE SAVEPOINT insert_savepoint_" <> processId))             createInsertedValuesTable =-             execute_ conn (Query ("CREATE TEMPORARY TABLE inserted_values_" <> processId <> " AS SELECT * FROM \"" <> sqliteEscape nm <> "\" LIMIT 0"))+             execute_ conn (Query ("CREATE TEMPORARY TABLE inserted_values_" <> processId <> " AS SELECT * FROM " <> tableNameTxt <> " LIMIT 0"))            dropInsertedValuesTable =              execute_ conn (Query ("DROP TABLE inserted_values_" <> processId))             createInsertTrigger =-             execute_ conn (Query ("CREATE TEMPORARY TRIGGER insert_trigger_" <> processId <> " AFTER INSERT ON \"" <> sqliteEscape nm <> "\" BEGIN " <>-                                   "INSERT INTO inserted_values_" <> processId <> " SELECT * FROM \"" <> sqliteEscape nm <> "\" WHERE ROWID=last_insert_rowid(); END" ))+             execute_ conn (Query ("CREATE TEMPORARY TRIGGER insert_trigger_" <> processId <> " AFTER INSERT ON " <> tableNameTxt <> " BEGIN " <>+                                   "INSERT INTO inserted_values_" <> processId <> " SELECT * FROM " <> tableNameTxt <> " WHERE ROWID=last_insert_rowid(); END" ))            dropInsertTrigger =              execute_ conn (Query ("DROP TRIGGER insert_trigger_" <> processId)) 

@@ -4,7 +4,7 @@ -- | Migrations support for SQLite databases module Database.Beam.Sqlite.Migrate   ( -- * @beam-migrate@ CLI support-    migrationBackend+    migrationBackend, SqliteCommandSyntax      -- * @beam-migrate@ utility functions   , migrateScript, writeMigrationScript@@ -18,6 +18,8 @@ import qualified Database.Beam.Migrate as Db import qualified Database.Beam.Migrate.Backend as Tool import qualified Database.Beam.Migrate.Serialization as Db+import           Database.Beam.Migrate.Types (QualifiedName(..))+import qualified Database.Beam.Query.DataTypes as Db  import           Database.Beam.Backend.SQL import           Database.Beam.Haskell.Syntax@@ -28,8 +30,7 @@ import           Control.Exception import           Control.Monad.Reader -import           Database.SQLite.Simple-                    ( Connection, open, close, query_ )+import           Database.SQLite.Simple (open, close, query_)  import           Data.Aeson import           Data.Attoparsec.Text (asciiCI, skipSpace)@@ -48,11 +49,10 @@  -- | Top-level 'Tool.BeamMigrationBackend' loaded dynamically by the -- @beam-migrate@ CLI tool.-migrationBackend :: Tool.BeamMigrationBackend SqliteCommandSyntax Sqlite Connection SqliteM+migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteM migrationBackend = Tool.BeamMigrationBackend                        "sqlite"                        "For beam-sqlite, this is the path to a sqlite3 file"-                       (BL.concat . migrateScript)                        getDbConstraints                        (Db.sql92Deserializers <> sqliteDataTypeDeserializers <>                         Db.beamCheckDeserializers)@@ -69,7 +69,7 @@ -- 'sqliteBlob', 'sqliteText', and 'sqliteBigInt'. These are compatible with the -- "typical" serialized versions of the standard 'Db.binaryLargeObject', -- 'Db.characterLargeObject', and 'Db.bigint' types.-sqliteDataTypeDeserializers :: Db.BeamDeserializers SqliteCommandSyntax+sqliteDataTypeDeserializers :: Db.BeamDeserializers Sqlite sqliteDataTypeDeserializers =   Db.beamDeserializer $ \_ v ->   fmap (id @SqliteDataTypeSyntax) $@@ -86,7 +86,7 @@ -- line-by-line list of lazy 'BL'ByteString's. The output is suitable for -- inclusion in a migration script. Comments are generated giving a description -- of each migration step.-migrateScript :: Db.MigrationSteps SqliteCommandSyntax () a -> [BL.ByteString]+migrateScript :: Db.MigrationSteps Sqlite () a -> [BL.ByteString] migrateScript steps =   "-- Generated by beam-sqlite beam-migrate backend\n" :   "\n" :@@ -98,7 +98,7 @@       Endo ((sqliteRenderSyntaxScript (fromSqliteCommand cmd) <> ";\n"):)  -- | Write the output of 'migrateScript' to a file-writeMigrationScript :: FilePath -> Db.MigrationSteps SqliteCommandSyntax () a -> IO ()+writeMigrationScript :: FilePath -> Db.MigrationSteps Sqlite () a -> IO () writeMigrationScript fp steps =   let stepBs = migrateScript steps   in BL.writeFile fp (BL.concat stepBs)@@ -107,14 +107,14 @@ -- by 'getDbConstaints' into their equivalent in the @beam-migrate@ haskell -- syntax. Suitable for auto-generation of a haskell migration. sqlitePredConverter :: Tool.HaskellPredicateConverter-sqlitePredConverter = Tool.sql92HsPredicateConverters @SqliteColumnSchemaSyntax sqliteTypeToHs <>+sqlitePredConverter = Tool.sql92HsPredicateConverters @Sqlite sqliteTypeToHs <>                       Tool.hsPredicateConverter sqliteHasColumnConstraint   where     sqliteHasColumnConstraint (Db.TableColumnHasConstraint tblNm colNm c ::-                                  Db.TableColumnHasConstraint SqliteColumnSchemaSyntax)+                                  Db.TableColumnHasConstraint Sqlite)       | c == Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing =         Just (Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tblNm colNm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) ::-                                           Db.TableColumnHasConstraint HsColumnSchema))+                                           Db.TableColumnHasConstraint HsMigrateBackend))       | otherwise = Nothing  -- | Convert a SQLite data type to the corresponding Haskell one@@ -238,9 +238,10 @@   SqliteM . ReaderT $ \(_, conn) -> do     tblNames <- query_ conn "SELECT name, sql from sqlite_master where type='table'"     tblPreds <--      fmap mconcat . forM tblNames $ \(tblName, sql) -> do+      fmap mconcat . forM tblNames $ \(tblNameStr, sql) -> do+        let tblName = QualifiedName Nothing tblNameStr         columns <- fmap (sortBy (comparing (\(cid, _, _, _, _, _) -> cid :: Int))) $-                   query_ conn (fromString ("PRAGMA table_info('" <> T.unpack tblName <> "')"))+                   query_ conn (fromString ("PRAGMA table_info('" <> T.unpack tblNameStr <> "')"))          let columnPreds =               foldMap@@ -267,12 +268,12 @@                            then [ Db.SomeDatabasePredicate                                     (Db.TableColumnHasConstraint tblName nm                                        (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing)-                                         :: Db.TableColumnHasConstraint SqliteColumnSchemaSyntax) ]+                                         :: Db.TableColumnHasConstraint Sqlite) ]                            else []                       in [ Db.SomeDatabasePredicate                             (Db.TableHasColumn tblName nm dtType ::-                               Db.TableHasColumn SqliteColumnSchemaSyntax) ] +++                               Db.TableHasColumn Sqlite) ] ++                         notNullPred                 )                 columns@@ -288,12 +289,12 @@      pure tblPreds -sqliteText :: Db.DataType SqliteDataTypeSyntax T.Text+sqliteText :: Db.DataType Sqlite T.Text sqliteText = Db.DataType sqliteTextType -sqliteBlob :: Db.DataType SqliteDataTypeSyntax ByteString+sqliteBlob :: Db.DataType Sqlite ByteString sqliteBlob = Db.DataType sqliteBlobType -sqliteBigInt :: Db.DataType SqliteDataTypeSyntax Int64+sqliteBigInt :: Db.DataType Sqlite Int64 sqliteBigInt = Db.DataType sqliteBigIntType 

@@ -11,6 +11,7 @@ import           Database.Beam import           Database.Beam.Backend.SQL import           Database.Beam.Query.Internal+import           Database.Beam.Sqlite.Connection import           Database.Beam.Sqlite.Syntax #if !MIN_VERSION_base(4, 11, 0) import           Data.Semigroup@@ -20,14 +21,13 @@ -- Joins the value in each row of the first argument, using the second -- argument as a delimiter. See 'sqliteGroupConcatOver' if you want to provide -- explicit quantification.-sqliteGroupConcat -    :: ( HasSqlValueSyntax SqliteValueSyntax a-       , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str -       , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str2-       )-    => QExpr SqliteExpressionSyntax s a-    -> QExpr SqliteExpressionSyntax s str-    -> QAgg SqliteExpressionSyntax s (Maybe str2)+sqliteGroupConcat+    :: ( BeamSqlBackendCanSerialize Sqlite a+       , BeamSqlBackendIsString Sqlite str+       , BeamSqlBackendIsString Sqlite str2 )+    => QExpr Sqlite s a+    -> QExpr Sqlite s str+    -> QAgg Sqlite s (Maybe str2) sqliteGroupConcat v delim = _sqliteGroupConcatOver allInGroup_ v (Just delim)  @@ -35,27 +35,25 @@ -- Joins the value in each row of the first argument using ','. -- See 'sqliteGroupConcat' if you want to change the delimiter. -- Choosing a custom delimiter and quantification isn't allowed by SQLite.-sqliteGroupConcatOver -    :: ( HasSqlValueSyntax SqliteValueSyntax a-        , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str -        )+sqliteGroupConcatOver+    :: ( BeamSqlBackendCanSerialize Sqlite a+       , BeamSqlBackendIsString Sqlite str )     => Maybe SqliteAggregationSetQuantifierSyntax-    -> QExpr SqliteExpressionSyntax s a-    -> QAgg SqliteExpressionSyntax s (Maybe str)+    -> QExpr Sqlite s a+    -> QAgg Sqlite s (Maybe str) sqliteGroupConcatOver quantifier v = _sqliteGroupConcatOver quantifier v Nothing  -- SQLite doesn't allow DISTINCT and a custom delimiter-_sqliteGroupConcatOver -    :: ( HasSqlValueSyntax SqliteValueSyntax a-        , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str-        )+_sqliteGroupConcatOver+    :: ( BeamSqlBackendCanSerialize Sqlite a+       , BeamSqlBackendIsString Sqlite str )     => Maybe SqliteAggregationSetQuantifierSyntax-    -> QExpr SqliteExpressionSyntax s a-    -> Maybe (QExpr SqliteExpressionSyntax s str2)-    -> QAgg SqliteExpressionSyntax s (Maybe str)+    -> QExpr Sqlite s a+    -> Maybe (QExpr Sqlite s str2)+    -> QAgg Sqlite s (Maybe str) _sqliteGroupConcatOver quantifier (QExpr v) delim =     QExpr $ \tbl -> SqliteExpressionSyntax $     emit "group_concat" <>     parens ( maybe mempty (\q -> fromSqliteAggregationSetQuantifier q <> emit " ") quantifier <>-             fromSqliteExpression (v tbl) <> +             fromSqliteExpression (v tbl) <>              maybe mempty (\(QExpr d) -> emit ", " <> fromSqliteExpression (d tbl)) delim)

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing#-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -21,6 +22,7 @@   , SqliteInsertValuesSyntax(..)   , SqliteColumnSchemaSyntax(..)   , SqliteExpressionSyntax(..), SqliteValueSyntax(..)+  , SqliteTableNameSyntax(..)   , SqliteAggregationSetQuantifierSyntax(..)    , fromSqliteExpression@@ -40,15 +42,13 @@   ) where  import           Database.Beam.Backend.SQL+import           Database.Beam.Backend.SQL.AST (ExtractField(..)) import           Database.Beam.Haskell.Syntax-import           Database.Beam.Migrate.Generics+import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck(..)) import           Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes) import           Database.Beam.Migrate.SQL.SQL92-import           Database.Beam.Migrate.SQL (DataType(..), FieldReturnType(..), field)-import           Database.Beam.Migrate.SQL.BeamExtensions import           Database.Beam.Migrate.Serialization-import           Database.Beam.Query-import           Database.Beam.Query.SQL92+import           Database.Beam.Query hiding (ExtractField(..))  import           Data.ByteString (ByteString) import qualified Data.ByteString as B@@ -59,7 +59,6 @@ import           Data.Hashable import           Data.Int import           Data.Maybe-import           Data.Proxy (Proxy(..)) import           Data.Scientific import           Data.String import qualified Data.Text as T@@ -182,19 +181,16 @@  -- | SQLite @SELECT@ syntax newtype SqliteSelectSyntax = SqliteSelectSyntax { fromSqliteSelect :: SqliteSyntax }-instance HasQBuilder SqliteSelectSyntax where-  buildSqlQuery = buildSql92Query' False -- SQLite does not support arbitrarily nesting UNION, INTERSECT, and EXCEPT - -- | 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 :: T.Text+  { sqliteInsertTable  :: !SqliteTableNameSyntax   , sqliteInsertFields :: [ T.Text ]-  , sqliteInsertValues :: SqliteInsertValuesSyntax+  , sqliteInsertValues :: !SqliteInsertValuesSyntax   }  -- | SQLite @UPDATE@ syntax@@ -212,7 +208,6 @@ instance Hashable SqliteExpressionSyntax newtype SqliteFromSyntax = SqliteFromSyntax { fromSqliteFromSyntax :: SqliteSyntax } newtype SqliteComparisonQuantifierSyntax = SqliteComparisonQuantifierSyntax { fromSqliteComparisonQuantifier :: SqliteSyntax }-newtype SqliteExtractFieldSyntax = SqliteExtractFieldSyntax { fromSqliteExtractField :: SqliteSyntax } newtype SqliteAggregationSetQuantifierSyntax = SqliteAggregationSetQuantifierSyntax { fromSqliteAggregationSetQuantifier :: SqliteSyntax } newtype SqliteProjectionSyntax = SqliteProjectionSyntax { fromSqliteProjection :: SqliteSyntax } newtype SqliteGroupingSyntax = SqliteGroupingSyntax { fromSqliteGrouping :: SqliteSyntax }@@ -287,6 +282,7 @@ newtype SqliteAlterTableActionSyntax = SqliteAlterTableActionSyntax { fromSqliteAlterTableAction :: Maybe SqliteSyntax } newtype SqliteAlterColumnActionSyntax = SqliteAlterColumnActionSyntax { fromSqliteAlterColumnAction :: Maybe SqliteSyntax } newtype SqliteDropTableSyntax = SqliteDropTableSyntax { fromSqliteDropTable :: SqliteSyntax }+newtype SqliteTableNameSyntax = SqliteTableNameSyntax { fromSqliteTableName :: SqliteSyntax }  fromSqliteExpression :: SqliteExpressionSyntax -> SqliteSyntax fromSqliteExpression (SqliteExpressionSyntax s) = s@@ -297,9 +293,9 @@                              sqliteRenderSyntaxScript . fromSqliteExpression  -- | Format a SQLite @INSERT@ expression for the given table name, fields, and values.-formatSqliteInsert :: T.Text -> [ T.Text ] -> SqliteInsertValuesSyntax -> SqliteSyntax+formatSqliteInsert :: SqliteTableNameSyntax -> [ T.Text ] -> SqliteInsertValuesSyntax -> SqliteSyntax formatSqliteInsert tblNm fields values =-  emit "INSERT INTO " <> quotedIdentifier tblNm <> parens (commas (map quotedIdentifier fields)) <> emit " " <>+  emit "INSERT INTO " <> fromSqliteTableName tblNm <> parens (commas (map quotedIdentifier fields)) <> emit " " <>   case values of     SqliteInsertFromSql (SqliteSelectSyntax select) -> select     SqliteInsertExpressions es ->@@ -325,17 +321,25 @@   alterTableCmd = SqliteCommandSyntax . fromSqliteAlterTable   dropTableCmd = SqliteCommandSyntax . fromSqliteDropTable +instance IsSql92TableNameSyntax SqliteTableNameSyntax where+  -- SQLite doesn't have schemas proper, but it does have attached databases, which is what we use here+  tableName Nothing tbl = SqliteTableNameSyntax (quotedIdentifier tbl)+  tableName (Just sch) tbl = SqliteTableNameSyntax (quotedIdentifier sch <> emit "." <> quotedIdentifier tbl)+ instance IsSql92DropTableSyntax SqliteDropTableSyntax where-  dropTableSyntax nm = SqliteDropTableSyntax (emit "DROP TABLE " <> quotedIdentifier nm)+  type Sql92DropTableTableNameSyntax SqliteDropTableSyntax = SqliteTableNameSyntax +  dropTableSyntax nm = SqliteDropTableSyntax (emit "DROP TABLE " <> fromSqliteTableName nm)+ instance IsSql92AlterTableSyntax SqliteAlterTableSyntax where   type Sql92AlterTableAlterTableActionSyntax SqliteAlterTableSyntax = SqliteAlterTableActionSyntax+  type Sql92AlterTableTableNameSyntax SqliteAlterTableSyntax = SqliteTableNameSyntax    alterTableSyntax nm action =     SqliteAlterTableSyntax $     case fromSqliteAlterTableAction action of       Just alterTable ->-        emit "ALTER TABLE " <> quotedIdentifier nm <> emit " " <> alterTable+        emit "ALTER TABLE " <> fromSqliteTableName nm <> emit " " <> alterTable       Nothing ->         emit "SELECT 1" @@ -447,6 +451,7 @@   type Sql92CreateTableColumnSchemaSyntax SqliteCreateTableSyntax = SqliteColumnSchemaSyntax   type Sql92CreateTableTableConstraintSyntax SqliteCreateTableSyntax = SqliteTableConstraintSyntax   type Sql92CreateTableOptionsSyntax SqliteCreateTableSyntax = SqliteTableOptionsSyntax+  type Sql92CreateTableTableNameSyntax SqliteCreateTableSyntax = SqliteTableNameSyntax    createTableSyntax _ nm fields constraints =     let fieldDefs = map mkFieldDef fields@@ -462,7 +467,7 @@          createWithConstraints constraintDefs' =           SqliteCreateTableSyntax $-          emit "CREATE TABLE " <> quotedIdentifier nm <> parens (commas (fieldDefs <> constraintDefs'))+          emit "CREATE TABLE " <> fromSqliteTableName nm <> parens (commas (fieldDefs <> constraintDefs'))         normalCreateTable = createWithConstraints constraintDefs         createTableNoPkConstraint = createWithConstraints noPkConstraintDefs @@ -611,8 +616,9 @@   type Sql92FromTableSourceSyntax SqliteFromSyntax = SqliteTableSourceSyntax    fromTable tableSrc Nothing = SqliteFromSyntax (fromSqliteTableSource tableSrc)-  fromTable tableSrc (Just nm) =-    SqliteFromSyntax (fromSqliteTableSource tableSrc <> emit " AS " <> quotedIdentifier nm)+  fromTable tableSrc (Just (nm, colNms)) =+    SqliteFromSyntax (fromSqliteTableSource tableSrc <> emit " AS " <> quotedIdentifier nm <>+                      maybe mempty (\colNms' -> parens (commas (map quotedIdentifier colNms'))) colNms)    innerJoin = _join "INNER JOIN"   leftJoin = _join "LEFT JOIN"@@ -641,11 +647,16 @@     quotedIdentifier a  instance IsSql92TableSourceSyntax SqliteTableSourceSyntax where+  type Sql92TableSourceTableNameSyntax SqliteTableSourceSyntax = SqliteTableNameSyntax   type Sql92TableSourceSelectSyntax SqliteTableSourceSyntax = SqliteSelectSyntax+  type Sql92TableSourceExpressionSyntax SqliteTableSourceSyntax = SqliteExpressionSyntax -  tableNamed = SqliteTableSourceSyntax . quotedIdentifier+  tableNamed = SqliteTableSourceSyntax . fromSqliteTableName   tableFromSubSelect s =     SqliteTableSourceSyntax (parens (fromSqliteSelect s))+  tableFromValues vss = SqliteTableSourceSyntax . parens $+                        emit "VALUES " <>+                        commas (map (\vs -> parens (commas (map fromSqliteExpression vs))) vss)  instance IsSql92GroupingSyntax SqliteGroupingSyntax where   type Sql92GroupingExpressionSyntax SqliteGroupingSyntax = SqliteExpressionSyntax@@ -660,8 +671,6 @@   ascOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " ASC")   descOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " DESC") -instance IsSqlExpressionSyntaxStringType SqliteExpressionSyntax T.Text-instance IsSqlExpressionSyntaxStringType SqliteExpressionSyntax String instance HasSqlValueSyntax SqliteValueSyntax Int where   sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int8 where@@ -723,7 +732,7 @@   type Sql92ExpressionFieldNameSyntax SqliteExpressionSyntax = SqliteFieldNameSyntax   type Sql92ExpressionQuantifierSyntax SqliteExpressionSyntax = SqliteComparisonQuantifierSyntax   type Sql92ExpressionCastTargetSyntax SqliteExpressionSyntax = SqliteDataTypeSyntax-  type Sql92ExpressionExtractFieldSyntax SqliteExpressionSyntax = SqliteExtractFieldSyntax+  type Sql92ExpressionExtractFieldSyntax SqliteExpressionSyntax = ExtractField    addE = binOp "+"; subE = binOp "-"; mulE = binOp "*"; divE = binOp "/"   modE = binOp "%"; orE = binOp "OR"; andE = binOp "AND"; likeE = binOp "LIKE"@@ -771,9 +780,7 @@   upperE x = SqliteExpressionSyntax (emit "UPPER" <> parens (fromSqliteExpression x))   trimE x = SqliteExpressionSyntax (emit "TRIM" <> parens (fromSqliteExpression x))   coalesceE es = SqliteExpressionSyntax (emit "COALESCE" <> parens (commas (map fromSqliteExpression es)))-  extractE field from =-    SqliteExpressionSyntax $-    emit "EXTRACT" <> parens (fromSqliteExtractField field <> emit " FROM " <> parens (fromSqliteExpression from))+  extractE = sqliteExtract   castE e t = SqliteExpressionSyntax (emit "CAST" <> parens (parens (fromSqliteExpression e) <> emit " AS " <> fromSqliteDataType t))   caseE cases else_ =     SqliteExpressionSyntax $@@ -792,6 +799,12 @@     SqliteExpressionSyntax $ parens $     foldl (\a b -> a <> emit " || " <> parens (fromSqliteExpression b)) (fromSqliteExpression x) xs +instance IsSql99FunctionExpressionSyntax SqliteExpressionSyntax where+  functionCallE fn args =+    SqliteExpressionSyntax $+    fromSqliteExpression fn <> parens (commas (fmap fromSqliteExpression args))+  functionNameE nm = SqliteExpressionSyntax (emit (TE.encodeUtf8 nm))+ binOp :: ByteString -> SqliteExpressionSyntax -> SqliteExpressionSyntax -> SqliteExpressionSyntax binOp op a b =   SqliteExpressionSyntax $@@ -835,6 +848,7 @@   setQuantifierAll = SqliteAggregationSetQuantifierSyntax (emit "ALL")  instance IsSql92InsertSyntax SqliteInsertSyntax where+  type Sql92InsertTableNameSyntax SqliteInsertSyntax = SqliteTableNameSyntax   type Sql92InsertValuesSyntax SqliteInsertSyntax = SqliteInsertValuesSyntax    insertStmt = SqliteInsertSyntax@@ -847,12 +861,13 @@   insertFromSql = SqliteInsertFromSql  instance IsSql92UpdateSyntax SqliteUpdateSyntax where+  type Sql92UpdateTableNameSyntax SqliteUpdateSyntax = SqliteTableNameSyntax   type Sql92UpdateFieldNameSyntax SqliteUpdateSyntax = SqliteFieldNameSyntax   type Sql92UpdateExpressionSyntax SqliteUpdateSyntax = SqliteExpressionSyntax    updateStmt tbl fields where_ =     SqliteUpdateSyntax $-    emit "UPDATE " <> quotedIdentifier tbl <>+    emit "UPDATE " <> fromSqliteTableName tbl <>     (case fields of        [] -> mempty        _ -> emit " SET " <>@@ -860,11 +875,12 @@     maybe mempty (\where_ -> emit " WHERE " <> fromSqliteExpression where_) where_  instance IsSql92DeleteSyntax SqliteDeleteSyntax where+  type Sql92DeleteTableNameSyntax SqliteDeleteSyntax = SqliteTableNameSyntax   type Sql92DeleteExpressionSyntax SqliteDeleteSyntax = SqliteExpressionSyntax    deleteStmt tbl Nothing where_ =     SqliteDeleteSyntax $-    emit "DELETE FROM " <> quotedIdentifier tbl <>+    emit "DELETE FROM " <> fromSqliteTableName tbl <>     maybe mempty (\where_ -> emit " WHERE " <> fromSqliteExpression where_) where_   deleteStmt _ (Just _) _ =       error "beam-sqlite: invariant failed: DELETE must not have a table alias"@@ -878,40 +894,36 @@ commas [x] = x commas (x:xs) = x <> foldMap (emit ", " <>) xs +strftimeSyntax :: SqliteExpressionSyntax -> SqliteExpressionSyntax -> [ SqliteExpressionSyntax ] -> SqliteExpressionSyntax+strftimeSyntax fmt ts mods =+    functionCallE (SqliteExpressionSyntax (emit "strftime"))+                  (fmt:ts:mods)++-- | SQLite does not support @EXTRACT@ directly, but we can emulate+-- the behavior if we know which field we want.+sqliteExtract :: ExtractField -> SqliteExpressionSyntax -> SqliteExpressionSyntax+sqliteExtract field from =+    case field of+      ExtractFieldTimeZoneHour   -> error "sqliteExtract: TODO ExtractFieldTimeZoneHour"+      ExtractFieldTimeZoneMinute -> error "sqliteExtract: TODO ExtractFieldTimeZoneMinute"++      ExtractFieldDateTimeYear   -> extractStrftime "%Y"+      ExtractFieldDateTimeMonth  -> extractStrftime "%m"+      ExtractFieldDateTimeDay    -> extractStrftime "%d"+      ExtractFieldDateTimeHour   -> extractStrftime "%H"+      ExtractFieldDateTimeMinute -> extractStrftime "%M"+      ExtractFieldDateTimeSecond -> extractStrftime "%S"++    where+      extractStrftime :: String -> SqliteExpressionSyntax+      extractStrftime fmt = strftimeSyntax (valueE (sqlValueSyntax fmt)) from []+ sqliteSerialType :: SqliteDataTypeSyntax sqliteSerialType = SqliteDataTypeSyntax (emit "INTEGER PRIMARY KEY AUTOINCREMENT")                                         intType                                         (BeamSerializedDataType (beamSerializeJSON "sqlite" "serial"))                                         True -data SqliteHasDefault = SqliteHasDefault-instance FieldReturnType 'True 'False SqliteColumnSchemaSyntax resTy a =>-         FieldReturnType 'False 'False SqliteColumnSchemaSyntax resTy (SqliteHasDefault -> a) where-  field' _ _ nm ty _ collation constraints SqliteHasDefault =-    field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints--instance IsBeamSerialColumnSchemaSyntax SqliteColumnSchemaSyntax where-  genericSerial nm = field nm (DataType sqliteSerialType) SqliteHasDefault--instance HasDefaultSqlDataType SqliteDataTypeSyntax (SqlSerial Int) where-  defaultSqlDataType _ False = sqliteSerialType-  defaultSqlDataType _ True = intType-instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax (SqlSerial Int) where-  defaultSqlDataTypeConstraints _ _ _ = []--instance HasDefaultSqlDataType SqliteDataTypeSyntax ByteString where-  -- TODO we should somehow allow contsraints based on backend-  defaultSqlDataType _ _ = sqliteBlobType-instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax ByteString--instance HasDefaultSqlDataType SqliteDataTypeSyntax UTCTime where-  defaultSqlDataType _ _ = timestampType Nothing False-instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax UTCTime--instance HasDefaultSqlDataType SqliteDataTypeSyntax LocalTime where-  defaultSqlDataType _ _ = timestampType Nothing False-instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax LocalTime- instance HasSqlValueSyntax SqliteValueSyntax ByteString where   sqlValueSyntax bs = SqliteValueSyntax (emitValue (SQLBlob bs)) @@ -927,32 +939,5 @@   sqlValueSyntax tm = SqliteValueSyntax (emitValue (SQLText (fromString tmStr)))     where tmStr = formatTime defaultTimeLocale (iso8601DateFormat Nothing) tm --- * Equality checks-#define HAS_SQLITE_EQUALITY_CHECK(ty)                       \-  instance HasSqlEqualityCheck SqliteExpressionSyntax (ty); \-  instance HasSqlQuantifiedEqualityCheck SqliteExpressionSyntax (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)-HAS_SQLITE_EQUALITY_CHECK(Word64)-HAS_SQLITE_EQUALITY_CHECK(Double)-HAS_SQLITE_EQUALITY_CHECK(Float)-HAS_SQLITE_EQUALITY_CHECK(Bool)-HAS_SQLITE_EQUALITY_CHECK(String)-HAS_SQLITE_EQUALITY_CHECK(T.Text)-HAS_SQLITE_EQUALITY_CHECK(TL.Text)-HAS_SQLITE_EQUALITY_CHECK(B.ByteString)-HAS_SQLITE_EQUALITY_CHECK(BL.ByteString)-HAS_SQLITE_EQUALITY_CHECK(UTCTime)-HAS_SQLITE_EQUALITY_CHECK(LocalTime)-HAS_SQLITE_EQUALITY_CHECK(ZonedTime)-HAS_SQLITE_EQUALITY_CHECK(Char)-HAS_SQLITE_EQUALITY_CHECK(Integer)-HAS_SQLITE_EQUALITY_CHECK(Scientific)+instance HasDataTypeCreatedCheck SqliteDataTypeSyntax where+  dataTypeHasBeenCreated _ _ = True

@@ -1,6 +1,5 @@- name:                beam-sqlite-version:             0.3.2.4+version:             0.4.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>@@ -26,8 +25,8 @@   other-modules:      Database.Beam.Sqlite.SqliteSpecific   build-depends:      base          >=4.7  && <5, -                      beam-core     >=0.7  && <0.8,-                      beam-migrate  >=0.3  && <0.4,+                      beam-core     >=0.8  && <0.9,+                      beam-migrate  >=0.4  && <0.5,                        sqlite-simple >=0.4  && <0.5,                       text          >=1.0  && <1.3,