selda 0.1.4.1 → 0.1.5.0

raw patch · 15 files changed

+255/−152 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• README.md +0/−2
• selda.cabal +1/−1
• src/Database/Selda.hs +11/−6
• src/Database/Selda/Caching.hs +9/−9
• src/Database/Selda/Column.hs +9/−14
• src/Database/Selda/Compile.hs +24/−7
• src/Database/Selda/Frontend.hs +19/−14
• src/Database/Selda/Inner.hs +8/−8
• src/Database/Selda/Query.hs +37/−5
• src/Database/Selda/SQL.hs +4/−1
• src/Database/Selda/SQL/Print.hs +47/−26
• src/Database/Selda/SqlType.hs +59/−54
• src/Database/Selda/Transform.hs +3/−3
• src/Database/Selda/Unsafe.hs +17/−2

@@ -1,5 +1,12 @@ # Revision history for selda +## 0.1.5.0 -- 2017-05-05++* Inner join support.+* More sensible names in backend API.+* Fix rounding and casts.++ ## 0.1.4.1 -- 2017-05-04  * Fix cache consistency bug in the presence of multiple databases.

@@ -647,12 +647,10 @@ Features that would be nice to have but are not yet implemented.  * If/else.-* Foreign keys. * Streaming * Type-safe migrations * `WHERE x IN (SELECT ...)` * `SELECT INTO`.-* Constraints other than primary key. * Database schema upgrades. * Stack build. * MySQL/MariaDB backend.

@@ -1,5 +1,5 @@ name:                selda-version:             0.1.4.1+version:             0.1.5.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,

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables, TypeOperators, GADTs #-} -- | Selda is not LINQ, but they're definitely related. -- --   Selda is a high-level EDSL for interacting with relational databases.@@ -83,8 +84,8 @@     -- * Converting between column types   , round_, just, fromBool, fromInt, toString     -- * Inner queries-  , Aggr, Aggregates, OuterCols, JoinCols, Inner, MinMax-  , leftJoin+  , Aggr, Aggregates, OuterCols, LeftCols, Inner, MinMax+  , inner, suchThat, leftJoin   , aggregate, groupBy   , count, avg, sum_, max_, min_     -- * Modifying tables@@ -113,7 +114,6 @@   , Tup, Head   , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth   ) where-import Data.Text (Text) import Database.Selda.Backend import Database.Selda.Column import Database.Selda.Compile@@ -130,6 +130,8 @@ import Database.Selda.Types import Database.Selda.Unsafe import Control.Exception (throw)+import Data.Text (Text)+import Data.Typeable (Typeable, eqT, (:~:)(..))  -- | Any column type that can be used with the 'min_' and 'max_' functions. class SqlType a => MinMax a@@ -238,8 +240,11 @@ sum_ = aggr "SUM"  -- | Round a value to the nearest integer. Equivalent to @roundTo 0@.-round_ :: Num a => Col s Double -> Col s a-round_ = fun "ROUND"+round_ :: forall s a. (Typeable a, SqlType a, Num a) => Col s Double -> Col s a+round_ =+  case eqT :: Maybe (a :~: Double) of+    Just Refl -> fun "ROUND"+    _         -> cast . fun "ROUND"  -- | Round a column to the given number of decimals places. roundTo :: Col s Int -> Col s Double -> Col s Double@@ -262,5 +267,5 @@ fromInt = cast  -- | Convert any column to a string.-toString :: Col s a -> Col s String+toString :: Col s a -> Col s Text toString = cast

@@ -40,15 +40,15 @@ instance Hashable Param where   hashWithSalt s (Param x) = hashWithSalt s x instance Hashable (Lit a) where-  hashWithSalt s (LitS x)    = hashWithSalt s x-  hashWithSalt s (LitI x)    = hashWithSalt s x-  hashWithSalt s (LitD x)    = hashWithSalt s x-  hashWithSalt s (LitB x)    = hashWithSalt s x-  hashWithSalt s (LitTS x)   = hashWithSalt s x-  hashWithSalt s (LitDate x) = hashWithSalt s x-  hashWithSalt s (LitTime x) = hashWithSalt s x-  hashWithSalt s (LitJust x) = hashWithSalt s x-  hashWithSalt _ (LitNull)   = 0+  hashWithSalt s (LText x)     = hashWithSalt s x+  hashWithSalt s (LInt x)      = hashWithSalt s x+  hashWithSalt s (LDouble x)   = hashWithSalt s x+  hashWithSalt s (LBool x)     = hashWithSalt s x+  hashWithSalt s (LDateTime x) = hashWithSalt s x+  hashWithSalt s (LDate x)     = hashWithSalt s x+  hashWithSalt s (LTime x)     = hashWithSalt s x+  hashWithSalt s (LJust x)     = hashWithSalt s x+  hashWithSalt _ (LNull)       = 0  data ResultCache = ResultCache   { -- | Query to result mapping.

@@ -1,6 +1,12 @@ {-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances #-} -- | Columns and associated utility functions.-module Database.Selda.Column where+module Database.Selda.Column+  ( Cols, Columns+  , Col (..), SomeCol (..), Exp (..), UnOp (..), BinOp (..)+  , toTup, fromTup, liftC, liftC2+  , allNamesIn+  , literal+  ) where import Database.Selda.SqlType import Database.Selda.Types import Data.String@@ -41,17 +47,6 @@ literal :: SqlType a => a -> Col s a literal = C . Lit . mkLit --- | A unary operation. Note that the provided function name is spliced---   directly into the resulting SQL query. Thus, this function should ONLY---   be used to implement well-defined functions that are missing from Selda's---   standard library, and NOT in an ad hoc manner during queries.-fun :: Text -> Col s a -> Col s b-fun f = liftC $ UnOp (Fun f)---- | Like 'fun', but with two arguments.-fun2 :: Text -> Col s a -> Col s b -> Col s c-fun2 f = liftC2 (Fun2 f)- -- | Underlying column expression type, not tied to any particular query. data Exp a where   Col    :: !ColName -> Exp a@@ -60,7 +55,7 @@   BinOp  :: !(BinOp a b) -> !(Exp a) -> !(Exp a) -> Exp b   UnOp   :: !(UnOp a b) -> !(Exp a) -> Exp b   Fun2   :: !Text -> !(Exp a) -> !(Exp b) -> Exp c-  Cast   :: !(Exp a) -> Exp b+  Cast   :: !Text -> !(Exp a) -> Exp b   AggrEx :: !Text -> !(Exp a) -> Exp b  -- | Get all column names in the given expression.@@ -71,7 +66,7 @@ allNamesIn (BinOp _ a b) = allNamesIn a ++ allNamesIn b allNamesIn (UnOp _ a)    = allNamesIn a allNamesIn (Fun2 _ a b)  = allNamesIn a ++ allNamesIn b-allNamesIn (Cast x)      = allNamesIn x+allNamesIn (Cast _ x)    = allNamesIn x allNamesIn (AggrEx _ x)  = allNamesIn x  data UnOp a b where

@@ -1,7 +1,13 @@ {-# LANGUAGE GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -- | Selda SQL compilation.-module Database.Selda.Compile where+module Database.Selda.Compile+  ( Result, Res+  , toRes+  , compile, compileWith, compileWithTables+  , compileInsert, compileUpdate, compileDelete+  )+  where import Database.Selda.Column import Database.Selda.Query.Type import Database.Selda.SQL@@ -16,13 +22,23 @@ import Data.Typeable  -- | Compile a query into a parameterised SQL statement.+--+--   The types given are tailored for SQLite. To translate SQLite types into+--   whichever types are used by your backend, use 'compileWith'. compile :: Result a => Query s a -> (Text, [Param])-compile = snd . compileWithTables+compile = snd . compileWithTables id +-- | Compile a query using the given type translation function.+compileWith :: Result a => (Text -> Text) -> Query s a -> (Text, [Param])+compileWith ttr = snd . compileWithTables ttr+ -- | Compile a query into a parameterised SQL statement. Also returns all --   tables depended on by the query.-compileWithTables :: Result a => Query s a -> ([TableName], (Text, [Param]))-compileWithTables = compSql . snd . compQuery+compileWithTables :: Result a+                  => (Text -> Text)+                  -> Query s a+                  -> ([TableName], (Text, [Param]))+compileWithTables ttr = compSql ttr . snd . compQuery  -- | Compile an @INSERT@ query, given the keyword representing default values --   in the target SQL dialect, a table and a list of items corresponding@@ -33,12 +49,13 @@  -- | Compile an @UPDATE@ query. compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a))-              => Table a                  -- ^ The table to update.+              => (Text -> Text)           -- ^ Type translation function.+              -> Table a                  -- ^ The table to update.               -> (Cols s a -> Cols s a)   -- ^ Update function.               -> (Cols s a -> Col s Bool) -- ^ Predicate: update only when true.               -> (Text, [Param])-compileUpdate tbl upd check =-    compUpdate (tableName tbl) predicate updated+compileUpdate ttr tbl upd check =+    compUpdate ttr (tableName tbl) predicate updated   where     names = map colName (tableCols tbl)     cs = toTup names

@@ -86,7 +86,8 @@        -> (Cols s a -> Cols s a)   -- ^ Update function.        -> m Int update tbl check upd = do-  res <- uncurry exec $ compileUpdate tbl upd check+  tt <- typeTrans <$> seldaBackend+  res <- uncurry exec $ compileUpdate tt tbl upd check   invalidateTable tbl   return res @@ -168,19 +169,23 @@ queryWith :: forall s m a. (MonadSelda m, Result a)           => QueryRunner (Int, [[SqlValue]]) -> Query s a -> m [Res a] queryWith qr q = do-    db <- dbIdentifier <$> seldaBackend-    let cacheKey = (db, qs, ps)-    mres <- liftIO $ cached cacheKey-    case mres of-      Just res -> do-        return res-      _        -> do-        res <- fmap snd . liftIO $ uncurry qr qry-        let res' = mkResults (Proxy :: Proxy a) res-        liftIO $ cache tables cacheKey res'-        return res'-  where-    (tables, qry@(qs, ps)) = compileWithTables q+  backend <- seldaBackend+  let db = dbIdentifier backend+      cacheKey = (db, qs, ps)+      (tables, qry@(qs, ps)) = compileWithTables (typeTrans backend) q+  mres <- liftIO $ cached cacheKey+  case mres of+    Just res -> do+      return res+    _        -> do+      res <- fmap snd . liftIO $ uncurry qr qry+      let res' = mkResults (Proxy :: Proxy a) res+      liftIO $ cache tables cacheKey res'+      return res'++-- | Translate types for casts. Column attributes are ignored here.+typeTrans :: SeldaBackend -> Text -> Text+typeTrans backend t = maybe t id (customColType backend t [])  -- | Generate the final result of a query from a list of untyped result rows. mkResults :: Result a => Proxy a -> [[SqlValue]] -> [Res a]

@@ -40,19 +40,19 @@   OuterCols (t (Inner s) a :*: b) = Col s a :*: OuterCols b   OuterCols (t (Inner s) a)       = Col s a --- | The results of a join are always nullable, as there is no guarantee that---   all joined columns will be non-null.+-- | The results of a left join are always nullable, as there is no guarantee+--   that all joined columns will be non-null. --   @JoinCols a@ where @a@ is an extensible tuple is that same tuple, but in --   the outer query and with all elements nullable. --   For instance: ----- >  JoinCols (Col (Inner s) Int :*: Col (Inner s) Text)+-- >  LeftCols (Col (Inner s) Int :*: Col (Inner s) Text) -- >    = Col s (Maybe Int) :*: Col s (Maybe Text)-type family JoinCols a where-  JoinCols (Col (Inner s) (Maybe a) :*: b) = Col s (Maybe a) :*: JoinCols b-  JoinCols (Col (Inner s) a :*: b)         = Col s (Maybe a) :*: JoinCols b-  JoinCols (Col (Inner s) (Maybe a))       = Col s (Maybe a)-  JoinCols (Col (Inner s) a)               = Col s (Maybe a)+type family LeftCols a where+  LeftCols (Col (Inner s) (Maybe a) :*: b) = Col s (Maybe a) :*: LeftCols b+  LeftCols (Col (Inner s) a :*: b)         = Col s (Maybe a) :*: LeftCols b+  LeftCols (Col (Inner s) (Maybe a))       = Col s (Maybe a)+  LeftCols (Col (Inner s) a)               = Col s (Maybe a)  -- | One or more aggregate columns. class Aggregates a where

@@ -1,6 +1,10 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -- | Query monad and primitive operations.-module Database.Selda.Query where+module Database.Selda.Query+  (select, selectValues+  , restrict, groupBy, limit, order+  , aggregate, leftJoin, inner, suchThat+  ) where import Database.Selda.Column import Database.Selda.Inner import Database.Selda.Query.Type@@ -120,13 +124,41 @@ -- >   _ :*: address <- leftJoin (\(n :*: _) -> n .== name) -- >                             (select addresses) -- >   return (name :*: address)-leftJoin :: (Columns a, Columns (OuterCols a), Columns (JoinCols a))+leftJoin :: (Columns a, Columns (OuterCols a), Columns (LeftCols a))          => (OuterCols a -> Col s Bool)             -- ^ Predicate determining which lines to join.             -- | Right-hand query to join.          -> Query (Inner s) a-         -> Query s (JoinCols a)-leftJoin check q = Query $ do+         -> Query s (LeftCols a)+leftJoin = someJoin LeftJoin++-- | Perform an @INNER JOIN@ with the current result set and the given query.+inner :: (Columns a, Columns (OuterCols a))+      => (OuterCols a -> Col s Bool)+            -- ^ Predicate determining which lines to join.+            -- | Right-hand query to join.+      -> Query (Inner s) a+      -> Query s (OuterCols a)+inner = someJoin InnerJoin++-- | Synonym for 'inner' for infix use:+--+-- > person <- select people+-- > home <- select homes `suchThat` \home -> home ! owner .== person ! name+-- > return (person ! name :*: home ! isApartment)+suchThat :: (Columns a, Columns (OuterCols a))+         => (OuterCols a -> Col s Bool)+         -> Query (Inner s) a+         -> Query s (OuterCols a)+suchThat = inner++-- | The actual code for any join.+someJoin :: (Columns a, Columns (OuterCols a), Columns a')+         => JoinType+         -> (OuterCols a -> Col s Bool)+         -> Query (Inner s) a+         -> Query s a'+someJoin jointype check q = Query $ do   (join_st, res) <- isolate q   cs <- mapM rename $ fromTup res   st <- get@@ -135,7 +167,7 @@       right = SQL cs (Product [state2sql join_st]) [] [] [] Nothing       C on = check $ toTup nameds       outCols = [Some $ Col n | Named n _ <- cs] ++ allCols [left]-      sql = SQL outCols (LeftJoin on left right) [] [] [] Nothing+      sql = SQL outCols (Join jointype on left right) [] [] [] Nothing   put $ st {sources = [sql]}   pure $ toTup nameds 

@@ -13,9 +13,12 @@ data SqlSource  = TableName !TableName  | Product ![SQL]- | LeftJoin !(Exp Bool) !SQL !SQL+ | Join !JoinType !(Exp Bool) !SQL !SQL  | Values ![SomeCol] ![[Param]]  | EmptyTable++-- | Type of join to perform.+data JoinType = InnerJoin | LeftJoin  -- | AST for SQL queries. data SQL = SQL

@@ -20,29 +20,38 @@ type PP = State PPState  data PPState = PPState-  { ppParams  :: [Param]-  , ppTables  :: [TableName]-  , ppParamNS :: Int-  , ppQueryNS :: Int+  { ppParams  :: ![Param]+  , ppTables  :: ![TableName]+  , ppParamNS :: !Int+  , ppQueryNS :: !Int+  , ppTypeTr  :: !(Text -> Text)   }  -- | Run a pretty-printer.-runPP :: PP Text -> ([TableName], (Text, [Param]))-runPP pp =-  case runState pp (PPState [] [] 1 0) of+runPP :: (Text -> Text)+      -> PP Text+      -> ([TableName], (Text, [Param]))+runPP typetr pp =+  case runState pp (PPState [] [] 1 0 typetr) of     (q, st) -> (snub $ ppTables st, (q, reverse (ppParams st)))  -- | Compile an SQL AST into a parameterized SQL query.-compSql :: SQL -> ([TableName], (Text, [Param]))-compSql = runPP . ppSql+compSql :: (Text -> Text)+        -> SQL+        -> ([TableName], (Text, [Param]))+compSql typetr = runPP typetr . ppSql  -- | Compile a single column expression.-compExp :: Exp a -> (Text, [Param])-compExp = snd . runPP . ppCol+compExp :: (Text -> Text) -> Exp a -> (Text, [Param])+compExp typetr = snd . runPP typetr . ppCol  -- | Compile an @UPATE@ statement.-compUpdate :: TableName -> Exp Bool -> [(ColName, SomeCol)] -> (Text, [Param])-compUpdate tbl p cs = snd $ runPP ppUpd+compUpdate :: (Text -> Text)+           -> TableName+           -> Exp Bool+           -> [(ColName, SomeCol)]+           -> (Text, [Param])+compUpdate typetr tbl p cs = snd $ runPP typetr ppUpd   where     ppUpd = do       updates <- mapM ppUpdate cs@@ -68,32 +77,38 @@  -- | Compile a @DELETE@ statement. compDelete :: TableName -> Exp Bool -> (Text, [Param])-compDelete tbl p = snd $ runPP ppDelete+compDelete tbl p = snd $ runPP id ppDelete   where     ppDelete = do       c' <- ppCol p       pure $ Text.unwords ["DELETE FROM", fromTableName tbl, "WHERE", c'] +-- | Pretty-print a type name.+ppType :: Text -> PP Text+ppType t = do+  typeTr <- ppTypeTr <$> get+  pure $ typeTr t+ -- | Pretty-print a literal as a named parameter and save the --   name-value binding in the environment. ppLit :: Lit a -> PP Text-ppLit LitNull     = pure "NULL"-ppLit (LitJust l) = ppLit l-ppLit l           = do-  PPState ps ts ns qns <- get-  put $ PPState (Param l : ps) ts (succ ns) qns+ppLit LNull     = pure "NULL"+ppLit (LJust l) = ppLit l+ppLit l         = do+  PPState ps ts ns qns tr <- get+  put $ PPState (Param l : ps) ts (succ ns) qns tr   return $ Text.pack ('$':show ns)  dependOn :: TableName -> PP () dependOn t = do-  PPState ps ts ns qns <- get-  put $ PPState ps (t:ts) ns qns+  PPState ps ts ns qns tr <- get+  put $ PPState ps (t:ts) ns qns tr  -- | Generate a unique name for a subquery. freshQueryName :: PP Text freshQueryName = do-  PPState ps ts ns qns <- get-  put $ PPState ps ts ns (succ qns)+  PPState ps ts ns qns tr <- get+  put $ PPState ps ts ns (succ qns) tr   return $ Text.pack ('q':show qns)  -- | Pretty-print an SQL AST.@@ -141,7 +156,7 @@         , ") AS "         , qn         ]-    ppSrc (LeftJoin on left right) = do+    ppSrc (Join jointype on left right) = do       l' <- ppSql left       r' <- ppSql right       on' <- ppCol on@@ -149,10 +164,13 @@       rqn <- freshQueryName       pure $ mconcat         [ " FROM (", l', ") AS ", lqn-        , " LEFT JOIN (", r', ") AS ", rqn+        , " ",  ppJoinType jointype, " (", r', ") AS ", rqn         , " ON ", on'         ] +    ppJoinType LeftJoin  = "LEFT JOIN"+    ppJoinType InnerJoin = "JOIN"+     ppRow xs = do       ls <- sequence [ppLit l | Param l <- xs]       pure $ Text.intercalate ", " ls@@ -202,7 +220,10 @@   b' <- ppCol b   pure $ mconcat [f, "(", a', ", ", b', ")"] ppCol (AggrEx f x)   = ppUnOp (Fun f) x-ppCol (Cast x)       = ppCol x+ppCol (Cast t x)     = do+  x' <- ppCol x+  t' <- ppType t+  pure $ mconcat ["CAST(", x', " AS ", t', ")"]  ppUnOp :: UnOp a b -> Exp a -> PP Text ppUnOp op c = do

@@ -1,6 +1,11 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-} -- | Types representable in Selda's subset of SQL.-module Database.Selda.SqlType where+module Database.Selda.SqlType+  ( Lit (..), SqlValue (..), SqlType+  , mkLit, sqlType, fromSql, defaultValue+  , compLit+  , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat+  ) where import Data.Text (Text, pack, unpack) import Data.Time import Data.Proxy@@ -29,15 +34,15 @@  -- | An SQL literal. data Lit a where-  LitS    :: !Text    -> Lit Text-  LitI    :: !Int     -> Lit Int-  LitD    :: !Double  -> Lit Double-  LitB    :: !Bool    -> Lit Bool-  LitTS   :: !Text    -> Lit UTCTime-  LitDate :: !Text    -> Lit Day-  LitTime :: !Text    -> Lit TimeOfDay-  LitJust :: !(Lit a) -> Lit (Maybe a)-  LitNull :: Lit (Maybe a)+  LText     :: !Text    -> Lit Text+  LInt      :: !Int     -> Lit Int+  LDouble   :: !Double  -> Lit Double+  LBool     :: !Bool    -> Lit Bool+  LDateTime :: !Text    -> Lit UTCTime+  LDate     :: !Text    -> Lit Day+  LTime     :: !Text    -> Lit TimeOfDay+  LJust     :: !(Lit a) -> Lit (Maybe a)+  LNull     :: Lit (Maybe a)  instance Eq (Lit a) where   a == b = compLit a b == EQ@@ -47,27 +52,27 @@  -- | Constructor tag for all literals. Used for Ord instance. litConTag :: Lit a -> Int-litConTag (LitS{})    = 0-litConTag (LitI{})    = 1-litConTag (LitD{})    = 2-litConTag (LitB{})    = 3-litConTag (LitTS{})   = 4-litConTag (LitDate{}) = 5-litConTag (LitTime{}) = 6-litConTag (LitJust{}) = 7-litConTag (LitNull)   = 8+litConTag (LText{})     = 0+litConTag (LInt{})      = 1+litConTag (LDouble{})   = 2+litConTag (LBool{})     = 3+litConTag (LDateTime{}) = 4+litConTag (LDate{})     = 5+litConTag (LTime{})     = 6+litConTag (LJust{})     = 7+litConTag (LNull)       = 8  -- | Compare two literals of different type for equality. compLit :: Lit a -> Lit b -> Ordering-compLit (LitS x)    (LitS x')    = x `compare` x'-compLit (LitI x)    (LitI x')    = x `compare` x'-compLit (LitD x)    (LitD x')    = x `compare` x'-compLit (LitB x)    (LitB x')    = x `compare` x'-compLit (LitTS x)   (LitTS x')   = x `compare` x'-compLit (LitDate x) (LitDate x') = x `compare` x'-compLit (LitTime x) (LitTime x') = x `compare` x'-compLit (LitJust x) (LitJust x') = x `compLit` x'-compLit a           b            = litConTag a `compare` litConTag b+compLit (LText x)     (LText x')     = x `compare` x'+compLit (LInt x)      (LInt x')      = x `compare` x'+compLit (LDouble x)   (LDouble x')   = x `compare` x'+compLit (LBool x)     (LBool x')     = x `compare` x'+compLit (LDateTime x) (LDateTime x') = x `compare` x'+compLit (LDate x)     (LDate x')     = x `compare` x'+compLit (LTime x)     (LTime x')     = x `compare` x'+compLit (LJust x)     (LJust x')     = x `compLit` x'+compLit a             b              = litConTag a `compare` litConTag b  -- | Some value that is representable in SQL. data SqlValue where@@ -85,80 +90,80 @@   show (SqlNull)     = "SqlNull"  instance Show (Lit a) where-  show (LitS s)    = show s-  show (LitI i)    = show i-  show (LitD d)    = show d-  show (LitB b)    = show b-  show (LitTS s)   = show s-  show (LitDate s) = show s-  show (LitTime s) = show s-  show (LitJust x) = "Just " ++ show x-  show (LitNull)   = "Nothing"+  show (LText s)     = show s+  show (LInt i)      = show i+  show (LDouble d)   = show d+  show (LBool b)     = show b+  show (LDateTime s) = show s+  show (LDate s)     = show s+  show (LTime s)     = show s+  show (LJust x)     = "Just " ++ show x+  show (LNull)       = "Nothing"  instance SqlType Int where-  mkLit = LitI+  mkLit = LInt   sqlType _ = "INTEGER"   fromSql (SqlInt x) = x   fromSql v          = error $ "fromSql: int column with non-int value: " ++ show v-  defaultValue = LitI 0+  defaultValue = LInt 0  instance SqlType Double where-  mkLit = LitD+  mkLit = LDouble   sqlType _ = "DOUBLE"   fromSql (SqlFloat x) = x   fromSql v            = error $ "fromSql: float column with non-float value: " ++ show v-  defaultValue = LitD 0+  defaultValue = LDouble 0  instance SqlType Text where-  mkLit = LitS+  mkLit = LText   sqlType _ = "TEXT"   fromSql (SqlString x) = x   fromSql v             = error $ "fromSql: text column with non-text value: " ++ show v-  defaultValue = LitS ""+  defaultValue = LText ""  instance SqlType Bool where-  mkLit = LitB+  mkLit = LBool   sqlType _ = "INT"   fromSql (SqlBool x) = x   fromSql (SqlInt 0)  = False   fromSql (SqlInt _)  = True   fromSql v           = error $ "fromSql: bool column with non-bool value: " ++ show v-  defaultValue = LitB False+  defaultValue = LBool False  instance SqlType UTCTime where-  mkLit = LitTS . pack . formatTime defaultTimeLocale sqlDateTimeFormat+  mkLit = LDateTime . pack . formatTime defaultTimeLocale sqlDateTimeFormat   sqlType _             = "DATETIME"   fromSql (SqlString s) =     case parseTimeM True defaultTimeLocale sqlDateTimeFormat (unpack s) of       Just t -> t       _      -> error $ "fromSql: bad datetime string: " ++ unpack s   fromSql v             = error $ "fromSql: datetime column with non-datetime value: " ++ show v-  defaultValue = LitTS "1970-01-01 00:00:00"+  defaultValue = LDateTime "1970-01-01 00:00:00"  instance SqlType Day where-  mkLit = LitDate . pack . formatTime defaultTimeLocale sqlDateFormat+  mkLit = LDate . pack . formatTime defaultTimeLocale sqlDateFormat   sqlType _             = "DATE"   fromSql (SqlString s) =     case parseTimeM True defaultTimeLocale sqlDateFormat (unpack s) of       Just t -> t       _      -> error $ "fromSql: bad date string: " ++ unpack s   fromSql v             = error $ "fromSql: date column with non-date value: " ++ show v-  defaultValue = LitDate "1970-01-01"+  defaultValue = LDate "1970-01-01"  instance SqlType TimeOfDay where-  mkLit = LitTime . pack . formatTime defaultTimeLocale sqlTimeFormat+  mkLit = LTime . pack . formatTime defaultTimeLocale sqlTimeFormat   sqlType _             = "TIME"   fromSql (SqlString s) =     case parseTimeM True defaultTimeLocale sqlTimeFormat (unpack s) of       Just t -> t       _      -> error $ "fromSql: bad time string: " ++ unpack s   fromSql v             = error $ "fromSql: time column with non-time value: " ++ show v-  defaultValue = LitTime "00:00:00"+  defaultValue = LTime "00:00:00"  instance SqlType a => SqlType (Maybe a) where-  mkLit (Just x) = LitJust $ mkLit x-  mkLit Nothing  = LitNull+  mkLit (Just x) = LJust $ mkLit x+  mkLit Nothing  = LNull   sqlType _ = sqlType (Proxy :: Proxy a)   fromSql (SqlNull) = Nothing   fromSql x         = Just $ fromSql x-  defaultValue = LitNull+  defaultValue = LNull

@@ -14,7 +14,7 @@       TableName _     -> sql'       Values  _ _     -> sql'       Product qs      -> sql' {source = Product $ map noDead qs}-      LeftJoin on l r -> sql' {source = LeftJoin on (noDead l) (noDead r)}+      Join jt on l r  -> sql' {source = Join jt on (noDead l) (noDead r)}   where     noDead = removeDeadCols live'     sql' = keepCols (allNonOutputColNames sql ++ live) sql@@ -33,8 +33,8 @@   , colNames (groups sql)   , colNames (map snd $ ordering sql)   , case source sql of-      LeftJoin on _ _ -> allNamesIn on-      _               -> []+      Join _ on _ _ -> allNamesIn on+      _             -> []   ]  -- | Get all column names appearing in the given list of (possibly complex)

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} -- | Unsafe operations giving the user unchecked low-level control over --   the generated SQL. module Database.Selda.Unsafe@@ -7,8 +8,22 @@   ) where import Database.Selda.Column import Database.Selda.Inner (aggr)+import Database.Selda.SqlType+import Data.Text (Text)+import Data.Proxy  -- | Cast a column to another type, using whichever coercion semantics are used --   by the underlying SQL implementation.-cast :: Col s a -> Col s b-cast = liftC Cast+cast :: forall s a b. SqlType b => Col s a -> Col s b+cast = liftC $ Cast (sqlType (Proxy :: Proxy b))++-- | A unary operation. Note that the provided function name is spliced+--   directly into the resulting SQL query. Thus, this function should ONLY+--   be used to implement well-defined functions that are missing from Selda's+--   standard library, and NOT in an ad hoc manner during queries.+fun :: Text -> Col s a -> Col s b+fun f = liftC $ UnOp (Fun f)++-- | Like 'fun', but with two arguments.+fun2 :: Text -> Col s a -> Col s b -> Col s c+fun2 f = liftC2 (Fun2 f)