hasqlator-mysql (empty) → 0.0.1
raw patch · 5 files changed
+1962/−0 lines, 5 filesdep +aesondep +basedep +binary
Dependencies added: aeson, base, binary, bytestring, containers, dlist, io-streams, megaparsec, mtl, mysql-haskell, pretty-simple, prettyprinter, scientific, template-haskell, text, time
Files
- LICENSE +27/−0
- hasqlator-mysql.cabal +52/−0
- src/Database/MySQL/Hasqlator.hs +818/−0
- src/Database/MySQL/Hasqlator/Typed.hs +624/−0
- src/Database/MySQL/Hasqlator/Typed/Schema.hs +441/−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.
+ hasqlator-mysql.cabal view
@@ -0,0 +1,52 @@+Name: hasqlator-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/hasqlator-mysql/issues+Build-type: Simple+Cabal-version: >=1.10+Description: A simple but expressive applicative SQL generation library for mysql+ .+ Haskqlator is a simple but expressive SQL generation library. Instead of+ matching haskell records, or using complicate type level computations to match+ haskell types to database schemas, it uses a simple applicative interface to+ convert between SQL and haskell. The produced SQL matches exactly the SQL+ written by the user. An addition layer is provided to encode database schemas+ as haskell values, and give more type safety.+ +source-repository head+ type: git+ location: https://github.com/kuribas/hasqlator-mysql++Library+ Ghc-options: -Wall+ default-language: Haskell2010+ Build-depends: base >= 3 && < 5,+ binary,+ bytestring,+ containers,+ dlist,+ dlist,+ io-streams >= 1.5.2.1,+ megaparsec,+ mtl >= 2.1.3,+ mysql-haskell,+ prettyprinter,+ scientific,+ text,+ time,+ template-haskell,+ aeson,+ pretty-simple+ hs-source-dirs:+ src + Exposed-Modules:+ Database.MySQL.Hasqlator+ Database.MySQL.Hasqlator.Typed+ Database.MySQL.Hasqlator.Typed.Schema
+ src/Database/MySQL/Hasqlator.hs view
@@ -0,0 +1,818 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}++{-|+Module : Database.Hasqelator+Description : SQL generation+Copyright : (c) Kristof Bastiaensen, 2020+License : BSD-3+Maintainer : kristof@resonata.be+Stability : unstable+Portability : ghc+++-}++module Database.MySQL.Hasqlator+ ( -- * Querying+ Query, Command, select, mergeSelect, replaceSelect,++ -- * Query Clauses+ QueryClauses, from, innerJoin, leftJoin, rightJoin, outerJoin, emptyJoins,+ where_, emptyWhere, groupBy_, having, emptyHaving, QueryOrdering(..),+ orderBy, limit, limitOffset,++ -- * Selectors+ Selector, as,++ -- ** polymorphic selector+ sel,+ -- ** specialised selectors+ -- | The following are specialised versions of `sel`. Using these+ -- may make refactoring easier, for example accidently swapping+ -- @`sel` "age"@ and @`sel` "name"@ would not give a type error,+ -- while @intSel "age"@ and @textSel "name"@ most likely would.+ intSel, integerSel, doubleSel, floatSel, scientificSel, + localTimeSel, timeOfDaySel, diffTimeSel, daySel, byteStringSel,+ textSel,+ -- ** other selectors+ values, values_,++ -- * Expressions+ subQuery,+ arg, fun, op, (>.), (<.), (>=.), (<=.), (+.), (-.), (*.), (/.), (=.), (++.),+ (/=.), (&&.), (||.), abs_, negate_, signum_, sum_, rawSql, substr, in_,++ -- * Insertion+ Insertor, insertValues, insertSelect, insertData, skipInsert, into, Getter,+ lensInto, insertOne, ToSql,+ + -- * Rendering Queries+ renderStmt, renderPreparedStmt, SQLError(..), QueryBuilder,+ ToQueryBuilder(..), FromSql,++ -- * Executing Queries+ executeQuery, executeCommand+ )++where++import Database.MySQL.Base hiding (Query, Command)+import qualified Database.MySQL.Base as MySQL+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 GHC.Generics hiding (Selector, from)+import qualified GHC.Generics as Generics (from)+ +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+import Data.Traversable+import Data.Functor.Contravariant+import qualified System.IO.Streams as Streams+import Control.Exception (throw, Exception)+import Data.Aeson++class FromSql a where+ fromSql :: MySQLValue -> Either SQLError a++class ToSql a where+ toSqlValue :: a -> MySQLValue++instance FromSql a => IsString (Selector a) where+ fromString = sel . 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++-- | Execute a Query which returns a resultset. May throw a+-- `SQLError` exception. See the mysql-haskell package for other+-- exceptions it may throw.+executeQuery :: MySQLConn -> Query a -> IO [a]+executeQuery conn q@(Query s _) =+ do is <- fmap snd $ MySQL.query_ conn $ MySQL.Query $ renderStmt q+ results <- Streams.toList is+ for results $ either throw pure . runSelector s++-- | Execute a Command which doesn't return a result-set. May throw a+-- `SQLError` exception. See the mysql-haskell package for other+-- exceptions it may throw.+executeCommand :: MySQLConn -> Command -> IO OK+executeCommand conn c = MySQL.execute_ conn $ MySQL.Query $ renderStmt c++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.+sel :: FromSql a => QueryBuilder -> Selector a+sel 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.+intSel :: (Show a, Bounded a, Integral a) => QueryBuilder -> Selector a+intSel 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.+integerSel :: QueryBuilder -> Selector Integer+integerSel = sel++-- | a DOUBLE field.+doubleSel :: QueryBuilder -> Selector Double+doubleSel = sel++-- | a FLOAT field.+floatSel :: QueryBuilder -> Selector Float+floatSel = sel++-- | A DECIMAL or NUMERIC field.+scientificSel :: QueryBuilder -> Selector Scientific+scientificSel = sel++-- | a DATETIME or a TIMESTAMP field.+localTimeSel :: QueryBuilder -> Selector LocalTime+localTimeSel = sel++-- | A TIME field taken as a specific time.+timeOfDaySel :: QueryBuilder -> Selector TimeOfDay+timeOfDaySel = sel++-- | a TIME field taken as a time duration.+diffTimeSel :: QueryBuilder -> Selector DiffTime+diffTimeSel = sel++-- | A DATE field.+daySel :: QueryBuilder -> Selector Day+daySel = sel++-- | A binary BLOB field.+byteStringSel :: QueryBuilder -> Selector StrictBS.ByteString+byteStringSel = sel++-- | a TEXT field.+textSel :: QueryBuilder -> Selector Text+textSel = sel+++data SQLError = SQLError String+ | ResultSetCountError+ | TypeError MySQLValue String+ | Underflow+ | Overflow+ deriving Show++instance Exception SQLError+-- | 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)++runSelector :: Selector a -> [MySQLValue] -> Either SQLError a+runSelector (Selector _ run) = evalStateT run+ +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 (Selector dl _) body) =+ "SELECT " <> commaSep (DList.toList dl) <> " " <> toQueryBuilder body++rawSql :: Text -> QueryBuilder+rawSql t = QueryBuilder builder builder DList.empty where+ builder = Builder.byteString (Text.encodeUtf8 t)+ +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++instance Contravariant Insertor where+ contramap f (Insertor x g) = Insertor x (g . f)++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 = parentized $ e1 <> " " <> fromText name <> " " <> e2++substr :: QueryBuilder -> QueryBuilder -> QueryBuilder -> QueryBuilder+substr field start end = fun "substr" [field, start, end]++(>.), (<.), (>=.), (<=.), (+.), (-.), (/.), (*.), (=.), (/=.), (++.), (&&.),+ (||.)+ :: QueryBuilder -> QueryBuilder -> QueryBuilder+(>.) = op ">"+(<.) = op "<"+(>=.) = op ">="+(<=.) = op "<="+(+.) = op "+"+(*.) = op "*"+(/.) = op "/"+(-.) = op "-"+(=.) = op "="+(/=.) = op "<>"+a ++. b = fun "concat" [a, b]+(&&.) = op "and"+(||.) = op "or"++abs_, signum_, negate_, sum_ :: QueryBuilder -> QueryBuilder+abs_ x = fun "abs" [x]+signum_ x = fun "sign" [x]+negate_ x = fun "-" [x]+sum_ x = fun "sum" [x]+++-- | insert a single value directly+insertOne :: ToSql a => Text -> Insertor a+insertOne s = Insertor [s] (\t -> [toSqlValue t])++-- | insert a datastructure+class InsertGeneric (fields :: *) (data_ :: *) where+ insertDataGeneric :: fields -> Insertor data_++genFst :: (a :*: b) () -> a ()+genFst (a :*: _) = a++genSnd :: (a :*: b) () -> b ()+genSnd (_ :*: b) = b++instance (InsertGeneric (a ()) (c ()),+ InsertGeneric (b ()) (d ())) =>+ InsertGeneric ((a :*: b) ()) ((c :*: d) ()) where+ insertDataGeneric (a :*: b) =+ contramap genFst (insertDataGeneric a) <>+ contramap genSnd (insertDataGeneric b)++instance InsertGeneric (a ()) (b ()) =>+ InsertGeneric (M1 m1 m2 a ()) (M1 m3 m4 b ()) where+ insertDataGeneric = contramap unM1 . insertDataGeneric . unM1++instance ToSql b => InsertGeneric (K1 r Text ()) (K1 r b ()) where+ insertDataGeneric = contramap unK1 . insertOne . unK1++instance InsertGeneric (K1 r (Insertor a) ()) (K1 r a ()) where+ insertDataGeneric = contramap unK1 . unK1++-- | `insertData` inserts a tuple or other product type into the given+-- fields. It uses generics to match the input to the fields. For+-- example:+--+-- > insert "Person" (insertData ("name", "age"))+-- > [Person "Bart Simpson" 10, Person "Lisa Simpson" 8]++insertData :: (Generic a, Generic b, InsertGeneric (Rep a ()) (Rep b ()))+ => a -> Insertor b+insertData = contramap from' . insertDataGeneric . from'+ where from' :: Generic a => a -> Rep a ()+ from' = Generics.from++-- | skipInsert is mempty specialized to an Insertor. It can be used+-- to skip fields when using insertData.+skipInsert :: Insertor a+skipInsert = mempty++-- | `into` uses the given accessor 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 = contramap toVal . insertOne++-- | A Getter type compatible with the lens library+type Getter s a = (a -> Const a a) -> s -> Const a s++-- | `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 => Getter a b -> Text -> Insertor a+lensInto lens = into (getConst . lens Const)++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++in_ :: QueryBuilder -> [QueryBuilder] -> QueryBuilder+in_ e l = e <> " IN " <> parentized (commaSep l)++-- | 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 Bool where+ fromSql (MySQLInt8U x) = pure $ x /= 0+ fromSql (MySQLInt8 x) = pure $ x /= 0+ fromSql v = throwError $ TypeError v "Bool"+ +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++instance ToSql Bool where+ toSqlValue = MySQLInt8U . fromIntegral . fromEnum+
+ src/Database/MySQL/Hasqlator/Typed.hs view
@@ -0,0 +1,624 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor #-}++module Database.MySQL.Hasqlator.Typed+ ( -- * Database Types+ Table(..), Field(..), Tbl(..), (@@), Nullable (..),+ + + -- * Querying+ Query, ++ -- * Selectors+ H.Selector, sel, selMaybe,++ -- * Expressions+ Expression, SomeExpression, someExpr, Operator, + arg, argMaybe, nullable, cast, unsafeCast,+ op, fun1, fun2, fun3, (>.), (<.), (>=.), (<=.), (&&.), (||.),+ substr, true_, false_,++ -- * Clauses+ from, fromSubQuery, innerJoin, leftJoin, joinSubQuery, leftJoinSubQuery,+ where_, groupBy_, having, orderBy, limit, limitOffset,++ -- * Insertion+ Insertor, insertValues, insertSelect, insertData, skipInsert, into,+ lensInto, insertOne, exprInto, Into,+ + -- * imported from Database.MySQL.Hasqlator+ H.Getter, H.ToSql, H.FromSql, subQueryExpr+ )+where+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Coerce+import qualified Data.ByteString as StrictBS+import Data.Scientific+import Data.Word+import Data.Int+import Data.Time+import Data.String+import qualified Data.DList as DList+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+import qualified GHC.Generics as Generics (from, to)+import GHC.Generics hiding (from, Selector)+import qualified Database.MySQL.Hasqlator as H+import Data.Proxy++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+ where+ JoinNullable 'InnerJoined nullable = nullable+ JoinNullable 'LeftJoined _ = 'Nullable++data Field (table :: Symbol) database (nullable :: Nullable) a =+ Field Text Text+ +newtype Expression (nullable :: Nullable) a =+ Expression {runExpression :: QueryInner H.QueryBuilder }++-- | An expression of any type+newtype SomeExpression =+ SomeExpression { runSomeExpression :: QueryInner H.QueryBuilder }++newtype Selector a = Selector (QueryInner (H.Selector a))++instance Functor Selector where+ fmap f (Selector s) = Selector (fmap f <$> s)+instance Applicative Selector where+ pure x = Selector $ pure $ pure x+ Selector a <*> Selector b = Selector $ liftA2 (<*>) a b+instance Semigroup a => Semigroup (Selector a) where+ Selector a <> Selector b = Selector $ liftA2 (<>) a b+instance Monoid a => Monoid (Selector a) where+ mempty = Selector $ pure mempty++-- | Remove types of an expression+someExpr :: Expression nullable a -> SomeExpression+someExpr = coerce++instance IsString (Expression nullable Text) where+ fromString = arg . fromString++instance Semigroup (Expression nullable Text) where+ (<>) = fun2 (H.++.)++instance Monoid (Expression nullable Text) where+ mempty = arg ""++instance (Num n, H.ToSql n) => Num (Expression nullable n) where+ (+) = op (H.+.)+ (-) = op (H.-.)+ (*) = op (H.*.)+ negate = fun1 H.negate_+ abs = fun1 H.abs_+ signum = fun1 H.signum_+ fromInteger = arg . fromInteger++instance (Fractional n, H.ToSql n)+ => Fractional (Expression nullable n) where+ (/) = op (H./.)+ fromRational = arg . fromRational+ +data Table (table :: Symbol) database = Table (Maybe Text) Text++-- | 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 =>+ Field table database fieldNull a ->+ Expression exprNull a }++newtype Insertor (table :: Symbol) database a = Insertor (H.Insertor a)+ deriving (Monoid, Semigroup, Contravariant)++data ClauseState = ClauseState+ { clausesBuild :: H.QueryClauses -- clauses build so far+ , aliases :: Map.Map Text Int -- map of aliases to times used+ }++emptyClauseState :: ClauseState+emptyClauseState = ClauseState mempty Map.empty++type QueryInner a = State ClauseState a++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 ->+ Expression nullable c)++infixl 9 @@++-- | Create an expression from an aliased table and a field.+(@@) :: CheckExprNullable (JoinNullable joinType fieldNull) exprNull+ => Tbl table database (joinType :: JoinType)+ -> Field table database fieldNull a+ -> Expression exprNull a+(@@) = getTableAlias + +mkTableAlias :: Text -> Tbl table database leftJoined+mkTableAlias tableName = Tbl $ \(Field _ fieldName) ->+ Expression $ pure $ H.rawSql $ tableName <> "." <> fieldName++data QueryOrdering = Asc SomeExpression | Desc SomeExpression++-- | make a selector from a column+sel :: H.FromSql a+ => Expression 'NotNull a+ -> Selector a+sel (Expression expr) = Selector $ H.sel <$> expr++-- | make a selector from a column that can be null+selMaybe :: H.FromSql (Maybe a)+ => Expression 'Nullable a+ -> Selector (Maybe a)+selMaybe (Expression expr) = Selector $ H.sel <$> expr++-- | pass an argument+arg :: H.ToSql a => a -> Expression nullable a+arg x = Expression $ pure $ H.arg x++-- | pass an argument which can be null+argMaybe :: H.ToSql a => Maybe a -> Expression 'Nullable a+argMaybe x = Expression $ pure $ H.arg x++-- | create an operator+op :: (H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder)+ -> Operator a b c+op = fun2++fun1 :: (H.QueryBuilder -> H.QueryBuilder)+ -> Expression nullable a+ -> Expression nullable b+fun1 f (Expression x) = Expression $ f <$> x++fun2 :: (H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder)+ -> Expression nullable a+ -> Expression nullable b+ -> Expression nullable c+fun2 f (Expression x1) (Expression x2) = Expression $ liftA2 f x1 x2++fun3 :: (H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder)+ -> Expression nullable a+ -> Expression nullable b+ -> Expression nullable c+ -> Expression nullable d+fun3 f (Expression x1) (Expression x2) (Expression x3) =+ Expression $ liftA3 f x1 x2 x3++substr :: Expression nullable Text -> Expression nullable Int+ -> Expression nullable Int+ -> Expression nullable Text+substr = fun3 H.substr++(>.), (<.), (>=.), (<=.) :: H.ToSql a => Operator a a Bool+(>.) = op (H.>.)+(<.) = op (H.<.)+(>=.) = op (H.>=.)+(<=.) = op (H.<=.)++(||.), (&&.) :: Operator Bool Bool Bool+(||.) = op (H.||.)+(&&.) = op (H.&&.)++true_, false_ :: Expression nullable Bool+true_ = Expression $ pure $ H.rawSql "true"+false_ = Expression $ pure $ H.rawSql "false"++-- | make expression nullable+nullable :: Expression nullable a -> Expression 'Nullable a+nullable = coerce++class Castable a where+ -- | Safe cast. This uses the SQL CAST function to convert safely+ -- from one type to another.+ cast :: Expression nullable b+ -> Expression nullable a++castTo :: H.QueryBuilder+ -> Expression nullable b+ -> Expression nullable a+castTo tp (Expression e) = Expression $ do+ x <- e+ pure $ H.fun "cast" [x `H.as` tp]++instance Castable StrictBS.ByteString where+ cast = castTo "BINARY"++instance Castable Text where+ cast = castTo "CHAR UNICODE"++instance Castable Day where+ cast = castTo "DATE"++instance Castable LocalTime where+ cast = castTo "DATETIME"++instance Castable Scientific where+ cast = castTo "DECIMAL"++instance Castable Double where+ cast = castTo "FLOAT[53]"++instance Castable Int where+ cast = castTo "SIGNED"++instance Castable Int8 where+ cast = castTo "SIGNED"++instance Castable Int16 where+ cast = castTo "SIGNED"++instance Castable Int32 where+ cast = castTo "SIGNED"++instance Castable Int64 where+ cast = castTo "SIGNED"++instance Castable TimeOfDay where+ cast = castTo "TIME"++instance Castable DiffTime where+ cast = castTo "TIME"++instance Castable Word where+ cast = castTo "UNSIGNED"++instance Castable Word8 where+ cast = castTo "UNSIGNED"++instance Castable Word16 where+ cast = castTo "UNSIGNED"++instance Castable Word32 where+ cast = castTo "UNSIGNED"++instance Castable Word64 where+ cast = castTo "UNSIGNED"++-- | Cast the return type of an expression to any other type, without+-- changing the query. Since this library adds static typing on top of+-- SQL, you may sometimes want to use this to get back the lenient+-- behaviour of SQL. This opens up more possibilies for runtime+-- errors, so it's up to the programmer to ensure type correctness.+unsafeCast :: Expression nullable a -> Expression nullable b+unsafeCast = coerce++fieldText :: Field table database nullable a -> Text+fieldText (Field table fieldName) = table <> "." <> fieldName++insertOne :: Insertable fieldNull fieldType a+ => Field table database fieldNull fieldType+ -> Insertor table database a+insertOne = Insertor . H.insertOne. fieldText++genFst :: (a :*: b) () -> a ()+genFst (a :*: _) = a++genSnd :: (a :*: b) () -> b ()+genSnd (_ :*: b) = b++class InsertGeneric table database (fields :: *) (data_ :: *) where+ insertDataGeneric :: fields -> Insertor table database data_++instance (InsertGeneric tbl db (a ()) (c ()),+ InsertGeneric tbl db (b ()) (d ())) =>+ InsertGeneric tbl db ((a :*: b) ()) ((c :*: d) ()) where+ insertDataGeneric (a :*: b) =+ contramap genFst (insertDataGeneric a) <>+ contramap genSnd (insertDataGeneric b)++instance InsertGeneric tbl db (a ()) (b ()) =>+ 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 InsertGeneric tbl db (K1 r (Insertor tbl db a) ()) (K1 r a ()) where+ insertDataGeneric = contramap unK1 . unK1++insertData :: (Generic a, Generic b, InsertGeneric tbl db (Rep a ()) (Rep b ()))+ => a -> Insertor tbl db b+insertData = contramap from' . insertDataGeneric . from'+ where from' :: Generic a => a -> Rep a ()+ from' = Generics.from++skipInsert :: Insertor tbl db a+skipInsert = mempty++{-+personInsertor :: Insertor table database Person+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++lensInto :: Insertable fieldNull fieldType b+ => H.Getter a b+ -> Field table database fieldNull fieldType+ -> Insertor table database a+lensInto lens a = Insertor $ H.lensInto lens $ fieldText a++insertValues :: Table table database+ -> Insertor table database a+ -> [a]+ -> H.Command+insertValues (Table _schema tableName) (Insertor i) =+ H.insertValues (H.rawSql tableName) i++newAlias :: Text -> QueryInner Text+newAlias prefix = do+ clsState <- get+ let newIndex = Map.findWithDefault 0 prefix (aliases clsState) + 1+ put $ clsState { aliases = Map.insert prefix newIndex $ aliases clsState}+ pure $ prefix <> Text.pack (show newIndex)++addClauses :: H.QueryClauses -> QueryInner ()+addClauses c = modify $ \clsState ->+ clsState { clausesBuild = clausesBuild clsState <> c }++from :: Table table database+ -> Query database (Tbl table database 'InnerJoined)+from (Table schema tableName) = Query $+ do alias <- newAlias (Text.take 1 tableName)+ addClauses $ H.from $+ H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as` H.rawSql alias+ pure $ mkTableAlias alias++innerJoin :: Table table database+ -> (Tbl 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)+ let tblAlias = mkTableAlias alias+ exprBuilder <- runExpression $ joinCondition tblAlias+ addClauses $+ H.innerJoin [H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as`+ H.rawSql alias]+ [exprBuilder]+ pure tblAlias++leftJoin :: Table table database+ -> (Tbl 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)+ let tblAlias = mkTableAlias alias+ exprBuilder <- runExpression $ joinCondition tblAlias+ addClauses $+ H.leftJoin [H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as`+ H.rawSql alias]+ [exprBuilder]+ pure tblAlias+++class SubQueryExpr (joinType :: JoinType) inExpr outExpr where+ -- The ReaderT monad takes the alias of the subquery table.+ -- The State monad uses the index of the last expression in the select clause.+ -- It generates SELECT clause expressions with aliases e1, e2, ...+ -- The outExpr contains just the output aliases.+ -- input and output should be product types, and have the same number of+ -- elements.+ subJoinGeneric :: Proxy joinType+ -> inExpr+ -> ReaderT Text (State Int)+ (DList.DList SomeExpression, outExpr)++instance ( SubQueryExpr joinType (a ()) (c ())+ , SubQueryExpr joinType (b ()) (d ())) =>+ SubQueryExpr joinType ((a :*: b) ()) ((c :*: d) ()) where+ subJoinGeneric p (l :*: r) = do+ (lftBuilder, outLft) <- subJoinGeneric p l+ (rtBuilder, outRt) <- subJoinGeneric p r+ pure (lftBuilder <> rtBuilder, outLft :*: outRt)+ +instance SubQueryExpr joinType (a ()) (b ()) =>+ SubQueryExpr joinType (M1 m1 m2 a ()) (M1 m3 m4 b ()) where+ subJoinGeneric p (M1 x) = fmap M1 <$> subJoinGeneric p x+ +instance JoinNullable joinType nullable ~ nullable2 => + SubQueryExpr+ joinType+ (K1 r (Expression nullable a) ())+ (K1 r (Expression nullable2 b) ())+ where+ subJoinGeneric _ (K1 (Expression exprBuilder)) =+ ReaderT $ \alias -> state $ \i ->+ let name = Text.pack ('e': show i)+ in ( ( DList.singleton $ SomeExpression $+ (`H.as` H.rawSql name) <$> exprBuilder+ , K1 $ Expression $ pure $ H.rawSql $ alias <> "." <> name)+ , i+1+ )++-- update the aliases, but create and return new query clauses+runAsSubQuery :: Query database a -> QueryInner (H.QueryClauses, a)+runAsSubQuery (Query sq) =+ do ClauseState currentClauses currentAliases <- get+ let (subQueryRet, ClauseState subQueryBody newAliases) =+ runState sq (ClauseState mempty currentAliases)+ put $ ClauseState currentClauses newAliases+ pure (subQueryBody, subQueryRet)++subQueryExpr :: Query database (Expression nullable a) -> Expression nullable a+subQueryExpr sq = Expression $+ do (subQueryBody, Expression subQuerySelect) <- runAsSubQuery sq + selectBuilder <- subQuerySelect+ pure $ H.subQuery $ H.select (H.values_ [selectBuilder]) subQueryBody++-- +subJoinBody :: (Generic inExprs,+ Generic outExprs,+ SubQueryExpr joinType (Rep inExprs ()) (Rep outExprs ()))+ => Proxy joinType+ -> Query database inExprs+ -> QueryInner (H.QueryBuilder, outExprs)+subJoinBody p sq = do+ sqAlias <- newAlias "sq"+ (subQueryBody, sqExprs) <- runAsSubQuery sq+ let from' :: Generic inExprs => inExprs -> Rep inExprs ()+ from' = Generics.from+ to' :: Generic outExpr => Rep outExpr () -> outExpr+ to' = Generics.to+ (selectExprs, outExprRep) = flip evalState 1 $+ flip runReaderT sqAlias $+ subJoinGeneric p $+ from' sqExprs+ outExpr = to' outExprRep+ selectBuilder <- DList.toList <$> traverse runSomeExpression selectExprs+ pure ( H.subQuery $ H.select (H.values_ selectBuilder) subQueryBody+ , outExpr)++joinSubQuery :: (Generic inExprs,+ Generic outExprs,+ SubQueryExpr 'InnerJoined (Rep inExprs ()) (Rep outExprs ()))+ => Query database inExprs+ -> (outExprs -> Expression nullable Bool)+ -> Query database outExprs+joinSubQuery sq condition = Query $ do+ (subQueryBody, outExpr) <- subJoinBody (Proxy :: Proxy 'InnerJoined) sq+ conditionBuilder <- runExpression $ condition outExpr+ addClauses $ H.innerJoin [subQueryBody] [conditionBuilder]+ pure outExpr++leftJoinSubQuery :: (Generic inExprs,+ Generic outExprs,+ SubQueryExpr 'LeftJoined (Rep inExprs ()) (Rep outExprs ()))+ => Query database inExprs+ -> (outExprs -> Expression nullable Bool)+ -> Query database outExprs+leftJoinSubQuery sq condition = Query $ do+ (subQueryBody, outExpr) <- subJoinBody (Proxy :: Proxy 'LeftJoined) sq+ conditionBuilder <- runExpression $ condition outExpr+ addClauses $ H.leftJoin [subQueryBody] [conditionBuilder]+ pure outExpr++fromSubQuery :: (Generic inExprs,+ Generic outExprs,+ SubQueryExpr 'LeftJoined (Rep inExprs ()) (Rep outExprs ()))+ => Query database inExprs+ -> Query database outExprs+fromSubQuery sq = Query $ do + (subQueryBody, outExpr) <- subJoinBody (Proxy :: Proxy 'LeftJoined) sq + addClauses $ H.from subQueryBody+ pure outExpr++where_ :: Expression nullable Bool -> Query database ()+where_ expr = Query $ do+ exprBuilder <- runExpression expr+ addClauses $ H.where_ [exprBuilder]++groupBy_ :: [SomeExpression] -> Query database ()+groupBy_ columns = Query $ do+ columnBuilders <- traverse runSomeExpression columns+ addClauses $ H.groupBy_ columnBuilders++having :: Expression nullable Bool -> Query database ()+having expr = Query $ do+ exprBuilder <- runExpression expr+ addClauses $ H.having [exprBuilder]++orderBy :: [QueryOrdering] -> Query database ()+orderBy ordering = Query $+ do newOrdering <- traverse orderingToH ordering+ addClauses $ H.orderBy newOrdering+ where orderingToH (Asc x) = H.Asc <$> runSomeExpression x+ orderingToH (Desc x) = H.Desc <$> runSomeExpression x++limit :: Int -> Query database ()+limit count = Query $ addClauses $ H.limit count++limitOffset :: Int -> Int -> Query database ()+limitOffset count offset = Query $ addClauses $ H.limitOffset count offset++newtype Into database (table :: Symbol) =+ Into { runInto :: QueryInner (Text, H.QueryBuilder) }++exprInto :: CheckExprNullable exprNullable fieldNullable+ => Expression exprNullable a ->+ Field table database fieldNullable a ->+ Into database table+exprInto expr (Field _ fieldName) =+ Into $ (fieldName,) <$> 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))+ (map (H.rawSql . fst) intos)+ (map snd intos) clauses+ where (intos, ClauseState clauses _) =+ runState (query >>= traverse runInto) emptyClauseState+
+ src/Database/MySQL/Hasqlator/Typed/Schema.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module Database.MySQL.Hasqlator.Typed.Schema+ (TableInfo(..), ColumnInfo(..), fetchTableInfo, Sign(..), ColumnType(..),+ pprTableInfo, Properties(..), defaultProperties, makeDBTypes) where+import Database.MySQL.Hasqlator+import qualified Database.MySQL.Hasqlator.Typed as T+import Database.MySQL.Base(MySQLConn)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import Text.Megaparsec+import qualified Data.Map as Map+import qualified Data.Set as Set+import Text.Megaparsec.Char+import Data.Text (Text)+import Control.Applicative (liftA2)+import Language.Haskell.TH+import Data.Word+import Data.Int+import Data.Scientific+import Data.Time+import Control.Monad+import qualified Data.ByteString as StrictBS+import Data.Aeson(Value)+import Data.Char+import Data.List+import GHC.TypeLits(Symbol)+import Text.Pretty.Simple++data Sign = Signed | Unsigned+ deriving Show++data ColumnType =+ TinyIntColumn Sign |+ SmallIntColumn Sign |+ MediumIntColumn Sign |+ IntColumn Sign |+ BigIntColumn Sign |+ DecimalColumn Int Int Sign |+ VarCharColumn Int |+ CharColumn Int |+ TextColumn |+ BlobColumn |+ DateTimeColumn Int |+ TimestampColumn Int |+ DateColumn |+ TimeColumn Int |+ DoubleColumn |+ FloatColumn |+ EnumColumn [Text] |+ SetColumn [Text] |+ BinaryColumn Int |+ VarBinaryColumn Int | + BitColumn Int |+ JsonColumn+ deriving (Show)++data ColumnInfo = ColumnInfo+ { columnTableSchema :: Text+ , columnTableName :: Text+ , columnName :: Text+ , columnType :: ColumnType+ , columnNullable :: Bool+ , primaryKey :: Bool+ , autoIncrement :: Bool+ , foreignKey :: Maybe (Text, Text, Text)+ } deriving (Show)++data TableInfo = TableInfo+ { tableName :: Text+ , tableSchema :: Text+ , tableColumns :: [ColumnInfo]+ } deriving (Show)++argsP :: Parsec () Text a -> Parsec () Text [a]+argsP p = between (single '(') (single ')') $ sepBy p (single ',')++arg1P :: Parsec () Text a -> Parsec () Text a+arg1P = between (single '(') (single ')')++arg2P :: Parsec () Text a -> Parsec () Text (a, a)+arg2P p = between (single '(') (single ')') $ liftA2 (,) p (single ',' >> p)++stringP :: Parsec () Text Text+stringP = fmap Text.pack $ between (single '\'') (single '\'') $ many $+ noneOf ['\'', '\\'] <|> (single '\\' >> anySingle)++intP :: Parsec () Text Int+intP = read <$> many digitChar++signP :: Parsec () Text Sign+signP = option Signed $ Unsigned <$ string "unsigned"++parseType :: Text -> ColumnType+parseType t = case runParser typeParser "COLUMN_TYPE" t of+ Left err -> error $ show err+ Right res -> res++typeParser :: Parsec () Text ColumnType+typeParser = do+ typename <- many letterChar+ case typename of+ -- ignore the "display width" argument+ "tinyint" -> fmap TinyIntColumn $ optional (argsP intP) *> space *> signP+ "smallint" -> fmap SmallIntColumn $ optional (argsP intP) *> space *> signP+ "mediumint" -> fmap MediumIntColumn $ optional (argsP intP) *> space *> signP+ "int" -> fmap IntColumn $ optional (argsP intP) *> space *> signP+ "bigint" -> fmap BigIntColumn $ optional (argsP intP) *> space *> signP+ "decimal" -> do (m, d) <- arg2P intP+ space+ sign <- signP+ pure $ DecimalColumn m d sign+ "varchar" -> VarCharColumn <$> arg1P intP+ "char" -> CharColumn <$> arg1P intP+ "tinytext" -> pure TextColumn+ "text" -> pure TextColumn+ "mediumtext" -> pure TextColumn+ "longtext" -> pure TextColumn+ "tinyblob" -> pure BlobColumn+ "blob" -> pure BlobColumn+ "mediumblob" -> pure BlobColumn+ "longblob" -> pure BlobColumn+ "datetime" -> fmap DateTimeColumn $ option 0 $ arg1P intP+ "date" -> pure DateColumn + "time" -> fmap TimeColumn $ option 0 $ arg1P intP+ "timestamp" -> fmap TimestampColumn $ option 0 $ arg1P intP+ "float" -> pure FloatColumn+ "double" -> pure DoubleColumn+ "enum" -> EnumColumn <$> argsP stringP+ "set" -> SetColumn <$> argsP stringP+ "binary" -> VarBinaryColumn <$> arg1P intP+ "varbinary" -> VarBinaryColumn <$> arg1P intP+ "json" -> pure JsonColumn+ "bit" -> BitColumn <$> arg1P intP+ x -> fail $ "Don't know how to parse COLUMN_TYPE " <> show x++tableQuery :: [Text] -> Query TableInfo+tableQuery schemas =+ select tableSelector $+ from "information_schema.TABLES" <>+ where_ ["TABLE_SCHEMA" `in_` map arg schemas]+ where tableSelector = do+ tableName_ <- textSel "TABLE_NAME"+ tableSchema_ <- textSel "TABLE_SCHEMA"+ pure $ TableInfo{ tableName = tableName_+ , tableSchema = tableSchema_+ , tableColumns = []}+ +columnsQuery :: [Text] -> Query ColumnInfo+columnsQuery schemas =+ select columnSelector $+ from ("information_schema.COLUMNS" `as` "c")+ <> leftJoin ["information_schema.KEY_COLUMN_USAGE" `as` "k"]+ [ "k.TABLE_SCHEMA" =. "c.TABLE_SCHEMA"+ , "k.TABLE_NAME" =. "c.TABLE_NAME"+ , "k.COLUMN_NAME" =. "c.COLUMN_NAME"+ , "k.REFERENCED_COLUMN_NAME IS NOT NULL" + ]+ <> where_ ["c.TABLE_SCHEMA" `in_` map arg schemas]+ where columnSelector = do+ tableName_ <- textSel "c.TABLE_NAME"+ tableSchema_ <- textSel "c.TABLE_SCHEMA"+ columnName_ <- textSel "c.COLUMN_NAME"+ nullable <- textSel "c.IS_NULLABLE"+ columnType_ <- textSel "c.COLUMN_TYPE"+ columnKey <- textSel "c.COLUMN_KEY"+ extra <- textSel "c.EXTRA"+ referencedTableSchema <-+ sel "k.REFERENCED_TABLE_SCHEMA" :: Selector (Maybe Text)+ referencedTableName <- + sel "k.REFERENCED_TABLE_NAME" :: Selector (Maybe Text)+ referencedColumnName <- + sel "k.REFERENCED_COLUMN_NAME" :: Selector (Maybe Text)+ pure $ ColumnInfo+ { columnTableSchema = tableSchema_+ , columnTableName = tableName_+ , columnType = parseType columnType_+ , columnName = columnName_+ , columnNullable = nullable == "YES"+ , primaryKey = columnKey == "PRI"+ , autoIncrement = "auto_increment" `Text.isInfixOf` extra+ , foreignKey = (,,)+ <$> referencedTableSchema+ <*> referencedTableName+ <*> referencedColumnName+ }++-- | Fetch TableInfo structures for each of the given schemas, using+-- the given `MySQLConn` connection.+fetchTableInfo :: MySQLConn -> [Text] -> IO [TableInfo]+fetchTableInfo conn schemas = do+ tables <- executeQuery conn $ tableQuery schemas+ columns <- executeQuery conn $ columnsQuery schemas+ let columnMap = Map.fromListWith (++) $+ map (\ci -> ( (columnTableSchema ci, columnTableName ci)+ , [ci]))+ columns+ pure $+ map (\tbl@TableInfo{tableName, tableSchema} ->+ tbl {tableColumns = Map.findWithDefault [] (tableSchema, tableName)+ columnMap} )+ tables++pprTableInfo :: LazyText.Text -> [TableInfo] -> LazyText.Text+pprTableInfo name ti =+ LazyText.unlines $ ((name <> " = ") : ) $+ map (" " <>) $ LazyText.lines $ pShowNoColor ti++columnTHType :: ColumnInfo -> Q Type+columnTHType ColumnInfo{ columnType, columnNullable}+ | columnNullable = [t| Maybe $(tp) |]+ | otherwise = tp+ where tp = case columnType of+ TinyIntColumn _ -> [t| Int |]+ SmallIntColumn _ -> [t| Int |]+ MediumIntColumn _ -> [t| Int |]+ IntColumn _ -> [t| Int |]+ BigIntColumn Signed -> [t| Int64 |]+ BigIntColumn Unsigned -> [t| Word64 |]+ DecimalColumn{} -> [t| Scientific |]+ VarCharColumn _ -> [t| Text |]+ CharColumn _ -> [t| Text |]+ TextColumn -> [t| Text |]+ DateTimeColumn _ -> [t| LocalTime |]+ TimestampColumn _ -> [t| LocalTime |]+ DateColumn -> [t| Day |]+ TimeColumn _ -> [t| TimeOfDay |]+ DoubleColumn -> [t| Double |]+ FloatColumn -> [t| Float |]+ EnumColumn _ -> [t| Text |]+ SetColumn _ -> [t| Text |]+ BinaryColumn _ -> [t| StrictBS.ByteString |]+ VarBinaryColumn _ -> [t| StrictBS.ByteString |]+ BlobColumn -> [t| StrictBS.ByteString |]+ BitColumn _ -> [t| Word64 |]+ JsonColumn -> [t| Value |]++data Properties = Properties+ { fieldNameModifier :: String -> String+ , tableNameModifier :: String -> String+ , classNameModifier :: String -> String+ , includeInsertor :: Bool+ , insertorTypeModifier :: String -> String+ , insertorNameModifier :: String -> String+ , insertorFieldModifier :: String -> String+ }+++downcase :: String -> String+downcase (c:cs)+ | isAlpha c = let (l, r) = span isUpper (c:cs)+ in map toLower l ++ r+ | otherwise = '_' : c : cs+downcase "" = ""++upcase :: String -> String+upcase (c:cs)+ | isAlpha c = toUpper c : cs+ | otherwise = '_' : c : cs+upcase "" = ""++removeUnderscore :: String -> String+removeUnderscore ('_':c:cs)+ | isAlpha c = toUpper c : removeUnderscore cs+removeUnderscore (c:cs) = c:removeUnderscore cs+removeUnderscore [] = []++defaultProperties :: Properties+defaultProperties = Properties+ { fieldNameModifier = \n ->+ downcase n <> (if downcase n `elem` reserved then "_" else mempty)+ , tableNameModifier = \n ->+ downcase n <> (if downcase n `elem` reserved then "_" else mempty) <> "_tbl"+ , classNameModifier = \n -> "Has_" <> n <> "_Field"+ , includeInsertor = True+ , insertorTypeModifier = \n -> removeUnderscore (upcase n) <> "Fields"+ , insertorNameModifier = \n ->+ downcase (removeUnderscore n) <> "Insertor"+ , insertorFieldModifier = \n -> downcase n <> "_field"+ }+ where reserved :: [String]+ reserved = ["id", "class", "data", "type", "foreign", "import",+ "default", "case"]+ +makeField :: Properties -> Name -> ColumnInfo -> Q [Dec]+makeField props dbName ci@ColumnInfo{columnTableName,+ columnName,+ columnNullable} =+ sequence [ sigD+ (mkName $ fieldNameModifier props fieldName)+ [t| T.Field+ $(litT $ strTyLit tableName)+ $(conT dbName)+ $(if columnNullable+ then promotedT 'T.Nullable+ else promotedT 'T.NotNull)+ $(columnTHType ci)+ |]+ , valD (varP $ mkName $ fieldNameModifier props fieldName)+ (normalB [e| T.Field+ $(litE $ stringL tableName)+ $(litE $ stringL fieldName)+ |])+ []+ ]+ where fieldName = Text.unpack columnName+ tableName = Text.unpack columnTableName+ +makeTable :: Properties -> Name -> TableInfo -> Q [Dec]+makeTable props dbname TableInfo{tableName} =+ sequence [ sigD+ (mkName $ tableNameModifier props tableString)+ [t| T.Table+ $(litT $ strTyLit tableString)+ $(conT dbname)+ |]+ , valD (varP $ mkName $ tableNameModifier props tableString)+ (normalB [e| T.Table+ $(conE 'Nothing)+ $(litE $ stringL tableString)+ |])+ []+ ]+ where tableString = Text.unpack tableName+ +fieldClass :: Properties -> Name -> String -> Q Dec+fieldClass props dbName columnName =+ classD (pure []) (mkName $ classNameModifier props columnName)+ [ kindedTV (mkName "table") (ConT ''Symbol)+ , kindedTV (mkName "nullable") (ConT ''T.Nullable)+ , plainTV $ mkName "a"]+ [FunDep [mkName "table"] [mkName "nullable", mkName "a"]]+ [ sigD+ (mkName columnName)+ [t| T.Field+ $(varT $ mkName "table")+ $(conT dbName)+ $(varT $ mkName "nullable")+ $(varT $ mkName "a")+ |]]++fieldInstance :: Properties -> ColumnInfo -> Q Dec+fieldInstance props ci@ColumnInfo{columnName,+ columnNullable,+ columnTableName} =+ instanceD (pure [])+ [t| $(conT $ mkName $ classNameModifier props $ fieldNameModifier props $+ Text.unpack columnName)+ $(litT $ strTyLit $ Text.unpack columnTableName)+ $(promotedT $ if columnNullable then 'T.Nullable else 'T.NotNull)+ $(columnTHType ci)+ |]+ [valD (varP $ mkName $ fieldNameModifier props fieldName)+ (normalB [e| T.Field+ $(litE $ stringL tableName)+ $(litE $ stringL fieldName)+ |])+ []]+ where fieldName = Text.unpack columnName+ tableName = Text.unpack columnTableName++ +insertorType :: Properties -> TableInfo -> Q Dec+insertorType props ti =+ dataD (pure [])+ (mkName typeName)+ []+ Nothing+ [recC (mkName typeName) $ map columnTypes (tableColumns ti) ]+ []+ where typeName = insertorTypeModifier props (Text.unpack $ tableName ti)+ columnTypes ci =+ ( (mkName $ insertorFieldModifier props $ Text.unpack $ columnName ci)+ , Bang NoSourceUnpackedness NoSourceStrictness+ ,+ ) <$> columnTHType ci+ + +insertor :: Properties -> Name -> TableInfo -> Q [Dec]+insertor props dbName ti =+ sequence [ sigD+ insertorName+ [t| T.Insertor+ $(litT $ strTyLit $ Text.unpack $ tableName ti)+ $(conT dbName)+ $(conT insertorTypeName)+ |]+ , valD (varP insertorName)+ (normalB $ foldr1 (\x y -> [| $(x) <> $(y) |]) $+ map insertorField $ tableColumns ti)+ []+ ]+ where + insertorName = mkName $ insertorNameModifier props $ Text.unpack $+ tableName ti+ insertorTypeName = mkName $ insertorTypeModifier props $ Text.unpack $+ tableName ti+ insertorField :: ColumnInfo -> Q Exp+ insertorField ci = [e| $(sigE+ (varE $ mkName $ insertorFieldModifier props $+ Text.unpack $ columnName ci)+ [t| $(conT insertorTypeName) -> $(columnTHType ci) |])+ `T.into`+ $(varE $ mkName $ fieldNameModifier props $+ Text.unpack $ columnName ci) |]+++makeDBTypes :: Properties -> Name -> [TableInfo] -> Q [Dec]+makeDBTypes props dbName tis =+ liftA2 (++) classDecs $ concat <$> traverse tableDecs tis+ where+ classDecs :: Q [Dec]+ classDecs = traverse (fieldClass props dbName) $ Set.toList duplicateCols++ tableDecs :: TableInfo -> Q [Dec]+ tableDecs ti = concat <$> sequence+ [ makeTable props dbName ti+ , fmap concat $ traverse (makeField props dbName) $+ filter (not . duplicateCol . getFieldName) $ tableColumns ti+ , traverse (fieldInstance props) $ filter (duplicateCol . getFieldName) $+ tableColumns ti+ , if includeInsertor props+ then (:) <$> insertorType props ti <*> insertor props dbName ti+ else pure mempty+ ]++ getFieldName :: ColumnInfo -> String+ getFieldName ti = fieldNameModifier props $ Text.unpack $ columnName ti++ duplicateCols :: Set.Set String+ duplicateCols = Set.fromList $ map fst $ filter ((> 1) . snd) $ Map.toList $+ Map.fromListWith (+) $+ map (\c -> (getFieldName c, 1 :: Int)) $+ tis >>= tableColumns+ duplicateCol :: String -> Bool+ duplicateCol c = c `Set.member` duplicateCols