selda (empty) → 0.1.0.0
raw patch · 22 files changed
+2565/−0 lines, 22 filesdep +basedep +exceptionsdep +hashablesetup-changed
Dependencies added: base, exceptions, hashable, mtl, psqueues, text, time, transformers, unordered-containers
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- README.md +500/−0
- Setup.hs +2/−0
- selda.cabal +99/−0
- src/Database/Selda.hs +189/−0
- src/Database/Selda/Backend.hs +56/−0
- src/Database/Selda/Caching.hs +151/−0
- src/Database/Selda/Column.hs +142/−0
- src/Database/Selda/Compile.hs +102/−0
- src/Database/Selda/Frontend.hs +192/−0
- src/Database/Selda/Inner.hs +60/−0
- src/Database/Selda/Query.hs +152/−0
- src/Database/Selda/Query/Type.hs +59/−0
- src/Database/Selda/SQL.hs +39/−0
- src/Database/Selda/SQL/Print.hs +216/−0
- src/Database/Selda/SqlType.hs +148/−0
- src/Database/Selda/Table.hs +196/−0
- src/Database/Selda/Table/Compile.hs +64/−0
- src/Database/Selda/Transform.hs +76/−0
- src/Database/Selda/Types.hs +83/−0
- src/Database/Selda/Unsafe.hs +14/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for selda++## 0.1.0.0 -- 2017-04-14++* Initial release.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Anton Ekblad++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,500 @@+What is Selda?+==============+[](https://travis-ci.org/valderman/selda)++Selda is an embedded domain-specific language for interacting with relational+databases. It was inspired by LINQ and+[Opaleye](http://hackage.haskell.org/package/opaleye).+++Features+========++* Creating, dropping and querying tables using type-safe database schemas.+* Monadic query language with products, filtering, joins and aggregation.+* Inserting, updating and deleting rows from tables.+* Transaction support.+* Configurable, automatic, consistent in-process caching of query results.+* Multiple backends: SQLite and PostgreSQL.+* Lightweight and modular: non-essential features are optional or split into+ add-on packages.+++Requirements+============++Selda requires SQLite 3.7.11+, or PostgreSQL 9+.+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+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 queries are run in the `SeldaT` monad transformer. Any `MonadIO` can be+extended with database capabilities. Throughout this tutorial, we will simply+use `SeldaT` on top of the plain `IO` monad.+`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 :: SeldaT IO [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 :: SeldaT IO ()+setup = do+ createTable people+ createTable addresses++teardown :: SeldaT IO ()+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 :: SeldaT IO ()+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.++There is one gotcha when inserting tuples: auto-incrementing primary keys.+When inserting data into a table with such a primary key, *the primary key+column must be omitted from any inserted tuples* to avoid a type error.+The reason for this is that it's usually a bad idea to set auto-incrementing+keys manually. The following example inserts a few rows into a table with an+auto-incrementing primary key:++```+people' :: Table (Auto Int :*: Text :*: Int :*: Maybe Text)+people' = table "people_with_ids"+ $ autoPrimary "id"+ ¤ required "name"+ ¤ required "age"+ ¤ optional "pet"++populate' :: SeldaT IO ()+populate' = do+ insert_ people'+ [ "Link" :*: 125 :*: Just "horse"+ , "Velvet" :*: 19 :*: Nothing+ , "Kobayashi" :*: 23 :*: Just "dragon"+ , "Miyu" :*: 10 :*: Nothing+ ]+```++Note that the tuple list passed to `insert_` is the same as for the previous+example, even though our new table has an additional field `id`.+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 |+```++If you want manual control over your primary keys, do not use `autoPrimary`.+++Updating rows+-------------++To update a table, pass the table and two functions to the `update` function.+The first is a mapping over table columns, specifying how to update each row.+The second is a predicate over table columns.+Only rows satisfying the predicate are updated.++```+age10Years :: SeldaT IO ()+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 `delete` operation takes a table and a predicate, specifying which rows+to delete.+The following example deletes all minors from the `people` table:++```+byeMinors :: SeldaT IO ()+byeMinors = delete_ 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 :: SeldaT IO ()+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.+++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 :: SeldaT IO ()+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 (count city :*: owner')+ 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 -> SeldaT s ()+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 shared between all Selda computations+running in the same process.+++TODOs+=====++Features that would be nice to have but are not yet implemented.++* If/else.+* Examples.+* Foreign keys.+* `WHERE x IN (SELECT ...)`+* `SELECT INTO`.+* Constraints other than primary key.+* Database schema upgrades.+* Stack build.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ selda.cabal view
@@ -0,0 +1,99 @@+name: selda+version: 0.1.0.0+synopsis: Type-safe, high-level EDSL for interacting with relational 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.+ + To use this package you need at least one backend package, in addition to+ this package. There are currently two different backend packages:+ selda-sqlite and selda-postgresql.+homepage: https://github.com/valderman/selda+license: MIT+license-file: LICENSE+author: Anton Ekblad+maintainer: anton@ekblad.cc+category: Database+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10+tested-with: GHC == 7.10.3, GHC == 8.0.2++extra-source-files:+ README.md++flag localcache+ default: True+ description:+ Enable process-local cache support. Even when supported, caching is turned+ off by default until enabled by the application.+ When unsupported, the relevant APIs are still available, but the cache will+ act as if every update is a no-op and every lookup a cache miss.++flag haste+ default: False+ description:+ Automatically set when installing for the Haste compiler.++source-repository head+ type: git+ location: https://github.com/valderman/selda.git++library+ exposed-modules:+ Database.Selda+ Database.Selda.Backend+ Database.Selda.Unsafe+ other-modules:+ Database.Selda.Caching+ Database.Selda.Column+ Database.Selda.Compile+ Database.Selda.Frontend+ Database.Selda.Inner+ Database.Selda.Query+ Database.Selda.Query.Type+ Database.Selda.SQL+ Database.Selda.SQL.Print+ Database.Selda.SqlType+ Database.Selda.Table+ Database.Selda.Table.Compile+ Database.Selda.Transform+ Database.Selda.Types+ other-extensions:+ OverloadedStrings+ GADTs+ CPP+ MultiParamTypeClasses+ UndecidableInstances+ ScopedTypeVariables+ RankNTypes+ TypeFamilies+ FlexibleInstances+ GeneralizedNewtypeDeriving+ FlexibleContexts+ build-depends:+ base >=4.8 && <5+ , exceptions >=0.8 && <0.9+ , mtl >=2.0 && <2.3+ , text >=1.0 && <1.3+ , time >=1.6 && <1.9+ if impl(ghc < 7.11)+ build-depends:+ transformers >=0.4 && <0.6+ if !flag(haste) && flag(localcache)+ build-depends:+ hashable >=1.1 && <1.3+ , psqueues >=0.2 && <0.3+ , unordered-containers >=0.2 && <0.3+ else+ cpp-options:+ -DNO_LOCALCACHE+ hs-source-dirs:+ src+ default-language:+ Haskell2010+ ghc-options:+ -Wall
+ src/Database/Selda.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-}+-- | Selda is not LINQ, but they're definitely related.+--+-- Selda is a high-level EDSL for interacting with relational databases.+-- Please see <https://github.com/valderman/selda/> for a brief tutorial.+module Database.Selda+ ( -- * Running queries+ MonadIO (..), MonadSelda+ , SeldaT, Table, Query, Col, Res, Result+ , query, transaction, setLocalCache+ -- * Constructing queries+ , SqlType+ , Text, Cols, Columns+ , Order (..)+ , (:*:)(..)+ , select, restrict, limit, order+ , ascending, descending+ -- * Expressions over columns+ , (.==), (./=), (.>), (.<), (.>=), (.<=), like+ , (.&&), (.||), not_+ , literal, int, float, text, true, false, null_+ , roundTo, length_, isNull+ -- * Converting between column types+ , round_, just, fromBool, fromInt, toString+ -- * Inner queries+ , Aggr, Aggregates, OuterCols, JoinCols, Inner, MinMax+ , leftJoin+ , aggregate, groupBy+ , count, avg, sum_, max_, min_+ -- * Modifying tables+ , Insert, InsertCols, HasAutoPrimary+ , insert, insert_, insertWithPK+ , update, update_+ , deleteFrom, deleteFrom_+ -- * Defining schemas+ , ColSpec, TableName, ColName+ , NonNull, IsNullable, Nullable, NotNullable+ , Auto+ , table, (¤), required, optional+ , primary, autoPrimary+ -- * Combining schemas+ , ComposeSpec, (:+++:), (+++)+ -- * Creating and dropping tables+ , createTable, tryCreateTable+ , dropTable, tryDropTable+ -- * Compiling and inspecting queries+ , OnError (..)+ , compile+ , compileCreateTable, compileDropTable+ , compileInsert, compileUpdate+ -- * Tuple convenience functions+ , Tup, Head+ , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth+ ) where+import Data.Text (Text)+import Database.Selda.Backend+import Database.Selda.Column+import Database.Selda.Compile+import Database.Selda.Frontend+import Database.Selda.Inner+import Database.Selda.Query+import Database.Selda.Query.Type+import Database.Selda.SQL (Order (..))+import Database.Selda.SqlType+import Database.Selda.Table+import Database.Selda.Table.Compile+import Database.Selda.Types+import Database.Selda.Unsafe++-- | Any column type that can be used with the 'min_' and 'max_' functions.+class MinMax a+instance {-# OVERLAPPABLE #-} Num a => MinMax a+instance MinMax Text+instance MinMax a => MinMax (Maybe a)++(.==), (./=), (.>), (.<), (.>=), (.<=) :: Col s a -> Col s a -> Col s Bool+(.==) = liftC2 $ BinOp Eq+(./=) = liftC2 $ BinOp Neq+(.>) = liftC2 $ BinOp Gt+(.<) = liftC2 $ BinOp Lt+(.>=) = liftC2 $ BinOp Gte+(.<=) = liftC2 $ BinOp Lte+infixl 4 .==+infixl 4 .>+infixl 4 .<+infixl 4 .>=+infixl 4 .<=++-- | Is the given column null?+isNull :: Col s (Maybe a) -> Col s Bool+isNull = liftC $ UnOp IsNull++(.&&), (.||) :: Col s Bool -> Col s Bool -> Col s Bool+(.&&) = liftC2 $ BinOp And+(.||) = liftC2 $ BinOp Or+infixr 3 .&&+infixr 2 .||++-- | Ordering for 'order'.+ascending, descending :: Order+ascending = Asc+descending = Desc++-- | 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"+-- >+-- > peopleWithCats = do+-- > name :*: _ :*: pet <- select people+-- > restrict (pet .== just "cat")+-- > return name+just :: Col s a -> Col s (Maybe a)+just = cast++-- | SQL NULL, at any type you like.+null_ :: SqlType a => Col s (Maybe a)+null_ = literal Nothing++-- | Specialization of 'literal' for integers.+int :: Int -> Col s Int+int = literal++-- | Specialization of 'literal' for doubles.+float :: Double -> Col s Double+float = literal++-- | Specialization of 'literal' for text.+text :: Text -> Col s Text+text = literal++-- | True and false boolean literals.+true, false :: Col s Bool+true = literal True+false = literal False++-- | The SQL @LIKE@ operator; matches strings with wildcards.+like :: Col s Text -> Col s Text -> Col s Bool+like = liftC2 $ BinOp Like+infixl 4 `like`++-- | The number of non-null values in the given column.+count :: Col s a -> Aggr s Int+count = aggr "COUNT"++-- | The average of all values in the given column.+avg :: Num a => Col s a -> Aggr s a+avg = aggr "AVG"++-- | The greatest value in the given column. Texts are compared lexically.+max_ :: MinMax a => Col s a -> Aggr s a+max_ = aggr "MAX"++-- | The smallest value in the given column. Texts are compared lexically.+min_ :: MinMax a => Col s a -> Aggr s a+min_ = aggr "MIN"++-- | Sum all values in the given column.+sum_ :: Num a => Col s a -> Aggr s a+sum_ = aggr "SUM"++-- | Round a value to the nearest integer. Equivalent to @roundTo 0@.+round_ :: Num a => Col s Double -> Col s a+round_ = fun "ROUND"++-- | Round a column to the given number of decimals places.+roundTo :: Col s Int -> Col s Double -> Col s Double+roundTo = flip $ fun2 "ROUND"++-- | Calculate the length of a string column.+length_ :: Col s Text -> Col s Int+length_ = fun "LENGTH"++-- | Boolean negation.+not_ :: Col s Bool -> Col s Bool+not_ = liftC $ UnOp Not++-- | Convert a boolean column to any numeric type.+fromBool :: Num a => Col s Bool -> Col s a+fromBool = cast++-- | Convert an integer column to any numeric type.+fromInt :: Num a => Col s Int -> Col s a+fromInt = cast++-- | Convert any column to a string.+toString :: Col s a -> Col s String+toString = cast
+ src/Database/Selda/Backend.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | API for building Selda backends.+module Database.Selda.Backend+ ( MonadIO (..)+ , QueryRunner, SeldaBackend (..), MonadSelda (..), SeldaT (..)+ , Param (..), Lit (..), SqlValue (..), ColAttr (..)+ , compileColAttr+ , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat+ , runSeldaT+ ) where+import Database.Selda.SQL (Param (..))+import Database.Selda.SqlType+import Database.Selda.Table (ColAttr (..))+import Database.Selda.Table.Compile (compileColAttr)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.State+import Data.Text (Text)++-- | A function which executes a query and gives back a list of extensible+-- tuples; one tuple per result row, and one tuple element per column.+type QueryRunner a = Text -> [Param] -> IO a++-- | A collection of functions making up a Selda backend.+data SeldaBackend = SeldaBackend+ { -- | Execute an SQL statement.+ runStmt :: QueryRunner (Int, [[SqlValue]])++ -- | Execute an SQL statement and return the last inserted primary key,+ -- where the primary key is auto-incrementing.+ -- Backends must take special care to make this thread-safe.+ , runStmtWithPK :: QueryRunner Int++ -- | Generate a custom column type for the column having the given Selda+ -- type and list of attributes.+ , customColType :: Text -> [ColAttr] -> Maybe Text+ }++-- | Some monad with Selda SQL capabilitites.+class MonadIO m => MonadSelda m where+ -- | Get the backend in use by the computation.+ seldaBackend :: m SeldaBackend++-- | Monad transformer adding Selda SQL capabilities.+newtype SeldaT m a = S {unS :: StateT SeldaBackend m a}+ deriving ( Functor, Applicative, Monad, MonadIO+ , MonadThrow, MonadCatch, MonadMask, MonadTrans+ )++instance MonadIO m => MonadSelda (SeldaT m) where+ seldaBackend = S get++-- | Run a Selda transformer. Backends should use this to implement their+-- @withX@ functions.+runSeldaT :: MonadIO m => SeldaT m a -> SeldaBackend -> m a+runSeldaT m b = fst <$> runStateT (unS m) b
+ src/Database/Selda/Caching.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.Selda.Caching+ ( CacheKey+ , cache, cached, invalidate, setMaxItems+ ) where+import Prelude hiding (lookup)+import Data.Dynamic+#ifndef NO_LOCALCACHE+import Data.Hashable+import Data.HashPSQ+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.List (foldl')+import Database.Selda.SqlType+import Data.IORef+import System.IO.Unsafe+#endif+import Data.Text (Text)+import Database.Selda.SQL (Param (..))+import Database.Selda.Types (TableName)++type CacheKey = (Text, [Param])++#ifdef NO_LOCALCACHE++cache :: Typeable a => [TableName] -> CacheKey -> a -> IO ()+cache _ _ _ = return ()++cached :: forall a. Typeable a => CacheKey -> IO (Maybe a)+cached _ = return Nothing++invalidate :: TableName -> IO ()+invalidate _ = return ()++setMaxItems :: Int -> IO ()+setMaxItems _ = return ()++#else++instance Hashable Param where+ hashWithSalt s (Param x) = hashWithSalt s x+instance Hashable (Lit a) where+ hashWithSalt s (LitS x) = hashWithSalt s x+ hashWithSalt s (LitI x) = hashWithSalt s x+ hashWithSalt s (LitD x) = hashWithSalt s x+ hashWithSalt s (LitB x) = hashWithSalt s x+ hashWithSalt s (LitTS x) = hashWithSalt s x+ hashWithSalt s (LitDate x) = hashWithSalt s x+ hashWithSalt s (LitTime x) = hashWithSalt s x+ hashWithSalt s (LitJust x) = hashWithSalt s x+ hashWithSalt _ (LitNull) = 0++data ResultCache = ResultCache+ { -- | Query to result mapping.+ results :: !(HashPSQ CacheKey Int Dynamic)+ -- | Table to query mapping, for keeping track of which queries depend on+ -- which tables.+ , deps :: !(M.HashMap TableName (S.HashSet CacheKey))+ -- | Items currently in cache.+ , items :: !Int+ -- | Max number of items in cache.+ , maxItems :: !Int+ -- | Next cache prio to use.+ , nextPrio :: !Int+ } deriving Show++emptyCache :: ResultCache+emptyCache = ResultCache+ { results = empty+ , deps = M.empty+ , items = 0+ , maxItems = 0+ , nextPrio = 0+ }++{-# NOINLINE theCache #-}+theCache :: IORef ResultCache+theCache = unsafePerformIO $ newIORef emptyCache++-- | Cache the given value, with the given table dependencies.+cache :: Typeable a => [TableName] -> CacheKey -> a -> IO ()+cache tns k v = atomicModifyIORef' theCache $ \c -> (cache' tns k v c, ())++cache' :: Typeable a => [TableName] -> CacheKey -> a -> ResultCache -> ResultCache+cache' tns k v rc+ | maxItems rc == 0 = rc+ | prio + 1 < prio = cache' tns k v (emptyCache {maxItems = maxItems rc})+ | otherwise = rc+ { results = insert k prio v' results'+ , deps = foldl' (\m tn -> M.alter (addTbl k) tn m) (deps rc) tns+ , nextPrio = prio + 1+ , items = items'+ }+ where+ v' = toDyn v+ prio = nextPrio rc+ -- evict LRU element before inserting if full+ (items', results')+ | items rc >= maxItems rc = (items rc, deleteMin $ results rc)+ | otherwise = (items rc + 1, results rc)+ addTbl key (Just ks) = Just (S.insert key ks)+ addTbl key Nothing = Just (S.singleton key)++-- | Get the cached value for the given key, if it exists.+cached :: forall a. Typeable a => CacheKey -> IO (Maybe a)+cached k = atomicModifyIORef' theCache $ cached' k++cached' :: forall a. Typeable a => CacheKey -> ResultCache -> (ResultCache, Maybe a)+cached' k rc = do+ case (maxItems rc, alter updatePrio k (results rc)) of+ (0, _) -> (rc, Nothing)+ (_, (Just x, results')) -> (rc' results', fromDynamic x)+ _ -> (rc, Nothing)+ where+ rc' rs = rc+ { results = rs+ , nextPrio = nextPrio rc + 1+ }+ updatePrio (Just (_, v)) = (Just v, Just (nextPrio rc, v))+ updatePrio _ = (Nothing, Nothing)++-- | Invalidate all items in cache that depend on the given table.+invalidate :: TableName -> IO ()+invalidate tn = atomicModifyIORef' theCache $ \c -> (invalidate' tn c, ())++invalidate' :: TableName -> ResultCache -> ResultCache+invalidate' tbl rc+ | maxItems rc == 0 = rc+ | otherwise = rc+ { results = results'+ , deps = deps'+ , items = items rc - length ks+ }+ where+ ks = maybe S.empty id $ M.lookup tbl (deps rc)+ results' = S.foldl' (flip delete) (results rc) ks+ deps' = M.delete tbl (deps rc)++-- | Set the maximum number of items allowed in the cache.+setMaxItems :: Int -> IO ()+setMaxItems n = atomicModifyIORef' theCache $ \c -> (setMaxItems' n c, ())++-- | The the maximum number of items for the cache.+getMaxItems :: IO Int+getMaxItems = maxItems <$> readIORef theCache++setMaxItems' :: Int -> ResultCache -> ResultCache+setMaxItems' 0 _ = emptyCache+setMaxItems' n rc = emptyCache {maxItems = n}+#endif
+ src/Database/Selda/Column.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances #-}+-- | Columns and associated utility functions.+module Database.Selda.Column where+import Database.Selda.SqlType+import Database.Selda.Table (Auto)+import Database.Selda.Types+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 (Auto a :*: b) = Col s a :*: Cols s b+ Cols s (a :*: b) = Col s a :*: Cols s b+ Cols s (Auto a) = Col s a+ Cols s a = Col s a++-- | Any column tuple.+class Columns a where+ toTup :: [ColName] -> a+ fromTup :: a -> [SomeCol]++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 Columns (Col s a) where+ toTup [x] = C (Col x)+ toTup [] = error "too few elements to toTup"+ toTup _ = error "too many elements to toTup"+ fromTup (C x) = [Some x]++-- | A type-erased column, which may also be renamed.+-- Only for internal use.+data SomeCol where+ Some :: !(Exp a) -> SomeCol+ Named :: !ColName -> !(Exp a) -> SomeCol++-- | 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 a}++-- | A literal expression.+literal :: SqlType a => a -> Col s a+literal = C . Lit . mkLit++-- | 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+-- standard library, and NOT in an ad hoc manner during queries.+fun :: Text -> Col s a -> Col s b+fun f = liftC $ UnOp (Fun f)++-- | Like 'fun', but with two arguments.+fun2 :: Text -> Col s a -> Col s b -> Col s c+fun2 f = liftC2 (Fun2 f)++-- | Underlying column expression type, not tied to any particular query.+data Exp a where+ Col :: !ColName -> Exp a+ Lit :: !(Lit a) -> Exp a+ BinOp :: !(BinOp a b) -> !(Exp a) -> !(Exp a) -> Exp b+ UnOp :: !(UnOp a b) -> !(Exp a) -> Exp b+ Fun2 :: !Text -> !(Exp a) -> !(Exp b) -> Exp c+ Cast :: !(Exp a) -> Exp b+ AggrEx :: !Text -> !(Exp a) -> Exp b++-- | Get all column names in the given expression.+allNamesIn :: Exp a -> [ColName]+allNamesIn (Col n) = [n]+allNamesIn (Lit _) = []+allNamesIn (BinOp _ a b) = allNamesIn a ++ allNamesIn b+allNamesIn (UnOp _ a) = allNamesIn a+allNamesIn (Fun2 _ a b) = allNamesIn a ++ allNamesIn b+allNamesIn (Cast x) = allNamesIn x+allNamesIn (AggrEx _ x) = allNamesIn x++data UnOp a b where+ Abs :: UnOp a a+ Not :: UnOp Bool Bool+ Neg :: UnOp a a+ Sgn :: UnOp a a+ IsNull :: UnOp (Maybe a) Bool+ Fun :: Text -> UnOp a b++data BinOp a b where+ Gt :: BinOp a Bool+ Lt :: BinOp a Bool+ Gte :: BinOp a Bool+ Lte :: BinOp a Bool+ Eq :: BinOp a Bool+ Neq :: BinOp a Bool+ And :: BinOp Bool Bool+ Or :: BinOp Bool Bool+ Add :: BinOp a a+ Sub :: BinOp a a+ Mul :: BinOp a a+ Div :: BinOp a a+ Like :: BinOp Text Bool++instance IsString (Col s Text) where+ fromString = literal . fromString++liftC2 :: (Exp a -> Exp b -> Exp c) -> Col s a -> Col s b -> Col s c+liftC2 f (C a) (C b) = C (f a b)++liftC :: (Exp a -> Exp b) -> Col s a -> Col s b+liftC f = C . f . unC++instance (SqlType a, Num a) => Num (Col s a) where+ fromInteger = literal . fromInteger+ (+) = liftC2 $ BinOp Add+ (-) = liftC2 $ BinOp Sub+ (*) = liftC2 $ BinOp Mul+ negate = liftC $ UnOp Neg+ abs = liftC $ UnOp Abs+ signum = liftC $ UnOp Sgn++instance {-# OVERLAPPING #-} (SqlType a, Num a) => Num (Col s (Maybe a)) where+ fromInteger = literal . Just . fromInteger+ (+) = liftC2 $ BinOp Add+ (-) = liftC2 $ BinOp Sub+ (*) = liftC2 $ BinOp Mul+ negate = liftC $ UnOp Neg+ abs = liftC $ UnOp Abs+ signum = liftC $ UnOp Sgn++instance Fractional (Col s Double) where+ fromRational = literal . fromRational+ (/) = liftC2 $ BinOp Div ++instance Fractional (Col s (Maybe Double)) where+ fromRational = literal . Just . fromRational+ (/) = liftC2 $ BinOp Div ++instance Fractional (Col s Int) where+ fromRational = literal . (truncate :: Double -> Int) . fromRational+ (/) = liftC2 $ BinOp Div++instance Fractional (Col s (Maybe Int)) where+ fromRational = literal . Just . (truncate :: Double -> Int) . fromRational+ (/) = liftC2 $ BinOp Div
+ src/Database/Selda/Compile.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+-- | Selda SQL compilation.+module Database.Selda.Compile where+import Database.Selda.Column+import Database.Selda.Query.Type+import Database.Selda.SQL+import Database.Selda.SQL.Print+import Database.Selda.SqlType+import Database.Selda.Table+import Database.Selda.Table.Compile+import Database.Selda.Transform+import Database.Selda.Types+import Data.Proxy+import Data.Text (Text, empty)+import Data.Typeable++-- | Compile a query into a parameterised SQL statement.+compile :: Result a => Query s a -> (Text, [Param])+compile = snd . compileWithTables++-- | Compile a query into a parameterised SQL statement. Also returns all+-- tables depended on by the query.+compileWithTables :: Result a => Query s a -> ([TableName], (Text, [Param]))+compileWithTables = compSql . snd . compQuery++-- | Compile an @INSERT@ query.+compileInsert :: Insert (InsertCols a)+ => Table a -> [InsertCols a] -> (Text, [Param])+compileInsert _ [] = (empty, [])+compileInsert tbl rows = (compInsert tbl nrows, concat ps)+ where ps = map params rows+ nrows = length rows++-- | Compile an @UPDATE@ query.+compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a))+ => 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.+ -> (Text, [Param])+compileUpdate tbl upd check =+ compUpdate (tableName tbl) predicate updated+ where+ names = map colName (tableCols tbl)+ cs = toTup names+ updated = zip names (finalCols (upd cs))+ C predicate = check cs++-- | Compile a @DELETE FROM@ query.+compileDelete :: Columns (Cols s a)+ => Table a -> (Cols s a -> Col s Bool) -> (Text, [Param])+compileDelete tbl check = compDelete (tableName tbl) predicate+ where C predicate = check $ toTup $ map colName $ tableCols tbl++-- | Compile a query to an SQL AST.+-- Groups are ignored, as they are only used by 'aggregate'.+compQuery :: Result a => Query s a -> (Int, SQL)+compQuery q =+ (nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing)+ where+ (cs, st) = runQueryM q+ final = finalCols cs+ sql = state2sql st+ live = colNames final ++ allNonOutputColNames sql+ srcs = removeDeadCols live sql++-- | An extensible tuple of Haskell-level values (i.e. @Int :*: Maybe Text@)+-- which can be inserted into a table.+class Insert a where+ params :: a -> [Param]+instance (SqlType a, Insert b) => Insert (a :*: b) where+ params (a :*: b) = Param (mkLit a) : params b+instance {-# OVERLAPPABLE #-} SqlType a => Insert a where+ params a = [Param (mkLit a) ]++-- | An acceptable query result type; one or more columns stitched together+-- with @:*:@.+class Typeable (Res r) => Result r where+ type Res r+ -- | Converts the given list of @SqlValue@s into an tuple of well-typed+ -- results.+ -- See 'querySQLite' for example usage.+ -- 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++ -- | Produce a list of all columns present in the result.+ finalCols :: r -> [SomeCol]++instance (Typeable a, 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"+ finalCols (a :*: b) = finalCols a ++ finalCols b++instance (Typeable a, 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]
+ src/Database/Selda/Frontend.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings #-}+-- | API for running Selda operations over databases.+module Database.Selda.Frontend+ ( Result, Res, MonadIO (..), MonadSelda (..), SeldaT+ , query+ , insert, insert_, insertWithPK+ , update, update_+ , deleteFrom, deleteFrom_+ , createTable, tryCreateTable+ , dropTable, tryDropTable+ , transaction, setLocalCache+ ) where+import Database.Selda.Backend+import Database.Selda.Caching+import Database.Selda.Column+import Database.Selda.Compile+import Database.Selda.Query.Type+import Database.Selda.Table+import Database.Selda.Table.Compile+import Data.Proxy+import Data.Text (Text)+import Control.Monad+import Control.Monad.Catch++-- | Run a query within a Selda transformer.+-- Selda transformers are entered using backend-specific @withX@ functions,+-- such as 'withSQLite' from the SQLite backend.+query :: (MonadSelda m, Result a) => Query s a -> m [Res a]+query q = do+ backend <- seldaBackend+ queryWith (runStmt backend) q++-- | Insert the given values into the given table. All columns of the table+-- must be present, EXCEPT any auto-incrementing primary keys ('autoPrimary'+-- columns), which are always assigned their default value.+-- Returns the number of rows that were inserted.+--+-- To insert a list of tuples into a table with auto-incrementing primary key:+--+-- > people :: Table (Auto Int :*: Text :*: Int :*: Maybe Text)+-- > people = table "ppl"+-- > $ autoPrimary "id"+-- > ¤ required "name"+-- > ¤ required "age"+-- > ¤ optional "pet"+-- >+-- > main = withSQLite "my_database.sqlite" $ do+-- > insert_ people+-- > [ "Link" :*: 125 :*: Just "horse"+-- > , "Zelda" :*: 119 :*: Nothing+-- > , ...+-- > ]+--+-- Again, note that ALL non-auto-incrementing fields must be present in the+-- tuples to be inserted, including primary keys without the auto-increment+-- attribute.+insert :: (MonadSelda m, Insert (InsertCols a))+ => Table a -> [InsertCols a] -> m Int+insert _ [] = do+ return 0+insert t cs = do+ liftIO $ invalidate (tableName t)+ uncurry exec $ compileInsert t cs++-- | 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 (InsertCols a))+ => Table a -> [InsertCols 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 is a type error.+insertWithPK :: (MonadSelda m, HasAutoPrimary a, Insert (InsertCols a))+ => Table a -> [InsertCols a] -> m Int+insertWithPK t cs = do+ backend <- seldaBackend+ liftIO $ invalidate (tableName t)+ liftIO . uncurry (runStmtWithPK backend) $ compileInsert t cs++-- | 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.+ -> m Int+update tbl check upd = do+ liftIO $ invalidate (tableName tbl)+ uncurry exec $ compileUpdate tbl upd check++-- | Like 'update', but doesn't return the number of updated rows.+update_ :: (MonadSelda m, Columns (Cols s a), Result (Cols s a))+ => Table a+ -> (Cols s a -> Col s Bool)+ -> (Cols s a -> Cols 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 tbl f = do+ liftIO $ invalidate (tableName tbl)+ uncurry exec $ compileDelete tbl f++-- | 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_ tbl f = void $ deleteFrom tbl f++-- | Create a table from the given schema.+createTable :: MonadSelda m => Table a -> m ()+createTable tbl = do+ cct <- customColType <$> seldaBackend+ void . flip exec [] $ compileCreateTable cct Fail tbl++-- | Create a table from the given schema, unless it already exists.+tryCreateTable :: MonadSelda m => Table a -> m ()+tryCreateTable tbl = do+ cct <- customColType <$> seldaBackend+ void . flip exec [] $ compileCreateTable cct Ignore tbl++-- | Drop the given table.+dropTable :: MonadSelda m => Table a -> m ()+dropTable = withInval $ void . flip exec [] . compileDropTable Fail++-- | Drop the given table, if it exists.+tryDropTable :: MonadSelda m => Table a -> m ()+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, MonadThrow m, MonadCatch m) => m a -> m a+transaction m = do+ void $ exec "BEGIN TRANSACTION" []+ res <- try m+ case res of+ Left (SomeException e) -> do+ void $ exec "ROLLBACK" []+ throwM e+ Right x -> do+ void $ exec "COMMIT" []+ return x++-- | 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.+--+-- By default, local caching is turned off.+--+-- WARNING: local caching is guaranteed to be consistent with the underlying+-- database, ONLY under the assumption that no other process will modify it.+-- Also note that the cache is shared between ALL Selda computations running+-- within the same process.+setLocalCache :: MonadSelda m => Int -> m ()+setLocalCache = liftIO . setMaxItems++-- | Build the final result from a list of result columns.+queryWith :: forall s m a. (MonadSelda m, Result a)+ => QueryRunner (Int, [[SqlValue]]) -> Query s a -> m [Res a]+queryWith qr q = do+ mres <- liftIO $ cached qry+ case mres of+ Just res -> do+ return res+ _ -> do+ res <- fmap snd . liftIO $ uncurry qr qry+ let res' = mkResults (Proxy :: Proxy a) res+ liftIO $ cache tables qry res'+ return res'+ where+ (tables, qry) = compileWithTables q++-- | 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)++-- | Run the given computation over a table after invalidating all cached+-- results depending on that table.+withInval :: MonadSelda m => (Table a -> m b) -> Table a -> m b+withInval f t = do+ liftIO $ invalidate $ tableName t+ f t++-- | Execute a statement without a result.+exec :: MonadSelda m => Text -> [Param] -> m Int+exec q ps = do+ backend <- seldaBackend+ fmap fst . liftIO $ runStmt backend q ps
+ src/Database/Selda/Inner.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, FlexibleContexts #-}+-- | Helpers for working with inner queries.+module Database.Selda.Inner where+import Database.Selda.Column+import Database.Selda.Types+import Data.Text (Text)++-- | A single aggregate column.+-- Aggregate columns may not be used to restrict queries.+-- When returned from an 'aggregate' subquery, an aggregate column is+-- converted into a non-aggregate column.+newtype Aggr s a = Aggr {unAggr :: Exp a}++-- | Denotes an inner query.+-- For aggregation, treating sequencing as the cartesian product of queries+-- does not work well.+-- Instead, we treat the sequencing of 'aggregate' with other+-- queries as the cartesian product of the aggregated result of the query,+-- a small but important difference.+--+-- However, for this to work, the aggregate query must not depend on any+-- columns in the outer product. Therefore, we let the aggregate query be+-- parameterized over @Inner s@ if the parent query is parameterized over @s@,+-- to enforce this separation.+data Inner s++-- | 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++-- | 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@,+-- for instance.+type family OuterCols a where+ OuterCols (t (Inner s) a :*: b) = Col s a :*: OuterCols b+ OuterCols (t (Inner s) a) = Col s a++-- | The results of a join are always nullable, as there is no guarantee that+-- all joined columns will be non-null.+-- @JoinCols a@ where @a@ is an extensible tuple is that same tuple, but in+-- the outer query and with all elements nullable.+-- For instance:+--+-- > JoinCols (Col (Inner s) Int :*: Col (Inner s) Text)+-- > = Col s (Maybe Int) :*: Col s (Maybe Text)+type family JoinCols a where+ JoinCols (Col (Inner s) (Maybe a) :*: b) = Col s (Maybe a) :*: JoinCols b+ JoinCols (Col (Inner s) a :*: b) = Col s (Maybe a) :*: JoinCols b+ JoinCols (Col (Inner s) (Maybe a)) = Col s (Maybe a)+ JoinCols (Col (Inner s) a) = Col s (Maybe a)++-- | One or more aggregate columns.+class Aggregates a where+ unAggrs :: a -> [SomeCol]+instance Aggregates (Aggr (Inner s) a) where+ unAggrs (Aggr x) = [Some x]+instance Aggregates b => Aggregates (Aggr (Inner s) a :*: b) where+ unAggrs (Aggr a :*: b) = Some a : unAggrs b
+ src/Database/Selda/Query.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Query monad and primitive operations.+module Database.Selda.Query where+import Database.Selda.Column+import Database.Selda.Inner+import Database.Selda.Query.Type+import Database.Selda.SQL+import Database.Selda.Table+import Database.Selda.Transform+import Control.Monad.State.Strict++-- | 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)+select (Table name cs) = Query $ do+ rns <- mapM (rename . Some . Col) cs'+ st <- get+ put $ st {sources = SQL rns (TableName name) [] [] [] Nothing : sources st}+ return $ toTup [n | Named n _ <- rns]+ where+ cs' = map colName cs++-- | Restrict the query somehow. Roughly equivalent to @WHERE@.+restrict :: Col s Bool -> Query s ()+restrict (C p) = Query $ do+ st <- get+ put $ case sources st of+ [] ->+ st {staticRestricts = p : staticRestricts st}+ -- PostgreSQL doesn't put renamed columns in scope in the WHERE clause+ -- of the query where they are renamed, so if the restrict predicate+ -- contains any vars renamed in this query, we must add another query+ -- just for the restrict.+ [SQL cs s ps gs os lim] | not $ p `wasRenamedIn` cs ->+ st {sources = [SQL cs s (p : ps) gs os lim]}+ ss ->+ st {sources = [SQL (allCols ss) (Product ss) [p] [] [] Nothing]}+ where+ wasRenamedIn predicate cs =+ let cs' = [n | Named n _ <- cs]+ in any (`elem` cs') (colNames [Some predicate])++-- | Execute a query, returning an aggregation of its results.+-- The query must return an inductive tuple of 'Aggregate' columns.+-- When @aggregate@ returns, those columns are converted into non-aggregate+-- columns, which may then be used to further restrict the query.+--+-- Note that aggregate queries must not depend on outer queries, nor must+-- they return any non-aggregate columns. Attempting to do either results in+-- a type error.+--+-- The SQL @HAVING@ keyword can be implemented by combining @aggregte@+-- and 'restrict':+--+-- > -- Find the number of people living on every address, for all addresses+-- < -- with more than one tenant:+-- > -- 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)+-- > restrict (num_tenants .> 1)+-- > return (num_tenants :*: address)+aggregate :: (Columns (OuterCols a), Aggregates a)+ => Query (Inner s) a+ -> Query s (OuterCols a)+aggregate q = Query $ do+ -- Run query in isolation, then rename the remaining vars and generate outer+ -- query.+ st <- get+ (gst, aggrs) <- isolate q+ cs <- mapM rename $ unAggrs aggrs+ let sql = state2sql gst+ sql' = SQL cs (Product [sql]) [] (groupCols gst) [] Nothing+ put $ st {sources = sql' : sources st}+ pure $ toTup [n | Named n _ <- cs]++-- | Perform a @LEFT JOIN@ with the current result set (i.e. the outer query)+-- as the left hand side, and the given query as the right hand side.+-- Like with 'aggregate', the inner (or right) query must not depend on the+-- outer (or right) one.+--+-- The given predicate over the values returned by the inner query determines+-- for each row whether to join or not. This predicate may depend on any+-- values from the outer query.+--+-- For instance, the following will list everyone in the @people@ table+-- together with their address if they have one; if they don't, the address+-- field will be @NULL@.+--+-- > getAddresses :: Query s (Col s Text :*: Col s (Maybe Text))+-- > getAddresses = do+-- > name :*: _ <- select people+-- > _ :*: address <- leftJoin (\(n :*: _) -> n .== name)+-- > (select addresses)+-- > return (name :*: address)+leftJoin :: (Columns a, Columns (OuterCols a), Columns (JoinCols a))+ -- | Predicate determining which lines to join.+ => (OuterCols a -> Col s Bool)+ -- | Right-hand query to join.+ -> Query (Inner s) a+ -> Query s (JoinCols a)+leftJoin check q = Query $ do+ (join_st, res) <- isolate q+ cs <- mapM rename $ fromTup res+ st <- get+ let nameds = [n | Named n _ <- cs]+ left = state2sql st+ right = SQL cs (Product [state2sql join_st]) [] [] [] Nothing+ C on = check $ toTup nameds+ outCols = [Some $ Col n | Named n _ <- cs] ++ allCols [left]+ sql = SQL outCols (LeftJoin on left right) [] [] [] Nothing+ put $ st {sources = [sql]}+ pure $ toTup nameds++-- | Group an aggregate query by a column.+-- Attempting to group a non-aggregate query is a type error.+-- An aggregate representing the grouped-by column is returned, which can be+-- returned from the aggregate query. For instance, if you want to find out+-- 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+ st <- get+ put $ st {groupCols = Some c : groupCols st}+ return (Aggr c)++-- | Drop the first @m@ rows, then get at most @n@ of the remaining rows.+limit :: Int -> Int -> Query s ()+limit from to = Query $ do+ st <- get+ put $ case sources st of+ [SQL cs s ps gs os Nothing] ->+ st {sources = [SQL cs s ps gs os (Just (from, to))]}+ ss ->+ st {sources = [SQL (allCols ss) (Product ss) [] [] [] (Just (from, to))]}++-- | Sort the result rows in ascending or descending order on the given row.+order :: Col s a -> Order -> Query s ()+order (C c) o = Query $ do+ st <- get+ put $ case sources st of+ [SQL cs s ps gs os lim] ->+ st {sources = [SQL cs s ps gs ((o, Some c):os) lim]}+ ss ->+ st {sources = [SQL (allCols ss) (Product ss) [] [] [(o, Some c)] Nothing]}
+ src/Database/Selda/Query/Type.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+module Database.Selda.Query.Type where+import Control.Monad.State.Strict+import Data.Monoid+import Data.Text (pack)+import Database.Selda.SQL+import Database.Selda.Column++-- | An SQL query.+newtype Query s a = Query {unQ :: State GenState a}+ deriving (Functor, Applicative, Monad)++-- | Run a query computation from an initial state.+runQueryM :: Query s a -> (a, GenState)+runQueryM = flip runState initState . unQ++-- | Run a query computation in isolation, but reusing the current name supply.+isolate :: Query s a -> State GenState (GenState, a)+isolate (Query q) = do+ st <- get+ put $ initState {nameSupply = nameSupply st}+ x <- q+ st' <- get+ put $ st {nameSupply = nameSupply st'}+ return (st', x)++-- | SQL generation internal state.+-- Contains the subqueries and static (i.e. not dependent on any subqueries)+-- restrictions of the query currently being built, as well as a name supply+-- for column renaming.+data GenState = GenState+ { sources :: ![SQL]+ , staticRestricts :: ![Exp Bool]+ , groupCols :: ![SomeCol]+ , nameSupply :: !Int+ }++-- | Initial state: no subqueries, no restrictions.+initState :: GenState+initState = GenState+ { sources = []+ , staticRestricts = []+ , groupCols = []+ , nameSupply = 0+ }++-- | Generate a unique name for the given column.+rename :: SomeCol -> State GenState SomeCol+rename (Some col) = do+ st <- get+ put $ st {nameSupply = succ $ nameSupply st}+ return $ Named (newName $ nameSupply st) col+ where+ newName ns =+ case col of+ Col n -> n <> "_" <> pack (show ns)+ _ -> "tmp_" <> pack (show ns)+rename col@(Named _ _) = do+ return col
+ src/Database/Selda/SQL.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE GADTs, OverloadedStrings #-}+-- | SQL AST and pretty-printing.+module Database.Selda.SQL where+import Database.Selda.Column+import Database.Selda.SqlType+import Database.Selda.Types (TableName)+import Data.Monoid++-- | A source for an SQL query.+data SqlSource+ = TableName !TableName+ | Product ![SQL]+ | LeftJoin !(Exp Bool) !SQL !SQL++-- | AST for SQL queries.+data SQL = SQL+ { cols :: ![SomeCol]+ , source :: !SqlSource+ , restricts :: ![Exp Bool]+ , groups :: ![SomeCol]+ , ordering :: ![(Order, SomeCol)]+ , limits :: !(Maybe (Int, Int))+ }++-- | The order in which to sort result rows.+data Order = Asc | Desc+ deriving (Show, Ord, Eq)++-- | A parameter to a prepared SQL statement.+data Param where+ Param :: !(Lit a) -> Param++instance Show Param where+ show (Param l) = "Param " <> show l++instance Eq Param where+ Param a == Param b = compLit a b == EQ+instance Ord Param where+ compare (Param a) (Param b) = compLit a b
+ src/Database/Selda/SQL/Print.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE GADTs, OverloadedStrings #-}+-- | Pretty-printing for SQL queries. For some values of pretty.+module Database.Selda.SQL.Print where+import Database.Selda.Column+import Database.Selda.SQL+import Database.Selda.SqlType+import Database.Selda.Types+import Control.Monad.State+import Data.List+import Data.Monoid hiding (Product)+import Data.Text (Text)+import qualified Data.Text as Text++-- | O(n log n) equivalent of @nub . sort@+snub :: (Ord a, Eq a) => [a] -> [a]+snub = map head . group . sort++-- | SQL pretty-printer. The state is the list of SQL parameters to the+-- prepared statement.+type PP = State PPState++data PPState = PPState+ { ppParams :: [Param]+ , ppTables :: [TableName]+ , ppParamNS :: Int+ , ppQueryNS :: Int+ }++-- | Run a pretty-printer.+runPP :: PP Text -> ([TableName], (Text, [Param]))+runPP pp =+ case runState pp (PPState [] [] 1 0) of+ (q, st) -> (snub $ ppTables st, (q, reverse (ppParams st)))++-- | Compile an SQL AST into a parameterized SQL query.+compSql :: SQL -> ([TableName], (Text, [Param]))+compSql = runPP . ppSql++-- | Compile a single column expression.+compExp :: Exp a -> (Text, [Param])+compExp = snd . runPP . ppCol++-- | Compile an @UPATE@ statement.+compUpdate :: TableName -> Exp Bool -> [(ColName, SomeCol)] -> (Text, [Param])+compUpdate tbl p cs = snd $ runPP ppUpd+ where+ ppUpd = do+ updates <- mapM ppUpdate cs+ check <- ppCol p+ pure $ Text.unwords+ [ "UPDATE", tbl+ , "SET", Text.intercalate ", " $ filter (not . Text.null) updates+ , "WHERE", check+ ]+ ppUpdate (n, c) = do+ c' <- ppSomeCol c+ if n == c'+ then pure ""+ else pure $ Text.unwords [n, "=", c']++-- | Compile a @DELETE@ statement.+compDelete :: TableName -> Exp Bool -> (Text, [Param])+compDelete tbl p = snd $ runPP ppDelete+ where+ ppDelete = do+ c' <- ppCol p+ pure $ Text.unwords ["DELETE FROM", tbl, "WHERE", c']++-- | Pretty-print a literal as a named parameter and save the+-- name-value binding in the environment.+ppLit :: Lit a -> PP Text+ppLit LitNull = pure "NULL"+ppLit (LitJust l) = ppLit l+ppLit l = do+ PPState ps ts ns qns <- get+ put $ PPState (Param l : ps) ts (succ ns) qns+ return $ Text.pack ('$':show ns)++dependOn :: TableName -> PP ()+dependOn t = do+ PPState ps ts ns qns <- get+ put $ PPState ps (t:ts) ns qns++-- | Generate a unique name for a subquery.+freshQueryName :: PP Text+freshQueryName = do+ PPState ps ts ns qns <- get+ put $ PPState ps ts ns (succ qns)+ return $ Text.pack ('q':show qns)++-- | Pretty-print an SQL AST.+ppSql :: SQL -> PP Text+ppSql (SQL cs src r gs ord lim) = do+ cs' <- mapM ppSomeCol cs+ src' <- ppSrc src+ r' <- ppRestricts r+ gs' <- ppGroups gs+ ord' <- ppOrder ord+ lim' <- ppLimit lim+ pure $ mconcat+ [ "SELECT ", result cs'+ , src'+ , r'+ , gs'+ , ord'+ , lim'+ ]+ where+ result [] = "1"+ result cs' = Text.intercalate "," cs'++ ppSrc (TableName n) = do+ dependOn n+ pure $ " FROM " <> n+ ppSrc (Product []) = do+ pure ""+ ppSrc (Product sqls) = do+ srcs <- mapM ppSql (reverse sqls)+ qs <- flip mapM ["(" <> s <> ")" | s <- srcs] $ \q -> do+ qn <- freshQueryName+ pure (q <> " AS " <> qn)+ pure $ " FROM " <> Text.intercalate "," qs+ ppSrc (LeftJoin on left right) = do+ l' <- ppSql left+ r' <- ppSql right+ on' <- ppCol on+ lqn <- freshQueryName+ rqn <- freshQueryName+ pure $ mconcat+ [ " FROM (", l', ") AS ", lqn+ , " LEFT JOIN (", r', ") AS ", rqn+ , " ON ", on'+ ]++ ppRestricts [] = pure ""+ ppRestricts rs = ppCols rs >>= \rs' -> pure $ " WHERE " <> rs'++ ppGroups [] = pure ""+ ppGroups grps = do+ cls <- sequence [ppCol c | Some c <- grps]+ pure $ " GROUP BY " <> Text.intercalate ", " cls++ ppOrder [] = pure ""+ ppOrder os = do+ os' <- sequence [(<> (" " <> ppOrd o)) <$> ppCol c | (o, Some c) <- os]+ pure $ " ORDER BY " <> Text.intercalate ", " os'++ ppOrd Asc = "ASC"+ ppOrd Desc = "DESC"++ ppLimit Nothing =+ pure ""+ ppLimit (Just (off, limit)) =+ pure $ " LIMIT " <> ppInt limit <> " OFFSET " <> ppInt off++ ppInt = Text.pack . show++ppSomeCol :: SomeCol -> PP Text+ppSomeCol (Some c) = ppCol c+ppSomeCol (Named n c) = do+ c' <- ppCol c+ pure $ c' <> " AS " <> n++ppCols :: [Exp Bool] -> PP Text+ppCols cs = do+ cs' <- mapM ppCol (reverse cs)+ pure $ "(" <> Text.intercalate ") AND (" cs' <> ")"++ppCol :: Exp a -> PP Text+ppCol (Col name) = pure name+ppCol (Lit l) = ppLit l+ppCol (BinOp op a b) = ppBinOp op a b+ppCol (UnOp op a) = ppUnOp op a+ppCol (Fun2 f a b) = do+ a' <- ppCol a+ b' <- ppCol b+ pure $ mconcat [f, "(", a', ", ", b', ")"]+ppCol (AggrEx f x) = ppUnOp (Fun f) x+ppCol (Cast x) = ppCol x++ppUnOp :: UnOp a b -> Exp a -> PP Text+ppUnOp op c = do+ c' <- ppCol c+ pure $ case op of+ Abs -> "ABS(" <> c' <> ")"+ Sgn -> "SIGN(" <> c' <> ")"+ Neg -> "-(" <> c' <> ")"+ Not -> "NOT(" <> c' <> ")"+ IsNull -> "(" <> c' <> ") IS NULL"+ Fun f -> f <> "(" <> c' <> ")"++ppBinOp :: BinOp a b -> Exp a -> Exp a -> PP Text+ppBinOp op a b = do+ a' <- ppCol a+ b' <- ppCol b+ pure $ paren a a' <> " " <> ppOp op <> " " <> paren b b'+ where+ paren :: Exp a -> Text -> Text+ paren (Col{}) c = c+ paren (Lit{}) c = c+ paren _ c = "(" <> c <> ")"++ ppOp :: BinOp a b -> Text+ ppOp Gt = ">"+ ppOp Lt = "<"+ ppOp Gte = ">="+ ppOp Lte = "<="+ ppOp Eq = "="+ ppOp Neq = "!="+ ppOp And = "AND"+ ppOp Or = "OR"+ ppOp Add = "+"+ ppOp Sub = "-"+ ppOp Mul = "*"+ ppOp Div = "/"+ ppOp Like = "LIKE"
+ src/Database/Selda/SqlType.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables #-}+-- | Types representable in Selda's subset of SQL.+module Database.Selda.SqlType where+import Data.Text (Text, pack, unpack)+import Data.Time+import Data.Proxy++-- | Format string used to represent date and time when+-- talking to the database backend.+sqlDateTimeFormat :: String+sqlDateTimeFormat = "%F %H:%M:%S%Q"++-- | Format string used to represent date when+-- talking to the database backend.+sqlDateFormat :: String+sqlDateFormat = "%F"++-- | Format string used to represent time of day when+-- talking to the database backend.+sqlTimeFormat :: String+sqlTimeFormat = "%H:%M:%S%Q"++-- | Any datatype representable in (Selda's subset of) SQL.+class SqlType a where+ mkLit :: a -> Lit a+ sqlType :: Proxy a -> Text+ fromSql :: SqlValue -> a++-- | An SQL mkLit.+data Lit a where+ LitS :: !Text -> Lit Text+ LitI :: !Int -> Lit Int+ LitD :: !Double -> Lit Double+ LitB :: !Bool -> Lit Bool+ LitTS :: !Text -> Lit UTCTime+ LitDate :: !Text -> Lit Day+ LitTime :: !Text -> Lit TimeOfDay+ LitJust :: !(Lit a) -> Lit (Maybe a)+ LitNull :: Lit (Maybe a)++instance Eq (Lit a) where+ a == b = compLit a b == EQ++instance Ord (Lit a) where+ compare = compLit++-- | Constructor tag for all literals. Used for Ord instance.+litConTag :: Lit a -> Int+litConTag (LitS{}) = 0+litConTag (LitI{}) = 1+litConTag (LitD{}) = 2+litConTag (LitB{}) = 3+litConTag (LitTS{}) = 4+litConTag (LitDate{}) = 5+litConTag (LitTime{}) = 6+litConTag (LitJust{}) = 7+litConTag (LitNull) = 8++-- | Compare two literals of different type for equality.+compLit :: Lit a -> Lit b -> Ordering+compLit (LitS x) (LitS x') = x `compare` x'+compLit (LitI x) (LitI x') = x `compare` x'+compLit (LitD x) (LitD x') = x `compare` x'+compLit (LitB x) (LitB x') = x `compare` x'+compLit (LitTS x) (LitTS x') = x `compare` x'+compLit (LitDate x) (LitDate x') = x `compare` x'+compLit (LitTime x) (LitTime x') = x `compare` x'+compLit (LitJust x) (LitJust x') = x `compLit` x'+compLit a b = litConTag a `compare` litConTag b++-- | Some value that is representable in SQL.+data SqlValue where+ SqlInt :: !Int -> SqlValue+ SqlFloat :: !Double -> SqlValue+ SqlString :: !Text -> SqlValue+ SqlBool :: !Bool -> SqlValue+ SqlNull :: SqlValue++instance Show SqlValue where+ show (SqlInt n) = "SqlInt " ++ show n+ show (SqlFloat f) = "SqlFloat " ++ show f+ show (SqlString s) = "SqlString " ++ show s+ show (SqlBool b) = "SqlBool " ++ show b+ show (SqlNull) = "SqlNull"++instance Show (Lit a) where+ show (LitS s) = show s+ show (LitI i) = show i+ show (LitD d) = show d+ show (LitB b) = show b+ show (LitTS s) = show s+ show (LitDate s) = show s+ show (LitTime s) = show s+ show (LitJust x) = "Just " ++ show x+ show (LitNull) = "Nothing"++instance SqlType Int where+ mkLit = LitI+ sqlType _ = "INTEGER"+ fromSql (SqlInt x) = x+ fromSql v = error $ "fromSql: int column with non-int value: " ++ show v+instance SqlType Double where+ mkLit = LitD+ sqlType _ = "DOUBLE"+ fromSql (SqlFloat x) = x+ fromSql v = error $ "fromSql: float column with non-float value: " ++ show v+instance SqlType Text where+ mkLit = LitS+ sqlType _ = "TEXT"+ fromSql (SqlString x) = x+ fromSql v = error $ "fromSql: text column with non-text value: " ++ show v+instance SqlType Bool where+ mkLit = LitB+ sqlType _ = "INT"+ fromSql (SqlBool x) = x+ fromSql (SqlInt 0) = False+ fromSql (SqlInt _) = True+ fromSql v = error $ "fromSql: bool column with non-bool value: " ++ show v+instance SqlType UTCTime where+ mkLit = LitTS . pack . formatTime defaultTimeLocale sqlDateTimeFormat+ sqlType _ = "DATETIME"+ fromSql (SqlString s) =+ case parseTimeM True defaultTimeLocale sqlDateTimeFormat (unpack s) of+ Just t -> t+ _ -> error $ "fromSql: bad datetime string: " ++ unpack s+ fromSql v = error $ "fromSql: datetime column with non-datetime value: " ++ show v+instance SqlType Day where+ mkLit = LitDate . pack . formatTime defaultTimeLocale sqlDateFormat+ sqlType _ = "DATE"+ fromSql (SqlString s) =+ case parseTimeM True defaultTimeLocale sqlDateFormat (unpack s) of+ Just t -> t+ _ -> error $ "fromSql: bad date string: " ++ unpack s+ fromSql v = error $ "fromSql: date column with non-date value: " ++ show v+instance SqlType TimeOfDay where+ mkLit = LitTime . pack . formatTime defaultTimeLocale sqlTimeFormat+ sqlType _ = "TIME"+ fromSql (SqlString s) =+ case parseTimeM True defaultTimeLocale sqlTimeFormat (unpack s) of+ Just t -> t+ _ -> error $ "fromSql: bad time string: " ++ unpack s+ fromSql v = error $ "fromSql: time column with non-time value: " ++ show v+instance SqlType a => SqlType (Maybe a) where+ mkLit (Just x) = LitJust $ mkLit x+ mkLit Nothing = LitNull+ sqlType _ = sqlType (Proxy :: Proxy a)+ fromSql (SqlNull) = Nothing+ fromSql x = Just $ fromSql x
+ src/Database/Selda/Table.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE GADTs, TypeOperators, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, RankNTypes #-}+{-# LANGUAGE UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-}+-- | Selda table definition language.+module Database.Selda.Table where+import Database.Selda.Types+import Database.Selda.SqlType+import Data.Text (Text, unpack, intercalate)+import Data.Proxy+import Data.List (sort, group)+import Data.Monoid++type family a :+++: b where+ (a :*: b) :+++: c = a :*: (b :+++: c)+ a :+++: b = a :*: b+infixr 5 :+++:+infixr 5 +++++class ComposeSpec t a b where+ -- | Combine the given tables or column specifications into a new+ -- column specification which can be used to create a new table.+ -- Useful for building composable table specifications.+ --+ -- Note that this function is only suitable for combining specifications+ -- which have a concrete type. To build a column specification from scratch,+ -- use '(¤)' instead.+ (+++) :: t a -> t b -> ColSpec (a :+++: b)++instance (ComposeSpec Table a b, ComposeSpec Table b c) =>+ ComposeSpec Table (a :*: b) c where+ a +++ b = ColSpec $ tableCols a ++ tableCols b++instance {-# OVERLAPPABLE #-} ((a :+++: b) ~ (a :*: b)) =>+ ComposeSpec Table a b where+ a +++ b = ColSpec $ tableCols a ++ tableCols b++instance (ComposeSpec ColSpec a b, ComposeSpec ColSpec b c) =>+ ComposeSpec ColSpec (a :*: b) c where+ ColSpec a +++ ColSpec b = ColSpec $ a ++ b++instance {-# OVERLAPPABLE #-} ((a :+++: b) ~ (a :*: b)) =>+ ComposeSpec ColSpec a b where+ ColSpec a +++ ColSpec b = ColSpec $ a ++ b++-- | Insertion over all non-autoincrementing required columns.+-- Autoincrementing primary keys are automatically assigned their value.+type family InsertCols a where+ InsertCols (Auto a :*: b) = InsertCols b+ InsertCols (a :*: Auto b) = a+ InsertCols (a :*: b) = a :*: InsertCols b+ InsertCols a = 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@.+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]+ }++data ColInfo = ColInfo+ { colName :: !ColName+ , colType :: !Text+ , colAttrs :: ![ColAttr]+ }++newCol :: forall a. SqlType a => ColName -> ColSpec a+newCol name = ColSpec [ColInfo+ { colName = name+ , colType = sqlType (Proxy :: Proxy a)+ , colAttrs = []+ }]++-- | A table column specification.+newtype ColSpec a = ColSpec [ColInfo]++-- | Combine two column specifications.+-- Table descriptions are built by chaining columns using this operator:+--+-- > people :: Table (Text :*: Int :*: Maybe Text)+-- > people = table "people" $ required "name" ¤ required "age" ¤ optional "pet"+--+-- To combine two pre-built tables into a table comprised of both tables'+-- fields, see '(+++)'.+(¤) :: ColSpec a -> ColSpec b -> ColSpec (a :*: b)+ColSpec a ¤ ColSpec b = ColSpec (a ++ b)+infixr 1 ¤++-- | Indicates an automatically incrementing column.+-- Auto columns are usually not touched in @INSERT@ queries.+data Auto a++-- | Used by 'IsNullable' to indicate a nullable type.+data Nullable++-- | Used by 'IsNullable' to indicate a nullable type.+data NotNullable++-- | Is the given type nullable?+type family IsNullable a where+ IsNullable (Maybe a) = Nullable+ IsNullable a = NotNullable++-- | Any table type that has an auto-incrementing primary key.+class HasAutoPrimary a+instance HasAutoPrimary (Auto a)+instance HasAutoPrimary (Auto a :*: b)+instance {-# OVERLAPPABLE #-} HasAutoPrimary b => HasAutoPrimary (a :*: b)++-- | Any SQL type which is NOT nullable.+class SqlType a => NonNull a+instance (SqlType a, IsNullable a ~ NotNullable) => 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+ deriving (Show, Eq, Ord)++-- | A non-nullable column with the given name.+required :: NonNull a => ColName -> ColSpec a+required = addAttr Required . newCol++-- | A nullable column with the given name.+optional :: SqlType a => ColName -> ColSpec (Maybe a)+optional = addAttr Optional . newCol++-- | 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 a run-time error.+primary :: NonNull a => ColName -> ColSpec a+primary = addAttr Primary . required++-- | Automatically increment the given attribute if not specified during insert.+-- Also adds the @PRIMARY KEY@ attribute on the column.+autoPrimary :: ColName -> ColSpec (Auto Int)+autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required]}]+ where ColSpec [c] = newCol n :: ColSpec Int++-- | 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: SqlType ColSpec with several columns"++-- | A table with the given name and columns.+table :: TableName -> ColSpec a -> Table a+table name (ColSpec cs) = Table+ { tableName = name+ , tableCols = validate name $ map tidy cs+ }++-- | Remove duplicate attributes.+tidy :: ColInfo -> ColInfo+tidy ci = ci {colAttrs = snub $ colAttrs ci}++-- | 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++-- | Ensure that there are no duplicate column names or primary keys.+validate :: TableName -> [ColInfo] -> [ColInfo]+validate name cis+ | null errs = cis+ | otherwise = error $ concat+ [ "validation of table ", unpack name, " failed:"+ , "\n "+ , unpack $ intercalate "\n " errs+ ]+ where+ errs = concat+ [ dupes+ , pkDupes+ , optionalRequiredMutex+ ]+ dupes =+ ["duplicate column: " <> x | (x:_:_) <- soup $ map colName cis]+ pkDupes =+ ["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis]++ -- This should be impossible, but...+ optionalRequiredMutex =+ [ "BUG: column " <> colName ci <> " is both optional and required"+ | ci <- cis+ , Optional `elem` colAttrs ci && Required `elem` colAttrs ci+ ]
+ src/Database/Selda/Table/Compile.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Generating SQL for creating and deleting tables.+module Database.Selda.Table.Compile where+import Database.Selda.Table+import Data.Monoid+import Data.Text (Text, intercalate, pack)+import qualified Data.Text as Text++data OnError = Fail | Ignore+ deriving (Eq, Ord, Show)++-- | Compile a @CREATAE TABLE@ query from a table definition.+compileCreateTable :: (Text -> [ColAttr] -> Maybe Text) -> OnError -> Table a -> Text+compileCreateTable customColType ifex tbl = mconcat+ [ "CREATE TABLE ", ifNotExists ifex, tableName tbl, "("+ , intercalate ", " (map (compileTableCol customColType) (tableCols tbl))+ , ")"+ ]+ where+ ifNotExists Fail = ""+ ifNotExists Ignore = "IF NOT EXISTS "++-- | Compile a table column.+compileTableCol :: (Text -> [ColAttr] -> Maybe Text) -> ColInfo -> Text+compileTableCol customColType ci = Text.unwords+ [ colName ci+ , case customColType typ attrs of+ Just s -> s+ _ -> typ <> " " <> Text.unwords (map compileColAttr attrs)+ ]+ where+ typ = colType ci+ attrs = colAttrs ci++-- | Compile a @DROP TABLE@ query.+compileDropTable :: OnError -> Table a -> Text+compileDropTable Fail t = Text.unwords ["DROP TABLE",tableName t]+compileDropTable _ t = Text.unwords ["DROP TABLE IF EXISTS",tableName t]++-- | Compile an @INSERT INTO@ query inserting @m@ rows with @n@ cols each.+-- Note that backends expect insertions to NOT have a semicolon at the end.+compInsert :: Table a -> Int -> Text+compInsert tbl mrows =+ Text.unwords ["INSERT INTO", tableName tbl, names, "VALUES", vals]+ where+ nonAutos =+ [ colName c+ | c <- tableCols tbl+ , not (AutoIncrement `elem` colAttrs c)+ ]+ ncols = length nonAutos+ names = "(" <> Text.intercalate ", " nonAutos <> ")"+ cols n = "(" <> Text.intercalate ", " (mkParams ncols n) <> ")"+ vals = Text.intercalate ", " $ zipWith (\f n -> f n)+ (replicate mrows cols)+ [0, ncols ..]+ mkParams cs n = map (pack . ('$':) . show . (+n)) [1..cs]++-- | Compile a column attribute.+compileColAttr :: ColAttr -> Text+compileColAttr Primary = "PRIMARY KEY"+compileColAttr AutoIncrement = "AUTOINCREMENT"+compileColAttr Required = "NOT NULL"+compileColAttr Optional = "NULL"
+ src/Database/Selda/Transform.hs view
@@ -0,0 +1,76 @@+-- | Analysis and transformation of SQL queries.+module Database.Selda.Transform where+import Database.Selda.Column+import Database.Selda.SQL+import Database.Selda.Query.Type+import Database.Selda.Types++-- | Remove all dead columns recursively, assuming that the given list of+-- column names contains all names present in the final result.+removeDeadCols :: [ColName] -> SQL -> SQL+removeDeadCols live sql =+ case source sql' of+ TableName _ -> sql'+ Product qs -> sql' {source = Product $ map noDead qs}+ LeftJoin on l r -> sql' {source = LeftJoin on (noDead l) (noDead r)}+ where+ noDead = removeDeadCols live'+ sql' = keepCols (allNonOutputColNames sql ++ live) sql+ live' = allColNames sql'++-- | Return the names of all columns in the given top-level query.+-- Subqueries are not traversed.+allColNames :: SQL -> [ColName]+allColNames sql = colNames (cols sql) ++ allNonOutputColNames sql++-- | Return the names of all non-output (i.e. 'cols') columns in the given+-- top-level query. Subqueries are not traversed.+allNonOutputColNames :: SQL -> [ColName]+allNonOutputColNames sql = concat+ [ concatMap allNamesIn (restricts sql)+ , colNames (groups sql)+ , colNames (map snd $ ordering sql)+ , case source sql of+ LeftJoin on _ _ -> allNamesIn on+ _ -> []+ ]++-- | Get all column names appearing in the given list of (possibly complex)+-- columns.+colNames :: [SomeCol] -> [ColName]+colNames cs = concat+ [ [n | Some c <- cs, n <- allNamesIn c]+ , [n | Named _ c <- cs, n <- allNamesIn c]+ , [n | Named n _ <- cs]+ ]++-- | Remove all columns but the given, named ones and aggregates, from a query's+-- list of outputs.+-- If we want to refer to a column in an outer query, it must have a name.+-- If it doesn't, then it's either not referred to by an outer query, or+-- the outer query duplicates the expression, thereby referring directly+-- to the names of its components.+keepCols :: [ColName] -> SQL -> SQL+keepCols live sql = sql {cols = filtered}+ where+ filtered = filter (`oneOf` live) (cols sql)+ oneOf (Some (AggrEx _ _)) _ = True+ oneOf (Named _ (AggrEx _ _)) _ = True+ oneOf (Some (Col n)) ns = n `elem` ns+ oneOf (Named n _) ns = n `elem` ns+ oneOf _ _ = False++-- | Build the outermost query from the SQL generation state.+-- Groups are ignored, as they are only used by 'aggregate'.+state2sql :: GenState -> SQL+state2sql (GenState [sql] srs _ _) =+ sql {restricts = restricts sql ++ srs}+state2sql (GenState ss srs _ _) =+ SQL (allCols ss) (Product ss) srs [] [] Nothing++-- | Get all output columns from a list of SQL ASTs.+allCols :: [SQL] -> [SomeCol]+allCols sqls = [outCol col | sql <- sqls, col <- cols sql]+ where+ outCol (Named n _) = Some (Col n)+ outCol c = c
+ src/Database/Selda/Types.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GADTs, TypeOperators, TypeFamilies, FlexibleInstances #-}+-- | Basic Selda types.+module Database.Selda.Types where+import Data.Text (Text)+import Data.Typeable++-- | Name of a database column.+type ColName = Text++-- | Name of a database table.+type TableName = Text++-- | An inductively defined "tuple", or heterogeneous, non-empty list.+data a :*: b where+ (:*:) :: a -> b -> a :*: b+ deriving Typeable+infixr 1 :*:++instance (Show a, Show b) => Show (a :*: b) where+ show (a :*: b) = show a ++ " :*: " ++ show b++instance (Eq a, Eq b) => Eq (a :*: b) where+ (a :*: b) == (a' :*: b') = a == a' && b == b'++instance (Ord a, Ord b) => Ord (a :*: b) where+ (a :*: b) `compare` (a' :*: b') =+ case a `compare` a' of+ EQ -> b `compare` b'+ o -> o++type family Head a where+ Head (a :*: b) = a+ Head a = a++class Tup a where+ tupHead :: a -> Head a++instance {-# OVERLAPPING #-} Tup (a :*: b) where+ tupHead (a :*: _) = a++instance Head a ~ a => Tup a where+ tupHead a = a++-- | Get the first element of an inductive tuple.+first :: Tup a => a -> Head a+first = tupHead++-- | Get the second element of an inductive tuple.+second :: Tup b => (a :*: b) -> Head b+second (_ :*: b) = tupHead b++-- | Get the third element of an inductive tuple.+third :: Tup c => (a :*: b :*: c) -> Head c+third (_ :*: _ :*: c) = tupHead c++-- | Get the fourth element of an inductive tuple.+fourth :: Tup d => (a :*: b :*: c :*: d) -> Head d+fourth (_ :*: _ :*: _ :*: d) = tupHead d++-- | Get the fifth element of an inductive tuple.+fifth :: Tup e => (a :*: b :*: c :*: d :*: e) -> Head e+fifth (_ :*: _ :*: _ :*: _ :*: e) = tupHead e++-- | Get the sixth element of an inductive tuple.+sixth :: Tup f => (a :*: b :*: c :*: d :*: e :*: f) -> Head f+sixth (_ :*: _ :*: _ :*: _ :*: _ :*: f) = tupHead f++-- | Get the seventh element of an inductive tuple.+seventh :: Tup g => (a :*: b :*: c :*: d :*: e :*: f :*: g) -> Head g+seventh (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: g) = tupHead g++-- | Get the eighth element of an inductive tuple.+eighth :: Tup h => (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h) -> Head h+eighth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: h) = tupHead h++-- | Get the ninth element of an inductive tuple.+ninth :: Tup i => (a :*: b :*: c :*: d :*: e :*: f :*: h :*: h :*: i) -> Head i+ninth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: i) = tupHead i++-- | Get the tenth element of an inductive tuple.+tenth :: Tup j => (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h :*: i :*: j)+ -> Head j+tenth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: j) = tupHead j
+ src/Database/Selda/Unsafe.hs view
@@ -0,0 +1,14 @@+-- | Unsafe operations giving the user unchecked low-level control over+-- the generated SQL.+module Database.Selda.Unsafe+ ( fun, fun2+ , aggr+ , cast+ ) where+import Database.Selda.Column+import Database.Selda.Inner (aggr)++-- | Cast a column to another type, using whichever coercion semantics are used+-- by the underlying SQL implementation.+cast :: Col s a -> Col s b+cast = liftC Cast