diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for selda +## 0.1.3.0 -- 2017-04-30 + +* Add selectors for non-generic tables. +* Allow default insertions on all columns. +* More sensible API for LIMIT. +* Fix broken SQL being generated for pathological corner cases. +* Documentation fixes. + ## 0.1.2.0 -- 2017-04-20 * Replace `¤` with `:*:` in table definitions. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,15 @@ -What is Selda? -============== +Selda +===== [![Build Status](https://travis-ci.org/valderman/selda.svg?branch=master)](https://travis-ci.org/valderman/selda) + +![Hackage Dependencies](https://img.shields.io/hackage-deps/v/selda.svg) +![MIT License](http://img.shields.io/badge/license-MIT-brightgreen.svg) + +What is Selda? +============== Selda is an embedded domain-specific language for interacting with relational -databases. It was inspired by LINQ and +databases. It was inspired by [LINQ](https://en.wikipedia.org/wiki/Language_Integrated_Query) and [Opaleye](http://hackage.haskell.org/package/opaleye). @@ -13,6 +19,7 @@ * Monadic interface: no need to be a category theory wizard just to write a few database queries. * Portable: fully functional backends for SQLite and PostgreSQL. +* Generic: easy integration with your existing Haskell types. * Creating, dropping and querying tables using type-safe database schemas. * Typed query language with products, filtering, joins and aggregation. * Inserting, updating and deleting rows from tables. @@ -220,9 +227,9 @@ ------------- 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. +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 :: SeldaT IO () @@ -242,13 +249,13 @@ ------------- 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 +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 :: SeldaT IO () -byeMinors = delete_ people (\(_ :*: age :*: _) -> age .< 20) +byeMinors = deleteFrom_ people (\(_ :*: age :*: _) -> age .< 20) ``` @@ -283,8 +290,71 @@ 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 :: SeldaT IO () +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 (Int :*: 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. @@ -501,9 +571,9 @@ Generic tables and queries -========================== +-------------------------- -Selda also supports building tables and queries from (almost) arbytrary +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: @@ -541,17 +611,6 @@ Note the use of the `gen` function here, to extract the underlying table of columns from the generic table. -With generic tables, you can use the table's datatype's record selectors -together with the `!` operator to access its columns in queries. - -``` -genericGrownups :: Query s (Col s Text) -genericGrownups = do - person <- select (gen people) - restrict (person ! age .> 20) - return (person ! personName) -``` - However, queries over generic tables aren't magic; they still consist of the same collections of columns as queries over non-generic tables. @@ -570,8 +629,8 @@ getPeopleOfAge :: Int -> SeldaT IO [Person] getPeopleOfAge yrs = do ps <- query $ do - p <- select (gen people) - restrict (p ! age .== yrs) + (name :*: age :*: _) <- select (gen people) + restrict (age .== yrs) return p return (map fromRel ps) ``` @@ -588,8 +647,9 @@ Features that would be nice to have but are not yet implemented. * If/else. -* Examples. * Foreign keys. +* Streaming +* Type-safe migrations * `WHERE x IN (SELECT ...)` * `SELECT INTO`. * Constraints other than primary key. diff --git a/selda.cabal b/selda.cabal --- a/selda.cabal +++ b/selda.cabal @@ -1,5 +1,5 @@ name: selda -version: 0.1.2.0 +version: 0.1.3.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, @@ -56,6 +56,7 @@ Database.Selda.Inner Database.Selda.Query Database.Selda.Query.Type + Database.Selda.Selectors Database.Selda.SQL Database.Selda.SQL.Print Database.Selda.SqlType diff --git a/src/Database/Selda.hs b/src/Database/Selda.hs --- a/src/Database/Selda.hs +++ b/src/Database/Selda.hs @@ -6,9 +6,10 @@ module Database.Selda ( -- * Running queries MonadIO (..), MonadSelda - , SeldaT, Table, Query, Col, Res, Result + , SeldaT, SeldaM, Table, Query, Col, Res, Result , query, transaction, setLocalCache -- * Constructing queries + , Selector, (!), Assignment(..), with , SqlType , Text, Cols, Columns , Order (..) @@ -37,7 +38,9 @@ , TableSpec, ColSpecs, ColSpec, TableName, ColName , NonNull, IsNullable, Nullable, NotNullable , Append (..), (:++:) - , table, required, optional + , Selectors, HasSelectors + , table, tableWithSelectors, selectors + , required, optional , primary, autoPrimary -- * Creating and dropping tables , createTable, tryCreateTable @@ -59,6 +62,7 @@ import Database.Selda.Inner import Database.Selda.Query import Database.Selda.Query.Type +import Database.Selda.Selectors import Database.Selda.SQL import Database.Selda.SqlType import Database.Selda.Table diff --git a/src/Database/Selda/Backend.hs b/src/Database/Selda/Backend.hs --- a/src/Database/Selda/Backend.hs +++ b/src/Database/Selda/Backend.hs @@ -2,7 +2,7 @@ -- | API for building Selda backends. module Database.Selda.Backend ( MonadIO (..) - , QueryRunner, SeldaBackend (..), MonadSelda (..), SeldaT (..) + , QueryRunner, SeldaBackend (..), MonadSelda (..), SeldaT (..), SeldaM , Param (..), Lit (..), SqlValue (..), ColAttr (..) , compileColAttr , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat @@ -53,6 +53,9 @@ instance MonadIO m => MonadSelda (SeldaT m) where seldaBackend = S get + +-- | The simplest form of Selda computation; 'SeldaT' specialized to 'IO'. +type SeldaM = SeldaT IO -- | Run a Selda transformer. Backends should use this to implement their -- @withX@ functions. diff --git a/src/Database/Selda/Caching.hs b/src/Database/Selda/Caching.hs --- a/src/Database/Selda/Caching.hs +++ b/src/Database/Selda/Caching.hs @@ -37,7 +37,6 @@ setMaxItems _ = return () #else - instance Hashable Param where hashWithSalt s (Param x) = hashWithSalt s x instance Hashable (Lit a) where diff --git a/src/Database/Selda/Compile.hs b/src/Database/Selda/Compile.hs --- a/src/Database/Selda/Compile.hs +++ b/src/Database/Selda/Compile.hs @@ -11,7 +11,6 @@ import Database.Selda.Table.Compile import Database.Selda.Transform import Database.Selda.Types -import Data.Maybe (catMaybes) import Data.Proxy import Data.Text (Text, empty) import Data.Typeable @@ -29,10 +28,8 @@ -- in the target SQL dialect, a table and a list of items corresponding -- to the table. compileInsert :: Insert a => Text -> Table a -> [a] -> (Text, [Param]) -compileInsert _ _ [] = (empty, []) -compileInsert defkw tbl rows = (compInsert defkw tbl defs, catMaybes $ concat ps) - where ps = map params rows - defs = map (map (maybe True (const False))) ps +compileInsert _ _ [] = (empty, []) +compileInsert defkw tbl rows = compInsert defkw tbl (map params rows) -- | Compile an @UPDATE@ query. compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a)) diff --git a/src/Database/Selda/Frontend.hs b/src/Database/Selda/Frontend.hs --- a/src/Database/Selda/Frontend.hs +++ b/src/Database/Selda/Frontend.hs @@ -40,7 +40,7 @@ -- -- To insert a list of tuples into a table with auto-incrementing primary key: -- --- > people :: Table (Auto Int :*: Text :*: Int :*: Maybe Text) +-- > people :: Table (Int :*: Text :*: Int :*: Maybe Text) -- > people = table "ppl" -- > $ autoPrimary "id" -- > ¤ required "name" diff --git a/src/Database/Selda/Generic.hs b/src/Database/Selda/Generic.hs --- a/src/Database/Selda/Generic.hs +++ b/src/Database/Selda/Generic.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-} @@ -22,19 +23,19 @@ module Database.Selda.Generic ( Relational, Generic , GenAttr (..), GenTable (..), Attribute, Relation - , genTable, toRel, fromRel, (!) + , genTable, toRel, toRels, fromRel, fromRels , insertGen, insertGen_, insertGenWithPK , primaryGen, autoPrimaryGen ) where import Control.Monad.State import Data.Dynamic import Data.Text (pack) -import GHC.Generics hiding (R, (:*:)) -import qualified GHC.Generics as G ((:*:)(..)) +import GHC.Generics hiding (R, (:*:), Selector) +import qualified GHC.Generics as G ((:*:)(..), Selector) import Unsafe.Coerce import Database.Selda -import Database.Selda.Column import Database.Selda.Table +import Database.Selda.Types import Database.Selda.SqlType -- | Any type which has a corresponding relation. @@ -131,6 +132,10 @@ 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: -- @@ -158,8 +163,12 @@ -- 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 . toD +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 Int @@ -173,38 +182,6 @@ insertGen_ :: (Relational a, MonadSelda m) => GenTable a -> [a] -> m () insertGen_ t = void . insertGen t --- | From the given table column, get the column corresponding to the given --- selector function. For instance: --- --- > data Person = Person --- > { id :: Int --- > , name :: Text --- > , age :: Int --- > , pet :: Maybe Text --- > } --- > deriving Generic --- > --- > people :: Table Person --- > people = genTable "people" [name :- primary] --- > --- > getAllAges :: Query s Int --- > getAllAges = do --- > p <- select people --- > return (p ! age) --- --- Note that ONLY selector functions may be passed as the second argument of --- this function. Attempting to pass any non-selector function results in a --- Haskell runtime error. -(!) :: (Columns (Cols s (Relation a)), Relational a, SqlType b) - => Cols s (Relation a) -> (a -> b) -> Col s b -cs ! f = - case drop (identify mkDummy f) cols of - (Named x _ : _) -> C (Col x) - (Some c : _) -> C (unsafeCoerce c) - _ -> error "attempted to use a non-selector with (!)" - where - cols = fromTup cs - -- | Some attribute that may be set on a table column. newtype Attribute = Attribute [ColAttr] @@ -228,7 +205,7 @@ where pack' n ci = ci { colName = if colName ci == "" - then pack $ "col_" ++ show n + then mkColName . pack $ "col_" ++ show n else colName ci } @@ -274,13 +251,13 @@ gTblCols _ = gTblCols (Proxy :: Proxy a) gMkDummy = M1 <$> gMkDummy -instance (Selector c, GRelation a) => GRelation (M1 S c a) where +instance (G.Selector c, GRelation a) => GRelation (M1 S c a) where gToRel (M1 x) = gToRel x gTblCols _ = [ci'] where [ci] = gTblCols (Proxy :: Proxy a) ci' = ColInfo - { colName = pack $ selName ((M1 undefined) :: M1 S c a b) + { colName = mkColName . pack $ selName ((M1 undefined) :: M1 S c a b) , colType = colType ci , colAttrs = colAttrs ci } @@ -309,14 +286,6 @@ a <- gMkDummy :: State Int (a x) b <- gMkDummy :: State Int (b x) return (a G.:*: b) - - -class Typeable a => ToDyn a where - toD :: a -> [Dynamic] -instance (Typeable a, ToDyn b) => ToDyn (a :*: b) where - toD (a :*: b) = toDyn a : toD b -instance {-# OVERLAPPABLE #-} Typeable a => ToDyn a where - toD a = [toDyn a] class GFromRel f where -- | Convert a value to a Haskell type from the type's corresponding relation. diff --git a/src/Database/Selda/Inner.hs b/src/Database/Selda/Inner.hs --- a/src/Database/Selda/Inner.hs +++ b/src/Database/Selda/Inner.hs @@ -1,9 +1,11 @@ {-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | Helpers for working with inner queries. module Database.Selda.Inner where import Database.Selda.Column import Database.Selda.Types import Data.Text (Text) +import Data.Typeable -- | A single aggregate column. -- Aggregate columns may not be used to restrict queries. @@ -23,6 +25,7 @@ -- parameterized over @Inner s@ if the parent query is parameterized over @s@, -- to enforce this separation. data Inner s + deriving Typeable -- | Create a named aggregate function. -- Like 'fun', this function is generally unsafe and should ONLY be used diff --git a/src/Database/Selda/Query.hs b/src/Database/Selda/Query.hs --- a/src/Database/Selda/Query.hs +++ b/src/Database/Selda/Query.hs @@ -28,21 +28,21 @@ put $ st {sources = SQL [] EmptyTable [] [] [] Nothing : sources st} return $ toTup (repeat "NULL") selectValues (row:rows) = Query $ do - names <- mapM (const freshName) rowlist + names <- mapM (const freshName) firstrow let rns = [Named n (Col n) | n <- names] - r = mkFirstRow names - st <- get - put $ st {sources = SQL rns (Values r rs) [] [] [] Nothing : sources st} + row' = mkFirstRow names + s <- get + put $ s {sources = SQL rns (Values row' rows') [] [] [] Nothing : sources s} return $ toTup [n | Named n _ <- rns] where - rowlist = map noDef $ params row + firstrow = map defToVal $ params row mkFirstRow ns = [ Named n (Lit l) - | (Param l, n) <- zip rowlist ns + | (Param l, n) <- zip firstrow ns ] - rs = map (map noDef . params) rows - noDef Nothing = error "default value given to selectValues" - noDef (Just x) = x + rows' = map (map defToVal . params) rows + defToVal (Left x) = x + defToVal (Right x) = x -- | Restrict the query somehow. Roughly equivalent to @WHERE@. restrict :: Col s Bool -> Query s () @@ -155,15 +155,19 @@ 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 +-- | Drop the first @m@ rows, then get at most @n@ of the remaining rows from the +-- given subquery. +limit :: Int -> Int -> Query (Inner s) a -> Query s a +limit from to q = Query $ do + (lim_st, res) <- isolate q 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))]} + let sql = case sources lim_st of + [SQL cs s ps gs os Nothing] -> + SQL cs s ps gs os (Just (from, to)) + ss -> + SQL (allCols ss) (Product ss) [] [] [] (Just (from, to)) + put $ st {sources = sql : sources st} + return res -- | Sort the result rows in ascending or descending order on the given row. order :: Col s a -> Order -> Query s () diff --git a/src/Database/Selda/Query/Type.hs b/src/Database/Selda/Query/Type.hs --- a/src/Database/Selda/Query/Type.hs +++ b/src/Database/Selda/Query/Type.hs @@ -5,7 +5,7 @@ import Data.Text (pack) import Database.Selda.SQL import Database.Selda.Column -import Database.Selda.Types (ColName) +import Database.Selda.Types (ColName, mkColName, addColSuffix) -- | An SQL query. newtype Query s a = Query {unQ :: State GenState a} @@ -53,8 +53,8 @@ where newName ns = case col of - Col n -> n <> "_" <> pack (show ns) - _ -> "tmp_" <> pack (show ns) + Col n -> addColSuffix n $ "_" <> pack (show ns) + _ -> mkColName $ "tmp_" <> pack (show ns) rename col@(Named _ _) = do return col @@ -69,4 +69,4 @@ freshName :: State GenState ColName freshName = do n <- freshId - return $ "tmp_" <> pack (show n) + return $ mkColName $ "tmp_" <> pack (show n) diff --git a/src/Database/Selda/SQL.hs b/src/Database/Selda/SQL.hs --- a/src/Database/Selda/SQL.hs +++ b/src/Database/Selda/SQL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, OverloadedStrings #-} +{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables #-} {-# LANGUAGE TypeOperators, FlexibleInstances, UndecidableInstances #-} -- | SQL AST and parameters for prepared statements. module Database.Selda.SQL where @@ -53,16 +53,20 @@ -- | 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 -> [Maybe Param] + params :: a -> [Either Param Param] instance (SqlType a, Insert b) => Insert (a :*: b) where params (a :*: b) = unsafePerformIO $ do res <- try $ return $! a - case res of - Right a' -> return $ Just (Param (mkLit a')) : params b - Left DefaultValueException -> return $ Nothing : params b + 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 - case res of - Right a' -> return [Just $ Param (mkLit a')] - Left DefaultValueException -> return [Nothing] + return $ case res of + Right a' -> + [Right $ Param (mkLit a')] + Left DefaultValueException -> + [Left $ Param (defaultValue :: Lit a)] diff --git a/src/Database/Selda/SQL/Print.hs b/src/Database/Selda/SQL/Print.hs --- a/src/Database/Selda/SQL/Print.hs +++ b/src/Database/Selda/SQL/Print.hs @@ -48,15 +48,23 @@ updates <- mapM ppUpdate cs check <- ppCol p pure $ Text.unwords - [ "UPDATE", tbl - , "SET", Text.intercalate ", " $ filter (not . Text.null) updates + [ "UPDATE", fromTableName tbl + , "SET", set updates , "WHERE", check ] ppUpdate (n, c) = do + let n' = fromColName n c' <- ppSomeCol c - if n == c' - then pure "" - else pure $ Text.unwords [n, "=", c'] + let upd = Text.unwords [n', "=", c'] + if n' == c' + then pure $ Left upd + else pure $ Right upd + -- if the update doesn't change anything, pick an arbitrary column to + -- set to itself just to satisfy SQL's syntactic rules + set us = + case [u | Right u <- us] of + [] -> set (take 1 [Right u | Left u <- us]) + us' -> Text.intercalate ", " us' -- | Compile a @DELETE@ statement. compDelete :: TableName -> Exp Bool -> (Text, [Param]) @@ -64,7 +72,7 @@ where ppDelete = do c' <- ppCol p - pure $ Text.unwords ["DELETE FROM", tbl, "WHERE", c'] + pure $ Text.unwords ["DELETE FROM", fromTableName tbl, "WHERE", c'] -- | Pretty-print a literal as a named parameter and save the -- name-value binding in the environment. @@ -114,7 +122,7 @@ pure $ " FROM (SELECT NULL LIMIT 0) AS " <> qn ppSrc (TableName n) = do dependOn n - pure $ " FROM " <> n + pure $ " FROM " <> fromTableName n ppSrc (Product []) = do pure "" ppSrc (Product sqls) = do @@ -176,7 +184,7 @@ ppSomeCol (Some c) = ppCol c ppSomeCol (Named n c) = do c' <- ppCol c - pure $ c' <> " AS " <> n + pure $ c' <> " AS " <> fromColName n ppCols :: [Exp Bool] -> PP Text ppCols cs = do @@ -185,7 +193,7 @@ ppCol :: Exp a -> PP Text ppCol (TblCol xs) = error $ "compiler bug: ppCol saw TblCol: " ++ show xs -ppCol (Col name) = pure name +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 diff --git a/src/Database/Selda/Selectors.hs b/src/Database/Selda/Selectors.hs new file mode 100644 --- /dev/null +++ b/src/Database/Selda/Selectors.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators, UndecidableInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, RankNTypes, AllowAmbiguousTypes, GADTs #-} +module Database.Selda.Selectors where +import Database.Selda.Table +import Database.Selda.Types +import Database.Selda.Column +import Data.Dynamic +import Data.List (foldl') +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 + +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) + 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" + +-- | A selector-value assignment pair. +data Assignment s t where + (:=) :: Selector t a -> Col s a -> Assignment s t +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 = foldl' upd + +-- | A column selector. Column selectors can be used together with the '!' and +-- '!=' operators to get and set values on inductive tuples. +newtype Selector t a = Selector 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 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) + +-- | Any table type that can have selectors generated. +class HasSelectors t a where + mkSel :: Proxy t -> Int -> Proxy a -> Selectors t a + +instance (Typeable a, HasSelectors t b) => HasSelectors t (a :*: b) where + mkSel p n _ = (Selector n :*: mkSel p (n+1) (Proxy :: Proxy b)) + +instance {-# OVERLAPPABLE #-} (Selectors t a ~ Selector t a) => + HasSelectors t a where + mkSel _ n _ = Selector n + +-- | 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 diff --git a/src/Database/Selda/SqlType.hs b/src/Database/Selda/SqlType.hs --- a/src/Database/Selda/SqlType.hs +++ b/src/Database/Selda/SqlType.hs @@ -22,9 +22,10 @@ -- | Any datatype representable in (Selda's subset of) SQL. class SqlType a where - mkLit :: a -> Lit a - sqlType :: Proxy a -> Text - fromSql :: SqlValue -> a + mkLit :: a -> Lit a + sqlType :: Proxy a -> Text + fromSql :: SqlValue -> a + defaultValue :: Lit a -- | An SQL literal. data Lit a where @@ -99,18 +100,21 @@ sqlType _ = "INTEGER" fromSql (SqlInt x) = x fromSql v = error $ "fromSql: int column with non-int value: " ++ show v + defaultValue = LitI 0 instance SqlType Double where mkLit = LitD sqlType _ = "DOUBLE" fromSql (SqlFloat x) = x fromSql v = error $ "fromSql: float column with non-float value: " ++ show v + defaultValue = LitD 0 instance SqlType Text where mkLit = LitS sqlType _ = "TEXT" fromSql (SqlString x) = x fromSql v = error $ "fromSql: text column with non-text value: " ++ show v + defaultValue = LitS "" instance SqlType Bool where mkLit = LitB @@ -119,6 +123,7 @@ fromSql (SqlInt 0) = False fromSql (SqlInt _) = True fromSql v = error $ "fromSql: bool column with non-bool value: " ++ show v + defaultValue = LitB False instance SqlType UTCTime where mkLit = LitTS . pack . formatTime defaultTimeLocale sqlDateTimeFormat @@ -128,6 +133,7 @@ Just t -> t _ -> error $ "fromSql: bad datetime string: " ++ unpack s fromSql v = error $ "fromSql: datetime column with non-datetime value: " ++ show v + defaultValue = LitTS "1970-01-01 00:00:00" instance SqlType Day where mkLit = LitDate . pack . formatTime defaultTimeLocale sqlDateFormat @@ -137,6 +143,7 @@ Just t -> t _ -> error $ "fromSql: bad date string: " ++ unpack s fromSql v = error $ "fromSql: date column with non-date value: " ++ show v + defaultValue = LitDate "1970-01-01" instance SqlType TimeOfDay where mkLit = LitTime . pack . formatTime defaultTimeLocale sqlTimeFormat @@ -146,6 +153,7 @@ Just t -> t _ -> error $ "fromSql: bad time string: " ++ unpack s fromSql v = error $ "fromSql: time column with non-time value: " ++ show v + defaultValue = LitTime "00:00:00" instance SqlType a => SqlType (Maybe a) where mkLit (Just x) = LitJust $ mkLit x @@ -153,3 +161,4 @@ sqlType _ = sqlType (Proxy :: Proxy a) fromSql (SqlNull) = Nothing fromSql x = Just $ fromSql x + defaultValue = LitNull diff --git a/src/Database/Selda/Table.hs b/src/Database/Selda/Table.hs --- a/src/Database/Selda/Table.hs +++ b/src/Database/Selda/Table.hs @@ -1,19 +1,23 @@ {-# LANGUAGE TypeOperators, TypeFamilies, OverloadedStrings #-} {-# LANGUAGE UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | 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.Dynamic import Data.List (sort, group) import Data.Monoid +import Data.Text (Text, unpack, intercalate, any) -- | 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@. +-- +-- 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 @@ -123,24 +127,43 @@ validate name cis | null errs = cis | otherwise = error $ concat - [ "validation of table ", unpack name, " failed:" + [ "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 ] + 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: " <> x | (x:_:_) <- soup $ map colName cis] + ["duplicate column: " <> fromColName 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" + [ "BUG: column " <> fromColName (colName ci) + <> " is both optional and required" | ci <- cis , Optional `elem` colAttrs ci && Required `elem` colAttrs ci ] diff --git a/src/Database/Selda/Table/Compile.hs b/src/Database/Selda/Table/Compile.hs --- a/src/Database/Selda/Table/Compile.hs +++ b/src/Database/Selda/Table/Compile.hs @@ -6,6 +6,8 @@ import Data.Monoid import Data.Text (Text, intercalate, pack) import qualified Data.Text as Text +import Database.Selda.SQL hiding (params) +import Database.Selda.Types data OnError = Fail | Ignore deriving (Eq, Ord, Show) @@ -13,7 +15,7 @@ -- | Compile a @CREATE 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, "(" + [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "(" , intercalate ", " (map (compileTableCol customColType) (tableCols tbl)) , ")" ] @@ -24,7 +26,7 @@ -- | Compile a table column. compileTableCol :: (Text -> [ColAttr] -> Maybe Text) -> ColInfo -> Text compileTableCol customColType ci = Text.unwords - [ colName ci + [ fromColName (colName ci) , case customColType typ attrs of Just s -> s _ -> typ <> " " <> Text.unwords (map compileColAttr attrs) @@ -35,47 +37,60 @@ -- | 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] +compileDropTable Fail t = + Text.unwords ["DROP TABLE",fromTableName (tableName t)] +compileDropTable _ t = + Text.unwords ["DROP TABLE IF EXISTS",fromTableName (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 :: Text -> Table a -> [[Bool]] -> Text +-- In addition to the compiled query, this function also returns the list of +-- parameters to be passed to the backend. +compInsert :: Text -> Table a -> [[Either Param Param]] -> (Text, [Param]) compInsert defaultKeyword tbl defs = - Text.unwords ["INSERT INTO", tableName tbl, names, "VALUES", values] + (query, parameters) where colNames = map colName $ tableCols tbl - names = "(" <> Text.intercalate ", " colNames <> ")" - values = Text.intercalate ", " (mkRows (1 :: Int) defs) + values = Text.intercalate ", " vals + (vals, parameters) = mkRows 1 defs [] [] + query = Text.unwords + [ "INSERT INTO" + , fromTableName (tableName tbl) + , "(" <> Text.intercalate ", " (map fromColName colNames) <> ")" + , "VALUES" + , values + ] -- Build all rows: just recurse over the list of defaults (which encodes -- the # of elements in total as well), building each row, keeping track -- of the next parameter identifier. - mkRows n (ds:dss) = - case mkRow n ds (tableCols tbl) of - (n', vals) -> mkRowText (reverse vals) : mkRows n' dss - mkRows _ _ = - [] - - mkRowText vals = "(" <> Text.intercalate ", " vals <> ")" + mkRows n (ps:pss) rts paramss = + case mkRow n ps (tableCols tbl) of + (n', names, params) -> mkRows n' pss (rowText:rts) (params:paramss) + where rowText = "(" <> Text.intercalate ", " (reverse names) <> ")" + mkRows _ _ rts ps = + (reverse rts, reverse $ concat ps) -- Build a row: use the NULL/DEFAULT keyword for default rows, otherwise -- use a parameter. - mkRow n ds cs = foldl' mkCols (n, []) (zip ds cs) + mkRow n ps names = foldl' mkCols (n, [], []) (zip ps names) -- Build a column: default values only available for for auto-incrementing -- primary keys. - mkCol n def col - | def && not (AutoIncrement `elem` colAttrs col) = - error "only auto-incrementing primary keys may have defaults" - | def = - (n, defaultKeyword) + mkCol :: Int -> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param]) + mkCol n (Left def) col ps + | AutoIncrement `elem` colAttrs col = + (n, defaultKeyword, ps) | otherwise = - (n+1, pack ('$':show n)) + (n+1, pack ('$':show n), def:ps) + mkCol n (Right val) _ ps = + (n+1, pack ('$':show n), val:ps) -- Create a colum and return the next parameter id, plus the column itself. - mkCols (n, cols) (def, col) = - fmap (:cols) (mkCol n def col) + mkCols :: (Int, [Text], [Param]) -> (Either Param Param, ColInfo) -> (Int, [Text], [Param]) + mkCols (n, names, params) (param, col) = + case mkCol n param col params of + (n', name, params') -> (n', name:names, params') -- | Compile a column attribute. compileColAttr :: ColAttr -> Text diff --git a/src/Database/Selda/Types.hs b/src/Database/Selda/Types.hs --- a/src/Database/Selda/Types.hs +++ b/src/Database/Selda/Types.hs @@ -1,20 +1,65 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# LANGUAGE GADTs, TypeOperators, TypeFamilies, FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances, DeriveGeneric, OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | Basic Selda types. -module Database.Selda.Types where -import Data.Text (Text) -import Data.Typeable +module Database.Selda.Types + ( (:*:)(..), Head, Append (..), (:++:), ToDyn (..), Tup (..) + , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth + , ColName, TableName + , mkColName, mkTableName, addColSuffix + , fromColName, fromTableName + ) 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 + +instance Hashable TableName where + hashWithSalt s (TableName tn) = hashWithSalt s tn +#endif + -- | Name of a database column. -type ColName = Text +newtype ColName = ColName Text + deriving (Ord, Eq, Show, IsString) -- | Name of a database table. -type TableName = Text +newtype TableName = TableName Text + deriving (Ord, Eq, Show, IsString) +-- | Add a suffix to a column name. +addColSuffix :: ColName -> Text -> ColName +addColSuffix (ColName cn) s = ColName $ Data.Text.append cn s + +-- | Convert a column name into a string, with quotes. +fromColName :: ColName -> Text +fromColName (ColName cn) = mconcat ["\"", escapeQuotes cn, "\""] + +-- | Convert a table name into a string, with quotes. +fromTableName :: TableName -> Text +fromTableName (TableName tn) = mconcat ["\"", escapeQuotes tn, "\""] + +-- | Create a column name. +mkColName :: Text -> ColName +mkColName = ColName + +-- | Create a column name. +mkTableName :: Text -> TableName +mkTableName = TableName + +-- | Escape double quotes in an SQL identifier. +escapeQuotes :: Text -> Text +escapeQuotes = Data.Text.replace "\"" "\"\"" + -- | An inductively defined "tuple", or heterogeneous, non-empty list. data a :*: b where (:*:) :: a -> b -> a :*: b - deriving Typeable + deriving (Typeable, Generic) infixr 1 :*: instance (Show a, Show b) => Show (a :*: b) where @@ -91,9 +136,38 @@ 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"