selda 0.1.2.0 → 0.1.3.0

raw patch · 19 files changed

+434/−162 lines, 19 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• README.md +85/−25
• selda.cabal +2/−1
• src/Database/Selda.hs +6/−2
• src/Database/Selda/Backend.hs +4/−1
• src/Database/Selda/Caching.hs +0/−1
• src/Database/Selda/Compile.hs +2/−5
• src/Database/Selda/Frontend.hs +1/−1
• src/Database/Selda/Generic.hs +17/−48
• src/Database/Selda/Inner.hs +3/−0
• src/Database/Selda/Query.hs +21/−17
• src/Database/Selda/Query/Type.hs +4/−4
• src/Database/Selda/SQL.hs +12/−8
• src/Database/Selda/SQL/Print.hs +17/−9
• src/Database/Selda/Selectors.hs +91/−0
• src/Database/Selda/SqlType.hs +12/−3
• src/Database/Selda/Table.hs +28/−5
• src/Database/Selda/Table/Compile.hs +39/−24
• src/Database/Selda/Types.hs +82/−8

@@ -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.

@@ -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)+<a href="https://www.irccloud.com/invite?channel=%23selda&amp;hostname=irc.freenode.net&amp;port=6697&amp;ssl=1" target="_blank"><img src="https://img.shields.io/badge/IRC-%23selda-1e72ff.svg?style=flat"  height="20"></a>+![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.

@@ -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

@@ -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

@@ -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.

@@ -37,7 +37,6 @@ setMaxItems _ = return ()  #else- instance Hashable Param where   hashWithSalt s (Param x) = hashWithSalt s x instance Hashable (Lit a) where

@@ -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))

@@ -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"

@@ -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.

@@ -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

@@ -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 ()

@@ -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)

@@ -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)]

@@ -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

@@ -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

@@ -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

@@ -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       ]

@@ -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

@@ -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"