hasqly-mysql (empty) → 0.0.1
raw patch · 3 files changed
+833/−0 lines, 3 filesdep +basedep +binarydep +bytestring
Dependencies added: base, binary, bytestring, dlist, mtl, mysql-haskell, scientific, text, time
Files
- LICENSE +27/−0
- hasqly-mysql.cabal +32/−0
- src/Database/Hasqly.hs +774/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2019, Kristof Bastiaensen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the {organization} nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hasqly-mysql.cabal view
@@ -0,0 +1,32 @@+Name: hasqly-mysql+Version: 0.0.1+Synopsis: composable SQL generation+Category: Database+Copyright: Kristof Bastiaensen (2020)+Stability: Unstable+License: BSD3+License-file: LICENSE+Author: Kristof Bastiaensen+Maintainer: Kristof Bastiaensen+Bug-Reports: https://github.com/kuribas/hasqly-mysql/issues+Build-type: Simple+Cabal-version: >=1.10+Description: A mid level applicative SQL generation library+ .+ Haskqly intends to be a mid-level SQL generation library. It doesn't use advanced type extensions+ to encode the schema in the types., but provides a light applicative layer to easy the conversion+ between haskell and SQL. It is inspired by the clojures honeysql library.+ +source-repository head+ type: git+ location: https://github.com/kuribas/hasqly-mysql++Library+ Ghc-options: -Wall+ default-language: Haskell2010+ Build-depends: base >= 3 && < 5, mtl >= 2.1.3, mysql-haskell, text, bytestring, time, dlist, scientific, binary, dlist+ hs-source-dirs:+ src + Exposed-Modules:+ Database.Hasqly+
+ src/Database/Hasqly.hs view
@@ -0,0 +1,774 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Database.Hasqly+Description : SQL generation+Copyright : (c) Kristof Bastiaensen, 2020+License : BSD-3+Maintainer : kristof@resonata.be+Stability : unstable+Portability : ghc+++-}++module Database.Hasqly+ ( -- * Querying+ Query, Command, select, mergeSelect, replaceSelect,++ -- * Query Clauses+ QueryClauses, from, innerJoin, leftJoin, rightJoin, outerJoin, emptyJoins,+ where_, emptyWhere, groupBy_, having, emptyHaving, orderBy, limit, limitOffset,++ -- * Selectors+ Selector, as,++ -- ** polymorphic selector+ col,+ -- ** specialised selectors+ -- | The following are specialised versions of `col`. Using these+ -- may make refactoring easier, for example accidently swapping+ -- @`col` "age"@ and @`col` "name"@ would not give a type error,+ -- while @intCol "age"@ and @textCol "name"@ most likely would.+ intCol, integerCol, doubleCol, floatCol, scientificCol, + localTimeCol, timeOfDayCol, diffTimeCol, dayCol, byteStringCol,+ textCol,+ -- ** other selectors+ values, values_,++ -- * Expressions+ subQuery,+ arg, fun, op, (.>), (.+), (.-),++ -- * Insertion+ Insertor, insertValues, insertSelect, into, lensInto,+ insert1, insert2, insert3, insert4, insert5,+ insert6, insert7, insert8, insert9, insert10,+ ToSql,+ + -- * Rendering Queries+ renderStmt, renderPreparedStmt, SQLError(..), QueryBuilder, ToQueryBuilder, FromSql+ )++where++import Database.MySQL.Base hiding (Query, Command)+import Prelude hiding (unwords)+import Control.Monad.State+import Control.Applicative+import Control.Monad.Except+import Data.Monoid hiding ((<>))+import Data.String hiding (unwords)+import Data.List hiding (unwords)+import qualified Data.DList as DList+ +import Data.DList (DList)+import Data.Scientific+import Data.Word+import Data.Int+import Data.Time+import qualified Data.ByteString as StrictBS+import qualified Data.ByteString.Lazy as LazyBS+import Data.ByteString.Lazy.Builder (Builder)+import qualified Data.ByteString.Lazy.Builder as Builder+import qualified Data.Text.Encoding as Text+import Data.Text (Text)+import Data.Binary.Put++class FromSql a where+ fromSql :: MySQLValue -> Either SQLError a++class ToSql a where+ toSqlValue :: a -> MySQLValue++instance FromSql a => IsString (Selector a) where+ fromString = col . fromString++class ToQueryBuilder a where+ toQueryBuilder :: a -> QueryBuilder++renderStmt :: ToQueryBuilder a => a -> LazyBS.ByteString+renderStmt a = Builder.toLazyByteString stmt+ where+ QueryBuilder stmt _ _ = toQueryBuilder a++renderPreparedStmt :: ToQueryBuilder a => a -> (LazyBS.ByteString, [MySQLValue])+renderPreparedStmt a = (Builder.toLazyByteString pstmt, DList.toList args)+ where+ QueryBuilder _ pstmt args = toQueryBuilder a++selectOne :: (MySQLValue -> Either SQLError a) -> QueryBuilder -> Selector a+selectOne f fieldName =+ Selector (DList.singleton fieldName) $ do+ results <- get+ case results of+ [] -> throwError ResultSetCountError+ (r1:rest) -> do+ put rest+ lift $ f r1++-- | The polymorphic selector. The return type is determined by type+-- inference.+col :: FromSql a => QueryBuilder -> Selector a+col fieldName = selectOne fromSql fieldName++-- | an integer field (TINYINT.. BIGINT). Any bounded haskell integer+-- type can be used here , for example `Int`, `Int32`, `Word32`. An+-- `Overflow` ur `Underflow` error will be raised if the value doesn't+-- fit the type.+intCol :: (Show a, Bounded a, Integral a) => QueryBuilder -> Selector a+intCol e = selectOne intFromSql e++-- | Un unbounded integer field, either a bounded integer (TINYINT,+-- etc...) or DECIMAL in the database. Will throw a type error if the+-- stored value is actually fractional.+--+-- /WARNING/: this function could potentially create huge integers with DECIMAL,+-- if the exponent is large, even fillup the space and crash your+-- program! Only use this on trusted inputs, or use Scientific+-- instead.+integerCol :: QueryBuilder -> Selector Integer+integerCol = col++-- | a DOUBLE field.+doubleCol :: QueryBuilder -> Selector Double+doubleCol = col++-- | a FLOAT field.+floatCol :: QueryBuilder -> Selector Float+floatCol = col++-- | A DECIMAL or NUMERIC field.+scientificCol :: QueryBuilder -> Selector Scientific+scientificCol = col++-- | a DATETIME or a TIMESTAMP field.+localTimeCol :: QueryBuilder -> Selector LocalTime+localTimeCol = col++-- | A TIME field taken as a specific time.+timeOfDayCol :: QueryBuilder -> Selector TimeOfDay+timeOfDayCol = col++-- | a TIME field taken as a time duration.+diffTimeCol :: QueryBuilder -> Selector DiffTime+diffTimeCol = col++-- | A DATE field.+dayCol :: QueryBuilder -> Selector Day+dayCol = col++-- | A binary BLOB field.+byteStringCol :: QueryBuilder -> Selector StrictBS.ByteString+byteStringCol = col++-- | a TEXT field.+textCol :: QueryBuilder -> Selector Text+textCol = col++data SQLError = SQLError String+ | ResultSetCountError+ | TypeError MySQLValue String+ | Underflow+ | Overflow++-- | Selectors contain the target fields or expressions in a SQL+-- SELECT statement, and perform the conversion to haskell. Selectors+-- are instances of `Applicative`, so they can return the desired+-- haskell type.+data Selector a = Selector (DList QueryBuilder)+ (StateT [MySQLValue] (Either SQLError) a)+ + +instance Functor Selector where+ fmap f (Selector cols cast) = Selector cols (fmap f cast)++instance Applicative Selector where+ Selector cols1 cast1 <*> Selector cols2 cast2 =+ Selector (cols1 <> cols2) (cast1 <*> cast2)+ pure x = Selector DList.empty (pure x)++instance Semigroup a => Semigroup (Selector a) where+ (<>) = liftA2 (<>)+ +instance Monoid a => Monoid (Selector a) where+ mempty = pure mempty++data Query a = Query (Selector a) QueryBody+data Command = Update QueryBuilder [(QueryBuilder, QueryBuilder)] QueryBody+ | InsertSelect QueryBuilder [QueryBuilder] [QueryBuilder] QueryBody+ | forall a.InsertValues QueryBuilder (Insertor a) [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 Join = Join JoinType [QueryBuilder] [QueryBuilder]+data JoinType = InnerJoin | LeftJoin | RightJoin | OuterJoin++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)+ values__+ builder = unwords [ "INSERT INTO", table+ , parentized $ commaSep $+ map (Builder.byteString . Text.encodeUtf8) cols+ , "VALUES", valuesB]+ in QueryBuilder builder builder (DList.empty)+ toQueryBuilder (InsertSelect table cols rows queryBody) =+ unwords $+ [ "INSERT INTO", table+ , parentized $ commaSep cols+ , "SELECT", parentized $ commaSep rows+ , toQueryBuilder queryBody+ ]+ toQueryBuilder (Delete query__) =+ "DELETE " <> toQueryBuilder query__++instance ToQueryBuilder QueryBody where+ toQueryBuilder body =+ unwords $ + fromB (_from body) <>+ (joinB <$> _joins body) <>+ renderPredicates "WHERE" (_where_ body) <>+ (groupByB $ _groupBy body) <>+ renderPredicates "HAVING" (_having body) <>+ orderByB (_orderBy body) <>+ limitB (_limit body)+ where+ fromB Nothing = []+ fromB (Just table) = ["FROM", table]++ joinB (Join _ [] _) = error "list of join tables cannot be empty"+ joinB (Join joinType tables joinConditions) =+ unwords $ [toQueryBuilder joinType, renderList tables] +++ renderPredicates "ON" joinConditions++ groupByB [] = []+ groupByB e = ["GROUP BY", commaSep e]++ orderByB [] = []+ orderByB e = ["ORDER BY", commaSep $ map toQueryBuilder e]++ limitB Nothing = []+ limitB (Just (count, Nothing)) = ["LIMIT", fromString (show count)]+ limitB (Just (count, Just offset)) =+ [ "LIMIT" , fromString (show count)+ , "OFFSET", fromString (show offset) ]++instance ToQueryBuilder (Query a) where+ toQueryBuilder (Query _ body) = toQueryBuilder body+ +instance ToQueryBuilder JoinType where+ toQueryBuilder InnerJoin = "INNER JOIN"+ toQueryBuilder LeftJoin = "LEFT JOIN"+ toQueryBuilder RightJoin = "RIGHT JOIN"+ toQueryBuilder OuterJoin = "OUTER JOIN"++data QueryBody = QueryBody+ { _from :: Maybe QueryBuilder+ , _joins :: [Join]+ , _where_ :: [QueryBuilder]+ , _groupBy :: [QueryBuilder]+ , _having :: [QueryBuilder]+ , _orderBy :: [QueryOrdering]+ , _limit :: Maybe (Int, Maybe Int)+ }++data QueryOrdering = + Asc QueryBuilder | Desc QueryBuilder++instance ToQueryBuilder QueryOrdering where+ toQueryBuilder (Asc b) = b <> " ASC"+ toQueryBuilder (Desc b) = b <> " DESC"++data QueryBuilder = QueryBuilder Builder Builder (DList MySQLValue)++instance IsString QueryBuilder where+ fromString s = QueryBuilder b b DList.empty+ where b = Builder.string8 s++instance Semigroup QueryBuilder where+ QueryBuilder stmt1 prepStmt1 vals1 <> QueryBuilder stmt2 prepStmt2 vals2 =+ QueryBuilder (stmt1 <> stmt2) (prepStmt1 <> prepStmt2) (vals1 <> vals2)++instance Monoid QueryBuilder where+ mempty = QueryBuilder mempty mempty mempty++newtype QueryClauses = QueryClauses (Endo QueryBody)+ deriving (Semigroup, Monoid)++instance Semigroup (Insertor a) where+ Insertor fields1 conv1 <> Insertor fields2 conv2 =+ Insertor (fields1 <> fields2) (conv1 <> conv2)++instance Monoid (Insertor a) where+ mempty = Insertor mempty mempty++class HasQueryClauses a where+ mergeClauses :: a -> QueryClauses -> a++instance HasQueryClauses (Query a) where+ mergeClauses (Query selector body) (QueryClauses clauses) =+ Query selector (clauses `appEndo` body)++instance HasQueryClauses Command where+ mergeClauses (Update table setting body) (QueryClauses clauses) =+ Update table setting (clauses `appEndo` body)+ mergeClauses (InsertSelect table toColumns fromColumns queryBody)+ (QueryClauses clauses) =+ InsertSelect table toColumns fromColumns (appEndo clauses queryBody)+ mergeClauses command__@(InsertValues _ _ _) _ =+ command__+ mergeClauses (Delete query__) clauses =+ Delete $ mergeClauses query__ clauses+ +fromText :: Text -> QueryBuilder+fromText s = QueryBuilder b b DList.empty+ where b = Builder.byteString $ Text.encodeUtf8 s++sepBy :: Monoid a => a -> [a] -> a+sepBy sep builder = mconcat $ intersperse sep builder+{-# INLINE sepBy #-}++commaSep :: (IsString a, Monoid a) => [a] -> a+commaSep = sepBy ", "+{-# INLINE commaSep #-}++unwords :: (IsString a, Monoid a) => [a] -> a+unwords = sepBy " "+{-# INLINE unwords #-}++parentized :: (IsString a, Monoid a) => a -> a+parentized expr = "(" <> expr <> ")"+{-# INLINE parentized #-}++renderList :: [QueryBuilder] -> QueryBuilder+renderList [] = ""+renderList [e] = e+renderList es = parentized $ commaSep es++renderPredicates :: QueryBuilder -> [QueryBuilder] -> [QueryBuilder]+renderPredicates _ [] = []+renderPredicates keyword [e] = [keyword, e]+renderPredicates keyword es =+ keyword : intersperse "AND" (map parentized $ reverse es)++mysqlValueBuilder :: MySQLValue -> Builder+mysqlValueBuilder = Builder.lazyByteString . runPut . putTextField ++arg :: ToSql a => a -> QueryBuilder+arg a = QueryBuilder + (mysqlValueBuilder $ toSqlValue a)+ (Builder.lazyByteString "?")+ (DList.singleton $ toSqlValue a)++fun :: Text -> [QueryBuilder] -> QueryBuilder+fun name exprs = fromText name <> parentized (commaSep exprs)++op :: Text -> QueryBuilder -> QueryBuilder -> QueryBuilder+op name e1 e2 = e1 <> " " <> fromText name <> " " <> e2++(.>), (.+), (.-) :: QueryBuilder -> QueryBuilder -> QueryBuilder+(.>) = op ">"+(.+) = op "+"+(.-) = op "-"++-- | insert a single value directly+insert1 :: ToSql a => Text -> Insertor a+insert1 s = Insertor [s] (\t -> [toSqlValue t])++-- | insert the values of a tuple+insert2 :: (ToSql a1, ToSql a2) => Text -> Text -> Insertor (a1, a2)+insert2 s1 s2 = Insertor [s1, s2] $+ \(t1, t2) -> [toSqlValue t1, toSqlValue t2]++insert3 :: (ToSql a1, ToSql a2, ToSql a3)+ => Text -> Text -> Text -> Insertor (a1, a2, a3)+insert3 s1 s2 s3 = Insertor [s1, s2, s3] $+ \(t1, t2, t3) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3]++insert4 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4)+ => Text -> Text -> Text -> Text -> Insertor (a1, a2, a3, a4)+insert4 s1 s2 s3 s4 = Insertor [s1, s2, s3, s4] $+ \(t1, t2, t3, t4) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3,+ toSqlValue t4]+++insert5 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5)+ => Text -> Text -> Text -> Text -> Text+ -> Insertor (a1, a2, a3, a4, a5)+insert5 s1 s2 s3 s4 s5 = Insertor [s1, s2, s3, s4, s5] $+ \(t1, t2, t3, t4, t5) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3,+ toSqlValue t4, toSqlValue t5]++insert6 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6)+ => Text -> Text -> Text -> Text -> Text -> Text+ -> Insertor (a1, a2, a3, a4, a5, a6)+insert6 s1 s2 s3 s4 s5 s6 = Insertor [s1, s2, s3, s4, s5, s6] $+ \(t1, t2, t3, t4, t5, t6) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3,+ toSqlValue t4, toSqlValue t5, toSqlValue t6]++insert7 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6,+ ToSql a7)+ => Text -> Text -> Text -> Text -> Text -> Text -> Text+ -> Insertor (a1, a2, a3, a4, a5, a6, a7)+insert7 s1 s2 s3 s4 s5 s6 s7 =+ Insertor [s1, s2, s3, s4, s5, s6, s7] $+ \(t1, t2, t3, t4, t5, t6, t7) ->+ [toSqlValue t1, toSqlValue t2, toSqlValue t3,+ toSqlValue t4, toSqlValue t5, toSqlValue t6,+ toSqlValue t7]++insert8 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6,+ ToSql a7, ToSql a8)+ => Text -> Text -> Text -> Text -> Text -> Text -> Text+ -> Text+ -> Insertor (a1, a2, a3, a4, a5, a6, a7, a8)+insert8 s1 s2 s3 s4 s5 s6 s7 s8 =+ Insertor [s1, s2, s3, s4, s5, s6, s7, s8] $+ \(t1, t2, t3, t4, t5, t6, t7, t8) ->+ [toSqlValue t1, toSqlValue t2, toSqlValue t3,+ toSqlValue t4, toSqlValue t5, toSqlValue t6,+ toSqlValue t7, toSqlValue t8]++insert9 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6,+ ToSql a7, ToSql a8, ToSql a9)+ => Text -> Text -> Text -> Text -> Text -> Text -> Text+ -> Text -> Text+ -> Insertor (a1, a2, a3, a4, a5, a6, a7, a8, a9)+insert9 s1 s2 s3 s4 s5 s6 s7 s8 s9 =+ Insertor [s1, s2, s3, s4, s5, s6, s7, s8, s9] $+ \(t1, t2, t3, t4, t5, t6, t7, t8, t9) ->+ [toSqlValue t1, toSqlValue t2, toSqlValue t3,+ toSqlValue t4, toSqlValue t5, toSqlValue t6,+ toSqlValue t7, toSqlValue t8, toSqlValue t9]+ +insert10 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6,+ ToSql a7, ToSql a8, ToSql a9, ToSql a10)+ => Text -> Text -> Text -> Text -> Text -> Text+ -> Text -> Text -> Text -> Text+ -> Insertor (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)+insert10 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 =+ Insertor [s1, s2, s3, s4, s5, s6, s7, s8, s9, s10] $+ \(t1, t2, t3, t4, t5, t6, t7, t8, t9, t10) ->+ [toSqlValue t1, toSqlValue t2, toSqlValue t3,+ toSqlValue t4, toSqlValue t5, toSqlValue t6,+ toSqlValue t7, toSqlValue t8, toSqlValue t9,+ toSqlValue t10]++-- | `into` uses the given extractor function to map the part to a+-- field. For example:+--+-- > insertValues "Person" (fst `into` "name" <> snd `into` "age")+-- > [("Bart Simpson", 10), ("Lisa Simpson", 8)]+into :: ToSql b => (a -> b) -> Text -> Insertor a+into toVal theField = Insertor [theField] ((:[]) . toSqlValue . toVal)++-- | `lensInto` uses a lens to map the part to a field. For example:+--+-- > insertValues "Person" (_1 `lensInto` "name" <> _2 `lensInto` "age")+-- > [("Bart Simpson", 10), ("Lisa Simpson", 8)]++lensInto :: ToSql b => ((b -> Const b b) -> (a -> Const b a)) -> Text+ -> Insertor a+lensInto lens theField = into (getConst . lens Const) theField++subQuery :: ToQueryBuilder a => a -> QueryBuilder+subQuery = parentized . toQueryBuilder+ +from :: QueryBuilder -> QueryClauses+from table = QueryClauses $ Endo $ \qc -> qc {_from = Just table}++joinClause :: JoinType -> [QueryBuilder] -> [QueryBuilder] -> QueryClauses+joinClause tp tables conditions = QueryClauses $ Endo $ \qc ->+ qc { _joins = Join tp tables conditions : _joins qc }++innerJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses+innerJoin = joinClause InnerJoin++leftJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses+leftJoin = joinClause LeftJoin++rightJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses+rightJoin = joinClause RightJoin++outerJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses+outerJoin = joinClause OuterJoin++emptyJoins :: QueryClauses+emptyJoins = QueryClauses $ Endo $ \qc ->+ qc { _joins = [] }++where_ :: [QueryBuilder] -> QueryClauses+where_ conditions = QueryClauses $ Endo $ \qc ->+ qc { _where_ = reverse conditions ++ _where_ qc}++emptyWhere :: QueryClauses+emptyWhere = QueryClauses $ Endo $ \qc ->+ qc { _where_ = [] }++groupBy_ :: [QueryBuilder] -> QueryClauses+groupBy_ columns = QueryClauses $ Endo $ \qc ->+ qc { _groupBy = columns }++having :: [QueryBuilder] -> QueryClauses+having conditions = QueryClauses $ Endo $ \qc ->+ qc { _having = reverse conditions ++ _having qc }++emptyHaving :: QueryClauses+emptyHaving = QueryClauses $ Endo $ \qc ->+ qc { _having = [] }++orderBy :: [QueryOrdering] -> QueryClauses+orderBy ordering = QueryClauses $ Endo $ \qc ->+ qc { _orderBy = ordering }++limit :: Int -> QueryClauses+limit count = QueryClauses $ Endo $ \qc ->+ qc { _limit = Just (count, Nothing) }++limitOffset :: Int -> Int -> QueryClauses+limitOffset count offset = QueryClauses $ Endo $ \qc ->+ qc { _limit = Just (count, Just offset) }++emptyQueryBody :: QueryBody+emptyQueryBody = QueryBody Nothing [] [] [] [] [] Nothing ++select :: Selector a -> QueryClauses -> Query a+select selector (QueryClauses clauses) =+ Query selector (clauses `appEndo` emptyQueryBody)++mergeSelect :: Query b -> (a -> b -> c) -> Selector a -> Query c+mergeSelect (Query selector2 body) f selector1 =+ Query (liftA2 f selector1 selector2) body++replaceSelect :: Selector a -> Query b -> Query a+replaceSelect s (Query _ body) = Query s body++insertValues :: QueryBuilder -> Insertor a -> [a] -> Command+insertValues = InsertValues++insertSelect :: QueryBuilder -> [QueryBuilder] -> [QueryBuilder] -> QueryClauses+ -> Command+insertSelect table toColumns fromColumns (QueryClauses clauses) =+ InsertSelect table (toColumns) (fromColumns) (appEndo clauses emptyQueryBody)++-- | combinator for aliasing columns.+as :: QueryBuilder -> QueryBuilder -> QueryBuilder+as e1 e2 = e1 <> " AS " <> e2++-- | Read the columns directly as a `MySQLValue` type without conversion.+values :: [QueryBuilder] -> Selector [MySQLValue]+values cols = Selector (DList.fromList cols) $+ state $ splitAt (length cols)++-- | Ignore the content of the given columns+values_ :: [QueryBuilder] -> Selector ()+values_ cols = () <$ values cols+ +-- selector for any bounded integer type+intFromSql :: forall a.(Show a, Bounded a, Integral a)+ => MySQLValue -> Either SQLError a+intFromSql r = case r of+ MySQLInt8U u -> castFromWord $ fromIntegral u+ MySQLInt8 i -> castFromInt $ fromIntegral i+ MySQLInt16U u -> castFromWord $ fromIntegral u+ MySQLInt16 i -> castFromInt $ fromIntegral i+ MySQLInt32U u -> castFromWord $ fromIntegral u+ MySQLInt32 i -> castFromInt $ fromIntegral i+ MySQLInt64U u -> castFromWord $ fromIntegral u+ MySQLInt64 i -> castFromInt $ fromIntegral i+ MySQLYear y -> castFromWord $ fromIntegral y+ _ -> Left $ TypeError r $+ "Int (" <> show (minBound :: a) <> ", " <> show (maxBound :: a) <> ")"+ where castFromInt :: Int64 -> Either SQLError a+ castFromInt i+ | i < fromIntegral (minBound :: a) = throwError Underflow+ | i > fromIntegral (maxBound :: a) = throwError Overflow+ | otherwise = pure $ fromIntegral i+ castFromWord :: Word64 -> Either SQLError a+ castFromWord i+ | i > fromIntegral (maxBound :: a) = throwError Overflow+ | otherwise = pure $ fromIntegral i++integerFromSql :: MySQLValue -> Either SQLError Integer+integerFromSql (MySQLInt8U u) = pure $ fromIntegral u+integerFromSql (MySQLInt8 i) = pure $ fromIntegral i+integerFromSql (MySQLInt16U u) = pure $ fromIntegral u+integerFromSql (MySQLInt16 i) = pure $ fromIntegral i+integerFromSql (MySQLInt32U u) = pure $ fromIntegral u+integerFromSql (MySQLInt32 i) = pure $ fromIntegral i+integerFromSql (MySQLInt64U u) = pure $ fromIntegral u+integerFromSql (MySQLInt64 i) = pure $ fromIntegral i+integerFromSql (MySQLYear y) = pure $ fromIntegral y+integerFromSql (MySQLDecimal d) = case floatingOrInteger d of+ Left (_ :: Double) -> throwError $ TypeError (MySQLDecimal d) "Integer"+ Right i -> pure i+integerFromSql v = throwError $ TypeError v "Integer"+ +instance FromSql Int where+ fromSql = intFromSql++instance FromSql Int8 where+ fromSql = intFromSql++instance FromSql Word8 where+ fromSql = intFromSql++instance FromSql Int16 where+ fromSql = intFromSql++instance FromSql Word16 where+ fromSql = intFromSql++instance FromSql Int32 where+ fromSql = intFromSql++instance FromSql Word32 where+ fromSql = intFromSql++instance FromSql Int64 where+ fromSql = intFromSql++instance FromSql Word64 where+ fromSql = intFromSql++instance FromSql Integer where+ fromSql = integerFromSql++instance FromSql Float where+ fromSql r = case r of+ MySQLFloat f -> pure f+ _ -> Left $ TypeError r "Float"++instance FromSql Double where+ fromSql r = case r of+ MySQLFloat f -> pure $ realToFrac f+ MySQLDouble f -> pure f+ _ -> Left $ TypeError r "Double"++instance FromSql Scientific where+ fromSql r = case r of+ MySQLDecimal f -> pure f+ _ -> Left $ TypeError r "Scientific"++instance FromSql LocalTime where+ fromSql r = case r of+ MySQLTimeStamp t -> pure t+ MySQLDateTime t -> pure t+ _ -> Left $ TypeError r "LocalTime"++instance FromSql TimeOfDay where+ fromSql r = case r of+ MySQLTime sign_ t | sign_ >= 0 -> pure t+ | otherwise -> throwError Overflow+ _ -> Left $ TypeError r "TimeOfDay"++instance FromSql DiffTime where+ fromSql r = case r of+ MySQLTime sign_ t | sign_ == 1 -> pure $ negate $ timeOfDayToTime t+ | otherwise -> pure $ timeOfDayToTime t+ _ -> Left $ TypeError r "DiffTime"+ +instance FromSql Day where+ fromSql r = case r of+ MySQLDate d -> pure d+ _ -> Left $ TypeError r "Day"++instance FromSql StrictBS.ByteString where+ fromSql r = case r of+ MySQLBytes b -> pure b+ _ -> Left $ TypeError r "ByteString"++instance FromSql Text where+ fromSql r = case r of+ MySQLText t -> pure t+ _ -> Left $ TypeError r "Text"++instance FromSql a => FromSql (Maybe a) where+ fromSql r = case r of+ MySQLNull -> pure Nothing+ _ -> Just <$> fromSql r++instance ToSql Int where+ toSqlValue = MySQLInt64 . fromIntegral++instance ToSql Int8 where+ toSqlValue = MySQLInt8++instance ToSql Word8 where+ toSqlValue = MySQLInt8U++instance ToSql Int16 where+ toSqlValue = MySQLInt16++instance ToSql Word16 where+ toSqlValue = MySQLInt16U++instance ToSql Int32 where+ toSqlValue = MySQLInt32++instance ToSql Word32 where+ toSqlValue = MySQLInt32U++instance ToSql Int64 where+ toSqlValue = MySQLInt64++instance ToSql Word64 where+ toSqlValue = MySQLInt64U++instance ToSql Integer where+ toSqlValue = MySQLDecimal . fromIntegral++instance ToSql Float where+ toSqlValue = MySQLFloat++instance ToSql Double where+ toSqlValue = MySQLDouble++instance ToSql Scientific where+ toSqlValue = MySQLDecimal++instance ToSql LocalTime where+ toSqlValue = MySQLDateTime++instance ToSql TimeOfDay where+ toSqlValue = MySQLTime 0+ +instance ToSql DiffTime where+ toSqlValue dt | dt < 0 = MySQLTime 1 $ timeToTimeOfDay $ negate dt+ | otherwise = MySQLTime 0 $ timeToTimeOfDay dt++instance ToSql Day where+ toSqlValue = MySQLDate++instance ToSql StrictBS.ByteString where+ toSqlValue = MySQLBytes++instance ToSql Text where+ toSqlValue = MySQLText++instance ToSql a => ToSql (Maybe a) where+ toSqlValue Nothing = MySQLNull+ toSqlValue (Just v) = toSqlValue v