selda 0.1.10.1 → 0.1.11.0

raw patch · 11 files changed

+125/−49 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• selda.cabal +1/−1
• src/Database/Selda.hs +15/−4
• src/Database/Selda/Column.hs +4/−1
• src/Database/Selda/Compile.hs +21/−6
• src/Database/Selda/Exp.hs +2/−0
• src/Database/Selda/Query.hs +31/−25
• src/Database/Selda/Query/Type.hs +19/−7
• src/Database/Selda/SQL.hs +15/−0
• src/Database/Selda/SQL/Print.hs +7/−2
• src/Database/Selda/Transform.hs +3/−3

@@ -1,6 +1,13 @@ # Revision history for Selda  +## 0.1.11.0 -- 2017-09-08++* Fix name generation in the presence of isIn over queries.+* SELECT DISTINCT support.+* Conditional expressions and matchNull.++ ## 0.1.10.1 -- 2017-08-11  * Fix name generation in the presence of multiple aggregates.

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

@@ -73,7 +73,7 @@   , Cols, Columns   , Order (..)   , (:*:)(..)-  , select, selectValues, from+  , select, selectValues, from, distinct   , restrict, limit   , order , ascending, descending   , inner, suchThat@@ -83,7 +83,7 @@   , (.==), (./=), (.>), (.<), (.>=), (.<=), like   , (.&&), (.||), not_   , literal, int, float, text, true, false, null_-  , roundTo, length_, isNull+  , roundTo, length_, isNull, ifThenElse, matchNull     -- * Converting between column types   , round_, just, fromBool, fromInt, toString     -- * Inner queries@@ -132,7 +132,7 @@ import Database.Selda.Query import Database.Selda.Query.Type import Database.Selda.Selectors-import Database.Selda.SQL+import Database.Selda.SQL hiding (distinct) import Database.Selda.SqlType import Database.Selda.Table import Database.Selda.Table.Compile@@ -214,6 +214,13 @@ isNull :: Col s (Maybe a) -> Col s Bool isNull = liftC $ UnOp IsNull +-- | Applies the given function to the given nullable column where it isn't null,+--   and returns the given default value where it is.+--+--   This is the Selda equivalent of 'maybe'.+matchNull :: SqlType a => Col s b -> (Col s a -> Col s b) -> Col s (Maybe a) -> Col s b+matchNull nullvalue f x = ifThenElse (isNull x) nullvalue (f (cast x))+ -- | Any container type for which we can check object membership. class Set set where   -- | Is the given column contained in the given set?@@ -226,7 +233,7 @@   isIn (C x) xs = C $ InList x (unsafeCoerce xs)  instance Set (Query s) where-  isIn (C x) = C . InQuery x . snd . compQuery+  isIn (C x) = C . InQuery x . snd . compQueryWithFreshScope  (.&&), (.||) :: Col s Bool -> Col s Bool -> Col s Bool (.&&) = liftC2 $ BinOp And@@ -338,3 +345,7 @@ -- | Convert any column to a string. toString :: Col s a -> Col s Text toString = cast++-- | Perform a conditional on a column+ifThenElse :: Col s Bool -> Col s a -> Col s a -> Col s a+ifThenElse = liftC3 If

@@ -3,7 +3,7 @@ module Database.Selda.Column   ( Cols, Columns   , Col (..), SomeCol (..), Exp (..), UnOp (..), BinOp (..)-  , toTup, fromTup, liftC, liftC2+  , toTup, fromTup, liftC, liftC2, liftC3   , allNamesIn   , literal   ) where@@ -45,6 +45,9 @@  instance IsString (Col s Text) where   fromString = literal . fromString++liftC3 :: (Exp SQL a -> Exp SQL b -> Exp SQL c -> Exp SQL d) -> Col s a -> Col s b -> Col s c -> Col s d+liftC3 f (C a) (C b) (C c) = C (f a b c)  liftC2 :: (Exp SQL a -> Exp SQL b -> Exp SQL c) -> Col s a -> Col s b -> Col s c liftC2 f (C a) (C b) = C (f a b)

@@ -3,7 +3,7 @@ -- | Selda SQL compilation. module Database.Selda.Compile   ( Result, Res-  , toRes, compQuery+  , toRes, compQuery, compQueryWithFreshScope   , compile, compileWith, compileWithTables   , compileInsert, compileUpdate, compileDelete   )@@ -22,6 +22,10 @@ import Data.Text (Text, empty) import Data.Typeable (Typeable) +-- For scope supply+import Data.IORef+import System.IO.Unsafe+ -- | Compile a query into a parameterised SQL statement. -- --   The types given are tailored for SQLite. To translate SQLite types into@@ -39,7 +43,7 @@                   => PPConfig                   -> Query s a                   -> ([TableName], (Text, [Param]))-compileWithTables cfg = compSql cfg . snd . compQuery+compileWithTables cfg = compSql cfg . snd . compQuery 0  -- | Compile an @INSERT@ query, given the keyword representing default values --   in the target SQL dialect, a table and a list of items corresponding@@ -83,15 +87,26 @@  -- | Compile a query to an SQL AST. --   Groups are ignored, as they are only used by 'aggregate'.-compQuery :: Result a => Query s a -> (Int, SQL)-compQuery q =-    (nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing)+compQuery :: Result a => Scope -> Query s a -> (Int, SQL)+compQuery ns q =+    (nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing False)   where-    (cs, st) = runQueryM q+    (cs, st) = runQueryM ns q     final = finalCols cs     sql = state2sql st     live = colNames final ++ allNonOutputColNames sql     srcs = removeDeadCols live sql++{-# NOINLINE scopeSupply #-}+scopeSupply :: IORef Scope+scopeSupply = unsafePerformIO $ newIORef 1++-- | Get a fresh scope from the global scope supply, then use it to compile+--   the given query.+compQueryWithFreshScope :: Result a => Query s a -> (Int, SQL)+compQueryWithFreshScope q = unsafePerformIO $ do+  s <- atomicModifyIORef' scopeSupply (\s -> (s+1, s))+  return $ compQuery s q  -- | An acceptable query result type; one or more columns stitched together --   with @:*:@.

@@ -20,6 +20,7 @@   BinOp   :: !(BinOp a b) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql b   UnOp    :: !(UnOp a b) -> !(Exp sql a) -> Exp sql b   Fun2    :: !Text -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c+  If      :: !(Exp sql Bool) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql a   Cast    :: !SqlTypeRep -> !(Exp sql a) -> Exp sql b   AggrEx  :: !Text -> !(Exp sql a) -> Exp sql b   InList  :: !(Exp sql a) -> ![Exp sql a] -> Exp sql Bool@@ -63,6 +64,7 @@   allNamesIn (BinOp _ a b) = allNamesIn a ++ allNamesIn b   allNamesIn (UnOp _ a)    = allNamesIn a   allNamesIn (Fun2 _ a b)  = allNamesIn a ++ allNamesIn b+  allNamesIn (If a b c)    = allNamesIn a ++ allNamesIn b ++ allNamesIn c   allNamesIn (Cast _ x)    = allNamesIn x   allNamesIn (AggrEx _ x)  = allNamesIn x   allNamesIn (InList x xs) = concatMap allNamesIn (x:xs)

@@ -1,14 +1,15 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -- | Query monad and primitive operations. module Database.Selda.Query-  ( select, selectValues+  ( select, selectValues, Database.Selda.Query.distinct   , restrict, groupBy, limit, order   , aggregate, leftJoin, innerJoin   ) where+import Data.Maybe (isNothing) import Database.Selda.Column import Database.Selda.Inner import Database.Selda.Query.Type-import Database.Selda.SQL+import Database.Selda.SQL as SQL import Database.Selda.Table import Database.Selda.Transform import Control.Monad.State.Strict@@ -20,7 +21,7 @@ select (Table name cs _) = Query $ do     rns <- mapM (rename . Some . Col) cs'     st <- get-    put $ st {sources = SQL rns (TableName name) [] [] [] Nothing : sources st}+    put $ st {sources = sqlFrom rns (TableName name) : sources st}     return $ toTup [n | Named n _ <- rns]   where     cs' = map colName cs@@ -30,14 +31,14 @@ 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}+  put $ st {sources = sqlFrom [] EmptyTable : sources st}   return $ toTup (repeat "NULL") selectValues (row:rows) = Query $ do     names <- mapM (const freshName) firstrow     let rns = [Named n (Col n) | n <- names]         row' = mkFirstRow names     s <- get-    put $ s {sources = SQL rns (Values row' rows') [] [] [] Nothing : sources s}+    put $ s {sources = sqlFrom rns (Values row' rows') : sources s}     return $ toTup [n | Named n _ <- rns]   where     firstrow = map defToVal $ params row@@ -60,10 +61,10 @@       -- of the query where they are renamed, so if the restrict predicate       -- contains any vars renamed in this query, we must add another query       -- just for the restrict.-      [SQL cs s ps gs os lim] | not $ p `wasRenamedIn` cs ->-        st {sources = [SQL cs s (p : ps) gs os lim]}+      [sql] | not $ p `wasRenamedIn` cols sql ->+        st {sources = [sql {restricts = p : restricts sql}]}       ss ->-        st {sources = [SQL (allCols ss) (Product ss) [p] [] [] Nothing]}+        st {sources = [(sqlFrom (allCols ss) (Product ss)) {restricts = [p]}]}   where     wasRenamedIn predicate cs =       let cs' = [n | Named n _ <- cs]@@ -98,9 +99,8 @@ aggregate q = Query $ do   (gst, aggrs) <- isolate q   cs <- mapM rename $ unAggrs aggrs-  let sql = state2sql gst-      sql' = SQL cs (Product [sql]) [] (groupCols gst) [] Nothing-  modify $ \st -> st {sources = sql' : sources st}+  let sql = (sqlFrom cs (Product [state2sql gst])) {groups = groupCols gst}+  modify $ \st -> st {sources = sql : sources st}   pure $ toTup [n | Named n _ <- cs]  -- | Perform a @LEFT JOIN@ with the current result set (i.e. the outer query)@@ -151,11 +151,10 @@   st <- get   let nameds = [n | Named n _ <- cs]       left = state2sql st-      right = SQL cs (Product [state2sql join_st]) [] [] [] Nothing+      right = sqlFrom cs (Product [state2sql join_st])       C on = check $ toTup nameds       outCols = [Some $ Col n | Named n _ <- cs] ++ allCols [left]-      sql = SQL outCols (Join jointype on left right) [] [] [] Nothing-  put $ st {sources = [sql]}+  put $ st {sources = [sqlFrom outCols (Join jointype on left right)]}   pure $ toTup nameds  -- | Group an aggregate query by a column.@@ -180,12 +179,10 @@ limit from to q = Query $ do   (lim_st, res) <- isolate q   st <- get-  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}+  let sql' = case sources lim_st of+        [sql] | isNothing (limits sql) -> sql+        ss                             -> sqlFrom (allCols ss) (Product ss)+  put $ st {sources = sql' {limits = Just (from, to)} : sources st}   -- TODO: replace with safe coercion   return $ unsafeCoerce res @@ -213,8 +210,17 @@ order :: Col s a -> Order -> Query s () order (C c) o = Query $ do   st <- get-  put $ case sources st of-    [SQL cs s ps gs os lim] ->-      st {sources = [SQL cs s ps gs ((o, Some c):os) lim]}-    ss ->-      st {sources = [SQL (allCols ss) (Product ss) [] [] [(o, Some c)] Nothing]}+  case sources st of+    [sql] -> put st {sources = [sql {ordering = (o, Some c) : ordering sql}]}+    ss    -> put st {sources = [sql {ordering = [(o,Some c)]}]}+      where sql = sqlFrom (allCols ss) (Product ss)++-- | Remove all duplicates from the result set.+distinct :: Query s a -> Query s a+distinct q = Query $ do+  (inner_st, res) <- isolate q+  st <- get+  case sources inner_st of+    [sql] -> put st {sources = [sql {SQL.distinct = True}]}+    ss    -> put st {sources = [sqlFrom (allCols ss) (Product ss)]}+  return res

@@ -7,19 +7,29 @@ import Database.Selda.Column import Database.Selda.Types (ColName, mkColName, addColSuffix) +type Scope = Int+type Ident = Int++-- | A name, consisting of a scope and an identifier.+data Name = Name Scope Ident++instance Show Name where+  show (Name 0 n) = concat [show n]+  show (Name s n) = concat [show s, "s_", show n]+ -- | An SQL query. newtype Query s a = Query {unQ :: State GenState a}   deriving (Functor, Applicative, Monad)  -- | Run a query computation from an initial state.-runQueryM :: Query s a -> (a, GenState)-runQueryM = flip runState initState . unQ+runQueryM :: Scope -> Query s a -> (a, GenState)+runQueryM scope = flip runState (initState scope) . unQ  -- | Run a query computation in isolation, but reusing the current name supply. isolate :: Query s a -> State GenState (GenState, a) isolate (Query q) = do   st <- get-  put $ initState {nameSupply = nameSupply st}+  put $ (initState (nameScope st)) {nameSupply = nameSupply st}   x <- q   st' <- get   put $ st {nameSupply = nameSupply st'}@@ -34,15 +44,17 @@   , staticRestricts :: ![Exp SQL Bool]   , groupCols       :: ![SomeCol SQL]   , nameSupply      :: !Int+  , nameScope       :: !Int   }  -- | Initial state: no subqueries, no restrictions.-initState :: GenState-initState = GenState+initState :: Int -> GenState+initState scope = GenState   { sources = []   , staticRestricts = []   , groupCols = []   , nameSupply = 0+  , nameScope  = scope   }  -- | Generate a unique name for the given column.@@ -59,11 +71,11 @@   return col  -- | Get a guaranteed unique identifier.-freshId :: State GenState Int+freshId :: State GenState Name freshId = do   st <- get   put $ st {nameSupply = succ $ nameSupply st}-  return (nameSupply st)+  return (Name (nameScope st) (nameSupply st))  -- | Get a guaranteed unique column name. freshName :: State GenState ColName

@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE TypeOperators, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-} -- | SQL AST and parameters for prepared statements. module Database.Selda.SQL where import Database.Selda.Exp@@ -28,6 +29,7 @@   , groups    :: ![SomeCol SQL]   , ordering  :: ![(Order, SomeCol SQL)]   , limits    :: !(Maybe (Int, Int))+  , distinct  :: !Bool   }  instance Names SqlSource where@@ -46,6 +48,19 @@     , allNamesIn restricts     , allNamesIn source     ]++-- | Build a plain SQL query with the given columns and source, with no filters,+--   ordering, etc.+sqlFrom :: [SomeCol SQL] -> SqlSource -> SQL+sqlFrom cs src = SQL+  { cols = cs+  , source = src+  , restricts = []+  , groups = []+  , ordering = []+  , limits = Nothing+  , distinct = False+  }  -- | The order in which to sort result rows. data Order = Asc | Desc

@@ -109,7 +109,7 @@  -- | Pretty-print an SQL AST. ppSql :: SQL -> PP Text-ppSql (SQL cs src r gs ord lim) = do+ppSql (SQL cs src r gs ord lim dist) = do   cs' <- mapM ppSomeCol cs   src' <- ppSrc src   r' <- ppRestricts r@@ -117,7 +117,7 @@   ord' <- ppOrder ord   lim' <- ppLimit lim   pure $ mconcat-    [ "SELECT ", result cs'+    [ "SELECT ", if dist then "DISTINCT " else "", result cs'     , src'     , r'     , gs'@@ -220,6 +220,11 @@   a' <- ppCol a   b' <- ppCol b   pure $ mconcat [f, "(", a', ", ", b', ")"]+ppCol (If a b c)     = do+  a' <- ppCol a+  b' <- ppCol b+  c' <- ppCol c+  pure $ mconcat ["CASE WHEN ", a', " THEN ", b', " ELSE ", c', " END"] ppCol (AggrEx f x)   = ppUnOp (Fun f) x ppCol (Cast t x)     = do   x' <- ppCol x

@@ -65,10 +65,10 @@ -- | Build the outermost query from the SQL generation state. --   Groups are ignored, as they are only used by 'aggregate'. state2sql :: GenState -> SQL-state2sql (GenState [sql] srs _ _) =+state2sql (GenState [sql] srs _ _ _) =   sql {restricts = restricts sql ++ srs}-state2sql (GenState ss srs _ _) =-  SQL (allCols ss) (Product ss) srs [] [] Nothing+state2sql (GenState ss srs _ _ _) =+  SQL (allCols ss) (Product ss) srs [] [] Nothing False  -- | Get all output columns from a list of SQL ASTs. allCols :: [SQL] -> [SomeCol SQL]