packages feed

selda 0.1.0.0 → 0.1.1.0

raw patch · 17 files changed

+579/−119 lines, 17 filesdep ~base

Dependency ranges changed: base

Files

README.md view
@@ -10,12 +10,14 @@ Features ======== +* 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. * Creating, dropping and querying tables using type-safe database schemas.-* Monadic query language with products, filtering, joins and aggregation.+* Typed 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. @@ -158,15 +160,11 @@ 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+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 (Int :*: Text :*: Int :*: Maybe Text) people' = table "people_with_ids"         $ autoPrimary "id"         ¤ required "name"@@ -176,15 +174,15 @@ populate' :: SeldaT IO () populate' = do   insert_ people'-    [ "Link"      :*: 125 :*: Just "horse"-    , "Velvet"    :*: 19  :*: Nothing-    , "Kobayashi" :*: 23  :*: Just "dragon"-    , "Miyu"      :*: 10  :*: Nothing+    [ def :*: "Link"      :*: 125 :*: Just "horse"+    , def :*: "Velvet"    :*: 19  :*: Nothing+    , def :*: "Kobayashi" :*: 23  :*: Just "dragon"+    , def :*: "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`.+Note the use of the `def` value for the `id` field. This indicates that the+default value for the column should be used in lieu of any user-provided value. Since the `id` field is an auto-incrementing primary key, it will automatically be assigned a unique, increasing value. Thus, the resulting table would look like this:@@ -198,7 +196,9 @@  3 | Miyu      | 10  | ``` -If you want manual control over your primary keys, do not use `autoPrimary`.+Also note that `def` can *only* be used for columns that have default values.+Currently, only auto-incrementing primary keys can have defaults.+Attempting to use `def` in any other context results in a runtime error.   Updating rows@@ -498,3 +498,4 @@ * Constraints other than primary key. * Database schema upgrades. * Stack build.+* MySQL/MariaDB backend.
selda.cabal view
@@ -1,5 +1,5 @@ name:                selda-version:             0.1.0.0+version:             0.1.1.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,@@ -46,6 +46,7 @@   exposed-modules:     Database.Selda     Database.Selda.Backend+    Database.Selda.Generic     Database.Selda.Unsafe   other-modules:     Database.Selda.Caching
src/Database/Selda.hs view
@@ -13,7 +13,8 @@   , Text, Cols, Columns   , Order (..)   , (:*:)(..)-  , select, restrict, limit, order+  , select, selectValues+  , restrict, limit, order   , ascending, descending     -- * Expressions over columns   , (.==), (./=), (.>), (.<), (.>=), (.<=), like@@ -28,14 +29,13 @@   , aggregate, groupBy   , count, avg, sum_, max_, min_     -- * Modifying tables-  , Insert, InsertCols, HasAutoPrimary-  , insert, insert_, insertWithPK+  , Insert+  , insert, insert_, insertWithPK, def   , update, update_   , deleteFrom, deleteFrom_     -- * Defining schemas   , ColSpec, TableName, ColName   , NonNull, IsNullable, Nullable, NotNullable-  , Auto   , table, (¤), required, optional   , primary, autoPrimary     -- * Combining schemas@@ -60,20 +60,21 @@ import Database.Selda.Inner import Database.Selda.Query import Database.Selda.Query.Type-import Database.Selda.SQL (Order (..))+import Database.Selda.SQL import Database.Selda.SqlType import Database.Selda.Table import Database.Selda.Table.Compile import Database.Selda.Types import Database.Selda.Unsafe+import Control.Exception (throw)  -- | Any column type that can be used with the 'min_' and 'max_' functions.-class MinMax a-instance {-# OVERLAPPABLE #-} Num a => MinMax a+class SqlType a => MinMax a+instance {-# OVERLAPPABLE #-} (SqlType a, Num a) => MinMax a instance MinMax Text instance MinMax a => MinMax (Maybe a) -(.==), (./=), (.>), (.<), (.>=), (.<=) :: Col s a -> Col s a -> Col s Bool+(.==), (./=), (.>), (.<), (.>=), (.<=) :: SqlType a => Col s a -> Col s a -> Col s Bool (.==) = liftC2 $ BinOp Eq (./=) = liftC2 $ BinOp Neq (.>)  = liftC2 $ BinOp Gt@@ -101,6 +102,15 @@ ascending = Asc descending = Desc +-- | The default value for a column during insertion.+--   For an auto-incrementing primary key, the default value is the next key.+--+--   Using @def@ in any other context than insertion results in a runtime error.+--   Likewise, if @def@ is given for a column that does not have a default+--   value, the insertion will fail.+def :: SqlType a => a+def = throw DefaultValueException+ -- | Lift a non-nullable column to a nullable one. --   Useful for creating expressions over optional columns: --@@ -111,7 +121,7 @@ -- >   name :*: _ :*: pet <- select people -- >   restrict (pet .== just "cat") -- >   return name-just :: Col s a -> Col s (Maybe a)+just :: SqlType a => Col s a -> Col s (Maybe a) just = cast  -- | SQL NULL, at any type you like.@@ -135,17 +145,20 @@ true = literal True false = literal False --- | The SQL @LIKE@ operator; matches strings with wildcards.+-- | The SQL @LIKE@ operator; matches strings with @%@ wildcards.+--   For instance:+--+-- > "%gon" `like` "dragon" .== true 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 :: SqlType a => 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 :: (SqlType a, Num a) => Col s a -> Aggr s a avg = aggr "AVG"  -- | The greatest value in the given column. Texts are compared lexically.@@ -157,7 +170,7 @@ min_ = aggr "MIN"  -- | Sum all values in the given column.-sum_ :: Num a => Col s a -> Aggr s a+sum_ :: (SqlType a, Num a) => Col s a -> Aggr s a sum_ = aggr "SUM"  -- | Round a value to the nearest integer. Equivalent to @roundTo 0@.@@ -177,11 +190,11 @@ not_ = liftC $ UnOp Not  -- | Convert a boolean column to any numeric type.-fromBool :: Num a => Col s Bool -> Col s a+fromBool :: (SqlType a, 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 :: (SqlType a, Num a) => Col s Int -> Col s a fromInt = cast  -- | Convert any column to a string.
src/Database/Selda/Backend.hs view
@@ -34,7 +34,11 @@     -- | Generate a custom column type for the column having the given Selda     --   type and list of attributes.   , customColType :: Text -> [ColAttr] -> Maybe Text-  }++    -- | The keyword that represents the default value for auto-incrementing+    --   primary keys.+  , defaultKeyword :: Text+}  -- | Some monad with Selda SQL capabilitites. class MonadIO m => MonadSelda m where
src/Database/Selda/Column.hs view
@@ -2,16 +2,13 @@ -- | 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.@@ -27,7 +24,7 @@ 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"+  toTup xs  = C (TblCol xs)   fromTup (C x) = [Some x]  -- | A type-erased column, which may also be renamed.@@ -58,6 +55,7 @@ -- | Underlying column expression type, not tied to any particular query. data Exp a where   Col    :: !ColName -> Exp a+  TblCol :: ![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@@ -67,6 +65,7 @@  -- | Get all column names in the given expression. allNamesIn :: Exp a -> [ColName]+allNamesIn (TblCol ns)   = ns allNamesIn (Col n)       = [n] allNamesIn (Lit _)       = [] allNamesIn (BinOp _ a b) = allNamesIn a ++ allNamesIn b
src/Database/Selda/Compile.hs view
@@ -11,6 +11,7 @@ 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@@ -24,13 +25,14 @@ 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)+-- | Compile an @INSERT@ query, given the keyword representing default values+--   in the target SQL dialect, a table and a list of items corresponding+--   to the table.+compileInsert :: Insert a => Text -> Table a -> [a] -> (Text, [Param])+compileInsert _ _ []     = (empty, [])+compileInsert defkw tbl rows = (compInsert defkw tbl defs, catMaybes $ concat ps)   where ps = map params rows-        nrows = length rows+        defs = map (map (maybe True (const False))) ps  -- | Compile an @UPDATE@ query. compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a))@@ -63,15 +65,6 @@     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 @:*:@.
src/Database/Selda/Frontend.hs view
@@ -15,6 +15,7 @@ import Database.Selda.Column import Database.Selda.Compile import Database.Selda.Query.Type+import Database.Selda.SQL import Database.Selda.Table import Database.Selda.Table.Compile import Data.Proxy@@ -22,7 +23,8 @@ import Control.Monad import Control.Monad.Catch --- | Run a query within a Selda transformer.+-- | Run a query within a Selda monad. In practice, this is often a 'SeldaT'+--   transformer on top of some other monad. --   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]@@ -31,8 +33,9 @@   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.+--   must be present. If your table has an auto-incrementing primary key,+--   use the special value 'def' for that column to get the auto-incrementing+--   behavior. --   Returns the number of rows that were inserted. -- --   To insert a list of tuples into a table with auto-incrementing primary key:@@ -46,37 +49,34 @@ -- > -- > main = withSQLite "my_database.sqlite" $ do -- >   insert_ people--- >     [ "Link"  :*: 125 :*: Just "horse"--- >     , "Zelda" :*: 119 :*: Nothing+-- >     [ def :*: "Link"  :*: 125 :*: Just "horse"+-- >     , def :*: "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 :: (MonadSelda m, Insert a) => Table a -> [a] -> m Int insert _ [] = do   return 0 insert t cs = do+  kw <- defaultKeyword <$> seldaBackend+  res <- uncurry exec $ compileInsert kw t cs   liftIO $ invalidate (tableName t)-  uncurry exec $ compileInsert t cs+  return res  -- | 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_ :: (MonadSelda m, Insert a) => Table a -> [a] -> m () insert_ t cs = void $ insert t cs  -- | Like 'insert', but returns the primary key of the last inserted row. --   Attempting to run this operation on a table without an auto-incrementing --   primary key is a type error.-insertWithPK :: (MonadSelda m, HasAutoPrimary a, Insert (InsertCols a))-                => Table a -> [InsertCols a] -> m Int+insertWithPK :: (MonadSelda m, Insert a) => Table a -> [a] -> m Int insertWithPK t cs = do   backend <- seldaBackend-  liftIO $ invalidate (tableName t)-  liftIO . uncurry (runStmtWithPK backend) $ compileInsert t cs+  liftIO $ do+    res <- uncurry (runStmtWithPK backend) $ compileInsert (defaultKeyword backend) t cs+    invalidate (tableName t)+    return res  -- | Update the given table using the given update function, for all rows --   matching the given predicate. Returns the number of updated rows.@@ -86,8 +86,9 @@        -> (Cols s a -> Cols s a)   -- ^ Update function.        -> m Int update tbl check upd = do+  res <- uncurry exec $ compileUpdate tbl upd check   liftIO $ invalidate (tableName tbl)-  uncurry exec $ compileUpdate tbl upd check+  return res  -- | Like 'update', but doesn't return the number of updated rows. update_ :: (MonadSelda m, Columns (Cols s a), Result (Cols s a))@@ -102,8 +103,9 @@ deleteFrom :: (MonadSelda m, Columns (Cols s a))            => Table a -> (Cols s a -> Col s Bool) -> m Int deleteFrom tbl f = do+  res <- uncurry exec $ compileDelete tbl f   liftIO $ invalidate (tableName tbl)-  uncurry exec $ compileDelete tbl f+  return res  -- | Like 'deleteFrom', but does not return the number of deleted rows. deleteFrom_ :: (MonadSelda m, Columns (Cols s a))@@ -182,8 +184,9 @@ --   results depending on that table. withInval :: MonadSelda m => (Table a -> m b) -> Table a -> m b withInval f t = do+  res <- f t   liftIO $ invalidate $ tableName t-  f t+  return res  -- | Execute a statement without a result. exec :: MonadSelda m => Text -> [Param] -> m Int
+ src/Database/Selda/Generic.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}+-- | Build tables and database operations from (almost) any Haskell type.+--+--   While the types in this module may look somewhat intimidating, the rules+--   for generic tables and queries are quite simple:+--+--     * Any record type with a single data constructor, where all fields are+--       instances of 'SqlType', can be used for generic tables and queries+--       if it derives 'Generic'.+--     * To use the standard functions from "Database.Selda" on a generic table,+--       it needs to be unwrapped using 'gen'.+--     * Performing a 'select' on a generic table returns all the table's fields+--       as an inductive tuple.+--     * Tuples obtained this way can be handled either as any other tuple, or+--       using the '(!)' operator together with any record selector for the+--       tuple's corresponding type.+--     * Relations obtained from a query can be re-assembled into their+--       corresponding data type using 'fromRel'.+module Database.Selda.Generic+  ( Relational, Generic+  , GenTable (..), Attribute, Relation+  , genTable, toRel, fromRel, (!)+  , 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 Unsafe.Coerce+import Database.Selda+import Database.Selda.Column+import Database.Selda.Table+import Database.Selda.SqlType++-- | Any type which has a corresponding relation.+--   To make a @Relational@ instance for some type, simply derive 'Generic'.+--+--   Note that only types which have a single data constructor, and where all+--   fields are instances of 'SqlValue' can be used with this module.+--   Attempting to use functions in this module with any type which doesn't+--   obey those constraints will result in a very confusing type error.+type Relational a =+  ( Generic a+  , GRelation (Rep a)+  , GFromRel (Rep a)+  , ToDyn (Relation a)+  , Insert (Relation a)+  )++-- | A generic table. Needs to be unpacked using @gen@ before use with+--   'select', 'insert', etc.+newtype GenTable a = GenTable {gen :: Table (Relation a)}++-- | The relation corresponding to the given Haskell type.+--   This relation simply corresponds to the fields in the data type, from+--   left to right. For instance:+--+-- > data Foo = Foo+-- >   { bar :: Int+-- >   , baz :: Text+-- >   }+--+--   In this example, @Relation Foo@ is @(Int :*: Text)@, as the first field+--   of @Foo@ has type @Int@, and the second has type @Text@.+type Relation a = Rel (Rep a)++-- | Generate a table from the given table name and list of column attributes.+--   All @Maybe@ fields in the table's type will be represented by nullable+--   columns, and all non-@Maybe@ fields fill be represented by required+--   columns.+--   For example:+--+-- > data Person = Person+-- >   { id   :: Int+-- >   , name :: Text+-- >   , age  :: Int+-- >   , pet  :: Maybe Text+-- >   }+-- >   deriving Generic+-- >+-- > people :: GenTable Person+-- > people = genTable "people" [(name, autoPrimaryGen)]+--+--   This example will create a table with the column types+--   @Int :*: Text :*: Int :*: Maybe Text@, where the first field is+--   an auto-incrementing primary key.+genTable :: forall a b. Relational a+         => TableName+         -> [(a -> b, Attribute)]+         -> GenTable a+genTable tn attrs = GenTable $ Table tn (validate tn (map tidy cols))+  where+    dummy = mkDummy+    cols = zipWith addAttrs [0..] (tblCols (Proxy :: Proxy a))+    addAttrs n ci = ci+      { colAttrs = colAttrs ci ++ concat+          [ as+          | (f, Attribute as) <- attrs+          , identify dummy f == n+          ]+      }++-- | Convert a generic type into the corresponding database relation.+--   A type's corresponding relation is simply the inductive tuple consisting+--   of all of the type's fields.+--+-- > data Person = Person+-- >   { id   :: Auto Int+-- >   , name :: Text+-- >   , age  :: Int+-- >   , pet  :: Maybe Text+-- >   }+-- >   deriving Generic+-- >+-- > somePerson = Person 0 "Velvet" 19 Nothing+-- > (theId :*: theName :*: theAge :*: thePet) = toRel somePerson+--+--   This is mainly useful when inserting values into a table using 'insert'+--   and the other functions from "Database.Selda".+--   Note that since @toRel@ doesn't filter out auto-incrementing primary key+--   fields, you should use 'insertGen' and friends to insert values into+--   tables with auto-incrementing primary keys instead.+toRel :: Relational a => a -> Relation a+toRel = gToRel . from++-- | Re-assemble a generic type from its corresponding relation. This can be+--   done either for ad hoc queries or for queries over generic tables:+--+-- > data SimplePerson = SimplePerson+-- >   { name :: Text+-- >   , age  :: Int+-- >   }+-- >   deriving Generic+-- >+-- > demoPerson :: SimplePerson+-- > demoPerson = fromRel ("Miyu" :*: 10)+-- >+-- > adhoc :: Table (Text :*: Int)+-- > adhoc = table "adhoc" $ required "name" ¤ required "age"+-- >+-- > getPersons1 :: MonadSelda m => m [SimplePerson]+-- > getPersons1 = map fromRel <$> query (select adhoc)+-- >+-- > generic :: GenTable SimplePerson+-- > generic = genTable "generic" []+-- >+-- > getPersons2 :: MonadSelda m => m [SimplePerson]+-- > getPersons2 = map fromRel <$> query (select (gen generic))+--+--   Applying @toRel@ to an inductive tuple which isn't the corresponding+--   relation of the return type is a type error.+fromRel :: Relational a => Relation a -> a+fromRel = to . fst . gFromRel . toD++-- | Like 'insertWithPK', but accepts a generic table and+--   its corresponding data type.+insertGenWithPK :: (Relational a, MonadSelda m) => GenTable a -> [a] -> m Int+insertGenWithPK t = insertWithPK (gen t) . map toRel++-- | Like 'insert', but accepts a generic table and its corresponding data type.+insertGen :: (Relational a, MonadSelda m) => GenTable a -> [a] -> m Int+insertGen t = insert (gen t) . map toRel++-- | Like 'insert_', but accepts a generic table and its corresponding data type.+insertGen_ :: (Relational a, MonadSelda m) => GenTable a -> [a] -> m ()+insertGen_ t = void . insertGen t++-- | From the given table column, get the column corresponding to the given+--   selector function. For instance:+--+-- > data Person = Person+-- >   { id   :: Auto 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]++-- | A primary key which does not auto-increment.+primaryGen :: Attribute+primaryGen = Attribute [Primary, Required]++-- | An auto-incrementing primary key.+autoPrimaryGen :: Attribute+autoPrimaryGen = Attribute [Primary, AutoIncrement, Required]++-- | A dummy of some type. Encapsulated to avoid improper use, since all of+--   its fields are 'unsafeCoerce'd ints.+newtype Dummy a = Dummy a++-- | Extract all column names from the given type.+--   If the type is not a record, the columns will be named @col_1@,+--   @col_2@, etc.+tblCols :: forall a. (GRelation (Rep a)) => Proxy a -> [ColInfo]+tblCols _ = zipWith pack' [0 :: Int ..] $ gTblCols (Proxy :: Proxy (Rep a))+  where+    pack' n ci = ci+      { colName = if colName ci == ""+                    then pack $ "col_" ++ show n+                    else colName ci+      }++-- | Create a dummy of the given type.+mkDummy :: (Generic a, GRelation (Rep a)) => Dummy a+mkDummy = Dummy $ to $ evalState gMkDummy 0++-- | Get the selector identifier of the given selector for the given dummy.+identify :: Dummy a -> (a -> b) -> Int+identify (Dummy d) f = unsafeCoerce $ f d++class Traits a where+  isMaybeType :: Proxy a -> Bool+  isMaybeType _ = False+instance Traits (Maybe a) where+  isMaybeType _ = True+instance {-# OVERLAPPABLE #-} Traits a++-- | Normalized append of two inductive tuples.+--   Note that this will flatten any nested inductive tuples.+type family a :++: b where+  (a :*: b) :++: c = a :*: (b :++: c)+  a         :++: b = a :*: b++class Append a b where+  app :: a -> b -> a :++: b++instance {-# OVERLAPPING #-} Append b c => Append (a :*: b) c where+  app (a :*: b) c = a :*: app b c++instance ((a :*: b) ~ (a :++: b)) => Append a b where+  app a b = a :*: b++-- | The relation corresponding to the given type.+type family Rel (rep :: * -> *) where+  Rel (M1 t c a)  = Rel a+  Rel (K1 i a)    = a+  Rel (a G.:*: b) = Rel a :++: Rel b++class GRelation f where+  -- | Convert a value from its Haskell type into the corresponding relation.+  gToRel   :: f a -> Rel f++  -- | Compute all columns needed to represent the given type.+  gTblCols :: Proxy f -> [ColInfo]++  -- | Create a dummy value where all fields are replaced by @unsafeCoerce@'d+  --   ints. See 'mkDummy' and 'identify' for more information.+  gMkDummy :: State Int (f a)++instance GRelation a => GRelation (M1 C c a) where+  gToRel (M1 x)   = gToRel x+  gTblCols _ = gTblCols (Proxy :: Proxy a)+  gMkDummy = M1 <$> gMkDummy++instance GRelation a => GRelation (M1 D c a) where+  gToRel (M1 x)   = gToRel x+  gTblCols _ = gTblCols (Proxy :: Proxy a)+  gMkDummy = M1 <$> gMkDummy++instance (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)+        , colType = colType ci+        , colAttrs = colAttrs ci+        }+  gMkDummy = M1 <$> gMkDummy++instance (Traits a, SqlType a) => GRelation (K1 i a) where+  gToRel (K1 x) = x+  gTblCols _    = [ColInfo "" (sqlType (Proxy :: Proxy a)) optReq]+    where+      optReq+        | isMaybeType (Proxy :: Proxy a) = [Optional]+        | otherwise                      = [Required]+  gMkDummy = do+    n <- get+    put (n+1)+    return $ unsafeCoerce n++instance (Append (Rel a) (Rel b), GRelation a, GRelation b) =>+         GRelation (a G.:*: b) where+  gToRel (a G.:*: b)   = gToRel a `app` gToRel b+  gTblCols _ = gTblCols a ++ gTblCols b+    where+      a = Proxy :: Proxy a+      b = Proxy :: Proxy b+  gMkDummy = do+    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.+  gFromRel :: [Dynamic] -> (f a, [Dynamic])++instance (GFromRel a, GFromRel b) => GFromRel (a G.:*: b) where+  gFromRel xs =+      (x G.:*: y, xs'')+    where+      (x, xs') = gFromRel xs+      (y, xs'') = gFromRel xs'++instance Typeable a => GFromRel (K1 i a) where+  gFromRel (x:xs) = (K1 (fromDyn x (error "impossible")), xs)+  gFromRel _      = error "impossible: too few elements to gFromRel"++instance GFromRel a => GFromRel (M1 t c a) where+  gFromRel xs = (M1 x, xs')+    where (x, xs') = gFromRel xs
src/Database/Selda/Query.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -- | Query monad and primitive operations. module Database.Selda.Query where import Database.Selda.Column@@ -20,6 +20,30 @@   where     cs' = map colName cs +-- | Query an ad hoc table of type @a@. Each element in the given list represents+--   one row in the ad hoc table.+selectValues :: (Insert a, Columns (Cols s a)) => [a] -> Query s (Cols s a)+selectValues [] = Query $ do+  st <- get+  put $ st {sources = SQL [] EmptyTable [] [] [] Nothing : sources st}+  return $ toTup (repeat "NULL")+selectValues (row:rows) = Query $ do+    names <- mapM (const freshName) rowlist+    let rns = [Named n (Col n) | n <- names]+        r = mkFirstRow names+    st <- get+    put $ st {sources = SQL rns (Values r rs) [] [] [] Nothing : sources st}+    return $ toTup [n | Named n _ <- rns]+  where+    rowlist = map noDef $ params row+    mkFirstRow ns =+      [ Named n (Lit l)+      | (Param l, n) <- zip rowlist ns+      ]+    rs = map (map noDef . params) rows+    noDef Nothing  = error "default value given to selectValues"+    noDef (Just x) = x+ -- | Restrict the query somehow. Roughly equivalent to @WHERE@. restrict :: Col s Bool -> Query s () restrict (C p) = Query $ do@@ -49,11 +73,11 @@ --   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@+--   The SQL @HAVING@ keyword can be implemented by combining @aggregate@ --   and 'restrict': -- -- > -- Find the number of people living on every address, for all addresses--- < -- with more than one tenant:+-- > -- with more than one tenant: -- > -- SELECT COUNT(name) AS c, address FROM housing GROUP BY name HAVING c > 1 -- > -- > numPpl = do@@ -97,8 +121,8 @@ -- >                             (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)+            -- ^ Predicate determining which lines to join.             -- | Right-hand query to join.          -> Query (Inner s) a          -> Query s (JoinCols a)
src/Database/Selda/Query/Type.hs view
@@ -5,6 +5,7 @@ import Data.Text (pack) import Database.Selda.SQL import Database.Selda.Column+import Database.Selda.Types (ColName)  -- | An SQL query. newtype Query s a = Query {unQ :: State GenState a}@@ -47,9 +48,8 @@ -- | 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+    n <- freshId+    return $ Named (newName n) col   where     newName ns =       case col of@@ -57,3 +57,16 @@         _     -> "tmp_" <> pack (show ns) rename col@(Named _ _) = do   return col++-- | Get a guaranteed unique identifier.+freshId :: State GenState Int+freshId = do+  st <- get+  put $ st {nameSupply = succ $ nameSupply st}+  return (nameSupply st)++-- | Get a guaranteed unique column name.+freshName :: State GenState ColName+freshName = do+  n <- freshId+  return $ "tmp_" <> pack (show n)
src/Database/Selda/SQL.hs view
@@ -1,16 +1,21 @@ {-# LANGUAGE GADTs, OverloadedStrings #-}--- | SQL AST and pretty-printing.+{-# LANGUAGE TypeOperators, FlexibleInstances, UndecidableInstances #-}+-- | SQL AST and parameters for prepared statements. module Database.Selda.SQL where import Database.Selda.Column import Database.Selda.SqlType-import Database.Selda.Types (TableName)+import Database.Selda.Types+import Control.Exception import Data.Monoid+import System.IO.Unsafe  -- | A source for an SQL query. data SqlSource  = TableName !TableName  | Product ![SQL]  | LeftJoin !(Exp Bool) !SQL !SQL+ | Values ![SomeCol] ![[Param]]+ | EmptyTable  -- | AST for SQL queries. data SQL = SQL@@ -37,3 +42,27 @@   Param a == Param b = compLit a b == EQ instance Ord Param where   compare (Param a) (Param b) = compLit a b++-- | Exception indicating the use of a default value.+--   If any values throwing this during evaluation of @param xs@ will be+--   replaced by their default value.+data DefaultValueException = DefaultValueException+  deriving Show+instance Exception DefaultValueException++-- | An inductive tuple of Haskell-level values (i.e. @Int :*: Maybe Text@)+--   which can be inserted into a table.+class Insert a where+  params :: a -> [Maybe 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+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]
src/Database/Selda/SQL/Print.hs view
@@ -109,6 +109,9 @@     result []  = "1"     result cs' = Text.intercalate "," cs' +    ppSrc EmptyTable = do+      qn <- freshQueryName+      pure $ " FROM (SELECT NULL LIMIT 0) AS " <> qn     ppSrc (TableName n)  = do       dependOn n       pure $ " FROM " <> n@@ -120,6 +123,16 @@         qn <- freshQueryName         pure (q <> " AS " <> qn)       pure $ " FROM " <> Text.intercalate "," qs+    ppSrc (Values row rows) = do+      row' <- Text.intercalate ", " <$> mapM ppSomeCol row+      rows' <- mapM ppRow rows+      qn <- freshQueryName+      pure $ mconcat+        [ " FROM (SELECT "+        , Text.intercalate " UNION ALL SELECT " (row':rows')+        , ") AS "+        , qn+        ]     ppSrc (LeftJoin on left right) = do       l' <- ppSql left       r' <- ppSql right@@ -132,6 +145,10 @@         , " ON ", on'         ] +    ppRow xs = do+      ls <- sequence [ppLit l | Param l <- xs]+      pure $ Text.intercalate ", " ls+     ppRestricts [] = pure ""     ppRestricts rs = ppCols rs >>= \rs' -> pure $ " WHERE " <> rs' @@ -167,6 +184,7 @@   pure $ "(" <> Text.intercalate ") AND (" cs' <> ")"  ppCol :: Exp a -> PP Text+ppCol (TblCol xs)    = error $ "compiler bug: ppCol saw TblCol: " ++ show xs ppCol (Col name)     = pure name ppCol (Lit l)        = ppLit l ppCol (BinOp op a b) = ppBinOp op a b
src/Database/Selda/SqlType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-} -- | Types representable in Selda's subset of SQL. module Database.Selda.SqlType where import Data.Text (Text, pack, unpack)@@ -22,11 +22,11 @@  -- | Any datatype representable in (Selda's subset of) SQL. class SqlType a where-  mkLit :: a -> Lit a+  mkLit   :: a -> Lit a   sqlType :: Proxy a -> Text   fromSql :: SqlValue -> a --- | An SQL mkLit.+-- | An SQL literal. data Lit a where   LitS    :: !Text    -> Lit Text   LitI    :: !Int     -> Lit Int@@ -99,16 +99,19 @@   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"@@ -116,6 +119,7 @@   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"@@ -124,6 +128,7 @@       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"@@ -132,6 +137,7 @@       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"@@ -140,6 +146,7 @@       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
src/Database/Selda/Table.hs view
@@ -42,14 +42,6 @@          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@@ -92,10 +84,6 @@ 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 @@ -107,12 +95,6 @@   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@@ -140,7 +122,7 @@  -- | 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 :: ColName -> ColSpec Int autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required]}]   where ColSpec [c] = newCol n :: ColSpec Int
src/Database/Selda/Table/Compile.hs view
@@ -2,6 +2,7 @@ -- | Generating SQL for creating and deleting tables. module Database.Selda.Table.Compile where import Database.Selda.Table+import Data.List (foldl') import Data.Monoid import Data.Text (Text, intercalate, pack) import qualified Data.Text as Text@@ -9,7 +10,7 @@ data OnError = Fail | Ignore   deriving (Eq, Ord, Show) --- | Compile a @CREATAE TABLE@ query from a table definition.+-- | 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, "("@@ -39,22 +40,42 @@  -- | 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]+compInsert :: Text -> Table a -> [[Bool]] -> Text+compInsert defaultKeyword tbl defs =+    Text.unwords ["INSERT INTO", tableName tbl, names, "VALUES", values]   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]+    colNames = map colName $ tableCols tbl+    names = "(" <>  Text.intercalate ", " colNames <> ")"+    values = Text.intercalate ", " (mkRows (1 :: Int) defs)++    -- 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 <> ")"++    -- 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)++    -- 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)+      | otherwise =+        (n+1, pack ('$':show n))++    -- Create a colum and return the next parameter id, plus the column itself.+    mkCols (n, cols) (def, col) =+      fmap (:cols) (mkCol n def col)  -- | Compile a column attribute. compileColAttr :: ColAttr -> Text
src/Database/Selda/Transform.hs view
@@ -10,7 +10,9 @@ removeDeadCols :: [ColName] -> SQL -> SQL removeDeadCols live sql =     case source sql' of+      EmptyTable      -> sql'       TableName _     -> sql'+      Values  _ _     -> sql'       Product qs      -> sql' {source = Product $ map noDead qs}       LeftJoin on l r -> sql' {source = LeftJoin on (noDead l) (noDead r)}   where
src/Database/Selda/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs, TypeOperators, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Basic Selda types. module Database.Selda.Types where import Data.Text (Text)