diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,239 +0,0 @@ -# Revision history for Selda - - -## 0.5.1.0 -- 2020-01-20 - -* Support for raw SQL fragments. (#134) -* Expose tableName. -* Document performance drawbacks of withoutForeignKeyEnforcement. -* Fix several bugs validating auto-incrementing PKs. (#133) - - -## 0.5.0.0 -- 2019-09-21 - -* index and indexUsing now accept a Group instead of a Selector (#121) -* Custom type errors for scope mismatches. -* Provide Generic instances for ID and RowID. -* Provide To/FromJSON instances for ID and RowID (selda-json). -* Add back MonadTrans instance for SeldaT. - - -## 0.4.0.0 -- 2019-06-02 - -* Type-safe support for backend-specific functionality. Top level query definitions now require explicit type signature. (#80) -* Native UUID support. (#47) -* Support JSON columns on all backends through aeson. -* Support JSON lookups (i.e. SELECT json_column.some_property FROM ...) on PostgreSQL. -* Multi-column primary key and uniqueness constraint support. (#25, #99) -* Switch to PostgreSQL binary protocol. (#18) -* Prevent dangerous user-defined SQL result instances. -* Expose backend internals through Database.Selda.Backend.Internal. (#109) -* Expose SQLite connection handle. (#101) -* Make MonadSelda more amenable to connection pooling. (#108) -* Add weakly auto-incrementing primary keys. (#94) -* Move compile* functions to Database.Selda.Debug. -* Remove half the tuple convenience functions. -* Remove in-process cache. (#117) -* Officially support GHC 8.6, 8.8 (SQLite only until postgres dependencies catch up with 8.8). -* Drop support for GHC 7.10. (#118) -* Manual (i.e. non record label) selectors are no longer exported by default; import Database.Selda.MakeSelectors is you need them. (#118) -* Update toolchain to use v2-style cabal commands. -* Fix date/time types for PostgreSQL. (#104) -* Fix bug when migrating tables with indexes. (#107) -* Misc. smaller bug fixes. - - -## 0.3.4.0 -- 2018-09-29 - -* Added convenience functions for working with nullable columns. - - -## 0.3.3.1 -- 2018-09-04 - -* DISTINCT should now always return distinct results. -* DISTINCT can no longer produce ill-scoped queries. - - -## 0.3.3.0 -- 2018-09-01 - -* Ad hoc selectors using OverloadedLabels. -* Shorter build times. -* Minor API updates and simplifications. - - -## 0.3.2.0 -- 2018-08-07 - -* Some aggregates are now nullable. -* sum_ on an empty table doesn't crash anymore. -* Aggregating over an empty selectValues doesn't crash anymore. - - -## 0.3.1.0 -- 2018-08-06 - -* Minor API fix when defining table attributes. - - -## 0.3.0.0 -- 2018-08-05 - -* Support for Stack and GHC 8.4. -* Precedence fix for selector index (!) operator. -* Accept INT and SMALLINT columns in user-created PostgreSQL tables. -* Add combinator for turning off foreign key checking. -* Rename unsafeRowId/unsafeId to toRowId/rowId. -* Add typed row identifiers. -* More generic type for sum_. -* Table validation against current database. -* Basic migration support. -* Basic index support. -* Remove ad hoc tables; only generic tables from now on. - - -## 0.2.0.0 -- 2018-04-02 - -* Support custom column names for generic tables. -* Scope safety fix for inner queries. -* Better type errors on GHC 8+ for inner queries. - - -## 0.1.12.1 -- 2018-02-27 - -* New PPConfig hook for more flexibility when compiling types. - - -## 0.1.12.0 -- 2018-01-11 - -* Allow recursive and optional foreign keys. -* Allow arbitrary enums in tables, represented as text. -* Fix RowID issues for PostgreSQL. -* Fix auto-incrementing primary keys for generic tables. - - -## 0.1.11.2 -- 2017-12-14 - -* Fix treatment of booleans in PostgreSQL backend. - - -## 0.1.11.1 -- 2017-10-10 - -* Fix rare infinite loop bug in in-process cache. - - -## 0.1.11.0 -- 2017-09-08 - -* Fix name generation in the presence of isIn over queries. -* SELECT DISTINCT support. -* Conditional expressions and matchNull. - - -## 0.1.10.1 -- 2017-08-11 - -* Fix name generation in the presence of multiple aggregates. - - -## 0.1.10.0 -- 2017-08-01 - -* Async exception safety. -* Allow MonadSelda instances not built on SeldaT. -* Chunk very large insertions on backends that request it (i.e. SQLite). -* GHC 8.2 support. - - -## 0.1.9.0 -- 2017-06-16 - -* Properly document semantics of order. -* Export conditional inserts. -* Fix Haste build for backends. - - -## 0.1.8.0 -- 2017-06-10 - -* Move SQL pretty-printing config into a single type. -* Support for binary blobs. -* Support for prepared statements. -* Support for connection reuse across Selda computations. -* Cleaner and more robust backend API. -* Stricter type constraints on comparisons. -* Allow limit on inner queries. -* Allow inspecting row identifiers. - - -## 0.1.7.0 -- 2017-05-17 - -* Add specialized insertUnless upsert variant. -* Fix potential race condition in upserts. -* Use abstract row identifier type for auto-incrementing primary keys. -* Less strict version bounds on dependencies. - - -## 0.1.6.0 -- 2017-05-07 - -* Conditional insert ("upsert") support. -* Support `SELECT x IN (SELECT ...)` and `SELECT x IN (a, b, ...)` queries. -* Explicit inner queries. -* Rename `inner` to `innerJoin`, more intuitive behavior for `suchThat`. -* Add `from` shorthand for `\s q -> fmap (!s) q`. -* Unique and foreign key constraints for generics. - - -## 0.1.5.0 -- 2017-05-05 - -* Inner join support. -* More sensible names in backend API. -* Fix rounding and casts. - - -## 0.1.4.1 -- 2017-05-04 - -* Fix cache consistency bug in the presence of multiple databases. - - -## 0.1.4.0 -- 2017-05-04 - -* Add uniqueness constraints and foreign keys. - - -## 0.1.3.3 -- 2017-05-04 - -* Fix cache invalidation race when using transactions. - - -## 0.1.3.2 -- 2017-05-01 - -* Only throw well-documented, Selda-specific exceptions. - - -## 0.1.3.1 -- 2017-05-01 - -* More Hackage-friendly README. - - -## 0.1.3.0 -- 2017-04-30 - -* Add selectors for non-generic tables. -* Allow default insertions on all columns. -* More sensible API for LIMIT. -* Fix broken SQL being generated for pathological corner cases. -* Documentation fixes. - - -## 0.1.2.0 -- 2017-04-20 - -* Replace `ยค` with `:*:` in table definitions. - - -## 0.1.1.1 -- 2017-04-20 - -* Minor documentation fixes. - - -## 0.1.1.0 -- 2017-04-20 - -* Generic tables, queries and mutation. -* Select from inline tables. -* Tutorial updates. -* Minor bugfixes. - - -## 0.1.0.0 -- 2017-04-14 - -* Initial release. diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -MIT License - -Copyright (c) 2017-2019 Anton Ekblad - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,148 +0,0 @@ -Selda -===== - -[![Join the chat at https://gitter.im/selda-hs/Lobby](https://badges.gitter.im/selda-hs/Lobby.svg)](https://gitter.im/selda-hs/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) -[![Hackage](https://img.shields.io/hackage/v/selda.svg?style=flat)](http://hackage.haskell.org/package/selda) -[![IRC channel](https://img.shields.io/badge/IRC-%23selda-1e72ff.svg?style=flat)](https://www.irccloud.com/invite?channel=%23selda&hostname=irc.freenode.net&port=6697&ssl=1) -![MIT License](http://img.shields.io/badge/license-MIT-brightgreen.svg) -[![Build Status](https://travis-ci.org/valderman/selda.svg?branch=master)](https://travis-ci.org/valderman/selda) -[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/selda.svg)](https://packdeps.haskellers.com/feed?needle=selda) - - -What is Selda? -============== -[Selda](https://selda.link) is a Haskell library for interacting with SQL-based relational databases. -It was inspired by [LINQ](https://en.wikipedia.org/wiki/Language_Integrated_Query) and -[Opaleye](http://hackage.haskell.org/package/opaleye). - - -Features -======== - -* Monadic interface. -* Portable: backends for SQLite and PostgreSQL. -* Generic: easy integration with your existing Haskell types. -* Creating, dropping and querying tables using type-safe database schemas. -* Typed query language with products, filtering, joins and aggregation. -* Inserting, updating and deleting rows from tables. -* Conditional insert/update. -* Transactions, uniqueness constraints and foreign keys. -* Type-safe, backend-specific functionality, such as JSON lookups. -* Seamless prepared statements. -* Lightweight and modular: few dependencies, and non-essential features are - optional or split into add-on packages. - - -Getting started -=============== - -Install the `selda` package from Hackage, as well as at least one of the -backends: - - $ cabal update - $ cabal install selda selda-sqlite selda-postgresql - -Then, read [the tutorial](https://selda.link/tutorial). -The [API documentation](http://hackage.haskell.org/package/selda) will probably -also come in handy. - - -Requirements -============ - -Selda requires GHC 8.0+, as well as SQLite 3.7.11+ or PostgreSQL 9.4+. -To build the SQLite backend, you need a C compiler installed. -To build the PostgreSQL backend, you need the `libpq` development libraries -installed (`libpq-dev` on Debian-based Linux distributions). - -Hacking -======= - -Contributing ------------- - -All forms of contributions are welcome! - -If you have a bug to report, please try to include as much information as -possible, preferably including: - -* A brief description (one or two sentences) of the bug. -* The version of Selda+backend where the bug was found. -* A step-by-step guide to reproduce the bug. -* The *expected* result from following these steps. -* What *actually* happens when following the steps. -* Which component contains the bug (selda, selda-sqlite or selda-postgresql), - if you're reasonably sure about where the bug is. - -Bonus points for a small code example that illustrates the problem. - -If you want to contribute code, please consult the following checklist before -sending a pull request: - -* Does the code build with a recent version of GHC? -* Do all the tests pass? -* Have you added any tests covering your code? - -If you want to contribute code but don't really know where to begin, -issues tagged [good first issue](https://github.com/valderman/selda/issues?q=is%3Aissue+is%3Aopen+label%3A%22good+first+issue%22) are a good start. - - -Setting up the build environment --------------------------------- - -From the repository root: - -* Install `libpq-dev` from your package manager. - This is required to build the PostgreSQL backend. -* Make sure you're running a cabal version that supports v2-style commands. -* Familiarise yourself with the various targets in the makefile. - The dependencies between Selda, the backends and the tests are slightly - complex, so straight-up cabal is too quirky for day to day hacking. - - -Setting up a VM for PostgreSQL testing --------------------------------------- - -While the SQLite backend is completely self-contained, the PostgreSQL backend -needs an appropriate server for testing. Setting this up in a virtual machine -is definitely less intrusive than setting up a server on your development -machine. To set up a VM for the PostgreSQL backend tests: - -* Install your favourite hypervisor, such as VMWare player or VirtualBox. -* Download a pre-built PostgreSQL VM from - [Bitnami](https://bitnami.com/stack/postgresql/virtual-machine). -* Import the OVA file into your hypervisor. -* Change the network settings of your newly imported VM to NAT, and make sure - that port 5432 is forwarded. Note that this will conflict with any PostgreSQL - server running on your machine while the VM is running. -* Boot your VM and note the password displayed on the login screen. -* Create the file `selda-tests/PGConnectInfo.hs` with the following content: - ```haskell - {-# LANGUAGE OverloadedStrings #-} - module PGConnectInfo where - import Database.Selda.PostgreSQL - - pgConnectInfo = "test" `on` "localhost" `auth` ("postgres", "$PASSWORD") - ``` - Where `$PASSWORD` is the password from the VM's login screen. -* Log in to the VM and disable the built-in firewall by running - `sudo systemctl disable ufw ; sudo systemctl stop ufw`. -* From your host machine, create the test database: - ``` - $ psql -h 127.0.0.1 -U postgres -W - [password from login screen] - # CREATE DATABASE test; - # \q - ``` -* Run `make pgtest` to check that everything works. - - -TODOs ------ - -Features that would be nice to have but are not yet implemented. - -* Monadic if/else -* Streaming -* MySQL/MariaDB backend -* MSSQL backend diff --git a/selda.cabal b/selda.cabal --- a/selda.cabal +++ b/selda.cabal @@ -1,5 +1,5 @@ name: selda -version: 0.5.1.0 +version: 0.5.2.0 synopsis: Multi-backend, high-level EDSL for interacting with SQL databases. description: This package provides an EDSL for writing portable, type-safe, high-level database code. Its feature set includes querying and modifying databases, @@ -7,23 +7,18 @@ support. See the project website for a comprehensive tutorial. - + To use this package you need at least one backend package, in addition to this package. There are currently two different backend packages: selda-sqlite and selda-postgresql. homepage: https://selda.link license: MIT -license-file: LICENSE author: Anton Ekblad maintainer: anton@ekblad.cc category: Database build-type: Simple -extra-source-files: ChangeLog.md cabal-version: >=1.10 -tested-with: GHC == 8.0.2, GHC == 8.4.1, GHC == 8.6.3, GHC == 8.8.1 - -extra-source-files: - README.md +tested-with: GHC == 8.8.2, GHC == 8.10.1, GHC == 9.0.2, GHC == 9.2.3 source-repository head type: git @@ -76,24 +71,18 @@ GeneralizedNewtypeDeriving FlexibleContexts build-depends: - base >=4.9 && <5 - , bytestring >=0.10 && <0.11 + base >=4.10 && <5 + , bytestring >=0.10 && <0.12 , exceptions >=0.8 && <0.11 , mtl >=2.0 && <2.3 , text >=1.0 && <1.3 - , time >=1.5 && <1.10 + , time >=1.5 && <1.12 , containers >=0.4 && <0.7 - , random >=1.1 && <1.2 + , random >=1.1 && <1.3 , uuid-types >=1.0 && <1.1 - if impl(ghc < 8.1) && impl(ghc >= 8.0) - build-depends: - ghc-prim >= 0.5.0.0 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - if impl(ghc > 8.0) - ghc-options: - -fno-warn-redundant-constraints diff --git a/src/Database/Selda.hs b/src/Database/Selda.hs --- a/src/Database/Selda.hs +++ b/src/Database/Selda.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables, TypeOperators, GADTs, FlexibleContexts #-} {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies, CPP #-} {-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Selda is not LINQ, but they're definitely related. -- -- Selda is a high-level EDSL for interacting with relational databases. @@ -31,7 +32,7 @@ , newUuid -- * Constructing queries - , SqlType (..), SqlRow (..), SqlEnum (..) + , SqlType (..), SqlRow (..), GSqlRow, SqlEnum (..) , Columns, Same , Order (..) , (:*:)(..) @@ -39,7 +40,7 @@ , restrict, limit , order, ascending, descending , orderRandom - , inner, suchThat + , union, unionAll, inner, suchThat -- * Working with selectors , Selector, Coalesce @@ -48,14 +49,16 @@ , (+=), (-=), (*=), (||=), (&&=), ($=) -- * Expressions over columns - , Set (..) + , Set (..), Monoid (..), Semigroup (..) , ID, invalidId, isInvalidId, untyped, fromId, toId + , IsUUID (..), UUID', typedUuid, untypedUuid , RowID, invalidRowId, isInvalidRowId, fromRowId, toRowId , (.==), (./=), (.>), (.<), (.>=), (.<=), like , (.&&), (.||), not_ , literal, is, int, float, text, true, false, null_ , roundTo, length_, isNull, ifThenElse, ifNull, matchNull - , new, only + , toUpper, toLower + , new, row, only , Mappable (..) -- * Converting between column types @@ -100,33 +103,137 @@ , Text, Day, TimeOfDay, UTCTime, UUID ) where import Control.Monad.Catch (MonadMask) -import Data.Typeable (Typeable) -import Database.Selda.Backend +import Data.Typeable ( Typeable, eqT, (:~:)(..) ) +import Database.Selda.Backend.Internal + ( SqlType(..), + SeldaM, + SeldaT, + MonadSelda(Backend), + SeldaError(..) ) +import Database.Selda.SqlType + ( UUID, + UUID'(..), + ID(..), + RowID, + SqlEnum(..), + invalidRowId, + isInvalidRowId, + toRowId, + fromRowId, + typedUuid, + toId, + fromId, + invalidId, + isInvalidId ) +import Database.Selda.Table.Type ( IndexMethod(..) ) +import Database.Selda.Types + ( TableName, + ColName, + Tup, + Head, + type (:*:)(..), + first, + second, + third, + fourth, + fifth ) import Database.Selda.Column + ( BinOp(Like, Eq, Neq, Gt, Lt, Gte, Lte, And, Or), + UnOp(Not, IsNull), + Exp(If, InQuery, InList, BinOp, UnOp), + UntypedCol(Untyped), + Same(..), + Row(..), + Col(..), + Columns, + literal, + liftC3, + liftC ) import Database.Selda.Compile + ( Result, Res, compQueryWithFreshScope ) import Database.Selda.FieldSelectors + ( IsLabel, HasField, FieldType ) import Database.Selda.Frontend + ( MonadIO(..), + query, + queryInto, + insert, + tryInsert, + upsert, + insertUnless, + insertWhen, + insert_, + insertWithPK, + update, + update_, + deleteFrom, + deleteFrom_, + createTable, + tryCreateTable, + dropTable, + tryDropTable, + transaction, + withoutForeignKeyEnforcement ) import Database.Selda.Generic + ( Generic, gRow, gNew, Relational, def ) import Database.Selda.Inner -import Database.Selda.Prepared + ( Aggregates, + LeftCols, + AggrCols, + OuterCols, + Inner, + Aggr, + liftAggr, + aggr ) +import Database.Selda.Prepared ( Prepare, Preparable, prepared ) import Database.Selda.Query -import Database.Selda.Query.Type + ( select, + selectValues, + union, + unionAll, + restrict, + aggregate, + leftJoin, + innerJoin, + groupBy, + limit, + order, + orderRandom, + distinct ) +import Database.Selda.Query.Type ( Query ) import Database.Selda.Selectors -import Database.Selda.SQL hiding (distinct) -import Database.Selda.SqlRow + ( Selector, Assignment(..), Coalesce, (!), (?), ($=), with ) +import Database.Selda.SQL ( Order(..) ) +import Database.Selda.SqlRow ( GSqlRow, SqlRow(..) ) import Database.Selda.Table -import Database.Selda.Table.Validation -import Database.Selda.Types -import Database.Selda.Unsafe -import Data.Proxy + ( Table(tableName), + ForeignKey(..), + Attribute, + SelectorLike, + Attr(..), + Group(..), + table, + tableFieldMod, + primary, + index, + indexUsing, + autoPrimary, + weakAutoPrimary, + untypedAutoPrimary, + weakUntypedAutoPrimary, + unique ) +import Database.Selda.Table.Validation ( ValidationError ) +import Database.Selda.Unsafe ( cast, fun, fun2, operator ) +import Data.Proxy ( Proxy(..) ) import Data.String (IsString) import Data.Text (Text) import Data.Time (Day, TimeOfDay, UTCTime) -import Data.Typeable (eqT, (:~:)(..)) import GHC.Generics (Rep) -import Unsafe.Coerce +import qualified GHC.Generics as G (from) +import Unsafe.Coerce ( unsafeCoerce ) import System.Random (randomIO) import GHC.TypeLits as TL + ( TypeError, ErrorMessage(Text, (:<>:), ShowType, (:$$:)) ) -- | Any column type that can be used with the 'min_' and 'max_' functions. class SqlType a => SqlOrd a @@ -167,14 +274,22 @@ fromSql = error "unreachable" defaultValue = error "unreachable" +-- | Any type which is backed by an UUID. +class IsUUID a where + uuid :: UUID -> a +instance IsUUID UUID where + uuid = id +instance IsUUID (UUID' a) where + uuid = typedUuid + -- | Generate a new random UUID using the system's random number generator. -- UUIDs generated this way are (astronomically likely to be) unique, -- but not necessarily unpredictable. -- -- For applications where unpredictability is crucial, take care to use a -- proper cryptographic PRNG to generate your UUIDs. -newUuid :: MonadIO m => m UUID -newUuid = liftIO randomIO +newUuid :: (MonadIO m, IsUUID uuid) => m uuid +newUuid = uuid <$> liftIO randomIO -- | Annotation to force the type of a polymorphic label (i.e. @#foo@) to -- be a selector. This is useful, for instance, when defining unique @@ -227,11 +342,19 @@ only :: SqlType a => Col s a -> Row s (Only a) only (One x) = Many [Untyped x] --- | Create a new column with the given fields. +-- | Create a new row with the given fields. -- Any unassigned fields will contain their default values. new :: forall s a. Relational a => [Assignment s a] -> Row s a new fields = Many (gNew (Proxy :: Proxy (Rep a))) `with` fields +-- | Create a new row from the given value. +-- This can be useful when you want to update all or most of a row: +-- +-- > update users (#uid `is` user_id) +-- > (\old -> row user_info `with` [...]) +row :: forall s a. Relational a => a -> Row s a +row x = Many (gRow (G.from x)) + -- | Convenient shorthand for @fmap (! sel) q@. -- The following two queries are quivalent: -- @@ -456,6 +579,22 @@ -- | Convert any SQL type to a string. toString :: SqlType a => Col s a -> Col s Text toString = cast + +-- | Convert the given string to uppercase. +toUpper :: Col s Text -> Col s Text +toUpper = fun "UPPER" + +-- | Convert the given string to lowercase. +toLower :: Col s Text -> Col s Text +toLower = fun "LOWER" + +instance Semigroup (Col s Text) where + (<>) = operator "||" +instance Monoid (Col s Text) where + mempty = "" + + + -- | Perform a conditional on a column ifThenElse :: (Same s t, Same t u, SqlType a) => Col s Bool -> Col t a -> Col u a -> Col s a diff --git a/src/Database/Selda/Backend.hs b/src/Database/Selda/Backend.hs --- a/src/Database/Selda/Backend.hs +++ b/src/Database/Selda/Backend.hs @@ -15,14 +15,69 @@ , runSeldaT, seldaClose , module SqlType ) where -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.IORef +import Control.Monad ( unless ) +import Control.Monad.Catch ( mask_ ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.IORef ( atomicModifyIORef' ) import Database.Selda.Backend.Internal + ( Param(..), + ColAttr(..), + AutoIncType(..), + isAutoPrimary, + isPrimary, + isUnique, + PPConfig(..), + defPPConfig, + SeldaM, + SeldaT, + MonadSelda(..), + SeldaBackend(..), + ColumnInfo(..), + TableInfo(..), + SeldaConnection(connClosed, connBackend), + QueryRunner, + StmtID, + SeldaError(..), + BackendID(..), + newConnection, + allStmts, + fromColInfo, + tableInfo, + withBackend, + runSeldaT ) import Database.Selda.SqlType as SqlType -import Database.Selda.Table (IndexMethod (..)) + ( UUID, + UUID'(..), + ID(..), + RowID, + SqlValue(..), + Lit(..), + SqlEnum(..), + SqlType(..), + SqlTypeRep(..), + sqlDateTimeFormat, + sqlDateFormat, + sqlTimeFormat, + litType, + compLit, + invalidRowId, + isInvalidRowId, + toRowId, + fromRowId, + typedUuid, + toId, + fromId, + invalidId, + isInvalidId ) +import Database.Selda.Table.Type ( IndexMethod(..) ) import Database.Selda.Types + ( TableName, + ColName, + fromColName, + fromTableName, + rawTableName, + mkColName, + mkTableName ) -- | Close a reusable Selda connection. -- Closing a connection while in use is undefined. diff --git a/src/Database/Selda/Backend/Internal.hs b/src/Database/Selda/Backend/Internal.hs --- a/src/Database/Selda/Backend/Internal.hs +++ b/src/Database/Selda/Backend/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures, CPP, TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, TypeFamilies #-} -- | Internal backend API. -- Using anything exported from this module may or may not invalidate any -- safety guarantees made by Selda; use at your own peril. @@ -20,23 +20,41 @@ import Data.List (nub) import Database.Selda.SQL (Param (..)) import Database.Selda.SqlType -import Database.Selda.Table hiding (colName, colType, colFKs) -import qualified Database.Selda.Table as Table (ColInfo (..)) + ( SqlValue(..), + Lit(..), + SqlType(..), + SqlTypeRep(..), + sqlDateTimeFormat, + sqlDateFormat, + sqlTimeFormat ) +import Database.Selda.Table.Type + ( ColAttr(..), + AutoIncType(..), + Table(Table, tableAttrs, tableName, tableCols), + isAutoPrimary, + isPrimary, + isUnique ) +import qualified Database.Selda.Table.Type as Table ( ColInfo(..) ) import Database.Selda.SQL.Print.Config + ( PPConfig(..), defPPConfig ) import Database.Selda.Types (TableName, ColName) -import Control.Concurrent +import Data.Int (Int64) +import Control.Concurrent ( newMVar, putMVar, takeMVar, MVar ) import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.State -import Data.Dynamic + ( Exception, bracket, MonadCatch, MonadMask, MonadThrow(..) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Reader + ( MonadTrans(..), when, ReaderT(..), MonadReader(ask) ) +import Data.Dynamic ( Typeable, Dynamic ) import qualified Data.IntMap as M import Data.IORef + ( IORef, atomicModifyIORef', newIORef, readIORef ) import Data.Text (Text) import System.IO.Unsafe (unsafePerformIO) -#if !MIN_VERSION_base(4, 13, 0) -import Control.Monad.Fail (MonadFail) -#endif + + + -- | Uniquely identifies some particular backend. -- -- When publishing a new backend, consider submitting a pull request with a @@ -126,8 +144,10 @@ -- | Comprehensive information about a table. data TableInfo = TableInfo - { -- | Ordered information about each table column. - tableColumnInfos :: [ColumnInfo] + { -- | Name of the table. + tableInfoName :: TableName + -- | Ordered information about each table column. + , tableColumnInfos :: [ColumnInfo] -- | Unordered list of all (non-PK) uniqueness constraints on this table. , tableUniqueGroups :: [[ColName]] -- | Unordered list of all primary key constraints on this table. @@ -167,7 +187,8 @@ -- | Get the column information for each column in the given table. tableInfo :: Table a -> TableInfo tableInfo t = TableInfo - { tableColumnInfos = map fromColInfo (tableCols t) + { tableInfoName = tableName t + , tableColumnInfos = map fromColInfo (tableCols t) , tableUniqueGroups = uniqueGroups , tablePrimaryKey = pkGroup } @@ -197,7 +218,7 @@ -- | Execute an SQL statement and return the last inserted primary key, -- where the primary key is auto-incrementing. -- Backends must take special care to make this thread-safe. - , runStmtWithPK :: Text -> [Param] -> IO Int + , runStmtWithPK :: Text -> [Param] -> IO Int64 -- | Prepare a statement using the given statement identifier. , prepareStmt :: StmtID -> [SqlTypeRep] -> Text -> IO Dynamic @@ -256,14 +277,14 @@ withBackend m = withConnection (m . connBackend) -- | Monad transformer adding Selda SQL capabilities. -newtype SeldaT b m a = S {unS :: StateT (SeldaConnection b) m a} +newtype SeldaT b m a = S {unS :: ReaderT (SeldaConnection b) m a} deriving ( Functor, Applicative, Monad, MonadIO , MonadThrow, MonadCatch, MonadMask , MonadFail ) instance (MonadIO m, MonadMask m) => MonadSelda (SeldaT b m) where type Backend (SeldaT b m) = b - withConnection m = S get >>= m + withConnection m = S ask >>= m instance MonadTrans (SeldaT b) where lift = S . lift @@ -286,4 +307,4 @@ closed <- liftIO $ readIORef (connClosed c) when closed $ do liftIO $ throwM $ DbError "runSeldaT called with a closed connection" - fst <$> runStateT (unS m) c + runReaderT (unS m) c diff --git a/src/Database/Selda/Column.hs b/src/Database/Selda/Column.hs --- a/src/Database/Selda/Column.hs +++ b/src/Database/Selda/Column.hs @@ -12,14 +12,22 @@ , literal ) where import Database.Selda.Exp -import Database.Selda.SQL -import Database.Selda.SqlType -import Database.Selda.SqlRow -import Database.Selda.Types -import Data.Proxy -import Data.String + ( Names(allNamesIn), + BinOp(..), + UnOp(..), + NulOp(..), + Exp(..), + UntypedCol(..), + SomeCol(..), + hideRenaming ) +import Database.Selda.SQL ( SQL ) +import Database.Selda.SqlType ( SqlType(mkLit) ) +import Database.Selda.SqlRow ( SqlRow(nestedCols) ) +import Database.Selda.Types ( type (:*:)(..), ColName ) +import Data.Proxy ( Proxy(..) ) +import Data.String ( IsString(..) ) import Data.Text (Text) -import GHC.TypeLits as TL +import GHC.TypeLits as TL ( TypeError, ErrorMessage(Text) ) -- | Any column tuple. class Columns a where diff --git a/src/Database/Selda/Compile.hs b/src/Database/Selda/Compile.hs --- a/src/Database/Selda/Compile.hs +++ b/src/Database/Selda/Compile.hs @@ -11,24 +11,34 @@ where import Control.Monad (liftM2) import Database.Selda.Column -import Database.Selda.Generic + ( UntypedCol(Untyped), + SomeCol(Some), + Row(..), + Col(..), + Columns(toTup) ) +import Database.Selda.Generic ( Relational, params ) import Database.Selda.Query.Type -import Database.Selda.SQL -import Database.Selda.SQL.Print + ( GenState(nameSupply), Query, Scope, runQueryM ) +import Database.Selda.SQL ( Param, SQL(SQL), SqlSource(Product) ) +import Database.Selda.SQL.Print ( compSql, compUpdate, compDelete ) import Database.Selda.SQL.Print.Config + ( PPConfig(ppMaxInsertParams), defPPConfig ) import Database.Selda.SqlRow -import Database.Selda.SqlType + ( SqlRow(nextResult), ResultReader, runResultReader, next ) +import Database.Selda.SqlType ( SqlValue, SqlType(fromSql) ) import Database.Selda.Table -import Database.Selda.Table.Compile + ( ColInfo(colName), Table(tableCols, tableName), tableExpr ) +import Database.Selda.Table.Compile ( compInsert ) import Database.Selda.Transform -import Database.Selda.Types -import Data.Proxy + ( removeDeadCols, implicitlyLiveCols, colNames, state2sql ) +import Database.Selda.Types ( type (:*:)(..) ) +import Data.Proxy ( Proxy(..) ) import Data.Text (Text, empty) import Data.Typeable (Typeable) -- For scope supply -import Data.IORef -import System.IO.Unsafe +import Data.IORef ( IORef, atomicModifyIORef', newIORef ) +import System.IO.Unsafe ( unsafePerformIO ) -- | Compile a query into a parameterised SQL statement. -- @@ -88,12 +98,12 @@ -- Groups are ignored, as they are only used by 'aggregate'. compQuery :: Result a => Scope -> Query s a -> (Int, SQL) compQuery ns q = - (nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing False) + (nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing [] False) where (cs, st) = runQueryM ns q final = finalCols cs sql = state2sql st - live = colNames final ++ allNonOutputColNames sql + live = colNames final ++ implicitlyLiveCols sql srcs = removeDeadCols live sql {-# NOINLINE scopeSupply #-} diff --git a/src/Database/Selda/Debug.hs b/src/Database/Selda/Debug.hs --- a/src/Database/Selda/Debug.hs +++ b/src/Database/Selda/Debug.hs @@ -5,6 +5,8 @@ , compileCreateTable, compileDropTable , compileInsert, compileUpdate ) where -import Database.Selda.Backend +import Database.Selda.SQL.Print.Config ( defPPConfig ) import Database.Selda.Compile + ( compile, compileInsert, compileUpdate ) import Database.Selda.Table.Compile + ( OnError(..), compileCreateTable, compileDropTable ) diff --git a/src/Database/Selda/Exp.hs b/src/Database/Selda/Exp.hs --- a/src/Database/Selda/Exp.hs +++ b/src/Database/Selda/Exp.hs @@ -1,9 +1,9 @@ {-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances #-} -{-# LANGUAGE TypeOperators, CPP, DataKinds #-} +{-# LANGUAGE CPP, DataKinds #-} -- | The expression type underlying 'Col'. module Database.Selda.Exp where -import Database.Selda.SqlType -import Database.Selda.Types +import Database.Selda.SqlType ( Lit, SqlTypeRep ) +import Database.Selda.Types ( ColName ) import Data.Text (Text) -- | A type-erased column, which may also be renamed. diff --git a/src/Database/Selda/FieldSelectors.hs b/src/Database/Selda/FieldSelectors.hs --- a/src/Database/Selda/FieldSelectors.hs +++ b/src/Database/Selda/FieldSelectors.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, KindSignatures, TypeOperators, PolyKinds #-} +{-# LANGUAGE DataKinds, TypeOperators, PolyKinds #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeFamilies #-} {-# LANGUAGE UndecidableInstances, ConstraintKinds, UndecidableSuperClasses #-} @@ -10,12 +10,14 @@ (FieldType, HasField, IsLabel ) where import Database.Selda.Generic (Relational) -import Database.Selda.Selectors as S +import Database.Selda.Selectors as S ( Selector, unsafeSelector ) import Database.Selda.SqlType (SqlType) import Data.Kind (Constraint) import GHC.Generics + ( Generic(Rep), K1, M1, type (:*:), S, Meta(MetaSel) ) import GHC.TypeLits -import GHC.OverloadedLabels + ( Symbol, TypeError, ErrorMessage(Text, (:<>:), ShowType) ) +import GHC.OverloadedLabels ( IsLabel(..) ) -- | Get the next nested type. type family GetFieldType (f :: * -> *) :: * where @@ -58,11 +60,11 @@ instance (Relational t, HasField name t, FieldType name t ~ a) => IsLabel name (S.Selector t a) where -#if MIN_VERSION_base(4, 10, 0) + fromLabel = field @name @t -#else - fromLabel _ = field @name @t -#endif + + + -- | Create a selector from a record selector and a type application. -- diff --git a/src/Database/Selda/Frontend.hs b/src/Database/Selda/Frontend.hs --- a/src/Database/Selda/Frontend.hs +++ b/src/Database/Selda/Frontend.hs @@ -11,19 +11,45 @@ , transaction, withoutForeignKeyEnforcement ) where import Database.Selda.Backend.Internal -import Database.Selda.Column + ( SqlValue, + Param, + SeldaT, + MonadSelda(..), + SeldaBackend(runStmtWithPK, disableForeignKeys, ppConfig, runStmt), + QueryRunner, + SeldaError(SqlError), + withBackend ) +import Database.Selda.Column ( Row, Col ) import Database.Selda.Compile -import Database.Selda.Generic -import Database.Selda.Query.Type + ( Result, + Res, + compileWith, + compileInsert, + compileUpdate, + compileDelete, + buildResult ) +import Database.Selda.Generic ( Relational ) +import Database.Selda.Query.Type ( Query ) import Database.Selda.SqlType (ID, invalidId, toId) -import Database.Selda.Table +import Database.Selda.Table.Type + ( Table(tableName, tableHasAutoPK) ) import Database.Selda.Table.Compile + ( OnError(..), + compileCreateTable, + compileCreateIndexes, + compileDropTable ) import Database.Selda.Types (fromTableName) -import Data.Proxy +import Data.Proxy ( Proxy(..) ) import Data.Text (Text) -import Control.Monad +import Control.Monad ( void ) import Control.Monad.Catch -import Control.Monad.IO.Class + ( bracket_, + onException, + try, + MonadCatch, + MonadMask(mask), + MonadThrow(throwM) ) +import Control.Monad.IO.Class ( MonadIO(..) ) -- | Run a query within a Selda monad. In practice, this is often a 'SeldaT' -- transformer on top of some other monad. diff --git a/src/Database/Selda/Generic.hs b/src/Database/Selda/Generic.hs --- a/src/Database/Selda/Generic.hs +++ b/src/Database/Selda/Generic.hs @@ -2,35 +2,39 @@ {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-} -{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds #-} +{-# LANGUAGE GADTs, CPP, DataKinds #-} -- | Generics utilities. module Database.Selda.Generic ( Relational, Generic - , tblCols, params, def, gNew + , tblCols, params, def, gNew, gRow ) where import Control.Monad.State -import Data.Dynamic + ( liftM2, MonadState(put, get), evalState, State ) +import Data.Dynamic ( Typeable ) import Data.Text as Text (Text, pack) -#if MIN_VERSION_base(4, 10, 0) -import Data.Typeable -#endif -import GHC.Generics hiding (R, (:*:), Selector) -import qualified GHC.Generics as G ((:*:)(..), Selector) + +import Data.Typeable ( Proxy(..), typeRep, typeRepTyCon ) + +import GHC.Generics + ( Generic(from, Rep), Selector(selName), K1(K1), M1(M1), S ) +import qualified GHC.Generics as G + ( (:*:)(..), Selector, (:+:)(..) ) import qualified GHC.TypeLits as TL -import qualified GHC.Generics as G ((:+:)(..)) import qualified Database.Selda.Column as C (Col) import Control.Exception (Exception (..), try, throw) -import System.IO.Unsafe -import Database.Selda.Types +import System.IO.Unsafe ( unsafePerformIO ) +import Database.Selda.Types ( ColName, modColName, mkColName ) import Database.Selda.SqlType + ( Lit, SqlType(sqlType, defaultValue, mkLit) ) import Database.Selda.SqlRow (SqlRow) import Database.Selda.Table.Type + ( ColAttr(Required, Optional), ColInfo(..) ) import Database.Selda.SQL (Param (..)) import Database.Selda.Exp (Exp (Col, Lit), UntypedCol (..)) -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif + + + -- | Any type which has a corresponding relation. -- To make a @Relational@ instance for some type, simply derive 'Generic'. -- @@ -85,10 +89,14 @@ -- | Create a new value with all default fields. gNew :: Proxy f -> [UntypedCol sql] + -- | Create a new row from the given value. + gRow :: f a -> [UntypedCol sql] + instance {-# OVERLAPPABLE #-} GRelation a => GRelation (M1 t c a) where gParams (M1 x) = gParams x gTblCols _ = gTblCols (Proxy :: Proxy a) gNew _ = gNew (Proxy :: Proxy a) + gRow (M1 x) = gRow x instance {-# OVERLAPPING #-} (G.Selector c, GRelation a) => GRelation (M1 S c a) where @@ -100,6 +108,7 @@ "" -> Nothing s -> Just (mkColName $ pack s) gNew _ = gNew (Proxy :: Proxy a) + gRow (M1 x) = gRow x instance (Typeable a, SqlType a) => GRelation (K1 i a) where gParams (K1 x) = do @@ -129,6 +138,7 @@ | otherwise = [Required] gNew _ = [Untyped (Lit (defaultValue :: Lit a))] + gRow (K1 x) = [Untyped (Lit (mkLit x))] instance (GRelation a, GRelation b) => GRelation (a G.:*: b) where gParams (a G.:*: b) = liftM2 (++) (gParams a) (gParams b) @@ -140,6 +150,7 @@ a = Proxy :: Proxy a b = Proxy :: Proxy b gNew _ = gNew (Proxy :: Proxy a) ++ gNew (Proxy :: Proxy b) + gRow (a G.:*: b) = gRow a ++ gRow b instance (TL.TypeError @@ -150,6 +161,7 @@ gParams = error "unreachable" gTblCols = error "unreachable" gNew = error "unreachable" + gRow = error "unreachable" instance {-# OVERLAPS #-} (TL.TypeError @@ -160,3 +172,4 @@ gParams = error "unreachable" gTblCols = error "unreachable" gNew = error "unreachable" + gRow = error "unreachable" diff --git a/src/Database/Selda/Inner.hs b/src/Database/Selda/Inner.hs --- a/src/Database/Selda/Inner.hs +++ b/src/Database/Selda/Inner.hs @@ -4,12 +4,13 @@ -- | Helpers for working with inner queries. module Database.Selda.Inner where import Database.Selda.Column + ( Exp(AggrEx), UntypedCol(..), Row, Col(..) ) import Database.Selda.SQL (SQL) import Database.Selda.SqlType (SqlType) -import Database.Selda.Types +import Database.Selda.Types ( type (:*:)(..) ) import Data.Text (Text) -import Data.Typeable -import GHC.TypeLits as TL +import Data.Typeable ( Typeable ) +import GHC.TypeLits as TL ( TypeError, ErrorMessage(Text, (:$$:)) ) -- | A single aggregate column. -- Aggregate columns may not be used to restrict queries. diff --git a/src/Database/Selda/MakeSelectors.hs b/src/Database/Selda/MakeSelectors.hs --- a/src/Database/Selda/MakeSelectors.hs +++ b/src/Database/Selda/MakeSelectors.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, TypeOperators, KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables, TypeOperators #-} {-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} -- | Utilities for creating selectors for non-record types. @@ -10,15 +10,16 @@ , selectors, tableWithSelectors ) where import Control.Monad.State.Strict -import Data.Proxy -import GHC.Generics hiding (Selector, (:*:)) + ( MonadState(state), State, evalState ) +import Data.Proxy ( Proxy(..) ) +import GHC.Generics ( Generic(Rep), K1, M1 ) import qualified GHC.Generics as G import Database.Selda.Generic (Relational) -import Database.Selda.Selectors -import Database.Selda.SqlRow -import Database.Selda.SqlType -import Database.Selda.Table -import Database.Selda.Types +import Database.Selda.Selectors ( Selector, unsafeSelector ) +import Database.Selda.SqlRow ( SqlRow ) +import Database.Selda.SqlType ( SqlType ) +import Database.Selda.Table ( Table, Attr, table ) +import Database.Selda.Types ( type (:*:)(..), TableName ) -- | Generate selector functions for the given table. -- Selectors can be used to access the fields of a query result tuple, avoiding diff --git a/src/Database/Selda/Migrations.hs b/src/Database/Selda/Migrations.hs --- a/src/Database/Selda/Migrations.hs +++ b/src/Database/Selda/Migrations.hs @@ -5,17 +5,26 @@ , migrate, migrateM, migrateAll, autoMigrate ) where import Control.Monad (void, when) -import Control.Monad.Catch -import Database.Selda hiding (from) -import Database.Selda.Frontend - ( OnError (..) - , createTableWithoutIndexes, createTableIndexes - ) +import Control.Monad.Catch ( MonadMask, MonadThrow(..) ) import Database.Selda.Backend.Internal -import Database.Selda.Table.Type (tableName) + ( MonadSelda(..), SeldaBackend(runStmt), withBackend ) +import Database.Selda.Column ( Row ) +import Database.Selda.Frontend + ( MonadIO(liftIO), + queryInto, + transaction, + withoutForeignKeyEnforcement, + OnError(..), + createTableWithoutIndexes, + createTableIndexes ) +import Database.Selda.Generic ( Relational ) +import Database.Selda.Query ( select ) +import Database.Selda.Query.Type ( Query ) +import Database.Selda.Table.Type ( Table(..) ) import Database.Selda.Table.Validation (ValidationError (..)) import Database.Selda.Types (mkTableName, fromTableName, rawTableName) import Database.Selda.Validation + ( TableDiff(TableOK), validateTable, validateSchema, diffTable ) -- | Wrapper for user with 'migrateAll', enabling multiple migrations to be -- packed into the same list: diff --git a/src/Database/Selda/Nullable.hs b/src/Database/Selda/Nullable.hs --- a/src/Database/Selda/Nullable.hs +++ b/src/Database/Selda/Nullable.hs @@ -7,10 +7,28 @@ , (?==), (?/=), (?>), (?<), (?>=), (?<=), (?+), (?-), (?*), (?/) ) where import Database.Selda + ( SqlType, + Same, + Row, + Col, + Selector, + Coalesce, + Query, + restrict, + SqlOrd, + (.==), + (./=), + (.>), + (.<), + (.>=), + (.<=), + isNull, + not_ ) import Database.Selda.Unsafe (cast) -import Database.Selda.Selectors +import Database.Selda.Selectors ( Selector(selectorIndex) ) import Database.Selda.Column -import Unsafe.Coerce + ( UntypedCol(Untyped), Row(Many), Col(One) ) +import Unsafe.Coerce ( unsafeCoerce ) -- | Two SQL types which are identical modulo nullability. type a :?~ b = diff --git a/src/Database/Selda/Prepared.hs b/src/Database/Selda/Prepared.hs --- a/src/Database/Selda/Prepared.hs +++ b/src/Database/Selda/Prepared.hs @@ -4,18 +4,32 @@ -- | Building and executing prepared statements. module Database.Selda.Prepared (Preparable, Prepare, prepared) where import Database.Selda.Backend.Internal -import Database.Selda.Column + ( Lit(LCustom), + SqlType(sqlType), + SqlTypeRep, + Param(..), + MonadSelda(Backend, withConnection), + SeldaBackend(ppConfig, runPrepared, backendId, prepareStmt), + SeldaConnection(connBackend, connStmts), + SeldaStmt(SeldaStmt, stmtHandle, stmtParams, stmtText), + StmtID(..), + BackendID, + freshStmtId, + withBackend ) +import Database.Selda.Column ( Exp(Lit), Col(..) ) import Database.Selda.Compile -import Database.Selda.Query.Type + ( Result, Res, compileWith, buildResult ) +import Database.Selda.Query.Type ( Query ) import Database.Selda.SQL (param, paramType) -import Control.Exception -import Control.Monad.IO.Class +import Control.Exception ( Exception, try, throw, mask ) +import Control.Monad.IO.Class ( MonadIO(liftIO) ) import qualified Data.IntMap as M import Data.IORef -import Data.Proxy + ( IORef, atomicModifyIORef', newIORef, readIORef, writeIORef ) +import Data.Proxy ( Proxy(..) ) import Data.Text (Text) -import Data.Typeable -import System.IO.Unsafe +import Data.Typeable ( Typeable ) +import System.IO.Unsafe ( unsafePerformIO ) data Placeholder = Placeholder Int deriving Show diff --git a/src/Database/Selda/Query.hs b/src/Database/Selda/Query.hs --- a/src/Database/Selda/Query.hs +++ b/src/Database/Selda/Query.hs @@ -1,23 +1,50 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Query monad and primitive operations. module Database.Selda.Query ( select, selectValues, Database.Selda.Query.distinct , restrict, groupBy, limit, order, orderRandom - , aggregate, leftJoin, innerJoin + , aggregate, leftJoin, innerJoin, union, unionAll ) where import Data.Maybe (isNothing) import Database.Selda.Column -import Database.Selda.Generic + ( NulOp(Fun0), + Exp(Lit, Col, NulOp), + SomeCol(Some, Named), + hideRenaming, + Same, + Row(..), + Col(..), + Columns(..) ) +import Database.Selda.Generic ( gNew, Relational, params ) import Database.Selda.Inner + ( Aggregates(..), + LeftCols, + AggrCols, + OuterCols, + Inner, + Aggr(Aggr) ) import Database.Selda.Query.Type + ( GenState(staticRestricts, groupCols, sources), + Query(..), + isolate, + renameAll, + freshName ) import Database.Selda.SQL as SQL + ( Param(Param), + Order(Asc), + SQL(liveExtras, cols, restricts, groups, limits, ordering, + distinct), + JoinType(..), + SqlSource(Product, TableName, EmptyTable, Values, Union, Join), + sqlFrom ) import Database.Selda.SqlType (SqlType) -import Database.Selda.Table -import Database.Selda.Transform -import Control.Monad.State.Strict -import Data.Proxy +import Database.Selda.Table.Type ( ColInfo(colExpr), Table(Table) ) +import Database.Selda.Transform ( colNames, state2sql, allCols ) +import Control.Monad.State.Strict ( MonadState(put, get), modify ) +import Data.Proxy ( Proxy(..) ) import GHC.Generics (Rep) -import Unsafe.Coerce +import Unsafe.Coerce ( unsafeCoerce ) -- | Query the given table. select :: Relational a => Table a -> Query s (Row s a) @@ -51,6 +78,39 @@ defToVal (Left x) = x defToVal (Right x) = x +internalUnion :: (Columns a, Columns (OuterCols a)) + => Bool + -> Query (Inner s) a + -> Query (Inner s) a + -> Query s (OuterCols a) +internalUnion union_all a b = Query $ do + (st_a, cols_a) <- isolate a + (st_b, cols_b) <- isolate b + renamed_a <- renameAll (fromTup cols_a) + renamed_b <- renameAll (fromTup cols_b) + let sql_a = (sqlFrom renamed_a (Product [state2sql st_a])) {liveExtras = renamed_a} + sql_b = (sqlFrom renamed_b (Product [state2sql st_b])) {liveExtras = renamed_b} + out_col_names = [n | Named n _ <- renamed_a] + out_cols = map (Some . Col) out_col_names + modify $ \st -> + st {sources = sqlFrom out_cols (Union union_all sql_a sql_b) : sources st} + return (toTup out_col_names) + +-- | The set union of two queries. Equivalent to the SQL @UNION@ operator. +union :: (Columns a, Columns (OuterCols a)) + => Query (Inner s) a + -> Query (Inner s) a + -> Query s (OuterCols a) +union = internalUnion False + +-- | The multiset union of two queries. +-- Equivalent to the SQL @UNION ALL@ operator. +unionAll :: (Columns a, Columns (OuterCols a)) + => Query (Inner s) a + -> Query (Inner s) a + -> Query s (OuterCols a) +unionAll = internalUnion True + -- | Restrict the query somehow. Roughly equivalent to @WHERE@. restrict :: Same s t => Col s Bool -> Query t () restrict (One p) = Query $ do @@ -225,8 +285,8 @@ => Query (Inner s) a -> Query s (OuterCols a) distinct q = Query $ do - (inner_st, res) <- isolate q + res <- unQ q st <- get - let ss = sources inner_st + let ss = sources st put st {sources = [(sqlFrom (allCols ss) (Product ss)) {SQL.distinct = True}]} return (unsafeCoerce res) diff --git a/src/Database/Selda/Query/Type.hs b/src/Database/Selda/Query/Type.hs --- a/src/Database/Selda/Query/Type.hs +++ b/src/Database/Selda/Query/Type.hs @@ -1,12 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, CPP #-} module Database.Selda.Query.Type where import Control.Monad.State.Strict -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif + ( StateT(StateT), MonadState(put, get), State, runState ) import Data.Text (pack) -import Database.Selda.SQL -import Database.Selda.Column +import Database.Selda.SQL ( SQL ) +import Database.Selda.Exp + ( Exp(Col), UntypedCol(..), SomeCol(Named) ) import Database.Selda.Types (ColName, mkColName, addColSuffix) type Scope = Int diff --git a/src/Database/Selda/SQL.hs b/src/Database/Selda/SQL.hs --- a/src/Database/Selda/SQL.hs +++ b/src/Database/Selda/SQL.hs @@ -1,16 +1,14 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, RecordWildCards #-} -{-# LANGUAGE TypeOperators, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE RankNTypes, CPP, MultiParamTypeClasses #-} -- | SQL AST and parameters for prepared statements. module Database.Selda.SQL where -import Data.String +import Data.String ( IsString(..) ) import Data.Text (Text) -import Database.Selda.Exp +import Database.Selda.Exp ( Names(..), Exp, SomeCol ) import Database.Selda.SqlType -import Database.Selda.Types -#if !MIN_VERSION_base(4, 11, 0) -import Data.Semigroup (Semigroup (..)) -#endif + ( Lit, SqlType(mkLit), SqlTypeRep, litType, compLit ) +import Database.Selda.Types ( TableName ) instance Semigroup QueryFragment where (<>) = RawCat @@ -27,6 +25,7 @@ data SqlSource = TableName !TableName | Product ![SQL] + | Union !Bool !SQL !SQL | Join !JoinType !(Exp SQL Bool) !SQL !SQL | Values ![SomeCol SQL] ![[Param]] | RawSql !QueryFragment @@ -37,13 +36,14 @@ -- | AST for SQL queries. data SQL = SQL - { cols :: ![SomeCol SQL] - , source :: !SqlSource - , restricts :: ![Exp SQL Bool] - , groups :: ![SomeCol SQL] - , ordering :: ![(Order, SomeCol SQL)] - , limits :: !(Maybe (Int, Int)) - , distinct :: !Bool + { cols :: ![SomeCol SQL] + , source :: !SqlSource + , restricts :: ![Exp SQL Bool] + , groups :: ![SomeCol SQL] + , ordering :: ![(Order, SomeCol SQL)] + , limits :: !(Maybe (Int, Int)) + , liveExtras :: ![SomeCol SQL] -- ^ Columns which are never considered dead. + , distinct :: !Bool } instance Names QueryFragment where @@ -58,6 +58,7 @@ allNamesIn (TableName _) = [] allNamesIn (RawSql r) = allNamesIn r allNamesIn (EmptyTable) = [] + allNamesIn (Union _ l r) = concatMap allNamesIn [l, r] instance Names SQL where -- Note that we don't include @cols@ here: the names in @cols@ are not @@ -79,6 +80,7 @@ , groups = [] , ordering = [] , limits = Nothing + , liveExtras = [] , distinct = False } diff --git a/src/Database/Selda/SQL/Print.hs b/src/Database/Selda/SQL/Print.hs --- a/src/Database/Selda/SQL/Print.hs +++ b/src/Database/Selda/SQL/Print.hs @@ -1,17 +1,24 @@ {-# LANGUAGE GADTs, OverloadedStrings, CPP #-} -- | Pretty-printing for SQL queries. For some values of pretty. module Database.Selda.SQL.Print where -import Database.Selda.Column +import Database.Selda.Exp + ( BinOp(..), UnOp(..), NulOp(..), Exp(..), SomeCol(..) ) import Database.Selda.SQL + ( Param(..), + Order(Desc, Asc), + SQL(SQL), + JoinType(InnerJoin, LeftJoin), + SqlSource(Union, EmptyTable, RawSql, TableName, Product, Values, + Join), + QueryFragment(..) ) import Database.Selda.SQL.Print.Config (PPConfig) import qualified Database.Selda.SQL.Print.Config as Cfg -import Database.Selda.SqlType +import Database.Selda.SqlType ( Lit(LJust, LNull), SqlTypeRep ) import Database.Selda.Types + ( TableName, ColName, fromColName, fromTableName ) import Control.Monad.State -import Data.List -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid hiding (Product) -#endif + ( liftM2, MonadState(get, put), runState, State ) +import Data.List ( group, sort ) import Data.Text (Text) import qualified Data.Text as Text @@ -107,7 +114,7 @@ -- | Pretty-print an SQL AST. ppSql :: SQL -> PP Text -ppSql (SQL cs src r gs ord lim dist) = do +ppSql (SQL cs src r gs ord lim _live dist) = do cs' <- mapM ppSomeCol cs src' <- ppSrc src r' <- ppRestricts r @@ -163,6 +170,16 @@ [ " FROM (", l', ") AS ", lqn , " ", ppJoinType jointype, " (", r', ") AS ", rqn , " ON ", on' + ] + ppSrc (Union union_all left right) = do + qs <- mapM ppSql [left, right] + qn <- freshQueryName + let union = if union_all then " UNION ALL " else " UNION " + pure $ mconcat + [ " FROM (" + , Text.intercalate union qs + , ") AS " + , qn ] ppJoinType LeftJoin = "LEFT JOIN" diff --git a/src/Database/Selda/SQL/Print/Config.hs b/src/Database/Selda/SQL/Print/Config.hs --- a/src/Database/Selda/SQL/Print/Config.hs +++ b/src/Database/Selda/SQL/Print/Config.hs @@ -2,8 +2,9 @@ module Database.Selda.SQL.Print.Config (PPConfig (..), defPPConfig) where import Data.Text (Text) import qualified Data.Text as T -import Database.Selda.SqlType -import Database.Selda.Table +import Database.Selda.SqlType ( SqlTypeRep(..) ) +import Database.Selda.Table.Type + ( IndexMethod, ColAttr(..), AutoIncType(Weak, Strong) ) -- | Backend-specific configuration for the SQL pretty-printer. data PPConfig = PPConfig @@ -70,8 +71,9 @@ defType :: SqlTypeRep -> Text defType TText = "TEXT" defType TRowID = "INTEGER" -defType TInt = "INT" -defType TFloat = "DOUBLE" +defType TInt32 = "INT" +defType TInt64 = "BIGINT" +defType TFloat = "DOUBLE PRECISION" defType TBool = "BOOLEAN" defType TDateTime = "DATETIME" defType TDate = "DATE" diff --git a/src/Database/Selda/Selectors.hs b/src/Database/Selda/Selectors.hs --- a/src/Database/Selda/Selectors.hs +++ b/src/Database/Selda/Selectors.hs @@ -5,10 +5,11 @@ , selectorIndex, unsafeSelector ) where import Database.Selda.SqlRow (SqlRow) -import Database.Selda.SqlType +import Database.Selda.SqlType ( SqlType ) import Database.Selda.Column + ( UntypedCol(Untyped), Row(..), Col(..) ) import Data.List (foldl') -import Unsafe.Coerce +import Unsafe.Coerce ( unsafeCoerce ) -- | Coalesce nested nullable column into a single level of nesting. type family Coalesce a where diff --git a/src/Database/Selda/SqlRow.hs b/src/Database/Selda/SqlRow.hs --- a/src/Database/Selda/SqlRow.hs +++ b/src/Database/Selda/SqlRow.hs @@ -1,17 +1,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds #-} {-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TypeOperators, DefaultSignatures, ScopedTypeVariables, CPP #-} -#if MIN_VERSION_base(4, 10, 0) {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -#endif module Database.Selda.SqlRow ( SqlRow (..), ResultReader + , GSqlRow , runResultReader, next ) where import Control.Monad.State.Strict + ( liftM2, + StateT(StateT), + MonadState(state, get), + State, + evalState ) import Database.Selda.SqlType -import Data.Typeable + ( SqlValue(SqlNull), SqlType(fromSql) ) +import Data.Typeable ( Typeable, Proxy(..) ) import GHC.Generics + ( Generic(Rep, to), K1(K1), M1(M1), type (:+:), type (:*:)(..) ) import qualified GHC.TypeLits as TL newtype ResultReader a = R (State [SqlValue] a) diff --git a/src/Database/Selda/SqlType.hs b/src/Database/Selda/SqlType.hs --- a/src/Database/Selda/SqlType.hs +++ b/src/Database/Selda/SqlType.hs @@ -3,20 +3,30 @@ -- | Types representable as columns in Selda's subset of SQL. module Database.Selda.SqlType ( SqlType (..), SqlEnum (..) - , Lit (..), UUID, RowID, ID, SqlValue (..), SqlTypeRep (..) + , Lit (..), UUID, UUID', RowID, ID, SqlValue (..), SqlTypeRep (..) , invalidRowId, isInvalidRowId, toRowId, fromRowId , fromId, toId, invalidId, isInvalidId, untyped , compLit, litType , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat + , typedUuid, untypedUuid ) where import Control.Applicative ((<|>)) +import Control.Exception (Exception (..), throw) import Data.ByteString (ByteString, empty) import qualified Data.ByteString.Lazy as BSL +import Data.Int (Int32, Int64) import Data.Maybe (fromJust) -import Data.Proxy +import Data.Proxy ( Proxy(..) ) import Data.Text (Text, pack, unpack) +import qualified Data.Text.Lazy as LazyText import Data.Time -import Data.Typeable + ( defaultTimeLocale, + parseTimeM, + Day(ModifiedJulianDay), + UTCTime(UTCTime), + ParseTime, + TimeOfDay(TimeOfDay) ) +import Data.Typeable ( Typeable ) import Data.UUID.Types (UUID, toString, fromByteString, nil) import GHC.Generics (Generic) @@ -42,7 +52,8 @@ data SqlTypeRep = TText | TRowID - | TInt + | TInt64 + | TInt32 | TFloat | TBool | TDateTime @@ -94,7 +105,8 @@ -- | An SQL literal. data Lit a where LText :: !Text -> Lit Text - LInt :: !Int -> Lit Int + LInt32 :: !Int32 -> Lit Int32 + LInt64 :: !Int64 -> Lit Int64 LDouble :: !Double -> Lit Double LBool :: !Bool -> Lit Bool LDateTime :: !UTCTime -> Lit UTCTime @@ -109,7 +121,8 @@ -- | The SQL type representation for the given literal. litType :: Lit a -> SqlTypeRep litType (LText{}) = TText -litType (LInt{}) = TInt +litType (LInt32{}) = TInt32 +litType (LInt64{}) = TInt64 litType (LDouble{}) = TFloat litType (LBool{}) = TBool litType (LDateTime{}) = TDateTime @@ -133,22 +146,24 @@ -- | Constructor tag for all literals. Used for Ord instance. litConTag :: Lit a -> Int litConTag (LText{}) = 0 -litConTag (LInt{}) = 1 -litConTag (LDouble{}) = 2 -litConTag (LBool{}) = 3 -litConTag (LDateTime{}) = 4 -litConTag (LDate{}) = 5 -litConTag (LTime{}) = 6 -litConTag (LJust{}) = 7 -litConTag (LBlob{}) = 8 -litConTag (LNull) = 9 -litConTag (LCustom{}) = 10 -litConTag (LUUID{}) = 11 +litConTag (LInt32{}) = 2 +litConTag (LInt64{}) = 3 +litConTag (LDouble{}) = 4 +litConTag (LBool{}) = 5 +litConTag (LDateTime{}) = 6 +litConTag (LDate{}) = 7 +litConTag (LTime{}) = 8 +litConTag (LJust{}) = 9 +litConTag (LBlob{}) = 10 +litConTag (LNull) = 11 +litConTag (LCustom{}) = 12 +litConTag (LUUID{}) = 13 -- | Compare two literals of different type for equality. compLit :: Lit a -> Lit b -> Ordering compLit (LText x) (LText x') = x `compare` x' -compLit (LInt x) (LInt x') = x `compare` x' +compLit (LInt32 x) (LInt32 x') = x `compare` x' +compLit (LInt64 x) (LInt64 x') = x `compare` x' compLit (LDouble x) (LDouble x') = x `compare` x' compLit (LBool x) (LBool x') = x `compare` x' compLit (LDateTime x) (LDateTime x') = x `compare` x' @@ -162,7 +177,8 @@ -- | Some value that is representable in SQL. data SqlValue where - SqlInt :: !Int -> SqlValue + SqlInt32 :: !Int32 -> SqlValue + SqlInt64 :: !Int64 -> SqlValue SqlFloat :: !Double -> SqlValue SqlString :: !Text -> SqlValue SqlBool :: !Bool -> SqlValue @@ -173,7 +189,8 @@ SqlNull :: SqlValue instance Show SqlValue where - show (SqlInt n) = "SqlInt " ++ show n + show (SqlInt32 n) = "SqlInt32 " ++ show n + show (SqlInt64 n) = "SqlInt64 " ++ show n show (SqlFloat f) = "SqlFloat " ++ show f show (SqlString s) = "SqlString " ++ show s show (SqlBool b) = "SqlBool " ++ show b @@ -185,7 +202,8 @@ instance Show (Lit a) where show (LText s) = show s - show (LInt i) = show i + show (LInt32 i) = show i + show (LInt64 i) = show i show (LDouble d) = show d show (LBool b) = show b show (LDateTime s) = show s @@ -199,7 +217,7 @@ -- | A row identifier for some table. -- This is the type of auto-incrementing primary keys. -newtype RowID = RowID Int +newtype RowID = RowID Int64 deriving (Eq, Ord, Typeable, Generic) instance Show RowID where show (RowID n) = show n @@ -215,11 +233,11 @@ -- | Create a row identifier from an integer. -- Use with caution, preferably only when reading user input. -toRowId :: Int -> RowID +toRowId :: Int64 -> RowID toRowId = RowID -- | Inspect a row identifier. -fromRowId :: RowID -> Int +fromRowId :: RowID -> Int64 fromRowId (RowID n) = n -- | A typed row identifier. @@ -232,14 +250,25 @@ instance Show (ID a) where show = show . untyped +-- | An UUID identifying a database row. +newtype UUID' a = UUID { untypedUuid :: UUID } + deriving (Eq, Ord, Typeable, Generic) +instance Show (UUID' a) where + show = show . untypedUuid + +-- | Convert an untyped UUID to a typed one. +-- Use sparingly, preferably only during deserialization. +typedUuid :: UUID -> UUID' a +typedUuid = UUID + -- | Create a typed row identifier from an integer. -- Use with caution, preferably only when reading user input. -toId :: Int -> ID a +toId :: Int64 -> ID a toId = ID . toRowId -- | Create a typed row identifier from an integer. -- Use with caution, preferably only when reading user input. -fromId :: ID a -> Int +fromId :: ID a -> Int64 fromId (ID i) = fromRowId i -- | A typed row identifier which is guaranteed to not match any row in any @@ -252,11 +281,19 @@ isInvalidId :: ID a -> Bool isInvalidId = isInvalidRowId . untyped +fromSqlError :: String -> a +fromSqlError = throw . FromSqlError + +newtype FromSqlError = FromSqlError String +instance Show FromSqlError where + show (FromSqlError e) = "[SELDA BUG] fromSql: " ++ e +instance Exception FromSqlError + instance SqlType RowID where - mkLit (RowID n) = LCustom TRowID (LInt n) + mkLit (RowID n) = LCustom TRowID (LInt64 n) sqlType _ = TRowID - fromSql (SqlInt x) = RowID x - fromSql v = error $ "fromSql: RowID column with non-int value: " ++ show v + fromSql (SqlInt64 x) = RowID x + fromSql v = fromSqlError $ "RowID column with non-int value: " ++ show v defaultValue = mkLit invalidRowId instance Typeable a => SqlType (ID a) where @@ -266,33 +303,56 @@ defaultValue = mkLit (ID invalidRowId) instance SqlType Int where - mkLit = LInt - sqlType _ = TInt - fromSql (SqlInt x) = x - fromSql v = error $ "fromSql: int column with non-int value: " ++ show v - defaultValue = LInt 0 + mkLit n = LCustom TInt64 (LInt64 $ fromIntegral n) + sqlType _ = TInt64 + fromSql (SqlInt64 x) = fromIntegral x + fromSql v = fromSqlError $ "int column with non-int value: " ++ show v + defaultValue = mkLit (0 :: Int) +instance SqlType Int64 where + mkLit = LInt64 + sqlType _ = TInt64 + fromSql (SqlInt64 x) = x + fromSql v = fromSqlError $ "int64 column with non-int value: " ++ show v + defaultValue = LInt64 0 + +instance SqlType Int32 where + mkLit = LInt32 + sqlType _ = TInt32 + fromSql (SqlInt32 x) = x + fromSql v = fromSqlError $ "int32 column with non-int value: " ++ show v + defaultValue = LInt32 0 + instance SqlType Double where mkLit = LDouble sqlType _ = TFloat fromSql (SqlFloat x) = x - fromSql v = error $ "fromSql: float column with non-float value: " ++ show v + fromSql v = fromSqlError $ "float column with non-float value: " ++ show v defaultValue = LDouble 0 instance SqlType Text where mkLit = LText sqlType _ = TText fromSql (SqlString x) = x - fromSql v = error $ "fromSql: text column with non-text value: " ++ show v + fromSql v = fromSqlError $ "text column with non-text value: " ++ show v defaultValue = LText "" +instance SqlType LazyText.Text where + mkLit = LCustom TText . LText . mconcat . LazyText.toChunks + sqlType _ = TText + fromSql (SqlString x) = LazyText.fromChunks [x] + fromSql v = fromSqlError $ "lazy text column with non-text value: " ++ show v + defaultValue = mkLit "" + instance SqlType Bool where mkLit = LBool sqlType _ = TBool - fromSql (SqlBool x) = x - fromSql (SqlInt 0) = False - fromSql (SqlInt _) = True - fromSql v = error $ "fromSql: bool column with non-bool value: " ++ show v + fromSql (SqlBool x) = x + fromSql (SqlInt32 0) = False + fromSql (SqlInt32 _) = True + fromSql (SqlInt64 0) = False + fromSql (SqlInt64 _) = True + fromSql v = fromSqlError $ "bool column with non-bool value: " ++ show v defaultValue = LBool False instance SqlType UTCTime where @@ -302,8 +362,8 @@ fromSql (SqlString s) = case withWeirdTimeZone sqlDateTimeFormat (unpack s) of Just t -> t - _ -> error $ "fromSql: bad datetime string: " ++ unpack s - fromSql v = error $ "fromSql: datetime column with non-datetime value: " ++ show v + _ -> fromSqlError $ "bad datetime string: " ++ unpack s + fromSql v = fromSqlError $ "datetime column with non-datetime value: " ++ show v defaultValue = LDateTime $ UTCTime (ModifiedJulianDay 40587) 0 instance SqlType Day where @@ -313,8 +373,8 @@ fromSql (SqlString s) = case parseTimeM True defaultTimeLocale sqlDateFormat (unpack s) of Just t -> t - _ -> error $ "fromSql: bad date string: " ++ unpack s - fromSql v = error $ "fromSql: date column with non-date value: " ++ show v + _ -> fromSqlError $ "bad date string: " ++ unpack s + fromSql v = fromSqlError $ "date column with non-date value: " ++ show v defaultValue = LDate $ ModifiedJulianDay 40587 instance SqlType TimeOfDay where @@ -324,8 +384,8 @@ fromSql (SqlString s) = case withWeirdTimeZone sqlTimeFormat (unpack s) of Just t -> t - _ -> error $ "fromSql: bad time string: " ++ unpack s - fromSql v = error $ "fromSql: time column with non-time value: " ++ show v + _ -> fromSqlError $ "bad time string: " ++ unpack s + fromSql v = fromSqlError $ "time column with non-time value: " ++ show v defaultValue = LTime $ TimeOfDay 0 0 0 -- | Both PostgreSQL and SQLite to weird things with time zones. @@ -341,14 +401,14 @@ mkLit = LBlob sqlType _ = TBlob fromSql (SqlBlob x) = x - fromSql v = error $ "fromSql: blob column with non-blob value: " ++ show v + fromSql v = fromSqlError $ "blob column with non-blob value: " ++ show v defaultValue = LBlob empty instance SqlType BSL.ByteString where mkLit = LCustom TBlob . LBlob . BSL.toStrict sqlType _ = TBlob fromSql (SqlBlob x) = BSL.fromStrict x - fromSql v = error $ "fromSql: blob column with non-blob value: " ++ show v + fromSql v = fromSqlError $ "blob column with non-blob value: " ++ show v defaultValue = LCustom TBlob (LBlob empty) -- | @defaultValue@ for UUIDs is the all-zero RFC4122 nil UUID. @@ -356,8 +416,15 @@ mkLit = LUUID sqlType _ = TUUID fromSql (SqlBlob x) = fromJust . fromByteString $ BSL.fromStrict x - fromSql v = error $ "fromSql: UUID column with non-blob value: " ++ show v + fromSql v = fromSqlError $ "UUID column with non-blob value: " ++ show v defaultValue = LUUID nil + +-- | @defaultValue@ for UUIDs is the all-zero RFC4122 nil UUID. +instance Typeable a => SqlType (UUID' a) where + mkLit = LCustom TUUID . LUUID . untypedUuid + sqlType _ = TUUID + fromSql = typedUuid . fromSql + defaultValue = LCustom TUUID (LUUID nil) instance SqlType a => SqlType (Maybe a) where mkLit (Just x) = LJust $ mkLit x diff --git a/src/Database/Selda/Table.hs b/src/Database/Selda/Table.hs --- a/src/Database/Selda/Table.hs +++ b/src/Database/Selda/Table.hs @@ -2,10 +2,8 @@ {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-} -{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds, MagicHash #-} -#if MIN_VERSION_base(4, 10, 0) +{-# LANGUAGE GADTs, CPP, DataKinds #-} {-# LANGUAGE TypeApplications #-} -#endif module Database.Selda.Table ( SelectorLike, Group (..), Attr (..), Table (..), Attribute , ColInfo (..), AutoIncType (..), ColAttr (..), IndexMethod (..) @@ -19,27 +17,26 @@ , isAutoPrimary, isPrimary, isUnique ) where import Data.Text (Text) -#if MIN_VERSION_base(4, 10, 0) -import Data.Typeable -#else -import Data.Proxy -import GHC.Prim -#endif -import Database.Selda.Types -import Database.Selda.Selectors -import Database.Selda.SqlType +import Data.Typeable ( Proxy(..) ) +import Database.Selda.Types ( type (:*:), TableName, ColName ) +import Database.Selda.Selectors ( Selector(..) ) +import Database.Selda.SqlType ( ID, RowID ) import Database.Selda.Column (Row (..)) -import Database.Selda.Generic +import Database.Selda.Generic ( Relational, tblCols ) import Database.Selda.Table.Type + ( IndexMethod(..), + ColAttr(..), + AutoIncType(..), + ColInfo(..), + Table(..), + isAutoPrimary, + isPrimary, + isUnique ) import Database.Selda.Table.Validation (snub) -import GHC.OverloadedLabels +import GHC.OverloadedLabels ( IsLabel(..) ) instance forall x t a. IsLabel x (Selector t a) => IsLabel x (Group t a) where -#if MIN_VERSION_base(4, 10, 0) fromLabel = Single (fromLabel @x) -#else - fromLabel _ = Single (fromLabel (proxy# :: Proxy# x)) -#endif -- | A non-empty list of selectors, where the element selectors need not have -- the same type. Used to specify constraints, such as uniqueness or primary diff --git a/src/Database/Selda/Table/Compile.hs b/src/Database/Selda/Table/Compile.hs --- a/src/Database/Selda/Table/Compile.hs +++ b/src/Database/Selda/Table/Compile.hs @@ -1,20 +1,32 @@ {-# LANGUAGE OverloadedStrings, CPP #-} -- | Generating SQL for creating and deleting tables. module Database.Selda.Table.Compile where -import Database.Selda.Table -import Database.Selda.Table.Validation +import Database.Selda.Table.Type + ( IndexMethod, + ColAttr(Indexed, Primary, Unique), + ColInfo(colFKs, colType, colName, colAttrs), + Table(Table, tableAttrs, tableName, tableCols), + isAutoPrimary ) +import Database.Selda.Table.Validation ( validateOrThrow ) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (foldl') -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif import Data.Text (Text, intercalate, pack) import qualified Data.Text as Text -import Database.Selda.SQL hiding (param,cols) +import Database.Selda.SQL ( Param ) import Database.Selda.SQL.Print.Config + ( PPConfig(ppIndexMethodHook, ppTypeHook, ppColAttrsHook, + ppColAttrs, ppTypePK, ppType, ppAutoIncInsert) ) import Database.Selda.SqlType (SqlTypeRep(..)) import Database.Selda.Types + ( TableName, + ColName, + modColName, + addColPrefix, + fromColName, + intercalateColNames, + fromTableName, + rawTableName ) data OnError = Fail | Ignore deriving (Eq, Ord, Show) diff --git a/src/Database/Selda/Table/Type.hs b/src/Database/Selda/Table/Type.hs --- a/src/Database/Selda/Table/Type.hs +++ b/src/Database/Selda/Table/Type.hs @@ -1,8 +1,8 @@ module Database.Selda.Table.Type where import Database.Selda.SqlType (SqlTypeRep) import Database.Selda.SQL (SQL) -import Database.Selda.Types -import Database.Selda.Exp +import Database.Selda.Types ( TableName, ColName ) +import Database.Selda.Exp ( UntypedCol ) -- | A database table, based on some Haskell data type. -- Any single constructor type can form the basis of a table, as long as diff --git a/src/Database/Selda/Table/Validation.hs b/src/Database/Selda/Table/Validation.hs --- a/src/Database/Selda/Table/Validation.hs +++ b/src/Database/Selda/Table/Validation.hs @@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings, CPP #-} module Database.Selda.Table.Validation where -import Control.Exception +import Control.Exception ( Exception, throw ) import Data.List (group, sort) import Data.Text (Text, any, intercalate, unpack) -import Data.Typeable +import Data.Typeable ( Typeable ) import Database.Selda.Table.Type + ( ColAttr(Required, Optional), + ColInfo(colFKs, colName, colAttrs), + Table(Table), + isPrimary, + isUnique ) import Database.Selda.Types -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif + ( TableName, fromColName, fromTableName ) -- | An error occurred when validating a database table. -- If this error is thrown, there is a bug in your database schema, and the @@ -42,7 +45,7 @@ | fromTableName name == "\"\"" = ["table name is empty"] | otherwise = [] emptyIdents - | Prelude.any (== "\"\"") colIdents = + | "\"\"" `elem` colIdents = ["table has columns with empty names"] | otherwise = [] @@ -54,7 +57,7 @@ dupes = ["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis] pkDupes = - if moreThanOne pkAttrs then ["multiple primary keys"] else [] + ["multiple primary keys" | moreThanOne pkAttrs] nonPkFks = [ "column is used as a foreign key, but is not primary or unique: " <> fromTableName ftn <> "." <> fromColName fcn diff --git a/src/Database/Selda/Transform.hs b/src/Database/Selda/Transform.hs --- a/src/Database/Selda/Transform.hs +++ b/src/Database/Selda/Transform.hs @@ -1,38 +1,44 @@ -- | Analysis and transformation of SQL queries. module Database.Selda.Transform where -import Database.Selda.Column +import Database.Selda.Exp + ( allNamesIn, Exp(Col, AggrEx), SomeCol(..) ) import Database.Selda.SQL -import Database.Selda.Query.Type -import Database.Selda.Types + ( SQL(SQL, groups, ordering, liveExtras, source, restricts, cols), + SqlSource(Product, EmptyTable, TableName, Values, RawSql, Union, + Join) ) +import Database.Selda.Query.Type ( GenState(GenState) ) +import Database.Selda.Types ( ColName ) -- | Remove all dead columns recursively, assuming that the given list of -- column names contains all names present in the final result. removeDeadCols :: [ColName] -> SQL -> SQL removeDeadCols live sql = case source sql' of - EmptyTable -> sql' - TableName _ -> sql' - Values _ _ -> sql' - RawSql _ -> sql' - Product qs -> sql' {source = Product $ map noDead qs} - Join jt on l r -> sql' {source = Join jt on (noDead l) (noDead r)} + EmptyTable -> sql' + TableName _ -> sql' + Values _ _ -> sql' + RawSql _ -> sql' + Product qs -> sql' {source = Product $ map noDead qs} + Join jt on l r -> sql' {source = Join jt on (noDead l) (noDead r)} + Union union_all l r -> sql' {source = Union union_all (noDead l) (noDead r)} where noDead = removeDeadCols live' - sql' = keepCols (allNonOutputColNames sql ++ live) sql + sql' = keepCols (implicitlyLiveCols sql ++ live) sql live' = allColNames sql' -- | Return the names of all columns in the given top-level query. -- Subqueries are not traversed. allColNames :: SQL -> [ColName] -allColNames sql = colNames (cols sql) ++ allNonOutputColNames sql +allColNames sql = colNames (cols sql) ++ implicitlyLiveCols sql -- | Return the names of all non-output (i.e. 'cols') columns in the given -- top-level query. Subqueries are not traversed. -allNonOutputColNames :: SQL -> [ColName] -allNonOutputColNames sql = concat +implicitlyLiveCols :: SQL -> [ColName] +implicitlyLiveCols sql = concat [ concatMap allNamesIn (restricts sql) , colNames (groups sql) , colNames (map snd $ ordering sql) + , colNames (liveExtras sql) , case source sql of Join _ on _ _ -> allNamesIn on _ -> [] @@ -69,7 +75,7 @@ state2sql (GenState [sql] srs _ _ _) = sql {restricts = restricts sql ++ srs} state2sql (GenState ss srs _ _ _) = - SQL (allCols ss) (Product ss) srs [] [] Nothing False + SQL (allCols ss) (Product ss) srs [] [] Nothing [] False -- | Get all output columns from a list of SQL ASTs. allCols :: [SQL] -> [SomeCol SQL] diff --git a/src/Database/Selda/Types.hs b/src/Database/Selda/Types.hs --- a/src/Database/Selda/Types.hs +++ b/src/Database/Selda/Types.hs @@ -11,8 +11,8 @@ , modColName, mkColName, mkTableName, addColSuffix, addColPrefix , fromColName, fromTableName, rawTableName, intercalateColNames ) where -import Data.Dynamic -import Data.String +import Data.Dynamic ( Typeable ) +import Data.String ( IsString ) import Data.Text (Text, replace, append, intercalate) import GHC.Generics (Generic) diff --git a/src/Database/Selda/Unsafe.hs b/src/Database/Selda/Unsafe.hs --- a/src/Database/Selda/Unsafe.hs +++ b/src/Database/Selda/Unsafe.hs @@ -10,9 +10,25 @@ ) where import Control.Exception (throw) import Control.Monad.State.Strict + ( MonadIO(liftIO), void, MonadState(put, get) ) import Database.Selda.Backend.Internal + ( SqlType(mkLit, sqlType), + MonadSelda, + SeldaBackend(runStmt, ppConfig), + SeldaError(UnsafeError), + withBackend ) import Database.Selda.Column -import Database.Selda.Exp (UntypedCol (..)) + ( BinOp(CustomOp), + UnOp(Fun), + NulOp(Fun0), + Exp(Col, Cast, UnOp, Fun2, BinOp, NulOp, Lit, Raw), + UntypedCol(Untyped), + SomeCol(Named), + hideRenaming, + Same(liftC2), + Row(..), + Col(..), + liftC ) import Database.Selda.Inner (Inner, Aggr, aggr, liftAggr) import Database.Selda.Selectors (unsafeSelector) import Database.Selda.Query.Type (Query (..), sources, renameAll, rename) @@ -21,8 +37,8 @@ import Database.Selda.SqlRow (SqlRow (..)) import Database.Selda.Types (ColName) import Data.Text (Text) -import Data.Proxy -import Unsafe.Coerce +import Data.Proxy ( Proxy(..) ) +import Unsafe.Coerce ( unsafeCoerce ) -- | Cast a column to another type, using whichever coercion semantics are used -- by the underlying SQL implementation. diff --git a/src/Database/Selda/Validation.hs b/src/Database/Selda/Validation.hs --- a/src/Database/Selda/Validation.hs +++ b/src/Database/Selda/Validation.hs @@ -7,22 +7,33 @@ , describeTable, diffTable, diffTables , validateTable, validateSchema ) where -import Control.Monad.Catch +import Control.Monad.Catch ( MonadThrow(..) ) import Data.List ((\\)) import Data.Maybe (catMaybes) -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid ((<>)) -#endif import Data.Text (pack, unpack, intercalate) import Database.Selda -import Database.Selda.Backend -import Database.Selda.Table.Type (tableName, tableCols) + ( Text, + MonadIO(liftIO), + TableName, + ColName, + Table(..), + MonadSelda ) +import Database.Selda.Backend.Internal + ( SqlTypeRep(TInt64, TRowID), + SeldaBackend(getTableInfo), + ColumnInfo(colType, colIsAutoPrimary, colIsNullable, colHasIndex, + colFKs, colName), + TableInfo(tableColumnInfos, tableUniqueGroups, tablePrimaryKey), + tableInfo, + withBackend ) +import Database.Selda.Types ( fromColName, fromTableName ) +import Database.Selda.Table.Type (tableCols) import Database.Selda.Table.Validation (ValidationError (..), validateOrThrow) -- | Are the given types compatible? isCompatibleWith :: SqlTypeRep -> SqlTypeRep -> Bool -isCompatibleWith TRowID TInt = True -isCompatibleWith TInt TRowID = True +isCompatibleWith TRowID TInt64 = True +isCompatibleWith TInt64 TRowID = True isCompatibleWith a b = a == b -- | Validate a table schema, and check it for consistency against the current @@ -227,7 +238,9 @@ (colFKs db \\ colFKs schema) ])) where - Right schemaColType = colType schema + schemaColType = case colType schema of + Right t -> t + Left t -> error $ "Selda has no idea what to make of this type: " ++ show t check :: Eq a => (ColumnInfo -> a) -> (a -> ColumnDiff)