diff --git a/hasqlator-mysql.cabal b/hasqlator-mysql.cabal --- a/hasqlator-mysql.cabal +++ b/hasqlator-mysql.cabal @@ -1,5 +1,5 @@ Name: hasqlator-mysql -Version: 0.0.8 +Version: 0.0.9 Synopsis: composable SQL generation Category: Database Copyright: Kristof Bastiaensen (2020) @@ -43,7 +43,8 @@ time, template-haskell, aeson, - pretty-simple + pretty-simple, + optics-core >= 0.4 && < 0.5 hs-source-dirs: src Exposed-Modules: diff --git a/src/Database/MySQL/Hasqlator.hs b/src/Database/MySQL/Hasqlator.hs --- a/src/Database/MySQL/Hasqlator.hs +++ b/src/Database/MySQL/Hasqlator.hs @@ -44,16 +44,20 @@ localTimeSel, timeOfDaySel, diffTimeSel, daySel, byteStringSel, textSel, -- ** other selectors - values, values_, + rawValues, rawValues_, -- * Expressions subQuery, - arg, fun, op, (>.), (<.), (>=.), (<=.), (+.), (-.), (*.), (/.), (=.), (++.), - (/=.), (&&.), (||.), abs_, negate_, signum_, sum_, rawSql, substr, in_, + arg, fun, op, isNull, isNotNull, (>.), (<.), (>=.), (<=.), (+.), (-.), (*.), + (/.), (=.), (++.), (/=.), (&&.), (||.), abs_, negate_, signum_, sum_, + rawSql, substr, in_, false_, true_, notIn_, values, -- * Insertion - Insertor, insertValues, insertSelect, insertData, skipInsert, into, Getter, - lensInto, insertOne, ToSql, + Insertor, insertValues, insertUpdateValues, insertSelect, insertData, + skipInsert, into, exprInto, Getter, lensInto, insertOne, ToSql, + + -- * Updates + update, -- * Rendering Queries renderStmt, renderPreparedStmt, SQLError(..), QueryBuilder, @@ -238,38 +242,45 @@ mempty = pure mempty data Query a = Query (Selector a) QueryBody -data Command = Update QueryBuilder [(QueryBuilder, QueryBuilder)] QueryBody +data Command = Update [QueryBuilder] [(QueryBuilder, QueryBuilder)] QueryBody | InsertSelect QueryBuilder [QueryBuilder] [QueryBuilder] QueryBody - | forall a.InsertValues QueryBuilder (Insertor a) [a] + | forall a.InsertValues QueryBuilder (Insertor a) + (Maybe [(QueryBuilder, QueryBuilder)]) [a] | forall a.Delete (Query a) -- | An @`Insertor` a@ provides a mapping of parts of values of type -- @a@ to columns in the database. Insertors can be combined using `<>`. -data Insertor a = Insertor [Text] (a -> [MySQLValue]) +data Insertor a = Insertor [Text] (a -> [QueryBuilder]) data Join = Join JoinType [QueryBuilder] [QueryBuilder] data JoinType = InnerJoin | LeftJoin | RightJoin | OuterJoin +pairQuery :: (QueryBuilder, QueryBuilder) -> QueryBuilder +pairQuery (a, b) = a <> " = " <> b + instance ToQueryBuilder Command where - toQueryBuilder (Update table setting body) = - let pairQuery (a, b) = a <> " = " <> b - in unwords - [ "UPDATE", table - , "SET", commaSep $ map pairQuery setting - , toQueryBuilder body - ] - - toQueryBuilder (InsertValues (QueryBuilder table _ _) - (Insertor cols convert) values__) = - let builder, valuesB :: Builder - valuesB = commaSep $ - map (parentized . commaSep . map mysqlValueBuilder . convert) + toQueryBuilder (Update tables setting body) = + unwords + [ "UPDATE", commaSep tables + , "SET", commaSep $ map pairQuery setting + , toQueryBuilder body + ] + + toQueryBuilder (InsertValues _ _ _ []) = "SELECT 'nothing to insert'" + toQueryBuilder (InsertValues table (Insertor cols convert) updates values__) = + let valuesB = commaSep $ + map (parentized . commaSep . convert) values__ - builder = unwords [ "INSERT INTO", table - , parentized $ commaSep $ - map (Builder.byteString . Text.encodeUtf8) cols - , "VALUES", valuesB] - in QueryBuilder builder builder DList.empty + insertStmt = [ "INSERT INTO", table + , parentized $ commaSep $ + map rawSql cols + , "VALUES", valuesB] + in unwords $ insertStmt ++ + foldMap (\setting -> + [ "ON DUPLICATE KEY UPDATE" + , commaSep (map pairQuery setting)]) + updates + toQueryBuilder (InsertSelect table cols rows queryBody) = unwords [ "INSERT INTO", table @@ -435,6 +446,12 @@ substr :: QueryBuilder -> QueryBuilder -> QueryBuilder -> QueryBuilder substr field start end = fun "substr" [field, start, end] +infixr 3 &&., ||. +infix 4 <., >., >=., <=., =., /=. +infixr 5 ++. +infixl 6 +., -. +infixl 7 *., /. + (>.), (<.), (>=.), (<=.), (+.), (-.), (/.), (*.), (=.), (/=.), (++.), (&&.), (||.) :: QueryBuilder -> QueryBuilder -> QueryBuilder @@ -458,10 +475,26 @@ negate_ x = fun "-" [x] sum_ x = fun "sum" [x] +false_, true_ :: QueryBuilder +false_ = rawSql "false" +true_ = rawSql "true" +values :: QueryBuilder -> QueryBuilder +values x = fun "values" [x] + +isNull :: QueryBuilder -> QueryBuilder +isNull e = parentized $ e <> " IS NULL" + +isNotNull :: QueryBuilder -> QueryBuilder +isNotNull e = parentized $ e <> " IS NOT NULL" + +-- | insert an expression +exprInto :: (a -> QueryBuilder) -> Text -> Insertor a +exprInto f s = Insertor [s] (\t -> [f t]) + -- | insert a single value directly insertOne :: ToSql a => Text -> Insertor a -insertOne s = Insertor [s] (\t -> [toSqlValue t]) +insertOne s = arg `exprInto` s -- | insert a datastructure class InsertGeneric (fields :: *) (data_ :: *) where @@ -600,28 +633,45 @@ replaceSelect s (Query _ body) = Query s body insertValues :: QueryBuilder -> Insertor a -> [a] -> Command -insertValues = InsertValues +insertValues qb i = InsertValues qb i Nothing +insertUpdateValues :: QueryBuilder + -> Insertor a + -> [(QueryBuilder, QueryBuilder)] + -> [a] + -> Command +insertUpdateValues qb i u = InsertValues qb i (Just u) + insertSelect :: QueryBuilder -> [QueryBuilder] -> [QueryBuilder] -> QueryClauses -> Command insertSelect table toColumns fromColumns (QueryClauses clauses) = InsertSelect table toColumns fromColumns $ appEndo clauses emptyQueryBody +update :: [QueryBuilder] -> [(QueryBuilder, QueryBuilder)] -> QueryClauses + -> Command +update tables assignments (QueryClauses clauses) = + Update tables assignments $ appEndo clauses emptyQueryBody + -- | combinator for aliasing columns. as :: QueryBuilder -> QueryBuilder -> QueryBuilder as e1 e2 = e1 <> " AS " <> e2 in_ :: QueryBuilder -> [QueryBuilder] -> QueryBuilder +in_ _ [] = false_ in_ e l = e <> " IN " <> parentized (commaSep l) +notIn_ :: QueryBuilder -> [QueryBuilder] -> QueryBuilder +notIn_ _ [] = true_ +notIn_ e l = e <> " NOT IN " <> parentized (commaSep l) + -- | Read the columns directly as a `MySQLValue` type without conversion. -values :: [QueryBuilder] -> Selector [MySQLValue] -values cols = Selector (DList.fromList cols) $ +rawValues :: [QueryBuilder] -> Selector [MySQLValue] +rawValues cols = Selector (DList.fromList cols) $ state $ splitAt (length cols) -- | Ignore the content of the given columns -values_ :: [QueryBuilder] -> Selector () -values_ cols = () <$ values cols +rawValues_ :: [QueryBuilder] -> Selector () +rawValues_ cols = () <$ rawValues cols -- selector for any bounded integer type intFromSql :: forall a.(Show a, Bounded a, Integral a) diff --git a/src/Database/MySQL/Hasqlator/Typed.hs b/src/Database/MySQL/Hasqlator/Typed.hs --- a/src/Database/MySQL/Hasqlator/Typed.hs +++ b/src/Database/MySQL/Hasqlator/Typed.hs @@ -12,36 +12,39 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveFunctor #-} module Database.MySQL.Hasqlator.Typed ( -- * Database Types - Table(..), Field(..), Tbl(..), (@@), Nullable (..), JoinType (..), - + Table(..), Field(..), Alias(..), (@@), Nullable (..), JoinType (..), -- * Querying - Query, + Query, untypeQuery, executeQuery, -- * Selectors Selector, sel, selMaybe, -- * Expressions Expression, SomeExpression, someExpr, Operator, - arg, argMaybe, nullable, cast, unsafeCast, - op, fun1, fun2, fun3, (=.), (/=.), (>.), (<.), (>=.), (<=.), (&&.), (||.), - substr, true_, false_, - + arg, argMaybe, isNull, isNotNull, nullable, notNull, orNull, unlessNull, + cast, unsafeCast, op, fun1, fun2, fun3, (=.), (/=.), (>.), (<.), (>=.), + (<=.), (&&.), (||.), substr, true_, false_, in_, notIn_, + -- * Clauses from, fromSubQuery, innerJoin, leftJoin, joinSubQuery, leftJoinSubQuery, where_, groupBy_, having, orderBy, limit, limitOffset, -- * Insertion - Insertor, insertValues, insertSelect, insertData, skipInsert, into, - lensInto, insertOne, exprInto, Into, - + Insertor, insertValues, insertUpdateValues, insertSelect, insertData, + skipInsert, into, + lensInto, maybeLensInto, opticInto, maybeOpticInto, insertOne, exprInto, + Into, + + -- * Update + Updator(..), update, + -- * imported from Database.MySQL.Hasqlator - H.Getter, H.ToSql, H.FromSql, subQueryExpr, H.Command + H.Getter, H.ToSql, H.FromSql, subQueryExpr, H.executeCommand, H.Command ) where import Data.Text (Text) @@ -57,7 +60,6 @@ import qualified Data.Map.Strict as Map import Control.Monad.State import Control.Monad.Reader -import GHC.Exts (Constraint) import GHC.TypeLits as TL import Data.Functor.Contravariant import Control.Applicative @@ -65,36 +67,12 @@ import GHC.Generics hiding (from, Selector) import qualified Database.MySQL.Hasqlator as H import Data.Proxy +import qualified Database.MySQL.Base as MySQL +import Optics.Core hiding (lens) data Nullable = Nullable | NotNull data JoinType = LeftJoined | InnerJoined -type family CheckInsertable (fieldNullable :: Nullable) fieldType a - :: Constraint where - CheckInsertable 'Nullable a (Maybe a) = () - CheckInsertable 'Nullable a a = () - CheckInsertable 'NotNull a a = () - CheckInsertable n t ft = - TypeError ('TL.Text "Cannot insert value of type " ':<>: - 'ShowType t ':<>: - 'TL.Text " into " ':<>: - 'ShowType n ':<>: - 'TL.Text " field of type " ':<>: - 'ShowType ft) - -type Insertable nullable field a = - (CheckInsertable nullable field a, H.ToSql a) - --- | check if field can be used in nullable context -type family CheckExprNullable (expr :: Nullable) (context :: Nullable) - :: Constraint - where - CheckExprNullable 'Nullable 'Nullable = () - CheckExprNullable 'Nullable 'NotNull = - TypeError ('Text "A nullable expression can be only used in a nullable context") - -- a NotNull expressions can be used in both contexts - CheckExprNullable 'NotNull _ = () - -- | check if a field is nullable after being joined type family JoinNullable (leftJoined :: JoinType) (field :: Nullable) :: Nullable @@ -156,14 +134,14 @@ -- | An table alias that can be used inside the Query. The function -- inside the newtype can also be applied directly to create an -- expression from a field. -newtype Tbl table database (joinType :: JoinType) = - Tbl { getTableAlias :: - forall fieldNull exprNull a . - CheckExprNullable (JoinNullable joinType fieldNull) exprNull => +newtype Alias table database (joinType :: JoinType) = + Alias { getTableAlias :: + forall fieldNull a . Field table database fieldNull a -> - Expression exprNull a } + Expression (JoinNullable joinType fieldNull) a } -newtype Insertor (table :: Symbol) database a = Insertor (H.Insertor a) +newtype Insertor (table :: Symbol) database a = + Insertor (H.Insertor a) deriving (Monoid, Semigroup, Contravariant) data ClauseState = ClauseState @@ -179,12 +157,6 @@ newtype Query database a = Query (QueryInner a) deriving (Functor, Applicative, Monad) -instance H.ToQueryBuilder (Query database (H.Selector a)) where - toQueryBuilder (Query query) = - let (selector, clauseState) = runState query emptyClauseState - -- TODO: finalize query - in H.toQueryBuilder $ H.select selector $ clausesBuild clauseState - type Operator a b c = forall nullable . (Expression nullable a -> Expression nullable b -> @@ -192,17 +164,29 @@ infixl 9 @@ +untypeQuery :: Query database (Selector a) -> H.Query a +untypeQuery (Query query) = + let (selector, clauseState) = + runState (do (Selector sel) <- query; sel) emptyClauseState + in H.select selector $ clausesBuild clauseState + +executeQuery :: MySQL.MySQLConn -> Query database (Selector a) -> IO [a] +executeQuery conn query = H.executeQuery conn (untypeQuery query) + -- | Create an expression from an aliased table and a field. -(@@) :: CheckExprNullable (JoinNullable joinType fieldNull) exprNull - => Tbl table database (joinType :: JoinType) +(@@) :: Alias table database (joinType :: JoinType) -> Field table database fieldNull a - -> Expression exprNull a + -> Expression (JoinNullable joinType fieldNull) a (@@) = getTableAlias -mkTableAlias :: Text -> Tbl table database leftJoined -mkTableAlias tableName = Tbl $ \(Field _ fieldName) -> - Expression $ pure $ H.rawSql $ tableName <> "." <> fieldName +mkTableAlias :: Text -> Alias table database leftJoined +mkTableAlias tableName = Alias $ \field -> + Expression $ pure $ H.rawSql $ tableName <> "." <> fieldName field +emptyAlias :: Alias table database leftJoined +emptyAlias = Alias $ \field -> + Expression $ pure $ H.rawSql $ fieldName field + data QueryOrdering = Asc SomeExpression | Desc SomeExpression -- | make a selector from a column @@ -254,6 +238,9 @@ -> Expression nullable Text substr = fun3 H.substr +infixr 3 &&., ||. +infix 4 <., >., >=., <=., =., /=. + (=.), (/=.), (>.), (<.), (>=.), (<=.) :: H.ToSql a => Operator a a Bool (=.) = op (H.=.) (/=.) = op (H./=.) @@ -266,14 +253,48 @@ (||.) = op (H.||.) (&&.) = op (H.&&.) +isNull :: Expression nullable a -> Expression 'NotNull Bool +isNull (Expression e) = Expression $ H.isNull <$> e + +isNotNull :: Expression 'Nullable a -> Expression 'NotNull Bool +isNotNull (Expression e) = Expression $ H.isNotNull <$> e + true_, false_ :: Expression nullable Bool -true_ = Expression $ pure $ H.rawSql "true" -false_ = Expression $ pure $ H.rawSql "false" +true_ = Expression $ pure $ H.false_ +false_ = Expression $ pure $ H.true_ +in_ :: Expression nullable a -> [Expression nullable a] + -> Expression nullable Bool +in_ e es = Expression $ + liftA2 H.in_ (runExpression e) (traverse runExpression es) + +notIn_ :: Expression nullable a -> [Expression nullable a] + -> Expression nullable Bool +notIn_ e es = Expression $ + liftA2 H.notIn_ (runExpression e) (traverse runExpression es) + -- | make expression nullable nullable :: Expression nullable a -> Expression 'Nullable a nullable = coerce +-- | ensure expression is not null +notNull :: Expression 'NotNull a -> Expression 'NotNull a +notNull = id + +-- | Return a true expression if the given expression is NULL (using +-- the IS NULL sql test), or pass the expression (coerced to +-- 'NotNull) to the given test. +orNull :: Expression nullable a + -> (Expression 'NotNull a -> Expression 'NotNull Bool) + -> Expression 'NotNull Bool +orNull e f = isNull e ||. f (coerce e) + +-- | Perform test if given expression is not NULL +unlessNull :: Expression nullable a + -> (Expression 'NotNull a -> Expression 'NotNull Bool) + -> Expression 'NotNull Bool +unlessNull e f = f (coerce e) + class Castable a where -- | Safe cast. This uses the SQL CAST function to convert safely -- from one type to another. @@ -349,14 +370,19 @@ unsafeCast :: Expression nullable a -> Expression nullable b unsafeCast = coerce -fieldText :: Field table database nullable a -> Text -fieldText (Field table fieldName) = table <> "." <> fieldName +fieldName :: Field table database nullable a -> Text +fieldName (Field _ fn) = fn -insertOne :: Insertable fieldNull fieldType a - => Field table database fieldNull fieldType +insertOne :: H.ToSql a + => Field table database 'NotNull fieldType -> Insertor table database a -insertOne = Insertor . H.insertOne. fieldText +insertOne = Insertor . H.insertOne . fieldName +insertOneMaybe :: H.ToSql a + => Field table database 'Nullable fieldType + -> Insertor table database (Maybe a) +insertOneMaybe = Insertor . H.insertOne . fieldName + genFst :: (a :*: b) () -> a () genFst (a :*: _) = a @@ -377,10 +403,15 @@ InsertGeneric tbl db (M1 m1 m2 a ()) (M1 m3 m4 b ()) where insertDataGeneric = contramap unM1 . insertDataGeneric . unM1 -instance Insertable fieldNull a b => - InsertGeneric tbl db (K1 r (Field tbl db fieldNull a) ()) (K1 r b ()) where - insertDataGeneric = contramap unK1 . insertOne . unK1 +instance H.ToSql b => + InsertGeneric tbl db (K1 r (Field tbl db 'NotNull a) ()) (K1 r b ()) + where insertDataGeneric = contramap unK1 . insertOne . unK1 +instance H.ToSql b => + InsertGeneric tbl db (K1 r (Field tbl db 'Nullable a) ()) + (K1 r (Maybe b) ()) + where insertDataGeneric = contramap unK1 . insertOneMaybe . unK1 + instance InsertGeneric tbl db (K1 r (Insertor tbl db a) ()) (K1 r a ()) where insertDataGeneric = contramap unK1 . unK1 @@ -398,25 +429,76 @@ personInsertor = insertData (name, age) -} -into :: Insertable fieldNull fieldType b - => (a -> b) - -> Field table database fieldNull fieldType - -> Insertor table database a -into f = Insertor . H.into f . fieldText +-- (a -> Expression) -> QueryInner (a -> QueryBuilder) +-- (a -> QueryInner QueryBuilder) +-- a -> queryState -> (queryState, result) +-- queryState -> a -> (query, result) +-- (a -> Expression) -> queryState -> a -> QueryBuilder +-- -lensInto :: Insertable fieldNull fieldType b +into :: (a -> Expression nullable b) + -> Field table database nullable fieldType + -> Insertor table database a +into e f = + Insertor $ + H.exprInto (\x -> evalState (runExpression $ e x) emptyClauseState) + (fieldName f) + +lensInto :: H.ToSql b => H.Getter a b - -> Field table database fieldNull fieldType + -> Field table database 'NotNull fieldType -> Insertor table database a -lensInto lens a = Insertor $ H.lensInto lens $ fieldText a +lensInto lens a = Insertor $ H.lensInto lens $ fieldName a +maybeLensInto :: H.ToSql b + => H.Getter a (Maybe b) + -> Field table database 'Nullable fieldType + -> Insertor table database a +maybeLensInto lens a = Insertor $ H.lensInto lens $ fieldName a + +opticInto :: (H.ToSql b , Is k A_Getter ) + => Optic' k is a b + -> Field table database 'NotNull fieldType + -> Insertor table database a +opticInto getter field = (arg . view getter) `into` field + +maybeOpticInto :: (H.ToSql b , Is k A_Getter) + => Optic' k is a (Maybe b) + -> Field table database 'Nullable fieldType + -> Insertor table database a +maybeOpticInto getter field = (argMaybe . view getter) `into` field + +tableSql :: Table table database -> H.QueryBuilder +tableSql (Table mbSchema tableName) = + H.rawSql $ foldMap (<> ".") mbSchema <> tableName + insertValues :: Table table database -> Insertor table database a -> [a] -> H.Command -insertValues (Table _schema tableName) (Insertor i) = - H.insertValues (H.rawSql tableName) i +insertValues table (Insertor i) = + H.insertValues (tableSql table) i +valuesAlias :: Alias table database leftJoined +valuesAlias = Alias $ \field -> + Expression $ pure $ H.values $ H.rawSql $ fieldName field + +insertUpdateValues :: Table table database + -> Insertor table database a + -> (Alias table database 'InnerJoined -> + Alias table database 'InnerJoined -> + [Updator table database]) + -> [a] + -> H.Command +insertUpdateValues table (Insertor i) mkUpdators = + H.insertUpdateValues (tableSql table) i updators + where updators = flip evalState emptyClauseState $ + traverse runUpdator $ mkUpdators emptyAlias valuesAlias + runUpdator :: Updator table database + -> QueryInner (H.QueryBuilder, H.QueryBuilder) + runUpdator (field := Expression expr) = do + (H.rawSql $ fieldName field, ) <$> expr + newAlias :: Text -> QueryInner Text newAlias prefix = do clsState <- get @@ -429,38 +511,35 @@ clsState { clausesBuild = clausesBuild clsState <> c } from :: Table table database - -> Query database (Tbl table database 'InnerJoined) -from (Table schema tableName) = Query $ + -> Query database (Alias table database 'InnerJoined) +from table@(Table _ tableName) = Query $ do alias <- newAlias (Text.take 1 tableName) - addClauses $ H.from $ - H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as` H.rawSql alias + addClauses $ H.from $ tableSql table `H.as` H.rawSql alias pure $ mkTableAlias alias innerJoin :: Table table database - -> (Tbl table database 'InnerJoined -> + -> (Alias table database 'InnerJoined -> Expression nullable Bool) - -> Query database (Tbl table database 'InnerJoined) -innerJoin (Table schema tableName) joinCondition = Query $ do - alias <- newAlias (Text.take 1 tableName) + -> Query database (Alias table database 'InnerJoined) +innerJoin table@(Table _ tableName) joinCondition = Query $ do + alias <- newAlias $ Text.take 1 tableName let tblAlias = mkTableAlias alias exprBuilder <- runExpression $ joinCondition tblAlias addClauses $ - H.innerJoin [H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as` - H.rawSql alias] + H.innerJoin [tableSql table `H.as` H.rawSql alias] [exprBuilder] pure tblAlias leftJoin :: Table table database - -> (Tbl table database 'LeftJoined -> + -> (Alias table database 'LeftJoined -> Expression nullable Bool) - -> Query database (Tbl table database 'LeftJoined) -leftJoin (Table schema tableName) joinCondition = Query $ do - alias <- newAlias (Text.take 1 tableName) + -> Query database (Alias table database 'LeftJoined) +leftJoin table@(Table _ tableName) joinCondition = Query $ do + alias <- newAlias $ Text.take 1 tableName let tblAlias = mkTableAlias alias exprBuilder <- runExpression $ joinCondition tblAlias addClauses $ - H.leftJoin [H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as` - H.rawSql alias] + H.leftJoin [tableSql table `H.as` H.rawSql alias] [exprBuilder] pure tblAlias @@ -517,7 +596,7 @@ subQueryExpr sq = Expression $ do (subQueryBody, Expression subQuerySelect) <- runAsSubQuery sq selectBuilder <- subQuerySelect - pure $ H.subQuery $ H.select (H.values_ [selectBuilder]) subQueryBody + pure $ H.subQuery $ H.select (H.rawValues_ [selectBuilder]) subQueryBody -- subJoinBody :: (Generic inExprs, @@ -539,7 +618,7 @@ from' sqExprs outExpr = to' outExprRep selectBuilder <- DList.toList <$> traverse runSomeExpression selectExprs - pure ( H.subQuery $ H.select (H.values_ selectBuilder) subQueryBody + pure ( H.subQuery $ H.select (H.rawValues_ selectBuilder) subQueryBody , outExpr) joinSubQuery :: (Generic inExprs, @@ -576,7 +655,7 @@ addClauses $ H.from subQueryBody pure outExpr -where_ :: Expression nullable Bool -> Query database () +where_ :: Expression 'NotNull Bool -> Query database () where_ expr = Query $ do exprBuilder <- runExpression expr addClauses $ H.where_ [exprBuilder] @@ -607,23 +686,46 @@ newtype Into database (table :: Symbol) = Into { runInto :: QueryInner (Text, H.QueryBuilder) } -exprInto :: CheckExprNullable exprNullable fieldNullable - => Expression exprNullable a -> - Field table database fieldNullable a -> +exprInto :: Expression nullable a -> + Field table database nullable a -> Into database table -exprInto expr (Field _ fieldName) = - Into $ (fieldName,) <$> runExpression expr +exprInto expr field = + Into $ (fieldName field,) <$> runExpression expr insertSelect :: Table table database -> Query database [Into database table] -> H.Command -insertSelect (Table schema tbl) (Query query) = - H.insertSelect (H.rawSql (maybe mempty (<> ".") schema <> tbl)) +insertSelect table (Query query) = + H.insertSelect (tableSql table) (map (H.rawSql . fst) intos) (map snd intos) clauses where (intos, ClauseState clauses _) = runState (query >>= traverse runInto) emptyClauseState +infix 0 := + +data Updator table database = + forall nullable a. + Field table database nullable a := Expression nullable a + +update :: Table table database + -> (Alias table database 'InnerJoined -> + Query database [Updator table database]) + -> H.Command +update table query = + H.update [tableSql table] + updators clauses + where Query runQuery = query emptyAlias + (updators, ClauseState clauses _) = + runState (runQuery >>= traverse runUpdator) emptyClauseState + runUpdator :: Updator table database + -> QueryInner (H.QueryBuilder, H.QueryBuilder) + runUpdator (field := Expression expr) = do + (H.rawSql $ fieldName field, ) <$> expr + + + + {- TODO: diff --git a/src/Database/MySQL/Hasqlator/Typed/Schema.hs b/src/Database/MySQL/Hasqlator/Typed/Schema.hs --- a/src/Database/MySQL/Hasqlator/Typed/Schema.hs +++ b/src/Database/MySQL/Hasqlator/Typed/Schema.hs @@ -428,10 +428,14 @@ insertorName = mkName $ insertorNameModifier props ti insertorTypeName = mkName $ insertorTypeModifier props ti insertorField :: ColumnInfo -> Q Exp - insertorField ci = [e| $(sigE - (varE $ mkName $ insertorFieldModifier props ci) - [t| $(conT insertorTypeName) -> - $(columnTHType False ci) |]) + insertorField ci = [e| ($(if columnNullable ci + then [e| T.argMaybe |] + else [e| T.arg |]) + . + $(sigE + (varE $ mkName $ insertorFieldModifier props ci) + [t| $(conT insertorTypeName) -> + $(columnTHType False ci) |])) `T.into` $(varE $ mkName $ fieldsQualifier props <> @@ -441,7 +445,7 @@ makeSelector props dbName ti = sequence [ sigD selectorName - [t| T.Tbl + [t| T.Alias $(litT $ strTyLit $ getTableName props ti) $(conT dbName) 'T.InnerJoined @@ -451,7 +455,7 @@ |] , funD selectorName [ do alias <- newName "alias" - clause [conP 'T.Tbl [varP alias]] + clause [conP 'T.Alias [varP alias]] (normalB $ tableSelector alias) [] ]]