selda 0.2.0.0 → 0.3.0.0

raw patch · 32 files changed

+1621/−1632 lines, 32 filesdep ~base

Dependency ranges changed: base

Files

• ChangeLog.md +15/−0
• LICENSE +18/−17
• README.md +4/−671
• selda.cabal +12/−5
• src/Database/Selda.hs +145/−98
• src/Database/Selda/Backend.hs +7/−1
• src/Database/Selda/Backend/Internal.hs +75/−9
• src/Database/Selda/Caching.hs +4/−4
• src/Database/Selda/Column.hs +41/−24
• src/Database/Selda/Compile.hs +36/−19
• src/Database/Selda/Exp.hs +20/−3
• src/Database/Selda/Frontend.hs +87/−57
• src/Database/Selda/Generic.hs +121/−270
• src/Database/Selda/Inner.hs +30/−19
• src/Database/Selda/Migrations.hs +133/−0
• src/Database/Selda/Prepared.hs +5/−3
• src/Database/Selda/Query.hs +38/−35
• src/Database/Selda/Query/Type.hs +9/−6
• src/Database/Selda/SQL.hs +3/−31
• src/Database/Selda/SQL/Print.hs +7/−2
• src/Database/Selda/SQL/Print/Config.hs +6/−0
• src/Database/Selda/Selectors.hs +87/−64
• src/Database/Selda/SqlRow.hs +90/−0
• src/Database/Selda/SqlType.hs +45/−13
• src/Database/Selda/Table.hs +173/−186
• src/Database/Selda/Table/Compile.hs +37/−14
• src/Database/Selda/Table/Foreign.hs +0/−30
• src/Database/Selda/Table/Type.hs +54/−0
• src/Database/Selda/Table/Validation.hs +94/−0
• src/Database/Selda/Types.hs +11/−48
• src/Database/Selda/Unsafe.hs +12/−3
• src/Database/Selda/Validation.hs +202/−0

@@ -1,6 +1,21 @@ # Revision history for Selda  +## 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.

@@ -1,20 +1,21 @@-Copyright (c) 2017 Anton Ekblad+MIT License -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:+Copyright (c) 2017-2018 Anton Ekblad -The above copyright notice and this permission notice shall be included-in all copies or substantial portions of the Software.+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 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.+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.

@@ -42,7 +42,7 @@     $ cabal update     $ cabal install selda selda-sqlite selda-postgresql -Then, read the tutorial.+Then, read [the tutorial](https://selda.link/tutorial). The [API documentation](http://hackage.haskell.org/package/selda) will probably also come in handy. @@ -50,675 +50,11 @@ Requirements ============ -Selda requires GHC 7.10+, as well as SQLite 3.7.11+ or PostgreSQL 9+.+Selda requires GHC 7.10+, as well as SQLite 3.7.11+ or PostgreSQL 9.6+. 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). --A brief tutorial-================--Defining a schema--------------------To work productively with Selda, you will need to enable the `TypeOperators` and-`OverloadedStrings` extensions.--Table schemas are defined as the product of one or more columns, stitched-together using the `:*:` operator.-A table is parameterized over the types of its columns, with the column types-also separated by the `:*:` operator. This, by the way, is why you need-`TypeOperators`.--```-people :: Table (Text :*: Int :*: Maybe Text)-people = table "people" $ primary "name" :*: required "age" :*: optional "pet"--addresses :: Table (Text :*: Text)-addresses = table "addresses" $ required "name" :*: required "city"-```--Columns may be either `required` or `optional`.-Although the SQL standard supports nullable primary keys, Selda primary keys-are always required.---Running queries------------------Selda operations are run in the `SeldaT` monad transformer, which can be layered-on top of any `MonadIO`. Throughout this tutorial, we will simply use the Selda-monad `SeldaM`, which is just a synonym for `SeldaT IO`.-`SeldaT` is entered using a backend-specific `withX` function. For instance,-the SQLite backend uses the `withSQLite` function:--```-main :: IO ()-main = withSQLite "my_database.sqlite" $ do-  people <- getAllPeople-  liftIO (print people)--getAllPeople :: SeldaM [Text :*: Int :*: Maybe Text]-getAllPeople = query (select people)-```--This will open the `my_database.sqlite` database for the duration of the-computation. If the computation terminates normally, or if it raises an-exception, the database is automatically closed.--Note the somewhat weird return type of `getAllPeople`. In Selda, queries are-represented using *inductive tuples*: a list of values, separated-by the `:*:` operator, but where each element can have a different type.-You can think of them as tuples with a slightly different syntax.-In this example, `getAllPeople` having a return type of-`[Text :*: Int :*: Maybe Text]` means that it returns a list of "3-tuples",-where the three elements have the types `Text`, `Int` and `Maybe Text`-respectively.--You can pattern match on these values as you would on normal tuples:--```-firstOfThree :: (a :*: b :*: c) -> a-firstOfThree (a :*: b :*: c) = a-```--Since inductive tuples are inductively defined, you may also choose to pattern-match on just the first few elements:--```-firstOfN :: (a :*: rest) -> a-firstOfN (a :*: _) = a-```--Throughout the rest of this tutorial, we will simply use inductive tuples as if-they were "normal" tuples.---Creating and deleting databases----------------------------------You can use a table definition to create the corresponding table in your-database backend, as well as delete it.--```-setup :: SeldaM ()-setup = do-  createTable people-  createTable addresses--teardown :: SeldaM ()-teardown = do-  tryDropTable people-  tryDropTable addresses-```--Both creating and deleting tables comes in two variants: the `try` version-which is a silent no-op when attempting to create a table that already exists-or delete one that doesn't, and the "plain" version which raises an error.---Inserting data-----------------Data insertion is done in batches. To insert a batch of rows, pass a list of-rows where each row is an inductive tuple matching the type of the table.-Optional values are encoded as `Maybe` values.--```-populate :: SeldaM ()-populate = do-  insert_ people-    [ "Link"      :*: 125 :*: Just "horse"-    , "Velvet"    :*: 19  :*: Nothing-    , "Kobayashi" :*: 23  :*: Just "dragon"-    , "Miyu"      :*: 10  :*: Nothing-    ]-  insert_ addresses-    [ "Link"      :*: "Kakariko"-    , "Kobayashi" :*: "Tokyo"-    , "Miyu"      :*: "Fuyukishi"-    ]-```--Insertions come in two variants: the "plain" version which reports back the-number of inserted rows, and one appended with an underscore which returns `()`.-Use the latter to explicitly indicate your intent to ignore the return value.--The following example inserts a few rows into a table with an-auto-incrementing primary key:--```-people' :: Table (RowID :*: Text :*: Int :*: Maybe Text)-people' = table "people_with_ids"-  $   autoPrimary "id"-  :*: required "name"-  :*: required "age"-  :*: optional "pet"--populate' :: SeldaM ()-populate' = do-  insert_ people'-    [ def :*: "Link"      :*: 125 :*: Just "horse"-    , def :*: "Velvet"    :*: 19  :*: Nothing-    , def :*: "Kobayashi" :*: 23  :*: Just "dragon"-    , def :*: "Miyu"      :*: 10  :*: Nothing-    ]-```--Note the use of the `def` value for the `id` field. This indicates that the-default value for the column should be used in lieu of any user-provided value.-Since the `id` field is an auto-incrementing primary key, it will automatically-be assigned a unique, increasing value.-Thus, the resulting table would look like this:--```-id | name      | age | pet------------------------------- 0 | Link      | 125 | horse- 1 | Velvet    | 19  |- 2 | Kobayashi | 23  | dragon- 3 | Miyu      | 10  |-```--Auto-incrementing primary keys must always have the type `RowID`.---Updating rows----------------To update a table, pass the table and two functions to the `update` function.-The first is a predicate over table columns. The second is a mapping over table -columns, specifying how to update each row. Only rows satisfying the predicate -are updated.--```-age10Years :: SeldaM ()-age10Years = do-  update_ people (\(name :*: _ :*: _) -> name ./= "Link")-                 (\(name :*: age :*: pet) -> name :*: age + 10 :*: pet)-```--Note that you can use arithmetic, logic and other standard SQL operations on-the columns in either function. Columns implement the appropriate numeric-type classes. For operations with less malleable types -- logic and-comparisons, for instance -- the standard Haskell operators are prefixed-with a period (`.`).---Deleting rows----------------Deleting rows is quite similar to updating them. The only difference is that-the `deleteFrom` operation takes a table and a predicate, specifying which rows-to delete.-The following example deletes all minors from the `people` table:--```-byeMinors :: SeldaM ()-byeMinors = deleteFrom_ people (\(_ :*: age :*: _) -> age .< 20)-```---Basic queries----------------Queries are written in the `Query` monad, in which you can query tables,-restrict the result set, and perform inner, aggregate queries.-Queries are executed in some Selda monad using the `query` function.--The following example uses the `select` operation to draw each row from the-`people` table, and the `restrict` operation to remove out all rows except-those having an `age` column with a value greater than 20.---```-grownups :: Query s (Col s Text)-grownups = do-  (name :*: age :*: _) <- select people-  restrict (age .> 20)-  return name--printGrownups :: SeldaM ()-printGrownups = do-  names <- query grownups-  liftIO (print names)-```--You may have noticed that in addition to the return type of a query,-the `Query` type has an additional type parameter `s`.-We'll cover this parameter in more detail when we get to-aggregating queries, so for now you can just ignore it.---Selector functions---------------------It's often annoying to explicitly take the tuples returned by queries apart.-For this reason, Selda provides a function `selectors` to generate-*selectors*: identifiers which can be used with the `!` operator to access-elements of inductive tuples similar to how record selectors are used to access-fields of standard Haskell record types.--Rewriting the previous example using selector functions:--```-name :*: age :*: pet = selectors people--grownups :: Query s (Col s Text)-grownups = do-  p <- select people-  restrict (p ! age .> 20)-  return (p ! name)--printGrownups :: SeldaM ()-printGrownups = do-  names <- query grownups-  liftIO (print names)-```--For added convenience, the `tableWithSelectors` function creates both a table-and its selector functions at the same time:--```-posts :: Table (RowID :*: Maybe Text :*: Text)-(posts, postId :*: author :*: content)-  =   tableWithSelectors "posts"-  $   autoPrimary "id"-  :*: optional "author"-  :*: required "content"--allAuthors :: Query s Text-allAuthors = do-  p <- select posts-  return (p ! author)-```--You can also use selectors with the `with` function to update columns in a tuple.-`with` takes a tuple and a list of *assignments*, where each assignment is a-selector-value pair. For each assignment, the column indicated by the selector-will be set to the corresponding value, on the given tuple.--```-grownupsIn10Years :: Query s (Col s Text)-grownupsIn10Years = do-  p <- select people-  let p' = p `with` [age := p ! age + 10]-  restrict (p' ! age .> 20)-  return (p' ! name)-```--Of course, selectors can be used for updates and deletions as well.--For the remainder of this tutorial, we'll keep matching on the tuples-explicitly.---Products and joins---------------------Of course, data can be drawn from multiple tables. The unfiltered result set-is essentially the cartesian product of all queried tables.-For this reason, `restrict` calls should be made as early as possible, to avoid-creating an unnecessarily large result set.--Arbitrary Haskell values can be injected into queries. As injected values are-passed as parameters to prepared statements under the hood, there is no need-to escape data; SQL injection is impossible by construction.--The following example uses data from two tables to find all grown-ups who-reside in Tokyo. Note the use of the `text` function, to convert a Haskell-`Text` value into an SQL column literal, as well as the use of `name .== name'`-to remove all elements from the result set where the name in the `people` table-does not match the one in the `addresses` table.--```-grownupsIn :: Text -> Query s (Col s Text)-grownupsIn city = do-  (name :*: age :*: _) <- select people-  restrict (age .> 20)-  (name' :*: home) <- select addresses-  restrict (home .== text city .&& name .== name')-  return name--printGrownupsInTokyo :: SeldaM ()-printGrownupsInTokyo = do-  names <- query (grownupsIn "Tokyo")-  liftIO (print names)-```--Also note that this is slightly different from an SQL join. If, for instance,-you wanted to get a list of all people and their addresses, you might do-something like this:--```-allPeople :: Query s (Col s Text :*: Col s Text)-allPeople = do-  (people_name :*: _ :*: _) <- select people-  (addresses_name :*: city) <- select addresses-  restrict (people_name .== addresses_name)-  return (people_name :*: city)-```--This will give you the list of everyone who has an address, resulting in the-following result set:--```-name      | city-----------------------Link      | Kakariko-Kobayashi | Tokyo-Miyu      | Fuyukishi-```--Note the absence of Velvet in this result set. Since there is no entry for-Velvet in the `addresses` table, there can be no entry in the product table-`people × addresses` where both `people_name` and `addresses_name` are equal-to `"Velvet"`. To produce a table like the above but with a `NULL` column for-Velvet's address (or for anyone else who does not have an entry in the-`addresses` table), you would have to use a join:--```-allPeople' :: Query s (Col s Text :*: Col s (Maybe Text))-allPeople' = do-  (name :*: _ :*: _) <- select people-  (_ :*: city) <- leftJoin (\(name' :*: _) -> name .== name')-                           (select addresses)-  return (name :*: city)-```--This gives us the result table we want:--```-name      | city-----------------------Link      | Kakariko-Velvet    |-Kobayashi | Tokyo-Miyu      | Fuyukishi--```--The `leftJoin` function left joins its query argument to the current result set-for all rows matching its predicate argument.-Note that all columns returned from the inner (or right) query are converted by-`leftJoin` into nullable columns. As there may not be a right counter part for-every element in the result set, SQL and Selda alike set any missing joined-columns to `NULL`.---Aggregate queries, grouping and sorting------------------------------------------You can also perform queries that sum, count, or otherwise aggregate their-result sets. This is done using the `aggregate` function.-This is where the additional type parameter to `Query` comes into play.-When used as an inner query, aggregate queries must not depend on any columns-from the outer query. To enforce this, the `aggregate` function forces all-operations to take place in the `Query (Inner s)` monad, if the outer query-takes place in the `Query s` monad. This ensures that aggregate inner queries-can only communicate with their outside query by returning some value.--Like in standard SQL, aggregate queries can be grouped by column name or by-some arbitrary expression.-An aggregate subquery must return at least one aggregate column, obtained using-`sum_`, `avg`, `count`, or one of the other provided aggregate functions.-Note that aggregate columns, having type `Aggr s a`, are different from normal-columns of type `Col s a`.-Since SQL does not allow aggregate functions in `WHERE` clauses, Selda prevents-them from being used in arguments to `restrict`.--The following example uses an aggregate query to calculate how many home each-person has, and order the result set with the most affluent homeowners at the-top.--```-countHomes :: Query s (Col s Text :*: Col s Int)-countHomes = do-  (name :*: _ :*: _) <- select people-  (owner :*: homes) <- aggregate $ do-    (owner :*: city) <- select addresses-    owner' <- groupBy owner-    return (owner' :*: count city)-  restrict (owner .== name)-  order homes descending-  return (owner :*: homes)-```--Note how `groupBy` returns an aggregate version of its argument, which can be-returned from the aggregate query. In this example, returning `owner` instead of-`owner'` wouldn't work since the former is a plain column and not an aggregate.---Transactions---------------All databases supported by Selda guarantee that each query is atomic: either-the entire query is performed in one go, with no observable intermediate state,-or the whole query fails without leaving a trace in the database.-However, sometimes this guarantee is not enough.-Consider, for instance, a money transfer from Alice's bank account to Bob's.-This involves at least two queries: one to remove the money from-Alice's account, and one to add the same amount to Bob's.-Clearly, it would be *bad* if this operation were to be interrupted after-withdrawing the money from Alice's account but before depositing it into Bob's.--The solution to this problem is *transactions*: a mechanism by which-*a list of queries* gain the same atomicity guarantees as a single query always-enjoys. Using transactions in Selda is super easy:--```-transferMoney :: Text -> Text -> Double -> SeldaM ()-transferMoney from to amount = do-  transaction $ do-    update_ accounts (\(owner :*: _) -> owner .== text from)-                     (\(owner :*: money) -> owner :*: money - float amount)-    update_ accounts (\(owner :*: _) -> owner .== text to)-                     (\(owner :*: money) -> owner :*: money + float amount)-```--This is all there is to it: pass the entire computation to the `transaction`-function, and the whole computation is guaranteed to either execute atomically,-or to fail without leaving a trace in the database.-If an exception is raised during the computation, it will of course be rolled-back.--Do be careful, however, to avoid performing IO within a query.-While they will not affect the atomicity of the computation as far as the-database is concerned, the computations themselves can obviously not be-rolled back.---In-process caching---------------------In many applications, read operations are orders of magnitude more common than-write operations. For such applications, it is often useful to *cache* the-results of a query, to avoid having the database perform the same, potentially-heavy, query over and over even though we *know* we'll get the same result-every time.--Selda supports automatic caching of query results out of the box.-However, it is turned off by default.-To enable caching, use the `setLocalCache` function.--```-main = withPostgreSQL connection_info $ do-  setLocalCache 1000-  ...-```--This will enable local caching of up to 1,000 different results.-When that limit is reached, the least recently used result will be discarded,-so the next request for that result will need to actually execute the query-on the database backend.-If caching was already enabled, changing the maximum number of cached results-will discard the cache's previous contents.-Setting the cache limit to 0 disables caching again.--To make sure that the cache is always consistent with the underlying database,-Selda keeps track of which tables each query depends on.-Whenever an insert, update, delete or drop is issued on a table `t`, all cached-queries that depend on `t` will be discarded.--This guarantees consistency between cache and database, but *only* under the-assumption that *no other process will modify the database*.-If this assumption does not hold for your application, you should avoid using-in-process caching.-It is perfectly fine, however, to have multiple *threads* within the same-application modifying the same database as long as they're all using Selda-to do it, as the cache is shared between all Selda computations-running in the same process.---Generic tables and queries-----------------------------Selda also supports building tables and queries from (almost) arbitrary-data types, using the `Database.Selda.Generic` module.-Re-implementing the ad hoc `people` and `addresses` tables from before in a-more disciplined manner in this way is quite easy:--```-data Person = Person-  { personName :: Text-  , age        :: Int-  , pet        :: Maybe Int-  } deriving Generic--data Address = Address-  { addrName :: Text-  , city     :: Text-  } deriving Generic---people :: GenTable Person-people = genTable "people" [personName :- primaryGen]--addresses :: GenTable Address-addresses = genTable "addresses" [personName :- primaryGen]-```--This will declare two tables with the same structure as their ad hoc-predecessors. Creating the tables is similarly easy:--```-create :: SeldaM ()-create = do-  createTable (gen people)-  createTable (gen addresses)-```--Note the use of the `gen` function here, to extract the underlying table of-columns from the generic table.--However, queries over generic tables aren't magic; they still consist of the-same collections of columns as queries over non-generic tables.--```-genericGrownups2 :: Query s (Col s Text)-genericGrownups2 = do-  (name :*: age :*: _) <- select (gen people)-  restrict (age .> 20)-  return name-```--Finally, with generics it's also quite easy to re-assemble Haskell objects-from the results of a query using the `fromRel` function.--```-getPeopleOfAge :: Int -> SeldaM [Person]-getPeopleOfAge yrs = do-  ps <- query $ do-    (name :*: age :*: _) <- select (gen people)-    restrict (age .== yrs)-    return p-  return (map fromRel ps)-```---Prepared statements----------------------While Selda makes use of prepared statements internally to ensure that any and-all input is safely escaped, it does not reuse those statements by default.-Every query is recompiler and replanned each time it is executed.-To improve the performance of your code, you should make use of the `prepared`-function, to mark performance-critical queries as reusable.--The `prepared` function converts any function `f` in the `Query` monad into an-equivalent function `f'` in some `MonadSelda`, provided that all of `f`'s-arguments are column expressions.-When `f'` is called for the first time during a connection to a database, it-automatically gets compiled, prepared and cached before being executed.-Any subsequent calls to `f'` from the same connection will reuse the prepared-version.--Note that since most database engines don't allow prepared statements to persist-across connections, a previously cached statement will get prepared once more if-called from another connection.--As an example, we modify the `grownupsIn` function we saw earlier to use prepared-statements.--```-preparedGrownupsIn :: Text -> SeldaM [Text]-preparedGrownupsIn = prepared $ \city -> do-  (name :*: age :*: _) <- select people-  restrict (age .> 20)-  (name' :*: home) <- select addresses-  restrict (home .== city .&& name .== name')-  return name-```--Note that the type of the `city` argument is `Col s Text` within the query, but-when *calling* `preparedGrownupsIn`, we instead pass in a value of type `Text`;-for convenience, `prepared` automatically converts all arguments to-prepared functions into their equivalent column types.---Foreign keys---------------To add a foreign key constraint on a column, use the `fk` function.-This function takes two parameters: a column of the table being defined, and-a tuple of the `(table, column)` the foreign key refers to.-The table identifier is simply a value of type `Table t`, while the column-is specified using a selector of type `Selector t a`.--The following example creates a table to store users, and one to store blog-posts. The `users` table stores a name, a password, and a unique identifier-for each user.-The `posts` table stores, for each post, the post body, a unique-post identifier, and the identifier of the user who wrote the post.-The column storing a post's author has a foreign key constraint on the `userid`-column of the `users` table, to ensure that each post has a valid author.--```-users :: Table (RowID :*: Text)-users = table "users"-  $   primary "userid"-  :*: required "username"-  :*: required "password"-(userId :*: userName :*: userPass) = selectors users--posts :: Table (RowID :*: RowID :*: Text)-posts = table "posts"-  $   primary "postid"-  :*: required "authorid" `fk` (users, userId)-  :*: required "post_body"-```--Note that a foreign key can *only* refer to a column which is either-a primary key or has a unique constraint. This is not specific to Selda, but-a restriction of SQL.--And with that, we conclude this tutorial. Hopefully it has been enough to get-you comfortably started using Selda.-For a more detailed API reference, please see Selda's-[Haddock documentation](http://hackage.haskell.org/package/selda).-- Hacking ======= @@ -780,7 +116,7 @@     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@@ -807,9 +143,6 @@  * Monadic if/else. * Streaming-* Type-safe migrations-* `SELECT INTO`.-* Database schema upgrades.-* Stack build. * MySQL/MariaDB backend.+* MSSQL backend. * Automatically sanity check changelog, versions and date before release.

@@ -1,12 +1,12 @@ name:                selda-version:             0.2.0.0+version:             0.3.0.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,                      automatic, in-process caching with consistency guarantees, and transaction                      support. -                     See the package readme for a brief usage tutorial.+                     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:@@ -20,7 +20,7 @@ build-type:          Simple extra-source-files:  ChangeLog.md cabal-version:       >=1.10-tested-with:         GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1+tested-with:         GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1  extra-source-files:   README.md@@ -46,8 +46,9 @@   exposed-modules:     Database.Selda     Database.Selda.Backend-    Database.Selda.Generic+    Database.Selda.Migrations     Database.Selda.Unsafe+    Database.Selda.Validation   other-modules:     Database.Selda.Backend.Internal     Database.Selda.Caching@@ -55,6 +56,7 @@     Database.Selda.Compile     Database.Selda.Exp     Database.Selda.Frontend+    Database.Selda.Generic     Database.Selda.Inner     Database.Selda.Prepared     Database.Selda.Query@@ -63,10 +65,12 @@     Database.Selda.SQL     Database.Selda.SQL.Print     Database.Selda.SQL.Print.Config+    Database.Selda.SqlRow     Database.Selda.SqlType     Database.Selda.Table     Database.Selda.Table.Compile-    Database.Selda.Table.Foreign+    Database.Selda.Table.Type+    Database.Selda.Table.Validation     Database.Selda.Transform     Database.Selda.Types   other-extensions:@@ -108,3 +112,6 @@     Haskell2010   ghc-options:     -Wall+  if impl(ghc > 8.0)+    ghc-options:+      -fno-warn-redundant-constraints

@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables, TypeOperators, GADTs, FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies, CPP #-}+{-# LANGUAGE DataKinds #-} -- | Selda is not LINQ, but they're definitely related. -- --   Selda is a high-level EDSL for interacting with relational databases.@@ -15,75 +17,38 @@ --   This includes database connection errors, uniqueness constraint errors, --   etc. -----   The following example shows off Selda's most basic features -- creating,---   populating, modifying and querying tables -- and is intended to act as a---   Hello World-ish quickstart.------ > {-# LANGUAGE TypeOperators, OverloadedStrings #-}--- > import Data.Text (Text, unpack)--- > import Database.Selda--- > import Database.Selda.SQLite--- >--- > people :: Table (Text :*: Int :*: Maybe Text)--- > (people, pName :*: pAge :*: pPet)--- >   = tableWithSelectors "people"--- >   $   primary "name"--- >   :*: required "age"--- >   :*: optional "pet"--- >--- > main = withSQLite "people.sqlite" $ do--- >   createTable people--- >--- >   insert_ people--- >     [ "Velvet"    :*: 19 :*: Nothing--- >     , "Kobayashi" :*: 23 :*: Just "dragon"--- >     , "Miyu"      :*: 10 :*: Nothing--- >     ]--- >--- >   update_ people--- >     (\person -> person ! pName .== "Velvet")--- >     (\person -> person `with` [pPet := just "orthros"])--- >--- >   adults <- query $ do--- >     person <- select people--- >     restrict (person ! pAge .> 20)--- >     return (person ! pName :*: person ! pAge)--- >--- >   n <- deleteFrom people (\person -> isNull (person ! pPet))--- >--- >   liftIO $ do--- >     putStrLn "The adults in the room are:"--- >     mapM_ printPerson adults--- >     putStrLn $ show n ++ " people were deleted for having no pets."--- >--- > printPerson :: Text :*: Int -> IO ()--- > printPerson (name :*: age) = putStrLn $ unpack name ++ ", age " ++ show age------   Please see <http://hackage.haskell.org/package/selda/#readme>---   for a more comprehensive tutorial.+--   See <https://selda.link/tutorial> for a tutorial covering the language+--   basics. module Database.Selda   ( -- * Running queries     MonadSelda   , SeldaError (..), ValidationError-  , SeldaT, SeldaM, Table, Query, Col, Res, Result-  , query, transaction, setLocalCache+  , SeldaT, SeldaM+  , Relational, Only (..), The (..)+  , Table, Query, Row, Col, Res, Result+  , query, queryInto+  , transaction, setLocalCache, withoutForeignKeyEnforcement     -- * Constructing queries-  , Selector, (!), Assignment(..), with-  , SqlType (..), SqlEnum (..)-  , Cols, Columns+  , Selector, Source, Selected, (!), Assignment ((:=)), with+  , (+=), (-=), (*=), (||=), (&&=), ($=)+  , SqlType (..), SqlRow (..), SqlEnum (..)+  , Columns   , Order (..)   , (:*:)(..)   , select, selectValues, from, distinct   , restrict, limit-  , order , ascending, descending+  , order, ascending, descending+  , orderRandom   , inner, suchThat     -- * Expressions over columns   , Set (..)-  , RowID, invalidRowId, isInvalidRowId, fromRowId+  , ID, invalidId, isInvalidId, untyped, toId+  , RowID, invalidRowId, isInvalidRowId, fromRowId, toRowId   , (.==), (./=), (.>), (.<), (.>=), (.<=), like   , (.&&), (.||), not_   , literal, int, float, text, true, false, null_   , roundTo, length_, isNull, ifThenElse, matchNull+  , new, only     -- * Converting between column types   , round_, just, fromBool, fromInt, toString     -- * Inner queries@@ -92,7 +57,6 @@   , aggregate, groupBy   , count, avg, sum_, max_, min_     -- * Modifying tables-  , Insert   , insert, insert_, insertWithPK, tryInsert, insertUnless, insertWhen, def   , update, update_, upsert   , deleteFrom, deleteFrom_@@ -100,17 +64,15 @@   , Preparable, Prepare   , prepared     -- * Defining schemas-  , TableSpec, ColSpecs, ColSpec, TableName, ColName-  , NonNull-  , Append (..), (:++:)-  , Selectors, HasSelectors-  , table, tableWithSelectors, selectors-  , required, optional-  , primary, autoPrimary-  , fk, optFk, unique+  , Generic+  , TableName, ColName, Attr (..), Attribute+  , Selectors, ForeignKey (..)+  , table, tableFieldMod, tableWithSelectors, selectors+  , primary, autoPrimary, untypedAutoPrimary, unique+  , IndexMethod (..), index, indexUsing     -- * Creating and dropping tables   , createTable, tryCreateTable-  , validateTable, dropTable, tryDropTable+  , dropTable, tryDropTable     -- * Compiling and inspecting queries   , OnError (..)   , compile@@ -123,44 +85,128 @@   , MonadIO, liftIO   , Text, Day, TimeOfDay, UTCTime   ) where+import Data.Typeable (Typeable) import Database.Selda.Backend import Database.Selda.Column import Database.Selda.Compile import Database.Selda.Frontend+import Database.Selda.Generic import Database.Selda.Inner import Database.Selda.Prepared import Database.Selda.Query import Database.Selda.Query.Type import Database.Selda.Selectors import Database.Selda.SQL hiding (distinct)+import Database.Selda.SqlRow import Database.Selda.SqlType import Database.Selda.Table import Database.Selda.Table.Compile-import Database.Selda.Table.Foreign+import Database.Selda.Table.Validation import Database.Selda.Types import Database.Selda.Unsafe-import Control.Exception (throw)+import Data.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 +#if MIN_VERSION_base(4, 9, 0)+import GHC.TypeLits as TL+#endif+ -- | Any column type that can be used with the 'min_' and 'max_' functions. class SqlType a => SqlOrd a instance {-# OVERLAPPABLE #-} (SqlType a, Num a) => SqlOrd a+instance SqlOrd RowID instance SqlOrd Text instance SqlOrd Day instance SqlOrd UTCTime instance SqlOrd TimeOfDay instance SqlOrd a => SqlOrd (Maybe a)+instance Typeable a => SqlOrd (ID a) --- | Validate a table schema.---   Throws a 'ValidationError' if the schema does not validate.---   Currently does not check the schema against what's actually in the---   current database.-validateTable :: MonadSelda m => Table a -> m ()-validateTable t = validate (tableName t) (tableCols t) `seq` return ()+-- | Wrapper for single column tables.+--   Use this when you need a table with only a single column, with 'table' or+--   'selectValues'.+newtype Only a = Only a+  deriving+    ( Generic+    , Show+    , Read+    , Eq+    , Ord+    , Enum+    , Num+    , Integral+    , Fractional+    , Real+    , IsString+    )+instance SqlType a => SqlRow (Only a) +#if MIN_VERSION_base(4, 9, 0)+instance (TypeError+  ( 'TL.Text "'Only " ':<>: 'ShowType a ':<>: 'TL.Text "' is not a proper SQL type."+    ':$$: 'TL.Text "Use 'the' to access the value of the column."+  ), Typeable a) => SqlType (Only a) where+  mkLit = error "unreachable"+  sqlType = error "unreachable"+  fromSql = error "unreachable"+  defaultValue = error "unreachable"+#endif++-- | Add the given column to the column pointed to by the given selector.+(+=) :: (SqlType a, Num (Col s a)) => Selector t a -> Col s a -> Assignment s t+s += c = s $= (+ c)+infixl 2 +=++-- | Subtract the given column from the column pointed to by the given selector.+(-=) :: (SqlType a, Num (Col s a)) => Selector t a -> Col s a -> Assignment s t+s -= c = s $= (\x -> x - c)+infixl 2 -=++-- | Multiply the column pointed to by the given selector, by the given column.+(*=) :: (SqlType a, Num (Col s a)) => Selector t a -> Col s a -> Assignment s t+s *= c = s $= (* c)+infixl 2 *=++-- | Logically @OR@ the column pointed to by the given selector with+--   the given column.+(||=) :: Selector t Bool -> Col s Bool -> Assignment s t+s ||= c = s $= (.|| c)+infixl 2 ||=++-- | Logically @AND@ the column pointed to by the given selector with+--   the given column.+(&&=) :: Selector t Bool -> Col s Bool -> Assignment s t+s &&= c = s $= (.&& c)+infixl 2 &&=++class The a where+  type TheOnly a+  -- | Extract the value of a row from a singleton table.+  the :: a -> TheOnly a++instance The (Only a) where+  type TheOnly (Only a) = a+  the (Only x) = x++instance The (Row s (Only a)) where+  type TheOnly (Row s (Only a)) = Col s a+  the (Many [Untyped x]) = One (unsafeCoerce x)+  the (Many _)           = error "BUG: non-singleton Only-column"++-- | Create a singleton table column from an appropriate value.+only :: SqlType a => Col s a -> Row s (Only a)+only (One x)  = Many [Untyped x]++-- | Create a new column 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+ -- | Convenient shorthand for @fmap (! sel) q@. --   The following two queries are quivalent: --@@ -168,10 +214,10 @@ -- > q2 = do -- >   person <- select people -- >   return (person ! name)-from :: ToDyn (Cols () a)-     => Selector a b-     -> Query s (Cols s a)-     -> Query s (Col s b)+from :: (Typeable a, SqlType b)+     => Selector (Source a) b+     -> Query s (Row s a)+     -> Query s (Col s (Selected a b)) from s q = (! s) <$> q infixr 7 `from` @@ -218,14 +264,18 @@ infixl 4 .<=  -- | Is the given column null?-isNull :: Col s (Maybe a) -> Col s Bool+isNull :: SqlType a => Col s (Maybe a) -> Col s Bool isNull = liftC $ UnOp IsNull  -- | Applies the given function to the given nullable column where it isn't null, --   and returns the given default value where it is. -- --   This is the Selda equivalent of 'maybe'.-matchNull :: SqlType a => Col s b -> (Col s a -> Col s b) -> Col s (Maybe a) -> Col s b+matchNull :: (SqlType a, SqlType b)+          => Col s b+          -> (Col s a -> Col s b)+          -> Col s (Maybe a)+          -> Col s b matchNull nullvalue f x = ifThenElse (isNull x) nullvalue (f (cast x))  -- | Any container type for which we can check object membership.@@ -235,12 +285,11 @@ infixl 4 `isIn`  instance Set [] where-  -- TODO: use safe coercions instead of unsafeCoerce   isIn _ []     = false-  isIn (C x) xs = C $ InList x (unsafeCoerce xs)+  isIn (One x) xs = One $ InList x [c | One c <- xs]  instance Set (Query s) where-  isIn (C x) = C . InQuery x . snd . compQueryWithFreshScope+  isIn (One x) = One . InQuery x . snd . compQueryWithFreshScope  (.&&), (.||) :: Col s Bool -> Col s Bool -> Col s Bool (.&&) = liftC2 $ BinOp And@@ -253,23 +302,21 @@ ascending = Asc descending = Desc --- | The default value for a column during insertion.---   For an auto-incrementing primary key, the default value is the next key.------   Using @def@ in any other context than insertion results in a runtime error.-def :: SqlType a => a-def = throw DefaultValueException- -- | Lift a non-nullable column to a nullable one. --   Useful for creating expressions over optional columns: ----- > people :: Table (Text :*: Int :*: Maybe Text)--- > people = table "people" $ required "name" :*: required "age" :*: optional "pet"+-- > data Person = Person {name :: Text, age :: Int, pet :: Maybe Text}+-- >   deriving Generic+-- > instance SqlRow Person -- >+-- > people :: Table Person+-- > people = table "people" []+-- > sName :*: sAge :*: sPet = selectors people+-- > -- > peopleWithCats = do--- >   name :*: _ :*: pet <- select people--- >   restrict (pet .== just "cat")--- >   return name+-- >   person <- select people+-- >   restrict (person ! sPet .== just "cat")+-- >   return (name ! sName) just :: SqlType a => Col s a -> Col s (Maybe a) just = cast @@ -315,12 +362,12 @@ max_ = aggr "MAX"  -- | The smallest value in the given column. Texts are compared lexically.-min_  :: SqlOrd a => Col s a -> Aggr s a+min_ :: SqlOrd a => Col s a -> Aggr s a min_ = aggr "MIN"  -- | Sum all values in the given column.-sum_ :: (SqlType a, Num a) => Col s a -> Aggr s a-sum_ = aggr "SUM"+sum_ :: forall a b s. (SqlType a, SqlType b, Num a, Num b) => Col s a -> Aggr s b+sum_ = castAggr . aggr "SUM"  -- | Round a value to the nearest integer. Equivalent to @roundTo 0@. round_ :: forall s a. (SqlType a, Num a) => Col s Double -> Col s a@@ -349,10 +396,10 @@ fromInt :: (SqlType a, Num a) => Col s Int -> Col s a fromInt = cast --- | Convert any column to a string.-toString :: Col s a -> Col s Text+-- | Convert any SQL type to a string.+toString :: SqlType a => Col s a -> Col s Text toString = cast  -- | Perform a conditional on a column-ifThenElse :: Col s Bool -> Col s a -> Col s a -> Col s a+ifThenElse :: SqlType a => Col s Bool -> Col s a -> Col s a -> Col s a ifThenElse = liftC3 If

@@ -4,17 +4,23 @@   ( MonadSelda (..), SeldaT, SeldaM, SeldaError (..)   , StmtID, BackendID (..), QueryRunner, SeldaBackend (..), SeldaConnection   , SqlType (..), SqlValue (..), SqlTypeRep (..)+  , IndexMethod (..)   , Param (..), Lit (..), ColAttr (..)   , PPConfig (..), defPPConfig+  , TableName, ColName, ColumnInfo (..)+  , columnInfo, fromColInfo+  , mkTableName, mkColName, fromTableName, fromColName, rawTableName   , newConnection, allStmts, seldaBackend   , runSeldaT, seldaClose   , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat   ) where-import Database.Selda.Backend.Internal import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Data.IORef+import Database.Selda.Backend.Internal+import Database.Selda.Table (IndexMethod (..))+import Database.Selda.Types  -- | Close a reusable Selda connection. --   Closing a connection while in use is undefined.

@@ -8,18 +8,20 @@   , Param (..), Lit (..), ColAttr (..)   , SqlType (..), SqlValue (..), SqlTypeRep (..)   , PPConfig (..), defPPConfig+  , ColumnInfo (..), columnInfo, fromColInfo   , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat   , freshStmtId   , invalidate   , newConnection, allStmts   , runSeldaT, seldaBackend   ) where-import Database.Selda.Caching (invalidate)+import Database.Selda.Caching (invalidate, setMaxItems) import Database.Selda.SQL (Param (..)) import Database.Selda.SqlType-import Database.Selda.Table (Table, ColAttr (..), tableName)+import Database.Selda.Table (Table (..), ColAttr (..), tableName)+import qualified Database.Selda.Table as Table (ColInfo (..)) import Database.Selda.SQL.Print.Config-import Database.Selda.Types (TableName)+import Database.Selda.Types (TableName, ColName) import Control.Concurrent import Control.Exception (throw) import Control.Monad.Catch@@ -80,7 +82,7 @@    --   starting at 0.    --   Backends implementing @runPrepared@ should probably ignore this field.  , stmtParams :: ![Either Int Param]-   +    -- | All tables touched by the statement.  , stmtTables :: ![TableName]  }@@ -119,6 +121,47 @@ allStmts =   fmap (map (\(k, v) -> (k, stmtHandle v)) . M.toList) . readIORef . connStmts +-- | Comprehensive information about a column.+data ColumnInfo = ColumnInfo+  { -- | Name of the column.+    colName :: ColName+    -- | Selda type of the column, or the type name given by the database+    --   if Selda couldn't make sense of the type.+  , colType :: Either Text SqlTypeRep+    -- | Is the given column the primary key of its table?+  , colIsPK :: Bool+    -- | Is the given column auto-incrementing?+  , colIsAutoIncrement :: Bool+    -- | Is the column unique, either through a UNIQUE constraint or by virtue+    --   of being a primary key?+  , colIsUnique :: Bool+    -- | Can the column be NULL?+  , colIsNullable :: Bool+    -- | Does the column have an index?+  , colHasIndex :: Bool+    -- | Any foreign key (table, column) pairs referenced by this column.+  , colFKs :: [(TableName, ColName)]+  } deriving (Show, Eq)++-- | Convert a 'Table.ColInfo' into a 'ColumnInfo'.+fromColInfo :: Table.ColInfo -> ColumnInfo+fromColInfo ci = ColumnInfo+    { colName = Table.colName ci+    , colType = Right $ Table.colType ci+    , colIsPK = Primary `elem` Table.colAttrs ci+    , colIsAutoIncrement = AutoIncrement `elem` Table.colAttrs ci+    , colIsUnique = Unique `elem` Table.colAttrs ci+    , colIsNullable = Optional `elem` Table.colAttrs ci+    , colHasIndex = not $ null [() | Indexed _ <- Table.colAttrs ci]+    , colFKs = map fk (Table.colFKs ci)+    }+  where+    fk (Table tbl _ _, col) = (tbl, col)++-- | Get the column information for each column in the given table.+columnInfo :: Table a -> [ColumnInfo]+columnInfo = map fromColInfo . tableCols+ -- | A collection of functions making up a Selda backend. data SeldaBackend = SeldaBackend   { -- | Execute an SQL statement.@@ -135,6 +178,11 @@     -- | Execute a prepared statement.   , runPrepared :: Dynamic -> [Param] -> IO (Int, [[SqlValue]]) +    -- | Get a list of all columns in the given table, with the type and any+    --   modifiers for each column.+    --   Return an empty list if the given table does not exist.+  , getTableInfo :: TableName -> IO [ColumnInfo]+     -- | SQL pretty-printer configuration.   , ppConfig :: PPConfig @@ -143,6 +191,15 @@      -- | Unique identifier for this backend.   , backendId :: BackendID++    -- | Turn on or off foreign key checking, and initiate/commit+    --   a transaction.+    --+    --   When implementing this function, it is safe to assume that+    --   @disableForeignKeys True@+    --   will always be called exactly once before each+    --   @disableForeignKeys False@.+  , disableForeignKeys :: Bool -> IO ()   }  data SeldaState = SeldaState@@ -156,13 +213,19 @@   }  -- | Some monad with Selda SQL capabilitites.-class MonadIO m => MonadSelda m where+--+--   Note that the default implementations of 'invalidateTable' and+--   'wrapTransaction' flush the entire cache and disable caching when+--   invoked. If you want to use Selda's built-in caching mechanism, you will+--   need to implement these operations yourself.+class (MonadIO m, MonadMask m) => MonadSelda m where   -- | Get the connection in use by the computation.   seldaConnection :: m SeldaConnection    -- | Invalidate the given table as soon as the current transaction finishes.   --   Invalidate the table immediately if no transaction is ongoing.   invalidateTable :: Table a -> m ()+  invalidateTable _ = liftIO $ setMaxItems 0    -- | Safely wrap a transaction. To ensure consistency of the in-process cache,   --   it is important that any cached tables modified during a transaction are@@ -176,14 +239,17 @@   --   2. Start bookkeeping of tables invalidated during the transaction.   --   3. Perform the transaction, with async exceptions restored.   --   4. Commit transaction, invalidate tables, and disable bookkeeping; OR-  --   5. If an exception was raised, rollback transaction and-  --      disable bookkeeping.-  ---  --   See the instance for 'SeldaT' for an example of how to do this safely.+  --   5. If an exception was raised, rollback transaction,+  --      disable bookkeeping, and re-throw the exception.   wrapTransaction :: m () -- ^ Signal transaction commit to SQL backend.                   -> m () -- ^ Signal transaction rollback to SQL backend.                   -> m a  -- ^ Transaction to perform.                   -> m a+  wrapTransaction commit rollback act = do+    bracketOnError (pure ())+                   (const rollback)+                   (const (act <* commit <* liftIO (setMaxItems 0)))+  {-# MINIMAL seldaConnection #-}  -- | Get the backend in use by the computation. seldaBackend :: MonadSelda m => m SeldaBackend

@@ -22,10 +22,6 @@  type CacheKey = (Text, Text, [Param]) --- | Reduce all parts of a cache key to HNF.-seqCK :: CacheKey -> a -> a-seqCK (db, q, ps) x = db `seq` q `seq` ps `seq` x- #ifdef NO_LOCALCACHE  cache :: Typeable a => [TableName] -> CacheKey -> a -> IO ()@@ -41,6 +37,10 @@ setMaxItems _ = return ()  #else+-- | Reduce all parts of a cache key to HNF.+seqCK :: CacheKey -> a -> a+seqCK (db, q, ps) x = db `seq` q `seq` ps `seq` x+ instance Hashable Param where   hashWithSalt s (Param x) = hashWithSalt s x instance Hashable (Lit a) where

@@ -1,59 +1,76 @@-{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances #-}+{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-} -- | Columns and associated utility functions, specialized to 'SQL'. module Database.Selda.Column-  ( Cols, Columns-  , Col (..), SomeCol (..), Exp (..), UnOp (..), BinOp (..)+  ( Columns+  , Row (..), Col (..), SomeCol (..), UntypedCol (..)+  , Exp (..), NulOp (..), UnOp (..), BinOp (..)   , toTup, fromTup, liftC, liftC2, liftC3   , allNamesIn+  , hideRenaming   , 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 import Data.Text (Text) --- | Convert a tuple of Haskell types to a tuple of column types.-type family Cols s a where-  Cols s (a :*: b)      = Col s a :*: Cols s b-  Cols s a              = Col s a- -- | Any column tuple. class Columns a where   toTup :: [ColName] -> a-  fromTup :: a -> [SomeCol SQL]+  fromTup :: a -> [UntypedCol SQL] -instance Columns b => Columns (Col s a :*: b) where-  toTup (x:xs) = C (Col x) :*: toTup xs-  toTup _      = error "too few elements to toTup"-  fromTup (C x :*: xs) = Some x : fromTup xs+instance (SqlType a, Columns b) => Columns (Col s a :*: b) where+  toTup (x:xs) = One (Col x) :*: toTup xs+  toTup []     = error "too few elements to toTup"+  fromTup (One x :*: xs) = Untyped x : fromTup xs +instance (SqlRow a, Columns b) => Columns (Row s a :*: b) where+  toTup xs =+    case nestedCols (Proxy :: Proxy a) of+      n -> Many (map (Untyped . Col) (take n xs)) :*: toTup (drop n xs)+  fromTup (Many xs :*: xss) = xs ++ fromTup xss+ instance Columns (Col s a) where-  toTup [x] = C (Col x)+  toTup [x] = One (Col x)   toTup []  = error "too few elements to toTup"-  toTup xs  = C (TblCol xs)-  fromTup (C x) = [Some x]+  toTup _   = error "too many elements to toTup"+  fromTup (One x) = [Untyped x] +instance Columns (Row s a) where+  toTup xs = Many (map (Untyped . Col) xs)+  fromTup (Many xs) = xs+ -- | A database column. A column is often a literal column table, but can also --   be an expression over such a column or a constant expression.-newtype Col s a = C {unC :: Exp SQL a}+newtype Col s a = One (Exp SQL a) +-- | A database row. A row is a collection of one or more columns.+newtype Row s a = Many [UntypedCol SQL]+ -- | A literal expression. literal :: SqlType a => a -> Col s a-literal = C . Lit . mkLit+literal = One . Lit . mkLit  instance IsString (Col s Text) where   fromString = literal . fromString -liftC3 :: (Exp SQL a -> Exp SQL b -> Exp SQL c -> Exp SQL d) -> Col s a -> Col s b -> Col s c -> Col s d-liftC3 f (C a) (C b) (C c) = C (f a b c)+liftC3 :: (Exp SQL a -> Exp SQL b -> Exp SQL c -> Exp SQL d)+       -> Col s a+       -> Col s b+       -> Col s c+       -> Col s d+liftC3 f (One a) (One b) (One c) = One (f a b c)  liftC2 :: (Exp SQL a -> Exp SQL b -> Exp SQL c) -> Col s a -> Col s b -> Col s c-liftC2 f (C a) (C b) = C (f a b)+liftC2 f (One a) (One b) = One (f a b)  liftC :: (Exp SQL a -> Exp SQL b) -> Col s a -> Col s b-liftC f = C . f . unC+liftC f (One x) = One (f x)  instance (SqlType a, Num a) => Num (Col s a) where   fromInteger = literal . fromInteger@@ -75,11 +92,11 @@  instance Fractional (Col s Double) where   fromRational = literal . fromRational-  (/) = liftC2 $ BinOp Div  +  (/) = liftC2 $ BinOp Div  instance Fractional (Col s (Maybe Double)) where   fromRational = literal . Just . fromRational-  (/) = liftC2 $ BinOp Div  +  (/) = liftC2 $ BinOp Div  instance Fractional (Col s Int) where   fromRational = literal . (truncate :: Double -> Int) . fromRational

@@ -1,18 +1,22 @@ {-# LANGUAGE GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-} -- | Selda SQL compilation. module Database.Selda.Compile   ( Result, Res-  , toRes, compQuery, compQueryWithFreshScope+  , buildResult, compQuery, compQueryWithFreshScope   , compile, compileWith, compileWithTables   , compileInsert, compileUpdate, compileDelete   )   where+import Control.Monad (liftM2) import Database.Selda.Column+import Database.Selda.Generic import Database.Selda.Query.Type import Database.Selda.SQL import Database.Selda.SQL.Print import Database.Selda.SQL.Print.Config+import Database.Selda.SqlRow import Database.Selda.SqlType import Database.Selda.Table import Database.Selda.Table.Compile@@ -48,7 +52,7 @@ -- | Compile an @INSERT@ query, given the keyword representing default values --   in the target SQL dialect, a table and a list of items corresponding --   to the table.-compileInsert :: Insert a => PPConfig -> Table a -> [a] -> [(Text, [Param])]+compileInsert :: Relational a => PPConfig -> Table a -> [a] -> [(Text, [Param])] compileInsert _ _ [] =   [(empty, [])] compileInsert cfg tbl rows =@@ -65,25 +69,28 @@         (x, xs') -> x : chunk chunksize xs'  -- | Compile an @UPDATE@ query.-compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a))-              => PPConfig                 -- ^ SQL pretty-printer config.-              -> Table a                  -- ^ The table to update.-              -> (Cols s a -> Cols s a)   -- ^ Update function.-              -> (Cols s a -> Col s Bool) -- ^ Predicate: update only when true.+compileUpdate :: forall s a. (Relational a, SqlRow a)+              => PPConfig+              -> Table a                 -- ^ Table to update.+              -> (Row s a -> Row s a)    -- ^ Update function.+              -> (Row s a -> Col s Bool) -- ^ Predicate.               -> (Text, [Param]) compileUpdate cfg tbl upd check =     compUpdate cfg (tableName tbl) predicate updated   where     names = map colName (tableCols tbl)-    cs = toTup names+    cs = tableExpr tbl     updated = zip names (finalCols (upd cs))-    C predicate = check cs+    One predicate = check cs  -- | Compile a @DELETE FROM@ query.-compileDelete :: Columns (Cols s a)-              => PPConfig -> Table a -> (Cols s a -> Col s Bool) -> (Text, [Param])+compileDelete :: Relational a+              => PPConfig+              -> Table a+              -> (Row s a -> Col s Bool)+              -> (Text, [Param]) compileDelete cfg tbl check = compDelete cfg (tableName tbl) predicate-  where C predicate = check $ toTup $ map colName $ tableCols tbl+  where One predicate = check $ toTup $ map colName $ tableCols tbl  -- | Compile a query to an SQL AST. --   Groups are ignored, as they are only used by 'aggregate'.@@ -108,6 +115,9 @@   s <- atomicModifyIORef' scopeSupply (\s -> (s+1, s))   return $ compQuery s q +buildResult :: Result r => Proxy r -> [SqlValue] -> Res r+buildResult p = runResultReader (toRes p)+ -- | An acceptable query result type; one or more columns stitched together --   with @:*:@. class Typeable (Res r) => Result r where@@ -118,20 +128,27 @@   --   The given list must contain exactly as many elements as dictated by   --   the @Res r@. If the result is @a :*: b :*: c@, then the list must   --   contain exactly three values, for instance.-  toRes :: Proxy r -> [SqlValue] -> Res r+  toRes :: Proxy r -> ResultReader (Res r)    -- | Produce a list of all columns present in the result.   finalCols :: r -> [SomeCol SQL]  instance (SqlType a, Result b) => Result (Col s a :*: b) where   type Res (Col s a :*: b) = a :*: Res b-  toRes _ (x:xs) = fromSql x :*: toRes (Proxy :: Proxy b) xs-  toRes _ _      = error "backend bug: too few result columns to toRes"+  toRes _ = liftM2 (:*:) (fromSql <$> next) (toRes (Proxy :: Proxy b))   finalCols (a :*: b) = finalCols a ++ finalCols b +instance (SqlRow a, Result b) => Result (Row s a :*: b) where+  type Res (Row s a :*: b) = a :*: Res b+  toRes _ = liftM2 (:*:) nextResult (toRes (Proxy :: Proxy b))+  finalCols (a :*: b) = finalCols a ++ finalCols b+ instance SqlType a => Result (Col s a) where   type Res (Col s a) = a-  toRes _ [x] = fromSql x-  toRes _ []  = error "backend bug: too few result columns to toRes"-  toRes _ _   = error "backend bug: too many result columns to toRes"-  finalCols (C c) = [Some c]+  toRes _ = fromSql <$> next+  finalCols (One c) = [Some c]++instance SqlRow a => Result (Row s a) where+  type Res (Row s a) = a+  toRes _ = nextResult+  finalCols (Many cs) = [Some c | Untyped c <- cs]

@@ -1,4 +1,5 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE TypeOperators, CPP, DataKinds #-} -- | The expression type underlying 'Col'. module Database.Selda.Exp where import Database.Selda.SqlType@@ -11,14 +12,24 @@   Some  :: !(Exp sql a) -> SomeCol sql   Named :: !ColName -> !(Exp sql a) -> SomeCol sql +data UntypedCol sql where+  Untyped :: !(Exp sql a) -> UntypedCol sql++-- | Turn a renamed column back into a regular one.+--   If the column was renamed, it will be represented by a literal column,+--   and not its original expression.+hideRenaming :: SomeCol sql -> UntypedCol sql+hideRenaming (Named n _) = Untyped (Col n)+hideRenaming (Some c)    = Untyped c+ -- | Underlying column expression type, parameterised over the type of --   SQL queries. data Exp sql a where   Col     :: !ColName -> Exp sql a-  TblCol  :: ![ColName] -> Exp sql a   Lit     :: !(Lit a) -> Exp sql a   BinOp   :: !(BinOp a b) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql b   UnOp    :: !(UnOp a b) -> !(Exp sql a) -> Exp sql b+  NulOp   :: !(NulOp a) -> Exp sql a   Fun2    :: !Text -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c   If      :: !(Exp sql Bool) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql a   Cast    :: !SqlTypeRep -> !(Exp sql a) -> Exp sql b@@ -26,6 +37,9 @@   InList  :: !(Exp sql a) -> ![Exp sql a] -> Exp sql Bool   InQuery :: !(Exp sql a) -> !sql -> Exp sql Bool +data NulOp a where+  Fun0   :: Text -> NulOp a+ data UnOp a b where   Abs    :: UnOp a a   Not    :: UnOp Bool Bool@@ -58,11 +72,11 @@   allNamesIn = concatMap allNamesIn  instance Names sql => Names (Exp sql a) where-  allNamesIn (TblCol ns)   = ns   allNamesIn (Col n)       = [n]   allNamesIn (Lit _)       = []   allNamesIn (BinOp _ a b) = allNamesIn a ++ allNamesIn b   allNamesIn (UnOp _ a)    = allNamesIn a+  allNamesIn (NulOp _)     = []   allNamesIn (Fun2 _ a b)  = allNamesIn a ++ allNamesIn b   allNamesIn (If a b c)    = allNamesIn a ++ allNamesIn b ++ allNamesIn c   allNamesIn (Cast _ x)    = allNamesIn x@@ -73,3 +87,6 @@ instance Names sql => Names (SomeCol sql) where   allNamesIn (Some c)    = allNamesIn c   allNamesIn (Named n c) = n : allNamesIn c++instance Names sql => Names (UntypedCol sql) where+  allNamesIn (Untyped c) = allNamesIn c

@@ -2,23 +2,24 @@ -- | API for running Selda operations over databases. module Database.Selda.Frontend   ( Result, Res, MonadIO (..), MonadSelda (..), SeldaT-  , query+  , query, queryInto   , insert, insert_, insertWithPK, tryInsert, insertWhen, insertUnless   , update, update_, upsert   , deleteFrom, deleteFrom_   , createTable, tryCreateTable   , dropTable, tryDropTable-  , transaction, setLocalCache+  , transaction, setLocalCache, withoutForeignKeyEnforcement   ) where import Database.Selda.Backend.Internal import Database.Selda.Caching import Database.Selda.Column import Database.Selda.Compile+import Database.Selda.Generic import Database.Selda.Query.Type-import Database.Selda.SQL-import Database.Selda.SqlType (RowID, invalidRowId, unsafeRowId)+import Database.Selda.SqlType (ID, invalidId, toId) import Database.Selda.Table import Database.Selda.Table.Compile+import Database.Selda.Types (fromTableName) import Data.Proxy import Data.Text (Text) import Control.Monad@@ -34,6 +35,20 @@   backend <- seldaBackend   queryWith (runStmt backend) q +-- | Perform the given query, and insert the result into the given table.+--   Returns the number of inserted rows.+queryInto :: (MonadSelda m, Relational a)+          => Table a+          -> Query s (Row s a)+          -> m Int+queryInto tbl q = do+    backend <- seldaBackend+    let (qry, ps) = compileWith (ppConfig backend) q+        qry' = mconcat ["INSERT INTO ", tblName, " ", qry]+    fmap fst . liftIO $ runStmt backend qry' ps+  where+    tblName = fromTableName (tableName tbl)+ -- | Insert the given values into the given table. All columns of the table --   must be present. If your table has an auto-incrementing primary key, --   use the special value 'def' for that column to get the auto-incrementing@@ -42,23 +57,27 @@ -- --   To insert a list of tuples into a table with auto-incrementing primary key: ----- > people :: Table (Int :*: Text :*: Int :*: Maybe Text)--- > people = table "ppl"--- >        $   autoPrimary "id"--- >        :*: required "name"--- >        :*: required "age"--- >        :*: optional "pet"+-- > data Person = Person+-- >   { id :: ID Person+-- >   , name :: Text+-- >   , age :: Int+-- >   , pet :: Maybe Text+-- >   } deriving Generic+-- > instance SqlResult Person -- >+-- > people :: Table Person+-- > people = table "people" [autoPrimary :- id]+-- > -- > main = withSQLite "my_database.sqlite" $ do -- >   insert_ people--- >     [ def :*: "Link"  :*: 125 :*: Just "horse"--- >     , def :*: "Zelda" :*: 119 :*: Nothing+-- >     [ Person def "Link" 125 (Just "horse")+-- >     , Person def "Zelda" 119 Nothing -- >     , ... -- >     ] -- --   Note that if one or more of the inserted rows would cause a constraint --   violation, NO rows will be inserted; the whole insertion fails atomically.-insert :: (MonadSelda m, Insert a) => Table a -> [a] -> m Int+insert :: (MonadSelda m, Relational a) => Table a -> [a] -> m Int insert _ [] = do   return 0 insert t cs = do@@ -73,7 +92,7 @@ -- --   Like 'insert', if even one of the inserted rows would cause a constraint --   violation, the whole insert operation fails.-tryInsert :: (MonadCatch m, MonadSelda m, Insert a) => Table a -> [a] -> m Bool+tryInsert :: (MonadSelda m, Relational a) => Table a -> [a] -> m Bool tryInsert tbl row = do   mres <- try $ insert tbl row   case mres of@@ -90,17 +109,14 @@ -- --   Note that this may perform two separate queries: one update, potentially --   followed by one insert.-upsert :: ( MonadCatch m-          , MonadSelda m-          , Insert a-          , Columns (Cols s a)-          , Result (Cols s a)+upsert :: ( MonadSelda m+          , Relational a           )        => Table a-       -> (Cols s a -> Col s Bool)-       -> (Cols s a -> Cols s a)+       -> (Row s a -> Col s Bool)+       -> (Row s a -> Row s a)        -> [a]-       -> m (Maybe RowID)+       -> m (Maybe (ID a)) upsert tbl check upd rows = transaction $ do   updated <- update tbl check upd   if updated == 0@@ -114,30 +130,24 @@ --   If called on a table which doesn't have an auto-incrementing primary key, --   @Just id@ is always returned on successful insert, where @id@ is a row --   identifier guaranteed to not match any row in any table.-insertUnless :: ( MonadCatch m-                , MonadSelda m-                , Insert a-                , Columns (Cols s a)-                , Result (Cols s a)+insertUnless :: ( MonadSelda m+                , Relational a                 )              => Table a-             -> (Cols s a -> Col s Bool)+             -> (Row s a -> Col s Bool)              -> [a]-             -> m (Maybe RowID)+             -> m (Maybe (ID a)) insertUnless tbl check rows = upsert tbl check id rows  -- | Like 'insertUnless', but performs the insert when at least one row matches --   the predicate.-insertWhen :: ( MonadCatch m-              , MonadSelda m-              , Insert a-              , Columns (Cols s a)-              , Result (Cols s a)+insertWhen :: ( MonadSelda m+              , Relational a               )            => Table a-           -> (Cols s a -> Col s Bool)+           -> (Row s a -> Col s Bool)            -> [a]-           -> m (Maybe RowID)+           -> m (Maybe (ID a)) insertWhen tbl check rows = transaction $ do   matches <- update tbl check id   if matches > 0@@ -146,14 +156,14 @@  -- | Like 'insert', but does not return anything. --   Use this when you really don't care about how many rows were inserted.-insert_ :: (MonadSelda m, Insert a) => Table a -> [a] -> m ()+insert_ :: (MonadSelda m, Relational a) => Table a -> [a] -> m () insert_ t cs = void $ insert t cs  -- | Like 'insert', but returns the primary key of the last inserted row. --   Attempting to run this operation on a table without an auto-incrementing --   primary key will always return a row identifier that is guaranteed to not --   match any row in any table.-insertWithPK :: (MonadSelda m, Insert a) => Table a -> [a] -> m RowID+insertWithPK :: (MonadSelda m, Relational a) => Table a -> [a] -> m (ID a) insertWithPK t cs = do   b <- seldaBackend   if tableHasAutoPK t@@ -161,17 +171,17 @@       res <- liftIO $ do         mapM (uncurry (runStmtWithPK b)) $ compileInsert (ppConfig b) t cs       invalidateTable t-      return $ unsafeRowId (last res)+      return $ toId (last res)     else do       insert_ t cs-      return invalidRowId+      return invalidId  -- | Update the given table using the given update function, for all rows --   matching the given predicate. Returns the number of updated rows.-update :: (MonadSelda m, Columns (Cols s a), Result (Cols s a))-       => Table a                  -- ^ The table to update.-       -> (Cols s a -> Col s Bool) -- ^ Predicate.-       -> (Cols s a -> Cols s a)   -- ^ Update function.+update :: (MonadSelda m, Relational a)+       => Table a                 -- ^ Table to update.+       -> (Row s a -> Col s Bool) -- ^ Predicate.+       -> (Row s a -> Row s a)    -- ^ Update function.        -> m Int update tbl check upd = do   cfg <- ppConfig <$> seldaBackend@@ -180,17 +190,19 @@   return res  -- | Like 'update', but doesn't return the number of updated rows.-update_ :: (MonadSelda m, Columns (Cols s a), Result (Cols s a))+update_ :: (MonadSelda m, Relational a)        => Table a-       -> (Cols s a -> Col s Bool)-       -> (Cols s a -> Cols s a)+       -> (Row s a -> Col s Bool)+       -> (Row s a -> Row s a)        -> m () update_ tbl check upd = void $ update tbl check upd  -- | From the given table, delete all rows matching the given predicate. --   Returns the number of deleted rows.-deleteFrom :: (MonadSelda m, Columns (Cols s a))-           => Table a -> (Cols s a -> Col s Bool) -> m Int+deleteFrom :: (MonadSelda m, Relational a)+           => Table a+           -> (Row s a -> Col s Bool)+           -> m Int deleteFrom tbl f = do   cfg <- ppConfig <$> seldaBackend   res <- uncurry exec $ compileDelete cfg tbl f@@ -198,21 +210,23 @@   return res  -- | Like 'deleteFrom', but does not return the number of deleted rows.-deleteFrom_ :: (MonadSelda m, Columns (Cols s a))-            => Table a -> (Cols s a -> Col s Bool) -> m ()+deleteFrom_ :: (MonadSelda m, Relational a)+            => Table a+            -> (Row s a -> Col s Bool)+            -> m () deleteFrom_ tbl f = void $ deleteFrom tbl f  -- | Create a table from the given schema. createTable :: MonadSelda m => Table a -> m () createTable tbl = do   cfg <- ppConfig <$> seldaBackend-  void . flip exec [] $ compileCreateTable cfg Fail tbl+  mapM_ (flip exec []) $ compileCreateTable cfg Fail tbl  -- | Create a table from the given schema, unless it already exists. tryCreateTable :: MonadSelda m => Table a -> m () tryCreateTable tbl = do   cfg <- ppConfig <$> seldaBackend-  void . flip exec [] $ compileCreateTable cfg Ignore tbl+  mapM_ (flip exec []) $ compileCreateTable cfg Ignore tbl  -- | Drop the given table. dropTable :: MonadSelda m => Table a -> m ()@@ -223,13 +237,29 @@ tryDropTable = withInval $ void . flip exec [] . compileDropTable Ignore  -- | Perform the given computation atomically.---   If an exception is raised during its execution, the enture transaction---   will be rolled back, and the exception re-thrown.-transaction :: (MonadSelda m, MonadCatch m) => m a -> m a+--   If an exception is raised during its execution, the entire transaction+--   will be rolled back and the exception re-thrown, even if the exception+--   is caught and handled within the transaction.+transaction :: MonadSelda m => m a -> m a transaction m =   wrapTransaction (void $ exec "COMMIT" []) (void $ exec "ROLLBACK" []) $ do     exec "BEGIN TRANSACTION" [] *> m +-- | Run the given computation as a transaction without enforcing foreign key+--   constraints.+--+--   If the computation finishes with the database in an inconsistent state+--   with regards to foreign keys, the resulting behavior is undefined.+--   Use with extreme caution, preferably only for migrations.+--+--   On the PostgreSQL backend, at least PostgreSQL 9.6 is required.+withoutForeignKeyEnforcement :: MonadSelda m => m a -> m a+withoutForeignKeyEnforcement m = do+  b <- seldaBackend+  bracket_ (liftIO $ disableForeignKeys b True)+           (liftIO $ disableForeignKeys b False)+           m+ -- | Set the maximum local cache size to @n@. A cache size of zero disables --   local cache altogether. Changing the cache size will also flush all --   entries. Note that the cache is shared among all Selda computations running@@ -265,7 +295,7 @@  -- | Generate the final result of a query from a list of untyped result rows. mkResults :: Result a => Proxy a -> [[SqlValue]] -> [Res a]-mkResults p = map (toRes p)+mkResults p = map (buildResult p)  -- | Run the given computation over a table after invalidating all cached --   results depending on that table.

@@ -2,43 +2,38 @@ {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}-{-# LANGUAGE GADTs #-}--- | Build tables and database operations from (almost) any Haskell type.------   While the types in this module may look somewhat intimidating, the rules---   for generic tables and queries are quite simple:------     * Any record type with a single data constructor, where all fields are---       instances of 'SqlType', can be used for generic tables and queries---       if it derives 'Generic'.---     * To use the standard functions from "Database.Selda" on a generic table,---       it needs to be unwrapped using 'gen'.---     * Performing a 'select' on a generic table returns all the table's fields---       as an inductive tuple.---     * Tuples obtained this way can be handled either as any other tuple, or---       using the '!' operator together with any record selector for the---       tuple's corresponding type.---     * Relations obtained from a query can be re-assembled into their---       corresponding data type using 'fromRel'.+{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds #-}+-- | Generics utilities. module Database.Selda.Generic   ( Relational, Generic-  , GenAttr (..), GenTable (..), Attribute, Relation-  , genTable, genTableFieldMod, toRel, toRels, fromRel, fromRels-  , insertGen, insertGen_, insertGenWithPK-  , primaryGen, autoPrimaryGen, uniqueGen, fkGen+  , tblCols, mkDummy, identify, params, def, gNew   ) where import Control.Monad.State import Data.Dynamic-import Data.Proxy-import Data.Text (pack)+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)+#if MIN_VERSION_base(4, 9, 0)+import qualified GHC.TypeLits as TL+import qualified GHC.Generics as G ((:+:)(..))+#endif import Unsafe.Coerce-import Database.Selda hiding (from)-import Database.Selda.Table+import Control.Exception (Exception (..), try, throw)+import System.IO.Unsafe import Database.Selda.Types import Database.Selda.Selectors+import Database.Selda.SqlType+import Database.Selda.SqlRow (SqlRow)+import Database.Selda.Table.Type+import Database.Selda.SQL (Param (..))+import Database.Selda.Exp (Exp (Col, Lit), UntypedCol (..))+import qualified Database.Selda.Column as C (Col)+#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'.@@ -49,210 +44,15 @@ --   obey those constraints will result in a very confusing type error. type Relational a =   ( Generic a+  , SqlRow a   , GRelation (Rep a)-  , GFromRel (Rep a)-  , ToDyn (Relation a)-  , Insert (Relation a)+  , GSelectors a (Rep a)   ) --- | A generic table. Needs to be unpacked using @gen@ before use with---   'select', 'insert', etc.-newtype GenTable a = GenTable {gen :: Table (Relation a)}---- | The relation corresponding to the given Haskell type.---   This relation simply corresponds to the fields in the data type, from---   left to right. For instance:------ > data Foo = Foo--- >   { bar :: Int--- >   , baz :: Text--- >   }------   In this example, @Relation Foo@ is @(Int :*: Text)@, as the first field---   of @Foo@ has type @Int@, and the second has type @Text@.-type Relation a = Rel (Rep a)---- | A generic column attribute.---   Essentially a pair or a record selector over the type @a@ and a column---   attribute.-data GenAttr a where-  (:-) :: (a -> b) -> Attribute -> GenAttr a---- | Generate a table from the given table name and list of column attributes.---   All @Maybe@ fields in the table's type will be represented by nullable---   columns, and all non-@Maybe@ fields fill be represented by required---   columns.---   For example:------ > data Person = Person--- >   { id   :: Int--- >   , name :: Text--- >   , age  :: Int--- >   , pet  :: Maybe Text--- >   }--- >   deriving Generic--- >--- > people :: GenTable Person--- > people = genTable "people" [(name, autoPrimaryGen)]------   This example will create a table with the column types---   @Int :*: Text :*: Int :*: Maybe Text@, where the first field is---   an auto-incrementing primary key.-genTable :: forall a. Relational a-         => TableName-         -> [GenAttr a]-         -> GenTable a-genTable tn attrs = genTableFieldMod tn attrs id---- | Generate a table from the given table name,---   a list of column attributes and a function---   that maps from field names to column names.---   Ex.:------ > data Person = Person--- >   { personId   :: Int--- >   , personName :: Text--- >   , personAge  :: Int--- >   , personPet  :: Maybe Text--- >   }--- >   deriving Generic--- >--- > people :: GenTable Person--- > people = genTableFieldMod "people" [(personName, autoPrimaryGen)] (stripPrefix "person")------   This will create a table with the columns named---   "Id", "Name", "Age" and "Pet".-genTableFieldMod :: forall a. Relational a-                 => TableName-                 -> [GenAttr a]-                 -> (String -> String)-                 -> GenTable a-genTableFieldMod tn attrs fieldMod = GenTable $ Table tn (validate tn (map tidy cols)) apk-  where-    dummy = mkDummy-    cols = zipWith addAttrs [0..] (tblCols (Proxy :: Proxy a) fieldMod)-    apk = or [AutoIncrement `elem` as | _ :- Attribute as <- attrs]-    addAttrs n ci = ci-      { colAttrs = colAttrs ci ++ concat-          [ as-          | f :- Attribute as <- attrs-          , identify dummy f == n-          ]-      , colFKs = colFKs ci ++-          [ thefk-          | f :- ForeignKey thefk <- attrs-          , identify dummy f == n-          ]-      }---- | Convert a generic type into the corresponding database relation.---   A type's corresponding relation is simply the inductive tuple consisting---   of all of the type's fields.------ > data Person = Person--- >   { id   :: Int--- >   , name :: Text--- >   , age  :: Int--- >   , pet  :: Maybe Text--- >   }--- >   deriving Generic--- >--- > somePerson = Person 0 "Velvet" 19 Nothing--- > (theId :*: theName :*: theAge :*: thePet) = toRel somePerson------   This is mainly useful when inserting values into a table using 'insert'---   and the other functions from "Database.Selda".-toRel :: Relational a => a -> Relation a-toRel = gToRel . from---- | Convenient synonym for @map toRel@.-toRels :: Relational a => [a] -> [Relation a]-toRels = map toRel---- | Re-assemble a generic type from its corresponding relation. This can be---   done either for ad hoc queries or for queries over generic tables:------ > data SimplePerson = SimplePerson--- >   { name :: Text--- >   , age  :: Int--- >   }--- >   deriving Generic--- >--- > demoPerson :: SimplePerson--- > demoPerson = fromRel ("Miyu" :*: 10)--- >--- > adhoc :: Table (Text :*: Int)--- > adhoc = table "adhoc" $ required "name" :*: required "age"--- >--- > getPersons1 :: MonadSelda m => m [SimplePerson]--- > getPersons1 = map fromRel <$> query (select adhoc)--- >--- > generic :: GenTable SimplePerson--- > generic = genTable "generic" []--- >--- > getPersons2 :: MonadSelda m => m [SimplePerson]--- > getPersons2 = map fromRel <$> query (select (gen generic))------   Applying @toRel@ to an inductive tuple which isn't the corresponding---   relation of the return type is a type error.-fromRel :: Relational a => Relation a -> a-fromRel = to . fst . gFromRel . toDyns---- | Convenient synonym for @map fromRel@.-fromRels :: Relational a => [Relation a] -> [a]-fromRels = map fromRel---- | Like 'insertWithPK', but accepts a generic table and---   its corresponding data type.-insertGenWithPK :: (Relational a, MonadSelda m) => GenTable a -> [a] -> m RowID-insertGenWithPK t = insertWithPK (gen t) . map toRel---- | Like 'insert', but accepts a generic table and its corresponding data type.-insertGen :: (Relational a, MonadSelda m) => GenTable a -> [a] -> m Int-insertGen t = insert (gen t) . map toRel---- | Like 'insert_', but accepts a generic table and its corresponding data type.-insertGen_ :: (Relational a, MonadSelda m) => GenTable a -> [a] -> m ()-insertGen_ t = void . insertGen t---- | Some attribute that may be set on a table column.-data Attribute-  = Attribute [ColAttr]-  | ForeignKey (Table (), ColName)---- | A primary key which does not auto-increment.-primaryGen :: Attribute-primaryGen = Attribute [Primary, Required, Unique]---- | An auto-incrementing primary key.-autoPrimaryGen :: Attribute-autoPrimaryGen = Attribute [Primary, AutoIncrement, Required, Unique]---- | A table-unique value.-uniqueGen :: Attribute-uniqueGen = Attribute [Unique]---- | A foreign key constraint referencing the given table and column.-fkGen :: Table t -> Selector t a -> Attribute-fkGen (Table tn tcs tapk) (Selector i) =-  ForeignKey (Table tn tcs tapk, colName (tcs !! i))- -- | A dummy of some type. Encapsulated to avoid improper use, since all of --   its fields are 'unsafeCoerce'd ints. newtype Dummy a = Dummy a --- | Extract all column names from the given type.---   If the type is not a record, the columns will be named @col_1@,---   @col_2@, etc.-tblCols :: forall a. (GRelation (Rep a)) => Proxy a -> (String -> String) -> [ColInfo]-tblCols _ fieldMod = zipWith pack' [0 :: Int ..] $ gTblCols (Proxy :: Proxy (Rep a)) fieldMod-  where-    pack' n ci = ci-      { colName = if colName ci == ""-                    then mkColName . pack $ "col_" ++ show n-                    else colName ci-      }- -- | Create a dummy of the given type. mkDummy :: (Generic a, GRelation (Rep a)) => Dummy a mkDummy = Dummy $ to $ evalState gMkDummy 0@@ -261,64 +61,109 @@ identify :: Dummy a -> (a -> b) -> Int identify (Dummy d) f = unsafeCoerce $ f d --- | The relation corresponding to the given type.-type family Rel (rep :: * -> *) where-  Rel (M1 t c a)  = Rel a-  Rel (K1 i a)    = a-  Rel (a G.:*: b) = Rel a :++: Rel b+-- | Extract all insert parameters from a generic value.+params :: Relational a => a -> [Either Param Param]+params = unsafePerformIO . gParams . from +-- | Extract all column names from the given type.+--   If the type is not a record, the columns will be named @col_1@,+--   @col_2@, etc.+tblCols :: forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo]+tblCols _ fieldMod =+    evalState (gTblCols (Proxy :: Proxy (Rep a)) Nothing rename) 0+  where+    rename n Nothing     = mkColName $ fieldMod ("col_" <> pack (show n))+    rename _ (Just name) = modColName name fieldMod++-- | Exception indicating the use of a default value.+--   If any values throwing this during evaluation of @param xs@ will be+--   replaced by their default value.+data DefaultValueException = DefaultValueException+  deriving Show+instance Exception DefaultValueException++-- | The default value for a column during insertion.+--   For an auto-incrementing primary key, the default value is the next key.+--+--   Using @def@ in any other context than insertion results in a runtime error.+def :: SqlType a => a+def = throw DefaultValueException+ class GRelation f where-  -- | Convert a value from its Haskell type into the corresponding relation.-  gToRel   :: f a -> Rel f+  -- | Generic worker for 'params'.+  gParams :: f a -> IO [Either Param Param]    -- | Compute all columns needed to represent the given type.-  gTblCols :: Proxy f -> (String -> String) -> [ColInfo]+  gTblCols :: Proxy f+           -> Maybe ColName+           -> (Int -> Maybe ColName -> ColName)+           -> State Int [ColInfo]    -- | Create a dummy value where all fields are replaced by @unsafeCoerce@'d   --   ints. See 'mkDummy' and 'identify' for more information.   gMkDummy :: State Int (f a) -instance GRelation a => GRelation (M1 C c a) where-  gToRel (M1 x)   = gToRel x-  gTblCols _ = gTblCols (Proxy :: Proxy a)-  gMkDummy = M1 <$> gMkDummy+  -- | Create a new value with all default fields.+  gNew :: Proxy f -> [UntypedCol sql] -instance GRelation a => GRelation (M1 D c a) where-  gToRel (M1 x)   = gToRel x+instance {-# OVERLAPPABLE #-} GRelation a => GRelation (M1 t c a) where+  gParams (M1 x) = gParams x   gTblCols _ = gTblCols (Proxy :: Proxy a)   gMkDummy = M1 <$> gMkDummy+  gNew _ = gNew (Proxy :: Proxy a) -instance (G.Selector c, GRelation a) => GRelation (M1 S c a) where-  gToRel (M1 x)     = gToRel x-  gTblCols _ fieldMod = [ci']+instance {-# OVERLAPPING #-} (G.Selector c, GRelation a) =>+         GRelation (M1 S c a) where+  gParams (M1 x) = gParams x+  gTblCols _ _ = gTblCols (Proxy :: Proxy a) name     where-      [ci] = gTblCols (Proxy :: Proxy a) fieldMod-      ci' = ColInfo-        { colName = mkColName . pack $ fieldMod (selName ((M1 undefined) :: M1 S c a b))-        , colType = colType ci-        , colAttrs = colAttrs ci-        , colFKs = colFKs ci-        }+      name =+        case selName ((M1 undefined) :: M1 S c a b) of+          "" -> Nothing+          s  -> Just (mkColName $ pack s)   gMkDummy = M1 <$> gMkDummy+  gNew _ = gNew (Proxy :: Proxy a)  instance (Typeable a, SqlType a) => GRelation (K1 i a) where-  gToRel (K1 x) = x-  gTblCols _ _  = [ColInfo "" (sqlType (Proxy :: Proxy a)) optReq []]+  gParams (K1 x) = do+    res <- try $ return $! x+    return $ case res of+      Right x'                   -> [Right $ Param (mkLit x')]+      Left DefaultValueException -> [Left $ Param (defaultValue :: Lit a)]++  gTblCols _ name rename = do+    n <- get+    put (n+1)+    let name' = rename n name+    return+      [ ColInfo+        { colName = name'+        , colType = sqlType (Proxy :: Proxy a)+        , colAttrs = optReq+        , colFKs = []+        , colExpr = Untyped (Col name')+        }+      ]     where       -- workaround for GHC 8.2 not resolving overlapping instances properly       maybeTyCon = typeRepTyCon (typeRep (Proxy :: Proxy (Maybe ())))       optReq         | typeRepTyCon (typeRep (Proxy :: Proxy a)) == maybeTyCon = [Optional]         | otherwise                                               = [Required]+   gMkDummy = do     n <- get     put (n+1)     return $ unsafeCoerce n -instance (Append (Rel a) (Rel b), GRelation a, GRelation b) =>-         GRelation (a G.:*: b) where-  gToRel (a G.:*: b)   = gToRel a `app` gToRel b-  gTblCols _ f = gTblCols a f ++ gTblCols b f+  gNew _ = [Untyped (Lit (defaultValue :: Lit a))]++instance (GRelation a, GRelation b) => GRelation (a G.:*: b) where+  gParams (a G.:*: b) = liftM2 (++) (gParams a) (gParams b)+  gTblCols _ _ rename = do+      as <- gTblCols a Nothing rename+      bs <- gTblCols b Nothing rename+      return (as ++ bs)     where       a = Proxy :: Proxy a       b = Proxy :: Proxy b@@ -326,22 +171,28 @@     a <- gMkDummy :: State Int (a x)     b <- gMkDummy :: State Int (b x)     return (a G.:*: b)--class GFromRel f where-  -- | Convert a value to a Haskell type from the type's corresponding relation.-  gFromRel :: [Dynamic] -> (f a, [Dynamic])--instance (GFromRel a, GFromRel b) => GFromRel (a G.:*: b) where-  gFromRel xs =-      (x G.:*: y, xs'')-    where-      (x, xs') = gFromRel xs-      (y, xs'') = gFromRel xs'+  gNew _ = gNew (Proxy :: Proxy a) ++ gNew (Proxy :: Proxy b) -instance Typeable a => GFromRel (K1 i a) where-  gFromRel (x:xs) = (K1 (fromDyn x (error "impossible")), xs)-  gFromRel _      = error "impossible: too few elements to gFromRel"+#if MIN_VERSION_base(4, 9, 0)+instance+  (TL.TypeError+    ( 'TL.Text "Selda currently does not support creating tables from sum types."+      'TL.:$$:+      'TL.Text "Restrict your table type to a single data constructor."+    )) => GRelation (a G.:+: b) where+  gParams = error "unreachable"+  gTblCols = error "unreachable"+  gMkDummy = error "unreachable"+  gNew = error "unreachable" -instance GFromRel a => GFromRel (M1 t c a) where-  gFromRel xs = (M1 x, xs')-    where (x, xs') = gFromRel xs+instance {-# OVERLAPS #-}+  (TL.TypeError+    ( 'TL.Text "Columns are now allowed to nest other columns."+      'TL.:$$:+      'TL.Text "Remove any fields of type 'Col s a' from your table type."+    )) => GRelation (K1 i (C.Col s a)) where+  gParams = error "unreachable"+  gTblCols = error "unreachable"+  gMkDummy = error "unreachable"+  gNew = error "unreachable"+#endif

@@ -5,11 +5,13 @@ module Database.Selda.Inner where import Database.Selda.Column import Database.Selda.SQL (SQL)+import Database.Selda.SqlType (SqlType) import Database.Selda.Types import Data.Text (Text) import Data.Typeable-import GHC.Exts+#if MIN_VERSION_base(4, 9, 0) import GHC.TypeLits as TL+#endif  -- | A single aggregate column. --   Aggregate columns may not be used to restrict queries.@@ -17,6 +19,9 @@ --   converted into a non-aggregate column. newtype Aggr s a = Aggr {unAggr :: Exp SQL a} +liftAggr :: (Exp SQL a -> Exp SQL b) -> Aggr s a -> Aggr s b+liftAggr f = Aggr . f . unAggr+ -- | Denotes an inner query. --   For aggregation, treating sequencing as the cartesian product of queries --   does not work well.@@ -34,8 +39,8 @@ -- | Create a named aggregate function. --   Like 'fun', this function is generally unsafe and should ONLY be used --   to implement missing backend-specific functionality.-aggr :: Text -> Col s a -> Aggr s b-aggr f = Aggr . AggrEx f . unC+aggr :: SqlType a => Text -> Col s a -> Aggr s b+aggr f (One x)  = Aggr (AggrEx f x)  -- | Convert one or more inner column to equivalent columns in the outer query. --   @OuterCols (Aggr (Inner s) a :*: Aggr (Inner s) b) = Col s a :*: Col s b@,@@ -43,15 +48,18 @@ type family OuterCols a where   OuterCols (Col (Inner s) a :*: b)  = Col s a :*: OuterCols b   OuterCols (Col (Inner s) a)        = Col s a+  OuterCols (Row (Inner s) a :*: b)  = Row s a :*: OuterCols b+  OuterCols (Row (Inner s) a)        = Row s a #if MIN_VERSION_base(4, 9, 0)   OuterCols (Col s a) = TypeError-    ( TL.Text "An inner query can only return columns from its own scope."+    ( 'TL.Text "An inner query can only return rows and columns from its own scope."     )-#endif-#if MIN_VERSION_base(4, 9, 0)+  OuterCols (Row s a) = TypeError+    ( 'TL.Text "An inner query can only return rows and columns from its own scope."+    )   OuterCols a = TypeError-    ( TL.Text "Only (inductive tuples of) columns can be returned from" :$$:-      TL.Text "an inner query."+    ( 'TL.Text "Only (inductive tuples of) row and columns can be returned from" ':$$:+      'TL.Text "an inner query."     ) #endif @@ -60,14 +68,12 @@   AggrCols (Aggr (Inner s) a)       = Col s a #if MIN_VERSION_base(4, 9, 0)   AggrCols (Aggr s a) = TypeError-    ( TL.Text "An aggregate query can only return columns from its own" :$$:-      TL.Text "scope."+    ( 'TL.Text "An aggregate query can only return columns from its own" ':$$:+      'TL.Text "scope."     )-#endif-#if MIN_VERSION_base(4, 9, 0)   AggrCols a = TypeError-    ( TL.Text "Only (inductive tuples of) aggregates can be returned from" :$$:-      TL.Text "an aggregate query."+    ( 'TL.Text "Only (inductive tuples of) aggregates can be returned from" ':$$:+      'TL.Text "an aggregate query."     ) #endif @@ -84,17 +90,22 @@   LeftCols (Col (Inner s) a :*: b)         = Col s (Maybe a) :*: LeftCols b   LeftCols (Col (Inner s) (Maybe a))       = Col s (Maybe a)   LeftCols (Col (Inner s) a)               = Col s (Maybe a)++  LeftCols (Row (Inner s) (Maybe a) :*: b) = Row s (Maybe a) :*: LeftCols b+  LeftCols (Row (Inner s) a :*: b)         = Row s (Maybe a) :*: LeftCols b+  LeftCols (Row (Inner s) (Maybe a))       = Row s (Maybe a)+  LeftCols (Row (Inner s) a)               = Row s (Maybe a) #if MIN_VERSION_base(4, 9, 0)   LeftCols a = TypeError-    ( TL.Text "Only (inductive tuples of) columns can be returned" :$$:-      TL.Text "from a join."+    ( 'TL.Text "Only (inductive tuples of) rows and columns can be returned" ':$$:+      'TL.Text "from a join."     ) #endif  -- | One or more aggregate columns. class Aggregates a where-  unAggrs :: a -> [SomeCol SQL]+  unAggrs :: a -> [UntypedCol SQL] instance Aggregates (Aggr (Inner s) a) where-  unAggrs (Aggr x) = [Some x]+  unAggrs (Aggr x) = [Untyped x] instance Aggregates b => Aggregates (Aggr (Inner s) a :*: b) where-  unAggrs (Aggr a :*: b) = Some a : unAggrs b+  unAggrs (Aggr a :*: b) = Untyped a : unAggrs b

@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}+-- | Functionality for upgrading a table from one schema to another.+module Database.Selda.Migrations+  ( Migration (..)+  , migrate, migrateM, migrateAll, autoMigrate+  ) where+import Control.Monad (void, when)+import Control.Monad.Catch+import Database.Selda hiding (from)+import Database.Selda.Backend.Internal+import Database.Selda.Table.Type (tableName)+import Database.Selda.Table.Validation (ValidationError (..))+import Database.Selda.Types (mkTableName, fromTableName, rawTableName)+import Database.Selda.Validation++-- | Wrapper for user with 'migrateAll', enabling multiple migrations to be+--   packed into the same list:+--+-- > migrateAll+-- >   [ Migration m1_from m1_to m1_upgrade+-- >   , Migration m2_from m2_to m2_upgrade+-- >   , ...+-- >   ]+data Migration where+  Migration :: (Relational a, Relational b)+            => Table a+            -> Table b+            -> (Row s a -> Query s (Row s b))+            -> Migration++-- | A migration step is zero or more migrations that need to be performed in+--   a single transaction in order to keep the database consistent.+type MigrationStep = [Migration]++-- | Migrate the first table into the second, using the given function to+--   migrate all records to the new schema.+--   Both table schemas are validated before starting the migration, and the+--   source table is validated against what's currently in the database.+--+--   The migration is performed as a migration, ensuring that either the entire+--   migration passes, or none of it does.+migrate :: (MonadSelda m, Relational a, Relational b)+        => Table a -- ^ Table to migrate from.+        -> Table b -- ^ Table to migrate to.+        -> (Row () a -> Row () b)+                   -- ^ Mapping from old to new table.+        -> m ()+migrate t1 t2 upg = migrateM t1 t2 ((pure :: a -> Query () a) . upg)++-- | Like 'migrate', but allows the column upgrade to access+--   the entire database.+migrateM :: (MonadSelda m, Relational a, Relational b)+         => Table a+         -> Table b+         -> (Row s a -> Query s (Row s b))+         -> m ()+migrateM t1 t2 upg = migrateAll True [Migration t1 t2 upg]++wrap :: MonadSelda m => Bool -> m a -> m a+wrap enforceFKs+  | enforceFKs = transaction+  | otherwise  = withoutForeignKeyEnforcement++-- | Perform all given migrations as a single transaction.+migrateAll :: MonadSelda m+           => Bool -- ^ Enforce foreign keys during migration?+           -> MigrationStep -- ^ Migration step to perform.+           -> m ()+migrateAll fks =+  wrap fks . mapM_ (\(Migration t1 t2 upg) -> migrateInternal t1 t2 upg)++-- | Given a list of migration steps in ascending chronological order, finds+--   the latest migration step starting state that matches the current database,+--   and performs all migrations from that point until the end of the list.+--   The whole operation is performed as a single transaction.+--+--   If no matching starting state is found, a 'ValidationError' is thrown.+--   If the database is already in the state specified by the end state of the+--   final step, no migration is performed.+--+--   Note that when looking for a matching starting state, index methods for+--   indexed columns are not taken into account. Two columns @c1@ and @c2@ are+--   considered to be identical if @c1@ is indexed with index method @foo@ and+--   @c2@ is indexed with index method @bar@.+autoMigrate :: MonadSelda m+            => Bool -- ^ Enforce foreign keys during migration?+            -> [MigrationStep] -- ^ Migration steps to perform.+            -> m ()+autoMigrate _ [] = do+  return ()+autoMigrate fks steps = wrap fks $ do+    diffs <- sequence finalState+    when (any (/= TableOK) diffs) $ do+      steps' <- reverse <$> calculateSteps revSteps+      mapM_ performStep steps'+  where+    revSteps = reverse steps+    finalState = [diffTable to | Migration _ to _ <- head revSteps]++    calculateSteps (step:ss) = do+      diffs <- mapM (\(Migration from _ _) -> diffTable from) step+      if all (== TableOK) diffs+        then return [step]+        else (step:) <$> calculateSteps ss+    calculateSteps [] = do+      throwM $ ValidationError "no starting state matches the current state of the database"++    performStep = mapM_ (\(Migration t1 t2 upg) -> migrateInternal t1 t2 upg)++-- | Workhorse for migration.+--   Is NOT performed as a transaction, so exported functions need to+--   properly wrap calls this function.+migrateInternal :: (MonadSelda m, Relational a, Relational b)+                => Table a+                -> Table b+                -> (Row s a -> Query s (Row s b))+                -> m ()+migrateInternal t1 t2 upg = do+    validateTable t1+    validateSchema t2+    backend <- seldaBackend+    createTable t2'+    void . queryInto t2' $ select t1 >>= upg+    void . liftIO $ runStmt backend (dropQuery (tableName t1)) []+    void . liftIO $ runStmt backend renameQuery []+  where+    t2' = t2 {tableName = mkTableName newName} `asTypeOf` t2+    newName = mconcat ["__selda_migration_", rawTableName (tableName t2)]+    renameQuery = mconcat+      [ "ALTER TABLE ", newName+      , " RENAME TO ", fromTableName (tableName t2), ";"+      ]+    dropQuery t = mconcat ["DROP TABLE ", fromTableName t, ";"]

@@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- | Building and executing prepared statements. module Database.Selda.Prepared (Preparable, Prepare, prepared) where import Database.Selda.Backend.Internal@@ -15,6 +16,7 @@ import Data.IORef import Data.Proxy import Data.Text (Text)+import Data.Typeable import System.IO.Unsafe  data Placeholder = Placeholder Int@@ -58,7 +60,7 @@ instance (SqlType a, Prepare q b) => Prepare q (a -> b) where   mkFun ref sid qry ps x = mkFun ref sid qry (param x : ps) -instance (MonadSelda m, a ~ Res (ResultT q), Result (ResultT q)) =>+instance (Typeable a, MonadSelda m, a ~ Res (ResultT q), Result (ResultT q)) =>          Prepare q (m [a]) where   -- This function uses read/writeIORef instead of atomicModifyIORef.   -- For once, this is actually safe: the IORef points to a single compiled@@ -109,11 +111,11 @@           _ -> do             res <- runPrepared backend hdl ps             cache (stmtTables stm) key res-            return $ map (toRes (Proxy :: Proxy (ResultT q))) (snd res)+            return $ map (buildResult (Proxy :: Proxy (ResultT q))) (snd res)  instance (SqlType a, Preparable b) => Preparable (Col s a -> b) where   mkQuery n f ts = mkQuery (n+1) (f x) (sqlType (Proxy :: Proxy a) : ts)-    where x = C $ Lit $ LCustom (throw (Placeholder n) :: Lit a)+    where x = One $ Lit $ LCustom (throw (Placeholder n) :: Lit a)  instance Result a => Preparable (Query s a) where   mkQuery _ q types = do

@@ -2,44 +2,43 @@ -- | Query monad and primitive operations. module Database.Selda.Query   ( select, selectValues, Database.Selda.Query.distinct-  , restrict, groupBy, limit, order+  , restrict, groupBy, limit, order, orderRandom   , aggregate, leftJoin, innerJoin   ) where import Data.Maybe (isNothing) import Database.Selda.Column+import Database.Selda.Generic import Database.Selda.Inner import Database.Selda.Query.Type import Database.Selda.SQL as SQL+import Database.Selda.SqlType (SqlType) import Database.Selda.Table import Database.Selda.Transform import Control.Monad.State.Strict import Unsafe.Coerce --- | Query the given table. Result is returned as an inductive tuple, i.e.---   @first :*: second :*: third <- query tableOfThree@.-select :: Columns (Cols s a) => Table a -> Query s (Cols s a)+-- | Query the given table.+select :: Relational a => Table a -> Query s (Row s a) select (Table name cs _) = Query $ do-    rns <- mapM (rename . Some . Col) cs'-    st <- get-    put $ st {sources = sqlFrom rns (TableName name) : sources st}-    return $ toTup [n | Named n _ <- rns]-  where-    cs' = map colName cs+  rns <- renameAll $ map colExpr cs+  st <- get+  put $ st {sources = sqlFrom rns (TableName name) : sources st}+  return $ Many (map hideRenaming rns)  -- | Query an ad hoc table of type @a@. Each element in the given list represents --   one row in the ad hoc table.-selectValues :: (Insert a, Columns (Cols s a)) => [a] -> Query s (Cols s a)+selectValues :: Relational a => [a] -> Query s (Row s a) selectValues [] = Query $ do   st <- get   put $ st {sources = sqlFrom [] EmptyTable : sources st}-  return $ toTup (repeat "NULL")+  return $ Many (repeat (Untyped $ Col "NULL")) selectValues (row:rows) = Query $ do     names <- mapM (const freshName) firstrow     let rns = [Named n (Col n) | n <- names]         row' = mkFirstRow names     s <- get     put $ s {sources = sqlFrom rns (Values row' rows') : sources s}-    return $ toTup [n | Named n _ <- rns]+    return $ Many (map hideRenaming rns)   where     firstrow = map defToVal $ params row     mkFirstRow ns =@@ -52,7 +51,7 @@  -- | Restrict the query somehow. Roughly equivalent to @WHERE@. restrict :: Col s Bool -> Query s ()-restrict (C p) = Query $ do+restrict (One p) = Query $ do     st <- get     put $ case sources st of       [] ->@@ -87,18 +86,18 @@ -- > -- SELECT COUNT(name) AS c, address FROM housing GROUP BY name HAVING c > 1 -- > -- > numPpl = do--- >   (num_tenants :*: address) <- aggregate $ do--- >     (_ :*: address) <- select housing--- >     groupBy address--- >     return (count address :*: some address)+-- >   (num_tenants :*: theAddress) <- aggregate $ do+-- >     h <- select housing+-- >     theAddress <- groupBy (h ! address)+-- >     return (count (h ! address) :*: theAddress) -- >  restrict (num_tenants .> 1)--- >  return (num_tenants :*: address)+-- >  return (num_tenants :*: theAddress) aggregate :: (Columns (AggrCols a), Aggregates a)           => Query (Inner s) a           -> Query s (AggrCols a) aggregate q = Query $ do   (gst, aggrs) <- isolate q-  cs <- mapM rename $ unAggrs aggrs+  cs <- renameAll $ unAggrs aggrs   let sql = (sqlFrom cs (Product [state2sql gst])) {groups = groupCols gst}   modify $ \st -> st {sources = sql : sources st}   pure $ toTup [n | Named n _ <- cs]@@ -147,12 +146,12 @@          -> Query s a' someJoin jointype check q = Query $ do   (join_st, res) <- isolate q-  cs <- mapM rename $ fromTup res+  cs <- renameAll $ fromTup res   st <- get   let nameds = [n | Named n _ <- cs]       left = state2sql st       right = sqlFrom cs (Product [state2sql join_st])-      C on = check $ toTup nameds+      One on = check $ toTup nameds       outCols = [Some $ Col n | Named n _ <- cs] ++ allCols [left]   put $ st {sources = [sqlFrom outCols (Join jointype on left right)]}   pure $ toTup nameds@@ -164,11 +163,11 @@ --   how many people have a pet at home: -- -- > aggregate $ do--- >   (name :*: pet_name) <- select people--- >   name' <- groupBy name--- >   return (name' :*: count(pet_name) .> 0)-groupBy :: Col (Inner s) a -> Query (Inner s) (Aggr (Inner s) a)-groupBy (C c) = Query $ do+-- >   person <- select people+-- >   name' <- groupBy (person ! name)+-- >   return (name' :*: count(person ! pet_name) .> 0)+groupBy :: SqlType a => Col (Inner s) a -> Query (Inner s) (Aggr (Inner s) a)+groupBy (One c) = Query $ do   st <- get   put $ st {groupCols = Some c : groupCols st}   return (Aggr c)@@ -193,12 +192,12 @@ --   To get a list of persons sorted primarily on age and secondarily on name: -- -- > peopleInAgeAndNameOrder = do--- >   (name :*: age) <- select people--- >   order name ascending--- >   order age ascending--- >   return name+-- >   person <- select people+-- >   order (person ! name) ascending+-- >   order (person ! age) ascending+-- >   return (person ! name) -----   For a table @["Alice" :*: 20, "Bob" :*: 20, "Eve" :*: 18]@, this query+--   For a table @[("Alice", 20), ("Bob", 20), ("Eve", 18)]@, this query --   will always return @["Eve", "Alice", "Bob"]@. -- --   The reason for later orderings taking precedence and not the other way@@ -207,13 +206,17 @@ --   is buried somewhere deep in an earlier query. --   However, the ordering must always be stable, to ensure that previous --   calls to order are not simply erased.-order :: Col s a -> Order -> Query s ()-order (C c) o = Query $ do+order :: SqlType a => Col s a -> Order -> Query s ()+order (One c) o = Query $ do   st <- get   case sources st of     [sql] -> put st {sources = [sql {ordering = (o, Some c) : ordering sql}]}-    ss    -> put st {sources = [sql {ordering = [(o,Some c)]}]}+    ss    -> put st {sources = [sql {ordering = [(o, Some c)]}]}       where sql = sqlFrom (allCols ss) (Product ss)++-- | Sort the result rows in random order.+orderRandom :: Query s ()+orderRandom = order (One (NulOp (Fun0 "RANDOM") :: Exp SQL Int)) Asc  -- | Remove all duplicates from the result set. distinct :: Query s a -> Query s a

@@ -1,7 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# 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 import Data.Text (pack) import Database.Selda.SQL import Database.Selda.Column@@ -57,18 +59,19 @@   , nameScope  = scope   } +renameAll :: [UntypedCol sql] -> State GenState [SomeCol sql]+renameAll = fmap concat . mapM rename+ -- | Generate a unique name for the given column.-rename :: SomeCol sql -> State GenState (SomeCol sql)-rename (Some col) = do+rename :: UntypedCol sql -> State GenState [SomeCol sql]+rename (Untyped col) = do     n <- freshId-    return $ Named (newName n) col+    return [Named (newName n) col]   where     newName ns =       case col of         Col n -> addColSuffix n $ "_" <> pack (show ns)         _     -> mkColName $ "tmp_" <> pack (show ns)-rename col@(Named _ _) = do-  return col  -- | Get a guaranteed unique identifier. freshId :: State GenState Name

@@ -1,14 +1,14 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE TypeOperators, FlexibleInstances, UndecidableInstances #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, CPP #-} -- | SQL AST and parameters for prepared statements. module Database.Selda.SQL where import Database.Selda.Exp import Database.Selda.SqlType import Database.Selda.Types-import Control.Exception+#if !MIN_VERSION_base(4, 11, 0) import Data.Monoid hiding (Product)-import System.IO.Unsafe+#endif  -- | A source for an SQL query. data SqlSource@@ -85,31 +85,3 @@ -- | The SQL type of the given parameter. paramType :: Param -> SqlTypeRep paramType (Param p) = litType p---- | Exception indicating the use of a default value.---   If any values throwing this during evaluation of @param xs@ will be---   replaced by their default value.-data DefaultValueException = DefaultValueException-  deriving Show-instance Exception DefaultValueException---- | An inductive tuple of Haskell-level values (i.e. @Int :*: Maybe Text@)---   which can be inserted into a table.-class Insert a where-  params :: a -> [Either Param Param]-instance (SqlType a, Insert b) => Insert (a :*: b) where-  params (a :*: b) = unsafePerformIO $ do-    res <- try $ return $! a-    return $ case res of-      Right a' ->-        Right (Param (mkLit a')) : params b-      Left DefaultValueException ->-        Left (Param (defaultValue :: Lit a)) : params b-instance {-# OVERLAPPABLE #-} SqlType a => Insert a where-  params a = unsafePerformIO $ do-    res <- try $ return $! a-    return $ case res of-      Right a' ->-        [Right $ Param (mkLit a')]-      Left DefaultValueException ->-        [Left $ Param (defaultValue :: Lit a)]

@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, OverloadedStrings #-}+{-# LANGUAGE GADTs, OverloadedStrings, CPP #-} -- | Pretty-printing for SQL queries. For some values of pretty. module Database.Selda.SQL.Print where import Database.Selda.Column@@ -9,7 +9,9 @@ import Database.Selda.Types import Control.Monad.State import Data.List+#if !MIN_VERSION_base(4, 11, 0) import Data.Monoid hiding (Product)+#endif import Data.Text (Text) import qualified Data.Text as Text @@ -216,11 +218,11 @@   pure $ Cfg.ppTypePK c t  ppCol :: Exp SQL a -> PP Text-ppCol (TblCol xs)    = error $ "compiler bug: ppCol saw TblCol: " ++ show xs ppCol (Col name)     = pure (fromColName name) ppCol (Lit l)        = ppLit l ppCol (BinOp op a b) = ppBinOp op a b ppCol (UnOp op a)    = ppUnOp op a+ppCol (NulOp a)      = ppNulOp a ppCol (Fun2 f a b)   = do   a' <- ppCol a   b' <- ppCol b@@ -243,6 +245,9 @@   x' <- ppCol x   q' <- ppSql q   pure $ mconcat [x', " IN (", q', ")"]++ppNulOp :: NulOp a -> PP Text+ppNulOp (Fun0 f) = pure $ f <> "()"  ppUnOp :: UnOp a b -> Exp SQL a -> PP Text ppUnOp op c = do

@@ -41,6 +41,10 @@     --   has more than this many columns, you should really rethink     --   your database design.   , ppMaxInsertParams :: Maybe Int++    -- | @CREATE INDEX@ suffix to indicate that the index should use the given+    --   index method.+  , ppIndexMethodHook :: IndexMethod -> Text   }  -- | Default settings for pretty-printing.@@ -58,6 +62,7 @@     , ppColAttrsHook = \_ ats _ -> T.unwords $ map defColAttr ats     , ppAutoIncInsert = "NULL"     , ppMaxInsertParams = Nothing+    , ppIndexMethodHook = const ""     }  -- | Default compilation for SQL types.@@ -79,3 +84,4 @@ defColAttr Required      = "NOT NULL" defColAttr Optional      = "NULL" defColAttr Unique        = "UNIQUE"+defColAttr (Indexed _)   = ""

@@ -1,93 +1,116 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies, MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators, UndecidableInstances, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, RankNTypes, AllowAmbiguousTypes, GADTs #-}-module Database.Selda.Selectors where-import Database.Selda.Table+{-# LANGUAGE DeriveGeneric, CPP #-}+module Database.Selda.Selectors+  ( Assignment ((:=)), Selected, Selector, Source, Selectors, GSelectors+  , (!), with, ($=)+  , selectorsFor, selectorIndex+  ) where+import Control.Monad.State.Strict+import Database.Selda.SqlType import Database.Selda.Types import Database.Selda.Column-import Data.Dynamic import Data.List (foldl') import Data.Proxy+import GHC.Generics hiding (Selector, (:*:))+import qualified GHC.Generics as G import Unsafe.Coerce --- | Get the value at the given index from the given inductive tuple.-(!)  :: forall s t a. ToDyn (Cols () t) => Cols s t -> Selector t a -> Col s a-tup ! (Selector n) = unsafeCoerce (unsafeToList (toU tup) !! n)-  where toU = unsafeCoerce :: Cols s t -> Cols () t+-- | The result of a '(!)' operation.+--   If either the source row, the column to extract,+--   or both, is nullable, the result is also nullable.+type family Selected a b where+  Selected (Maybe a) (Maybe b) = Maybe b+  Selected (Maybe a) b         = Maybe b+  Selected a         b         = b -upd :: forall s t. (ToDyn (Cols () t))-     => Cols s t -> Assignment s t -> Cols s t-upd tup (Selector n := x) =-    fromU . unsafeFromList $ replace (unsafeToList $ toU tup) (unsafeCoerce x)+-- | The source type of a '(!)' operation.+type family Source a where+  Source (Maybe a) = a+  Source a         = a++-- | Extract the given column from the given row.+--   Extracting a value from a nullable column will yield a nullable value.+--   In other words, this operator is null-coalescing.+(!) :: SqlType b => Row s a -> Selector (Source a) b -> Col s (Selected a b)+(Many xs) ! (Selector i) = case xs !! i of Untyped x -> One (unsafeCoerce x)++upd :: Row s a -> Assignment s a -> Row s a+upd (Many xs) (Selector i := (One x')) =+  case splitAt i xs of+    (left, _:right) -> Many (left ++ Untyped x' : right)+    _               -> error "BUG: too few columns in row!"+upd (Many xs) (Modify (Selector i) f) =+  case splitAt i xs of+    (left, Untyped x:right) -> Many (left ++ f' (unsafeCoerce x) : right)+    _                       -> error "BUG: too few columns in row!"   where-    toU = unsafeCoerce :: Cols s t -> Cols () t-    fromU = unsafeCoerce :: Cols () t -> Cols s t-    replace xs x' =-      case splitAt n xs of-        (left, _:right) -> left ++ x' : right-        _               -> error "impossible"+    f' x = case f (One x) of+      One y -> Untyped y  -- | A selector-value assignment pair.-data Assignment s t where+data Assignment s a where+#if MIN_VERSION_base(4, 9, 0)+  -- | Set the given column to the given value.+#endif   (:=) :: Selector t a -> Col s a -> Assignment s t++#if MIN_VERSION_base(4, 9, 0)+  -- | Modify the given column by the given function.+#endif+  Modify :: Selector t a -> (Col s a -> Col s a) -> Assignment s t infixl 2 := +-- | Apply the given function to the given column.+($=) :: Selector t a -> (Col s a -> Col s a) -> Assignment s t+($=) = Modify+infixl 2 $=+ -- | For each selector-value pair in the given list, on the given tuple, --   update the field pointed out by the selector with the corresponding value.-with :: forall s t. (ToDyn (Cols () t))-     => Cols s t -> [Assignment s t] -> Cols s t+with :: Row s a -> [Assignment s a] -> Row s a with = foldl' upd  -- | A column selector. Column selectors can be used together with the '!' and---   'with' functions to get and set values on inductive tuples, or to indicate+--   'with' functions to get and set values on rows, or to specify --   foreign keys.-data Selector t a = Selector Int+newtype Selector t a = Selector {selectorIndex :: Int} --- | The inductive tuple of selectors for a table of type @a@.-type family Selectors t a where-  Selectors t (a :*: b) = (Selector t a :*: Selectors t b)-  Selectors t a         = Selector t a+-- | Generate selectors for the given type.+selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r+selectorsFor = flip evalState 0 . mkSel (Proxy :: Proxy (Rep r)) --- | Generate selector functions for the given table.---   Selectors can be used to access the fields of a query result tuple, avoiding---   the need to pattern match on the entire tuple.------ > tbl :: Table (Int :*: Text)--- > tbl = table "foo" $ required "bar" :*: required "baz"--- > (tblBar :*: tblBaz) = selectors tbl--- >--- > q :: Query s Text--- > q = tblBaz <$> select tbl-selectors :: forall a. HasSelectors a a => Table a -> Selectors a a-selectors _ = mkSel (Proxy :: Proxy a) 0 (Proxy :: Proxy a)+-- | An inductive tuple of selectors for the given relation.+type Selectors r = Sels r (Rep r) +type family Sels t f where+  Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c))+  Sels t (a G.:*: b)           = Sels t a :*: Sels t b+  Sels t (M1 x y f)            = Sels t f+  Sels t (K1 i a)              = Selector t a+ -- | Any table type that can have selectors generated.-class HasSelectors t a where-  mkSel :: Proxy t -> Int -> Proxy a -> Selectors t a+class GSelectors t (f :: * -> *) where+  mkSel :: Proxy f -> Proxy t -> State Int (Sels t f) -instance (Typeable a, HasSelectors t b) => HasSelectors t (a :*: b) where-  mkSel p n _ = (Selector n :*: mkSel p (n+1) (Proxy :: Proxy b))+instance SqlType a => GSelectors t (K1 i a) where+  mkSel _ _ = Selector <$> state (\n -> (n, n+1)) -instance {-# OVERLAPPABLE #-} (Selectors t a ~ Selector t a) =>-         HasSelectors t a where-  mkSel _ n _ = Selector n+instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) =>+         GSelectors t (M1 x y f) where+  mkSel _ = mkSel (Proxy :: Proxy f) --- | A pair of the table with the given name and columns, and all its selectors.---   For example:------ > tbl :: Table (Int :*: Text)--- > (tbl, tblBar :*: tblBaz)--- >   =  tableWithSelectors "foo"--- >   $  required "bar"--- >   :*: required "baz"--- >--- > q :: Query s Text--- > q = tblBaz <$> select tbl-tableWithSelectors :: forall a. (TableSpec a, HasSelectors a a)-                   => TableName-                   -> ColSpecs a-                   -> (Table a, Selectors a a)-tableWithSelectors name cs = (t, s)-  where-    t = table name cs-    s = selectors t+instance GSelectors t (a G.:*: (b G.:*: c)) =>+         GSelectors t ((a G.:*: b) G.:*: c) where+  mkSel _ = mkSel (Proxy :: Proxy (a G.:*: (b G.:*: c)))++instance {-# OVERLAPPABLE #-}+  ( GSelectors t a+  , GSelectors t b+  , Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b)+  ) => GSelectors t (a G.:*: b) where+    mkSel _ p = do+      x <- mkSel (Proxy :: Proxy a) p+      xs <- mkSel (Proxy :: Proxy b) p+      return (x :*: xs)

@@ -0,0 +1,90 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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+  , runResultReader, next+  ) where+import Control.Monad.State.Strict+import Database.Selda.SqlType+import Data.Typeable+import GHC.Generics++newtype ResultReader a = R (State [SqlValue] a)+  deriving (Functor, Applicative, Monad)++runResultReader :: ResultReader a -> [SqlValue] -> a+runResultReader (R m) = evalState m++next :: ResultReader SqlValue+next = R . state $ \s -> (head s, tail s)++class Typeable a => SqlRow a where+  -- | Read the next, potentially composite, result from a stream of columns.+  nextResult :: ResultReader a+  default nextResult :: (Generic a, GSqlRow (Rep a)) => ResultReader a+  nextResult = to <$> gNextResult++  -- | The number of nested columns contained in this type.+  nestedCols :: Proxy a -> Int+  default nestedCols :: (Generic a, GSqlRow (Rep a)) => Proxy a -> Int+  nestedCols _ = gNestedCols (Proxy :: Proxy (Rep a))+++-- * Generic derivation for SqlRow+class GSqlRow f where+  gNextResult :: ResultReader (f x)+  gNestedCols :: Proxy f -> Int++instance SqlType a => GSqlRow (K1 i a) where+  gNextResult = K1 <$> fromSql <$> next+  gNestedCols _ = 1++instance GSqlRow f => GSqlRow (M1 c i f) where+  gNextResult = M1 <$> gNextResult+  gNestedCols _ = gNestedCols (Proxy :: Proxy f)++instance (GSqlRow a, GSqlRow b) => GSqlRow (a :*: b) where+  gNextResult = liftM2 (:*:) gNextResult gNextResult+  gNestedCols _ = gNestedCols (Proxy :: Proxy a) + gNestedCols (Proxy :: Proxy b)+++-- * Various instances+instance SqlRow a => SqlRow (Maybe a) where+  nextResult = do+      xs <- R get+      if all isNull (take (nestedCols (Proxy :: Proxy a)) xs)+        then return Nothing+        else Just <$> nextResult+    where+      isNull SqlNull = True+      isNull _       = False+  nestedCols _ = nestedCols (Proxy :: Proxy a)++instance+  ( Typeable (a, b)+  , GSqlRow (Rep (a, b))+  ) => SqlRow (a, b)+instance+  ( Typeable (a, b, c)+  , GSqlRow (Rep (a, b, c))+  ) => SqlRow (a, b, c)+instance+  ( Typeable (a, b, c, d)+  , GSqlRow (Rep (a, b, c, d))+  ) => SqlRow (a, b, c, d)+instance+  ( Typeable (a, b, c, d, e)+  , GSqlRow (Rep (a, b, c, d, e))+  ) => SqlRow (a, b, c, d, e)+instance+  ( Typeable (a, b, c, d, e, f)+  , GSqlRow (Rep (a, b, c, d, e, f))+  ) => SqlRow (a, b, c, d, e, f)+instance+  ( Typeable (a, b, c, d, e, f, g)+  , GSqlRow (Rep (a, b, c, d, e, f, g))+  ) => SqlRow (a, b, c, d, e, f, g)

@@ -1,10 +1,11 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances, DefaultSignatures #-} -- | Types representable in Selda's subset of SQL. module Database.Selda.SqlType   ( SqlType (..), SqlEnum (..)-  , Lit (..), RowID, SqlValue (..), SqlTypeRep (..)-  , invalidRowId, isInvalidRowId, unsafeRowId, fromRowId+  , Lit (..), RowID, ID (..), SqlValue (..), SqlTypeRep (..)+  , invalidRowId, isInvalidRowId, toRowId, fromRowId+  , toId, invalidId, isInvalidId   , compLit, litType   , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat   ) where@@ -47,6 +48,8 @@ class Typeable a => SqlType a where   -- | Create a literal of this type.   mkLit :: a -> Lit a+  default mkLit :: (Typeable a, SqlEnum a) => a -> Lit a+  mkLit = LCustom . LText . toText    -- | The SQL representation for this type.   sqlType :: Proxy a -> SqlTypeRep@@ -54,9 +57,13 @@    -- | Convert an SqlValue into this type.   fromSql :: SqlValue -> a+  default fromSql :: (Typeable a, SqlEnum a) => SqlValue -> a+  fromSql = fromText . fromSql    -- | Default value when using 'def' at this type.   defaultValue :: Lit a+  default defaultValue :: (Typeable a, SqlEnum a) => Lit a+  defaultValue = LCustom $ mkLit (toText (minBound :: a))  -- | Any type that's bounded, enumerable and has a text representation, and --   thus representable as a Selda enumerable.@@ -187,16 +194,39 @@ isInvalidRowId (RowID n) = n < 0  -- | Create a row identifier from an integer.---   A row identifier created using this function is not guaranteed to be a---   valid row identifier.---   Do not use unless you are absolutely sure what you're doing.-unsafeRowId :: Int -> RowID-unsafeRowId = RowID+--   Use with caution, preferably only when reading user input.+toRowId :: Int -> RowID+toRowId = RowID  -- | Inspect a row identifier. fromRowId :: RowID -> Int fromRowId (RowID n) = n +-- | A typed row identifier.+--   Generic tables should use this instead of 'RowID'.+--   Use 'untyped' to erase the type of a row identifier, and @cast@ from the+--   "Database.Selda.Unsafe" module if you for some reason need to add a type+--   to a row identifier.+newtype ID a = ID {untyped :: RowID}+  deriving (Eq, Ord, Typeable)+instance Show (ID a) where+  show = show . untyped++-- | Create a typed row identifier from an integer.+--   Use with caution, preferably only when reading user input.+toId :: Int -> ID a+toId = ID . toRowId++-- | A typed row identifier which is guaranteed to not match any row in any+--   table.+invalidId :: ID a+invalidId = ID invalidRowId++-- | Is the given typed row identifier invalid? I.e. is it guaranteed to not+--   match any row in any table?+isInvalidId :: ID a -> Bool+isInvalidId = isInvalidRowId . untyped+ instance SqlType RowID where   mkLit (RowID n) = LCustom $ LInt n   sqlType _ = TRowID@@ -204,6 +234,12 @@   fromSql v          = error $ "fromSql: RowID column with non-int value: " ++ show v   defaultValue = mkLit invalidRowId +instance Typeable a => SqlType (ID a) where+  mkLit (ID n) = LCustom $ mkLit n+  sqlType _ = TRowID+  fromSql = ID . fromSql+  defaultValue = mkLit (ID invalidRowId)+ instance SqlType Int where   mkLit = LInt   sqlType _ = TInt@@ -286,8 +322,4 @@   fromSql x         = Just $ fromSql x   defaultValue = LNull -instance {-# OVERLAPPABLE #-} (Typeable a, SqlEnum a) => SqlType a where-  mkLit = LCustom . LText . toText-  sqlType _ = sqlType (Proxy :: Proxy Text)-  fromSql = fromText . fromSql-  defaultValue = LCustom $ mkLit (toText (minBound :: a))+instance SqlType Ordering

@@ -1,207 +1,194 @@-{-# LANGUAGE TypeOperators, TypeFamilies, OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}-{-# LANGUAGE CPP, DataKinds #-}--- | Selda table definition language.-module Database.Selda.Table where+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}+{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds #-}+module Database.Selda.Table+  ( Attr (..), Table (..), Attribute+  , ColInfo (..), ColAttr (..), IndexMethod (..)+  , ForeignKey (..)+  , table, tableFieldMod, tableWithSelectors, selectors+  , primary, autoPrimary, untypedAutoPrimary, unique+  , index, indexUsing+  , tableExpr+  ) where+import Data.Text (Text)+#if MIN_VERSION_base(4, 10, 0)+import Data.Typeable+#else+import Data.Proxy+#endif import Database.Selda.Types+import Database.Selda.Selectors import Database.Selda.SqlType-import Control.Exception hiding (TypeError)-import GHC.Exts-import GHC.TypeLits-import Data.Dynamic-import Data.List (sort, group)-import Data.Monoid-import Data.Proxy-import Data.Text (unpack, intercalate, any)+import Database.Selda.Column (Row (..))+import Database.Selda.Generic+import Database.Selda.Table.Type+import Database.Selda.Table.Validation (snub) --- | An error occurred when validating a database table.---   If this error is thrown, there is a bug in your database schema, and the---   particular table that triggered the error is unusable.---   Since validation is deterministic, this error will be thrown on every---   consecutive operation over the offending table.------   Therefore, it is not meaningful to handle this exception in any way,---   just fix your bug instead.-data ValidationError = ValidationError String-  deriving (Show, Eq, Typeable)-instance Exception ValidationError+-- | A generic column attribute.+--   Essentially a pair or a record selector over the type @a@ and a column+--   attribute.+data Attr a where+  (:-) :: (a -> b) -> Attribute a b -> Attr a --- | A database table.---   Tables are parameterized over their column types. For instance, a table---   containing one string and one integer, in that order, would have the type---   @Table (Text :*: Int)@, and a table containing only a single string column---   would have the type @Table Text@.+-- | Generate a table from the given table name and list of column attributes.+--   All @Maybe@ fields in the table's type will be represented by nullable+--   columns, and all non-@Maybe@ fields fill be represented by required+--   columns.+--   For example: -----   Table and column names may contain any character except @\NUL@, and be---   non-empty. Column names must be unique per table.-data Table a = Table-  { -- | Name of the table. NOT guaranteed to be a valid SQL name.-    tableName :: TableName-    -- | All table columns.-    --   Invariant: the 'colAttrs' list of each column is sorted and contains-    --   no duplicates.-  , tableCols :: [ColInfo]-    -- | Does the given table have an auto-incrementing primary key?-  , tableHasAutoPK :: Bool-  }+-- > data Person = Person+-- >   { id   :: Int+-- >   , name :: Text+-- >   , age  :: Int+-- >   , pet  :: Maybe Text+-- >   }+-- >   deriving Generic+-- >+-- > people :: Table Person+-- > people = table "people" [name :- autoPrimary]+--+--   This example will create a table with the column types+--   @Int :*: Text :*: Int :*: Maybe Text@, where the first field is+--   an auto-incrementing primary key.+--+--   If the given type is not a record type, the column names will be+--   @col_1@, @col_2@, etc.+table :: forall a. Relational a+         => TableName+         -> [Attr a]+         -> Table a+table tn attrs = tableFieldMod tn attrs id -data ColInfo = ColInfo-  { colName  :: ColName-  , colType  :: SqlTypeRep-  , colAttrs :: [ColAttr]-  , colFKs   :: [(Table (), ColName)]+-- | Generate a table from the given table name,+--   a list of column attributes and a function+--   that maps from field names to column names.+--   Ex.:+--+-- > data Person = Person+-- >   { personId   :: Int+-- >   , personName :: Text+-- >   , personAge  :: Int+-- >   , personPet  :: Maybe Text+-- >   }+-- >   deriving Generic+-- >+-- > people :: Table Person+-- > people = tableFieldMod "people" [personName :- autoPrimaryGen] (stripPrefix "person")+--+--   This will create a table with the columns named+--   @Id@, @Name@, @Age@ and @Pet@.+tableFieldMod :: forall a. Relational a+                 => TableName+                 -> [Attr a]+                 -> (Text -> Text)+                 -> Table a+tableFieldMod tn attrs fieldMod = Table+  { tableName = tn+  , tableCols = map tidy cols+  , tableHasAutoPK = apk   }--newCol :: forall a. SqlType a => ColName -> ColSpec a-newCol name = ColSpec [ColInfo-  { colName  = name-  , colType  = sqlType (Proxy :: Proxy a)-  , colAttrs = []-  , colFKs   = []-  }]---- | A table column specification.-newtype ColSpec a = ColSpec {unCS :: [ColInfo]}---- | Any SQL type which is NOT nullable.-type family NonNull a :: Constraint where-#if MIN_VERSION_base(4, 9, 0)-  NonNull (Maybe a) = TypeError-    ( Text "Optional columns must not be nested, and" :<>:-      Text " required or primary key columns" :$$:-      Text "must not have option types."-    )-#else-  NonNull (Maybe a) = a ~ Maybe a-#endif-  NonNull a         = ()---- | Column attributes such as nullability, auto increment, etc.---   When adding elements, make sure that they are added in the order---   required by SQL syntax, as this list is only sorted before being---   pretty-printed.-data ColAttr = Primary | AutoIncrement | Required | Optional | Unique-  deriving (Show, Eq, Ord)+  where+    dummy = mkDummy+    cols = zipWith addAttrs [0..] (tblCols (Proxy :: Proxy a) fieldMod)+    apk = or [AutoIncrement `elem` as | _ :- Attribute as <- attrs]+    addAttrs n ci = ci+      { colAttrs = colAttrs ci ++ concat+          [ as+          | f :- Attribute as <- attrs+          , identify dummy f == n+          ]+      , colFKs = colFKs ci +++          [ thefk+          | f :- ForeignKey thefk <- attrs+          , identify dummy f == n+          ]+      } --- | A non-nullable column with the given name.-required :: (SqlType a, NonNull a) => ColName -> ColSpec a-required = addAttr Required . newCol+-- | Remove duplicate attributes.+tidy :: ColInfo -> ColInfo+tidy ci = ci {colAttrs = snub $ colAttrs ci} --- | A nullable column with the given name.-optional :: (SqlType a, NonNull a) => ColName -> ColSpec (Maybe a)-optional = addAttr Optional . newCol+-- | A pair of the table with the given name and columns, and all its selectors.+--   For example:+--+-- > tbl :: Table (Int :*: Text)+-- > (tbl, tblBar :*: tblBaz)+-- >   =  tableWithSelectors "foo"+-- >   $  required "bar"+-- >   :*: required "baz"+-- >+-- > q :: Query s Text+-- > q = tblBaz <$> select tbl+tableWithSelectors :: forall a. Relational a+                   => TableName+                   -> [Attr a]+                   -> (Table a, Selectors a)+tableWithSelectors name cs = (t, s)+  where+    t = table name cs+    s = selectors t --- | Marks the given column as the table's primary key.---   A table may only have one primary key; marking more than one key as---   primary will result in 'ValidationError' during validation.-primary :: (SqlType a, NonNull a) => ColName -> ColSpec a-primary = addAttr Primary . unique . required+-- | Generate selector functions for the given table.+--   Selectors can be used to access the fields of a query result tuple, avoiding+--   the need to pattern match on the entire tuple.+--+-- > tbl :: Table (Int :*: Text)+-- > tbl = table "foo" $ required "bar" :*: required "baz"+-- > (tblBar :*: tblBaz) = selectors tbl+-- >+-- > q :: Query s Text+-- > q = tblBaz <$> select tbl+selectors :: forall a. Relational a => Table a -> Selectors a+selectors _ = selectorsFor (Proxy :: Proxy a) --- | Automatically increment the given attribute if not specified during insert.---   Also adds the @PRIMARY KEY@ and @UNIQUE@ attributes on the column.-autoPrimary :: ColName -> ColSpec RowID-autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required, Unique]}]-  where ColSpec [c] = newCol n :: ColSpec RowID+-- | Some attribute that may be set on a column of type @c@, in a table of+--   type @t@.+data Attribute t c+  = Attribute [ColAttr]+  | ForeignKey (Table (), ColName) --- | Add a uniqueness constraint to the given column.---   Adding a uniqueness constraint to a column that is already implied to be---   unique, such as a primary key, is a no-op.-unique :: SqlType a => ColSpec a -> ColSpec a-unique = addAttr Unique+-- | A primary key which does not auto-increment.+primary :: Attribute t c+primary = Attribute [Primary, Required, Unique] --- | Add an attribute to a column. Not for public consumption.-addAttr :: SqlType a => ColAttr -> ColSpec a -> ColSpec a-addAttr attr (ColSpec [ci]) = ColSpec [ci {colAttrs = attr : colAttrs ci}]-addAttr _ _                 = error "impossible: ColSpec with several columns"+-- | Create an index on this column.+index :: Attribute t c+index = Attribute [Indexed Nothing] --- | An inductive tuple where each element is a column specification.-type family ColSpecs a where-  ColSpecs (a :*: b) = ColSpec a :*: ColSpecs b-  ColSpecs a         = ColSpec a+-- | Create an index using the given index method on this column.+indexUsing :: IndexMethod -> Attribute t c+indexUsing m = Attribute [Indexed (Just m)] --- | An inductive tuple forming a table specification.-class TableSpec a where-  mergeSpecs :: Proxy a -> ColSpecs a -> [ColInfo]-instance TableSpec b => TableSpec (a :*: b) where-  mergeSpecs _ (ColSpec a :*: b) = a ++ mergeSpecs (Proxy :: Proxy b) b-instance {-# OVERLAPPABLE #-} ColSpecs a ~ ColSpec a => TableSpec a where-  mergeSpecs _ (ColSpec a) = a+-- | An auto-incrementing primary key.+autoPrimary :: Attribute t (ID t)+autoPrimary = Attribute [Primary, AutoIncrement, Required, Unique] --- | A table with the given name and columns.-table :: forall a. TableSpec a => TableName -> ColSpecs a -> Table a-table name cs = Table-    { tableName = name-    , tableCols = tcs-    , tableHasAutoPK = Prelude.any ((AutoIncrement `elem`) . colAttrs) tcs-    }-  where-    tcs = map tidy $ mergeSpecs (Proxy :: Proxy a) cs+-- | An untyped auto-incrementing primary key.+--   You should really only use this for ad hoc tables, such as tuples.+untypedAutoPrimary :: Attribute t RowID+untypedAutoPrimary = Attribute [Primary, AutoIncrement, Required, Unique] --- | Remove duplicate attributes.-tidy :: ColInfo -> ColInfo-tidy ci = ci {colAttrs = snub $ colAttrs ci}+-- | A table-unique value.+unique :: Attribute t c+unique = Attribute [Unique] --- | Sort a list and remove all duplicates from it.-snub :: (Ord a, Eq a) => [a] -> [a]-snub = map head . soup+mkFK :: Table t -> Selector a b -> Attribute c d+mkFK (Table tn tcs tapk) sel =+  ForeignKey (Table tn tcs tapk, colName (tcs !! selectorIndex sel)) --- | Sort a list, then group all identical elements.-soup :: Ord a => [a] -> [[a]]-soup = group . sort+class ForeignKey a b where+  -- | A foreign key constraint referencing the given table and column.+  foreignKey :: Table t -> Selector t a -> Attribute self b --- | Ensure that there are no duplicate column names or primary keys.-validate :: TableName -> [ColInfo] -> [ColInfo]-validate name cis-  | null errs = cis-  | otherwise = throw $ ValidationError $ concat-      [ "validation of table ", unpack $ fromTableName name, " failed:"-      , "\n  "-      , unpack $ intercalate "\n  " errs-      ]-  where-    colIdents = map (fromColName . colName) cis-    allIdents = fromTableName name : colIdents-    errs = concat-      [ dupes-      , pkDupes-      , optionalRequiredMutex-      , nulIdents-      , emptyIdents-      , emptyTableName-      , nonPkFks-      ]-    emptyTableName-      | fromTableName name == "\"\"" = ["table name is empty"]-      | otherwise                    = []-    emptyIdents-      | Prelude.any (== "\"\"") colIdents =-        ["table has columns with empty names"]-      | otherwise =-        []-    nulIdents =-      [ "table or column name contains \\NUL: " <> n-      | n <- allIdents-      , Data.Text.any (== '\NUL') n-      ]-    dupes =-      ["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis]-    pkDupes =-      ["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis]-    nonPkFks =-      [ "column is used as a foreign key, but is not primary or unique: "-          <> fromTableName ftn <> "." <> fromColName fcn-      | ci <- cis-      , (Table ftn fcs _, fcn) <- colFKs ci-      , fc <- fcs-      , colName fc == fcn-      , not (Unique `elem` colAttrs fc)-      ]+instance ForeignKey a a where+  foreignKey = mkFK+instance ForeignKey (Maybe a) a where+  foreignKey = mkFK+instance ForeignKey a (Maybe a) where+  foreignKey = mkFK -    -- This should be impossible, but...-    optionalRequiredMutex =-      [ "BUG: column " <> fromColName (colName ci)-                       <> " is both optional and required"-      | ci <- cis-      , Optional `elem` colAttrs ci && Required `elem` colAttrs ci-      ]+-- | An expression representing the given table.+tableExpr :: Table a -> Row s a+tableExpr = Many . map colExpr . tableCols

@@ -1,12 +1,15 @@-{-# LANGUAGE OverloadedStrings #-}+{-# 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 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 (params, param)+import Database.Selda.SQL hiding (param) import Database.Selda.SQL.Print.Config import Database.Selda.SqlType (SqlTypeRep(..)) import Database.Selda.Types@@ -14,23 +17,43 @@ data OnError = Fail | Ignore   deriving (Eq, Ord, Show) --- | Compile a @CREATE TABLE@ query from a table definition.-compileCreateTable :: PPConfig -> OnError -> Table a -> Text-compileCreateTable customColType ifex tbl = ensureValid `seq` mconcat-  [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "("-  , intercalate ", " (map (compileTableCol customColType) (tableCols tbl))-  , case allFKs of-      [] -> ""-      _  -> ", " <> intercalate ", " compFKs-  , ")"-  ]+-- | Compile a sequence of queries to create the given table, including indexes.+--   The first query in the sequence is always @CREATE TABLE@.+compileCreateTable :: PPConfig -> OnError -> Table a -> [Text]+compileCreateTable cfg ifex tbl =+    ensureValid `seq` (createTable : createIndexes)   where+    createTable = mconcat+      [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "("+      , intercalate ", " (map (compileTableCol cfg) (tableCols tbl))+      , case allFKs of+          [] -> ""+          _  -> ", " <> intercalate ", " compFKs+      , ")"+      ]+    createIndexes =+      [ compileCreateIndex cfg (tableName tbl) (colName col) mmethod+      | col <- tableCols tbl+      , Indexed mmethod <- colAttrs col+      ]     ifNotExists Fail   = ""     ifNotExists Ignore = "IF NOT EXISTS "     allFKs = [(colName ci, fk) | ci <- tableCols tbl, fk <- colFKs ci]     compFKs = zipWith (uncurry compileFK) allFKs [0..]-    ensureValid = validate (tableName tbl) (tableCols tbl)+    ensureValid = validateOrThrow (tableName tbl) (tableCols tbl) +-- | Compile a @CREATE INDEX@ query for the given index.+compileCreateIndex :: PPConfig -> TableName -> ColName -> Maybe IndexMethod -> Text+compileCreateIndex cfg tbl col mmethod = mconcat+  [ "CREATE INDEX "+  , fromColName $ addColPrefix col ("ix" <> rawTableName tbl <> "_")+  , " ON ", fromTableName tbl+  , case mmethod of+      Just method -> " " <> ppIndexMethodHook cfg method+      _           -> ""+  , " (", fromColName col, ")"+  ]+ -- | Compile a foreign key constraint. compileFK :: ColName -> (Table (), ColName) -> Int -> Text compileFK col (Table ftbl _ _, fcol) n = mconcat@@ -51,7 +74,7 @@     colAttrsHook = ppColAttrsHook cfg cty attrs (ppColAttrs cfg)     cty = colType ci     attrs = colAttrs ci-    ppType' +    ppType'       | cty == TRowID && [Primary, AutoIncrement] `areIn` attrs = ppTypePK       | otherwise = ppType     areIn x y = null (x \\ y)

@@ -1,30 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Foreign key support.-module Database.Selda.Table.Foreign where-import Database.Selda.Selectors-import Database.Selda.Table-import Unsafe.Coerce---- | Add a foreign key constraint to the given column, referencing---   the column indicated by the given table and selector.---   If the referenced column is not a primary key or has a---   uniqueness constraint, a 'ValidationError' will be thrown---   during validation.-fk :: ColSpec a -> (Table t, Selector t a) -> ColSpec a-fk (ColSpec [c]) (tbl, Selector i) =-    ColSpec [c {colFKs = thefk : colFKs c}]-  where-    Table _ tcs _ = tbl-    thefk = (unsafeCoerce tbl, colName (tcs !! i))-fk _ _ =-  error "impossible: ColSpec with several columns"---- | Like 'fk', but for nullable foreign keys.-optFk :: ColSpec (Maybe a) -> (Table t, Selector t a) -> ColSpec (Maybe a)-optFk (ColSpec [c]) (tbl, Selector i) =-    ColSpec [c {colFKs = thefk : colFKs c}]-  where-    Table _ tcs _ = tbl-    thefk = (unsafeCoerce tbl, colName (tcs !! i))-optFk _ _ =-  error "impossible: ColSpec with several columns"

@@ -0,0 +1,54 @@+module Database.Selda.Table.Type where+import Database.Selda.SqlType (SqlTypeRep)+import Database.Selda.SQL (SQL)+import Database.Selda.Types+import Database.Selda.Exp++-- | A database table, based on some Haskell data type.+--   Any single constructor type can form the basis of a table, as long as+--   it derives @Generic@ and all of its fields are instances of @SqlType@.+data Table a = Table+  { -- | Name of the table. NOT guaranteed to be a valid SQL name.+    tableName :: TableName++    -- | All table columns.+    --   Invariant: the 'colAttrs' list of each column is sorted and contains+    --   no duplicates.+  , tableCols :: [ColInfo]++    -- | Does the given table have an auto-incrementing primary key?+  , tableHasAutoPK :: Bool+  }++-- | A complete description of a database column.+data ColInfo = ColInfo+  { colName  :: ColName+  , colType  :: SqlTypeRep+  , colAttrs :: [ColAttr]+  , colFKs   :: [(Table (), ColName)]+  , colExpr  :: UntypedCol SQL+  }++-- | Column attributes such as nullability, auto increment, etc.+--   When adding elements, make sure that they are added in the order+--   required by SQL syntax, as this list is only sorted before being+--   pretty-printed.+data ColAttr+  = Primary+  | AutoIncrement+  | Required+  | Optional+  | Unique+  | Indexed (Maybe IndexMethod)+  deriving (Show, Eq, Ord)++-- | Method to use for indexing with 'indexedUsing'.+--   Index methods are ignored by the SQLite backend, as SQLite doesn't support+--   different index methods.+data IndexMethod+  = BTreeIndex+  | HashIndex+-- Omitted until the operator class business is sorted out+--  | GistIndex+--  | GinIndex+  deriving (Show, Eq, Ord)

@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+module Database.Selda.Table.Validation where+import Control.Exception+import Data.List (group, sort)+import Data.Text (Text, any, intercalate, unpack)+import Data.Typeable+import Database.Selda.Table.Type+import Database.Selda.Types+#if !MIN_VERSION_base(4, 11, 0)+import Data.Monoid+#endif++-- | An error occurred when validating a database table.+--   If this error is thrown, there is a bug in your database schema, and the+--   particular table that triggered the error is unusable.+--   Since validation is deterministic, this error will be thrown on every+--   consecutive operation over the offending table.+--+--   Therefore, it is not meaningful to handle this exception in any way,+--   just fix your bug instead.+data ValidationError = ValidationError String+  deriving (Show, Eq, Typeable)+instance Exception ValidationError++-- | Ensure that there are no duplicate column names or primary keys.+--   Returns a list of validation errors encountered.+validate :: TableName -> [ColInfo] -> [Text]+validate name cis = errs+  where+    colIdents = map (fromColName . colName) cis+    allIdents = fromTableName name : colIdents+    errs = concat+      [ dupes+      , pkDupes+      , optionalRequiredMutex+      , nulIdents+      , emptyIdents+      , emptyTableName+      , nonPkFks+      ]+    emptyTableName+      | fromTableName name == "\"\"" = ["table name is empty"]+      | otherwise                    = []+    emptyIdents+      | Prelude.any (== "\"\"") colIdents =+        ["table has columns with empty names"]+      | otherwise =+        []+    nulIdents =+      [ "table or column name contains \\NUL: " <> n+      | n <- allIdents+      , Data.Text.any (== '\NUL') n+      ]+    dupes =+      ["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis]+    pkDupes =+      ["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis]+    nonPkFks =+      [ "column is used as a foreign key, but is not primary or unique: "+          <> fromTableName ftn <> "." <> fromColName fcn+      | ci <- cis+      , (Table ftn fcs _, fcn) <- colFKs ci+      , fc <- fcs+      , colName fc == fcn+      , not (Unique `elem` colAttrs fc)+      ]++    -- This should be impossible, but...+    optionalRequiredMutex =+      [ "BUG: column " <> fromColName (colName ci)+                       <> " is both optional and required"+      | ci <- cis+      , Optional `elem` colAttrs ci && Required `elem` colAttrs ci+      ]++-- | Return all columns of the given table if the table schema is valid,+--   otherwise throw a 'ValidationError'.+validateOrThrow :: TableName -> [ColInfo] -> [ColInfo]+validateOrThrow name cols =+  case validate name cols of+    []     -> cols+    errors -> throw $ ValidationError $ concat+      [ "validation of table `", unpack $ fromTableName name+      , "' failed:\n  "+      , unpack $ intercalate "\n  " errors+      ]++-- | Sort a list and remove all duplicates from it.+snub :: (Ord a, Eq a) => [a] -> [a]+snub = map head . soup++-- | Sort a list, then group all identical elements.+soup :: Ord a => [a] -> [[a]]+soup = group . sort

@@ -5,17 +5,16 @@ {-# LANGUAGE CPP #-} -- | Basic Selda types. module Database.Selda.Types-  ( (:*:)(..), Head, Append (..), (:++:), ToDyn (..), Tup (..)+  ( (:*:)(..), Head, Tup (..)   , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth   , ColName, TableName-  , mkColName, mkTableName, addColSuffix, addColPrefix-  , fromColName, fromTableName+  , modColName, mkColName, mkTableName, addColSuffix, addColPrefix+  , fromColName, fromTableName, rawTableName   ) where import Data.Dynamic import Data.String import Data.Text (Text, replace, append) import GHC.Generics (Generic)-import Unsafe.Coerce  #ifndef NO_LOCALCACHE import Data.Hashable@@ -32,6 +31,10 @@ newtype TableName = TableName Text   deriving (Ord, Eq, Show, IsString) +-- | Modify the given column name using the given function.+modColName :: ColName -> (Text -> Text) -> ColName+modColName (ColName cn) f = ColName (f cn)+ -- | Add a prefix to a column name. addColPrefix :: ColName -> Text -> ColName addColPrefix (ColName cn) s = ColName $ Data.Text.append s cn@@ -48,6 +51,10 @@ fromTableName :: TableName -> Text fromTableName (TableName tn) = mconcat ["\"", escapeQuotes tn, "\""] +-- | Convert a table name into a string, without quotes.+rawTableName :: TableName -> Text+rawTableName (TableName tn) = escapeQuotes tn+ -- | Create a column name. mkColName :: Text -> ColName mkColName = ColName@@ -131,47 +138,3 @@ tenth :: Tup j => (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h :*: i :*: j)       -> Head j tenth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: j) = tupHead j---- | Normalized append of two inductive tuples.---   Note that this will flatten any nested inductive tuples.-type family a :++: b where-  (a :*: b) :++: c = a :*: (b :++: c)-  a         :++: b = a :*: b--class Append a b where-  app :: a -> b -> a :++: b-instance {-# OVERLAPPING #-} Append b c => Append (a :*: b) c where-  app (a :*: b) c = a :*: app b c-instance ((a :*: b) ~ (a :++: b)) => Append a b where-  app a b = a :*: b--data Unsafe = Unsafe Int--class Typeable a => ToDyn a where-  toDyns :: a -> [Dynamic]-  fromDyns :: [Dynamic] -> Maybe a-  -- | TODO: replace with safe coercions when that hits platform-1.-  unsafeToList :: a -> [Unsafe]-  -- | TODO: replace with safe coercions when that hits platform-1.-  unsafeFromList :: [Unsafe] -> a--instance (Typeable a, ToDyn b) => ToDyn (a :*: b) where-  toDyns (a :*: b) = toDyn a : toDyns b-  fromDyns (x:xs) = do-    x' <- fromDynamic x-    xs' <- fromDyns xs-    return (x' :*: xs')-  fromDyns _ = do-    Nothing-  unsafeToList (x :*: xs) = unsafeCoerce x : unsafeToList xs-  unsafeFromList (x : xs) = unsafeCoerce x :*: unsafeFromList xs-  unsafeFromList _        = error "too short list to unsafeFromList"--instance {-# OVERLAPPABLE #-} Typeable a => ToDyn a where-  toDyns a = [toDyn a]-  fromDyns [x] = fromDynamic x-  fromDyns _   = Nothing-  unsafeToList x = [unsafeCoerce x]-  unsafeFromList [x] = unsafeCoerce x-  unsafeFromList []  = error "too short list to unsafeFromList"-  unsafeFromList _   = error "too long list to unsafeFromList"

@@ -2,13 +2,13 @@ -- | Unsafe operations giving the user unchecked low-level control over --   the generated SQL. module Database.Selda.Unsafe-  ( fun, fun2+  ( fun, fun2, fun0   , aggr   , cast-  , unsafeRowId+  , castAggr   ) where import Database.Selda.Column-import Database.Selda.Inner (aggr)+import Database.Selda.Inner (Aggr, aggr, liftAggr) import Database.Selda.SqlType import Data.Text (Text) import Data.Proxy@@ -18,6 +18,11 @@ cast :: forall s a b. SqlType b => Col s a -> Col s b cast = liftC $ Cast (sqlType (Proxy :: Proxy b)) +-- | Cast an aggregate to another type, using whichever coercion semantics+--   are used by the underlying SQL implementation.+castAggr :: forall s a b. SqlType b => Aggr s a -> Aggr s b+castAggr = liftAggr $ Cast (sqlType (Proxy :: Proxy b))+ -- | A unary operation. Note that the provided function name is spliced --   directly into the resulting SQL query. Thus, this function should ONLY --   be used to implement well-defined functions that are missing from Selda's@@ -28,3 +33,7 @@ -- | Like 'fun', but with two arguments. fun2 :: Text -> Col s a -> Col s b -> Col s c fun2 f = liftC2 (Fun2 f)++-- | Like 'fun', but with zero arguments.+fun0 :: Text -> Col s a+fun0 = One . NulOp . Fun0

@@ -0,0 +1,202 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}+-- | Utilities for validating and inspecting Selda tables.+module Database.Selda.Validation+  ( TableDiff (..), ColumnDiff (..)+  , TableName, ColName, ColumnInfo, SqlTypeRep, columnInfo+  , showTableDiff, showColumnDiff+  , describeTable, diffTable, diffTables+  , validateTable, validateSchema+  ) where+import Control.Monad.Catch+import Data.List ((\\))+import Data.Maybe (catMaybes)+import Data.Text (pack, unpack)+import Database.Selda+import Database.Selda.Backend+import Database.Selda.Table.Type (tableName, 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 a b         = a == b++-- | Validate a table schema, and check it for consistency against the current+--   database.+--   Throws a 'ValidationError' if the schema does not validate, or if+--   inconsistencies were found.+validateTable :: MonadSelda m => Table a -> m ()+validateTable t = do+  validateSchema t+  diffs <- diffTable t+  case diffs of+    TableOK -> return ()+    errors  -> throwM $ ValidationError $ concat+      [ "error validating table ", unpack (fromTableName (tableName t)), ":\n"+      , show errors+      ]++-- | Ensure that the schema of the given table is valid.+--   Does not ensure consistency with the current database.+validateSchema :: MonadThrow m => Table a -> m ()+validateSchema t = validateOrThrow (tableName t) (tableCols t) `seq` return ()++-- | A description of the difference between a schema and its corresponding+--   database table.+data TableDiff+  = TableOK+  | TableMissing+  | InconsistentColumns [(ColName, [ColumnDiff])]+    deriving Eq+instance Show TableDiff where+  show = unpack . showTableDiff++-- | A description of the difference between a column in a Selda table and its+--   corresponding database column.+data ColumnDiff+  = ColumnMissing+  | ColumnPresent+  | NameMismatch ColName+  | UnknownType Text+  | TypeMismatch SqlTypeRep SqlTypeRep+  | PrimaryKeyMismatch Bool+  | AutoIncrementMismatch Bool+  | NullableMismatch Bool+  | UniqueMismatch Bool+  | ForeignKeyMissing TableName ColName+  | ForeignKeyPresent TableName ColName+  | IndexMissing+  | IndexPresent+    deriving Eq++instance Show ColumnDiff where+  show = unpack . showColumnDiff++-- | Pretty-print a table diff.+showTableDiff :: TableDiff -> Text+showTableDiff TableOK = "no inconsistencies detected"+showTableDiff TableMissing = "table does not exist"+showTableDiff (InconsistentColumns cols) = mconcat+  [ "table has inconsistent columns:\n"+  , mconcat (map showColDiffs cols)+  ]+  where+    showColDiffs (col, diffs) = mconcat+      [ "  ", fromColName col, ":\n"+      , mconcat (map showDiffs diffs)+      ]+    showDiffs diff = mconcat+      [ "    ", showColumnDiff diff, "\n"+      ]++-- | Pretty-print a column diff.+showColumnDiff :: ColumnDiff -> Text+showColumnDiff ColumnMissing =+  "column does not exist in database"+showColumnDiff ColumnPresent =+  "column exists in database even though it shouldn't"+showColumnDiff IndexMissing =+  "column does not have an index in the database, even though it should"+showColumnDiff IndexPresent =+  "column has an index in the database, even though it shouldn't"+showColumnDiff (NameMismatch n) =+  mconcat ["column is called ", fromColName n, " in database"]+showColumnDiff (UnknownType t) =+  mconcat ["column has incompatible type \"", t, "\" in database"]+showColumnDiff (TypeMismatch t1 t2) =+  mconcat [ "column should have type `", pack (show t1)+          , "', but actually has type `", pack (show t2)+          , "' in database"+          ]+showColumnDiff (ForeignKeyMissing tbl col) =+  mconcat [ "column should be a foreign key referencing column "+          , fromColName col, " of table ", fromTableName tbl+          , "', but isn't a foreign key in database"+          ]+showColumnDiff (ForeignKeyPresent tbl col) =+  mconcat [ "column is a foreign key referencing column "+          , fromColName col, " of table ", fromTableName tbl+          , ", in database, even though it shouldn't be"+          ]+showColumnDiff (PrimaryKeyMismatch dbval) =+  showBoolDiff dbval "primary key"+showColumnDiff (AutoIncrementMismatch dbval) =+  showBoolDiff dbval "auto-incrementing"+showColumnDiff (NullableMismatch dbval) =+  showBoolDiff dbval "nullable"+showColumnDiff (UniqueMismatch dbval) =+  showBoolDiff dbval "unique"++showBoolDiff :: Bool -> Text -> Text+showBoolDiff True what =+  mconcat ["column is ", what, " in database, even though it shouldn't be"]+showBoolDiff False what =+  mconcat ["column is not ", what, " in database, even though it should be"]++-- | Get a description of the table by the given name currently in the database.+describeTable :: MonadSelda m => TableName -> m [ColumnInfo]+describeTable tbl = do+  b <- seldaBackend+  liftIO $ getTableInfo b tbl++-- | Check the given table for consistency with the current database, returning+--   a description of all inconsistencies found.+--   The table schema itself is not validated beforehand.+diffTable :: MonadSelda m => Table a -> m TableDiff+diffTable tbl = do+  dbInfos <- describeTable (tableName tbl)+  return $ diffColumns (columnInfo tbl) dbInfos++-- | Compute the difference between the two given tables.+--   The first table is considered to be the schema, and the second the database.+diffTables :: Table a -> Table b -> TableDiff+diffTables schema db = diffColumns (columnInfo schema) (columnInfo db)++-- | Compute the difference between the columns of two tables.+--   The first table is considered to be the schema, and the second the database.+diffColumns :: [ColumnInfo] -> [ColumnInfo] -> TableDiff+diffColumns infos dbInfos =+    case ( zipWith diffColumn infos dbInfos+         , map colName infos \\ map colName dbInfos+         , map colName dbInfos \\ map colName infos) of+      ([], _, _) ->+        TableMissing+      (diffs, [], []) | all consistent diffs ->+        TableOK+      (diffs, missing, extras) ->+        InconsistentColumns $ concat+          [ filter (not . consistent) diffs+          , map (, [ColumnMissing]) missing+          , map (, [ColumnPresent]) extras+          ]+  where+    consistent (_, diffs) = null diffs+    diffColumn schema db = (colName schema, catMaybes+      ([ check colName NameMismatch+       , case colType db of+           Left typ ->+             Just (UnknownType typ)+           Right t | not (t `isCompatibleWith` schemaColType) ->+             Just (TypeMismatch schemaColType t)+           _ ->+             Nothing+       , check colIsPK PrimaryKeyMismatch+       , check colIsAutoIncrement AutoIncrementMismatch+       , check colIsNullable NullableMismatch+       , check colIsUnique UniqueMismatch+       ] ++ mconcat+       [ map (Just . uncurry ForeignKeyPresent)+             (colFKs schema \\ colFKs db)+       , map (Just . uncurry ForeignKeyMissing)+             (colFKs db \\ colFKs schema)+       ]))+      where+        Right schemaColType = colType schema+        check :: Eq a+              => (ColumnInfo -> a)+              -> (a -> ColumnDiff)+              -> Maybe ColumnDiff+        check f err+          | f schema == f db = Nothing+          | otherwise        = Just (err (f db))