diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,14 @@ +# 0.6.0.0 + +* Mostly complete SQL92, SQL99 support +* Piecemeal support for SQL2003 and SQL2008 features +* Completely modular backends +* Various bug improvements and fixes + +# 0.5.0.0 + +* Move to using finally tagless style for SQL generation +* Split out backends from `beam-core` +* Allow non-table entities to be stored in databases +* Basic migrations support + diff --git a/Database/Beam.hs b/Database/Beam.hs new file mode 100644 --- /dev/null +++ b/Database/Beam.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs #-} +-- | Top-level Beam module. This module re-exports all the symbols +-- necessary for most common user operations. +-- +-- The most interesting modules are 'Database.Beam.Schema' and 'Database.Beam.Query'. +-- +-- This is mainly reference documentation. Most users will want to consult the +-- [manual](https://tathougies.github.io/beam). +-- +-- The API has mostly stayed the same, but not all the examples given there compile. +module Database.Beam + ( module Database.Beam.Query + , module Database.Beam.Schema + , MonadBeam(withDatabase, withDatabaseDebug) + , Auto(..) + , FromBackendRow(..) + + -- * Re-exports + , MonadIO(..), Typeable + , Generic, Identity ) where + +import Database.Beam.Query +import Database.Beam.Schema +import Database.Beam.Backend + +import Control.Monad.Identity +import Control.Monad.IO.Class (MonadIO(..)) + +import Data.Typeable + +import GHC.Generics diff --git a/Database/Beam/Backend.hs b/Database/Beam/Backend.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend.hs @@ -0,0 +1,6 @@ +module Database.Beam.Backend + ( module Database.Beam.Backend.Types + , MonadBeam(..) ) where + +import Database.Beam.Backend.Types +import Database.Beam.Backend.SQL diff --git a/Database/Beam/Backend/SQL.hs b/Database/Beam/Backend/SQL.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL.hs @@ -0,0 +1,93 @@ +module Database.Beam.Backend.SQL + ( module Database.Beam.Backend.SQL.SQL2003 + , module Database.Beam.Backend.SQL.Types + , module Database.Beam.Backend.Types + + , MonadBeam(..) ) where + +import Database.Beam.Backend.SQL.SQL2003 +import Database.Beam.Backend.SQL.Types +import Database.Beam.Backend.Types + +import Control.Monad.IO.Class + +-- * MonadBeam class + +-- | A class that ties together a Sql syntax, backend, handle, and monad type. +-- +-- Functional dependencies mean that only the backend type or the handle need +-- to be specified. +-- +-- Intuitively, this allows you to write code that performs database commands +-- without having to know the underlying API. As long as you have an +-- appropriate handle from a database library that Beam can use, you can use +-- the 'MonadBeam' methods to execute the query. +-- +-- Provided here is a low-level interface. Most often, you'll only need the +-- 'withDatabase' and 'withDatabaseDebug' function. The 'run*' functions are +-- wrapped by the appropriate functions in 'Database.Beam.Query'. +-- +-- This interface is very high-level and isn't meant to expose the full power +-- of the underlying database. Namely, it only supports simple data retrieval +-- strategies. More complicated strategies (for example, Postgres's @COPY@) +-- are supported in individual backends. See the documentation of those +-- backends for more details. +class (BeamBackend be, Monad m, MonadIO m, Sql92SanityCheck syntax) => + MonadBeam syntax be handle m | m -> syntax be handle, be -> m, handle -> m where + + {-# MINIMAL withDatabaseDebug, runReturningMany #-} + + -- | Run a database action, and log debugging information about statements + -- executed using the specified 'IO' action. + withDatabaseDebug :: (String -> IO ()) -- ^ Database statement logging function + -> handle -- ^ The database connection handle against which to execute the action + -> m a -- ^ The database action + -> IO a + withDatabase :: handle -> m a -> IO a + + -- | Run a database action, but don't report any debug information + withDatabase = withDatabaseDebug (\_ -> pure ()) + + -- | Run a query determined by the given syntax, providing an action that will + -- be called to consume the results from the database (if any). The action + -- will get a reader action that can be used to fetch the next row. When + -- this reader action returns 'Nothing', there are no rows left to consume. + -- When the reader action returns, the database result is freed. + runReturningMany :: FromBackendRow be x + => syntax -- ^ The query to run + -> (m (Maybe x) -> m a) -- ^ Reader action that will be called with a function to fetch the next row + -> m a + + -- | Run the given command and don't consume any results. Useful for DML + -- statements like INSERT, UPDATE, and DELETE, or DDL statements. + runNoReturn :: syntax -> m () + runNoReturn cmd = + runReturningMany cmd $ \(_ :: m (Maybe ())) -> pure () + + -- | Run the given command and fetch the unique result. The result is + -- 'Nothing' if either no results are returned or more than one result is + -- returned. + runReturningOne :: FromBackendRow be x => syntax -> m (Maybe x) + runReturningOne cmd = + runReturningMany cmd $ \next -> + do a <- next + case a of + Nothing -> pure Nothing + Just x -> do + a' <- next + case a' of + Nothing -> pure (Just x) + Just _ -> pure Nothing + + -- | Run the given command, collect all the results, and return them as a + -- list. May be more convenient than 'runReturningMany', but reads the entire + -- result set into memory. + runReturningList :: FromBackendRow be x => syntax -> m [x] + runReturningList cmd = + runReturningMany cmd $ \next -> + let collectM acc = do + a <- next + case a of + Nothing -> pure (acc []) + Just x -> collectM (acc . (x:)) + in collectM id diff --git a/Database/Beam/Backend/SQL/AST.hs b/Database/Beam/Backend/SQL/AST.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/AST.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +-- | This module implements an AST type for SQL92. It allows us to realize +-- the call structure of the builders defined in 'Database.Beam.Backend.SQL92' +module Database.Beam.Backend.SQL.AST where + +import Prelude hiding (Ordering) + +import Database.Beam.Backend.SQL.SQL92 +import Database.Beam.Backend.SQL.SQL99 +import Database.Beam.Backend.SQL.Types +import Database.Beam.Backend.Types + +import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Time +import Data.Word (Word16, Word32, Word64) +import Data.Typeable +import Data.Int + +data Command + = SelectCommand Select + | InsertCommand Insert + | UpdateCommand Update + | DeleteCommand Delete + deriving (Show, Eq) + +instance IsSql92Syntax Command where + type Sql92SelectSyntax Command = Select + type Sql92UpdateSyntax Command = Update + type Sql92InsertSyntax Command = Insert + type Sql92DeleteSyntax Command = Delete + + selectCmd = SelectCommand + insertCmd = InsertCommand + updateCmd = UpdateCommand + deleteCmd = DeleteCommand + +data Select + = Select + { selectTable :: SelectTable + , selectOrdering :: [ Ordering ] + , selectLimit, selectOffset :: Maybe Integer } + deriving (Show, Eq) + +instance IsSql92SelectSyntax Select where + type Sql92SelectSelectTableSyntax Select = SelectTable + type Sql92SelectOrderingSyntax Select = Ordering + + selectStmt = Select + +data SelectTable + = SelectTable + { selectQuantifier :: Maybe SetQuantifier + , selectProjection :: Projection + , selectFrom :: Maybe From + , selectWhere :: Maybe Expression + , selectGrouping :: Maybe Grouping + , selectHaving :: Maybe Expression } + | UnionTables Bool SelectTable SelectTable + | IntersectTables Bool SelectTable SelectTable + | ExceptTable Bool SelectTable SelectTable + deriving (Show, Eq) + +instance IsSql92SelectTableSyntax SelectTable where + type Sql92SelectTableSelectSyntax SelectTable = Select + type Sql92SelectTableExpressionSyntax SelectTable = Expression + type Sql92SelectTableProjectionSyntax SelectTable = Projection + type Sql92SelectTableFromSyntax SelectTable = From + type Sql92SelectTableGroupingSyntax SelectTable = Grouping + type Sql92SelectTableSetQuantifierSyntax SelectTable = SetQuantifier + + selectTableStmt = SelectTable + unionTables = UnionTables + intersectTables = IntersectTables + exceptTable = ExceptTable + +data Insert + = Insert + { insertTable :: Text + , insertFields :: [ Text ] + , insertValues :: InsertValues } + deriving (Show, Eq) + +instance IsSql92InsertSyntax Insert where + type Sql92InsertValuesSyntax Insert = InsertValues + + insertStmt = Insert + +data InsertValues + = InsertValues + { insertValuesExpressions :: [ [ Expression ] ] } + | InsertSelect + { insertSelectStmt :: Select } + deriving (Show, Eq) + +instance IsSql92InsertValuesSyntax InsertValues where + type Sql92InsertValuesExpressionSyntax InsertValues = Expression + type Sql92InsertValuesSelectSyntax InsertValues = Select + + insertSqlExpressions = InsertValues + insertFromSql = InsertSelect + +data Update + = Update + { updateTable :: Text + , updateFields :: [ (FieldName, Expression) ] + , updateWhere :: Maybe Expression } + deriving (Show, Eq) + +instance IsSql92UpdateSyntax Update where + type Sql92UpdateFieldNameSyntax Update = FieldName + type Sql92UpdateExpressionSyntax Update = Expression + + updateStmt = Update + +data Delete + = Delete + { deleteTable :: Text + , deleteWhere :: Maybe Expression } + deriving (Show, Eq) + +instance IsSql92DeleteSyntax Delete where + type Sql92DeleteExpressionSyntax Delete = Expression + + deleteStmt = Delete + +data FieldName + = QualifiedField Text Text + | UnqualifiedField Text + deriving (Show, Eq) + +instance IsSql92FieldNameSyntax FieldName where + qualifiedField = QualifiedField + unqualifiedField = UnqualifiedField + +data ComparatorQuantifier + = ComparatorQuantifierAny + | ComparatorQuantifierAll + deriving (Show, Eq) + +instance IsSql92QuantifierSyntax ComparatorQuantifier where + quantifyOverAll = ComparatorQuantifierAll + quantifyOverAny = ComparatorQuantifierAny + +data ExtractField + = ExtractFieldTimeZoneHour + | ExtractFieldTimeZoneMinute + + | ExtractFieldDateTimeYear + | ExtractFieldDateTimeMonth + | ExtractFieldDateTimeDay + | ExtractFieldDateTimeHour + | ExtractFieldDateTimeMinute + | ExtractFieldDateTimeSecond + deriving (Show, Eq) + +data CastTarget + = CastTargetDataType DataType + | CastTargetDomainName Text + deriving (Show, Eq) + +data DataType + = DataTypeChar Bool {- Varying -} (Maybe Int) + | DataTypeNationalChar Bool (Maybe Int) + | DataTypeBit Bool (Maybe Int) + | DataTypeNumeric Int (Maybe Int) + | DataTypeInteger + | DataTypeSmallInt + | DataTypeFloat (Maybe Int) + | DataTypeReal + | DataTypeDoublePrecision + | DataTypeDate + | DataTypeTime (Maybe Word) {- time fractional seconds precision -} Bool {- With time zone -} + | DataTypeTimeStamp (Maybe Word) Bool + | DataTypeInterval ExtractField + | DataTypeIntervalFromTo ExtractField ExtractField + deriving (Show, Eq) + +data SetQuantifier + = SetQuantifierAll | SetQuantifierDistinct + deriving (Show, Eq) + +instance IsSql92AggregationSetQuantifierSyntax SetQuantifier where + setQuantifierDistinct = SetQuantifierDistinct + setQuantifierAll = SetQuantifierAll + +data Expression + = ExpressionValue Value + | ExpressionDefault + | ExpressionRow [ Expression ] + + | ExpressionIn Expression [ Expression ] + + | ExpressionIsNull Expression + | ExpressionIsNotNull Expression + | ExpressionIsTrue Expression + | ExpressionIsNotTrue Expression + | ExpressionIsFalse Expression + | ExpressionIsNotFalse Expression + | ExpressionIsUnknown Expression + | ExpressionIsNotUnknown Expression + + | ExpressionCase [(Expression, Expression)] Expression + | ExpressionCoalesce [Expression] + | ExpressionNullIf Expression Expression + + | ExpressionFieldName FieldName + + | ExpressionBetween Expression Expression Expression + | ExpressionBinOp Text Expression Expression + | ExpressionCompOp Text (Maybe ComparatorQuantifier) Expression Expression + | ExpressionUnOp Text Expression + + | ExpressionPosition Expression Expression + | ExpressionCast Expression CastTarget + | ExpressionExtract ExtractField Expression + | ExpressionCharLength Expression + | ExpressionOctetLength Expression + | ExpressionBitLength Expression + | ExpressionAbs Expression + + | ExpressionFunctionCall Expression [ Expression ] + | ExpressionInstanceField Expression Text + | ExpressionRefField Expression Text + + | ExpressionCountAll + | ExpressionAgg Text (Maybe SetQuantifier) [ Expression ] + + | ExpressionSubquery Select + | ExpressionUnique Select + | ExpressionDistinct Select + | ExpressionExists Select + + | ExpressionCurrentTimestamp + deriving (Show, Eq) + +instance IsSqlExpressionSyntaxStringType Expression Text + +instance IsSql92ExpressionSyntax Expression where + type Sql92ExpressionQuantifierSyntax Expression = ComparatorQuantifier + type Sql92ExpressionValueSyntax Expression = Value + type Sql92ExpressionSelectSyntax Expression = Select + type Sql92ExpressionFieldNameSyntax Expression = FieldName + type Sql92ExpressionCastTargetSyntax Expression = CastTarget + type Sql92ExpressionExtractFieldSyntax Expression = ExtractField + + valueE = ExpressionValue + rowE = ExpressionRow + + isNullE = ExpressionIsNull + isNotNullE = ExpressionIsNotNull + isTrueE = ExpressionIsTrue + isNotTrueE = ExpressionIsNotTrue + isFalseE = ExpressionIsFalse + isNotFalseE = ExpressionIsNotFalse + isUnknownE = ExpressionIsUnknown + isNotUnknownE = ExpressionIsNotUnknown + + caseE = ExpressionCase + coalesceE = ExpressionCoalesce + nullIfE = ExpressionNullIf + positionE = ExpressionPosition + extractE = ExpressionExtract + castE = ExpressionCast + + fieldE = ExpressionFieldName + + betweenE = ExpressionBetween + andE = ExpressionBinOp "AND" + orE = ExpressionBinOp "OR" + + eqE = ExpressionCompOp "==" + neqE = ExpressionCompOp "<>" + ltE = ExpressionCompOp "<" + gtE = ExpressionCompOp ">" + leE = ExpressionCompOp "<=" + geE = ExpressionCompOp ">=" + addE = ExpressionBinOp "+" + subE = ExpressionBinOp "-" + mulE = ExpressionBinOp "*" + divE = ExpressionBinOp "/" + modE = ExpressionBinOp "%" + likeE = ExpressionBinOp "LIKE" + overlapsE = ExpressionBinOp "OVERLAPS" + + notE = ExpressionUnOp "NOT" + negateE = ExpressionUnOp "-" + + charLengthE = ExpressionCharLength + octetLengthE = ExpressionOctetLength + bitLengthE = ExpressionBitLength + absE = ExpressionAbs + + subqueryE = ExpressionSubquery + uniqueE = ExpressionUnique + existsE = ExpressionExists + + currentTimestampE = ExpressionCurrentTimestamp + + defaultE = ExpressionDefault + inE = ExpressionIn + +instance IsSql99ExpressionSyntax Expression where + distinctE = ExpressionDistinct + similarToE = ExpressionBinOp "SIMILAR TO" + functionCallE = ExpressionFunctionCall + instanceFieldE = ExpressionInstanceField + refFieldE = ExpressionRefField + +instance IsSql92AggregationExpressionSyntax Expression where + type Sql92AggregationSetQuantifierSyntax Expression = SetQuantifier + + countAllE = ExpressionCountAll + countE q = ExpressionAgg "COUNT" q . pure + sumE q = ExpressionAgg "SUM" q . pure + minE q = ExpressionAgg "MIN" q . pure + maxE q = ExpressionAgg "MAX" q . pure + avgE q = ExpressionAgg "AVG" q . pure + +newtype Projection + = ProjExprs [ (Expression, Maybe Text ) ] + deriving (Show, Eq) + +instance IsSql92ProjectionSyntax Projection where + type Sql92ProjectionExpressionSyntax Projection = Expression + + projExprs = ProjExprs + +data Ordering + = OrderingAsc Expression + | OrderingDesc Expression + deriving (Show, Eq) + +instance IsSql92OrderingSyntax Ordering where + type Sql92OrderingExpressionSyntax Ordering = Expression + + ascOrdering = OrderingAsc + descOrdering = OrderingDesc + +newtype Grouping = Grouping [ Expression ] deriving (Show, Eq) + +instance IsSql92GroupingSyntax Grouping where + type Sql92GroupingExpressionSyntax Grouping = Expression + + groupByExpressions = Grouping + +data TableSource + = TableNamed Text + | TableFromSubSelect Select + deriving (Show, Eq) + +instance IsSql92TableSourceSyntax TableSource where + type Sql92TableSourceSelectSyntax TableSource = Select + + tableNamed = TableNamed + tableFromSubSelect = TableFromSubSelect + +data From + = FromTable TableSource (Maybe Text) + | InnerJoin From From (Maybe Expression) + | LeftJoin From From (Maybe Expression) + | RightJoin From From (Maybe Expression) + | OuterJoin From From (Maybe Expression) + deriving (Show, Eq) + +instance IsSql92FromSyntax From where + type Sql92FromTableSourceSyntax From = TableSource + type Sql92FromExpressionSyntax From = Expression + + fromTable = FromTable + innerJoin = InnerJoin + leftJoin = LeftJoin + rightJoin = RightJoin + +data Value where + Value :: (Show a, Eq a, Typeable a) => a -> Value + +#define VALUE_SYNTAX_INSTANCE(ty) instance HasSqlValueSyntax Value ty where { sqlValueSyntax = Value } +VALUE_SYNTAX_INSTANCE(Int) +VALUE_SYNTAX_INSTANCE(Int16) +VALUE_SYNTAX_INSTANCE(Int32) +VALUE_SYNTAX_INSTANCE(Int64) +VALUE_SYNTAX_INSTANCE(Word) +VALUE_SYNTAX_INSTANCE(Word16) +VALUE_SYNTAX_INSTANCE(Word32) +VALUE_SYNTAX_INSTANCE(Word64) +VALUE_SYNTAX_INSTANCE(Integer) +VALUE_SYNTAX_INSTANCE(String) +VALUE_SYNTAX_INSTANCE(Text) +VALUE_SYNTAX_INSTANCE(ByteString) +VALUE_SYNTAX_INSTANCE(LocalTime) +VALUE_SYNTAX_INSTANCE(UTCTime) +VALUE_SYNTAX_INSTANCE(Day) +VALUE_SYNTAX_INSTANCE(TimeOfDay) +VALUE_SYNTAX_INSTANCE(SqlNull) +VALUE_SYNTAX_INSTANCE(Double) +VALUE_SYNTAX_INSTANCE(Bool) + +instance HasSqlValueSyntax Value x => HasSqlValueSyntax Value (Maybe x) where + sqlValueSyntax (Just x) = sqlValueSyntax x + sqlValueSyntax Nothing = sqlValueSyntax SqlNull + +instance HasSqlValueSyntax Value (Maybe x) => HasSqlValueSyntax Value (Auto x) where + sqlValueSyntax (Auto x) = sqlValueSyntax x + +instance Eq Value where + Value a == Value b = + case cast a of + Just a' -> a' == b + Nothing -> False +instance Show Value where + showsPrec prec (Value a) = + showParen (prec > app_prec) $ + ("Value " ++ ). + showsPrec (app_prec + 1) a + where app_prec = 10 diff --git a/Database/Beam/Backend/SQL/BeamExtensions.hs b/Database/Beam/Backend/SQL/BeamExtensions.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/BeamExtensions.hs @@ -0,0 +1,37 @@ +module Database.Beam.Backend.SQL.BeamExtensions where + +import Database.Beam.Backend +import Database.Beam.Backend.SQL +import Database.Beam.Query +import Database.Beam.Query.Internal +import Database.Beam.Schema + +import Control.Monad.Identity + +--import GHC.Generics + +-- | 'MonadBeam's that support returning the results of an insert statement. +-- Useful for discovering the real value of a defaulted value. +-- +-- Unfortunately, SQL has no standard way of doing this, so it is provided as +-- a beam extension. +class MonadBeam syntax be handle m => + MonadBeamInsertReturning syntax be handle m | m -> syntax be handle, be -> m, handle -> m where + runInsertReturningList + :: ( Beamable table + , Projectible (Sql92ExpressionSyntax syntax) (table (QExpr (Sql92ExpressionSyntax syntax) ())) + , FromBackendRow be (table Identity) ) + => DatabaseEntity be db (TableEntity table) + -> SqlInsertValues (Sql92InsertValuesSyntax (Sql92InsertSyntax syntax)) table + -> m [table Identity] + +class MonadBeam syntax be handle m => + MonadBeamUpdateReturning syntax be handle m | m -> syntax be handle, be -> m, handle -> m where + runUpdateReturningList + :: ( Beamable table + , Projectible (Sql92ExpressionSyntax syntax) (table (QExpr (Sql92ExpressionSyntax syntax) ())) + , FromBackendRow be (table Identity) ) + => DatabaseEntity be db (TableEntity table) + -> (forall s. table (QField s) -> [ QAssignment (Sql92UpdateFieldNameSyntax (Sql92UpdateSyntax syntax)) (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s ]) + -> (forall s. table (QExpr (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s) -> QExpr (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s Bool) + -> m [table Identity] diff --git a/Database/Beam/Backend/SQL/Builder.hs b/Database/Beam/Backend/SQL/Builder.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/Builder.hs @@ -0,0 +1,502 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE PolyKinds #-} + +-- | Provides a syntax 'SqlSyntaxBuilder' that uses a +-- 'Data.ByteString.Builder.Builder' to construct SQL expressions as strings. +-- Mainly serves as documentation for how to write a syntax for backends. Note +-- that, although you can use this to turn most 'Q' and 'QGenExpr's into +-- 'ByteString' queries, it is /very unwise/ to ship these to the database. +-- This module does not take into account server-specific quoting. Some +-- backends are very particular to quoting, and shipping arbitrary +-- 'ByteString's as queries can expose you to SQL injection vulnerabilities. +-- Always use the provided backends to submit queries and data manipulation +-- commands to the database. +module Database.Beam.Backend.SQL.Builder + ( SqlSyntaxBuilder(..), SqlSyntaxBackend + , buildSepBy + , quoteSql + , renderSql ) where + +import Database.Beam.Backend.SQL + +import Control.Monad.IO.Class + +import Data.ByteString (ByteString) +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Text.Encoding as TE +import qualified Data.Text as T +import Data.Text (Text) + +import Data.Coerce +import Data.Int +import Data.Hashable +import Data.Monoid +import Data.String + +-- | The main syntax. A wrapper over 'Builder' +newtype SqlSyntaxBuilder + = SqlSyntaxBuilder { buildSql :: Builder } + +instance Hashable SqlSyntaxBuilder where + hashWithSalt salt (SqlSyntaxBuilder b) = hashWithSalt salt (toLazyByteString b) + +instance Show SqlSyntaxBuilder where + showsPrec prec (SqlSyntaxBuilder s) = + showParen (prec > 10) $ + showString "SqlSyntaxBuilder (" . + shows (toLazyByteString s) . + showString ")" + +instance Eq SqlSyntaxBuilder where + a == b = toLazyByteString (buildSql a) == toLazyByteString (buildSql b) + +instance Monoid SqlSyntaxBuilder where + mempty = SqlSyntaxBuilder mempty + mappend (SqlSyntaxBuilder a) (SqlSyntaxBuilder b) = + SqlSyntaxBuilder (mappend a b) + +instance IsSql92Syntax SqlSyntaxBuilder where + type Sql92SelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92InsertSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92DeleteSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92UpdateSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + selectCmd = id + insertCmd = id + updateCmd = id + deleteCmd = id + +instance IsSql92SelectSyntax SqlSyntaxBuilder where + type Sql92SelectSelectTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92SelectOrderingSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + selectStmt tableSrc ordering limit offset = + SqlSyntaxBuilder $ + buildSql tableSrc <> + ( case ordering of + [] -> mempty + _ -> byteString " ORDER BY " <> + buildSepBy (byteString ", ") (map buildSql ordering) ) <> + maybe mempty (\l -> byteString " LIMIT " <> byteString (fromString (show l))) limit <> + maybe mempty (\o -> byteString " OFFSET " <> byteString (fromString (show o))) offset + +instance IsSql92GroupingSyntax SqlSyntaxBuilder where + type Sql92GroupingExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + groupByExpressions es = + SqlSyntaxBuilder $ + buildSepBy (byteString ", ") (map buildSql es) + +instance IsSql92SelectTableSyntax SqlSyntaxBuilder where + type Sql92SelectTableSelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92SelectTableExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92SelectTableProjectionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92SelectTableFromSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92SelectTableGroupingSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92SelectTableSetQuantifierSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + selectTableStmt setQuantifier proj from where_ grouping having = + SqlSyntaxBuilder $ + byteString "SELECT " <> + maybe mempty (\setQuantifier' -> buildSql setQuantifier' <> byteString " ") setQuantifier <> + buildSql proj <> + maybe mempty ((byteString " FROM " <>) . buildSql) from <> + maybe mempty (\w -> byteString " WHERE " <> buildSql w) where_ <> + maybe mempty (\g -> byteString " GROUP BY " <> buildSql g) grouping <> + maybe mempty (\e -> byteString " HAVING " <> buildSql e) having + + unionTables = tableOp "UNION" + intersectTables = tableOp "INTERSECT" + exceptTable = tableOp "EXCEPT" + +tableOp :: ByteString -> Bool -> SqlSyntaxBuilder -> SqlSyntaxBuilder -> SqlSyntaxBuilder +tableOp op all a b = + SqlSyntaxBuilder $ + byteString "(" <> buildSql a <> byteString ") " <> + byteString op <> if all then byteString " ALL " else mempty <> + byteString " (" <> buildSql b <> byteString ")" + +instance IsSql92InsertSyntax SqlSyntaxBuilder where + type Sql92InsertValuesSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + insertStmt table fields values = + SqlSyntaxBuilder $ + byteString "INSERT INTO " <> quoteSql table <> + byteString "(" <> buildSepBy (byteString ", ") (map quoteSql fields) <> byteString ") " <> + buildSql values + +instance IsSql92InsertValuesSyntax SqlSyntaxBuilder where + type Sql92InsertValuesExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92InsertValuesSelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + insertSqlExpressions values = + SqlSyntaxBuilder $ + byteString "VALUES " <> + buildSepBy (byteString ", ") (map mkValues values) + where mkValues values' = + byteString "(" <> + buildSepBy (byteString ", ") (map buildSql values') <> + byteString ")" + + insertFromSql select = select + +instance IsSql92UpdateSyntax SqlSyntaxBuilder where + type Sql92UpdateFieldNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92UpdateExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + updateStmt table set where_ = + SqlSyntaxBuilder $ + byteString "UPDATE " <> quoteSql table <> + (case set of + [] -> mempty + es -> byteString " SET " <> buildSepBy (byteString ", ") (map (\(field, expr) -> buildSql field <> byteString "=" <> buildSql expr) es)) <> + maybe mempty (\where_ -> byteString " WHERE " <> buildSql where_) where_ + +instance IsSql92DeleteSyntax SqlSyntaxBuilder where + type Sql92DeleteExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + deleteStmt tbl where_ = + SqlSyntaxBuilder $ + byteString "DELETE FROM " <> quoteSql tbl <> + maybe mempty (\where_ -> byteString " WHERE " <> buildSql where_) where_ + +instance IsSql92FieldNameSyntax SqlSyntaxBuilder where + qualifiedField a b = + SqlSyntaxBuilder $ + byteString "`" <> stringUtf8 (T.unpack a) <> byteString "`.`" <> + stringUtf8 (T.unpack b) <> byteString "`" + unqualifiedField a = + SqlSyntaxBuilder $ + byteString "`" <> stringUtf8 (T.unpack a) <> byteString "`" + +instance IsSqlExpressionSyntaxStringType SqlSyntaxBuilder Text + +instance IsSql92QuantifierSyntax SqlSyntaxBuilder where + quantifyOverAll = SqlSyntaxBuilder "ALL" + quantifyOverAny = SqlSyntaxBuilder "ANY" + +instance IsSql92ExpressionSyntax SqlSyntaxBuilder where + type Sql92ExpressionValueSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92ExpressionSelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92ExpressionFieldNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92ExpressionQuantifierSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92ExpressionCastTargetSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92ExpressionExtractFieldSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + rowE vs = SqlSyntaxBuilder $ + byteString "(" <> + buildSepBy (byteString ", ") (map buildSql (coerce vs)) <> + byteString ")" + isNotNullE = sqlPostFixOp "IS NOT NULL" + isNullE = sqlPostFixOp "IS NULL" + isTrueE = sqlPostFixOp "IS TRUE" + isFalseE = sqlPostFixOp "IS FALSE" + isUnknownE = sqlPostFixOp "IS UNKNOWN" + isNotTrueE = sqlPostFixOp "IS NOT TRUE" + isNotFalseE = sqlPostFixOp "IS NOT FALSE" + isNotUnknownE = sqlPostFixOp "IS NOT UNKNOWN" + caseE cases else_ = + SqlSyntaxBuilder $ + byteString "CASE " <> + foldMap (\(cond, res) -> byteString "WHEN " <> buildSql cond <> + byteString " THEN " <> buildSql res <> byteString " ") cases <> + byteString "ELSE " <> buildSql else_ <> byteString " END" + fieldE = id + + nullIfE a b = sqlFuncOp "NULLIF" $ + SqlSyntaxBuilder $ + byteString "(" <> buildSql a <> byteString "), (" <> + buildSql b <> byteString ")" + positionE needle haystack = + SqlSyntaxBuilder $ byteString "POSITION(" <> buildSql needle <> byteString ") IN (" <> buildSql haystack <> byteString ")" + extractE what from = + SqlSyntaxBuilder $ buildSql what <> byteString " FROM (" <> buildSql from <> byteString ")" + absE = sqlFuncOp "ABS" + charLengthE = sqlFuncOp "CHAR_LENGTH" + bitLengthE = sqlFuncOp "BIT_LENGTH" + octetLengthE = sqlFuncOp "OCTET_LENGTH" + + addE = sqlBinOp "+" + likeE = sqlBinOp "LIKE" + subE = sqlBinOp "-" + mulE = sqlBinOp "*" + divE = sqlBinOp "/" + modE = sqlBinOp "%" + overlapsE = sqlBinOp "OVERLAPS" + andE = sqlBinOp "AND" + orE = sqlBinOp "OR" + castE a ty = SqlSyntaxBuilder $ + byteString "CAST((" <> buildSql a <> byteString ") AS " <> buildSql ty <> byteString ")" + coalesceE es = SqlSyntaxBuilder $ + byteString "COALESCE(" <> + buildSepBy (byteString ", ") (map (\e -> byteString"(" <> buildSql e <> byteString ")") es) <> + byteString ")" + betweenE a b c = SqlSyntaxBuilder $ + byteString "(" <> buildSql a <> byteString ") BETWEEN (" <> buildSql b <> byteString ") AND (" <> buildSql c <> byteString ")" + eqE = sqlCompOp "=" + neqE = sqlCompOp "<>" + ltE = sqlCompOp "<" + gtE = sqlCompOp ">" + leE = sqlCompOp "<=" + geE = sqlCompOp ">=" + negateE = sqlUnOp "-" + notE = sqlUnOp "NOT" + existsE = sqlUnOp "EXISTS" + uniqueE = sqlUnOp "UNIQUE" + subqueryE a = SqlSyntaxBuilder $ byteString "(" <> buildSql a <> byteString ")" + valueE = id + + currentTimestampE = SqlSyntaxBuilder (byteString "CURRENT_TIMESTAMP") + + defaultE = SqlSyntaxBuilder (byteString "DEFAULT") + inE a es = SqlSyntaxBuilder (byteString "(" <> buildSql a <> byteString ") IN (" <> + buildSepBy (byteString ", ") (map buildSql es)) + +instance IsSql99ExpressionSyntax SqlSyntaxBuilder where + distinctE = sqlUnOp "DISTINCT" + similarToE = sqlBinOp "SIMILAR TO" + + functionCallE function args = + SqlSyntaxBuilder $ + buildSql function <> + byteString "(" <> + buildSepBy (byteString ", ") (map buildSql args) <> + byteString ")" + + instanceFieldE e fieldNm = + SqlSyntaxBuilder $ + byteString "(" <> buildSql e <> byteString ")." <> byteString (TE.encodeUtf8 fieldNm) + refFieldE e fieldNm = + SqlSyntaxBuilder $ + byteString "(" <> buildSql e <> byteString ")->" <> byteString (TE.encodeUtf8 fieldNm) + +instance IsSql2003ExpressionSyntax SqlSyntaxBuilder where + type Sql2003ExpressionWindowFrameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + overE expr frame = + SqlSyntaxBuilder $ + buildSql expr <> buildSql frame + +instance IsSql2003WindowFrameSyntax SqlSyntaxBuilder where + type Sql2003WindowFrameExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql2003WindowFrameOrderingSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql2003WindowFrameBoundsSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + frameSyntax partition_ ordering_ bounds_ = + SqlSyntaxBuilder $ + byteString " OVER (" <> + maybe mempty (\p -> byteString "PARTITION BY " <> buildSepBy (byteString ", ") (map buildSql p)) partition_ <> + maybe mempty (\o -> byteString " ORDER BY " <> buildSepBy (byteString ", ") (map buildSql o)) ordering_ <> + maybe mempty (\b -> byteString " ROWS " <> buildSql b) bounds_ <> + byteString ")" + +instance IsSql2003ExpressionElementaryOLAPOperationsSyntax SqlSyntaxBuilder where + filterAggE agg_ filter_ = + SqlSyntaxBuilder $ + buildSql agg_ <> byteString " FILTER (WHERE " <> buildSql filter_ <> byteString ")" + rankAggE = SqlSyntaxBuilder "RANK()" + +instance IsSql2003ExpressionAdvancedOLAPOperationsSyntax SqlSyntaxBuilder where + denseRankAggE = SqlSyntaxBuilder "DENSE_RANK()" + percentRankAggE = SqlSyntaxBuilder "PERCENT_RANK()" + cumeDistAggE = SqlSyntaxBuilder "CUME_DIST()" + +data SqlWindowFrameBound = SqlWindowFrameUnbounded + | SqlWindowFrameBounded Int + deriving Show + +instance IsSql2003WindowFrameBoundsSyntax SqlSyntaxBuilder where + type Sql2003WindowFrameBoundsBoundSyntax SqlSyntaxBuilder = SqlWindowFrameBound + + fromToBoundSyntax SqlWindowFrameUnbounded Nothing = SqlSyntaxBuilder "UNBOUNDED PRECEDING" + fromToBoundSyntax (SqlWindowFrameBounded 0) Nothing = SqlSyntaxBuilder "CURRENT ROW" + fromToBoundSyntax (SqlWindowFrameBounded n) Nothing = SqlSyntaxBuilder (fromString (show n) <> " PRECEDING") + fromToBoundSyntax SqlWindowFrameUnbounded (Just SqlWindowFrameUnbounded) = + SqlSyntaxBuilder "BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING" + fromToBoundSyntax SqlWindowFrameUnbounded (Just (SqlWindowFrameBounded 0)) = + SqlSyntaxBuilder "BETWEEN UNBOUNDED PRECEDING AND CURRENT ROW" + fromToBoundSyntax SqlWindowFrameUnbounded (Just (SqlWindowFrameBounded n)) = + SqlSyntaxBuilder ("BETWEEN UNBOUNDED PRECEDING AND " <> fromString (show n) <> " FOLLOWING") + fromToBoundSyntax (SqlWindowFrameBounded 0) (Just SqlWindowFrameUnbounded) = + SqlSyntaxBuilder "BETWEEN CURRENT ROW AND UNBOUNDED FOLLOWING" + fromToBoundSyntax (SqlWindowFrameBounded 0) (Just (SqlWindowFrameBounded 0)) = + SqlSyntaxBuilder "BETWEEN CURRENT ROW AND CURRENT ROW" + fromToBoundSyntax (SqlWindowFrameBounded 0) (Just (SqlWindowFrameBounded n)) = + SqlSyntaxBuilder ("BETWEEN CURRENT ROW AND " <> fromString (show n) <> " FOLLOWING") + fromToBoundSyntax (SqlWindowFrameBounded n) (Just SqlWindowFrameUnbounded) = + SqlSyntaxBuilder ("BETWEEN " <> fromString (show n) <> " PRECEDING AND UNBOUNDED FOLLOWING") + fromToBoundSyntax (SqlWindowFrameBounded n) (Just (SqlWindowFrameBounded 0)) = + SqlSyntaxBuilder ("BETWEEN " <> fromString (show n) <> " PRECEDING AND CURRENT ROW") + fromToBoundSyntax (SqlWindowFrameBounded n1) (Just (SqlWindowFrameBounded n2)) = + SqlSyntaxBuilder ("BETWEEN " <> fromString (show n1) <> " PRECEDING AND " <> fromString (show n2) <> " FOLLOWING") + +instance IsSql2003WindowFrameBoundSyntax SqlWindowFrameBound where + unboundedSyntax = SqlWindowFrameUnbounded + nrowsBoundSyntax = SqlWindowFrameBounded + +instance IsSql92AggregationExpressionSyntax SqlSyntaxBuilder where + type Sql92AggregationSetQuantifierSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + countAllE = SqlSyntaxBuilder (byteString "COUNT(*)") + countE q x = SqlSyntaxBuilder (byteString "COUNT(" <> maybe mempty (\q' -> buildSql q' <> byteString " ") q <> buildSql x <> byteString ")") + avgE q x = SqlSyntaxBuilder (byteString "AVG(" <> maybe mempty (\q' -> buildSql q' <> byteString " ") q <> buildSql x <> byteString ")") + minE q x = SqlSyntaxBuilder (byteString "MIN(" <> maybe mempty (\q' -> buildSql q' <> byteString " ") q <> buildSql x <> byteString ")") + maxE q x = SqlSyntaxBuilder (byteString "MAX(" <> maybe mempty (\q' -> buildSql q' <> byteString " ") q <> buildSql x <> byteString ")") + sumE q x = SqlSyntaxBuilder (byteString "SUM(" <> maybe mempty (\q' -> buildSql q' <> byteString " ") q <> buildSql x <> byteString ")") + +instance IsSql92AggregationSetQuantifierSyntax SqlSyntaxBuilder where + setQuantifierAll = SqlSyntaxBuilder (byteString "ALL") + setQuantifierDistinct = SqlSyntaxBuilder (byteString "DISTINCT") + +instance IsSql92ProjectionSyntax SqlSyntaxBuilder where + type Sql92ProjectionExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + projExprs exprs = + SqlSyntaxBuilder $ + buildSepBy (byteString ", ") + (map (\(expr, nm) -> buildSql expr <> + maybe mempty (\nm -> byteString " AS " <> quoteSql nm) nm) exprs) + +instance IsSql92OrderingSyntax SqlSyntaxBuilder where + type Sql92OrderingExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + ascOrdering expr = SqlSyntaxBuilder (buildSql expr <> byteString " ASC") + descOrdering expr = SqlSyntaxBuilder (buildSql expr <> byteString " DESC") + +instance IsSql92TableSourceSyntax SqlSyntaxBuilder where + type Sql92TableSourceSelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + tableNamed t = SqlSyntaxBuilder (quoteSql t) + tableFromSubSelect query = SqlSyntaxBuilder (byteString "(" <> buildSql query <> byteString ")") + +instance IsSql92FromSyntax SqlSyntaxBuilder where + type Sql92FromTableSourceSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92FromExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + fromTable t Nothing = t + fromTable t (Just nm) = SqlSyntaxBuilder (buildSql t <> byteString " AS " <> quoteSql nm) + + innerJoin = join "INNER JOIN" + leftJoin = join "LEFT JOIN" + rightJoin = join "RIGHT JOIN" + +instance IsSql92DataTypeSyntax SqlSyntaxBuilder where + domainType nm = SqlSyntaxBuilder (quoteSql nm) + charType prec charSet = SqlSyntaxBuilder ("CHAR" <> sqlOptPrec prec <> sqlOptCharSet charSet) + varCharType prec charSet = SqlSyntaxBuilder ("VARCHAR" <> sqlOptPrec prec <> sqlOptCharSet charSet) + nationalCharType prec = SqlSyntaxBuilder ("NATIONAL CHAR" <> sqlOptPrec prec) + nationalVarCharType prec = SqlSyntaxBuilder ("NATIONAL CHARACTER VARYING" <> sqlOptPrec prec) + + bitType prec = SqlSyntaxBuilder ("BIT" <> sqlOptPrec prec) + varBitType prec = SqlSyntaxBuilder ("BIT VARYING" <> sqlOptPrec prec) + + numericType prec = SqlSyntaxBuilder ("NUMERIC" <> sqlOptNumericPrec prec) + decimalType prec = SqlSyntaxBuilder ("DOUBLE" <> sqlOptNumericPrec prec) + + intType = SqlSyntaxBuilder "INT" + smallIntType = SqlSyntaxBuilder "SMALLINT" + + floatType prec = SqlSyntaxBuilder ("FLOAT" <> sqlOptPrec prec) + doubleType = SqlSyntaxBuilder "DOUBLE PRECISION" + realType = SqlSyntaxBuilder "REAL" + dateType = SqlSyntaxBuilder "DATE" + timeType prec withTz = + SqlSyntaxBuilder ("TIME" <> sqlOptPrec prec <> if withTz then " WITH TIME ZONE" else mempty) + timestampType prec withTz = + SqlSyntaxBuilder ("TIMESTAMP" <> sqlOptPrec prec <> if withTz then " WITH TIME ZONE" else mempty) + +sqlOptPrec :: Maybe Word -> Builder +sqlOptPrec Nothing = mempty +sqlOptPrec (Just x) = "(" <> byteString (fromString (show x)) <> ")" + +sqlOptCharSet :: Maybe T.Text -> Builder +sqlOptCharSet Nothing = mempty +sqlOptCharSet (Just cs) = " CHARACTER SET " <> byteString (TE.encodeUtf8 cs) + +sqlOptNumericPrec :: Maybe (Word, Maybe Word) -> Builder +sqlOptNumericPrec Nothing = mempty +sqlOptNumericPrec (Just (prec, Nothing)) = sqlOptPrec (Just prec) +sqlOptNumericPrec (Just (prec, Just dec)) = "(" <> fromString (show prec) <> ", " <> fromString (show dec) <> ")" + +-- TODO These instances are wrong (Text doesn't handle quoting for example) +instance HasSqlValueSyntax SqlSyntaxBuilder Int where + sqlValueSyntax x = SqlSyntaxBuilder $ + byteString (fromString (show x)) +instance HasSqlValueSyntax SqlSyntaxBuilder Int32 where + sqlValueSyntax x = SqlSyntaxBuilder $ + byteString (fromString (show x)) +instance HasSqlValueSyntax SqlSyntaxBuilder Bool where + sqlValueSyntax True = SqlSyntaxBuilder (byteString "TRUE") + sqlValueSyntax False = SqlSyntaxBuilder (byteString "FALSE") +instance HasSqlValueSyntax SqlSyntaxBuilder Text where + sqlValueSyntax x = SqlSyntaxBuilder $ + byteString (fromString (show x)) +instance HasSqlValueSyntax SqlSyntaxBuilder SqlNull where + sqlValueSyntax _ = SqlSyntaxBuilder (byteString "NULL") + +renderSql :: SqlSyntaxBuilder -> String +renderSql (SqlSyntaxBuilder b) = BL.unpack (toLazyByteString b) + +buildSepBy :: Builder -> [Builder] -> Builder +buildSepBy _ [] = mempty +buildSepBy _ [x] = x +buildSepBy sep (x:xs) = x <> sep <> buildSepBy sep xs + +-- TODO actual quoting +quoteSql :: Text -> Builder +quoteSql table = + byteString "\"" <> byteString (TE.encodeUtf8 table) <> byteString "\"" + +join :: ByteString + -> SqlSyntaxBuilder -> SqlSyntaxBuilder + -> Maybe SqlSyntaxBuilder -> SqlSyntaxBuilder +join type_ a b on = + SqlSyntaxBuilder $ + buildSql a <> byteString " " <> byteString type_ <> byteString " " <> buildSql b <> + case on of + Nothing -> mempty + Just on -> byteString " ON (" <> buildSql on <> byteString ")" +sqlPostFixOp, sqlUnOp :: ByteString -> SqlSyntaxBuilder -> SqlSyntaxBuilder +sqlUnOp op a = + SqlSyntaxBuilder $ + byteString op <> byteString " (" <> buildSql a <> byteString ")" +sqlPostFixOp op a = + SqlSyntaxBuilder $ + byteString "(" <> buildSql a <> byteString ") " <> byteString op +sqlCompOp :: ByteString -> Maybe SqlSyntaxBuilder + -> SqlSyntaxBuilder -> SqlSyntaxBuilder + -> SqlSyntaxBuilder +sqlCompOp op quant a b = + SqlSyntaxBuilder $ + byteString "(" <> buildSql a <> byteString ") " <> + byteString op <> + maybe mempty (\quant -> byteString " " <> buildSql quant) quant <> + byteString " (" <> buildSql b <> byteString ")" +sqlBinOp :: ByteString -> SqlSyntaxBuilder -> SqlSyntaxBuilder + -> SqlSyntaxBuilder +sqlBinOp op a b = + SqlSyntaxBuilder $ + byteString "(" <> buildSql a <> byteString ") " <> + byteString op <> + byteString " (" <> buildSql b <> byteString ")" +sqlFuncOp :: ByteString -> SqlSyntaxBuilder -> SqlSyntaxBuilder +sqlFuncOp fun a = + SqlSyntaxBuilder $ + byteString fun <> byteString "(" <> buildSql a <> byteString")" + +-- * Fake 'MonadBeam' instance (for using 'SqlSyntaxBuilder' with migrations mainly) + +data SqlSyntaxBackend + +class Trivial a +instance Trivial a + +instance BeamBackend SqlSyntaxBackend where + type BackendFromField SqlSyntaxBackend = Trivial + +newtype SqlSyntaxM a = SqlSyntaxM (IO a) + deriving (Applicative, Functor, Monad, MonadIO) + +instance MonadBeam SqlSyntaxBuilder SqlSyntaxBackend SqlSyntaxBackend SqlSyntaxM where + withDatabaseDebug _ _ _ = fail "absurd" + runReturningMany _ _ = fail "absurd" diff --git a/Database/Beam/Backend/SQL/SQL2003.hs b/Database/Beam/Backend/SQL/SQL2003.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/SQL2003.hs @@ -0,0 +1,142 @@ +-- | Modular finally tagless extension of SQL99 and SQL92 syntaxes for various +-- SQL2003 core and optional features. +module Database.Beam.Backend.SQL.SQL2003 + ( module Database.Beam.Backend.SQL.SQL99 + + , IsSql2003FromSyntax(..) + , IsSql2003OrderingElementaryOLAPOperationsSyntax(..) + , IsSql2003ExpressionSyntax(..) + , IsSql2003ExpressionElementaryOLAPOperationsSyntax(..) + , IsSql2003ExpressionAdvancedOLAPOperationsSyntax(..) + , IsSql2003BinaryAndVarBinaryDataTypeSyntax(..) + , IsSql2003WindowFrameSyntax(..) + , IsSql2003WindowFrameBoundsSyntax(..) + , IsSql2003WindowFrameBoundSyntax(..) + , IsSql2003EnhancedNumericFunctionsExpressionSyntax(..) + , IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax(..) + , IsSql2003FirstValueAndLastValueExpressionSyntax(..) + , IsSql2003NtileExpressionSyntax(..) + , IsSql2003NthValueExpressionSyntax(..) + , IsSql2003LeadAndLagExpressionSyntax(..) + , IsSql2008BigIntDataTypeSyntax(..) + + , Sql2003ExpressionSanityCheck + ) where + +import Database.Beam.Backend.SQL.SQL99 + +import Data.Text (Text) + +type Sql2003ExpressionSanityCheck syntax = + ( syntax ~ Sql2003WindowFrameExpressionSyntax (Sql2003ExpressionWindowFrameSyntax syntax) ) + +class IsSql92FromSyntax from => + IsSql2003FromSyntax from where + + type Sql2003FromSampleMethodSyntax from :: * + + fromTableSample :: Sql92FromTableSourceSyntax from + -> Sql2003FromSampleMethodSyntax from + -> Maybe Double + -> Maybe Integer + -> Maybe Text + -> from + +-- | Optional SQL2003 "Elementary OLAP operations" T611 support +class IsSql92OrderingSyntax ord => + IsSql2003OrderingElementaryOLAPOperationsSyntax ord where + nullsFirstOrdering, nullsLastOrdering :: ord -> ord + +class ( IsSql99ExpressionSyntax expr + , IsSql2003WindowFrameSyntax (Sql2003ExpressionWindowFrameSyntax expr) ) => + IsSql2003ExpressionSyntax expr where + + type Sql2003ExpressionWindowFrameSyntax expr :: * + + overE :: expr + -> Sql2003ExpressionWindowFrameSyntax expr + -> expr + +-- | Optional SQL2003 "Advanced OLAP operations" T612 support +class IsSql2003ExpressionSyntax expr => + IsSql2003ExpressionAdvancedOLAPOperationsSyntax expr where + percentRankAggE :: expr + denseRankAggE :: expr + cumeDistAggE :: expr + +-- | Optional SQL2003 "Elementary OLAP operations" T611 support +class IsSql2003ExpressionSyntax expr => + IsSql2003ExpressionElementaryOLAPOperationsSyntax expr where + + filterAggE :: expr -> expr -> expr + rankAggE :: expr + +-- | Optional SQL2003 "BINARY AND VARBINARY data type" T021 support +class IsSql99DataTypeSyntax dataType => + IsSql2003BinaryAndVarBinaryDataTypeSyntax dataType where + binaryType :: Maybe Word -> dataType + varBinaryType :: Maybe Word -> dataType + +class IsSql2003WindowFrameBoundsSyntax (Sql2003WindowFrameBoundsSyntax frame) => + IsSql2003WindowFrameSyntax frame where + type Sql2003WindowFrameExpressionSyntax frame :: * + type Sql2003WindowFrameOrderingSyntax frame :: * + type Sql2003WindowFrameBoundsSyntax frame :: * + + frameSyntax :: Maybe [Sql2003WindowFrameExpressionSyntax frame] + -> Maybe [Sql2003WindowFrameOrderingSyntax frame] + -> Maybe (Sql2003WindowFrameBoundsSyntax frame) + -> frame + +class IsSql2003WindowFrameBoundSyntax (Sql2003WindowFrameBoundsBoundSyntax bounds) => + IsSql2003WindowFrameBoundsSyntax bounds where + type Sql2003WindowFrameBoundsBoundSyntax bounds :: * + fromToBoundSyntax :: Sql2003WindowFrameBoundsBoundSyntax bounds + -> Maybe (Sql2003WindowFrameBoundsBoundSyntax bounds) + -> bounds + +class IsSql2003WindowFrameBoundSyntax bound where + unboundedSyntax :: bound + nrowsBoundSyntax :: Int -> bound + +-- | Optional SQL2003 "Enhanced numeric functions" T621 support +class IsSql99ExpressionSyntax expr => + IsSql2003EnhancedNumericFunctionsExpressionSyntax expr where + + lnE, expE, sqrtE, ceilE, floorE :: expr -> expr + powerE :: expr -> expr -> expr + +class IsSql99AggregationExpressionSyntax agg => + IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax agg where + + stddevPopE, stddevSampE, varPopE, varSampE + :: Maybe (Sql92AggregationSetQuantifierSyntax agg) -> agg -> agg + + covarPopE, covarSampE, corrE, regrSlopeE, regrInterceptE, regrCountE, + regrRSquaredE, regrAvgXE, regrAvgYE, regrSXXE, regrSXYE, regrSYYE :: + Maybe (Sql92AggregationSetQuantifierSyntax agg) -> agg -> agg -> agg + +-- | Optional SQL2003 "NTILE function" T614 support +class IsSql99AggregationExpressionSyntax agg => + IsSql2003NtileExpressionSyntax agg where + ntileE :: agg -> agg + +-- | Optional SQL2003 "LEAD and LAG function" T615 support +class IsSql99AggregationExpressionSyntax agg => + IsSql2003LeadAndLagExpressionSyntax agg where + leadE, lagE :: agg -> Maybe agg -> Maybe agg -> agg + +-- | Optional SQL2003 "FIRST_VALUE and LAST_VALUE function" T616 support +class IsSql99AggregationExpressionSyntax agg => + IsSql2003FirstValueAndLastValueExpressionSyntax agg where + firstValueE, lastValueE :: agg -> agg + +-- | Optional SQL2003 "NTH_VALUE function" T618 support +class IsSql99AggregationExpressionSyntax agg => + IsSql2003NthValueExpressionSyntax agg where + nthValueE :: agg -> agg -> agg + +-- | Optional SQL2008 "BIGINT data type" T071 support +class IsSql99DataTypeSyntax dataType => + IsSql2008BigIntDataTypeSyntax dataType where + bigIntType :: dataType diff --git a/Database/Beam/Backend/SQL/SQL92.hs b/Database/Beam/Backend/SQL/SQL92.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/SQL92.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE PolyKinds #-} + +-- | Finally tagless encoding of SQL92 syntax +module Database.Beam.Backend.SQL.SQL92 where + +import Database.Beam.Backend.SQL.Types +import Database.Beam.Backend.Types + +import Data.Int +import Data.Text (Text) +import Data.Time (LocalTime) +import Data.Typeable + +class ( BeamSqlBackend be ) => + BeamSql92Backend be where + +-- * Finally tagless style + +class HasSqlValueSyntax expr ty where + sqlValueSyntax :: ty -> expr +class IsSqlExpressionSyntaxStringType expr ty + +autoSqlValueSyntax :: (HasSqlValueSyntax expr String, Show a) => a -> expr +autoSqlValueSyntax = sqlValueSyntax . show + +type Sql92SelectExpressionSyntax select = Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) +type Sql92SelectProjectionSyntax select = Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax select) +type Sql92SelectGroupingSyntax select = Sql92SelectTableGroupingSyntax (Sql92SelectSelectTableSyntax select) +type Sql92SelectFromSyntax select = Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select) + +type Sql92ValueSyntax cmdSyntax = Sql92ExpressionValueSyntax (Sql92ExpressionSyntax cmdSyntax) +type Sql92ExpressionSyntax cmdSyntax = Sql92SelectExpressionSyntax (Sql92SelectSyntax cmdSyntax) +type Sql92HasValueSyntax cmdSyntax = HasSqlValueSyntax (Sql92ValueSyntax cmdSyntax) + +-- Putting these in the head constraint can cause infinite recursion that would +-- need + IsSql92Syntax cmd where + type Sql92SelectSyntax cmd :: * + type Sql92InsertSyntax cmd :: * + type Sql92UpdateSyntax cmd :: * + type Sql92DeleteSyntax cmd :: * + + selectCmd :: Sql92SelectSyntax cmd -> cmd + insertCmd :: Sql92InsertSyntax cmd -> cmd + updateCmd :: Sql92UpdateSyntax cmd -> cmd + deleteCmd :: Sql92DeleteSyntax cmd -> cmd + +class ( IsSql92SelectTableSyntax (Sql92SelectSelectTableSyntax select) + , IsSql92OrderingSyntax (Sql92SelectOrderingSyntax select) ) => + IsSql92SelectSyntax select where + type Sql92SelectSelectTableSyntax select :: * + type Sql92SelectOrderingSyntax select :: * + + selectStmt :: Sql92SelectSelectTableSyntax select + -> [Sql92SelectOrderingSyntax select] + -> Maybe Integer {-^ LIMIT -} + -> Maybe Integer {-^ OFFSET -} + -> select + +class ( IsSql92ExpressionSyntax (Sql92SelectTableExpressionSyntax select) + , IsSql92AggregationExpressionSyntax (Sql92SelectTableExpressionSyntax select) + , IsSql92ProjectionSyntax (Sql92SelectTableProjectionSyntax select) + , IsSql92FromSyntax (Sql92SelectTableFromSyntax select) + , IsSql92GroupingSyntax (Sql92SelectTableGroupingSyntax select) + , IsSql92AggregationSetQuantifierSyntax (Sql92SelectTableSetQuantifierSyntax select) + + , Sql92GroupingExpressionSyntax (Sql92SelectTableGroupingSyntax select) ~ Sql92SelectTableExpressionSyntax select + , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax select) ~ Sql92SelectTableExpressionSyntax select + , Sql92SelectSelectTableSyntax (Sql92SelectTableSelectSyntax select) ~ select + + , Eq (Sql92SelectTableExpressionSyntax select) ) => + IsSql92SelectTableSyntax select where + type Sql92SelectTableSelectSyntax select :: * + type Sql92SelectTableExpressionSyntax select :: * + type Sql92SelectTableProjectionSyntax select :: * + type Sql92SelectTableFromSyntax select :: * + type Sql92SelectTableGroupingSyntax select :: * + type Sql92SelectTableSetQuantifierSyntax select :: * + + selectTableStmt :: Maybe (Sql92SelectTableSetQuantifierSyntax select) + -> Sql92SelectTableProjectionSyntax select + -> Maybe (Sql92SelectTableFromSyntax select) + -> Maybe (Sql92SelectTableExpressionSyntax select) {-^ Where clause -} + -> Maybe (Sql92SelectTableGroupingSyntax select) + -> Maybe (Sql92SelectTableExpressionSyntax select) {-^ having clause -} + -> select + + unionTables, intersectTables, exceptTable :: + Bool -> select -> select -> select + +class IsSql92InsertValuesSyntax (Sql92InsertValuesSyntax insert) => + IsSql92InsertSyntax insert where + + type Sql92InsertValuesSyntax insert :: * + insertStmt :: Text + -> [ Text ] + -> Sql92InsertValuesSyntax insert + -> insert + +class IsSql92ExpressionSyntax (Sql92InsertValuesExpressionSyntax insertValues) => + IsSql92InsertValuesSyntax insertValues where + type Sql92InsertValuesExpressionSyntax insertValues :: * + type Sql92InsertValuesSelectSyntax insertValues :: * + + insertSqlExpressions :: [ [ Sql92InsertValuesExpressionSyntax insertValues ] ] + -> insertValues + insertFromSql :: Sql92InsertValuesSelectSyntax insertValues + -> insertValues + +class ( IsSql92ExpressionSyntax (Sql92UpdateExpressionSyntax update) + , IsSql92FieldNameSyntax (Sql92UpdateFieldNameSyntax update)) => + IsSql92UpdateSyntax update where + type Sql92UpdateFieldNameSyntax update :: * + type Sql92UpdateExpressionSyntax update :: * + + updateStmt :: Text + -> [(Sql92UpdateFieldNameSyntax update, Sql92UpdateExpressionSyntax update)] + -> Maybe (Sql92UpdateExpressionSyntax update) {-^ WHERE -} + -> update + +class IsSql92ExpressionSyntax (Sql92DeleteExpressionSyntax delete) => + IsSql92DeleteSyntax delete where + type Sql92DeleteExpressionSyntax delete :: * + + deleteStmt :: Text + -> Maybe (Sql92DeleteExpressionSyntax delete) + -> delete + +class IsSql92FieldNameSyntax fn where + qualifiedField :: Text -> Text -> fn + unqualifiedField :: Text -> fn + +class IsSql92QuantifierSyntax quantifier where + quantifyOverAll, quantifyOverAny :: quantifier + +class IsSql92DataTypeSyntax dataType where + domainType :: Text -> dataType + charType :: Maybe Word -> Maybe Text -> dataType + varCharType :: Maybe Word -> Maybe Text -> dataType + nationalCharType :: Maybe Word -> dataType + nationalVarCharType :: Maybe Word -> dataType + bitType :: Maybe Word -> dataType + varBitType :: Maybe Word -> dataType + numericType :: Maybe (Word, Maybe Word) -> dataType + decimalType :: Maybe (Word, Maybe Word) -> dataType + intType :: dataType + smallIntType :: dataType + floatType :: Maybe Word -> dataType + doubleType :: dataType + realType :: dataType + + dateType :: dataType + timeType :: Maybe Word -> Bool {-^ With time zone -} -> dataType + timestampType :: Maybe Word -> Bool {-^ With time zone -} -> dataType + -- TODO interval type + +class ( HasSqlValueSyntax (Sql92ExpressionValueSyntax expr) Int + , IsSql92FieldNameSyntax (Sql92ExpressionFieldNameSyntax expr) + , IsSql92QuantifierSyntax (Sql92ExpressionQuantifierSyntax expr) + , Typeable expr ) => + IsSql92ExpressionSyntax expr where + type Sql92ExpressionQuantifierSyntax expr :: * + type Sql92ExpressionValueSyntax expr :: * + type Sql92ExpressionSelectSyntax expr :: * + type Sql92ExpressionFieldNameSyntax expr :: * + type Sql92ExpressionCastTargetSyntax expr :: * + type Sql92ExpressionExtractFieldSyntax expr :: * + + valueE :: Sql92ExpressionValueSyntax expr -> expr + rowE, coalesceE :: [ expr ] -> expr + caseE :: [(expr, expr)] + -> expr -> expr + fieldE :: Sql92ExpressionFieldNameSyntax expr -> expr + + betweenE :: expr -> expr -> expr -> expr + + andE, orE, addE, subE, mulE, divE, likeE, + modE, overlapsE, nullIfE, positionE + :: expr + -> expr + -> expr + + eqE, neqE, ltE, gtE, leE, geE + :: Maybe (Sql92ExpressionQuantifierSyntax expr) + -> expr -> expr -> expr + + castE :: expr -> Sql92ExpressionCastTargetSyntax expr -> expr + + notE, negateE, isNullE, isNotNullE, + isTrueE, isNotTrueE, isFalseE, isNotFalseE, + isUnknownE, isNotUnknownE, charLengthE, + octetLengthE, bitLengthE + :: expr + -> expr + + -- | Included so that we can easily write a Num instance, but not defined in SQL92. + -- Implementations that do not support this, should use CASE .. WHEN .. + absE :: expr -> expr + + extractE :: Sql92ExpressionExtractFieldSyntax expr -> expr -> expr + + existsE, uniqueE, subqueryE + :: Sql92ExpressionSelectSyntax expr -> expr + + currentTimestampE :: expr + + defaultE :: expr + + inE :: expr -> [ expr ] -> expr + +instance HasSqlValueSyntax syntax x => HasSqlValueSyntax syntax (SqlSerial x) where + sqlValueSyntax (SqlSerial x) = sqlValueSyntax x + +class IsSql92AggregationSetQuantifierSyntax (Sql92AggregationSetQuantifierSyntax expr) => + IsSql92AggregationExpressionSyntax expr where + + type Sql92AggregationSetQuantifierSyntax expr :: * + + countAllE :: expr + countE, avgE, maxE, minE, sumE + :: Maybe (Sql92AggregationSetQuantifierSyntax expr) -> expr -> expr + +class IsSql92AggregationSetQuantifierSyntax q where + setQuantifierDistinct, setQuantifierAll :: q + +class IsSql92ExpressionSyntax (Sql92ProjectionExpressionSyntax proj) => IsSql92ProjectionSyntax proj where + type Sql92ProjectionExpressionSyntax proj :: * + + projExprs :: [ (Sql92ProjectionExpressionSyntax proj, Maybe Text) ] + -> proj + +class IsSql92OrderingSyntax ord where + type Sql92OrderingExpressionSyntax ord :: * + ascOrdering, descOrdering + :: Sql92OrderingExpressionSyntax ord -> ord + +class IsSql92TableSourceSyntax tblSource where + type Sql92TableSourceSelectSyntax tblSource :: * + tableNamed :: Text -> tblSource + tableFromSubSelect :: Sql92TableSourceSelectSyntax tblSource -> tblSource + +class IsSql92GroupingSyntax grouping where + type Sql92GroupingExpressionSyntax grouping :: * + + groupByExpressions :: [ Sql92GroupingExpressionSyntax grouping ] -> grouping + +class ( IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax from) + , IsSql92ExpressionSyntax (Sql92FromExpressionSyntax from) ) => + IsSql92FromSyntax from where + type Sql92FromTableSourceSyntax from :: * + type Sql92FromExpressionSyntax from :: * + + fromTable :: Sql92FromTableSourceSyntax from + -> Maybe Text + -> from + + innerJoin, leftJoin, rightJoin + :: from -> from + -> Maybe (Sql92FromExpressionSyntax from) + -> from + +class IsSql92FromSyntax from => + IsSql92FromOuterJoinSyntax from where + + outerJoin :: from -> from -> Maybe (Sql92FromExpressionSyntax from) -> from diff --git a/Database/Beam/Backend/SQL/SQL99.hs b/Database/Beam/Backend/SQL/SQL99.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/SQL99.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + +-- | Finally tagless extension of SQL92 syntaxes for SQL99 +module Database.Beam.Backend.SQL.SQL99 + ( module Database.Beam.Backend.SQL.SQL92 + , IsSql99ExpressionSyntax(..) + , IsSql99ConcatExpressionSyntax(..) + , IsSql99AggregationExpressionSyntax(..) + , IsSql99SelectSyntax(..) + , IsSql99DataTypeSyntax(..) ) where + +import Database.Beam.Backend.SQL.SQL92 + +import Data.Text ( Text ) + +class IsSql92SelectSyntax select => + IsSql99SelectSyntax select + +class IsSql92ExpressionSyntax expr => + IsSql99ExpressionSyntax expr where + + distinctE :: Sql92ExpressionSelectSyntax expr -> expr + similarToE :: expr -> expr -> expr + + functionCallE :: expr -> [ expr ] -> expr + + instanceFieldE :: expr -> Text -> expr + refFieldE :: expr -> Text -> expr + +class IsSql92ExpressionSyntax expr => + IsSql99ConcatExpressionSyntax expr where + concatE :: [ expr ] -> expr + +class IsSql92AggregationExpressionSyntax expr => + IsSql99AggregationExpressionSyntax expr where + everyE, someE, anyE :: Maybe (Sql92AggregationSetQuantifierSyntax expr) -> expr -> expr + +class IsSql92DataTypeSyntax dataType => + IsSql99DataTypeSyntax dataType where + characterLargeObjectType :: dataType + binaryLargeObjectType :: dataType + booleanType :: dataType + arrayType :: dataType -> Int -> dataType + rowType :: [ (Text, dataType) ] -> dataType diff --git a/Database/Beam/Backend/SQL/Types.hs b/Database/Beam/Backend/SQL/Types.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/Types.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Database.Beam.Backend.SQL.Types where + +import Database.Beam.Backend.Types + +import qualified Data.Aeson as Json +import Data.Bits + +class ( BeamBackend be ) => + BeamSqlBackend be where + +data SqlNull = SqlNull + deriving (Show, Eq, Ord, Bounded, Enum) +newtype SqlBitString = SqlBitString Integer + deriving (Show, Eq, Ord, Enum, Bits) + +newtype SqlSerial a = SqlSerial { unSerial :: a } + deriving (Show, Read, Eq, Ord) +instance FromBackendRow be x => FromBackendRow be (SqlSerial x) where + fromBackendRow = SqlSerial <$> fromBackendRow +instance Json.FromJSON a => Json.FromJSON (SqlSerial a) where + parseJSON a = SqlSerial <$> Json.parseJSON a +instance Json.ToJSON a => Json.ToJSON (SqlSerial a) where + toJSON (SqlSerial a) = Json.toJSON a + toEncoding (SqlSerial a) = Json.toEncoding a + diff --git a/Database/Beam/Backend/Types.hs b/Database/Beam/Backend/Types.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/Types.hs @@ -0,0 +1,189 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ConstraintKinds #-} + +module Database.Beam.Backend.Types + ( BeamBackend(..) + , Auto(..) + + , FromBackendRowF(..), FromBackendRowM + , parseOneField, peekField, checkNextNNull + + , FromBackendRow(..) + + , Exposed, Nullable ) where + +import Control.Monad.Free.Church +import Control.Monad.Identity +import qualified Data.Aeson as Json +import Data.Vector.Sized (Vector) +import qualified Data.Vector.Sized as Vector + +import Data.Proxy + +import GHC.Generics +import GHC.TypeLits +import GHC.Types + +-- | Class for all beam backends +class BeamBackend be where + -- | Requirements to marshal a certain type from a database of a particular backend + type BackendFromField be :: * -> Constraint + +-- | Newtype wrapper for types that may be given default values by the database. +-- Essentially, a wrapper around 'Maybe x'. +-- +-- When a value of type 'Auto x' is written to a database (via @INSERT@ or +-- @UPDATE@, for example), backends will translate a 'Nothing' value into an +-- expression that will evaluate to whatever default value the database would +-- choose. This is useful to insert rows with columns that are +-- auto-incrementable or have a @DEFAULT@ value. +-- +-- When read from the database, the wrapped value will always be a 'Just' +-- value. This isn't currently enforced at the type-level, but may be in +-- future versions of beam. +newtype Auto x = Auto { unAuto :: Maybe x } + deriving (Show, Read, Eq, Ord, Generic, Monoid) +instance Json.FromJSON a => Json.FromJSON (Auto a) where + parseJSON a = Auto <$> Json.parseJSON a +instance Json.ToJSON a => Json.ToJSON (Auto a) where + toJSON (Auto a) = Json.toJSON a + toEncoding (Auto a) = Json.toEncoding a + +data FromBackendRowF be f where + ParseOneField :: BackendFromField be a => (a -> f) -> FromBackendRowF be f + PeekField :: BackendFromField be a => (Maybe a -> f) -> FromBackendRowF be f + CheckNextNNull :: Int -> (Bool -> f) -> FromBackendRowF be f +deriving instance Functor (FromBackendRowF be) +type FromBackendRowM be = F (FromBackendRowF be) + +parseOneField :: BackendFromField be a => FromBackendRowM be a +parseOneField = liftF (ParseOneField id) + +peekField :: BackendFromField be a => FromBackendRowM be (Maybe a) +peekField = liftF (PeekField id) + +checkNextNNull :: Int -> FromBackendRowM be Bool +checkNextNNull n = liftF (CheckNextNNull n id) + +class BeamBackend be => FromBackendRow be a where + fromBackendRow :: FromBackendRowM be a + default fromBackendRow :: BackendFromField be a => FromBackendRowM be a + fromBackendRow = parseOneField + + valuesNeeded :: Proxy be -> Proxy a -> Int + valuesNeeded _ _ = 1 + +-- | newtype mainly used to inspect tho tag structure of a particular +-- 'Beamable'. Prevents overlapping instances in some case. Usually not used +-- in end-user code. +data Exposed x + +-- | Support for NULLable Foreign Key references. +-- +-- > data MyTable f = MyTable +-- > { nullableRef :: PrimaryKey AnotherTable (Nullable f) +-- > , ... } +-- > deriving (Generic, Typeable) +-- +-- See 'Columnar' for more information. +data Nullable (c :: * -> *) x + +class GFromBackendRow be (exposed :: * -> *) rep where + gFromBackendRow :: Proxy exposed -> FromBackendRowM be (rep ()) + gValuesNeeded :: Proxy be -> Proxy exposed -> Proxy rep -> Int +instance GFromBackendRow be e p => GFromBackendRow be (M1 t f e) (M1 t f p) where + gFromBackendRow _ = M1 <$> gFromBackendRow (Proxy @e) + gValuesNeeded be _ _ = gValuesNeeded be (Proxy @e) (Proxy @p) +instance GFromBackendRow be e U1 where + gFromBackendRow _ = pure U1 + gValuesNeeded _ _ _ = 0 +instance (GFromBackendRow be aExp a, GFromBackendRow be bExp b) => GFromBackendRow be (aExp :*: bExp) (a :*: b) where + gFromBackendRow _ = (:*:) <$> gFromBackendRow (Proxy @aExp) <*> gFromBackendRow (Proxy @bExp) + gValuesNeeded be _ _ = gValuesNeeded be (Proxy @aExp) (Proxy @a) + gValuesNeeded be (Proxy @bExp) (Proxy @b) +instance FromBackendRow be x => GFromBackendRow be (K1 R (Exposed x)) (K1 R x) where + gFromBackendRow _ = K1 <$> fromBackendRow + gValuesNeeded be _ _ = valuesNeeded be (Proxy @x) +instance FromBackendRow be (t Identity) => GFromBackendRow be (K1 R (t Exposed)) (K1 R (t Identity)) where + gFromBackendRow _ = K1 <$> fromBackendRow + gValuesNeeded be _ _ = valuesNeeded be (Proxy @(t Identity)) +instance FromBackendRow be (t (Nullable Identity)) => GFromBackendRow be (K1 R (t (Nullable Exposed))) (K1 R (t (Nullable Identity))) where + gFromBackendRow _ = K1 <$> fromBackendRow + gValuesNeeded be _ _ = valuesNeeded be (Proxy @(t (Nullable Identity))) +instance BeamBackend be => FromBackendRow be () where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep ())) + valuesNeeded _ _ = 0 + +instance ( BeamBackend be, KnownNat n, FromBackendRow be a ) => FromBackendRow be (Vector n a) where + fromBackendRow = Vector.replicateM fromBackendRow + valuesNeeded _ _ = fromIntegral (natVal (Proxy @n)) + +instance ( BeamBackend be, FromBackendRow be a, FromBackendRow be b ) => + FromBackendRow be (a, b) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) +instance ( BeamBackend be, FromBackendRow be a, FromBackendRow be b, FromBackendRow be c ) => + FromBackendRow be (a, b, c) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d ) => + FromBackendRow be (a, b, c, d) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e ) => + FromBackendRow be (a, b, c, d, e) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f ) => + FromBackendRow be (a, b, c, d, e, f) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f + , FromBackendRow be g ) => + FromBackendRow be (a, b, c, d, e, f, g) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f, Exposed g))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) + valuesNeeded be (Proxy @g) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f + , FromBackendRow be g, FromBackendRow be h ) => + FromBackendRow be (a, b, c, d, e, f, g, h) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f, Exposed g, Exposed h))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) + valuesNeeded be (Proxy @g) + valuesNeeded be (Proxy @h) + +instance ( BeamBackend be, Generic (tbl Identity), Generic (tbl Exposed) + , GFromBackendRow be (Rep (tbl Exposed)) (Rep (tbl Identity))) => + + FromBackendRow be (tbl Identity) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (tbl Exposed))) + valuesNeeded be _ = gValuesNeeded be (Proxy @(Rep (tbl Exposed))) (Proxy @(Rep (tbl Identity))) +instance ( BeamBackend be, Generic (tbl (Nullable Identity)), Generic (tbl (Nullable Exposed)) + , GFromBackendRow be (Rep (tbl (Nullable Exposed))) (Rep (tbl (Nullable Identity)))) => + + FromBackendRow be (tbl (Nullable Identity)) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (tbl (Nullable Exposed)))) + valuesNeeded be _ = gValuesNeeded be (Proxy @(Rep (tbl (Nullable Exposed)))) (Proxy @(Rep (tbl (Nullable Identity)))) + +instance FromBackendRow be x => FromBackendRow be (Maybe x) where + fromBackendRow = + do isNull <- checkNextNNull (valuesNeeded (Proxy @be) (Proxy @(Maybe x))) + if isNull then pure Nothing else Just <$> fromBackendRow + valuesNeeded be _ = valuesNeeded be (Proxy @x) +instance (BeamBackend be, FromBackendRow be (Maybe x)) => FromBackendRow be (Auto x) where + fromBackendRow = Auto <$> fromBackendRow + valuesNeeded be _ = valuesNeeded be (Proxy @(Maybe x)) + +deriving instance Generic (a, b, c, d, e, f, g, h) diff --git a/Database/Beam/Backend/URI.hs b/Database/Beam/Backend/URI.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/URI.hs @@ -0,0 +1,62 @@ +-- | Convenience methods for constructing backend-agnostic applications + +module Database.Beam.Backend.URI where + +import Database.Beam.Backend.SQL + +import Control.Exception + +import qualified Data.Map as M + +import Network.URI + +data BeamResourceNotFound = BeamResourceNotFound deriving Show +instance Exception BeamResourceNotFound + +data BeamOpenURIInvalid = BeamOpenURIInvalid deriving Show +instance Exception BeamOpenURIInvalid + +data BeamOpenURIUnsupportedScheme = BeamOpenURIUnsupportedScheme String deriving Show +instance Exception BeamOpenURIUnsupportedScheme + +data BeamURIOpener c where + BeamURIOpener :: MonadBeam syntax be hdl m + => c syntax be hdl m + -> (forall a. URI -> (hdl -> IO a) -> IO a) + -> BeamURIOpener c +newtype BeamURIOpeners c where + BeamURIOpeners :: M.Map String (BeamURIOpener c) -> BeamURIOpeners c + +instance Monoid (BeamURIOpeners c) where + mempty = BeamURIOpeners mempty + mappend (BeamURIOpeners a) (BeamURIOpeners b) = + BeamURIOpeners (mappend a b) + +mkUriOpener :: MonadBeam syntax be hdl m + => String -> (forall a. URI -> (hdl -> IO a) -> IO a) + -> c syntax be hdl m + -> BeamURIOpeners c +mkUriOpener schemeNm opener c = BeamURIOpeners (M.singleton schemeNm (BeamURIOpener c opener)) + +withDbFromUri :: forall c a + . BeamURIOpeners c + -> String + -> (forall syntax be hdl m. MonadBeam syntax be hdl m => c syntax be hdl m -> m a) + -> IO a +withDbFromUri protos uri actionWithDb = + withDbConnection protos uri (\c hdl -> withDatabase hdl (actionWithDb c)) + +withDbConnection :: forall c a + . BeamURIOpeners c + -> String + -> (forall syntax be hdl m. MonadBeam syntax be hdl m => + c syntax be hdl m -> hdl -> IO a) + -> IO a +withDbConnection (BeamURIOpeners protos) uri actionWithDb = + case parseURI uri of + Nothing -> throwIO BeamOpenURIInvalid + Just parsedUri -> + case M.lookup (uriScheme parsedUri) protos of + Nothing -> throwIO (BeamOpenURIUnsupportedScheme (uriScheme parsedUri)) + Just (BeamURIOpener c withURI) -> + withURI parsedUri (actionWithDb c) diff --git a/Database/Beam/Query.hs b/Database/Beam/Query.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query.hs @@ -0,0 +1,311 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +module Database.Beam.Query + ( -- * Query type + module Database.Beam.Query.Types + + -- ** Query expression contexts + -- | A context is a type-level value that signifies where an expression can + -- be used. For example, 'QExpr' corresponds to 'QGenExpr's that result in + -- values. In reality, 'QExpr' is really 'QGenExpr' parameterized over the + -- 'QValueContext'. Similarly, 'QAgg' represents expressions that contain + -- aggregates, but it is just 'QGenExpr' parameterized over + -- 'QAggregateContext' + , QAggregateContext, QGroupingContext, QValueContext + , QWindowingContext, QWindowFrameContext + + , QueryableSqlSyntax + + , QGenExprTable, QExprTable + + , module Database.Beam.Query.Combinators + , module Database.Beam.Query.Extensions + + , module Database.Beam.Query.Relationships + + -- * Operators + , module Database.Beam.Query.Operator + + -- ** Unquantified comparison operators + , SqlEq(..), SqlOrd(..) + + -- ** Quantified Comparison Operators #quantified-comparison-operator# + , SqlEqQuantified(..), SqlOrdQuantified(..) + , QQuantified + , anyOf_, allOf_, anyIn_, allIn_ + , between_ + , in_ + + , module Database.Beam.Query.Aggregate + + , module Database.Beam.Query.CustomSQL + + -- * SQL Command construction and execution + -- ** @SELECT@ + , SqlSelect(..) + , select, lookup + , runSelectReturningList + , runSelectReturningOne + , dumpSqlSelect + + -- ** @INSERT@ + , SqlInsert(..) + , insert + , runInsert + + , SqlInsertValues(..) + , insertExpressions + , insertValues + , insertFrom + + -- ** @UPDATE@ + , SqlUpdate(..) + , update, save + , runUpdate + + -- ** @DELETE@ + , SqlDelete(..) + , delete + , runDelete ) where + +import Prelude hiding (lookup) + +import Database.Beam.Query.Aggregate +import Database.Beam.Query.Combinators +import Database.Beam.Query.CustomSQL +import Database.Beam.Query.Extensions +import Database.Beam.Query.Internal +import Database.Beam.Query.Operator +import Database.Beam.Query.Ord +import Database.Beam.Query.Relationships +import Database.Beam.Query.Types (QGenExpr) -- hide QGenExpr constructor +import Database.Beam.Query.Types hiding (QGenExpr) + +import Database.Beam.Backend.Types +import Database.Beam.Backend.SQL +import Database.Beam.Backend.SQL.Builder +import Database.Beam.Schema.Tables + +import Control.Monad.Identity +import Control.Monad.Writer + +-- * Query + +data QueryInaccessible + +-- | A version of the table where each field is a 'QGenExpr' +type QGenExprTable ctxt syntax tbl = forall s. tbl (QGenExpr ctxt syntax s) + +type QExprTable syntax tbl = QGenExprTable QValueContext syntax tbl + +-- * SELECT + +-- | Represents a select statement over the syntax 'select' that will return +-- rows of type 'a'. +newtype SqlSelect select a + = SqlSelect select + +type QueryableSqlSyntax cmd = + ( IsSql92Syntax cmd + , Sql92SanityCheck cmd + , HasQBuilder (Sql92SelectSyntax cmd) ) + +-- | Build a 'SqlSelect' for the given 'Q'. +select :: forall syntax db res. + ( ProjectibleInSelectSyntax syntax res + , IsSql92SelectSyntax syntax + , HasQBuilder syntax ) => + Q syntax db QueryInaccessible res -> SqlSelect syntax (QExprToIdentity res) +select q = + SqlSelect (buildSqlQuery "t" q) + +-- | Convenience function to generate a 'SqlSelect' that looks up a table row +-- given a primary key. +lookup :: ( HasQBuilder syntax + , Sql92SelectSanityCheck syntax + + , SqlValableTable (PrimaryKey table) (Sql92SelectExpressionSyntax syntax) + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool + + , Beamable table, Table table + + , Database db ) + => DatabaseEntity be db (TableEntity table) + -> PrimaryKey table Identity + -> SqlSelect syntax (table Identity) +lookup tbl tblKey = + select $ + filter_ (\t -> pk t ==. val_ tblKey) $ + all_ tbl + +-- | Run a 'SqlSelect' in a 'MonadBeam' and get the results as a list +runSelectReturningList :: + (IsSql92Syntax cmd, MonadBeam cmd be hdl m, FromBackendRow be a) => + SqlSelect (Sql92SelectSyntax cmd) a -> m [ a ] +runSelectReturningList (SqlSelect s) = + runReturningList (selectCmd s) + +-- | Run a 'SqlSelect' in a 'MonadBeam' and get the unique result, if there is +-- one. Both no results as well as more than one result cause this to return +-- 'Nothing'. +runSelectReturningOne :: + (IsSql92Syntax cmd, MonadBeam cmd be hdl m, FromBackendRow be a) => + SqlSelect (Sql92SelectSyntax cmd) a -> m (Maybe a) +runSelectReturningOne (SqlSelect s) = + runReturningOne (selectCmd s) + +-- | Use a special debug syntax to print out an ANSI Standard @SELECT@ statement +-- that may be generated for a given 'Q'. +dumpSqlSelect :: ProjectibleInSelectSyntax SqlSyntaxBuilder res => + Q SqlSyntaxBuilder db QueryInaccessible res -> IO () +dumpSqlSelect q = + let SqlSelect s = select q + in putStrLn (renderSql s) + +-- * INSERT + +-- | Represents a SQL @INSERT@ command that has not yet been run +newtype SqlInsert syntax = SqlInsert syntax + +-- | Generate a 'SqlInsert' given a table and a source of values. +insert :: IsSql92InsertSyntax syntax => + DatabaseEntity be db (TableEntity table) + -- ^ Table to insert into + -> SqlInsertValues (Sql92InsertValuesSyntax syntax) table + -- ^ Values to insert. See 'insertValues', 'insertExpressions', and 'insertFrom' for possibilities. + -> SqlInsert syntax +insert (DatabaseEntity (DatabaseTable tblNm tblSettings)) (SqlInsertValues vs) = + SqlInsert (insertStmt tblNm tblFields vs) + where + tblFields = allBeamValues (\(Columnar' f) -> _fieldName f) tblSettings + +-- | Run a 'SqlInsert' in a 'MonadBeam' +runInsert :: (IsSql92Syntax cmd, MonadBeam cmd be hdl m) + => SqlInsert (Sql92InsertSyntax cmd) -> m () +runInsert (SqlInsert i) = runNoReturn (insertCmd i) + +-- | Represents a source of values that can be inserted into a table shaped like +-- 'tbl'. +newtype SqlInsertValues insertValues (tbl :: (* -> *) -> *) + = SqlInsertValues insertValues + +-- | Build a 'SqlInsertValues' from series of expressions +insertExpressions :: + forall syntax table. + ( Beamable table + , IsSql92InsertValuesSyntax syntax ) => + (forall s. [ table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s) ]) -> + SqlInsertValues syntax table +insertExpressions tbls = + SqlInsertValues $ + insertSqlExpressions (map mkSqlExprs tbls) + where + mkSqlExprs :: forall s. table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s) -> [Sql92InsertValuesExpressionSyntax syntax] + mkSqlExprs = allBeamValues (\(Columnar' (QExpr x)) -> x "t") + +-- | Build a 'SqlInsertValues' from concrete table values +insertValues :: + forall table syntax. + ( Beamable table + , IsSql92InsertValuesSyntax syntax + , FieldsFulfillConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92InsertValuesExpressionSyntax syntax))) table) => + [ table Identity ] -> SqlInsertValues syntax table +insertValues x = insertExpressions (map val_ x :: forall s. [table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s) ]) + +-- | Build a 'SqlInsertValues' from a 'SqlSelect' that returns the same table +insertFrom :: + IsSql92InsertValuesSyntax syntax => + SqlSelect (Sql92InsertValuesSelectSyntax syntax) (table Identity) -> SqlInsertValues syntax table +insertFrom (SqlSelect s) = SqlInsertValues (insertFromSql s) + +-- * UPDATE + +-- | Represents a SQL @UPDATE@ statement for the given @table@. +newtype SqlUpdate syntax (table :: (* -> *) -> *) = SqlUpdate syntax + +-- | Build a 'SqlUpdate' given a table, a list of assignments, and a way to +-- build a @WHERE@ clause. +-- +-- See the '(<-.)' operator for ways to build assignments. The argument to the +-- second argument is a the table parameterized over 'QField', which +-- represents the left hand side of assignments. Sometimes, you'd like to also +-- get the current value of a particular column. You can use the 'current_' +-- function to convert a 'QField' to a 'QExpr'. +update :: ( Beamable table + , IsSql92UpdateSyntax syntax) => + DatabaseEntity be db (TableEntity table) + -- ^ The table to insert into + -> (forall s. table (QField s) -> [ QAssignment (Sql92UpdateFieldNameSyntax syntax) (Sql92UpdateExpressionSyntax syntax) s ]) + -- ^ A sequence of assignments to make. + -> (forall s. table (QExpr (Sql92UpdateExpressionSyntax syntax) s) -> QExpr (Sql92UpdateExpressionSyntax syntax) s Bool) + -- ^ Build a @WHERE@ clause given a table containing expressions + -> SqlUpdate syntax table +update (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkAssignments mkWhere = + SqlUpdate (updateStmt tblNm assignments (Just (where_ "t"))) + where + assignments = concatMap (\(QAssignment as) -> as) (mkAssignments tblFields) + QExpr where_ = mkWhere tblFieldExprs + + tblFields = changeBeamRep (\(Columnar' (TableField name)) -> Columnar' (QField tblNm name)) tblSettings + tblFieldExprs = changeBeamRep (\(Columnar' (QField _ nm)) -> Columnar' (QExpr (pure (fieldE (unqualifiedField nm))))) tblFields + +-- | Generate a 'SqlUpdate' that will update the given table with the given value. +-- +-- The SQL @UPDATE@ that is generated will set every non-primary key field for +-- the row where each primary key field is exactly what is given. +-- +-- Note: This is a pure SQL @UPDATE@ command. This does not upsert or merge values. +save :: forall table syntax be db. + ( Table table + , IsSql92UpdateSyntax syntax + + , SqlValableTable (PrimaryKey table) (Sql92UpdateExpressionSyntax syntax) + , SqlValableTable table (Sql92UpdateExpressionSyntax syntax) + + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92UpdateExpressionSyntax syntax)) Bool + ) + => DatabaseEntity be db (TableEntity table) + -- ^ Table to update + -> table Identity + -- ^ Value to set to + -> SqlUpdate syntax table +save tbl@(DatabaseEntity (DatabaseTable _ tblSettings)) v = + update tbl (\(tblField :: table (QField s)) -> + execWriter $ + zipBeamFieldsM + (\(Columnar' field) c@(Columnar' value) -> + do when (qFieldName field `notElem` primaryKeyFieldNames) $ + tell [ field <-. value ] + pure c) + tblField (val_ v :: table (QExpr (Sql92UpdateExpressionSyntax syntax) s))) + (\tblE -> primaryKey tblE ==. val_ (primaryKey v)) + + where + primaryKeyFieldNames = + allBeamValues (\(Columnar' (TableField fieldNm)) -> fieldNm) (primaryKey tblSettings) + +-- | Run a 'SqlUpdate' in a 'MonadBeam'. +runUpdate :: (IsSql92Syntax cmd, MonadBeam cmd be hdl m) + => SqlUpdate (Sql92UpdateSyntax cmd) tbl -> m () +runUpdate (SqlUpdate u) = runNoReturn (updateCmd u) + +-- * DELETE + +-- | Represents a SQL @DELETE@ statement for the given @table@ +newtype SqlDelete syntax (table :: (* -> *) -> *) = SqlDelete syntax + +-- | Build a 'SqlDelete' from a table and a way to build a @WHERE@ clause +delete :: IsSql92DeleteSyntax delete + => DatabaseEntity be db (TableEntity table) + -- ^ Table to delete from + -> (forall s. table (QExpr (Sql92DeleteExpressionSyntax delete) s) -> QExpr (Sql92DeleteExpressionSyntax delete) s Bool) + -- ^ Build a @WHERE@ clause given a table containing expressions + -> SqlDelete delete table +delete (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkWhere = + SqlDelete (deleteStmt tblNm (Just (where_ "t"))) + where + QExpr where_ = mkWhere (changeBeamRep (\(Columnar' (TableField name)) -> Columnar' (QExpr (pure (fieldE (unqualifiedField name))))) tblSettings) + +-- | Run a 'SqlDelete' in a 'MonadBeam' +runDelete :: (IsSql92Syntax cmd, MonadBeam cmd be hdl m) + => SqlDelete (Sql92DeleteSyntax cmd) table -> m () +runDelete (SqlDelete d) = runNoReturn (deleteCmd d) diff --git a/Database/Beam/Query/Aggregate.hs b/Database/Beam/Query/Aggregate.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Aggregate.hs @@ -0,0 +1,235 @@ +module Database.Beam.Query.Aggregate + ( -- * Aggregates + -- | See the corresponding + -- + -- for more detail + + aggregate_ + , filterWhere_ + + , QGroupable(..) + + -- ** General-purpose aggregate functions #gp-agg-funcs# + , sum_, avg_, min_, max_, count_, countAll_ + , rank_, cumeDist_, percentRank_, denseRank_ + + , every_, any_, some_ + + -- ** Quantified aggregate functions + -- | These functions correspond one-to-one with the <#gp-agg-funcs + -- general-purpose aggregate functions>. However, they each take a + -- mandatory "set quantifier", which is any of the + -- <#set-quantifiers set quantifier> values. + , sumOver_, avgOver_, minOver_, maxOver_, countOver_ + , everyOver_, anyOver_, someOver_ + + -- *** Set quantifiers #set-quantifiers# + , distinctInGroup_, allInGroup_, allInGroupExplicitly_ + ) where + +import Database.Beam.Query.Internal + +import Database.Beam.Backend.SQL +import Database.Beam.Schema.Tables + +import Control.Applicative +import Control.Monad.Writer +import Control.Monad.Free + +import Data.Typeable + +-- | Compute an aggregate over a query. +-- +-- The supplied aggregate projection should return an aggregate expression (an +-- expression containing an aggregate function such as 'count_', 'sum_', +-- 'countAll_', etc), a grouping key (specified with the 'group_' function), +-- or a combination of tuples of the above. +-- +-- Appropriate instances are provided up to 8-tuples. +-- +-- Semantically, all grouping expressions in the projection will be added to a +-- SQL @GROUP BY@ clause and all aggregate expressions will be computed. +-- +-- The return value will be the type of the aggregate projection, but +-- transformed to be in the normal value context (i.e., everything will become +-- 'QExpr's). +-- +-- For usage examples, see +-- . +aggregate_ :: forall select a r db s. + ( ProjectibleWithPredicate AggregateContext (Sql92SelectExpressionSyntax select) a + , Projectible (Sql92SelectExpressionSyntax select) r + , Projectible (Sql92SelectExpressionSyntax select) a + + , ContextRewritable a + , ThreadRewritable (QNested s) (WithRewrittenContext a QValueContext) + + , IsSql92SelectSyntax select ) + => (r -> a) -- ^ Aggregate projection + -> Q select db (QNested s) r -- ^ Query to aggregate over + -> Q select db s (WithRewrittenThread (QNested s) s (WithRewrittenContext a QValueContext)) +aggregate_ mkAggregation (Q aggregating) = + Q (liftF (QAggregate mkAggregation' aggregating (rewriteThread (Proxy @s) . rewriteContext (Proxy @QValueContext)))) + where + mkAggregation' x tblPfx = + let agg = mkAggregation x + doProject :: AggregateContext c => Proxy c -> WithExprContext (Sql92SelectExpressionSyntax select) + -> Writer [WithExprContext (Sql92SelectExpressionSyntax select)] + (WithExprContext (Sql92SelectExpressionSyntax select)) + doProject p expr = + case cast p of + Just (Proxy :: Proxy QGroupingContext) -> + tell [ expr ] >> pure expr + Nothing -> + case cast p of + Just (Proxy :: Proxy QAggregateContext) -> + pure expr + Nothing -> error "aggregate_: impossible" + + groupingExprs = execWriter (project' (Proxy @AggregateContext) doProject agg) + in case groupingExprs of + [] -> (Nothing, agg) + _ -> (Just (groupByExpressions (sequenceA groupingExprs tblPfx)), agg) + +-- | Type class for grouping keys. 'expr' is the type of the grouping key after +-- projection. 'grouped' is the type of the grouping key in the aggregate +-- expression (usually something that contains 'QGenExpr's in the +-- 'QGroupingContext'). +class QGroupable expr grouped | expr -> grouped, grouped -> expr where + group_ :: expr -> grouped + +-- | 'group_' for simple value expressions. +instance QGroupable (QExpr expr s a) (QGroupExpr expr s a) where + group_ (QExpr a) = QExpr a + +-- | 'group_' for any 'Beamable' type. Adds every field in the type to the +-- grouping key. This is the equivalent of including the grouping expression +-- of each field in the type as part of the aggregate projection +instance Beamable tbl => + QGroupable (tbl (QExpr expr s)) (tbl (QGroupExpr expr s)) where + group_ = changeBeamRep (\(Columnar' (QExpr x)) -> Columnar' (QExpr x)) + +-- | Compute an aggregate over all values in a group. Corresponds semantically +-- to the @AGG(ALL ..)@ syntax, but doesn't produce an explicit @ALL@. To +-- produce @ALL@ expicitly, see 'allInGroupExplicitly_'. +allInGroup_ :: IsSql92AggregationSetQuantifierSyntax s + => Maybe s +allInGroup_ = Nothing + +-- | Compute an aggregate only over distinct values in a group. Corresponds to +-- the @AGG(DISTINCT ..)@ syntax. +distinctInGroup_ :: IsSql92AggregationSetQuantifierSyntax s + => Maybe s +distinctInGroup_ = Just setQuantifierDistinct + +-- | Compute an aggregate over all values in a group. Corresponds to the +-- @AGG(ALL ..)@ syntax. Note that @ALL@ is the default for most aggregations, +-- so you don't normally explicitly specify @ALL@. However, if you need to, +-- you can use this function. To be explicit about quantification in the beam +-- query DSL, but not produce an explicit @ALL@, use 'allInGroup_'. +-- 'allInGroup_' has the same semantic meaning, but does not produce an +-- explicit @ALL@. +allInGroupExplicitly_ :: IsSql92AggregationSetQuantifierSyntax s + => Maybe s +allInGroupExplicitly_ = Just setQuantifierAll + +-- ** Aggregations + +-- | SQL @MIN(ALL ..)@ function (but without the explicit ALL) +min_ :: IsSql92AggregationExpressionSyntax expr + => QExpr expr s a -> QAgg expr s a +min_ = minOver_ allInGroup_ + +-- | SQL @MAX(ALL ..)@ function (but without the explicit ALL) +max_ :: IsSql92AggregationExpressionSyntax expr + => QExpr expr s a -> QAgg expr s a +max_ = maxOver_ allInGroup_ + +-- | SQL @AVG(ALL ..)@ function (but without the explicit ALL) +avg_ :: ( IsSql92AggregationExpressionSyntax expr, Num a ) + => QExpr expr s a -> QAgg expr s a +avg_ = avgOver_ allInGroup_ + +-- | SQL @SUM(ALL ..)@ function (but without the explicit ALL) +sum_ :: ( IsSql92AggregationExpressionSyntax expr, Num a ) + => QExpr expr s a -> QAgg expr s a +sum_ = sumOver_ allInGroup_ + +-- | SQL @COUNT(*)@ function +countAll_ :: IsSql92AggregationExpressionSyntax expr => QAgg expr s Int +countAll_ = QExpr (pure countAllE) + +-- | SQL @COUNT(ALL ..)@ function (but without the explicit ALL) +count_ :: ( IsSql92AggregationExpressionSyntax expr + , Integral b ) => QExpr expr s a -> QAgg expr s b +count_ (QExpr over) = QExpr (countE Nothing <$> over) + +-- | SQL2003 @CUME_DIST@ function (Requires T612 Advanced OLAP operations support) +cumeDist_ :: IsSql2003ExpressionAdvancedOLAPOperationsSyntax expr + => QAgg expr s Double +cumeDist_ = QExpr (pure cumeDistAggE) + +-- | SQL2003 @PERCENT_RANK@ function (Requires T612 Advanced OLAP operations support) +percentRank_ :: IsSql2003ExpressionAdvancedOLAPOperationsSyntax expr + => QAgg expr s Double +percentRank_ = QExpr (pure percentRankAggE) + +denseRank_ :: IsSql2003ExpressionAdvancedOLAPOperationsSyntax expr + => QAgg expr s Int +denseRank_ = QExpr (pure denseRankAggE) + +-- | SQL2003 @RANK@ function (Requires T611 Elementary OLAP operations support) +rank_ :: IsSql2003ExpressionElementaryOLAPOperationsSyntax expr + => QAgg expr s Int +rank_ = QExpr (pure rankAggE) + +minOver_, maxOver_ + :: IsSql92AggregationExpressionSyntax expr + => Maybe (Sql92AggregationSetQuantifierSyntax expr) + -> QExpr expr s a -> QAgg expr s a +minOver_ q (QExpr a) = QExpr (minE q <$> a) +maxOver_ q (QExpr a) = QExpr (maxE q <$> a) + +avgOver_, sumOver_ + :: ( IsSql92AggregationExpressionSyntax expr + , Num a ) + => Maybe (Sql92AggregationSetQuantifierSyntax expr) + -> QExpr expr s a -> QAgg expr s a +avgOver_ q (QExpr a) = QExpr (avgE q <$> a) +sumOver_ q (QExpr a) = QExpr (sumE q <$> a) + +countOver_ + :: ( IsSql92AggregationExpressionSyntax expr + , Integral b ) + => Maybe (Sql92AggregationSetQuantifierSyntax expr) + -> QExpr expr s a -> QAgg expr s b +countOver_ q (QExpr a) = QExpr (countE q <$> a) + +everyOver_, someOver_, anyOver_ + :: IsSql99AggregationExpressionSyntax expr + => Maybe (Sql92AggregationSetQuantifierSyntax expr) + -> QExpr expr s Bool -> QAgg expr s Bool +everyOver_ q (QExpr a) = QExpr (everyE q <$> a) +someOver_ q (QExpr a) = QExpr (someE q <$> a) +anyOver_ q (QExpr a) = QExpr (anyE q <$> a) + +-- | Support for FILTER (WHERE ...) syntax for aggregates. +-- Part of SQL2003 Advanced OLAP operations feature (T612) +filterWhere_ :: IsSql2003ExpressionElementaryOLAPOperationsSyntax expr + => QAgg expr s a -> QExpr expr s Bool -> QAgg expr s a +filterWhere_ (QExpr agg) (QExpr cond) = QExpr (liftA2 filterAggE agg cond) + +-- | SQL99 @EVERY(ALL ..)@ function (but without the explicit ALL) +every_ :: IsSql99AggregationExpressionSyntax expr + => QExpr expr s Bool -> QAgg expr s Bool +every_ = everyOver_ allInGroup_ + +-- | SQL99 @SOME(ALL ..)@ function (but without the explicit ALL) +some_ :: IsSql99AggregationExpressionSyntax expr + => QExpr expr s Bool -> QAgg expr s Bool +some_ = someOver_ allInGroup_ + +-- | SQL99 @ANY(ALL ..)@ function (but without the explicit ALL) +any_ :: IsSql99AggregationExpressionSyntax expr + => QExpr expr s Bool -> QAgg expr s Bool +any_ = anyOver_ allInGroup_ diff --git a/Database/Beam/Query/Combinators.hs b/Database/Beam/Query/Combinators.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Combinators.hs @@ -0,0 +1,789 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Database.Beam.Query.Combinators + ( -- * Various SQL functions and constructs + coalesce_, position_ + , charLength_, octetLength_, bitLength_ + , currentTimestamp_ + + -- ** @IF-THEN-ELSE@ support + , if_, then_, else_ + + -- * SQL @UPDATE@ assignments + , (<-.), current_ + + -- * Project Haskell values to 'QGenExpr's + , HaskellLiteralForQExpr + , SqlValable(..), SqlValableTable + , default_, auto_ + + -- * General query combinators + + , all_ + , allFromView_, join_, guard_, filter_ + , related_, relatedBy_ + , leftJoin_, perhaps_ + , outerJoin_ + , subselect_, references_ + + , nub_ + + , SqlJustable(..) + , SqlDeconstructMaybe(..) + , SqlOrderable + , QIfCond, QIfElse + + , limit_, offset_ + + , as_ + + -- ** Subqueries + , exists_, unique_, distinct_, subquery_ + + -- ** Set operations + -- | 'Q' values can be combined using a variety of set operations. See the + -- . + , union_, unionAll_ + , intersect_, intersectAll_ + , except_, exceptAll_ + + -- * Window functions + -- | See the corresponding + -- for more. + , over_, frame_, bounds_, unbounded_, nrows_, fromBound_ + , noBounds_, noOrder_, noPartition_ + , partitionBy_, orderPartitionBy_, withWindow_ + + -- * Ordering primitives + , orderBy_, asc_, desc_, nullsFirst_, nullsLast_ + ) where + +import Database.Beam.Backend.Types +import Database.Beam.Backend.SQL + +import Database.Beam.Query.Internal +import Database.Beam.Query.Ord +import Database.Beam.Query.Operator +import Database.Beam.Query.Types + +import Database.Beam.Schema.Tables + +import Control.Monad.Writer +import Control.Monad.Identity +import Control.Monad.Free +import Control.Applicative + +import Data.Maybe +import Data.Proxy +import Data.Time (LocalTime) + +import GHC.Generics + +-- | Introduce all entries of a table into the 'Q' monad +all_ :: forall be (db :: (* -> *) -> *) table select s. + ( Database db + , IsSql92SelectSyntax select + + , IsSql92FromSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) + , IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) + , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) + + , Table table ) + => DatabaseEntity be db (TableEntity table) + -> Q select db s (table (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) +all_ (DatabaseEntity (DatabaseTable tblNm tblSettings)) = + Q $ liftF (QAll tblNm tblSettings (\_ -> Nothing) id) + +-- | Introduce all entries of a view into the 'Q' monad +allFromView_ :: forall be (db :: (* -> *) -> *) table select s. + ( Database db + , IsSql92SelectSyntax select + + , IsSql92FromSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) + , IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) + , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) + , Beamable table ) + => DatabaseEntity be db (ViewEntity table) + -> Q select db s (table (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) +allFromView_ (DatabaseEntity (DatabaseView tblNm tblSettings)) = + Q $ liftF (QAll tblNm tblSettings (\_ -> Nothing) id) + +-- | Introduce all entries of a table into the 'Q' monad based on the given +-- QExpr +join_ :: ( Database db, Table table + , IsSql92SelectSyntax select + , IsSql92FromSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) + , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) + , IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) ) => + DatabaseEntity be db (TableEntity table) + -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool) + -> Q select db s (table (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) +join_ (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkOn = + Q $ liftF (QAll tblNm tblSettings (\tbl -> let QExpr on = mkOn tbl in Just on) id) + +-- | Introduce a table using a left join with no ON clause. Because this is not +-- an inner join, the resulting table is made nullable. This means that each +-- field that would normally have type 'QExpr x' will now have type 'QExpr +-- (Maybe x)'. +perhaps_ :: forall s r select db. + ( Projectible (Sql92SelectExpressionSyntax select) r + , IsSql92SelectSyntax select + , ThreadRewritable (QNested s) r + , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s r) ) + => Q select db (QNested s) r + -> Q select db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) +perhaps_ (Q sub) = + Q $ liftF (QArbitraryJoin + sub leftJoin + (\_ -> Nothing) + (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr (Sql92SelectExpressionSyntax select) s) a) -> + Columnar' (QExpr e) :: Columnar' (Nullable (QExpr (Sql92SelectExpressionSyntax select) s)) a) $ + rewriteThread (Proxy @s) r)) + +outerJoin_ :: forall s a b select db. + ( Projectible (Sql92SelectExpressionSyntax select) a, Projectible (Sql92SelectExpressionSyntax select) b + , ThreadRewritable (QNested s) a, ThreadRewritable (QNested s) b + , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s a) + , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s b) + , IsSql92FromOuterJoinSyntax (Sql92SelectFromSyntax select) ) + => Q select db (QNested s) a + -> Q select db (QNested s) b + -> ( (WithRewrittenThread (QNested s) s a, WithRewrittenThread (QNested s) s b) -> QExpr (Sql92SelectExpressionSyntax select) s Bool ) + -> Q select db s ( Retag Nullable (WithRewrittenThread (QNested s) s a) + , Retag Nullable (WithRewrittenThread (QNested s) s b) ) +outerJoin_ (Q a) (Q b) on_ = + Q $ liftF (QTwoWayJoin a b outerJoin + (\(a', b') -> + let QExpr e = on_ (rewriteThread (Proxy @s) a', rewriteThread (Proxy @s) b') + in Just e) + (\(a', b') -> + let retag' :: (ThreadRewritable (QNested s) x, Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s x)) + => x -> Retag Nullable (WithRewrittenThread (QNested s) s x) + retag' = retag (\(Columnar' (QExpr e) :: Columnar' (QExpr (Sql92SelectExpressionSyntax select) s) x) -> + Columnar' (QExpr e) :: Columnar' (Nullable (QExpr (Sql92SelectExpressionSyntax select) s)) x) . + rewriteThread (Proxy @s) + in ( retag' a', retag' b' ))) + +-- | Introduce a table using a left join. The ON clause is required here.Because +-- this is not an inner join, the resulting table is made nullable. This means +-- that each field that would normally have type 'QExpr x' will now have type +-- 'QExpr (Maybe x)'. +leftJoin_ :: forall s r select db. + ( Projectible (Sql92SelectExpressionSyntax select) r + , IsSql92SelectSyntax select + , ThreadRewritable (QNested s) r + , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s r) ) + => Q select db (QNested s) r + -> (WithRewrittenThread (QNested s) s r -> QExpr (Sql92SelectExpressionSyntax select) s Bool) + -> Q select db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) +leftJoin_ (Q sub) on_ = + Q $ liftF (QArbitraryJoin + sub leftJoin + (\r -> let QExpr e = on_ (rewriteThread (Proxy @s) r) in Just e) + (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr (Sql92SelectExpressionSyntax select) s) a) -> + Columnar' (QExpr e) :: Columnar' (Nullable (QExpr (Sql92SelectExpressionSyntax select) s)) a) $ + rewriteThread (Proxy @s) r)) + +subselect_ :: forall s r select db. + ( ThreadRewritable (QNested s) r + , ProjectibleInSelectSyntax select r ) + => Q select db (QNested s) r + -> Q select db s (WithRewrittenThread (QNested s) s r) +subselect_ (Q q') = + Q (liftF (QSubSelect q' (rewriteThread (Proxy @s)))) + +-- | Only allow results for which the 'QExpr' yields 'True' +guard_ :: forall select db s. + ( IsSql92SelectSyntax select ) => + QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool -> Q select db s () +guard_ (QExpr guardE') = + Q (liftF (QGuard guardE' ())) + +-- | Synonym for @clause >>= \x -> guard_ (mkExpr x)>> pure x@ +filter_ :: forall r select db s. + ( IsSql92SelectSyntax select ) + => (r -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool) + -> Q select db s r -> Q select db s r +filter_ mkExpr clause = clause >>= \x -> guard_ (mkExpr x) >> pure x + +-- | Introduce all entries of the given table which are referenced by the given 'PrimaryKey' +related_ :: forall be db rel select s. + ( IsSql92SelectSyntax select + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select))) Bool + , Database db, Table rel ) => + DatabaseEntity be db (TableEntity rel) + -> PrimaryKey rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s) + -> Q select db s (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) +related_ relTbl relKey = + join_ relTbl (\rel -> relKey ==. primaryKey rel) + +-- | Introduce all entries of the given table which for which the expression (which can depend on the queried table returns true) +relatedBy_ :: forall be db rel select s. + ( Database db, Table rel + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select))) Bool + , IsSql92SelectSyntax select ) + => DatabaseEntity be db (TableEntity rel) + -> (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s) -> + QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool) + -> Q select db s (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) +relatedBy_ = join_ + +-- | Generate an appropriate boolean 'QGenExpr' comparing the given foreign key +-- to the given table. Useful for creating join conditions. +references_ :: ( IsSql92ExpressionSyntax expr + , HasSqlValueSyntax (Sql92ExpressionValueSyntax expr) Bool + , Table t ) + => PrimaryKey t (QGenExpr ctxt expr s) -> t (QGenExpr ctxt expr s) -> QGenExpr ctxt expr s Bool +references_ fk tbl = fk ==. pk tbl + +-- | Only return distinct values from a query +nub_ :: ( IsSql92SelectSyntax select + , Projectible (Sql92SelectExpressionSyntax select) r ) + => Q select db s r -> Q select db s r +nub_ (Q sub) = Q $ liftF (QDistinct (\_ _ -> setQuantifierDistinct) sub id) + +-- | Limit the number of results returned by a query. +limit_ :: forall s a select db. + ( ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a ) => + Integer -> Q select db (QNested s) a -> Q select db s (WithRewrittenThread (QNested s) s a) +limit_ limit' (Q q) = + Q (liftF (QLimit limit' q (rewriteThread (Proxy @s)))) + +-- | Drop the first `offset'` results. +offset_ :: forall s a select db. + ( ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a ) => + Integer -> Q select db (QNested s) a -> Q select db s (WithRewrittenThread (QNested s) s a) +offset_ offset' (Q q) = + Q (liftF (QOffset offset' q (rewriteThread (Proxy @s)))) + +-- | Use the SQL @EXISTS@ operator to determine if the given query returns any results +exists_ :: ( IsSql92SelectSyntax select + , HasQBuilder select + , ProjectibleInSelectSyntax select a + , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) + => Q select db s a + -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool +exists_ q = QExpr (\tbl -> existsE (buildSqlQuery tbl q)) + +-- | Use the SQL @UNIQUE@ operator to determine if the given query produces a unique result +unique_ :: ( IsSql92SelectSyntax select + , HasQBuilder select + , ProjectibleInSelectSyntax select a + , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) + => Q select db s a + -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool +unique_ q = QExpr (\tbl -> uniqueE (buildSqlQuery tbl q)) + +-- | Use the SQL99 @DISTINCT@ operator to determine if the given query produces a distinct result +distinct_ :: ( IsSql99ExpressionSyntax (Sql92SelectExpressionSyntax select) + , HasQBuilder select + , ProjectibleInSelectSyntax select a + , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) => + Q select db s a + -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool +distinct_ q = QExpr (\tbl -> distinctE (buildSqlQuery tbl q)) + +-- | Project the (presumably) singular result of the given query as an expression +subquery_ :: + ( IsSql92SelectSyntax select + , HasQBuilder select + , ProjectibleInSelectSyntax select (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s a) + , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) => + Q select (db :: (* -> *) -> *) s (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s a) + -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s a +subquery_ q = + QExpr (\tbl -> subqueryE (buildSqlQuery tbl q)) + +-- | SQL @CHAR_LENGTH@ function +charLength_ :: ( IsSqlExpressionSyntaxStringType syntax text + , IsSql92ExpressionSyntax syntax ) + => QGenExpr context syntax s text -> QGenExpr context syntax s Int +charLength_ (QExpr s) = QExpr (charLengthE <$> s) + +-- | SQL @OCTET_LENGTH@ function +octetLength_ :: ( IsSqlExpressionSyntaxStringType syntax text + , IsSql92ExpressionSyntax syntax ) + => QGenExpr context syntax s text -> QGenExpr context syntax s Int +octetLength_ (QExpr s) = QExpr (octetLengthE <$> s) + +-- | SQL @BIT_LENGTH@ function +bitLength_ :: + IsSql92ExpressionSyntax syntax => + QGenExpr context syntax s SqlBitString -> QGenExpr context syntax s Int +bitLength_ (QExpr x) = QExpr (bitLengthE <$> x) + +-- | SQL @CURRENT_TIMESTAMP@ function +currentTimestamp_ :: IsSql92ExpressionSyntax syntax => QGenExpr ctxt syntax s LocalTime +currentTimestamp_ = QExpr (pure currentTimestampE) + +-- | SQL @POSITION(.. IN ..)@ function +position_ :: + ( IsSqlExpressionSyntaxStringType syntax text + , IsSql92ExpressionSyntax syntax, Integral b ) => + QExpr syntax s text -> QExpr syntax s text -> QExpr syntax s b +position_ (QExpr needle) (QExpr haystack) = + QExpr (liftA2 likeE needle haystack) + +-- | Combine all the given boolean value 'QGenExpr's with the '&&.' operator. +allE :: ( IsSql92ExpressionSyntax syntax, HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool) => + [ QGenExpr context syntax s Bool ] -> QGenExpr context syntax s Bool +allE es = fromMaybe (QExpr (pure (valueE (sqlValueSyntax True)))) $ + foldl (\expr x -> + Just $ maybe x (\e -> e &&. x) expr) + Nothing es + +-- * UPDATE operators + +-- | Extract an expression representing the current (non-UPDATEd) value of a 'QField' +current_ :: IsSql92ExpressionSyntax expr + => QField s ty -> QExpr expr s ty +current_ (QField _ nm) = QExpr (pure (fieldE (unqualifiedField nm))) + +infix 4 <-. +class SqlUpdatable expr s lhs rhs | rhs -> expr, lhs -> s, rhs -> s, lhs s expr -> rhs, rhs -> lhs where + -- | Update a 'QField' or 'Beamable' type containing 'QField's with the given + -- 'QExpr' or 'Beamable' type containing 'QExpr' + (<-.) :: forall fieldName. + IsSql92FieldNameSyntax fieldName + => lhs + -> rhs + -> QAssignment fieldName expr s +instance SqlUpdatable expr s (QField s a) (QExpr expr s a) where + QField _ fieldNm <-. QExpr expr = + QAssignment [(unqualifiedField fieldNm, expr "t")] +instance Beamable tbl => SqlUpdatable expr s (tbl (QField s)) (tbl (QExpr expr s)) where + (<-.) :: forall fieldName. + IsSql92FieldNameSyntax fieldName + => tbl (QField s) -> tbl (QExpr expr s) + -> QAssignment fieldName expr s + lhs <-. rhs = + QAssignment $ + allBeamValues (\(Columnar' (Const assignments)) -> assignments) $ + runIdentity $ + zipBeamFieldsM (\(Columnar' (QField _ f) :: Columnar' (QField s) t) (Columnar' (QExpr e)) -> + pure (Columnar' (Const (unqualifiedField f, e "t")) :: Columnar' (Const (fieldName,expr)) t)) lhs rhs +instance Beamable tbl => SqlUpdatable expr s (tbl (Nullable (QField s))) (tbl (Nullable (QExpr expr s))) where + lhs <-. rhs = + let lhs' = changeBeamRep (\(Columnar' (QField tblName fieldName') :: Columnar' (Nullable (QField s)) a) -> + Columnar' (QField tblName fieldName') :: Columnar' (QField s) a) lhs + rhs' = changeBeamRep (\(Columnar' (QExpr e) :: Columnar' (Nullable (QExpr expr s)) a) -> + Columnar' (QExpr e) :: Columnar' (QExpr expr s) a) rhs + in lhs' <-. rhs' + +-- | SQL @UNION@ operator +union_ :: forall select db s a. + ( IsSql92SelectSyntax select + , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a + , ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a) + => Q select db (QNested s) a -> Q select db (QNested s) a + -> Q select db s (WithRewrittenThread (QNested s) s a) +union_ (Q a) (Q b) = Q (liftF (QUnion False a b (rewriteThread (Proxy @s)))) + +-- | SQL @UNION ALL@ operator +unionAll_ :: forall select db s a. + ( IsSql92SelectSyntax select + , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a + , ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a) + => Q select db (QNested s) a -> Q select db (QNested s) a + -> Q select db s (WithRewrittenThread (QNested s) s a) +unionAll_ (Q a) (Q b) = Q (liftF (QUnion True a b (rewriteThread (Proxy @s)))) + +-- | SQL @INTERSECT@ operator +intersect_ :: forall select db s a. + ( IsSql92SelectSyntax select + , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a + , ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a) + => Q select db (QNested s) a -> Q select db (QNested s) a + -> Q select db s (WithRewrittenThread (QNested s) s a) +intersect_ (Q a) (Q b) = Q (liftF (QIntersect False a b (rewriteThread (Proxy @s)))) + +-- | SQL @INTERSECT ALL@ operator +intersectAll_ :: forall select db s a. + ( IsSql92SelectSyntax select + , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a + , ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a) + => Q select db (QNested s) a -> Q select db (QNested s) a + -> Q select db s (WithRewrittenThread (QNested s) s a) +intersectAll_ (Q a) (Q b) = Q (liftF (QIntersect True a b (rewriteThread (Proxy @s)))) + +-- | SQL @EXCEPT@ operator +except_ :: forall select db s a. + ( IsSql92SelectSyntax select + , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a + , ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a) + => Q select db (QNested s) a -> Q select db (QNested s) a + -> Q select db s (WithRewrittenThread (QNested s) s a) +except_ (Q a) (Q b) = Q (liftF (QExcept False a b (rewriteThread (Proxy @s)))) + +-- | SQL @EXCEPT ALL@ operator +exceptAll_ :: forall select db s a. + ( IsSql92SelectSyntax select + , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a + , ProjectibleInSelectSyntax select a + , ThreadRewritable (QNested s) a) + => Q select db (QNested s) a -> Q select db (QNested s) a + -> Q select db s (WithRewrittenThread (QNested s) s a) +exceptAll_ (Q a) (Q b) = Q (liftF (QExcept True a b (rewriteThread (Proxy @s)))) + +-- | Convenience function that allows you to use type applications to specify +-- the result of a 'QGenExpr'. +-- +-- Useful to disambiguate the types of 'QGenExpr's without having to provide a +-- complete type signature. As an example, the 'countAll_' aggregate can +-- return a result of any 'Integral' type. Without further constraints, the +-- type is ambiguous. You can use 'as_' to disambiguate the return type. +-- +-- For example, this is ambiguous +-- +-- > aggregate_ (\_ -> countAll_) .. +-- +-- But this is not +-- +-- > aggregate_ (\_ -> as_ @Int countAll_) .. +-- +as_ :: forall a ctxt syntax s. QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a +as_ = id + +-- * Marshalling between Haskell literals and QExprs + +type family HaskellLiteralForQExpr x = a +type instance HaskellLiteralForQExpr (QGenExpr context syntax s a) = a +type instance HaskellLiteralForQExpr (table (QGenExpr context syntax s)) = table Identity +type instance HaskellLiteralForQExpr (table (Nullable f)) = HaskellLiteralForQExpr_AddNullable (HaskellLiteralForQExpr (table f)) + +type family HaskellLiteralForQExpr_AddNullable x = a +type instance HaskellLiteralForQExpr_AddNullable (tbl f) = tbl (Nullable f) + +type family QExprSyntax x where + QExprSyntax (QGenExpr ctxt syntax s a) = syntax + +type SqlValableTable table expr = + ( Beamable table + , IsSql92ExpressionSyntax expr + , FieldsFulfillConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax expr)) table ) + +class SqlValable a where + val_ :: HaskellLiteralForQExpr a -> a + +instance (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) a, IsSql92ExpressionSyntax syntax) => + SqlValable (QGenExpr ctxt syntax s a) where + + val_ = QExpr . pure . valueE . sqlValueSyntax +instance ( Beamable table + , IsSql92ExpressionSyntax syntax + , FieldsFulfillConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) table ) => + SqlValable (table (QGenExpr ctxt syntax s)) where + val_ tbl = + let fields :: table (WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax))) + fields = to (gWithConstrainedFields (Proxy @(HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax))) + (Proxy @(Rep (table Exposed))) (from tbl)) + in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) x)) -> + Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields +instance ( Beamable table + , IsSql92ExpressionSyntax syntax + + , FieldsFulfillConstraintNullable (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) table ) => + + SqlValable (table (Nullable (QGenExpr ctxt syntax s))) where + + val_ tbl = + let fields :: table (Nullable (WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)))) + fields = to (gWithConstrainedFields (Proxy @(HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax))) + (Proxy @(Rep (table (Nullable Exposed)))) (from tbl)) + in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) (Maybe x))) -> + Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields + +default_ :: IsSql92ExpressionSyntax expr + => QGenExpr ctxt expr s a +default_ = QExpr (pure defaultE) + +auto_ :: QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s (Auto a) +auto_ = unsafeRetype + +-- * Window functions + +noBounds_ :: QFrameBounds syntax +noBounds_ = QFrameBounds Nothing + +fromBound_ :: IsSql2003WindowFrameBoundsSyntax syntax + => QFrameBound (Sql2003WindowFrameBoundsBoundSyntax syntax) + -> QFrameBounds syntax +fromBound_ start = bounds_ start Nothing + +bounds_ :: IsSql2003WindowFrameBoundsSyntax syntax + => QFrameBound (Sql2003WindowFrameBoundsBoundSyntax syntax) + -> Maybe (QFrameBound (Sql2003WindowFrameBoundsBoundSyntax syntax)) + -> QFrameBounds syntax +bounds_ (QFrameBound start) end = + QFrameBounds . Just $ + fromToBoundSyntax start + (fmap (\(QFrameBound end') -> end') end) + +unbounded_ :: IsSql2003WindowFrameBoundSyntax syntax + => QFrameBound syntax +unbounded_ = QFrameBound unboundedSyntax + +nrows_ :: IsSql2003WindowFrameBoundSyntax syntax + => Int -> QFrameBound syntax +nrows_ x = QFrameBound (nrowsBoundSyntax x) + +noPartition_, noOrder_ :: Maybe (QOrd syntax s Int) +noOrder_ = Nothing +noPartition_ = Nothing + +partitionBy_, orderPartitionBy_ :: partition -> Maybe partition +partitionBy_ = Just +orderPartitionBy_ = Just + +-- | Specify a window frame with all the options +frame_ :: ( IsSql2003ExpressionSyntax syntax + , SqlOrderable (Sql2003WindowFrameOrderingSyntax (Sql2003ExpressionWindowFrameSyntax syntax)) ordering + , Projectible syntax partition + , Sql2003ExpressionSanityCheck syntax ) + => Maybe partition {-^ PARTITION BY -} + -> Maybe ordering {-^ ORDER BY -} + -> QFrameBounds (Sql2003WindowFrameBoundsSyntax (Sql2003ExpressionWindowFrameSyntax syntax)) {-^ RANGE / ROWS -} + -> QWindow (Sql2003ExpressionWindowFrameSyntax syntax) s +frame_ partition_ ordering_ (QFrameBounds bounds) = + QWindow $ \tblPfx -> + frameSyntax (case maybe [] (flip project tblPfx) partition_ of + [] -> Nothing + xs -> Just xs) + (case fmap makeSQLOrdering ordering_ of + Nothing -> Nothing + Just [] -> Nothing + Just xs -> Just (sequenceA xs tblPfx)) + bounds + +-- | Produce a window expression given an aggregate function and a window. +over_ :: IsSql2003ExpressionSyntax syntax => + QAgg syntax s a -> QWindow (Sql2003ExpressionWindowFrameSyntax syntax) s -> QWindowExpr syntax s a +over_ (QExpr a) (QWindow frame) = QExpr (overE <$> a <*> frame) + +-- | Compute a query over windows. +-- +-- The first function builds window frames using the 'frame_', 'partitionBy_', +-- etc functions. The return type can be a single frame, tuples of frame, or +-- any arbitrarily nested tuple of the above. Instances up to 8-tuples are +-- provided. +-- +-- The second function builds the resulting projection using the result of the +-- subquery as well as the window frames built in the first function. In this +-- function, window expressions can be included in the output using the +-- 'over_' function. +-- +withWindow_ :: forall window a s r select db. + ( ProjectibleWithPredicate WindowFrameContext (Sql2003ExpressionWindowFrameSyntax (Sql92SelectExpressionSyntax select)) window + , Projectible (Sql92SelectExpressionSyntax select) r + , Projectible (Sql92SelectExpressionSyntax select) a + , ContextRewritable a + , ThreadRewritable (QNested s) (WithRewrittenContext a QValueContext) + , IsSql92SelectSyntax select) + => (r -> window) -- ^ Window builder function + -> (r -> window -> a) -- ^ Projection builder function. Has access to the windows generated above + -> Q select db (QNested s) r -- ^ Query to window over + -> Q select db s (WithRewrittenThread (QNested s) s (WithRewrittenContext a QValueContext)) +withWindow_ mkWindow mkProjection (Q windowOver)= + Q (liftF (QWindowOver mkWindow mkProjection windowOver (rewriteThread (Proxy @s) . rewriteContext (Proxy @QValueContext)))) + +-- * Order bys + +class SqlOrderable syntax a | a -> syntax where + makeSQLOrdering :: a -> [ WithExprContext syntax ] +instance SqlOrderable syntax (QOrd syntax s a) where + makeSQLOrdering (QExpr x) = [x] +instance SqlOrderable syntax a => SqlOrderable syntax [a] where + makeSQLOrdering = concatMap makeSQLOrdering +instance ( SqlOrderable syntax a + , SqlOrderable syntax b ) => SqlOrderable syntax (a, b) where + makeSQLOrdering (a, b) = makeSQLOrdering a <> makeSQLOrdering b +instance ( SqlOrderable syntax a + , SqlOrderable syntax b + , SqlOrderable syntax c ) => SqlOrderable syntax (a, b, c) where + makeSQLOrdering (a, b, c) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c +instance ( SqlOrderable syntax a + , SqlOrderable syntax b + , SqlOrderable syntax c + , SqlOrderable syntax d ) => SqlOrderable syntax (a, b, c, d) where + makeSQLOrdering (a, b, c, d) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d +instance ( SqlOrderable syntax a + , SqlOrderable syntax b + , SqlOrderable syntax c + , SqlOrderable syntax d + , SqlOrderable syntax e ) => SqlOrderable syntax (a, b, c, d, e) where + makeSQLOrdering (a, b, c, d, e) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> makeSQLOrdering e +instance ( SqlOrderable syntax a + , SqlOrderable syntax b + , SqlOrderable syntax c + , SqlOrderable syntax d + , SqlOrderable syntax e + , SqlOrderable syntax f ) => SqlOrderable syntax (a, b, c, d, e, f) where + makeSQLOrdering (a, b, c, d, e, f) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> makeSQLOrdering e <> makeSQLOrdering f +instance ( SqlOrderable syntax a + , SqlOrderable syntax b + , SqlOrderable syntax c + , SqlOrderable syntax d + , SqlOrderable syntax e + , SqlOrderable syntax f + , SqlOrderable syntax g ) => SqlOrderable syntax (a, b, c, d, e, f, g) where + makeSQLOrdering (a, b, c, d, e, f, g) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> + makeSQLOrdering e <> makeSQLOrdering f <> makeSQLOrdering g +instance ( SqlOrderable syntax a + , SqlOrderable syntax b + , SqlOrderable syntax c + , SqlOrderable syntax d + , SqlOrderable syntax e + , SqlOrderable syntax f + , SqlOrderable syntax g + , SqlOrderable syntax h) => SqlOrderable syntax (a, b, c, d, e, f, g, h) where + makeSQLOrdering (a, b, c, d, e, f, g, h) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> + makeSQLOrdering e <> makeSQLOrdering f <> makeSQLOrdering g <> makeSQLOrdering h + +-- | Order by the given expressions. The return type of the ordering key should +-- either be the result of 'asc_' or 'desc_' (or another ordering 'QOrd' +-- generated by a backend-specific ordering) or an (possibly nested) tuple of +-- results of the former. +-- +-- The +-- has more information. +orderBy_ :: forall s a ordering syntax db. + ( Projectible (Sql92SelectExpressionSyntax syntax) a + , SqlOrderable (Sql92SelectOrderingSyntax syntax) ordering + , ThreadRewritable (QNested s) a) => + (a -> ordering) -> Q syntax db (QNested s) a -> Q syntax db s (WithRewrittenThread (QNested s) s a) +orderBy_ orderer (Q q) = + Q (liftF (QOrderBy (sequenceA . makeSQLOrdering . orderer) q (rewriteThread (Proxy @s)))) + +nullsFirst_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax syntax + => QOrd syntax s a + -> QOrd syntax s a +nullsFirst_ (QExpr e) = QExpr (nullsFirstOrdering <$> e) + +nullsLast_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax syntax + => QOrd syntax s a + -> QOrd syntax s a +nullsLast_ (QExpr e) = QExpr (nullsLastOrdering <$> e) + +-- | Produce a 'QOrd' corresponding to a SQL @ASC@ ordering +asc_ :: forall syntax s a. IsSql92OrderingSyntax syntax + => QExpr (Sql92OrderingExpressionSyntax syntax) s a + -> QOrd syntax s a +asc_ (QExpr e) = QExpr (ascOrdering <$> e) + +-- | Produce a 'QOrd' corresponding to a SQL @DESC@ ordering +desc_ :: forall syntax s a. IsSql92OrderingSyntax syntax + => QExpr (Sql92OrderingExpressionSyntax syntax) s a + -> QOrd syntax s a +desc_ (QExpr e) = QExpr (descOrdering <$> e) + +-- * Subqueries + +-- * Nullable conversions + +-- | Type class for things that can be nullable. This includes 'QExpr (Maybe a)', 'tbl (Nullable +-- QExpr)', and 'PrimaryKey tbl (Nullable QExpr)' +class SqlJustable a b | b -> a where + + -- | Given something of type 'QExpr a', 'tbl QExpr', or 'PrimaryKey tbl + -- QExpr', turn it into a 'QExpr (Maybe a)', 'tbl (Nullable QExpr)', or + -- 'PrimaryKey t (Nullable QExpr)' respectively that contains the same + -- values. + just_ :: a -> b + + -- | Return either a 'QExpr (Maybe x)' representing 'Nothing' or a nullable 'Table' or + -- 'PrimaryKey' filled with 'Nothing'. + nothing_ :: b + +instance ( IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) SqlNull) => + SqlJustable (QExpr syntax s a) (QExpr syntax s (Maybe a)) where + + just_ (QExpr e) = QExpr e + nothing_ = QExpr (pure (valueE (sqlValueSyntax SqlNull))) + +instance {-# OVERLAPPING #-} ( Table t + , IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) SqlNull ) => + SqlJustable (PrimaryKey t (QExpr syntax s)) (PrimaryKey t (Nullable (QExpr syntax s))) where + just_ = changeBeamRep (\(Columnar' q) -> Columnar' (just_ q)) + nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' nothing_) (primaryKey (tblSkeleton :: TableSkeleton t)) + +instance {-# OVERLAPPING #-} ( Table t + , IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) SqlNull ) => + SqlJustable (t (QExpr syntax s)) (t (Nullable (QExpr syntax s))) where + just_ = changeBeamRep (\(Columnar' q) -> Columnar' (just_ q)) + nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' nothing_) (tblSkeleton :: TableSkeleton t) + +instance {-# OVERLAPPING #-} Table t => SqlJustable (PrimaryKey t Identity) (PrimaryKey t (Nullable Identity)) where + just_ = changeBeamRep (\(Columnar' q) -> Columnar' (Just q)) + nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' Nothing) (primaryKey (tblSkeleton :: TableSkeleton t)) + +instance {-# OVERLAPPING #-} Table t => SqlJustable (t Identity) (t (Nullable Identity)) where + just_ = changeBeamRep (\(Columnar' q) -> Columnar' (Just q)) + nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' Nothing) (tblSkeleton :: TableSkeleton t) + +-- * Nullable checking + +data QIfCond context expr s a = QIfCond (QGenExpr context expr s Bool) (QGenExpr context expr s a) +newtype QIfElse context expr s a = QIfElse (QGenExpr context expr s a) + +then_ :: QGenExpr context expr s Bool -> QGenExpr context expr s a -> QIfCond context expr s a +then_ cond res = QIfCond cond res + +else_ :: QGenExpr context expr s a -> QIfElse context expr s a +else_ = QIfElse + +if_ :: IsSql92ExpressionSyntax expr => + [ QIfCond context expr s a ] + -> QIfElse context expr s a + -> QGenExpr context expr s a +if_ conds (QIfElse (QExpr elseExpr)) = + QExpr (\tbl -> caseE (map (\(QIfCond (QExpr cond) (QExpr res)) -> (cond tbl, res tbl)) conds) (elseExpr tbl)) + +-- | SQL @COALESCE@ support +coalesce_ :: IsSql92ExpressionSyntax expr => + [ QExpr expr s (Maybe a) ] -> QExpr expr s a -> QExpr expr s a +coalesce_ qs (QExpr onNull) = + QExpr $ do + onNull' <- onNull + coalesceE . (<> [onNull']) <$> mapM (\(QExpr q) -> q) qs + +-- | Type class for anything which can be checked for null-ness. This includes 'QExpr (Maybe a)' as +-- well as 'Table's or 'PrimaryKey's over 'Nullable QExpr'. +class IsSql92ExpressionSyntax syntax => SqlDeconstructMaybe syntax a nonNullA s | a s -> syntax, a -> nonNullA, a -> s, nonNullA -> s where + -- | Returns a 'QExpr' that evaluates to true when the first argument is not null + isJust_ :: a -> QExpr syntax s Bool + + -- | Returns a 'QExpr' that evaluates to true when the first argument is null + isNothing_ :: a -> QExpr syntax s Bool + + -- | Given an object (third argument) which may or may not be null, return the default value if + -- null (first argument), or transform the value that could be null to yield the result of the + -- expression (second argument) + maybe_ :: QExpr syntax s y -> (nonNullA -> QExpr syntax s y) -> a -> QExpr syntax s y + +instance IsSql92ExpressionSyntax syntax => SqlDeconstructMaybe syntax (QExpr syntax s (Maybe x)) (QExpr syntax s x) s where + isJust_ (QExpr x) = QExpr (isNotNullE <$> x) + isNothing_ (QExpr x) = QExpr (isNullE <$> x) + + maybe_ (QExpr onNothing) onJust (QExpr e) = let QExpr onJust' = onJust (QExpr e) + in QExpr (\tbl -> caseE [(isNotNullE (e tbl), onJust' tbl)] (onNothing tbl)) + +instance ( IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool + , Beamable t ) + => SqlDeconstructMaybe syntax (t (Nullable (QExpr syntax s))) (t (QExpr syntax s)) s where + isJust_ t = allE (allBeamValues (\(Columnar' e) -> isJust_ e) t) + isNothing_ t = allE (allBeamValues (\(Columnar' e) -> isNothing_ e) t) + maybe_ (QExpr onNothing) onJust tbl = + let QExpr onJust' = onJust (changeBeamRep (\(Columnar' (QExpr e)) -> Columnar' (QExpr e)) tbl) + QExpr cond = isJust_ tbl + in QExpr (\tblPfx -> caseE [(cond tblPfx, onJust' tblPfx)] (onNothing tblPfx)) diff --git a/Database/Beam/Query/CustomSQL.hs b/Database/Beam/Query/CustomSQL.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/CustomSQL.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Allows the creation of custom SQL expressions from arbitrary 'ByteStrings'. +-- +-- Simply create a function with an arbitrary number of 'ByteString' arguments +-- that returns a 'ByteString'. Then, apply 'customExpr_' to your function. +-- This will result in a function with the same arity, that takes in +-- 'QGenExpr's instead of 'ByteString's', and returns a 'QGenExpr' as well. +-- +-- Semantically, the expression builder function is called with arguments +-- representing SQL expressions, that, when evaluated, will evaluate to the +-- result of the expressions supplied as arguments to 'customExpr_'. See the +-- section on +-- in the user guide for example usage. +module Database.Beam.Query.CustomSQL + ( + -- * The 'customExpr_' function + IsCustomExprFn(..) + + -- ** Type-inference help + , valueExpr_, agg_ + + -- * For backends + , IsCustomSqlSyntax(..) ) where + +import Database.Beam.Query.Internal +import Database.Beam.Backend.SQL.Builder + +import Data.ByteString (ByteString) +import Data.ByteString.Builder (byteString, toLazyByteString) +import Data.ByteString.Lazy (toStrict) + +import Data.Monoid +import Data.String +import qualified Data.Text as T + +-- | A type-class for expression syntaxes that can embed custom expressions. +class (Monoid (CustomSqlSyntax syntax), IsString (CustomSqlSyntax syntax)) => + IsCustomSqlSyntax syntax where + data CustomSqlSyntax syntax :: * + + -- | Given an arbitrary 'ByteString', produce a 'syntax' that represents the + -- 'ByteString' as a SQL expression. + customExprSyntax :: CustomSqlSyntax syntax -> syntax + + -- | Given an arbitrary 'syntax', produce a 'ByteString' that corresponds to + -- how that syntax would look when rendered in the backend. + renderSyntax :: syntax -> CustomSqlSyntax syntax + +instance IsCustomSqlSyntax SqlSyntaxBuilder where + newtype CustomSqlSyntax SqlSyntaxBuilder = SqlSyntaxBuilderCustom ByteString + deriving (IsString, Monoid) + + customExprSyntax (SqlSyntaxBuilderCustom bs) = SqlSyntaxBuilder (byteString bs) + renderSyntax = SqlSyntaxBuilderCustom . toStrict . toLazyByteString . buildSql + +newtype CustomSqlSnippet syntax = CustomSqlSnippet (T.Text -> CustomSqlSyntax syntax) +instance IsCustomSqlSyntax syntax => Monoid (CustomSqlSnippet syntax) where + mempty = CustomSqlSnippet (pure mempty) + mappend (CustomSqlSnippet a) (CustomSqlSnippet b) = + CustomSqlSnippet $ \pfx -> a pfx <> b pfx +instance IsCustomSqlSyntax syntax => IsString (CustomSqlSnippet syntax) where + fromString s = CustomSqlSnippet $ \_ -> fromString s + +class IsCustomExprFn fn res | res -> fn where + customExpr_ :: fn -> res + +instance IsCustomSqlSyntax syntax => IsCustomExprFn (CustomSqlSnippet syntax) (QGenExpr ctxt syntax s res) where + customExpr_ (CustomSqlSnippet mkSyntax) = QExpr (customExprSyntax . mkSyntax) +instance (IsCustomExprFn a res, IsCustomSqlSyntax syntax) => IsCustomExprFn (CustomSqlSnippet syntax -> a) (QGenExpr ctxt syntax s r -> res) where + customExpr_ fn (QExpr e) = customExpr_ $ fn (CustomSqlSnippet (renderSyntax . e)) + +-- customExpr :: IsCustomExprFn + +-- | Force a 'QGenExpr' to be typed as a value expression (a 'QExpr'). Useful +-- for getting around type-inference errors with supplying the entire type. +valueExpr_ :: QExpr syntax s a -> QExpr syntax s a +valueExpr_ = id + +-- | Force a 'QGenExpr' to be typed as an aggregate. Useful for defining custom +-- aggregates for use in 'aggregate_'. +agg_ :: QAgg syntax s a -> QAgg syntax s a +agg_ = id + diff --git a/Database/Beam/Query/Extensions.hs b/Database/Beam/Query/Extensions.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Extensions.hs @@ -0,0 +1,145 @@ +module Database.Beam.Query.Extensions + ( -- * Various combinators corresponding to SQL extensions + + -- * T614 NTILE function + ntile_ + + -- * T615 LEAD and LAG function + , lead1_, lag1_, lead_, lag_ + , leadWithDefault_, lagWithDefault_ + + -- ** T616 FIRST_VALUE and LAST_VALUE functions + , firstValue_, lastValue_ + + -- ** T618 NTH_VALUE function + , nthValue_ + + -- ** T621 Enhanced numeric functions + , (**.), ln_, exp_, sqrt_ + , ceiling_, floor_ + + , stddevPopOver_, stddevSampOver_ + , varPopOver_, varSampOver_ + + , stddevPop_, stddevSamp_ + , varPop_, varSamp_ + + , covarPopOver_, covarSampOver_, corrOver_ + , regrSlopeOver_, regrInterceptOver_ + , regrCountOver_, regrRSquaredOver_ + , regrAvgXOver_, regrAvgYOver_ + , regrSXXOver_, regrSYYOver_, regrSXYOver_ + + , covarPop_, covarSamp_, corr_, regrSlope_ + , regrIntercept_, regrCount_, regrRSquared_ + , regrAvgX_, regrAvgY_, regrSXX_ + , regrSYY_, regrSXY_ + ) where + +import Database.Beam.Query.Internal +import Database.Beam.Query.Aggregate + +import Database.Beam.Backend.SQL + +ntile_ :: (Integral a, IsSql2003NtileExpressionSyntax syntax) + => QExpr syntax s Int -> QAgg syntax s a +ntile_ (QExpr a) = QExpr (ntileE <$> a) + +lead1_, lag1_ :: IsSql2003LeadAndLagExpressionSyntax syntax + => QExpr syntax s a -> QAgg syntax s a +lead1_ (QExpr a) = QExpr (leadE <$> a <*> pure Nothing <*> pure Nothing) +lag1_ (QExpr a) = QExpr (lagE <$> a <*> pure Nothing <*> pure Nothing) + +lead_, lag_ :: IsSql2003LeadAndLagExpressionSyntax syntax + => QExpr syntax s a -> QExpr syntax s Int -> QAgg syntax s a +lead_ (QExpr a) (QExpr n) = QExpr (leadE <$> a <*> (Just <$> n) <*> pure Nothing) +lag_ (QExpr a) (QExpr n) = QExpr (lagE <$> a <*> (Just <$> n) <*> pure Nothing) + +leadWithDefault_, lagWithDefault_ + :: IsSql2003LeadAndLagExpressionSyntax syntax + => QExpr syntax s a -> QExpr syntax s Int -> QExpr syntax s a + -> QAgg syntax s a +leadWithDefault_ (QExpr a) (QExpr n) (QExpr def) = + QExpr (leadE <$> a <*> fmap Just n <*> fmap Just def) +lagWithDefault_ (QExpr a) (QExpr n) (QExpr def) = + QExpr (lagE <$> a <*> fmap Just n <*> fmap Just def) + +-- TODO the first 'a' should be nullable, and the second one not +firstValue_, lastValue_ :: IsSql2003FirstValueAndLastValueExpressionSyntax syntax + => QExpr syntax s a -> QAgg syntax s a +firstValue_ (QExpr a) = QExpr (firstValueE <$> a) +lastValue_ (QExpr a) = QExpr (lastValueE <$> a) + +-- TODO see comment for 'firstValue_' and 'lastValue_' +nthValue_ :: IsSql2003NthValueExpressionSyntax syntax + => QExpr syntax s a -> QExpr syntax s Int -> QAgg syntax s a +nthValue_ (QExpr a) (QExpr n) = QExpr (nthValueE <$> a <*> n) + +ln_, exp_, sqrt_ :: (Floating a, IsSql2003EnhancedNumericFunctionsExpressionSyntax syntax) + => QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a +ln_ (QExpr a) = QExpr (lnE <$> a) +exp_ (QExpr a) = QExpr (expE <$> a) +sqrt_ (QExpr a) = QExpr (sqrtE <$> a) + +ceiling_, floor_ :: (RealFrac a, Integral b, IsSql2003EnhancedNumericFunctionsExpressionSyntax syntax) + => QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s b +ceiling_ (QExpr a) = QExpr (ceilE <$> a) +floor_ (QExpr a) = QExpr (floorE <$> a) + +infixr 8 **. +(**.) :: (Floating a, IsSql2003EnhancedNumericFunctionsExpressionSyntax syntax) + => QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a +QExpr a **. QExpr b = QExpr (powerE <$> a <*> b) + +stddevPopOver_, stddevSampOver_, varPopOver_, varSampOver_ + :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) + => Maybe (Sql92AggregationSetQuantifierSyntax syntax) -> QExpr syntax s a + -> QAgg syntax s b +stddevPopOver_ q (QExpr x) = QExpr (stddevPopE q <$> x) +stddevSampOver_ q (QExpr x) = QExpr (stddevSampE q <$> x) +varPopOver_ q (QExpr x) = QExpr (varPopE q <$> x) +varSampOver_ q (QExpr x) = QExpr (varSampE q <$> x) + +stddevPop_, stddevSamp_, varPop_, varSamp_ + :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) + => QExpr syntax s a -> QAgg syntax s b +stddevPop_ = stddevPopOver_ allInGroup_ +stddevSamp_ = stddevSampOver_ allInGroup_ +varPop_ = varPopOver_ allInGroup_ +varSamp_ = varSampOver_ allInGroup_ + +covarPopOver_, covarSampOver_, corrOver_, regrSlopeOver_, regrInterceptOver_, + regrCountOver_, regrRSquaredOver_, regrAvgYOver_, regrAvgXOver_, + regrSXXOver_, regrSXYOver_, regrSYYOver_ + :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) + => Maybe (Sql92AggregationSetQuantifierSyntax syntax) -> QExpr syntax s a -> QExpr syntax s a + -> QExpr syntax s b +covarPopOver_ q (QExpr x) (QExpr y) = QExpr (covarPopE q <$> x <*> y) +covarSampOver_ q (QExpr x) (QExpr y) = QExpr (covarSampE q <$> x <*> y) +corrOver_ q (QExpr x) (QExpr y) = QExpr (corrE q <$> x <*> y) +regrSlopeOver_ q (QExpr x) (QExpr y) = QExpr (regrSlopeE q <$> x <*> y) +regrInterceptOver_ q (QExpr x) (QExpr y) = QExpr (regrInterceptE q <$> x <*> y) +regrCountOver_ q (QExpr x) (QExpr y) = QExpr (regrCountE q <$> x <*> y) +regrRSquaredOver_ q (QExpr x) (QExpr y) = QExpr (regrRSquaredE q <$> x <*> y) +regrAvgYOver_ q (QExpr x) (QExpr y) = QExpr (regrAvgYE q <$> x <*> y) +regrAvgXOver_ q (QExpr x) (QExpr y) = QExpr (regrAvgXE q <$> x <*> y) +regrSXXOver_ q (QExpr x) (QExpr y) = QExpr (regrSXXE q <$> x <*> y) +regrSYYOver_ q (QExpr x) (QExpr y) = QExpr (regrSYYE q <$> x <*> y) +regrSXYOver_ q (QExpr x) (QExpr y) = QExpr (regrSXYE q <$> x <*> y) + +covarPop_, covarSamp_, corr_, regrSlope_, regrIntercept_, regrCount_, + regrRSquared_, regrAvgY_, regrAvgX_, regrSXX_, regrSXY_, regrSYY_ + :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) + => QExpr syntax s a -> QExpr syntax s a -> QExpr syntax s b +covarPop_ = covarPopOver_ allInGroup_ +covarSamp_ = covarSampOver_ allInGroup_ +corr_ = corrOver_ allInGroup_ +regrSlope_ = regrSlopeOver_ allInGroup_ +regrIntercept_ = regrInterceptOver_ allInGroup_ +regrCount_ = regrCountOver_ allInGroup_ +regrRSquared_ = regrRSquaredOver_ allInGroup_ +regrAvgY_ = regrAvgYOver_ allInGroup_ +regrAvgX_ = regrAvgXOver_ allInGroup_ +regrSXX_ = regrSXXOver_ allInGroup_ +regrSYY_ = regrSYYOver_ allInGroup_ +regrSXY_ = regrSXYOver_ allInGroup_ diff --git a/Database/Beam/Query/Internal.hs b/Database/Beam/Query/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Internal.hs @@ -0,0 +1,481 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors#-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Beam.Query.Internal where + +import Database.Beam.Backend.Types +import Database.Beam.Backend.SQL +import Database.Beam.Schema.Tables + +import Data.String +import qualified Data.Text as T +import qualified Data.DList as DList +import Data.Typeable +import Data.Vector.Sized (Vector) + +import Control.Monad.Free.Church +import Control.Monad.State +import Control.Monad.Writer + +import GHC.TypeLits +import GHC.Types + +type ProjectibleInSelectSyntax syntax a = + ( IsSql92SelectSyntax syntax + , Eq (Sql92SelectExpressionSyntax syntax) + , Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax) ~ Sql92SelectExpressionSyntax syntax + , Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax syntax)) ~ syntax + , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a + , ProjectibleValue (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a) + +type TablePrefix = T.Text + +data QF select (db :: (* -> *) -> *) s next where + QDistinct :: Projectible (Sql92SelectExpressionSyntax select) r + => (r -> WithExprContext (Sql92SelectTableSetQuantifierSyntax (Sql92SelectSelectTableSyntax select))) + -> QM select db s r + -> (r -> next) + -> QF select db s next + + QAll :: Beamable table + => T.Text -> TableSettings table + -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) + -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> next) -> QF select db s next + + QArbitraryJoin :: Projectible (Sql92SelectExpressionSyntax select) r + => QM select db (QNested s) r + -> (Sql92SelectFromSyntax select -> Sql92SelectFromSyntax select -> + Maybe (Sql92FromExpressionSyntax (Sql92SelectFromSyntax select)) -> + Sql92SelectFromSyntax select) + -> (r -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) + -> (r -> next) + -> QF select db s next + QTwoWayJoin :: ( Projectible (Sql92SelectExpressionSyntax select) a + , Projectible (Sql92SelectExpressionSyntax select) b ) + => QM select db (QNested s) a + -> QM select db (QNested s) b + -> (Sql92SelectFromSyntax select -> Sql92SelectFromSyntax select -> + Maybe (Sql92FromExpressionSyntax (Sql92SelectFromSyntax select)) -> + Sql92SelectFromSyntax select) + -> ((a, b) -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) + -> ((a, b) -> next) + -> QF select db s next + + QSubSelect :: Projectible (Sql92SelectExpressionSyntax select) r => + QM select db (QNested s) r -> (r -> next) -> QF select db s next + QGuard :: WithExprContext (Sql92SelectExpressionSyntax select) -> next -> QF select db s next + + QLimit :: Projectible (Sql92SelectExpressionSyntax select) r => Integer -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + QOffset :: Projectible (Sql92SelectExpressionSyntax select) r => Integer -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + + QUnion ::Projectible (Sql92SelectExpressionSyntax select) r => Bool -> QM select db (QNested s) r -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + QIntersect :: Projectible (Sql92SelectExpressionSyntax select) r => Bool -> QM select db (QNested s) r -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + QExcept :: Projectible (Sql92SelectExpressionSyntax select) r => Bool -> QM select db (QNested s) r -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + QOrderBy :: Projectible (Sql92SelectExpressionSyntax select) r => + (r -> WithExprContext [ Sql92SelectOrderingSyntax select ]) + -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + + QWindowOver :: ( ProjectibleWithPredicate WindowFrameContext (Sql2003ExpressionWindowFrameSyntax (Sql92SelectExpressionSyntax select)) window + , Projectible (Sql92SelectExpressionSyntax select) r + , Projectible (Sql92SelectExpressionSyntax select) a ) + => (r -> window) -> (r -> window -> a) + -> QM select db (QNested s) r -> (a -> next) -> QF select db s next + QAggregate :: ( Projectible (Sql92SelectExpressionSyntax select) grouping + , Projectible (Sql92SelectExpressionSyntax select) a ) => + (a -> TablePrefix -> (Maybe (Sql92SelectGroupingSyntax select), grouping)) -> + QM select db (QNested s) a -> + (grouping -> next) -> QF select db s next +deriving instance Functor (QF select db s) + +type QM select db s = F (QF select db s) + +-- | The type of queries over the database `db` returning results of type `a`. +-- The `s` argument is a threading argument meant to restrict cross-usage of +-- `QExpr`s. 'syntax' represents the SQL syntax that this query is building. +newtype Q syntax (db :: (* -> *) -> *) s a + = Q { runQ :: QM syntax db s a } + deriving (Monad, Applicative, Functor) + +data QInternal +data QNested s + +data QField s ty + = QField + { qFieldTblName :: T.Text + , qFieldName :: T.Text } + deriving (Show, Eq, Ord) + +data QAssignment fieldName expr s + = QAssignment [(fieldName, expr)] + deriving (Show, Eq, Ord) + +-- * QGenExpr type + +data QAggregateContext +data QGroupingContext +data QValueContext +data QOrderingContext +data QWindowingContext +data QWindowFrameContext + +-- | The type of lifted beam expressions that will yield the haskell type 't'. +-- +-- 'context' is a type-level representation of the types of expressions this +-- can contain. For example, 'QAggregateContext' represents expressions that +-- may contain aggregates, and 'QWindowingContext' represents expressions that +-- may contain @OVER@. +-- +-- 'syntax' is the expression syntax being built (usually a type that +-- implements 'IsSql92ExpressionSyntax' at least, but not always). +-- +-- 's' is a state threading parameter that prevents 'QExpr's from incompatible +-- sources to be combined. For example, this is used to prevent monadic joins +-- from depending on the result of previous joins (so-called @LATERAL@ joins). +newtype QGenExpr context syntax s t = QExpr (TablePrefix -> syntax) +type WithExprContext a = TablePrefix -> a + +-- | 'QExpr's represent expressions not containing aggregates. +type QExpr = QGenExpr QValueContext +type QAgg = QGenExpr QAggregateContext +type QOrd = QGenExpr QOrderingContext +type QWindowExpr = QGenExpr QWindowingContext +type QWindowFrame = QGenExpr QWindowFrameContext +type QGroupExpr = QGenExpr QGroupingContext +--deriving instance Show syntax => Show (QGenExpr context syntax s t) +instance Eq syntax => Eq (QGenExpr context syntax s t) where + QExpr a == QExpr b = a "" == b "" + +instance Retaggable (QGenExpr ctxt expr s) (QGenExpr ctxt expr s t) where + type Retag tag (QGenExpr ctxt expr s t) = Columnar (tag (QGenExpr ctxt expr s)) t + retag f e = case f (Columnar' e) of + Columnar' a -> a + +newtype QWindow syntax s = QWindow (WithExprContext syntax) +newtype QFrameBounds syntax = QFrameBounds (Maybe syntax) +newtype QFrameBound syntax = QFrameBound syntax + +qBinOpE :: forall syntax context s a b c. IsSql92ExpressionSyntax syntax => + (syntax -> syntax -> syntax) + -> QGenExpr context syntax s a -> QGenExpr context syntax s b + -> QGenExpr context syntax s c +qBinOpE mkOpE (QExpr a) (QExpr b) = QExpr (mkOpE <$> a <*> b) + +unsafeRetype :: QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a' +unsafeRetype (QExpr v) = QExpr v + +instance ( IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) [Char] ) => + IsString (QGenExpr context syntax s T.Text) where + fromString = QExpr . pure . valueE . sqlValueSyntax +instance (Num a + , IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) a) => + Num (QGenExpr context syntax s a) where + fromInteger x = let res :: QGenExpr context syntax s a + res = QExpr (pure (valueE (sqlValueSyntax (fromIntegral x :: a)))) + in res + QExpr a + QExpr b = QExpr (addE <$> a <*> b) + QExpr a - QExpr b = QExpr (subE <$> a <*> b) + QExpr a * QExpr b = QExpr (mulE <$> a <*> b) + negate (QExpr a) = QExpr (negateE <$> a) + abs (QExpr x) = QExpr (absE <$> x) + signum _ = error "signum: not defined for QExpr. Use CASE...WHEN" + +instance ( Fractional a + , IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) a ) => + Fractional (QGenExpr context syntax s a) where + + QExpr a / QExpr b = QExpr (divE <$> a <*> b) + recip = (1.0 /) + + fromRational = QExpr . pure . valueE . sqlValueSyntax . (id :: a -> a) . fromRational + +-- * Aggregations + +data Aggregation syntax s a + = GroupAgg syntax --(Sql92ExpressionSyntax syntax) + | ProjectAgg syntax --(Sql92ExpressionSyntax syntax) + +-- * Sql Projections +-- + +-- | Typeclass for all haskell data types that can be used to create a projection in a SQL select +-- statement. This includes all tables as well as all tuple classes. Projections are only defined on +-- tuples up to size 5. If you need more, follow the implementations here. + +class Typeable context => AggregateContext context +instance (IsAggregateContext a, Typeable a) => AggregateContext a + +type family ContextName a :: Symbol +type instance ContextName QValueContext = "a value" +type instance ContextName QWindowingContext = "a window expression" +type instance ContextName QWindowFrameContext = "a window frame" +type instance ContextName QOrderingContext = "an ordering expression" +type instance ContextName QAggregateContext = "an aggregate" +type instance ContextName QGroupingContext = "an aggregate grouping" + +type family IsAggregateContext a :: Constraint where + IsAggregateContext QAggregateContext = () + IsAggregateContext QGroupingContext = () + IsAggregateContext a = TypeError ('Text "Non-aggregate expression where aggregate expected." :$$: + ('Text "Got " :<>: 'Text (ContextName a) :<>: 'Text ". Expected an aggregate or a grouping") :$$: + AggregateContextSuggestion a) + +type family AggregateContextSuggestion a :: ErrorMessage where + AggregateContextSuggestion QValueContext = 'Text "Perhaps you forgot to wrap a value expression with 'group_'" + AggregateContextSuggestion QWindowingContext = 'Text "Perhaps you meant to use 'window_' instead of 'aggregate_'" + AggregateContextSuggestion QOrderingContext = 'Text "You cannot use an ordering in an aggregate" + AggregateContextSuggestion b = 'Text "" + +class Typeable context => ValueContext context +instance (IsValueContext a, Typeable a, a ~ QValueContext) => ValueContext a + +class Typeable context => WindowFrameContext context +instance (Typeable context, IsWindowFrameContext context, context ~ QWindowFrameContext) => + WindowFrameContext context + +type family IsWindowFrameContext a :: Constraint where + IsWindowFrameContext QWindowFrameContext = () + IsWindowFrameContext a = TypeError ('Text "Expected window frame." :$$: + ('Text "Got " :<>: 'Text (ContextName a) :<>: 'Text ". Expected a window frame")) + +class AnyType a +instance AnyType a + +type family IsValueContext a :: Constraint where + IsValueContext QValueContext = () + IsValueContext a = TypeError ('Text "Non-scalar context in projection" :$$: + ('Text "Got " :<>: 'Text (ContextName a) :<>: 'Text ". Expected a value") :$$: + ValueContextSuggestion a) + +type family ValueContextSuggestion a :: ErrorMessage where + ValueContextSuggestion QWindowingContext = 'Text "Use 'window_' to projecct aggregate expressions to the value level" + ValueContextSuggestion QOrderingContext = 'Text "An ordering context cannot be used in a projection. Try removing the 'asc_' or 'desc_', or use 'orderBy_' to sort the result set" + ValueContextSuggestion QAggregateContext = ('Text "Aggregate functions and groupings cannot be contained in value expressions." :$$: + 'Text "Use 'aggregate_' to compute aggregations at the value level.") + ValueContextSuggestion QGroupingContext = ValueContextSuggestion QAggregateContext + ValueContextSuggestion _ = 'Text "" + +type Projectible = ProjectibleWithPredicate AnyType +type ProjectibleValue = ProjectibleWithPredicate ValueContext + +class ThreadRewritable (s :: *) (a :: *) | a -> s where + type WithRewrittenThread s (s' :: *) a :: * + + rewriteThread :: Proxy s' -> a -> WithRewrittenThread s s' a +instance Beamable tbl => ThreadRewritable s (tbl (QGenExpr ctxt syntax s)) where + type WithRewrittenThread s s' (tbl (QGenExpr ctxt syntax s)) = tbl (QGenExpr ctxt syntax s') + rewriteThread _ = changeBeamRep (\(Columnar' (QExpr a)) -> Columnar' (QExpr a)) +instance Beamable tbl => ThreadRewritable s (tbl (Nullable (QGenExpr ctxt syntax s))) where + type WithRewrittenThread s s' (tbl (Nullable (QGenExpr ctxt syntax s))) = tbl (Nullable (QGenExpr ctxt syntax s')) + rewriteThread _ = changeBeamRep (\(Columnar' (QExpr a)) -> Columnar' (QExpr a)) +instance ThreadRewritable s (QGenExpr ctxt syntax s a) where + type WithRewrittenThread s s' (QGenExpr ctxt syntax s a) = QGenExpr ctxt syntax s' a + rewriteThread _ (QExpr a) = QExpr a +instance ThreadRewritable s a => ThreadRewritable s [a] where + type WithRewrittenThread s s' [a] = [WithRewrittenThread s s' a] + rewriteThread s' qs = map (rewriteThread s') qs +instance (ThreadRewritable s a, KnownNat n) => ThreadRewritable s (Vector n a) where + type WithRewrittenThread s s' (Vector n a) = Vector n (WithRewrittenThread s s' a) + rewriteThread s' qs = fmap (rewriteThread s') qs +instance ( ThreadRewritable s a, ThreadRewritable s b ) => + ThreadRewritable s (a, b) where + type WithRewrittenThread s s' (a, b) = (WithRewrittenThread s s' a, WithRewrittenThread s s' b) + rewriteThread s' (a, b) = (rewriteThread s' a, rewriteThread s' b) +instance ( ThreadRewritable s a, ThreadRewritable s b, ThreadRewritable s c ) => + ThreadRewritable s (a, b, c) where + type WithRewrittenThread s s' (a, b, c) = + (WithRewrittenThread s s' a, WithRewrittenThread s s' b, WithRewrittenThread s s' c) + rewriteThread s' (a, b, c) = (rewriteThread s' a, rewriteThread s' b, rewriteThread s' c) +instance ( ThreadRewritable s a, ThreadRewritable s b, ThreadRewritable s c, ThreadRewritable s d ) => + ThreadRewritable s (a, b, c, d) where + type WithRewrittenThread s s' (a, b, c, d) = + (WithRewrittenThread s s' a, WithRewrittenThread s s' b, WithRewrittenThread s s' c, WithRewrittenThread s s' d) + rewriteThread s' (a, b, c, d) = + (rewriteThread s' a, rewriteThread s' b, rewriteThread s' c, rewriteThread s' d) +instance ( ThreadRewritable s a, ThreadRewritable s b, ThreadRewritable s c, ThreadRewritable s d + , ThreadRewritable s e ) => + ThreadRewritable s (a, b, c, d, e) where + type WithRewrittenThread s s' (a, b, c, d, e) = + ( WithRewrittenThread s s' a, WithRewrittenThread s s' b, WithRewrittenThread s s' c, WithRewrittenThread s s' d + , WithRewrittenThread s s' e ) + rewriteThread s' (a, b, c, d, e) = + ( rewriteThread s' a, rewriteThread s' b, rewriteThread s' c, rewriteThread s' d + , rewriteThread s' e) +instance ( ThreadRewritable s a, ThreadRewritable s b, ThreadRewritable s c, ThreadRewritable s d + , ThreadRewritable s e, ThreadRewritable s f ) => + ThreadRewritable s (a, b, c, d, e, f) where + type WithRewrittenThread s s' (a, b, c, d, e, f) = + ( WithRewrittenThread s s' a, WithRewrittenThread s s' b, WithRewrittenThread s s' c, WithRewrittenThread s s' d + , WithRewrittenThread s s' e, WithRewrittenThread s s' f ) + rewriteThread s' (a, b, c, d, e, f) = + ( rewriteThread s' a, rewriteThread s' b, rewriteThread s' c, rewriteThread s' d + , rewriteThread s' e, rewriteThread s' f) +instance ( ThreadRewritable s a, ThreadRewritable s b, ThreadRewritable s c, ThreadRewritable s d + , ThreadRewritable s e, ThreadRewritable s f, ThreadRewritable s g ) => + ThreadRewritable s (a, b, c, d, e, f, g) where + type WithRewrittenThread s s' (a, b, c, d, e, f, g) = + ( WithRewrittenThread s s' a, WithRewrittenThread s s' b, WithRewrittenThread s s' c, WithRewrittenThread s s' d + , WithRewrittenThread s s' e, WithRewrittenThread s s' f, WithRewrittenThread s s' g) + rewriteThread s' (a, b, c, d, e, f, g) = + ( rewriteThread s' a, rewriteThread s' b, rewriteThread s' c, rewriteThread s' d + , rewriteThread s' e, rewriteThread s' f, rewriteThread s' g ) +instance ( ThreadRewritable s a, ThreadRewritable s b, ThreadRewritable s c, ThreadRewritable s d + , ThreadRewritable s e, ThreadRewritable s f, ThreadRewritable s g, ThreadRewritable s h ) => + ThreadRewritable s (a, b, c, d, e, f, g, h) where + type WithRewrittenThread s s' (a, b, c, d, e, f, g, h) = + ( WithRewrittenThread s s' a, WithRewrittenThread s s' b, WithRewrittenThread s s' c, WithRewrittenThread s s' d + , WithRewrittenThread s s' e, WithRewrittenThread s s' f, WithRewrittenThread s s' g, WithRewrittenThread s s' h) + rewriteThread s' (a, b, c, d, e, f, g, h) = + ( rewriteThread s' a, rewriteThread s' b, rewriteThread s' c, rewriteThread s' d + , rewriteThread s' e, rewriteThread s' f, rewriteThread s' g, rewriteThread s' h ) + +class ContextRewritable a where + type WithRewrittenContext a ctxt :: * + + rewriteContext :: Proxy ctxt -> a -> WithRewrittenContext a ctxt +instance Beamable tbl => ContextRewritable (tbl (QGenExpr old syntax s)) where + type WithRewrittenContext (tbl (QGenExpr old syntax s)) ctxt = tbl (QGenExpr ctxt syntax s) + + rewriteContext _ = changeBeamRep (\(Columnar' (QExpr a)) -> Columnar' (QExpr a)) +instance Beamable tbl => ContextRewritable (tbl (Nullable (QGenExpr old syntax s))) where + type WithRewrittenContext (tbl (Nullable (QGenExpr old syntax s))) ctxt = tbl (Nullable (QGenExpr ctxt syntax s)) + + rewriteContext _ = changeBeamRep (\(Columnar' (QExpr a)) -> Columnar' (QExpr a)) +instance ContextRewritable (QGenExpr old syntax s a) where + type WithRewrittenContext (QGenExpr old syntax s a) ctxt = QGenExpr ctxt syntax s a + rewriteContext _ (QExpr a) = QExpr a +instance ContextRewritable a => ContextRewritable [a] where + type WithRewrittenContext [a] ctxt = [ WithRewrittenContext a ctxt ] + rewriteContext p as = map (rewriteContext p) as +instance (ContextRewritable a, KnownNat n) => ContextRewritable (Vector n a) where + type WithRewrittenContext (Vector n a) ctxt = Vector n (WithRewrittenContext a ctxt) + rewriteContext p as = fmap (rewriteContext p) as +instance (ContextRewritable a, ContextRewritable b) => ContextRewritable (a, b) where + type WithRewrittenContext (a, b) ctxt = (WithRewrittenContext a ctxt, WithRewrittenContext b ctxt) + rewriteContext p (a, b) = (rewriteContext p a, rewriteContext p b) +instance (ContextRewritable a, ContextRewritable b, ContextRewritable c) => ContextRewritable (a, b, c) where + type WithRewrittenContext (a, b, c) ctxt = (WithRewrittenContext a ctxt, WithRewrittenContext b ctxt, WithRewrittenContext c ctxt) + rewriteContext p (a, b, c) = (rewriteContext p a, rewriteContext p b, rewriteContext p c) +instance ( ContextRewritable a, ContextRewritable b, ContextRewritable c + , ContextRewritable d ) => ContextRewritable (a, b, c, d) where + type WithRewrittenContext (a, b, c, d) ctxt = + ( WithRewrittenContext a ctxt, WithRewrittenContext b ctxt, WithRewrittenContext c ctxt + , WithRewrittenContext d ctxt ) + rewriteContext p (a, b, c, d) = ( rewriteContext p a, rewriteContext p b, rewriteContext p c + , rewriteContext p d ) +instance ( ContextRewritable a, ContextRewritable b, ContextRewritable c + , ContextRewritable d, ContextRewritable e ) => + ContextRewritable (a, b, c, d, e) where + type WithRewrittenContext (a, b, c, d, e) ctxt = + ( WithRewrittenContext a ctxt, WithRewrittenContext b ctxt, WithRewrittenContext c ctxt + , WithRewrittenContext d ctxt, WithRewrittenContext e ctxt ) + rewriteContext p (a, b, c, d, e) = ( rewriteContext p a, rewriteContext p b, rewriteContext p c + , rewriteContext p d, rewriteContext p e ) +instance ( ContextRewritable a, ContextRewritable b, ContextRewritable c + , ContextRewritable d, ContextRewritable e, ContextRewritable f ) => + ContextRewritable (a, b, c, d, e, f) where + type WithRewrittenContext (a, b, c, d, e, f) ctxt = + ( WithRewrittenContext a ctxt, WithRewrittenContext b ctxt, WithRewrittenContext c ctxt + , WithRewrittenContext d ctxt, WithRewrittenContext e ctxt, WithRewrittenContext f ctxt ) + rewriteContext p (a, b, c, d, e, f) = ( rewriteContext p a, rewriteContext p b, rewriteContext p c + , rewriteContext p d, rewriteContext p e, rewriteContext p f ) +instance ( ContextRewritable a, ContextRewritable b, ContextRewritable c + , ContextRewritable d, ContextRewritable e, ContextRewritable f + , ContextRewritable g ) => + ContextRewritable (a, b, c, d, e, f, g) where + type WithRewrittenContext (a, b, c, d, e, f, g) ctxt = + ( WithRewrittenContext a ctxt, WithRewrittenContext b ctxt, WithRewrittenContext c ctxt + , WithRewrittenContext d ctxt, WithRewrittenContext e ctxt, WithRewrittenContext f ctxt + , WithRewrittenContext g ctxt ) + rewriteContext p (a, b, c, d, e, f, g) = + ( rewriteContext p a, rewriteContext p b, rewriteContext p c + , rewriteContext p d, rewriteContext p e, rewriteContext p f + , rewriteContext p g ) +instance ( ContextRewritable a, ContextRewritable b, ContextRewritable c + , ContextRewritable d, ContextRewritable e, ContextRewritable f + , ContextRewritable g, ContextRewritable h ) => + ContextRewritable (a, b, c, d, e, f, g, h) where + type WithRewrittenContext (a, b, c, d, e, f, g, h) ctxt = + ( WithRewrittenContext a ctxt, WithRewrittenContext b ctxt, WithRewrittenContext c ctxt + , WithRewrittenContext d ctxt, WithRewrittenContext e ctxt, WithRewrittenContext f ctxt + , WithRewrittenContext g ctxt, WithRewrittenContext h ctxt ) + rewriteContext p (a, b, c, d, e, f, g, h) = + ( rewriteContext p a, rewriteContext p b, rewriteContext p c + , rewriteContext p d, rewriteContext p e, rewriteContext p f + , rewriteContext p g, rewriteContext p h ) + +class ProjectibleWithPredicate (contextPredicate :: * -> Constraint) syntax a | a -> syntax where + project' :: Monad m => Proxy contextPredicate + -> (forall context. contextPredicate context => Proxy context -> WithExprContext syntax -> m (WithExprContext syntax)) + -> a -> m a +instance (Beamable t, contextPredicate context) => ProjectibleWithPredicate contextPredicate syntax (t (QGenExpr context syntax s)) where + project' _ mutateM a = + zipBeamFieldsM (\(Columnar' (QExpr e)) _ -> + Columnar' . QExpr <$> mutateM (Proxy @context) e) a a +instance (Beamable t, contextPredicate context) => ProjectibleWithPredicate contextPredicate syntax (t (Nullable (QGenExpr context syntax s))) where + project' _ mutateM a = + zipBeamFieldsM (\(Columnar' (QExpr e)) _ -> + Columnar' . QExpr <$> mutateM (Proxy @context) e) a a +instance ProjectibleWithPredicate WindowFrameContext syntax (QWindow syntax s) where + project' _ mutateM (QWindow a) = + QWindow <$> mutateM (Proxy @QWindowFrameContext) a +instance contextPredicate context => ProjectibleWithPredicate contextPredicate syntax (QGenExpr context syntax s a) where + project' _ mkE (QExpr a) = QExpr <$> mkE (Proxy @context) a +instance ProjectibleWithPredicate contextPredicate syntax a => ProjectibleWithPredicate contextPredicate syntax [a] where + project' p mkE as = traverse (project' p mkE) as +instance (ProjectibleWithPredicate contextPredicate syntax a, KnownNat n) => ProjectibleWithPredicate contextPredicate syntax (Vector n a) where + project' p mkE as = traverse (project' p mkE) as +instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b ) => + ProjectibleWithPredicate contextPredicate syntax (a, b) where + + project' p mkE (a, b) = (,) <$> project' p mkE a <*> project' p mkE b +instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c ) => + ProjectibleWithPredicate contextPredicate syntax (a, b, c) where + + project' p mkE (a, b, c) = (,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c +instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c + , ProjectibleWithPredicate contextPredicate syntax d ) => + ProjectibleWithPredicate contextPredicate syntax (a, b, c, d) where + + project' p mkE (a, b, c, d) = (,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c + <*> project' p mkE d +instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c + , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e ) => + ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e) where + + project' p mkE (a, b, c, d, e) = (,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c + <*> project' p mkE d <*> project' p mkE e +instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c + , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e, ProjectibleWithPredicate contextPredicate syntax f ) => + ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e, f) where + + project' p mkE (a, b, c, d, e, f) = (,,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c + <*> project' p mkE d <*> project' p mkE e <*> project' p mkE f +instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c + , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e, ProjectibleWithPredicate contextPredicate syntax f + , ProjectibleWithPredicate contextPredicate syntax g ) => + ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e, f, g) where + + project' p mkE (a, b, c, d, e, f, g) = + (,,,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c + <*> project' p mkE d <*> project' p mkE e <*> project' p mkE f + <*> project' p mkE g +instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c + , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e, ProjectibleWithPredicate contextPredicate syntax f + , ProjectibleWithPredicate contextPredicate syntax g, ProjectibleWithPredicate contextPredicate syntax h ) => + ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e, f, g, h) where + + project' p mkE (a, b, c, d, e, f, g, h) = + (,,,,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c + <*> project' p mkE d <*> project' p mkE e <*> project' p mkE f + <*> project' p mkE g <*> project' p mkE h + +project :: Projectible syntax a => a -> WithExprContext [ syntax ] +project = sequenceA . DList.toList . execWriter . project' (Proxy @AnyType) (\_ e -> tell (DList.singleton e) >> pure e) + +reproject :: (IsSql92ExpressionSyntax syntax, Projectible syntax a) => + (Int -> syntax) -> a -> a +reproject mkField a = + evalState (project' (Proxy @AnyType) (\_ _ -> state (\i -> (i, i + 1)) >>= pure . pure . mkField) a) 0 diff --git a/Database/Beam/Query/Operator.hs b/Database/Beam/Query/Operator.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Operator.hs @@ -0,0 +1,107 @@ +module Database.Beam.Query.Operator + ( -- ** General-purpose operators + (&&.), (||.), not_, div_, mod_ + + , like_, similarTo_ + + , isTrue_, isNotTrue_ + , isFalse_, isNotFalse_ + , isUnknown_, isNotUnknown_ + + , concat_ + ) where + +import Database.Beam.Backend.SQL + +import Database.Beam.Query.Internal + +import Control.Applicative + +import qualified Data.Text as T + +-- | SQL @AND@ operator +(&&.) :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s Bool + -> QGenExpr context syntax s Bool + -> QGenExpr context syntax s Bool +(&&.) = qBinOpE andE + +-- | SQL @OR@ operator +(||.) :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s Bool + -> QGenExpr context syntax s Bool + -> QGenExpr context syntax s Bool +(||.) = qBinOpE orE + +infixr 3 &&. +infixr 2 ||. + +-- | SQL @LIKE@ operator +like_ :: + ( IsSqlExpressionSyntaxStringType syntax text + , IsSql92ExpressionSyntax syntax ) => + QExpr syntax s text -> QExpr syntax s text -> QExpr syntax s Bool +like_ (QExpr scrutinee) (QExpr search) = + QExpr (liftA2 likeE scrutinee search) + +-- | SQL99 @SIMILAR TO@ operator +similarTo_ :: + ( IsSqlExpressionSyntaxStringType syntax text + , IsSql99ExpressionSyntax syntax ) => + QExpr syntax s text -> QExpr syntax s text -> QExpr syntax s text +similarTo_ (QExpr scrutinee) (QExpr search) = + QExpr (liftA2 similarToE scrutinee search) + +-- | SQL @NOT@ operator +not_ :: forall syntax context s. + IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s Bool + -> QGenExpr context syntax s Bool +not_ (QExpr a) = QExpr (fmap notE a) + +-- | SQL @/@ operator +div_ :: (Integral a, IsSql92ExpressionSyntax syntax) + => QGenExpr context syntax s a -> QGenExpr context syntax s a + -> QGenExpr context syntax s a +div_ = qBinOpE divE + +-- | SQL @%@ operator +mod_ :: (Integral a, IsSql92ExpressionSyntax syntax) + => QGenExpr context syntax s a -> QGenExpr context syntax s a + -> QGenExpr context syntax s a +mod_ = qBinOpE modE + +-- | SQL @IS TRUE@ operator +isTrue_ :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s a -> QGenExpr context syntax s Bool +isTrue_ (QExpr s) = QExpr (fmap isTrueE s) + +-- | SQL @IS NOT TRUE@ operator +isNotTrue_ :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s a -> QGenExpr context syntax s Bool +isNotTrue_ (QExpr s) = QExpr (fmap isNotTrueE s) + +-- | SQL @IS FALSE@ operator +isFalse_ :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s a -> QGenExpr context syntax s Bool +isFalse_ (QExpr s) = QExpr (fmap isFalseE s) + +-- | SQL @IS NOT FALSE@ operator +isNotFalse_ :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s a -> QGenExpr context syntax s Bool +isNotFalse_ (QExpr s) = QExpr (fmap isNotFalseE s) + +-- | SQL @IS UNKNOWN@ operator +isUnknown_ :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s a -> QGenExpr context syntax s Bool +isUnknown_ (QExpr s) = QExpr (fmap isUnknownE s) + +-- | SQL @IS NOT UNKNOWN@ operator +isNotUnknown_ :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s a -> QGenExpr context syntax s Bool +isNotUnknown_ (QExpr s) = QExpr (fmap isNotUnknownE s) + +-- | SQL @CONCAT@ function +concat_ :: IsSql99ConcatExpressionSyntax syntax + => [ QGenExpr context syntax s T.Text ] -> QGenExpr context syntax s T.Text +concat_ es = QExpr (concatE <$> mapM (\(QExpr e) -> e) es) diff --git a/Database/Beam/Query/Ord.hs b/Database/Beam/Query/Ord.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Ord.hs @@ -0,0 +1,217 @@ +-- | Defines classen 'SqlEq' and 'SqlOrd' that can be used to perform equality +-- and comparison operations on certain expressions. +-- +-- In particular, any 'Beamable' value over 'QGenExpr' or any 'QGenExpr' +-- object can be compared for equality and inequality using the '(==.)' and +-- '(/=.)' operators respectively. +-- +-- Simple (scalar) 'QGenExpr's can be compared using the '(<.)', '(>.)', +-- '(<=.)', and '(>=.)' operators respectively. +-- +-- The "Quantified Comparison Syntax" (i.e., @.. > ANY (..)@) is supported +-- using the corresponding operators suffixed with a @*@ before the dot. For +-- example, @x == ANY(SELECT ..)@ can be written. +-- +-- > x ==*. anyOf_ .. +-- +-- Or, for example, @x > ALL(SELECT ..)@ can be written +-- +-- > x >*. allOf_ .. +module Database.Beam.Query.Ord + ( SqlEq(..), SqlEqQuantified(..) + , SqlOrd(..), SqlOrdQuantified(..) + , QQuantified(..) + + , anyOf_, anyIn_ + , allOf_, allIn_ + + , between_ + + , in_ ) where + +import Database.Beam.Query.Internal +import Database.Beam.Query.Types +import Database.Beam.Query.Operator + +import Database.Beam.Schema.Tables +import Database.Beam.Backend.SQL + +import Control.Applicative +import Control.Monad.State + +import Data.Maybe + +-- | A data structure representing the set to quantify a comparison operator over. +data QQuantified expr s r + = QQuantified (Sql92ExpressionQuantifierSyntax expr) (WithExprContext expr) + +-- | A 'QQuantified' representing a SQL @ALL(..)@ for use with a +-- <#quantified-comparison-operator quantified comparison operator> +-- +-- Accepts a subquery. Use 'allIn_' for an explicit list +allOf_ + :: forall s r select expr db. + ( ThreadRewritable (QNested s) r + , ProjectibleInSelectSyntax select r + , IsSql92SelectSyntax select + , IsSql92ExpressionSyntax expr + , HasQBuilder select + , Sql92ExpressionSelectSyntax expr ~ select ) + => Q select db (QNested s) r + -> QQuantified expr s (WithRewrittenThread (QNested s) s r) +allOf_ s = QQuantified quantifyOverAll (\tblPfx -> subqueryE (buildSqlQuery tblPfx s)) + +-- | A 'QQuantified' representing a SQL @ALL(..)@ for use with a +-- <#quantified-comparison-operator quantified comparison operator> +-- +-- Accepts an explicit list of typed expressions. Use 'allOf_' for +-- a subquery +allIn_ + :: forall s a expr + . ( IsSql92ExpressionSyntax expr ) + => [QExpr expr s a] + -> QQuantified expr s a +allIn_ es = QQuantified quantifyOverAll (rowE <$> mapM (\(QExpr e) -> e) es) + +-- | A 'QQuantified' representing a SQL @ANY(..)@ for use with a +-- <#quantified-comparison-operator quantified comparison operator> +-- +-- Accepts a subquery. Use 'anyIn_' for an explicit list +anyOf_ + :: forall s r select expr db. + ( ThreadRewritable (QNested s) r + , ProjectibleInSelectSyntax select r + , IsSql92SelectSyntax select + , IsSql92ExpressionSyntax expr + , HasQBuilder select + , Sql92ExpressionSelectSyntax expr ~ select ) + => Q select db (QNested s) r + -> QQuantified expr s (WithRewrittenThread (QNested s) s r) +anyOf_ s = QQuantified quantifyOverAny (\tblPfx -> subqueryE (buildSqlQuery tblPfx s)) + +-- | A 'QQuantified' representing a SQL @ANY(..)@ for use with a +-- <#quantified-comparison-operator quantified comparison operator> +-- +-- Accepts an explicit list of typed expressions. Use 'anyOf_' for +-- a subquery +anyIn_ + :: forall s a expr + . ( IsSql92ExpressionSyntax expr ) + => [QExpr expr s a] + -> QQuantified expr s a +anyIn_ es = QQuantified quantifyOverAny (rowE <$> mapM (\(QExpr e) -> e) es) + +-- | SQL @BETWEEN@ clause +between_ :: IsSql92ExpressionSyntax syntax + => QGenExpr context syntax s a -> QGenExpr context syntax s a + -> QGenExpr context syntax s a -> QGenExpr context syntax s Bool +between_ (QExpr a) (QExpr min_) (QExpr max_) = + QExpr (liftA3 betweenE a min_ max_) + +-- | SQL @IN@ predicate +in_ :: ( IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool ) + => QGenExpr context syntax s a + -> [ QGenExpr context syntax s a ] + -> QGenExpr context syntax s Bool +in_ _ [] = QExpr (pure (valueE (sqlValueSyntax False))) +in_ (QExpr row) options = QExpr (inE <$> row <*> mapM (\(QExpr o) -> o) options) + +-- | Class for expression types or expression containers for which there is a +-- notion of equality. +-- +-- Instances are provided to check the equality of expressions of the same +-- type as well as entire 'Beamable' types parameterized over 'QGenExpr' +class SqlEq expr a | a -> expr where + -- | Given two expressions, returns whether they are equal + (==.) :: a -> a -> expr Bool + -- | Given two expressions, returns whether they are not equal + (/=.) :: a -> a -> expr Bool + +-- | Class for expression types for which there is a notion of /quantified/ +-- equality. +class SqlEq expr a => SqlEqQuantified expr quantified a | a -> expr quantified where + + (==*.), (/=*.) :: a -> quantified -> expr Bool + +infix 4 ==., /=., ==*., /=*. +infix 4 <., >., <=., >=. +infix 4 <*., >*., <=*., >=*. + +-- | Compare two arbitrary expressions (of the same type) for equality +instance IsSql92ExpressionSyntax syntax => + SqlEq (QGenExpr context syntax s) (QGenExpr context syntax s a) where + + (==.) = qBinOpE (eqE Nothing) + (/=.) = qBinOpE (neqE Nothing) + +-- | Two arbitrary expressions can be quantifiably compared for equality. +instance IsSql92ExpressionSyntax syntax => + SqlEqQuantified (QGenExpr context syntax s) (QQuantified syntax s a) (QGenExpr context syntax s a) where + + a ==*. QQuantified q b = qBinOpE (eqE (Just q)) a (QExpr b) + a /=*. QQuantified q b = qBinOpE (neqE (Just q)) a (QExpr b) + +-- | Compare two arbitrary 'Beamable' types containing 'QGenExpr's for equality. +instance ( IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool + , Beamable tbl ) => + SqlEq (QGenExpr context syntax s) (tbl (QGenExpr context syntax s)) where + + a ==. b = let (_, e) = runState (zipBeamFieldsM + (\x'@(Columnar' x) (Columnar' y) -> + do modify (\expr -> + case expr of + Nothing -> Just $ x ==. y + Just expr' -> Just $ expr' &&. x ==. y) + return x') a b) Nothing + in fromMaybe (QExpr (\_ -> valueE (sqlValueSyntax True))) e + a /=. b = not_ (a ==. b) + +instance ( IsSql92ExpressionSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool + , Beamable tbl) + => SqlEq (QGenExpr context syntax s) (tbl (Nullable (QGenExpr context syntax s))) where + + a ==. b = let (_, e) = runState (zipBeamFieldsM + (\x'@(Columnar' x) (Columnar' y) -> do + modify (\expr -> + case expr of + Nothing -> Just $ x ==. y + Just expr' -> Just $ expr' &&. x ==. y) + return x') a b) Nothing + in fromMaybe (QExpr (\_ -> valueE (sqlValueSyntax True))) e + a /=. b = not_ (a ==. b) + +-- * Comparisons + +-- | Class for expression types or expression containers for which there is a +-- notion of ordering. +-- +-- Instances are provided to check the ordering of expressions of the same +-- type. Since there is no universal notion of ordering for an arbitrary +-- number of expressions, no instance is provided for 'Beamable' types. +class SqlEq expr e => SqlOrd expr e | e -> expr where + + (<.), (>.), (<=.), (>=.) :: e -> e -> expr Bool + +-- | Class for things which can be /quantifiably/ compared. +class (SqlOrd expr e, SqlEqQuantified expr quantified e) => + SqlOrdQuantified expr quantified e | e -> expr quantified where + + (<*.), (>*.), (<=*.), (>=*.) :: e -> quantified -> expr Bool + +instance IsSql92ExpressionSyntax syntax => + SqlOrd (QGenExpr context syntax s) (QGenExpr context syntax s a) where + + (<.) = qBinOpE (ltE Nothing) + (>.) = qBinOpE (gtE Nothing) + (<=.) = qBinOpE (leE Nothing) + (>=.) = qBinOpE (geE Nothing) + +instance IsSql92ExpressionSyntax syntax => + SqlOrdQuantified (QGenExpr context syntax s) (QQuantified syntax s a) (QGenExpr context syntax s a) where + a <*. QQuantified q b = qBinOpE (ltE (Just q)) a (QExpr b) + a <=*. QQuantified q b = qBinOpE (leE (Just q)) a (QExpr b) + a >*. QQuantified q b = qBinOpE (gtE (Just q)) a (QExpr b) + a >=*. QQuantified q b = qBinOpE (geE (Just q)) a (QExpr b) diff --git a/Database/Beam/Query/Relationships.hs b/Database/Beam/Query/Relationships.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Relationships.hs @@ -0,0 +1,178 @@ +-- | Combinators and types specific to relationships. +-- +-- These types and functions correspond with the relationships section in the +-- . +module Database.Beam.Query.Relationships + ( -- * Relationships + + -- ** Many-to-many relationships + ManyToMany, ManyToManyThrough + , manyToMany_, manyToManyPassthrough_ + + -- ** One-to-many relationships + , OneToMany, OneToManyOptional + , oneToMany_, oneToManyOptional_ + + -- ** One-to-one relationshships + , OneToOne, OneToMaybe + , oneToOne_, oneToMaybe_ ) where + +import Database.Beam.Query.Combinators +import Database.Beam.Query.Operator +import Database.Beam.Query.Internal +import Database.Beam.Query.Ord + +import Database.Beam.Schema + +import Database.Beam.Backend.SQL + + +-- | Synonym of 'OneToMany'. Useful for giving more meaningful types, when the +-- relationship is meant to be one-to-one. +type OneToOne db s one many = OneToMany db s one many + +-- | Convenience type to declare one-to-many relationships. See the manual +-- section on +-- +-- for more information +type OneToMany db s one many = + forall syntax. + ( IsSql92SelectSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool ) => + one (QExpr (Sql92SelectExpressionSyntax syntax) s) -> + Q syntax db s (many (QExpr (Sql92SelectExpressionSyntax syntax) s)) + +-- | Synonym of 'OneToManyOptional'. Useful for giving more meaningful types, +-- when the relationship is meant to be one-to-one. +type OneToMaybe db s tbl rel = OneToManyOptional db s tbl rel + +-- | Convenience type to declare one-to-many relationships with a nullable +-- foreign key. See the manual section on +-- +-- for more information +type OneToManyOptional db s tbl rel = + forall syntax. + ( IsSql92SelectSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) SqlNull ) => + tbl (QExpr (Sql92SelectExpressionSyntax syntax) s) -> + Q syntax db s (rel (Nullable (QExpr (Sql92SelectExpressionSyntax syntax) s))) + +-- | Used to define one-to-many (or one-to-one) relationships. Takes the table +-- to fetch, a way to extract the foreign key from that table, and the table to +-- relate to. +oneToMany_, oneToOne_ + :: ( IsSql92SelectSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool + , Database db + , Table tbl, Table rel ) + => DatabaseEntity be db (TableEntity rel) {-^ Table to fetch (many) -} + -> (rel (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey tbl (QExpr (Sql92SelectExpressionSyntax syntax) s)) + {-^ Foreign key -} + -> tbl (QExpr (Sql92SelectExpressionSyntax syntax) s) + -> Q syntax db s (rel (QExpr (Sql92SelectExpressionSyntax syntax) s)) +oneToMany_ rel getKey tbl = + join_ rel (\rel' -> getKey rel' ==. pk tbl) +oneToOne_ = oneToMany_ + +-- | Used to define one-to-many (or one-to-one) relationships with a nullable +-- foreign key. Takes the table to fetch, a way to extract the foreign key +-- from that table, and the table to relate to. +oneToManyOptional_, oneToMaybe_ + :: ( IsSql92SelectSyntax syntax + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool + , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) SqlNull + , Database db + , Table tbl, Table rel ) + => DatabaseEntity be db (TableEntity rel) {-^ Table to fetch -} + -> (rel (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey tbl (Nullable (QExpr (Sql92SelectExpressionSyntax syntax) s))) + {-^ Foreign key -} + -> tbl (QExpr (Sql92SelectExpressionSyntax syntax) s) + -> Q syntax db s (rel (Nullable (QExpr (Sql92SelectExpressionSyntax syntax) s))) +oneToManyOptional_ rel getKey tbl = + leftJoin_ (all_ rel) (\rel' -> getKey rel' ==. just_ (pk tbl)) +oneToMaybe_ = oneToManyOptional_ + +-- ** Many-to-many relationships + +-- | Convenience type to declare many-to-many relationships. See the manual +-- section on +-- +-- for more information +type ManyToMany db left right = + forall syntax s. + ( Sql92SelectSanityCheck syntax, IsSql92SelectSyntax syntax + + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) => + Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> + Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s), right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + +-- | Convenience type to declare many-to-many relationships with additional +-- data. See the manual section on +-- +-- for more information +type ManyToManyThrough db through left right = + forall syntax s. + ( Sql92SelectSanityCheck syntax, IsSql92SelectSyntax syntax + + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) => + Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> + Q syntax db s ( through (QExpr (Sql92SelectExpressionSyntax syntax) s) + , left (QExpr (Sql92SelectExpressionSyntax syntax) s) + , right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + +-- | Used to define many-to-many relationships without any additional data. +-- Takes the join table and two key extraction functions from that table to the +-- related tables. Also takes two `Q`s representing the table sources to relate. +-- +-- See +-- for more indformation. +manyToMany_ + :: ( Database db, Table joinThrough + , Table left, Table right + , Sql92SelectSanityCheck syntax + , IsSql92SelectSyntax syntax + + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) + => DatabaseEntity be db (TableEntity joinThrough) + -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s), right (QExpr (Sql92SelectExpressionSyntax syntax) s)) +manyToMany_ joinTbl leftKey rightKey left right = fmap (\(_, l, r) -> (l, r)) $ + manyToManyPassthrough_ joinTbl leftKey rightKey left right + +-- | Used to define many-to-many relationships with additional data. Takes the +-- join table and two key extraction functions from that table to the related +-- tables. Also takes two `Q`s representing the table sources to relate. +-- +-- See +-- for more indformation. +manyToManyPassthrough_ + :: ( Database db, Table joinThrough + , Table left, Table right + , Sql92SelectSanityCheck syntax + , IsSql92SelectSyntax syntax + + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) + , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) + => DatabaseEntity be db (TableEntity joinThrough) + -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> Q syntax db s ( joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) + , left (QExpr (Sql92SelectExpressionSyntax syntax) s) + , right (QExpr (Sql92SelectExpressionSyntax syntax) s)) +manyToManyPassthrough_ joinTbl leftKey rightKey left right = + do left_ <- left + right_ <- right + joinTbl_ <- join_ joinTbl (\joinTbl_ -> leftKey joinTbl_ ==. primaryKey left_ &&. + rightKey joinTbl_ ==. primaryKey right_) + pure (joinTbl_, left_, right_) + + + diff --git a/Database/Beam/Query/SQL92.hs b/Database/Beam/Query/SQL92.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/SQL92.hs @@ -0,0 +1,522 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} + +module Database.Beam.Query.SQL92 + ( buildSql92Query' ) where + +import Database.Beam.Query.Internal +import Database.Beam.Backend.SQL + +import Database.Beam.Schema.Tables + +import Control.Monad.Free.Church +import Control.Monad.Free +import Control.Monad.Writer + +import Data.Maybe +import Data.String +import qualified Data.Text as T + +-- * Beam queries + +andE' :: IsSql92ExpressionSyntax expr => + Maybe expr -> Maybe expr -> Maybe expr +andE' Nothing Nothing = Nothing +andE' (Just x) Nothing = Just x +andE' Nothing (Just y) = Just y +andE' (Just x) (Just y) = Just (andE x y) + +data QueryBuilder select + = QueryBuilder + { qbNextTblRef :: Int + , qbFrom :: Maybe (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) + , qbWhere :: Maybe (Sql92SelectExpressionSyntax select) } + +data SelectBuilder syntax (db :: (* -> *) -> *) a where + SelectBuilderQ :: ( IsSql92SelectSyntax syntax + , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a ) => + a -> QueryBuilder syntax -> SelectBuilder syntax db a + SelectBuilderGrouping + :: ( IsSql92SelectSyntax syntax + , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a ) + => a -> QueryBuilder syntax + -> Maybe (Sql92SelectGroupingSyntax syntax) + -> Maybe (Sql92SelectExpressionSyntax syntax) + -> Maybe (Sql92SelectTableSetQuantifierSyntax (Sql92SelectSelectTableSyntax syntax)) + -> SelectBuilder syntax db a + SelectBuilderSelectSyntax :: Bool {- Whether or not this contains UNION, INTERSECT, EXCEPT, etc -} + -> a -> Sql92SelectSelectTableSyntax syntax + -> SelectBuilder syntax db a + SelectBuilderTopLevel :: + { sbLimit, sbOffset :: Maybe Integer + , sbOrdering :: [ Sql92SelectOrderingSyntax syntax ] + , sbTable :: SelectBuilder syntax db a } -> + SelectBuilder syntax db a + +sbContainsSetOperation :: SelectBuilder syntax db a -> Bool +sbContainsSetOperation (SelectBuilderSelectSyntax contains _ _) = contains +sbContainsSetOperation (SelectBuilderTopLevel { sbTable = tbl }) = sbContainsSetOperation tbl +sbContainsSetOperation _ = False + +fieldNameFunc :: IsSql92ExpressionSyntax expr => + (T.Text -> Sql92ExpressionFieldNameSyntax expr) -> Int + -> expr +fieldNameFunc mkField i = fieldE (mkField ("res" <> fromString (show i))) + +nextTblPfx :: TablePrefix -> TablePrefix +nextTblPfx = ("sub_" <>) + +defaultProjection :: Projectible expr x => + TablePrefix -> x -> [ ( expr, Maybe T.Text ) ] +defaultProjection pfx = + zipWith (\i e -> (e, Just (fromString "res" <> fromString (show (i :: Integer))))) + [0..] . flip project (nextTblPfx pfx) + +buildSelect :: ( IsSql92SelectSyntax syntax + , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) a ) => + TablePrefix -> SelectBuilder syntax db a -> syntax +buildSelect _ (SelectBuilderTopLevel limit offset ordering (SelectBuilderSelectSyntax _ _ table)) = + selectStmt table ordering limit offset +buildSelect pfx (SelectBuilderTopLevel limit offset ordering (SelectBuilderQ proj (QueryBuilder _ from where_))) = + selectStmt (selectTableStmt Nothing (projExprs (defaultProjection pfx proj)) from where_ Nothing Nothing) ordering limit offset +buildSelect pfx (SelectBuilderTopLevel limit offset ordering (SelectBuilderGrouping proj (QueryBuilder _ from where_) grouping having distinct)) = + selectStmt (selectTableStmt distinct (projExprs (defaultProjection pfx proj)) from where_ grouping having) ordering limit offset +buildSelect pfx x = buildSelect pfx (SelectBuilderTopLevel Nothing Nothing [] x) + +selectBuilderToTableSource :: ( Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax syntax)) ~ syntax + , IsSql92SelectSyntax syntax + , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) a ) => + TablePrefix -> SelectBuilder syntax db a -> Sql92SelectSelectTableSyntax syntax +selectBuilderToTableSource _ (SelectBuilderSelectSyntax _ _ x) = x +selectBuilderToTableSource pfx (SelectBuilderQ x (QueryBuilder _ from where_)) = + selectTableStmt Nothing (projExprs (defaultProjection pfx x)) from where_ Nothing Nothing +selectBuilderToTableSource pfx (SelectBuilderGrouping x (QueryBuilder _ from where_) grouping having distinct) = + selectTableStmt distinct (projExprs (defaultProjection pfx x)) from where_ grouping having +selectBuilderToTableSource pfx sb = + let (x, QueryBuilder _ from where_) = selectBuilderToQueryBuilder pfx sb + in selectTableStmt Nothing (projExprs (defaultProjection pfx x)) from where_ Nothing Nothing + +selectBuilderToQueryBuilder :: ( Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax syntax)) ~ syntax + , IsSql92SelectSyntax syntax + , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) a ) => + TablePrefix -> SelectBuilder syntax db a -> (a, QueryBuilder syntax) +selectBuilderToQueryBuilder pfx sb = + let select = buildSelect pfx sb + x' = reproject (fieldNameFunc (qualifiedField t0)) (sbProj sb) + t0 = pfx <> "0" + in (x', QueryBuilder 1 (Just (fromTable (tableFromSubSelect select) (Just t0))) Nothing) + +emptyQb :: QueryBuilder select +emptyQb = QueryBuilder 0 Nothing Nothing + +sbProj :: SelectBuilder syntax db a -> a +sbProj (SelectBuilderQ proj _) = proj +sbProj (SelectBuilderGrouping proj _ _ _ _) = proj +sbProj (SelectBuilderSelectSyntax _ proj _) = proj +sbProj (SelectBuilderTopLevel _ _ _ sb) = sbProj sb + +setSelectBuilderProjection :: Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) b => + SelectBuilder syntax db a -> b -> SelectBuilder syntax db b +setSelectBuilderProjection (SelectBuilderQ _ q) proj = SelectBuilderQ proj q +setSelectBuilderProjection (SelectBuilderGrouping _ q grouping having d) proj = SelectBuilderGrouping proj q grouping having d +setSelectBuilderProjection (SelectBuilderSelectSyntax containsSetOp _ q) proj = SelectBuilderSelectSyntax containsSetOp proj q +setSelectBuilderProjection (SelectBuilderTopLevel limit offset ord sb) proj = + SelectBuilderTopLevel limit offset ord (setSelectBuilderProjection sb proj) + +limitSelectBuilder, offsetSelectBuilder :: Integer -> SelectBuilder syntax db a -> SelectBuilder syntax db a +limitSelectBuilder limit (SelectBuilderTopLevel limit' offset ordering tbl) = + SelectBuilderTopLevel (Just $ maybe limit (min limit) limit') offset ordering tbl +limitSelectBuilder limit x = SelectBuilderTopLevel (Just limit) Nothing [] x + +offsetSelectBuilder offset (SelectBuilderTopLevel Nothing offset' ordering tbl) = + SelectBuilderTopLevel Nothing (Just $ offset + fromMaybe 0 offset') ordering tbl +offsetSelectBuilder offset (SelectBuilderTopLevel (Just limit) offset' ordering tbl) = + SelectBuilderTopLevel (Just $ max 0 (limit - offset)) (Just $ offset + fromMaybe 0 offset') ordering tbl +offsetSelectBuilder offset x = SelectBuilderTopLevel Nothing (Just offset) [] x + +exprWithContext :: TablePrefix -> WithExprContext a -> a +exprWithContext pfx = ($ nextTblPfx pfx) + +buildJoinTableSourceQuery + :: ( IsSql92SelectSyntax select + , Projectible (Sql92SelectExpressionSyntax select) x + , Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax select)) ~ select ) + => TablePrefix -> select + -> x -> QueryBuilder select + -> (x, QueryBuilder select) +buildJoinTableSourceQuery tblPfx tblSource x qb = + let qb' = QueryBuilder (tblRef + 1) from' (qbWhere qb) + !tblRef = qbNextTblRef qb + from' = case qbFrom qb of + Nothing -> Just newSource + Just oldFrom -> Just (innerJoin oldFrom newSource Nothing) + newSource = fromTable (tableFromSubSelect tblSource) (Just newTblNm) + newTblNm = tblPfx <> fromString (show tblRef) + in (reproject (fieldNameFunc (qualifiedField newTblNm)) x, qb') + +buildInnerJoinQuery + :: forall select s table + . (Beamable table, IsSql92SelectSyntax select) + => TablePrefix -> T.Text -> TableSettings table + -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) + -> QueryBuilder select -> (table (QExpr (Sql92SelectExpressionSyntax select) s), QueryBuilder select) +buildInnerJoinQuery tblPfx tbl tblSettings mkOn qb = + let qb' = QueryBuilder (tblRef + 1) from' where' + tblRef = qbNextTblRef qb + newTblNm = tblPfx <> fromString (show tblRef) + newSource = fromTable (tableNamed tbl) (Just newTblNm) + (from', where') = + case qbFrom qb of + Nothing -> (Just newSource, andE' (qbWhere qb) (exprWithContext tblPfx <$> mkOn newTbl)) + Just oldFrom -> (Just (innerJoin oldFrom newSource (exprWithContext tblPfx <$> mkOn newTbl)), qbWhere qb) + + newTbl = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField newTblNm (_fieldName f))))) tblSettings + in (newTbl, qb') + +nextTbl :: (IsSql92SelectSyntax select, Beamable table) + => QueryBuilder select + -> TablePrefix -> T.Text -> TableSettings table + -> ( table (QExpr (Sql92SelectExpressionSyntax select) s) + , T.Text + , QueryBuilder select ) +nextTbl qb tblPfx _ tblSettings = + let tblRef = qbNextTblRef qb + newTblNm = tblPfx <> fromString (show tblRef) + newTbl = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField newTblNm (_fieldName f))))) tblSettings + in (newTbl, newTblNm, qb { qbNextTblRef = qbNextTblRef qb + 1}) + +projOrder :: Projectible expr x => + x -> WithExprContext [ expr ] +projOrder = project -- (Proxy @AnyType) (\_ x -> tell [x] >> pure x) + +-- | Convenience functions to construct an arbitrary SQL92 select syntax type +-- from a 'Q'. Used by most backends as the default implementation of +-- 'buildSqlQuery' in 'HasQBuilder'. +buildSql92Query' :: + forall select projSyntax db s a. + ( IsSql92SelectSyntax select + , Eq (Sql92SelectExpressionSyntax select) + , projSyntax ~ Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax select) + , Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax select)) ~ select + + , Sql92ProjectionExpressionSyntax projSyntax ~ Sql92SelectExpressionSyntax select + , Projectible (Sql92ProjectionExpressionSyntax projSyntax) a ) => + Bool {-^ Whether this backend supports arbitrary nested UNION, INTERSECT, EXCEPT -} -> + T.Text {-^ Table prefix -} -> + Q select db s a -> + select +buildSql92Query' arbitrarilyNestedCombinations tblPfx (Q q) = + buildSelect tblPfx (buildQuery (fromF q)) + where + buildQuery :: forall s x. + Projectible (Sql92ProjectionExpressionSyntax projSyntax) x => + Free (QF select db s) x + -> SelectBuilder select db x + buildQuery (Pure x) = SelectBuilderQ x emptyQb + buildQuery (Free (QGuard _ next)) = buildQuery next + buildQuery f@(Free QAll {}) = buildJoinedQuery f emptyQb + buildQuery f@(Free QArbitraryJoin {}) = buildJoinedQuery f emptyQb + buildQuery f@(Free QTwoWayJoin {}) = buildJoinedQuery f emptyQb + buildQuery (Free (QSubSelect q' next)) = + let sb = buildQuery (fromF q') + (proj, qb) = selectBuilderToQueryBuilder tblPfx sb + in buildJoinedQuery (next proj) qb + buildQuery (Free (QDistinct nubType q' next)) = + let (proj, qb, gp, hv) = + case buildQuery (fromF q') of + SelectBuilderQ proj qb -> + ( proj, qb, Nothing, Nothing) + SelectBuilderGrouping proj qb gp hv Nothing -> + ( proj, qb, gp, hv) + sb -> + let (proj, qb) = selectBuilderToQueryBuilder tblPfx sb + in ( proj, qb, Nothing, Nothing) + in case next proj of + Pure x -> SelectBuilderGrouping x qb gp hv (Just (exprWithContext tblPfx (nubType proj))) + _ -> let ( proj', qb' ) = selectBuilderToQueryBuilder tblPfx (SelectBuilderGrouping proj qb gp hv (Just (exprWithContext tblPfx (nubType proj)))) + in buildJoinedQuery (next proj') qb' + buildQuery (Free (QAggregate mkAgg q' next)) = + let sb = buildQuery (fromF q') + (groupingSyntax, aggProj) = mkAgg (sbProj sb) (nextTblPfx tblPfx) + in case tryBuildGuardsOnly (next aggProj) Nothing of + Just (proj, having) -> + case sb of + SelectBuilderQ _ q'' -> SelectBuilderGrouping proj q'' groupingSyntax having Nothing + + -- We'll have to generate a subselect + _ -> let (subProj, qb) = selectBuilderToQueryBuilder tblPfx sb --(setSelectBuilderProjection sb aggProj) + (groupingSyntax, aggProj') = mkAgg subProj (nextTblPfx tblPfx) + in case tryBuildGuardsOnly (next aggProj') Nothing of + Nothing -> error "buildQuery (Free (QAggregate ...)): Impossible" + Just (aggProj'', having') -> + SelectBuilderGrouping aggProj'' qb groupingSyntax having' Nothing + Nothing -> + let (_, having) = tryCollectHaving (next aggProj') Nothing + (next', _) = tryCollectHaving (next x') Nothing + (groupingSyntax', aggProj', qb) = + case sb of + SelectBuilderQ _ q'' -> (groupingSyntax, aggProj, q'') + _ -> let (proj', qb''') = selectBuilderToQueryBuilder tblPfx sb + (groupingSyntax', aggProj') = mkAgg proj' (nextTblPfx tblPfx) + in (groupingSyntax', aggProj', qb''') + (x', qb') = selectBuilderToQueryBuilder tblPfx $ + SelectBuilderGrouping aggProj' qb groupingSyntax' having Nothing + in buildJoinedQuery next' qb' + + buildQuery (Free (QOrderBy mkOrdering q' next)) = + let sb = buildQuery (fromF q') + proj = sbProj sb + ordering = exprWithContext tblPfx (mkOrdering proj) + + doJoined = + let sb' = case sb of + SelectBuilderQ {} -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb reproj) + SelectBuilderGrouping {} -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb reproj) + SelectBuilderSelectSyntax {} -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb reproj) + SelectBuilderTopLevel Nothing Nothing [] sb' -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb' reproj) + SelectBuilderTopLevel (Just 0) (Just 0) [] sb' -> + SelectBuilderTopLevel (Just 0) (Just 0) ordering (setSelectBuilderProjection sb' reproj) + SelectBuilderTopLevel {} + | (proj'', qb) <- selectBuilderToQueryBuilder tblPfx sb -> + SelectBuilderTopLevel Nothing Nothing (exprWithContext tblPfx (mkOrdering proj'')) (SelectBuilderQ proj'' qb) + | otherwise -> error "buildQuery (Free (QOrderBy ...)): query inspected expression" + + (reproj, _) = selectBuilderToQueryBuilder tblPfx sb + (joinedProj, qb) = selectBuilderToQueryBuilder tblPfx sb' + in buildJoinedQuery (next joinedProj) qb + in case next proj of + Pure proj' -> + case ordering of + [] -> setSelectBuilderProjection sb proj' + ordering -> + case sb of + SelectBuilderQ {} -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb proj') + SelectBuilderGrouping {} -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb proj') + SelectBuilderSelectSyntax {} -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb proj') + SelectBuilderTopLevel Nothing Nothing [] sb' -> + SelectBuilderTopLevel Nothing Nothing ordering (setSelectBuilderProjection sb' proj') + SelectBuilderTopLevel (Just 0) (Just 0) [] sb' -> + SelectBuilderTopLevel (Just 0) (Just 0) ordering (setSelectBuilderProjection sb' proj') + SelectBuilderTopLevel {} + | (proj'', qb) <- selectBuilderToQueryBuilder tblPfx sb, + Pure proj''' <- next proj'' -> + SelectBuilderTopLevel Nothing Nothing (exprWithContext tblPfx (mkOrdering proj'')) (SelectBuilderQ proj''' qb) + | otherwise -> error "buildQuery (Free (QOrderBy ...)): query inspected expression" + _ -> doJoined + + buildQuery (Free (QWindowOver mkWindows mkProjection q' next)) = + let sb = buildQuery (fromF q') + + x = sbProj sb + windows = mkWindows x + projection = mkProjection x windows + in case next projection of + Pure x' -> + -- Windowing makes this automatically a top-level (this prevents aggregates from being added directly) + case setSelectBuilderProjection sb x' of + sb'@SelectBuilderTopLevel {} -> sb' + sb' -> SelectBuilderTopLevel Nothing Nothing [] sb' + _ -> + let (x', qb) = selectBuilderToQueryBuilder tblPfx (setSelectBuilderProjection sb projection) + in buildJoinedQuery (next x') qb + + buildQuery (Free (QLimit limit q' next)) = + let sb = limitSelectBuilder limit (buildQuery (fromF q')) + x = sbProj sb + -- In the case of limit, we must directly return whatever was given + in case next x of + Pure x' -> setSelectBuilderProjection sb x' + + -- Otherwise, this is going to be part of a join... + _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb + in buildJoinedQuery (next x') qb + + buildQuery (Free (QOffset offset q' next)) = + let sb = offsetSelectBuilder offset (buildQuery (fromF q')) + x = sbProj sb + -- In the case of limit, we must directly return whatever was given + in case next x of + Pure x' -> setSelectBuilderProjection sb x' + -- Otherwise, this is going to be part of a join... + _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb + in buildJoinedQuery (next x') qb + + buildQuery (Free (QUnion all_ left right next)) = + buildTableCombination (unionTables all_) left right next + buildQuery (Free (QIntersect all_ left right next)) = + buildTableCombination (intersectTables all_) left right next + buildQuery (Free (QExcept all_ left right next)) = + buildTableCombination (exceptTable all_) left right next + + tryBuildGuardsOnly :: forall s x. + Free (QF select db s) x + -> Maybe (Sql92SelectExpressionSyntax select) + -> Maybe (x, Maybe (Sql92SelectExpressionSyntax select)) + tryBuildGuardsOnly next having = + case tryCollectHaving next having of + (Pure x, having') -> Just (x, having') + _ -> Nothing + + tryCollectHaving :: forall s x. + Free (QF select db s) x + -> Maybe (Sql92SelectExpressionSyntax select) + -> (Free (QF select db s) x, Maybe (Sql92SelectExpressionSyntax select)) + tryCollectHaving (Free (QGuard cond next)) having = tryCollectHaving next (andE' having (Just (exprWithContext tblPfx cond))) + tryCollectHaving next having = (next, having) + + buildTableCombination :: + forall s x r. + ( Projectible (Sql92ProjectionExpressionSyntax projSyntax) r + , Projectible (Sql92ProjectionExpressionSyntax projSyntax) x ) => + (Sql92SelectSelectTableSyntax select -> Sql92SelectSelectTableSyntax select -> Sql92SelectSelectTableSyntax select) -> + QM select db (QNested s) x -> QM select db (QNested s) x -> (x -> Free (QF select db s) r) -> SelectBuilder select db r + buildTableCombination combineTables left right next = + let leftSb = buildQuery (fromF left) + leftTb = selectBuilderToTableSource tblPfx leftSb + rightSb = buildQuery (fromF right) + rightTb = selectBuilderToTableSource tblPfx rightSb + + proj = reproject (fieldNameFunc unqualifiedField) (sbProj leftSb) + + leftTb' | arbitrarilyNestedCombinations = leftTb + | sbContainsSetOperation leftSb = + let (x', qb) = selectBuilderToQueryBuilder tblPfx leftSb + in selectBuilderToTableSource tblPfx (SelectBuilderQ x' qb) + | otherwise = leftTb + rightTb' | arbitrarilyNestedCombinations = rightTb + | sbContainsSetOperation rightSb = + let (x', qb) = selectBuilderToQueryBuilder tblPfx rightSb + in selectBuilderToTableSource tblPfx (SelectBuilderQ x' qb) + | otherwise = rightTb + + sb = SelectBuilderSelectSyntax True proj (combineTables leftTb' rightTb') + in case next proj of + Pure proj' + | projOrder proj (nextTblPfx tblPfx) == projOrder proj' (nextTblPfx tblPfx) -> + setSelectBuilderProjection sb proj' + _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb + in buildJoinedQuery (next x') qb + + buildJoinedQuery :: forall s x. + Projectible (Sql92ProjectionExpressionSyntax projSyntax) x => + Free (QF select db s) x -> QueryBuilder select -> SelectBuilder select db x + buildJoinedQuery (Pure x) qb = SelectBuilderQ x qb + buildJoinedQuery (Free (QAll tbl tblSettings on next)) qb = + let (newTbl, qb') = buildInnerJoinQuery tblPfx tbl tblSettings on qb + in buildJoinedQuery (next newTbl) qb' + buildJoinedQuery (Free (QArbitraryJoin q mkJoin on next)) qb = + case fromF q of + Free (QAll dbTblNm dbTblSettings on' next') + | (newTbl, newTblNm, qb') <- nextTbl qb tblPfx dbTblNm dbTblSettings, + Nothing <- exprWithContext tblPfx <$> on' newTbl, + Pure proj <- next' newTbl -> + let newSource = fromTable (tableNamed dbTblNm) (Just newTblNm) + on'' = exprWithContext tblPfx <$> on proj + (from', where') = + case qbFrom qb' of + Nothing -> (Just newSource, andE' (qbWhere qb) on'') + Just oldFrom -> (Just (mkJoin oldFrom newSource on''), qbWhere qb) + in buildJoinedQuery (next proj) (qb' { qbFrom = from', qbWhere = where' }) + + q' -> let sb = buildQuery q' + tblSource = buildSelect tblPfx sb + newTblNm = tblPfx <> fromString (show (qbNextTblRef qb)) + + newSource = fromTable (tableFromSubSelect tblSource) (Just newTblNm) + + proj' = reproject (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) + on' = exprWithContext tblPfx <$> on proj' + + (from', where') = + case qbFrom qb of + Nothing -> (Just newSource, andE' (qbWhere qb) on') + Just oldFrom -> (Just (mkJoin oldFrom newSource on'), qbWhere qb) + + in buildJoinedQuery (next proj') (qb { qbNextTblRef = qbNextTblRef qb + 1 + , qbFrom = from', qbWhere = where' }) + buildJoinedQuery (Free (QTwoWayJoin a b mkJoin on next)) qb = + let (aProj, aSource, qb') = + case fromF a of + Free (QAll dbTblNm dbTblSettings on' next') + | (newTbl, newTblNm, qb') <- nextTbl qb tblPfx dbTblNm dbTblSettings, + Nothing <- on' newTbl, Pure proj <- next' newTbl -> + (proj, fromTable (tableNamed dbTblNm) (Just newTblNm), qb') + + a -> let sb = buildQuery a + tblSource = buildSelect tblPfx sb + + newTblNm = tblPfx <> fromString (show (qbNextTblRef qb)) + + proj' = reproject (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) + in (proj', fromTable (tableFromSubSelect tblSource) (Just newTblNm), qb { qbNextTblRef = qbNextTblRef qb + 1 }) + + (bProj, bSource, qb'') = + case fromF b of + Free (QAll dbTblNm dbTblSettings on' next') + | (newTbl, newTblNm, qb'') <- nextTbl qb' tblPfx dbTblNm dbTblSettings, + Nothing <- on' newTbl, Pure proj <- next' newTbl -> + (proj, fromTable (tableNamed dbTblNm) (Just newTblNm), qb'') + + b -> let sb = buildQuery b + tblSource = buildSelect tblPfx sb + + newTblNm = tblPfx <> fromString (show (qbNextTblRef qb)) + + proj' = reproject (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) + in (proj', fromTable (tableFromSubSelect tblSource) (Just newTblNm), qb { qbNextTblRef = qbNextTblRef qb + 1 }) + + abSource = mkJoin aSource bSource (exprWithContext tblPfx <$> on (aProj, bProj)) + + from' = + case qbFrom qb'' of + Nothing -> Just abSource + Just oldFrom -> Just (innerJoin oldFrom abSource Nothing) + + in buildJoinedQuery (next (aProj, bProj)) (qb'' { qbFrom = from' }) + buildJoinedQuery (Free (QGuard cond next)) qb = + buildJoinedQuery next (qb { qbWhere = andE' (qbWhere qb) (Just (exprWithContext tblPfx cond)) }) + buildJoinedQuery now qb = + onlyQ now + (\now' next -> + let sb = buildQuery now' + tblSource = buildSelect tblPfx sb + (x', qb') = buildJoinTableSourceQuery tblPfx tblSource (sbProj sb) qb + in buildJoinedQuery (next x') qb') + + onlyQ :: forall s x. + Free (QF select db s) x + -> (forall a'. Projectible (Sql92SelectExpressionSyntax select) a' => Free (QF select db s) a' -> (a' -> Free (QF select db s) x) -> SelectBuilder select db x) + -> SelectBuilder select db x + onlyQ (Free (QAll entityNm entitySettings mkOn next)) f = + f (Free (QAll entityNm entitySettings mkOn Pure)) next + onlyQ (Free (QArbitraryJoin entity mkJoin mkOn next)) f = + f (Free (QArbitraryJoin entity mkJoin mkOn Pure)) next + onlyQ (Free (QTwoWayJoin a b mkJoin mkOn next)) f = + f (Free (QTwoWayJoin a b mkJoin mkOn Pure)) next + onlyQ (Free (QSubSelect q' next)) f = + f (Free (QSubSelect q' Pure)) next + onlyQ (Free (QLimit limit q' next)) f = + f (Free (QLimit limit q' Pure)) next + onlyQ (Free (QOffset offset q' next)) f = + f (Free (QOffset offset q' Pure)) next + onlyQ (Free (QUnion all_ a b next)) f = + f (Free (QUnion all_ a b Pure)) next + onlyQ (Free (QIntersect all_ a b next)) f = + f (Free (QIntersect all_ a b Pure)) next + onlyQ (Free (QExcept all_ a b next)) f = + f (Free (QExcept all_ a b Pure)) next + onlyQ (Free (QOrderBy mkOrdering q' next)) f = + f (Free (QOrderBy mkOrdering q' Pure)) next + onlyQ (Free (QWindowOver mkWindow mkProj q' next)) f = + f (Free (QWindowOver mkWindow mkProj q' Pure)) next + onlyQ (Free (QAggregate mkAgg q' next)) f = + f (Free (QAggregate mkAgg q' Pure)) next + onlyQ (Free (QDistinct d q' next)) f = + f (Free (QDistinct d q' Pure)) next + onlyQ _ _ = error "impossible" diff --git a/Database/Beam/Query/Types.hs b/Database/Beam/Query/Types.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Types.hs @@ -0,0 +1,44 @@ +module Database.Beam.Query.Types + ( Q, QExpr, QGenExpr(..), QExprToIdentity, QWindow, QWindowFrame + + , Projectible, Aggregation + + , HasQBuilder(..) ) where + +import Database.Beam.Query.Internal +import Database.Beam.Query.SQL92 + +import Database.Beam.Schema.Tables + +import Database.Beam.Backend.SQL.Builder +import Database.Beam.Backend.SQL.AST +import Database.Beam.Backend.SQL.SQL92 + +import Control.Monad.Identity +import Data.Vector.Sized (Vector) + +type family QExprToIdentity x +type instance QExprToIdentity (table (QGenExpr context syntax s)) = table Identity +type instance QExprToIdentity (table (Nullable c)) = Maybe (QExprToIdentity (table c)) +type instance QExprToIdentity (QGenExpr context syntax s a) = a +type instance QExprToIdentity () = () +type instance QExprToIdentity (a, b) = (QExprToIdentity a, QExprToIdentity b) +type instance QExprToIdentity (a, b, c) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c) +type instance QExprToIdentity (a, b, c, d) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c, QExprToIdentity d) +type instance QExprToIdentity (a, b, c, d, e) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c, QExprToIdentity d, QExprToIdentity e) +type instance QExprToIdentity (a, b, c, d, e, f) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c, QExprToIdentity d, QExprToIdentity e, QExprToIdentity f) +type instance QExprToIdentity (a, b, c, d, e, f, g) = + ( QExprToIdentity a, QExprToIdentity b, QExprToIdentity c, QExprToIdentity d, QExprToIdentity e, QExprToIdentity f + , QExprToIdentity g) +type instance QExprToIdentity (a, b, c, d, e, f, g, h) = + ( QExprToIdentity a, QExprToIdentity b, QExprToIdentity c, QExprToIdentity d, QExprToIdentity e, QExprToIdentity f + , QExprToIdentity g, QExprToIdentity h ) +type instance QExprToIdentity (Vector n a) = Vector n (QExprToIdentity a) + +class IsSql92SelectSyntax selectSyntax => HasQBuilder selectSyntax where + buildSqlQuery :: Projectible (Sql92SelectExpressionSyntax selectSyntax) a => + TablePrefix -> Q selectSyntax db s a -> selectSyntax +instance HasQBuilder SqlSyntaxBuilder where + buildSqlQuery = buildSql92Query' True +instance HasQBuilder Select where + buildSqlQuery = buildSql92Query' True diff --git a/Database/Beam/Schema.hs b/Database/Beam/Schema.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Schema.hs @@ -0,0 +1,56 @@ +-- | Defines type classes for 'Table's and 'Database's. +-- +-- All important class methods of these classes can be derived automatically using 'Generic's and GHC's DefaultSignatures extension, +-- but you can override any method if necessary. +-- +-- To get started, see 'Table', 'Columnar', and 'Nullable'. +module Database.Beam.Schema + ( + -- * Database construction + -- $db-construction + Database + + , DatabaseSettings + , DatabaseEntity + + -- ** #entities# Database entities + -- $entities + , TableEntity + + -- * Table construction + , Table(..), Beamable + , defTblFieldSettings, pk + + , Columnar, C, Columnar', Nullable + , TableField, fieldName + + , TableSettings, HaskellTable + + -- * 'Generic'-deriving mechanisms + , defaultDbSettings + + -- ** Modifying the derived schema + , DatabaseModification, EntityModification, FieldModification + , withDbModification, withTableModification + , dbModification, tableModification + , modifyTable, fieldNamed + + -- * Types for lens generation + , Lenses, LensFor(..) + + , module Database.Beam.Schema.Lenses ) where + +import Database.Beam.Schema.Tables +import Database.Beam.Schema.Lenses + +-- $db-construction +-- Types and functions to express database types and auto-generate name mappings +-- for them. See the +-- [manual](https://tathougies.github.io/beam/user-guide/databases.md) for more +-- information. + +-- $entities +-- Database entities represent things that can go into databases. Each entity in +-- your database that you want to access from Haskell must be given a field in +-- your database type. Each type of entity gets a particular entity tag, such as +-- 'TableEntity' or 'DomainTypeEntity' diff --git a/Database/Beam/Schema/Lenses.hs b/Database/Beam/Schema/Lenses.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Schema/Lenses.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE PolyKinds #-} +module Database.Beam.Schema.Lenses + ( tableLenses + , TableLens(..) + + , dbLenses ) where + +import Database.Beam.Schema.Tables + +import Control.Monad.Identity + +import Data.Proxy + +import GHC.Generics + +import Lens.Micro hiding (to) + +class GTableLenses t (m :: * -> *) a (lensType :: * -> *) where + gTableLenses :: Proxy a -> Lens' (t m) (a p) -> lensType () +instance GTableLenses t m a al => GTableLenses t m (M1 s d a) (M1 s d al) where + gTableLenses (Proxy :: Proxy (M1 s d a)) lensToHere = M1 $ gTableLenses (Proxy :: Proxy a) (\f -> lensToHere (\(M1 x) -> M1 <$> f x)) +instance (GTableLenses t m a aLens, GTableLenses t m b bLens) => GTableLenses t m (a :*: b) (aLens :*: bLens) where + gTableLenses (Proxy :: Proxy (a :*: b)) lensToHere = leftLenses :*: rightLenses + where leftLenses = gTableLenses (Proxy :: Proxy a) (\f -> lensToHere (\(a :*: b) -> (:*: b) <$> f a)) + rightLenses = gTableLenses (Proxy :: Proxy b) (\f -> lensToHere (\(a :*: b) -> (a :*:) <$> f b)) +instance Generic (t m) => GTableLenses t m (K1 R x) (K1 R (LensFor (t m) x)) where + gTableLenses _ lensToHere = K1 (LensFor (\f -> lensToHere (\(K1 x) -> K1 <$> f x))) +instance ( Generic (PrimaryKey rel m) + , Generic (PrimaryKey rel (Lenses t m)) + , GTableLenses t m (Rep (PrimaryKey rel m)) (Rep (PrimaryKey rel (Lenses t m))) ) => + GTableLenses t m (K1 R (PrimaryKey rel m)) (K1 R (PrimaryKey rel (Lenses t m))) where + gTableLenses _ lensToHere = K1 (to (gTableLenses (Proxy :: Proxy (Rep (PrimaryKey rel m))) (\f -> lensToHere (\(K1 x) -> K1 . to <$> f (from x))))) + +tableLenses' :: ( lensType ~ Lenses t f + , Generic (t lensType) + , Generic (t f) + , GTableLenses t f (Rep (t f)) (Rep (t lensType)) ) => + Proxy t -> Proxy f -> t lensType +tableLenses' (Proxy :: Proxy t) (Proxy :: Proxy f) = + to (gTableLenses (Proxy :: Proxy (Rep (t f))) ((\f x -> to <$> f (from x)) :: Lens' (t f) (Rep (t f) ()))) + +-- | Automatically deduce lenses for a table over any column tag. lenses at +-- global level by doing a top-level pattern match on 'tableLenses', replacing +-- every column in the pattern with `LensFor '. The lenses +-- are generated per-column, not per field in the record. Thus if you have +-- nested 'Beamable' types, lenses are generated for each nested field. +-- +-- For example, +-- +-- > data AuthorT f = AuthorT +-- > { _authorEmail :: Columnar f Text +-- > , _authorFirstName :: Columnar f Text +-- > , _authorLastName :: Columnar f Text } +-- > deriving Generic +-- > +-- > data BlogPostT f = BlogPost +-- > { _blogPostSlug :: Columnar f Text +-- > , _blogPostBody :: Columnar f Text +-- > , _blogPostDate :: Columnar f UTCTime +-- > , _blogPostAuthor :: PrimaryKey AuthorT f +-- > , _blogPostTagline :: Columnar f (Maybe Text) } +-- > deriving Generic +-- > instance Table BlogPostT where +-- > data PrimaryKey BlogPostT f = BlogPostId (Columnar f Text) +-- > primaryKey = BlogPostId . _blogPostSlug +-- > instance Table AuthorT where +-- > data PrimaryKey AuthorT f = AuthorId (Columnar f Text) +-- > primaryKey = AuthorId . _authorEmail +-- +-- > BlogPost (LensFor blogPostSlug +-- > (LensFor blogPostBody) +-- > (LensFor blogPostDate) +-- > (AuthorId (LensFor blogPostAuthorEmail)) +-- > (LensFor blogPostTagLine) = tableLenses +-- +-- Note: In order to have GHC deduce the right type, you will need to turn off +-- the monomorphism restriction. This is a part of the Haskell standard that +-- specifies that top-level definitions must be inferred to have a monomorphic +-- type. However, lenses need a polymorphic type to work properly. You can +-- turn off the monomorphism restriction by enabling the +-- 'NoMonomorphismRestriction' extension. You can do this per-file by using +-- the {-# LANGUAGE NoMonomorphismRestriction #-} pragma at the top of the +-- file. You can also pass the @-XNoMonomorphismRestriction@ command line flag +-- to GHC during compilation. +tableLenses :: ( lensType ~ Lenses t f + , Generic (t lensType) + , Generic (t f) + , GTableLenses t f (Rep (t f)) (Rep (t lensType)) ) => + t (Lenses t f) +tableLenses = let res = tableLenses' (tProxy res) (fProxy res) + + tProxy :: t (Lenses t f) -> Proxy t + tProxy _ = Proxy + fProxy :: t (Lenses t f) -> Proxy f + fProxy _ = Proxy + in res + +newtype TableLens f db (x :: k) = TableLens (Lens' (db f) (f x)) + +class GDatabaseLenses outer structure lensType where + gDatabaseLenses :: Lens' outer (structure p) -> lensType () +instance GDatabaseLenses db a al => GDatabaseLenses db (M1 s d a) (M1 s d al) where + gDatabaseLenses lensToHere = M1 $ gDatabaseLenses (\f -> lensToHere (\(M1 x) -> M1 <$> f x)) +instance (GDatabaseLenses db a al, GDatabaseLenses db b bl) => GDatabaseLenses db (a :*: b) (al :*: bl) where + gDatabaseLenses lensToHere = leftLenses :*: rightLenses + where leftLenses = gDatabaseLenses (\f -> lensToHere (\(a :*: b) -> (:*: b) <$> f a)) + rightLenses = gDatabaseLenses (\f -> lensToHere (\(a :*: b) -> (a :*:) <$> f b)) +instance GDatabaseLenses (db f) (K1 R (f x)) + (K1 R (TableLens f db x)) where + gDatabaseLenses lensToHere = K1 (TableLens (\f -> lensToHere (\(K1 x) -> K1 <$> f x))) + +-- | Like 'tableLenses' but for types that are instances of 'Database'. Instead +-- of pattern matching on 'LensFor', pattern match on 'TableLens'. +dbLenses :: ( Generic (db (TableLens f db)) + , Generic (db f) + , GDatabaseLenses (db f) (Rep (db f)) (Rep (db (TableLens f db))) ) + => db (TableLens f db) +dbLenses = fix $ \(_ :: db (TableLens f db)) -> + to (gDatabaseLenses (\f (x :: db f) -> to <$> f (from x)) :: Rep (db (TableLens f db)) ()) diff --git a/Database/Beam/Schema/Tables.hs b/Database/Beam/Schema/Tables.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Schema/Tables.hs @@ -0,0 +1,853 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} + +-- | Defines a generic schema type that can be used to define schemas for Beam tables +module Database.Beam.Schema.Tables + ( + -- * Database Types + Database + , zipTables + + , DatabaseSettings + , IsDatabaseEntity(..) + , DatabaseEntityDescriptor(..) + , DatabaseEntity(..), TableEntity, ViewEntity, DomainTypeEntity + , dbEntityDescriptor + , DatabaseModification, EntityModification(..) + , FieldModification(..) + , dbModification, tableModification, withDbModification + , withTableModification, modifyTable, fieldNamed + , defaultDbSettings + + , RenamableWithRule(..), RenamableField(..) + , FieldRenamer(..) + + , Lenses, LensFor(..) + + -- * Columnar and Column Tags + , Columnar, C, Columnar'(..) + , Nullable, TableField(..) + , Exposed + , fieldName + + , TableSettings, HaskellTable + , TableSkeleton, Ignored(..) + , GFieldsFulfillConstraint(..), FieldsFulfillConstraint + , FieldsFulfillConstraintNullable + , WithConstraint(..) + , TagReducesTo(..), ReplaceBaseTag + + -- * Tables + , Table(..), Beamable(..) + , Retaggable(..) + , defTblFieldSettings + , tableValuesNeeded + , pk + , allBeamValues, changeBeamRep ) + where + +import Database.Beam.Backend.Types + +import Control.Arrow (first) +import Control.Monad.Identity +import Control.Monad.Writer + +import Data.Char (isUpper, toLower) +import Data.Monoid ((<>)) +import Data.Proxy +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable + +import qualified GHC.Generics as Generic +import GHC.Generics hiding (R, C) +import GHC.TypeLits +import GHC.Types + +import Lens.Micro hiding (to) +import qualified Lens.Micro as Lens + +-- | Allows introspection into database types. +-- +-- All database types must be of kind '(* -> *) -> *'. If the type parameter +-- is named 'f', each field must be of the type of 'f' applied to some type +-- for which an 'IsDatabaseEntity' instance exists. +-- +-- Entities are documented under [the corresponding +-- section](Database.Beam.Schema#entities) and in the +-- [manual](http://tathougies.github.io/beam/user-guide/databases/) +class Database db where + + -- | Default derived function. Do not implement this yourself. + -- + -- The idea is that, for any two databases over particular entity tags 'f' + -- and 'g', if we can take any entity in 'f' and 'g' to the corresponding + -- entity in 'h' (in the possibly effectful monad 'm'), then we can + -- transform the two databases over 'f' and 'g' to a database in 'h', + -- within the monad 'm'. + -- + -- If that doesn't make sense, don't worry. This is mostly beam internal + zipTables :: Monad m + => Proxy be + -> (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) => + f tbl -> g tbl -> m (h tbl)) + -> db f -> db g -> m (db h) + default zipTables :: ( Generic (db f), Generic (db g), Generic (db h) + , Monad m + , GZipDatabase be f g h + (Rep (db f)) (Rep (db g)) (Rep (db h)) ) => + Proxy be -> + (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) -> + db f -> db g -> m (db h) + -- We need the pattern type signature on 'combine' to get around a type checking bug in GHC 8.0.1. In future releases, + -- we will switch to the standard forall. + zipTables be combine (f :: db f) (g :: db g) = + refl $ \h -> + to <$> gZipDatabase (Proxy @f, Proxy @g, h, be) combine (from f) (from g) + where + -- For GHC 8.0.1 renamer bug + refl :: (Proxy h -> m (db h)) -> m (db h) + refl fn = fn Proxy + +-- | Automatically provide names for tables, and descriptions for tables (using +-- 'defTblFieldSettings'). Your database must implement 'Generic', and must be +-- auto-derivable. For more information on name generation, see the +-- [manual](https://tathougies.github.io/beam/user-guide/models) +defaultDbSettings :: ( Generic (DatabaseSettings be db) + , GAutoDbSettings (Rep (DatabaseSettings be db) ()) ) => + DatabaseSettings be db +defaultDbSettings = to' autoDbSettings' + +-- | A helper data type that lets you modify a database schema. Converts all +-- entities in the database into functions from that entity to itself. +type DatabaseModification f be db = db (EntityModification f be) +-- | A newtype wrapper around 'f e -> f e' (i.e., an endomorphism between entity +-- types in 'f'). You usually want to use 'modifyTable' or another function to +-- contstruct these for you. +newtype EntityModification f be e = EntityModification (f e -> f e) +-- | A newtype wrapper around 'Columnar f a -> Columnar f ' (i.e., an +-- endomorphism between 'Columnar's over 'f'). You usually want to use +-- 'fieldNamed' or the 'IsString' instance to rename the field, when 'f ~ +-- TableField' +newtype FieldModification f a + = FieldModification (Columnar f a -> Columnar f a) + +-- | Return a 'DatabaseModification' that does nothing. This is useful if you +-- only want to rename one table. You can do +-- +-- > dbModification { tbl1 = modifyTable (\oldNm -> "NewTableName") tableModification } +dbModification :: forall f be db. Database db => DatabaseModification f be db +dbModification = runIdentity $ + zipTables (Proxy @be) (\_ _ -> pure (EntityModification id)) (undefined :: DatabaseModification f be db) (undefined :: DatabaseModification f be db) + +-- | Return a table modification (for use with 'modifyTable') that does nothing. +-- Useful if you only want to change the table name, or if you only want to +-- modify a few fields. +-- +-- For example, +-- +-- > tableModification { field1 = "Column1" } +-- +-- is a table modification (where 'f ~ TableField tbl') that changes the +-- column name of 'field1' to "Column1". +tableModification :: forall f tbl. Beamable tbl => tbl (FieldModification f) +tableModification = runIdentity $ + zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) -> + pure (Columnar' (FieldModification id :: FieldModification f x))) (undefined :: TableSkeleton tbl) (undefined :: TableSkeleton tbl) + +-- | Modify a database according to a given modification. Most useful for +-- 'DatabaseSettings' to change the name mappings of tables and fields. For +-- example, you can use this to modify the default names of a table +-- +-- > db :: DatabaseSettings MyDb +-- > db = defaultDbSettings `withDbModification` +-- > dbModification { +-- > -- Change default name "table1" to "Table_1". Change the name of "table1Field1" to "first_name" +-- > table1 = modifyTable (\_ -> "Table_1") (tableModification { table1Field1 = "first_name" } +-- > } +withDbModification :: forall db be entity + . Database db + => db (entity be db) + -> DatabaseModification (entity be db) be db + -> db (entity be db) +withDbModification db mods = + runIdentity $ zipTables (Proxy @be) (\tbl (EntityModification entityFn) -> pure (entityFn tbl)) db mods + +-- | Modify a table according to the given field modifications. Invoked by +-- 'modifyTable' to apply the modification in the database. Not used as often in +-- user code, but provided for completeness. +withTableModification :: Beamable tbl => tbl (FieldModification f) -> tbl f -> tbl f +withTableModification mods tbl = + runIdentity $ zipBeamFieldsM (\(Columnar' field :: Columnar' f a) (Columnar' (FieldModification fieldFn :: FieldModification f a)) -> + pure (Columnar' (fieldFn field))) tbl mods + +-- | Provide an 'EntityModification' for 'TableEntity's. Allows you to modify +-- the name of the table and provide a modification for each field in the +-- table. See the examples for 'withDbModification' for more. +modifyTable :: (Text -> Text) + -> tbl (FieldModification (TableField tbl)) + -> EntityModification (DatabaseEntity be db) be (TableEntity tbl) +modifyTable modTblNm modFields = + EntityModification (\(DatabaseEntity (DatabaseTable nm fields)) -> + (DatabaseEntity (DatabaseTable (modTblNm nm) (withTableModification modFields fields)))) + +-- | A field modification to rename the field. Also offered under the 'IsString' +-- instance for 'FieldModification (TableField tbl) a' for convenience. +fieldNamed :: Text -> FieldModification (TableField tbl) a +fieldNamed newName = FieldModification (\_ -> TableField newName) + +newtype FieldRenamer entity = FieldRenamer { withFieldRenamer :: entity -> entity } + +class RenamableField f where + renameField :: Proxy f -> Proxy a -> (Text -> Text) -> Columnar f a -> Columnar f a +instance RenamableField (TableField tbl) where + renameField _ _ f (TableField nm) = TableField (f nm) + +class RenamableWithRule mod where + renamingFields :: (Text -> Text) -> mod +instance Database db => RenamableWithRule (db (EntityModification (DatabaseEntity be db) be)) where + renamingFields renamer = + runIdentity $ + zipTables (Proxy @be) (\_ _ -> pure (renamingFields renamer)) + (undefined :: DatabaseModification f be db) + (undefined :: DatabaseModification f be db) +instance IsDatabaseEntity be entity => RenamableWithRule (EntityModification (DatabaseEntity be db) be entity) where + renamingFields renamer = + EntityModification (\(DatabaseEntity tbl) -> DatabaseEntity (withFieldRenamer (renamingFields renamer) tbl)) +instance (Beamable tbl, RenamableField f) => RenamableWithRule (tbl (FieldModification f)) where + renamingFields renamer = + runIdentity $ + zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) -> + pure (Columnar' (FieldModification (renameField (Proxy @f) (Proxy @x) renamer) :: FieldModification f x) :: + Columnar' (FieldModification f) x)) + (undefined :: TableSkeleton tbl) (undefined :: TableSkeleton tbl) + +instance IsString (FieldModification (TableField tbl) a) where + fromString = fieldNamed . fromString + +-- * Database entity types + +-- | An entity tag for tables. See the documentation for 'Table' or consult the +-- [manual](https://tathougies.github.io/beam/user-guide/models) for more. +data TableEntity (tbl :: (* -> *) -> *) +data ViewEntity (view :: (* -> *) -> *) +--data UniqueConstraint (tbl :: (* -> *) -> *) (c :: (* -> *) -> *) +data DomainTypeEntity (ty :: *) +--data CharacterSetEntity +--data CollationEntity +--data TranslationEntity +--data AssertionEntity + +class RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be entityType)) => + IsDatabaseEntity be entityType where + data DatabaseEntityDescriptor be entityType :: * + type DatabaseEntityDefaultRequirements be entityType :: Constraint + type DatabaseEntityRegularRequirements be entityType :: Constraint + + dbEntityName :: Lens' (DatabaseEntityDescriptor be entityType) Text + dbEntityAuto :: DatabaseEntityDefaultRequirements be entityType => + Text -> DatabaseEntityDescriptor be entityType + +instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (TableEntity tbl))) where + renamingFields renamer = + FieldRenamer $ \(DatabaseTable tblName fields) -> + DatabaseTable tblName $ + changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) -> + Columnar' (renameField (Proxy @(TableField tbl)) (Proxy @a) renamer tblField) :: Columnar' (TableField tbl) a) $ + fields + +instance Beamable tbl => IsDatabaseEntity be (TableEntity tbl) where + data DatabaseEntityDescriptor be (TableEntity tbl) where + DatabaseTable :: Table tbl => Text -> TableSettings tbl -> DatabaseEntityDescriptor be (TableEntity tbl) + type DatabaseEntityDefaultRequirements be (TableEntity tbl) = + ( GDefaultTableFieldSettings (Rep (TableSettings tbl) ()) + , Generic (TableSettings tbl), Table tbl, Beamable tbl ) + type DatabaseEntityRegularRequirements be (TableEntity tbl) = + ( Table tbl, Beamable tbl ) + + dbEntityName f (DatabaseTable t s) = fmap (\t' -> DatabaseTable t' s) (f t) + dbEntityAuto nm = + DatabaseTable (unCamelCaseSel nm) defTblFieldSettings + +instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (ViewEntity tbl))) where + renamingFields renamer = + FieldRenamer $ \(DatabaseView tblName fields) -> + DatabaseView tblName $ + changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) -> + Columnar' (renameField (Proxy @(TableField tbl)) (Proxy @a) renamer tblField) :: Columnar' (TableField tbl) a) $ + fields + +instance Beamable tbl => IsDatabaseEntity be (ViewEntity tbl) where + data DatabaseEntityDescriptor be (ViewEntity tbl) where + DatabaseView :: Text -> TableSettings tbl -> DatabaseEntityDescriptor be (ViewEntity tbl) + type DatabaseEntityDefaultRequirements be (ViewEntity tbl) = + ( GDefaultTableFieldSettings (Rep (TableSettings tbl) ()) + , Generic (TableSettings tbl), Beamable tbl ) + type DatabaseEntityRegularRequirements be (ViewEntity tbl) = + ( Beamable tbl ) + + dbEntityName f (DatabaseView t s) = fmap (\t' -> DatabaseView t' s) (f t) + dbEntityAuto nm = + DatabaseView (unCamelCaseSel nm) defTblFieldSettings + +instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (DomainTypeEntity ty))) where + renamingFields _ = FieldRenamer id + +instance IsDatabaseEntity be (DomainTypeEntity ty) where + data DatabaseEntityDescriptor be (DomainTypeEntity ty) + = DatabaseDomainType !Text + type DatabaseEntityDefaultRequirements be (DomainTypeEntity ty) = () + type DatabaseEntityRegularRequirements be (DomainTypeEntity ty) = () + + dbEntityName f (DatabaseDomainType t) = DatabaseDomainType <$> f t + dbEntityAuto = DatabaseDomainType + +-- | Represents a meta-description of a particular entityType. Mostly, a wrapper +-- around 'DatabaseEntityDescriptor be entityType', but carries around the +-- 'IsDatabaseEntity' dictionary. +data DatabaseEntity be (db :: (* -> *) -> *) entityType where + DatabaseEntity :: + IsDatabaseEntity be entityType => + DatabaseEntityDescriptor be entityType -> DatabaseEntity be db entityType + +dbEntityDescriptor :: SimpleGetter (DatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType) +dbEntityDescriptor = Lens.to (\(DatabaseEntity e) -> e) + +-- | When parameterized by this entity tag, a database type will hold +-- meta-information on the Haskell mappings of database entities. Under the +-- hood, each entity type is transformed into its 'DatabaseEntityDescriptor' +-- type. For tables this includes the table name as well as the corresponding +-- 'TableSettings', which provides names for each column. +type DatabaseSettings be db = db (DatabaseEntity be db) + +class GAutoDbSettings x where + autoDbSettings' :: x +instance GAutoDbSettings (x p) => GAutoDbSettings (D1 f x p) where + autoDbSettings' = M1 autoDbSettings' +instance GAutoDbSettings (x p) => GAutoDbSettings (C1 f x p) where + autoDbSettings' = M1 autoDbSettings' +instance (GAutoDbSettings (x p), GAutoDbSettings (y p)) => GAutoDbSettings ((x :*: y) p) where + autoDbSettings' = autoDbSettings' :*: autoDbSettings' +instance ( Selector f, IsDatabaseEntity be x, DatabaseEntityDefaultRequirements be x ) => + GAutoDbSettings (S1 f (K1 Generic.R (DatabaseEntity be db x)) p) where + autoDbSettings' = M1 (K1 (DatabaseEntity (dbEntityAuto name))) + where name = T.pack (selName (undefined :: S1 f (K1 Generic.R (DatabaseEntity be db x)) p)) + +class GZipDatabase be f g h x y z where + gZipDatabase :: Monad m => + (Proxy f, Proxy g, Proxy h, Proxy be) + -> (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) + -> x () -> y () -> m (z ()) +instance GZipDatabase be f g h x y z => + GZipDatabase be f g h (M1 a b x) (M1 a b y) (M1 a b z) where + gZipDatabase p combine ~(M1 f) ~(M1 g) = M1 <$> gZipDatabase p combine f g +instance ( GZipDatabase be f g h ax ay az + , GZipDatabase be f g h bx by bz ) => + GZipDatabase be f g h (ax :*: bx) (ay :*: by) (az :*: bz) where + gZipDatabase p combine ~(ax :*: bx) ~(ay :*: by) = + do a <- gZipDatabase p combine ax ay + b <- gZipDatabase p combine bx by + pure (a :*: b) +instance (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) => + GZipDatabase be f g h (K1 Generic.R (f tbl)) (K1 Generic.R (g tbl)) (K1 Generic.R (h tbl)) where + + gZipDatabase _ combine ~(K1 x) ~(K1 y) = + K1 <$> combine x y + +data Lenses (t :: (* -> *) -> *) (f :: * -> *) x +data LensFor t x where + LensFor :: Generic t => Lens' t x -> LensFor t x + +-- | A type family that we use to "tag" columns in our table datatypes. +-- +-- This is what allows us to use the same table type to hold table data, describe table settings, +-- derive lenses, and provide expressions. +-- +-- The basic rules are +-- +-- > Columnar Identity x = x +-- +-- Thus, any Beam table applied to 'Identity' will yield a simplified version of the data type, that contains +-- just what you'd expect. +-- +-- The 'Nullable' type is used when referencing 'PrimaryKey's that we want to include optionally. +-- For example, if we have a table with a 'PrimaryKey', like the following +-- +-- > data BeamTableT f = BeamTableT +-- > { _refToAnotherTable :: PrimaryKey AnotherTableT f +-- > , ... } +-- +-- we would typically be required to provide values for the 'PrimaryKey' embedded into 'BeamTableT'. We can use +-- 'Nullable' to lift this constraint. +-- +-- > data BeamTableT f = BeamTableT +-- > { _refToAnotherTable :: PrimaryKey AnotherTableT (Nullable f) +-- > , ... } +-- +-- Now we can use 'justRef' and 'nothingRef' to refer to this table optionally. The embedded 'PrimaryKey' in '_refToAnotherTable' +-- automatically has its fields converted into 'Maybe' using 'Nullable'. +-- +-- The last 'Columnar' rule is +-- +-- > Columnar f x = f x +-- +-- Use this rule if you'd like to parameterize your table type over any other functor. For example, this is used +-- in the query modules to write expressions such as 'TableT QExpr', which returns a table whose fields have been +-- turned into query expressions. +-- +-- The other rules are used within Beam to provide lenses and to expose the inner structure of the data type. +type family Columnar (f :: * -> *) x where + Columnar Exposed x = Exposed x + + Columnar Identity x = x + + Columnar (Lenses t f) x = LensFor (t f) (Columnar f x) +-- Columnar (Lenses t f) x = LensFor (t f) (f x) + + Columnar (Nullable c) x = Columnar c (Maybe x) + + Columnar f x = f x + +-- | A short type-alias for 'Columnar'. May shorten your schema definitions +type C f a = Columnar f a + +-- | If you declare a function 'Columnar f a -> b' and try to constrain your +-- function by a type class for 'f', GHC will complain, because 'f' is +-- ambiguous in 'Columnar f a'. For example, 'Columnar Identity (Maybe a) ~ +-- Maybe a' and 'Columnar (Nullable Identity) a ~ Maybe a', so given a type +-- 'Columnar f a', we cannot know the type of 'f'. +-- +-- Thus, if you need to know 'f', you can instead use 'Columnar''. Since its a +-- newtype, it carries around the 'f' paramater unambiguously. Internally, it +-- simply wraps 'Columnar f a' +newtype Columnar' f a = Columnar' (Columnar f a) + +-- | Metadata for a field of type 'ty' in 'table'. +-- +-- Essentially a wrapper over the field name, but with a phantom type +-- parameter, so that it forms an appropriate column tag. +-- +-- Usually you use the 'defaultDbSettings' function to generate an appropriate +-- naming convention for you, and then modify it with 'withDbModification' if +-- necessary. Under this scheme, the field can be renamed using the 'IsString' +-- instance for 'TableField', or the 'fieldNamed' function. +data TableField (table :: (* -> *) -> *) ty + = TableField + { _fieldName :: Text -- ^ The field name + } deriving (Show, Eq) + +-- | Van Laarhoven lens to retrieve or set the field name from a 'TableField'. +fieldName :: Lens' (TableField table ty) Text +fieldName f (TableField name) = TableField <$> f name + +-- | Represents a table that contains metadata on its fields. In particular, +-- each field of type 'Columnar f a' is transformed into 'TableField table a'. +-- You can get or update the name of each field by using the 'fieldName' lens. +type TableSettings table = table (TableField table) + +-- | The regular Haskell version of the table. Equivalent to 'tbl Identity' +type HaskellTable table = table Identity + +-- | Column tag that ignores the type. +data Ignored x = Ignored +-- | A form of 'table' all fields 'Ignored'. Useful as a parameter to +-- 'zipTables' when you only care about one table. +type TableSkeleton table = table Ignored + +from' :: Generic x => x -> Rep x () +from' = from + +to' :: Generic x => Rep x () -> x +to' = to + +type HasBeamFields table f g h = ( GZipTables f g h (Rep (table Exposed)) (Rep (table f)) (Rep (table g)) (Rep (table h)) + , Generic (table f), Generic (table g), Generic (table h) ) + +-- | The big Kahuna! All beam tables implement this class. +-- +-- The kind of all table types is '(* -> *) -> *'. This is because all table types are actually /table type constructors/. +-- Every table type takes in another type constructor, called the /column tag/, and uses that constructor to instantiate the column types. +-- See the documentation for 'Columnar'. +-- +-- This class is mostly Generic-derivable. You need only specify a type for the table's primary key and a method to extract the primary key +-- given the table. +-- +-- An example table: +-- +-- > data BlogPostT f = BlogPost +-- > { _blogPostSlug :: Columnar f Text +-- > , _blogPostBody :: Columnar f Text +-- > , _blogPostDate :: Columnar f UTCTime +-- > , _blogPostAuthor :: PrimaryKey AuthorT f +-- > , _blogPostTagline :: Columnar f (Maybe Text) +-- > , _blogPostImageGallery :: PrimaryKey ImageGalleryT (Nullable f) } +-- > deriving Generic +-- > instance Beamable BlogPostT +-- > instance Table BlogPostT where +-- > data PrimaryKey BlogPostT f = BlogPostId (Columnar f Text) deriving Generic +-- > primaryKey = BlogPostId . _blogPostSlug +-- > instance Beamable (PrimaryKey BlogPostT) +-- +-- We can interpret this as follows: +-- +-- * The `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, and `_blogPostTagline` fields are of types 'Text', 'Text', 'UTCTime', and 'Maybe Text' respectfully. +-- * Since `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, `_blogPostAuthor` must be provided (i.e, they cannot contain 'Nothing'), they will be given SQL NOT NULL constraints. +-- `_blogPostTagline` is declared 'Maybe' so 'Nothing' will be stored as NULL in the database. `_blogPostImageGallery` will be allowed to be empty because it uses the 'Nullable' tag modifier. +-- * `blogPostAuthor` references the `AuthorT` table (not given here) and is required. +-- * `blogPostImageGallery` references the `ImageGalleryT` table (not given here), but this relation is not required (i.e., it may be 'Nothing'. See 'Nullable'). +class (Typeable table, Beamable table, Beamable (PrimaryKey table)) => Table (table :: (* -> *) -> *) where + + -- | A data type representing the types of primary keys for this table. + -- In order to play nicely with the default deriving mechanism, this type must be an instance of 'Generic'. + data PrimaryKey table (column :: * -> *) :: * + + -- | Given a table, this should return the PrimaryKey from the table. By keeping this polymorphic over column, + -- we ensure that the primary key values come directly from the table (i.e., they can't be arbitrary constants) + primaryKey :: table column -> PrimaryKey table column + +-- | Provides a number of introspection routines for the beam library. Allows us +-- to "zip" tables with different column tags together. Always instantiate an +-- empty 'Beamable' instance for tables, primary keys, and any type that you +-- would like to embed within either. See the +-- [manual](https://tathougies.github.io/beam/user-guide/models) for more +-- information on embedding. +class Beamable table where + zipBeamFieldsM :: Applicative m => + (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h) + default zipBeamFieldsM :: ( HasBeamFields table f g h + , Applicative m ) => + (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h) + zipBeamFieldsM combine (f :: table f) g = + to' <$> gZipTables (Proxy :: Proxy (Rep (table Exposed))) combine (from' f) (from' g) + + tblSkeleton :: TableSkeleton table + default tblSkeleton :: ( Generic (TableSkeleton table) + , GTableSkeleton (Rep (TableSkeleton table)) ) => TableSkeleton table + tblSkeleton = withProxy $ \proxy -> to' (gTblSkeleton proxy) + where withProxy :: (Proxy (Rep (TableSkeleton table)) -> TableSkeleton table) -> TableSkeleton table + withProxy f = f Proxy + +tableValuesNeeded :: Beamable table => Proxy table -> Int +tableValuesNeeded (Proxy :: Proxy table) = length (allBeamValues (const ()) (tblSkeleton :: TableSkeleton table)) + +allBeamValues :: Beamable table => (forall a. Columnar' f a -> b) -> table f -> [b] +allBeamValues (f :: forall a. Columnar' f a -> b) (tbl :: table f) = + execWriter (zipBeamFieldsM combine tbl tbl) + where combine :: Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a) + combine x _ = do tell [f x] + return x + +changeBeamRep :: Beamable table => (forall a. Columnar' f a -> Columnar' g a) -> table f -> table g +changeBeamRep f tbl = runIdentity (zipBeamFieldsM (\x _ -> return (f x)) tbl tbl) + +class Retaggable f x | x -> f where + type Retag (tag :: (* -> *) -> * -> *) x :: * + + retag :: (forall a. Columnar' f a -> Columnar' (tag f) a) -> x + -> Retag tag x + +instance Beamable tbl => Retaggable f (tbl (f :: * -> *)) where + type Retag tag (tbl f) = tbl (tag f) + + retag = changeBeamRep + +instance (Retaggable f a, Retaggable f b) => Retaggable f (a, b) where + type Retag tag (a, b) = (Retag tag a, Retag tag b) + + retag transform (a, b) = (retag transform a, retag transform b) + +instance (Retaggable f a, Retaggable f b, Retaggable f c) => + Retaggable f (a, b, c) where + type Retag tag (a, b, c) = (Retag tag a, Retag tag b, Retag tag c) + + retag transform (a, b, c) = (retag transform a, retag transform b, retag transform c) + +instance (Retaggable f a, Retaggable f b, Retaggable f c, Retaggable f d) => + Retaggable f (a, b, c, d) where + type Retag tag (a, b, c, d) = + (Retag tag a, Retag tag b, Retag tag c, Retag tag d) + + retag transform (a, b, c, d) = + (retag transform a, retag transform b, retag transform c, retag transform d) + +instance ( Retaggable f a, Retaggable f b, Retaggable f c, Retaggable f d + , Retaggable f e ) => + Retaggable f (a, b, c, d, e) where + type Retag tag (a, b, c, d, e) = + (Retag tag a, Retag tag b, Retag tag c, Retag tag d, Retag tag e) + + retag transform (a, b, c, d, e) = + ( retag transform a, retag transform b, retag transform c, retag transform d + , retag transform e) + +instance ( Retaggable f' a, Retaggable f' b, Retaggable f' c, Retaggable f' d + , Retaggable f' e, Retaggable f' f ) => + Retaggable f' (a, b, c, d, e, f) where + type Retag tag (a, b, c, d, e, f) = + ( Retag tag a, Retag tag b, Retag tag c, Retag tag d + , Retag tag e, Retag tag f) + + retag transform (a, b, c, d, e, f) = + ( retag transform a, retag transform b, retag transform c, retag transform d + , retag transform e, retag transform f ) + +instance ( Retaggable f' a, Retaggable f' b, Retaggable f' c, Retaggable f' d + , Retaggable f' e, Retaggable f' f, Retaggable f' g ) => + Retaggable f' (a, b, c, d, e, f, g) where + type Retag tag (a, b, c, d, e, f, g) = + ( Retag tag a, Retag tag b, Retag tag c, Retag tag d + , Retag tag e, Retag tag f, Retag tag g ) + + retag transform (a, b, c, d, e, f, g) = + ( retag transform a, retag transform b, retag transform c, retag transform d + , retag transform e, retag transform f, retag transform g ) + +instance ( Retaggable f' a, Retaggable f' b, Retaggable f' c, Retaggable f' d + , Retaggable f' e, Retaggable f' f, Retaggable f' g, Retaggable f' h ) => + Retaggable f' (a, b, c, d, e, f, g, h) where + type Retag tag (a, b, c, d, e, f, g, h) = + ( Retag tag a, Retag tag b, Retag tag c, Retag tag d + , Retag tag e, Retag tag f, Retag tag g, Retag tag h ) + + retag transform (a, b, c, d, e, f, g, h) = + ( retag transform a, retag transform b, retag transform c, retag transform d + , retag transform e, retag transform f, retag transform g, retag transform h ) + +-- Carry a constraint instance +data WithConstraint (c :: * -> Constraint) x where + WithConstraint :: c x => x -> WithConstraint c x + +class GFieldsFulfillConstraint (c :: * -> Constraint) (exposed :: * -> *) values withconstraint where + gWithConstrainedFields :: Proxy c -> Proxy exposed -> values () -> withconstraint () +instance GFieldsFulfillConstraint c exposed values withconstraint => + GFieldsFulfillConstraint c (M1 s m exposed) (M1 s m values) (M1 s m withconstraint) where + gWithConstrainedFields c _ (M1 x) = M1 (gWithConstrainedFields c (Proxy @exposed) x) +instance GFieldsFulfillConstraint c U1 U1 U1 where + gWithConstrainedFields _ _ _ = U1 +instance (GFieldsFulfillConstraint c aExp a aC, GFieldsFulfillConstraint c bExp b bC) => + GFieldsFulfillConstraint c (aExp :*: bExp) (a :*: b) (aC :*: bC) where + gWithConstrainedFields be _ (a :*: b) = gWithConstrainedFields be (Proxy @aExp) a :*: gWithConstrainedFields be (Proxy @bExp) b +instance (c x) => GFieldsFulfillConstraint c (K1 Generic.R (Exposed x)) (K1 Generic.R x) (K1 Generic.R (WithConstraint c x)) where + gWithConstrainedFields _ _ (K1 x) = K1 (WithConstraint x) +instance FieldsFulfillConstraint c t => + GFieldsFulfillConstraint c (K1 Generic.R (t Exposed)) (K1 Generic.R (t Identity)) (K1 Generic.R (t (WithConstraint c))) where + gWithConstrainedFields _ _ (K1 x) = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t Exposed))) (from x))) +instance FieldsFulfillConstraintNullable c t => + GFieldsFulfillConstraint c (K1 Generic.R (t (Nullable Exposed))) (K1 Generic.R (t (Nullable Identity))) (K1 Generic.R (t (Nullable (WithConstraint c)))) where + gWithConstrainedFields _ _ (K1 x) = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t (Nullable Exposed)))) (from x))) + +type FieldsFulfillConstraint (c :: * -> Constraint) t = + ( Generic (t (WithConstraint c)), Generic (t Identity), Generic (t Exposed) + , GFieldsFulfillConstraint c (Rep (t Exposed)) (Rep (t Identity)) (Rep (t (WithConstraint c)))) + +type FieldsFulfillConstraintNullable (c :: * -> Constraint) t = + ( Generic (t (Nullable (WithConstraint c))), Generic (t (Nullable Identity)), Generic (t (Nullable Exposed)) + , GFieldsFulfillConstraint c (Rep (t (Nullable Exposed))) (Rep (t (Nullable Identity))) (Rep (t (Nullable (WithConstraint c))))) + +-- | Synonym for 'primaryKey' +pk :: Table t => t f -> PrimaryKey t f +pk = primaryKey + +-- | Return a 'TableSettings' for the appropriate 'table' type where each column +-- has been given its default name. See the +-- [manual](https://tathougies.github.io/beam/user-guide/models) for +-- information on the default naming convention. +defTblFieldSettings :: ( Generic (TableSettings table) + , GDefaultTableFieldSettings (Rep (TableSettings table) ())) => + TableSettings table +defTblFieldSettings = withProxy $ \proxy -> to' (gDefTblFieldSettings proxy) + where withProxy :: (Proxy (Rep (TableSettings table) ()) -> TableSettings table) -> TableSettings table + withProxy f = f Proxy + +class GZipTables f g h (exposedRep :: * -> *) fRep gRep hRep where + gZipTables :: Applicative m => Proxy exposedRep -> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> fRep () -> gRep () -> m (hRep ()) +instance ( GZipTables f g h exp1 f1 g1 h1 + , GZipTables f g h exp2 f2 g2 h2) => + GZipTables f g h (exp1 :*: exp2) (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where + + gZipTables _ combine ~(f1 :*: f2) ~(g1 :*: g2) = + (:*:) <$> gZipTables (Proxy :: Proxy exp1) combine f1 g1 + <*> gZipTables (Proxy :: Proxy exp2) combine f2 g2 +instance GZipTables f g h exp fRep gRep hRep => + GZipTables f g h (M1 x y exp) (M1 x y fRep) (M1 x y gRep) (M1 x y hRep) where + gZipTables _ combine ~(M1 f) ~(M1 g) = M1 <$> gZipTables (Proxy :: Proxy exp) combine f g +instance ( fa ~ Columnar f a + , ga ~ Columnar g a + , ha ~ Columnar h a) => + GZipTables f g h (K1 Generic.R (Exposed a)) (K1 Generic.R fa) (K1 Generic.R ga) (K1 Generic.R ha) where + gZipTables _ combine ~(K1 f) ~(K1 g) = (\(Columnar' h) -> K1 h) <$> combine (Columnar' f :: Columnar' f a) (Columnar' g :: Columnar' g a) +instance ( Generic (tbl f) + , Generic (tbl g) + , Generic (tbl h) + + , GZipTables f g h (Rep (tbl Exposed)) (Rep (tbl f)) (Rep (tbl g)) (Rep (tbl h))) => + GZipTables f g h (K1 Generic.R (tbl Exposed)) (K1 Generic.R (tbl f)) (K1 Generic.R (tbl g)) (K1 Generic.R (tbl h)) where + gZipTables _ combine ~(K1 f) ~(K1 g) = K1 . to' <$> gZipTables (Proxy :: Proxy (Rep (tbl Exposed))) combine (from' f) (from' g) + +instance GZipTables f g h U1 U1 U1 U1 where + gZipTables _ _ _ _ = pure U1 + +instance ( Generic (tbl (Nullable f)) + , Generic (tbl (Nullable g)) + , Generic (tbl (Nullable h)) + + , GZipTables f g h (Rep (tbl (Nullable Exposed))) (Rep (tbl (Nullable f))) (Rep (tbl (Nullable g))) (Rep (tbl (Nullable h)))) => + GZipTables f g h + (K1 Generic.R (tbl (Nullable Exposed))) + (K1 Generic.R (tbl (Nullable f))) + (K1 Generic.R (tbl (Nullable g))) + (K1 Generic.R (tbl (Nullable h))) where + gZipTables _ combine ~(K1 f) ~(K1 g) = K1 . to' <$> gZipTables (Proxy :: Proxy (Rep (tbl (Nullable Exposed)))) combine (from' f) (from' g) + +class GDefaultTableFieldSettings x where + gDefTblFieldSettings :: Proxy x -> x +instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (D1 f p x) where + gDefTblFieldSettings (_ :: Proxy (D1 f p x)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x)) +instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (C1 f p x) where + gDefTblFieldSettings (_ :: Proxy (C1 f p x)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x)) +instance (GDefaultTableFieldSettings (a p), GDefaultTableFieldSettings (b p)) => GDefaultTableFieldSettings ((a :*: b) p) where + gDefTblFieldSettings (_ :: Proxy ((a :*: b) p)) = gDefTblFieldSettings (Proxy :: Proxy (a p)) :*: gDefTblFieldSettings (Proxy :: Proxy (b p)) + +instance Selector f => + GDefaultTableFieldSettings (S1 f (K1 Generic.R (TableField table field)) p) where + gDefTblFieldSettings (_ :: Proxy (S1 f (K1 Generic.R (TableField table field)) p)) = M1 (K1 s) + where s = TableField name + name = unCamelCaseSel (T.pack (selName (undefined :: S1 f (K1 Generic.R (TableField table field)) ()))) + +instance ( TypeError ('Text "All Beamable types must be record types, so appropriate names can be given to columns")) => GDefaultTableFieldSettings (K1 r f p) where + gDefTblFieldSettings _ = error "impossible" + +-- | Type-level representation of the naming strategy to use for defaulting +-- Needed because primary keys should be named after the default naming of +-- their corresponding table, not the names of the record selectors in the +-- primary key (if any). +data SubTableStrategy + = PrimaryKeyStrategy + | BeamableStrategy + | RecursiveKeyStrategy + +type family ChooseSubTableStrategy (tbl :: (* -> *) -> *) (sub :: (* -> *) -> *) :: SubTableStrategy where + ChooseSubTableStrategy tbl (PrimaryKey tbl) = 'RecursiveKeyStrategy + ChooseSubTableStrategy tbl (PrimaryKey rel) = 'PrimaryKeyStrategy + ChooseSubTableStrategy tbl sub = 'BeamableStrategy + +-- TODO is this necessary +type family CheckNullable (f :: * -> *) :: Constraint where + CheckNullable (Nullable f) = () + CheckNullable f = TypeError ('Text "Recursive reference without Nullable constraint forms an infinite loop." ':$$: + 'Text "Hint: Only embed nullable 'PrimaryKey tbl' within the definition of 'tbl'." ':$$: + 'Text " For example, replace 'PrimaryKey tbl f' with 'PrimaryKey tbl (Nullable f)'") + + +class SubTableStrategyImpl (strategy :: SubTableStrategy) (f :: * -> *) sub where + namedSubTable :: Proxy strategy -> sub f + +-- The defaulting with @TableField rel@ is necessary to avoid infinite loops +instance ( Table rel, Generic (rel (TableField rel)) + , TagReducesTo f (TableField tbl) + , GDefaultTableFieldSettings (Rep (rel (TableField rel)) ()) ) => + SubTableStrategyImpl 'PrimaryKeyStrategy f (PrimaryKey rel) where + namedSubTable _ = primaryKey tbl + where tbl = changeBeamRep (\(Columnar' (TableField nm) :: Columnar' (TableField rel) a) -> + let c = Columnar' (TableField nm) :: Columnar' (TableField tbl) a + in runIdentity (reduceTag (\_ -> pure c) undefined)) $ + to' $ gDefTblFieldSettings (Proxy @(Rep (rel (TableField rel)) ())) +instance ( Generic (sub f) + , GDefaultTableFieldSettings (Rep (sub f) ()) ) => + SubTableStrategyImpl 'BeamableStrategy f sub where + namedSubTable _ = to' $ gDefTblFieldSettings (Proxy @(Rep (sub f) ())) +instance ( CheckNullable f, SubTableStrategyImpl 'PrimaryKeyStrategy f (PrimaryKey rel) ) => + SubTableStrategyImpl 'RecursiveKeyStrategy f (PrimaryKey rel) where + namedSubTable _ = namedSubTable (Proxy @'PrimaryKeyStrategy) + +instance {-# OVERLAPPING #-} + ( Selector f' + , ChooseSubTableStrategy tbl sub ~ strategy + , SubTableStrategyImpl strategy f sub + , TagReducesTo f (TableField tbl) + , Beamable sub ) => + GDefaultTableFieldSettings (S1 f' (K1 Generic.R (sub f)) p) where + gDefTblFieldSettings _ = M1 . K1 $ settings' + where tbl :: sub f + tbl = namedSubTable (Proxy @strategy) + + relName = unCamelCaseSel (T.pack (selName (undefined :: S1 f' (K1 Generic.R (sub f)) p))) + + settings' :: sub f + settings' = changeBeamRep (reduceTag %~ \(Columnar' (TableField nm)) -> Columnar' (TableField (relName <> "__" <> nm))) tbl + +type family ReplaceBaseTag tag f where + ReplaceBaseTag tag (Nullable f) = Nullable (ReplaceBaseTag tag f) + ReplaceBaseTag tag x = tag + +-- | Class to automatically unwrap nested Nullables +class TagReducesTo f f' | f -> f' where + reduceTag :: Functor m => + (Columnar' f' a' -> m (Columnar' f' a')) + -> Columnar' f a -> m (Columnar' f a) +instance TagReducesTo (TableField tbl) (TableField tbl) where + reduceTag f ~(Columnar' (TableField nm)) = + (\(Columnar' (TableField nm')) -> Columnar' (TableField nm')) <$> + f (Columnar' (TableField nm)) +instance TagReducesTo f f' => TagReducesTo (Nullable f) f' where + reduceTag fn ~(Columnar' x :: Columnar' (Nullable f) a) = + (\(Columnar' x' :: Columnar' f (Maybe a')) -> Columnar' x') <$> + reduceTag fn (Columnar' x :: Columnar' f (Maybe a)) + +class GTableSkeleton x where + gTblSkeleton :: Proxy x -> x () +instance GTableSkeleton p => GTableSkeleton (M1 t f p) where + gTblSkeleton (_ :: Proxy (M1 t f p)) = M1 (gTblSkeleton (Proxy :: Proxy p)) +instance GTableSkeleton U1 where + gTblSkeleton _ = U1 +instance (GTableSkeleton a, GTableSkeleton b) => + GTableSkeleton (a :*: b) where + gTblSkeleton _ = gTblSkeleton (Proxy :: Proxy a) :*: gTblSkeleton (Proxy :: Proxy b) +instance GTableSkeleton (K1 Generic.R (Ignored field)) where + gTblSkeleton _ = K1 Ignored +instance ( Generic (tbl Ignored) + , GTableSkeleton (Rep (tbl Ignored)) ) => + GTableSkeleton (K1 Generic.R (tbl Ignored)) where + gTblSkeleton _ = K1 (to' (gTblSkeleton (Proxy :: Proxy (Rep (tbl Ignored))))) +instance ( Generic (tbl (Nullable Ignored)) + , GTableSkeleton (Rep (tbl (Nullable Ignored))) ) => + GTableSkeleton (K1 Generic.R (tbl (Nullable Ignored))) where + gTblSkeleton _ = K1 (to' (gTblSkeleton (Proxy :: Proxy (Rep (tbl (Nullable Ignored)))))) + +-- * Internal functions + +unCamelCase :: T.Text -> [T.Text] +unCamelCase "" = [] +unCamelCase s + | (comp, next) <- T.break isUpper s, not (T.null comp) = + let next' = maybe mempty (uncurry T.cons . first toLower) (T.uncons next) + in T.toLower comp:unCamelCase next' + | otherwise = + let (comp, next) = T.span isUpper s + next' = maybe mempty (uncurry T.cons . first toLower) (T.uncons next) + in T.toLower comp:unCamelCase next' + +-- | Camel casing magic for standard beam record field names. +-- +-- All leading underscores are ignored. If what remains is camel-cased beam +-- will convert it to use underscores instead. If there are any underscores in +-- what remains, then the entire name (minus the leading underscares). If the +-- field name is solely underscores, beam will assume you know what you're +-- doing and include the full original name as the field name +unCamelCaseSel :: Text -> Text +unCamelCaseSel original = + let symbolLeft = T.dropWhile (=='_') original + in if T.null symbolLeft + then original + else if T.any (=='_') symbolLeft + then symbolLeft + else case unCamelCase symbolLeft of + [] -> symbolLeft + [xs] -> xs + _:xs -> T.intercalate "_" xs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,8 @@ +The MIT License (MIT) +Copyright (c) 2015, 2016 Travis Athougies + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/beam-core.cabal b/beam-core.cabal new file mode 100644 --- /dev/null +++ b/beam-core.cabal @@ -0,0 +1,97 @@ +-- Initial beam.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: beam-core +version: 0.6.0.0 +synopsis: Type-safe, feature-complete SQL query and manipulation interface for Haskell +description: Beam is a Haskell library for type-safe querying and manipulation of SQL databases. + Beam is modular and supports various backends. In order to use beam, you will need to use + @beam-core@ along with a specific backend (such as @beam-postgres@ or @beam-sqlite@) as + well as the corresponding backend. + + For more information, see the user manual and tutorial on + . +homepage: http://travis.athougies.net/projects/beam.html +license: MIT +license-file: LICENSE +author: Travis Athougies +maintainer: travis@athougies.net +category: Database +build-type: Simple +cabal-version: >=1.18 +bug-reports: https://github.com/tathougies/beam/issues +extra-doc-files: ChangeLog.md + +library + exposed-modules: Database.Beam Database.Beam.Backend + Database.Beam.Query + Database.Beam.Query.Internal + Database.Beam.Query.CustomSQL + Database.Beam.Query.SQL92 + Database.Beam.Query.Types + + Database.Beam.Schema + Database.Beam.Schema.Tables + + Database.Beam.Backend.Types + Database.Beam.Backend.URI + Database.Beam.Backend.SQL + Database.Beam.Backend.SQL.Types + Database.Beam.Backend.SQL.BeamExtensions + Database.Beam.Backend.SQL.SQL92 + Database.Beam.Backend.SQL.SQL99 + Database.Beam.Backend.SQL.SQL2003 + Database.Beam.Backend.SQL.Builder + Database.Beam.Backend.SQL.AST + other-modules: Database.Beam.Query.Aggregate + Database.Beam.Query.Combinators + Database.Beam.Query.Extensions + Database.Beam.Query.Operator + Database.Beam.Query.Ord + Database.Beam.Query.Relationships + + Database.Beam.Schema.Lenses + build-depends: base >=4.7 && <5.0, + aeson >=0.11 && <1.3, + text >=1.0 && <1.3, + bytestring >=0.10 && <0.11, + mtl >=2.1 && <2.3, + microlens >=0.4 && <0.5, + ghc-prim >=0.5 && <0.6, + free >=4.12 && <4.13, + dlist >=0.7.1.2 && <0.9, + time >=1.6 && <1.10, + hashable >=1.1 && <1.3, + network-uri >=2.6 && <2.7, + containers >=0.5 && <0.6, + vector-sized >=0.5 && <0.7 + Default-language: Haskell2010 + default-extensions: ScopedTypeVariables, OverloadedStrings, GADTs, RecursiveDo, FlexibleInstances, FlexibleContexts, TypeFamilies, + GeneralizedNewtypeDeriving, RankNTypes, TupleSections, ConstraintKinds, StandaloneDeriving, TypeOperators, + DefaultSignatures, KindSignatures, MultiParamTypeClasses, DeriveGeneric, DeriveFunctor, DeriveDataTypeable, + TypeApplications, FunctionalDependencies, DataKinds, BangPatterns, InstanceSigs + ghc-options: -Wall + if flag(werror) + ghc-options: -Werror + +flag werror + description: Enable -Werror during development + default: False + manual: True + +test-suite beam-core-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Database.Beam.Test.Schema Database.Beam.Test.SQL + build-depends: base, beam-core, text, bytestring, time, tasty, tasty-hunit + default-language: Haskell2010 + default-extensions: OverloadedStrings, FlexibleInstances, FlexibleContexts, GADTs, TypeFamilies, + DeriveGeneric, DefaultSignatures, RankNTypes, StandaloneDeriving, KindSignatures, + TypeApplications, ScopedTypeVariables, MultiParamTypeClasses + +source-repository head + type: git + location: https://github.com/tathougies/beam.git + subdir: beam-core + diff --git a/test/Database/Beam/Test/SQL.hs b/test/Database/Beam/Test/SQL.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Test/SQL.hs @@ -0,0 +1,1128 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module Database.Beam.Test.SQL + ( tests ) where + +import Database.Beam.Test.Schema hiding (tests) + +import Database.Beam +import Database.Beam.Backend.SQL.AST + +import Data.Time.Clock +import Data.Text (Text) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "SQL generation tests" + [ simpleSelect + , simpleWhere + , simpleJoin + , selfJoin + , leftJoin + , leftJoinSingle + , aggregates + , orderBy + + , joinHaving + + , maybeFieldTypes + + , tableEquality + , related + , selectCombinators + , limitOffset + + , existsTest + + , updateCurrent + , updateNullable + + , noEmptyIns ] + +-- | Ensure simple select selects the right fields + +simpleSelect :: TestTree +simpleSelect = + testCase "All fields are present in a simple all_ query" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , .. } <- pure (select (all_ (_employees employeeDbSettings))) + + selectGrouping @?= Nothing + selectOrdering @?= [] + selectWhere @?= Nothing + selectLimit @?= Nothing + selectOffset @?= Nothing + selectHaving @?= Nothing + selectQuantifier @?= Nothing + + Just (FromTable (TableNamed "employees") (Just tblName)) <- pure selectFrom + + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField tblName "first_name"), Just "res0") + , (ExpressionFieldName (QualifiedField tblName "last_name"), Just "res1") + , (ExpressionFieldName (QualifiedField tblName "phone_number"), Just "res2") + , (ExpressionFieldName (QualifiedField tblName "age"), Just "res3") + , (ExpressionFieldName (QualifiedField tblName "salary"), Just "res4") + , (ExpressionFieldName (QualifiedField tblName "hire_date"), Just "res5") + , (ExpressionFieldName (QualifiedField tblName "leave_date"), Just "res6") + , (ExpressionFieldName (QualifiedField tblName "created"), Just "res7") ] + +-- | Simple select with WHERE clause + +simpleWhere :: TestTree +simpleWhere = + testCase "guard_ clauses are successfully translated into WHERE statements" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , .. } <- pure $ select $ + do e <- all_ (_employees employeeDbSettings) + guard_ (_employeeSalary e >. 120202 &&. + _employeeAge e <. 30 &&. + _employeeFirstName e ==. _employeeLastName e) + pure e + selectGrouping @?= Nothing + selectOrdering @?= [] + selectLimit @?= Nothing + selectOffset @?= Nothing + selectHaving @?= Nothing + selectQuantifier @?= Nothing + + Just (FromTable (TableNamed "employees") (Just employees)) <- pure selectFrom + + let salaryCond = ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField employees "salary")) (ExpressionValue (Value (120202 :: Double))) + ageCond = ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField employees "age")) (ExpressionValue (Value (30 :: Int))) + nameCond = ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField employees "first_name")) (ExpressionFieldName (QualifiedField employees "last_name")) + + selectWhere @?= Just (ExpressionBinOp "AND" salaryCond (ExpressionBinOp "AND" ageCond nameCond)) + +-- | Ensure that multiple tables are correctly joined + +simpleJoin :: TestTree +simpleJoin = + testCase "Introducing multiple tables results in an inner join" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , .. } <- pure $ select $ + do e <- all_ (_employees employeeDbSettings) + r <- all_ (_roles employeeDbSettings) + pure (_employeePhoneNumber e, _roleName r) + + selectGrouping @?= Nothing + selectOrdering @?= [] + selectWhere @?= Nothing + selectLimit @?= Nothing + selectOffset @?= Nothing + selectHaving @?= Nothing + selectQuantifier @?= Nothing + + Just (InnerJoin (FromTable (TableNamed "employees") (Just employees)) + (FromTable (TableNamed "roles") (Just roles)) + Nothing) <- pure selectFrom + + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField employees "phone_number"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField roles "name"), Just "res1") ] + +-- | Ensure that multiple joins on the same table are correctly referenced + +selfJoin :: TestTree +selfJoin = + testCase "Table names are unique and properly used in self joins" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , .. } <- pure $ select $ + do e1 <- all_ (_employees employeeDbSettings) + e2 <- relatedBy_ (_employees employeeDbSettings) + (\e2 -> _employeeFirstName e1 ==. _employeeLastName e2) + e3 <- relatedBy_ (_employees employeeDbSettings) + (\e3 -> _employeePhoneNumber e1 ==. _employeeLastName e3 &&. _employeePhoneNumber e3 ==. _employeeFirstName e2) + pure (_employeeFirstName e1, _employeeLastName e2, _employeePhoneNumber e3) + + selectGrouping @?= Nothing + selectOrdering @?= [] + selectWhere @?= Nothing + selectLimit @?= Nothing + selectOffset @?= Nothing + selectHaving @?= Nothing + selectQuantifier @?= Nothing + + Just (InnerJoin (InnerJoin (FromTable (TableNamed "employees") (Just e1)) + (FromTable (TableNamed "employees") (Just e2)) + (Just joinCondition12)) + (FromTable (TableNamed "employees") (Just e3)) + (Just joinCondition123)) <- pure selectFrom + + assertBool "Table names are not unique" (e1 /= e2 && e1 /= e3 && e2 /= e3) + joinCondition12 @?= ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField e1 "first_name")) + (ExpressionFieldName (QualifiedField e2 "last_name")) + joinCondition123 @?= ExpressionBinOp "AND" (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField e1 "phone_number")) + (ExpressionFieldName (QualifiedField e3 "last_name"))) + (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField e3 "phone_number")) (ExpressionFieldName (QualifiedField e2 "first_name"))) + +-- | Ensure that left joins are properly generated + +leftJoin :: TestTree +leftJoin = + testCase "leftJoin_ generates the right join" $ + do SqlSelect Select { selectTable = SelectTable { selectWhere = Nothing, selectFrom } } <- + pure $ select $ + do r <- all_ (_roles employeeDbSettings) + e <- leftJoin_ (all_ (_employees employeeDbSettings)) (\e -> primaryKey e ==. _roleForEmployee r) + pure (e, r) + + Just (LeftJoin (FromTable (TableNamed "roles") (Just roles)) + (FromTable (TableNamed "employees") (Just employees)) + (Just cond)) <- pure selectFrom + + let andE = ExpressionBinOp "AND" + eqE = ExpressionCompOp "==" Nothing + + firstNameCond = eqE (ExpressionFieldName (QualifiedField employees "first_name")) + (ExpressionFieldName (QualifiedField roles "for_employee__first_name")) + lastNameCond = eqE (ExpressionFieldName (QualifiedField employees "last_name")) + (ExpressionFieldName (QualifiedField roles "for_employee__last_name")) + createdCond = eqE (ExpressionFieldName (QualifiedField employees "created")) + (ExpressionFieldName (QualifiedField roles "for_employee__created")) + + cond @?= andE (andE firstNameCond lastNameCond) createdCond + +-- | Ensure that left joins which return a single column are properly typed. The +-- point of this test is to test for compile-time errors. The same query +-- should be generated as above. + +leftJoinSingle :: TestTree +leftJoinSingle = + testCase "leftJoin_ generates the right join (single return value)" $ + do SqlSelect Select { selectTable = SelectTable { selectWhere = Nothing, selectFrom } } <- + pure $ select $ + do r <- all_ (_roles employeeDbSettings) + e <- leftJoin_ (do e <- all_ (_employees employeeDbSettings) + pure (primaryKey e, _employeeAge e)) + (\(key, _) -> key ==. _roleForEmployee r) + pure (e, r) + + Just (LeftJoin (FromTable (TableNamed "roles") (Just roles)) + (FromTable (TableNamed "employees") (Just employees)) + (Just cond)) <- pure selectFrom + + let andE = ExpressionBinOp "AND" + eqE = ExpressionCompOp "==" Nothing + + firstNameCond = eqE (ExpressionFieldName (QualifiedField employees "first_name")) + (ExpressionFieldName (QualifiedField roles "for_employee__first_name")) + lastNameCond = eqE (ExpressionFieldName (QualifiedField employees "last_name")) + (ExpressionFieldName (QualifiedField roles "for_employee__last_name")) + createdCond = eqE (ExpressionFieldName (QualifiedField employees "created")) + (ExpressionFieldName (QualifiedField roles "for_employee__created")) + + cond @?= andE (andE firstNameCond lastNameCond) createdCond + +-- | Ensure that aggregations cause the correct GROUP BY clause to be generated + +aggregates :: TestTree +aggregates = + testGroup "Aggregate support" + [ basicAggregate + , basicHaving + , aggregateInJoin + , aggregateInJoinReverse + , aggregateOverTopLevel + , filterAfterTopLevelAggregate + , joinTopLevelAggregate + , joinTopLevelAggregate2 ] + where + basicAggregate = + testCase "Basic aggregate support" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ + do e <- all_ (_employees employeeDbSettings) + pure e + + Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0 "age"), Just "res0" ) + , ( ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name")) ], Just "res1") ] + selectWhere @?= Nothing + selectGrouping @?= Just (Grouping [ ExpressionFieldName (QualifiedField t0 "age") ]) + selectHaving @?= Nothing + + basicHaving = + testCase "Basic HAVING support" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do (age, maxNameLength) <- aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ + all_ (_employees employeeDbSettings) + guard_ (maxNameLength >. 42) + pure (age, maxNameLength) + + Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0 "age"), Just "res0" ) + , ( ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name")) ], Just "res1") ] + selectWhere @?= Nothing + selectGrouping @?= Just (Grouping [ ExpressionFieldName (QualifiedField t0 "age") ]) + selectHaving @?= Just (ExpressionCompOp ">" Nothing (ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name")) ]) + (ExpressionValue (Value (42 :: Int)))) + + aggregateInJoin = + testCase "Aggregate in JOIN" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do (age, maxFirstNameLength) <- aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ + all_ (_employees employeeDbSettings) + role <- all_ (_roles employeeDbSettings) + pure (age, maxFirstNameLength, _roleName role) + + Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just t0)) + (FromTable (TableNamed "roles") (Just t1)) + Nothing) <- pure selectFrom + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "res0"), Just "res0") + , (ExpressionFieldName (QualifiedField t0 "res1"), Just "res1") + , (ExpressionFieldName (QualifiedField t1 "name"), Just "res2") ] + selectWhere @?= Nothing + selectGrouping @?= Nothing + selectHaving @?= Nothing + + Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- pure subselect + Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "age"), Just "res0") + , (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))], Just "res1") ] + selectWhere @?= Nothing + selectGrouping @?= Just (Grouping [ExpressionFieldName (QualifiedField t0 "age")]) + selectHaving @?= Nothing + + aggregateInJoinReverse = + testCase "Aggregate in JOIN (reverse order)" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do role <- all_ (_roles employeeDbSettings) + (age, maxFirstNameLength) <- aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ + all_ (_employees employeeDbSettings) + pure (age, maxFirstNameLength, _roleName role) + + Just (InnerJoin (FromTable (TableNamed "roles") (Just t0)) + (FromTable (TableFromSubSelect subselect) (Just t1)) + Nothing) <- pure selectFrom + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t1 "res0"), Just "res0") + , (ExpressionFieldName (QualifiedField t1 "res1"), Just "res1") + , (ExpressionFieldName (QualifiedField t0 "name"), Just "res2") ] + selectWhere @?= Nothing + selectGrouping @?= Nothing + selectHaving @?= Nothing + + Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- pure subselect + Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "age"), Just "res0") + , (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))], Just "res1") ] + selectWhere @?= Nothing + selectGrouping @?= Just (Grouping [ExpressionFieldName (QualifiedField t0 "age")]) + selectHaving @?= Nothing + + aggregateOverTopLevel = + testCase "Aggregate over top-level" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ + limit_ 10 (all_ (_employees employeeDbSettings)) + + Just (FromTable (TableFromSubSelect subselect) (Just t0)) <- pure selectFrom + + selectProjection @?= ProjExprs [(ExpressionFieldName (QualifiedField t0 "res3"),Just "res0"),(ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0"))], Just "res1")] + selectWhere @?= Nothing + selectGrouping @?= Just (Grouping [ExpressionFieldName (QualifiedField t0 "res3")]) + selectHaving @?= Nothing + + selectLimit subselect @?= Just 10 + selectOffset subselect @?= Nothing + selectOrdering subselect @?= [] + + SelectTable {selectFrom = Just (FromTable (TableNamed "employees") (Just t0')), .. } <- + pure $ selectTable subselect + + selectWhere @?= Nothing + selectGrouping @?= Nothing + selectHaving @?= Nothing + selectProjection @?= + ProjExprs [ (ExpressionFieldName (QualifiedField t0' "first_name"), Just "res0") + , (ExpressionFieldName (QualifiedField t0' "last_name"), Just "res1") + , (ExpressionFieldName (QualifiedField t0' "phone_number"), Just "res2") + , (ExpressionFieldName (QualifiedField t0' "age"), Just "res3") + , (ExpressionFieldName (QualifiedField t0' "salary"), Just "res4") + , (ExpressionFieldName (QualifiedField t0' "hire_date"), Just "res5") + , (ExpressionFieldName (QualifiedField t0' "leave_date"), Just "res6") + , (ExpressionFieldName (QualifiedField t0' "created"), Just "res7") ] + +-- assertFailure ("Select " ++ show s) + + filterAfterTopLevelAggregate = + testCase "Filter after top-level aggregate" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + filter_ (\(_, l) -> l <. 10 ||. l >. 20) $ + aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ + limit_ 10 (all_ (_employees employeeDbSettings)) + Just (FromTable (TableFromSubSelect subselect) (Just t0)) <- pure selectFrom + + selectProjection @?= ProjExprs [(ExpressionFieldName (QualifiedField t0 "res3"),Just "res0"),(ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0"))], Just "res1")] + selectWhere @?= Nothing + selectGrouping @?= Just (Grouping [ExpressionFieldName (QualifiedField t0 "res3")]) + selectHaving @?= Just (ExpressionBinOp "OR" (ExpressionCompOp "<" Nothing + (ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0")) ]) + (ExpressionValue (Value (10 :: Int)))) + (ExpressionCompOp ">" Nothing + (ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0")) ]) + (ExpressionValue (Value (20 :: Int))))) + + selectLimit subselect @?= Just 10 + selectOffset subselect @?= Nothing + selectOrdering subselect @?= [] + + SelectTable {selectFrom = Just (FromTable (TableNamed "employees") (Just t0')), .. } <- + pure $ selectTable subselect + + selectWhere @?= Nothing + selectGrouping @?= Nothing + selectHaving @?= Nothing + selectProjection @?= + ProjExprs [ (ExpressionFieldName (QualifiedField t0' "first_name"), Just "res0") + , (ExpressionFieldName (QualifiedField t0' "last_name"), Just "res1") + , (ExpressionFieldName (QualifiedField t0' "phone_number"), Just "res2") + , (ExpressionFieldName (QualifiedField t0' "age"), Just "res3") + , (ExpressionFieldName (QualifiedField t0' "salary"), Just "res4") + , (ExpressionFieldName (QualifiedField t0' "hire_date"), Just "res5") + , (ExpressionFieldName (QualifiedField t0' "leave_date"), Just "res6") + , (ExpressionFieldName (QualifiedField t0' "created"), Just "res7") ] + + joinTopLevelAggregate = + testCase "Join against top-level aggregate" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do (lastName, firstNameLength) <- + filter_ (\(_, charLength) -> charLength >. 10) $ + aggregate_ (\e -> (group_ (_employeeLastName e), max_ (charLength_ (_employeeFirstName e)))) $ + limit_ 10 (all_ (_employees employeeDbSettings)) + role <- relatedBy_ (_roles employeeDbSettings) (\r -> _roleName r ==. lastName) + pure (firstNameLength, role, lastName) + + Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just t0)) + (FromTable (TableNamed "roles") (Just t1)) + (Just joinCond) ) <- + pure selectFrom + + joinCond @?= ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField t1 "name")) (ExpressionFieldName (QualifiedField t0 "res0")) + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0 "res1"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField t1 "for_employee__first_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField t1 "for_employee__last_name"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField t1 "for_employee__created"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField t1 "name"), Just "res4" ) + , ( ExpressionFieldName (QualifiedField t1 "started"), Just "res5" ) + , ( ExpressionFieldName (QualifiedField t0 "res0"), Just "res6" ) ] + selectWhere @?= Nothing + selectHaving @?= Nothing + selectGrouping @?= Nothing + + Select { selectTable = SelectTable { .. }, selectLimit = Nothing + , selectOffset = Nothing, selectOrdering = [] } <- + pure subselect + Just (FromTable (TableFromSubSelect employeesSelect) (Just t0')) <- pure selectFrom + selectWhere @?= Nothing + selectHaving @?= Just (ExpressionCompOp ">" Nothing (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0' "res0"))]) + (ExpressionValue (Value (10 :: Int)))) + selectGrouping @?= Just (Grouping [ (ExpressionFieldName (QualifiedField t0' "res1")) ]) + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0' "res1"), Just "res0" ) + , ( ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0' "res0"))], Just "res1" ) ] + + Select { selectTable = SelectTable { .. }, selectLimit = Just 10 + , selectOffset = Nothing, selectOrdering = [] } <- + pure employeesSelect + Just (FromTable (TableNamed "employees") (Just t0'')) <- pure selectFrom + + selectWhere @?= Nothing + selectHaving @?= Nothing + selectGrouping @?= Nothing + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0'' "first_name"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField t0'' "last_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField t0'' "phone_number"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField t0'' "age"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField t0'' "salary"), Just "res4" ) + , ( ExpressionFieldName (QualifiedField t0'' "hire_date"), Just "res5" ) + , ( ExpressionFieldName (QualifiedField t0'' "leave_date"), Just "res6" ) + , ( ExpressionFieldName (QualifiedField t0'' "created"), Just "res7" ) ] + + joinTopLevelAggregate2 = + testCase "Join against top-level aggregate (places reversed)" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do role <- all_ (_roles employeeDbSettings) + (lastName, firstNameLength) <- + filter_ (\(_, charLength) -> charLength >. 10) $ + aggregate_ (\e -> (group_ (_employeeLastName e), max_ (charLength_ (_employeeFirstName e)))) $ + limit_ 10 (all_ (_employees employeeDbSettings)) + guard_ (_roleName role ==. lastName) + pure (firstNameLength, role, lastName) + + Just (InnerJoin (FromTable (TableNamed "roles") (Just t0)) + (FromTable (TableFromSubSelect subselect) (Just t1)) + Nothing) <- + pure selectFrom + selectWhere @?= Just (ExpressionBinOp "AND" + (ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField t1 "res1")) (ExpressionValue (Value (10 :: Int)))) + (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField t0 "name")) (ExpressionFieldName (QualifiedField t1 "res0")))) + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t1 "res1"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField t0 "for_employee__first_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField t0 "for_employee__last_name"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField t0 "for_employee__created"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField t0 "name"), Just "res4" ) + , ( ExpressionFieldName (QualifiedField t0 "started"), Just "res5" ) + , ( ExpressionFieldName (QualifiedField t1 "res0"), Just "res6" ) ] + selectHaving @?= Nothing + selectGrouping @?= Nothing + + Select { selectTable = SelectTable { .. }, selectLimit = Nothing + , selectOffset = Nothing, selectOrdering = [] } <- + pure subselect + Just (FromTable (TableFromSubSelect employeesSelect) (Just t0')) <- pure selectFrom + selectWhere @?= Nothing + selectHaving @?= Nothing + selectGrouping @?= Just (Grouping [ (ExpressionFieldName (QualifiedField t0' "res1")) ]) + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0' "res1"), Just "res0" ) + , ( ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0' "res0"))], Just "res1" ) ] + + Select { selectTable = SelectTable { .. }, selectLimit = Just 10 + , selectOffset = Nothing, selectOrdering = [] } <- + pure employeesSelect + Just (FromTable (TableNamed "employees") (Just t0'')) <- pure selectFrom + + selectWhere @?= Nothing + selectHaving @?= Nothing + selectGrouping @?= Nothing + selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0'' "first_name"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField t0'' "last_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField t0'' "phone_number"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField t0'' "age"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField t0'' "salary"), Just "res4" ) + , ( ExpressionFieldName (QualifiedField t0'' "hire_date"), Just "res5" ) + , ( ExpressionFieldName (QualifiedField t0'' "leave_date"), Just "res6" ) + , ( ExpressionFieldName (QualifiedField t0'' "created"), Just "res7" ) ] + +-- | ORDER BY + +orderBy :: TestTree +orderBy = + testGroup "ORDER BY tests" + [ simpleOrdering + , orderCombination + , orderLimitsOffsets + , orderJoin + , orderJoinReversed ] + where + simpleOrdering = + testCase "Simple Ordering" $ + do SqlSelect Select { selectTable = select + , selectLimit = Just 100, selectOffset = Just 5 + , selectOrdering = ordering } <- + pure $ select $ + limit_ 100 $ offset_ 5 $ + orderBy_ (asc_ . _roleStarted) $ + all_ (_roles employeeDbSettings) + select @?= SelectTable { selectProjection = + ProjExprs [ ( ExpressionFieldName (QualifiedField "t0" "for_employee__first_name"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "for_employee__last_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "for_employee__created"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t0" "name"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField "t0" "started"), Just "res4" ) ] + , selectFrom = Just (FromTable (TableNamed "roles") (Just "t0")) + , selectWhere = Nothing + , selectGrouping = Nothing + , selectHaving = Nothing + , selectQuantifier = Nothing } + ordering @?= [ OrderingAsc (ExpressionFieldName (QualifiedField "t0" "started")) ] + orderCombination = + testCase "Order combined query" $ + do SqlSelect Select { selectTable = select + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = ordering } <- + pure $ select $ + orderBy_ (asc_ . _roleStarted) $ + (all_ (_roles employeeDbSettings) `unionAll_` + all_ (_roles employeeDbSettings)) + + let expSelect = + SelectTable { selectProjection = + ProjExprs [ ( ExpressionFieldName (QualifiedField "t0" "for_employee__first_name"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "for_employee__last_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "for_employee__created"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t0" "name"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField "t0" "started"), Just "res4" ) ] + , selectFrom = Just (FromTable (TableNamed "roles") (Just "t0")) + , selectWhere = Nothing + , selectGrouping = Nothing + , selectHaving = Nothing + , selectQuantifier = Nothing } + select @?= UnionTables True expSelect expSelect + ordering @?= [ OrderingAsc (ExpressionFieldName (UnqualifiedField "res4")) ] + + orderLimitsOffsets = + testCase "Order after LIMIT/OFFSET" $ + do SqlSelect Select { selectTable = s + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = ordering } <- + pure $ select $ + orderBy_ (asc_ . _roleStarted) $ + limit_ 100 $ offset_ 5 $ + all_ (_roles employeeDbSettings) + + let rolesSelect = + SelectTable { selectProjection = + ProjExprs [ ( ExpressionFieldName (QualifiedField "t0" "for_employee__first_name"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "for_employee__last_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "for_employee__created"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t0" "name"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField "t0" "started"), Just "res4" ) ] + , selectFrom = Just (FromTable (TableNamed "roles") (Just "t0")) + , selectWhere = Nothing + , selectGrouping = Nothing + , selectHaving = Nothing + , selectQuantifier = Nothing } + s @?= SelectTable { selectProjection = + ProjExprs [ ( ExpressionFieldName (QualifiedField "t0" "res0"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "res1"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "res2"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t0" "res3"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField "t0" "res4"), Just "res4" ) ] + , selectFrom = Just (FromTable (TableFromSubSelect (Select { selectTable = rolesSelect, selectLimit = Just 100 + , selectOffset = Just 5, selectOrdering = [] })) (Just "t0")) + , selectWhere = Nothing + , selectGrouping = Nothing + , selectHaving = Nothing + , selectQuantifier = Nothing } + ordering @?= [ OrderingAsc (ExpressionFieldName (QualifiedField "t0" "res4")) ] + + orderJoin = + testCase "Order join" $ + do SqlSelect Select { selectTable = select + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do oldestEmployees <- limit_ 10 $ orderBy_ ((,) <$> (asc_ <$> _employeeAge) <*> (desc_ <$> (charLength_ <$> _employeeFirstName))) $ + all_ (_employees employeeDbSettings) + role <- relatedBy_ (_roles employeeDbSettings) (\r -> _roleForEmployee r ==. primaryKey oldestEmployees) + pure (_employeeFirstName oldestEmployees, _employeeLastName oldestEmployees, _employeeAge oldestEmployees, _roleName role) + + selectProjection select @?= ProjExprs [ ( ExpressionFieldName (QualifiedField "t0" "res0"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "res1"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "res3"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t1" "name"), Just "res3" ) ] + let subselectExp = Select { selectTable = subselectTableExp, selectLimit = Just 10, selectOffset = Nothing + , selectOrdering = [ OrderingAsc (ExpressionFieldName (QualifiedField "t0" "age")) + , OrderingDesc (ExpressionCharLength (ExpressionFieldName (QualifiedField "t0" "first_name"))) ] } + subselectTableExp = SelectTable { selectProjection = + ProjExprs [ ( ExpressionFieldName (QualifiedField "t0" "first_name"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "last_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "phone_number"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t0" "age"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField "t0" "salary"), Just "res4" ) + , ( ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5" ) + , ( ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6" ) + , ( ExpressionFieldName (QualifiedField "t0" "created"), Just "res7" ) ] + , selectFrom = Just (FromTable (TableNamed "employees") (Just "t0")) + , selectWhere = Nothing + , selectGrouping = Nothing + , selectHaving = Nothing + , selectQuantifier = Nothing } + joinCondExp = ExpressionBinOp "AND" (ExpressionBinOp "AND" (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "t1" "for_employee__first_name")) + (ExpressionFieldName (QualifiedField "t0" "res0"))) + (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "t1" "for_employee__last_name")) + (ExpressionFieldName (QualifiedField "t0" "res1")))) + (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "t1" "for_employee__created")) + (ExpressionFieldName (QualifiedField "t0" "res7"))) + selectFrom select @?= Just (InnerJoin (FromTable (TableFromSubSelect subselectExp) (Just "t0")) (FromTable (TableNamed "roles") (Just "t1")) + (Just joinCondExp)) + selectWhere select @?= Nothing + selectGrouping select @?= Nothing + selectHaving select @?= Nothing + + orderJoinReversed = + testCase "Order join (reversed)" $ + do SqlSelect Select { selectTable = s + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do role <- all_ (_roles employeeDbSettings) + oldestEmployees <- limit_ 10 $ orderBy_ ((,) <$> (asc_ <$> _employeeAge) <*> (desc_ <$> (charLength_ <$> _employeeFirstName))) $ + all_ (_employees employeeDbSettings) + guard_ (_roleForEmployee role ==. primaryKey oldestEmployees) + pure (_employeeFirstName oldestEmployees, _employeeLastName oldestEmployees, _employeeAge oldestEmployees, _roleName role) + + selectProjection s @?= ProjExprs [ ( ExpressionFieldName (QualifiedField "t1" "res0"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t1" "res1"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t1" "res3"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t0" "name"), Just "res3" ) ] + selectWhere s @?= Just (ExpressionBinOp "AND" + (ExpressionBinOp "AND" + (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "t0" "for_employee__first_name")) + (ExpressionFieldName (QualifiedField "t1" "res0"))) + (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "t0" "for_employee__last_name")) + (ExpressionFieldName (QualifiedField "t1" "res1")))) + (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "t0" "for_employee__created")) + (ExpressionFieldName (QualifiedField "t1" "res7")))) + selectGrouping s @?= Nothing + selectHaving s @?= Nothing + + let subselect = Select { selectTable = subselectTable, selectLimit = Just 10, selectOffset = Nothing + , selectOrdering = [ OrderingAsc (ExpressionFieldName (QualifiedField "t0" "age")) + , OrderingDesc (ExpressionCharLength (ExpressionFieldName (QualifiedField "t0" "first_name"))) ] } + subselectTable = SelectTable { selectProjection = + ProjExprs [ ( ExpressionFieldName (QualifiedField "t0" "first_name"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "last_name"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "phone_number"), Just "res2" ) + , ( ExpressionFieldName (QualifiedField "t0" "age"), Just "res3" ) + , ( ExpressionFieldName (QualifiedField "t0" "salary"), Just "res4" ) + , ( ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5" ) + , ( ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6" ) + , ( ExpressionFieldName (QualifiedField "t0" "created"), Just "res7" ) ] + , selectFrom = Just (FromTable (TableNamed "employees") (Just "t0")) + , selectWhere = Nothing + , selectGrouping = Nothing + , selectHaving = Nothing + , selectQuantifier = Nothing } + selectFrom s @?= Just (InnerJoin (FromTable (TableNamed "roles") (Just "t0")) + (FromTable (TableFromSubSelect subselect) (Just "t1")) + Nothing) + +-- | HAVING clause should not be floated out of a join + +joinHaving :: TestTree +joinHaving = + testCase "HAVING clause should not be floated out of a join" $ + do SqlSelect Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- + pure $ select $ + do (age, maxFirstNameLength) <- filter_ (\(_, nameLength) -> nameLength >=. 20) $ + aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ + all_ (_employees employeeDbSettings) + role <- all_ (_roles employeeDbSettings) + pure (age, maxFirstNameLength, _roleName role) + + Just (InnerJoin + (FromTable (TableFromSubSelect subselect) (Just t0)) + (FromTable (TableNamed "roles") (Just t1)) + Nothing) <- pure selectFrom + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "res0"), Just "res0") + , (ExpressionFieldName (QualifiedField t0 "res1"), Just "res1") + , (ExpressionFieldName (QualifiedField t1 "name"), Just "res2") ] + selectWhere @?= Nothing + selectGrouping @?= Nothing + selectHaving @?= Nothing + + Select { selectTable = SelectTable { .. } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- pure subselect + Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "age"), Just "res0") + , (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))], Just "res1") ] + selectWhere @?= Nothing + selectGrouping @?= Just (Grouping [ExpressionFieldName (QualifiedField t0 "age")]) + selectHaving @?= Just (ExpressionCompOp ">=" Nothing (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))]) (ExpressionValue (Value (20 :: Int)))) + +-- | Ensure that isJustE and isNothingE work correctly for simple types + +maybeFieldTypes :: TestTree +maybeFieldTypes = + testCase "Simple maybe field types" $ + do SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ select $ do + e <- all_ (_employees employeeDbSettings) + guard_ (isNothing_ (_employeeLeaveDate e)) + pure e + + Just (FromTable (TableNamed "employees") (Just employees)) <- pure selectFrom + selectWhere @?= ExpressionIsNull (ExpressionFieldName (QualifiedField employees "leave_date")) + +-- | Ensure isJustE and isNothingE work correctly for table and composite types + +-- | Ensure maybeE works for simple types + +-- | Ensure equality works for tables + +tableEquality :: TestTree +tableEquality = + testGroup "Equality comparisions among table expressions and table literals" + [ tableExprToTableExpr, tableExprToTableLiteral ] + where + tableExprToTableExpr = + testCase "Equality comparison between two table expressions" $ + do SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ select $ do + d <- all_ (_departments employeeDbSettings) + guard_ (d ==. d) + pure d + + Just (FromTable (TableNamed "departments") (Just depts)) <- pure selectFrom + + let andE = ExpressionBinOp "AND" + eqE = ExpressionCompOp "==" Nothing + nameCond = eqE (ExpressionFieldName (QualifiedField depts "name")) + (ExpressionFieldName (QualifiedField depts "name")) + firstNameCond = eqE (ExpressionFieldName (QualifiedField depts "head__first_name")) + (ExpressionFieldName (QualifiedField depts "head__first_name")) + lastNameCond = eqE (ExpressionFieldName (QualifiedField depts "head__last_name")) + (ExpressionFieldName (QualifiedField depts "head__last_name")) + createdCond = eqE (ExpressionFieldName (QualifiedField depts "head__created")) + (ExpressionFieldName (QualifiedField depts "head__created")) + selectWhere @?= andE (andE (andE nameCond firstNameCond) lastNameCond) createdCond + + tableExprToTableLiteral = + testCase "Equality comparison between table expression and table literal" $ + do now <- getCurrentTime + + let exp = DepartmentT "Sales" (EmployeeId (Just "Jane") (Just "Smith") (Just (Auto (Just now)))) + SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ select $ do + d <- all_ (_departments employeeDbSettings) + guard_ (d ==. val_ exp) + pure d + + Just (FromTable (TableNamed "departments") (Just depts)) <- pure selectFrom + + let andE = ExpressionBinOp "AND" + eqE = ExpressionCompOp "==" Nothing + nameCond = eqE (ExpressionFieldName (QualifiedField depts "name")) + (ExpressionValue (Value ("Sales" :: Text))) + firstNameCond = eqE (ExpressionFieldName (QualifiedField depts "head__first_name")) + (ExpressionValue (Value ("Jane" :: Text))) + lastNameCond = eqE (ExpressionFieldName (QualifiedField depts "head__last_name")) + (ExpressionValue (Value ("Smith" :: Text))) + createdCond = eqE (ExpressionFieldName (QualifiedField depts "head__created")) + (ExpressionValue (Value now)) + selectWhere @?= andE (andE (andE nameCond firstNameCond) lastNameCond) createdCond + +-- | Ensure related_ generates the correct ON conditions + +related :: TestTree +related = + testCase "related_ generate the correct ON conditions" $ + do SqlSelect Select { .. } <- + pure $ select $ + do r <- all_ (_roles employeeDbSettings) + e <- related_ (_employees employeeDbSettings) (_roleForEmployee r) + pure (e, r) + + pure () + +-- | Ensure select can be joined with UNION, INTERSECT, and EXCEPT + +selectCombinators :: TestTree +selectCombinators = + testGroup "UNION, INTERSECT, EXCEPT support" + [ basicUnion + , fieldNamesCapturedCorrectly + , basicIntersect + , basicExcept + , equalProjectionsDontHaveSubSelects + + , unionWithGuards ] + where + basicUnion = + testCase "Basic UNION support" $ + do let hireDates = do e <- all_ (_employees employeeDbSettings) + pure (as_ @Text $ val_ "hire", just_ (_employeeHireDate e)) + leaveDates = do e <- all_ (_employees employeeDbSettings) + guard_ (isJust_ (_employeeLeaveDate e)) + pure (as_ @Text $ val_ "leave", _employeeLeaveDate e) + SqlSelect Select { selectTable = UnionTables False a b } <- pure (select (union_ hireDates leaveDates)) + a @?= SelectTable Nothing + (ProjExprs [ (ExpressionValue (Value ("hire" :: Text)), Just "res0") + , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res1") ]) + (Just (FromTable (TableNamed "employees") (Just "t0"))) + Nothing Nothing Nothing + b @?= SelectTable Nothing + (ProjExprs [ (ExpressionValue (Value ("leave" :: Text)), Just "res0") + , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res1") ]) + (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (ExpressionIsNotNull (ExpressionFieldName (QualifiedField "t0" "leave_date")))) + Nothing Nothing + pure () + + fieldNamesCapturedCorrectly = + testCase "UNION field names are propagated correctly" $ + do let hireDates = do e <- all_ (_employees employeeDbSettings) + pure (as_ @Text $ val_ "hire", _employeeAge e, just_ (_employeeHireDate e)) + leaveDates = do e <- all_ (_employees employeeDbSettings) + guard_ (isJust_ (_employeeLeaveDate e)) + pure (as_ @Text $ val_ "leave", _employeeAge e, _employeeLeaveDate e) + SqlSelect Select { selectTable = SelectTable { .. }, selectLimit = Nothing, selectOffset = Nothing, selectOrdering = [] } <- + pure (select $ do + (type_, age, date) <- limit_ 10 (union_ hireDates leaveDates) + guard_ (age <. 22) + pure (type_, age + 23, date)) + + Just (FromTable (TableFromSubSelect subselect) (Just subselectTbl)) <- pure selectFrom + selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField subselectTbl "res0"), Just "res0") + , (ExpressionBinOp "+" (ExpressionFieldName (QualifiedField subselectTbl "res1")) + (ExpressionValue (Value (23 :: Int))), Just "res1") + , (ExpressionFieldName (QualifiedField subselectTbl "res2"), Just "res2") ] + selectHaving @?= Nothing + selectGrouping @?= Nothing + selectWhere @?= Just (ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField subselectTbl "res1")) (ExpressionValue (Value (22 :: Int)))) + + Select { selectTable = UnionTables False hireDatesQuery leaveDatesQuery + , selectLimit = Just 10, selectOffset = Nothing + , selectOrdering = [] } <- + pure subselect + + hireDatesQuery @?= SelectTable Nothing + (ProjExprs [ ( ExpressionValue (Value ("hire" :: Text)), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "age"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res2" ) ]) + (Just (FromTable (TableNamed "employees") (Just "t0"))) Nothing Nothing Nothing + leaveDatesQuery @?= SelectTable Nothing + (ProjExprs [ ( ExpressionValue (Value ("leave" :: Text)), Just "res0" ) + , ( ExpressionFieldName (QualifiedField "t0" "age"), Just "res1") + , ( ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res2") ]) + (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (ExpressionIsNotNull (ExpressionFieldName (QualifiedField "t0" "leave_date")))) + Nothing Nothing + + pure () + + basicIntersect = + testCase "intersect_ generates INTERSECT combination" $ + do let hireDates = do e <- all_ (_employees employeeDbSettings) + pure (_employeeFirstName e, _employeeLastName e) + leaveDates = do e <- all_ (_employees employeeDbSettings) + guard_ (isJust_ (_employeeLeaveDate e)) + pure (_employeeFirstName e, _employeeLastName e) + SqlSelect Select { selectTable = IntersectTables False _ _ } <- pure $ select $ intersect_ hireDates leaveDates + pure () + + basicExcept = + testCase "except_ generates EXCEPT combination" $ + do let hireDates = do e <- all_ (_employees employeeDbSettings) + pure (_employeeFirstName e, _employeeLastName e) + leaveDates = do e <- all_ (_employees employeeDbSettings) + guard_ (isJust_ (_employeeLeaveDate e)) + pure (_employeeFirstName e, _employeeLastName e) + SqlSelect Select { selectTable = ExceptTable False _ _ } <- pure $ select $ except_ hireDates leaveDates + pure () + + equalProjectionsDontHaveSubSelects = + testCase "Equal projections dont have sub-selects" $ + do let hireDates = do e <- all_ (_employees employeeDbSettings) + pure (_employeeFirstName e, _employeeLastName e, _employeeAge e) + leaveDates = do e <- all_ (_employees employeeDbSettings) + guard_ (isJust_ (_employeeLeaveDate e)) + pure (_employeeFirstName e, _employeeLastName e, _employeeAge e) + SqlSelect Select { selectTable = ExceptTable False _ _ } <- + pure $ select $ do + (firstName, lastName, age) <- except_ hireDates leaveDates + pure (firstName, (lastName, age)) + pure () + + unionWithGuards = + testCase "UNION with guards" $ + do let hireDates = do e <- all_ (_employees employeeDbSettings) + pure (as_ @Text $ val_ "hire", _employeeAge e, just_ (_employeeHireDate e)) + leaveDates = do e <- all_ (_employees employeeDbSettings) + guard_ (isJust_ (_employeeLeaveDate e)) + pure (as_ @Text $ val_ "leave", _employeeAge e, _employeeLeaveDate e) + SqlSelect Select { selectTable = + SelectTable + { selectFrom = Just (FromTable (TableFromSubSelect (Select (UnionTables False a b) [] Nothing Nothing)) (Just t0)) + , selectProjection = proj + , selectWhere = Just where_ + , selectGrouping = Nothing + , selectHaving = Nothing + , selectQuantifier = Nothing } + , selectLimit = Nothing, selectOffset = Nothing + , selectOrdering = [] } <- pure (select (filter_ (\(_, age, _) -> age <. 40) (union_ hireDates leaveDates))) + a @?= SelectTable Nothing + (ProjExprs [ (ExpressionValue (Value ("hire" :: Text)), Just "res0") + , (ExpressionFieldName (QualifiedField "t0" "age"), Just "res1") + , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res2") ]) + (Just (FromTable (TableNamed "employees") (Just "t0"))) + Nothing Nothing Nothing + b @?= SelectTable Nothing + (ProjExprs [ (ExpressionValue (Value ("leave" :: Text)), Just "res0") + , (ExpressionFieldName (QualifiedField "t0" "age"), Just "res1") + , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res2") ]) + (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (ExpressionIsNotNull (ExpressionFieldName (QualifiedField "t0" "leave_date")))) + Nothing Nothing + + proj @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0 "res0"), Just "res0" ) + , ( ExpressionFieldName (QualifiedField t0 "res1"), Just "res1" ) + , ( ExpressionFieldName (QualifiedField t0 "res2"), Just "res2" ) ] + where_ @?= ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField "t0" "res1")) (ExpressionValue (Value (40 :: Int))) + pure () + + +-- | Ensure simple selects can be used with limit_ and offset_ + +limitOffset :: TestTree +limitOffset = + testGroup "LIMIT/OFFSET support" + [ limitSupport, offsetSupport, limitOffsetSupport + + , limitPlacedOnUnion ] + where + limitSupport = + testCase "Basic LIMIT support" $ + do SqlSelect Select { selectLimit, selectOffset } <- + pure $ select $ limit_ 100 $ limit_ 20 (all_ (_employees employeeDbSettings)) + + selectLimit @?= Just 20 + selectOffset @?= Nothing + + offsetSupport = + testCase "Basic OFFSET support" $ + do SqlSelect Select { selectLimit, selectOffset } <- + pure $ select $ offset_ 2 $ offset_ 100 (all_ (_employees employeeDbSettings)) + + selectLimit @?= Nothing + selectOffset @?= Just 102 + + limitOffsetSupport = + testCase "Basic LIMIT .. OFFSET .. support" $ + do SqlSelect Select { selectLimit, selectOffset } <- + pure $ select $ offset_ 2 $ limit_ 100 (all_ (_roles employeeDbSettings)) + + selectLimit @?= Just 98 + selectOffset @?= Just 2 + + limitPlacedOnUnion = + testCase "LIMIT placed on UNION" $ + do SqlSelect Select { selectOffset = Nothing, selectLimit = Just 10 + , selectOrdering = [] + , selectTable = UnionTables False a b } <- + pure $ select $ limit_ 10 $ union_ (filter_ (\e -> _employeeAge e <. 40) (all_ (_employees employeeDbSettings))) + (filter_ (\e -> _employeeAge e >. 50) (do { e <- all_ (_employees employeeDbSettings); pure e { _employeeFirstName = _employeeLastName e, _employeeLastName = _employeeFirstName e} })) + + selectProjection a @?= ProjExprs [ (ExpressionFieldName (QualifiedField "t0" "first_name"), Just "res0") + , (ExpressionFieldName (QualifiedField "t0" "last_name"), Just "res1") + , (ExpressionFieldName (QualifiedField "t0" "phone_number"), Just "res2") + , (ExpressionFieldName (QualifiedField "t0" "age"), Just "res3") + , (ExpressionFieldName (QualifiedField "t0" "salary"), Just "res4") + , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5") + , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6") + , (ExpressionFieldName (QualifiedField "t0" "created"), Just "res7") ] + selectFrom a @?= Just (FromTable (TableNamed "employees") (Just "t0")) + selectWhere a @?= Just (ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (40 :: Int)))) + selectGrouping a @?= Nothing + selectHaving a @?= Nothing + + selectProjection b @?= ProjExprs [ (ExpressionFieldName (QualifiedField "t0" "last_name"), Just "res0") + , (ExpressionFieldName (QualifiedField "t0" "first_name"), Just "res1") + , (ExpressionFieldName (QualifiedField "t0" "phone_number"), Just "res2") + , (ExpressionFieldName (QualifiedField "t0" "age"), Just "res3") + , (ExpressionFieldName (QualifiedField "t0" "salary"), Just "res4") + , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5") + , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6") + , (ExpressionFieldName (QualifiedField "t0" "created"), Just "res7") ] + selectFrom b @?= Just (FromTable (TableNamed "employees") (Just "t0")) + selectWhere b @?= Just (ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (50 :: Int)))) + selectGrouping b @?= Nothing + selectHaving b @?= Nothing + +-- | Ensures exists predicates generate table names that do not overlap + +existsTest :: TestTree +existsTest = + testGroup "EXISTS() tests" + [ existsInWhere ] + where + existsInWhere = + testCase "EXISTS() in WHERE" $ + do SqlSelect Select { selectOffset = Nothing, selectLimit = Nothing + , selectOrdering = [] + , selectTable = SelectTable { .. } } <- + pure $ select $ do + role <- all_ (_roles employeeDbSettings) + guard_ (not_ (exists_ (do dept <- all_ (_departments employeeDbSettings) + guard_ (_departmentName dept ==. _roleName role) + pure (as_ @Int 1)))) + pure role + + let existsQuery = Select + { selectOffset = Nothing, selectLimit = Nothing + , selectOrdering = [] + , selectTable = SelectTable + { selectQuantifier = Nothing + , selectProjection = ProjExprs [ (ExpressionValue (Value (1 :: Int)), Just "res0") ] + , selectGrouping = Nothing + , selectHaving = Nothing + , selectWhere = Just joinExpr + , selectFrom = Just (FromTable (TableNamed "departments") (Just "sub_t0")) } } + joinExpr = ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "sub_t0" "name")) + (ExpressionFieldName (QualifiedField "t0" "name")) + + selectGrouping @?= Nothing + selectWhere @?= Just (ExpressionUnOp "NOT" (ExpressionExists existsQuery)) + selectHaving @?= Nothing + selectQuantifier @?= Nothing + selectFrom @?= Just (FromTable (TableNamed "roles") (Just "t0")) + +-- | UPDATE can correctly get the current value + +updateCurrent :: TestTree +updateCurrent = + testCase "UPDATE can use current value" $ + do SqlUpdate Update { .. } <- + pure $ update (_employees employeeDbSettings) + (\employee -> [ _employeeAge employee <-. current_ (_employeeAge employee) + 1]) + (\employee -> _employeeFirstName employee ==. "Joe") + + updateTable @?= "employees" + updateFields @?= [ (UnqualifiedField "age", ExpressionBinOp "+" (ExpressionFieldName (UnqualifiedField "age")) (ExpressionValue (Value (1 :: Int)))) ] + updateWhere @?= Just (ExpressionCompOp "==" Nothing (ExpressionFieldName (UnqualifiedField "first_name")) (ExpressionValue (Value ("Joe" :: String)))) + +updateNullable :: TestTree +updateNullable = + testCase "UPDATE can correctly set a nullable field" $ + do curTime <- getCurrentTime + + let employeeKey :: PrimaryKey EmployeeT (Nullable Identity) + employeeKey = EmployeeId (Just "John") (Just "Smith") (Just (Auto (Just curTime))) + + SqlUpdate Update { .. } <- + pure $ update (_departments employeeDbSettings) + (\department -> [ _departmentHead department <-. val_ employeeKey ]) + (\department -> _departmentName department ==. "Sales") + + updateTable @?= "departments" + updateFields @?= [ (UnqualifiedField "head__first_name", ExpressionValue (Value ("John" :: Text))) + , (UnqualifiedField "head__last_name", ExpressionValue (Value ("Smith" :: Text))) + , (UnqualifiedField "head__created", ExpressionValue (Value curTime)) ] + updateWhere @?= Just (ExpressionCompOp "==" Nothing + (ExpressionFieldName (UnqualifiedField "name")) + (ExpressionValue (Value ("Sales" :: String)))) + +-- | Ensure empty IN operators transform into FALSE + +noEmptyIns :: TestTree +noEmptyIns = + testCase "Empty INs are transformed to FALSE" $ + do SqlSelect Select { selectTable = SelectTable {..} } <- + pure $ select $ do + e <- all_ (_employees employeeDbSettings) + guard_ (_employeeFirstName e `in_` []) + pure e + + selectWhere @?= Just (ExpressionValue (Value False)) diff --git a/test/Database/Beam/Test/Schema.hs b/test/Database/Beam/Test/Schema.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Test/Schema.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Database.Beam.Test.Schema + ( EmployeeT(..), DepartmentT(..) + , RoleT(..), FunnyT (..) + , EmployeeDb(..) + , PrimaryKey(..) + + , DummyBackend + + , employeeDbSettings + + , tests ) where + +import Database.Beam +import Database.Beam.Schema.Tables +import Database.Beam.Backend +import Database.Beam.Backend.SQL.AST + +import Data.Monoid +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "Schema Tests" + [ basicSchemaGeneration + , ruleBasedRenaming +-- , automaticNestedFieldsAreUnset +-- , nullableForeignKeysGivenMaybeType + , underscoresAreHandledGracefully ] +-- , dbSchemaGeneration ] +-- , dbSchemaModification ] + +data DummyBackend + +instance BeamBackend DummyBackend where + -- Pretty much everything we can shove in a database satisfies show + type BackendFromField DummyBackend = Show + +data EmployeeT f + = EmployeeT + { _employeeFirstName :: Columnar f Text + , _employeeLastName :: Columnar f Text + , _employeePhoneNumber :: Columnar f Text + + , _employeeAge :: Columnar f Int + , _employeeSalary :: Columnar f Double + + , _employeeHireDate :: Columnar f UTCTime + , _employeeLeaveDate :: Columnar f (Maybe UTCTime) + + , _employeeCreated :: Columnar f (Auto UTCTime) + } deriving Generic +instance Beamable EmployeeT +instance Table EmployeeT where + data PrimaryKey EmployeeT f = EmployeeId (Columnar f Text) (Columnar f Text) (Columnar f (Auto UTCTime)) + deriving Generic + primaryKey e = EmployeeId (_employeeFirstName e) (_employeeLastName e) (_employeeCreated e) +instance Beamable (PrimaryKey EmployeeT) +deriving instance Show (TableSettings EmployeeT) +deriving instance Eq (TableSettings EmployeeT) +deriving instance (Show (Columnar f Text), Show (Columnar f (Auto UTCTime))) => Show (PrimaryKey EmployeeT f) +deriving instance (Eq (Columnar f Text), Eq(Columnar f (Auto UTCTime))) => Eq (PrimaryKey EmployeeT f) + +-- * Verify that the schema is generated properly + +employeeTableSchema :: TableSettings EmployeeT +employeeTableSchema = defTblFieldSettings + +expectedEmployeeTableSchema :: TableSettings EmployeeT +expectedEmployeeTableSchema = + EmployeeT { _employeeFirstName = TableField "first_name" + , _employeeLastName = TableField "last_name" + , _employeePhoneNumber = TableField "phone_number" + , _employeeAge = TableField "age" + , _employeeSalary = TableField "salary" + , _employeeHireDate = TableField "hire_date" + , _employeeLeaveDate = TableField "leave_date" + , _employeeCreated = TableField "created" + } + +basicSchemaGeneration :: TestTree +basicSchemaGeneration = + testCase "Basic Schema Generation" $ + do _employeeFirstName employeeTableSchema @?= _employeeFirstName expectedEmployeeTableSchema + _employeeLastName employeeTableSchema @?= _employeeLastName expectedEmployeeTableSchema + _employeePhoneNumber employeeTableSchema @?= _employeePhoneNumber expectedEmployeeTableSchema + _employeeAge employeeTableSchema @?= _employeeAge expectedEmployeeTableSchema + _employeeSalary employeeTableSchema @?= _employeeSalary expectedEmployeeTableSchema + _employeeHireDate employeeTableSchema @?= _employeeHireDate expectedEmployeeTableSchema + _employeeLeaveDate employeeTableSchema @?= _employeeLeaveDate expectedEmployeeTableSchema + _employeeCreated employeeTableSchema @?= _employeeCreated expectedEmployeeTableSchema + +-- * Ensure that automatic fields are unset when nesting + +data RoleT f + = RoleT + { _roleForEmployee :: PrimaryKey EmployeeT f + , _roleName :: Columnar f Text + , _roleStarted :: Columnar f UTCTime } + deriving Generic +instance Beamable RoleT +instance Table RoleT where + data PrimaryKey RoleT f = RoleId (PrimaryKey EmployeeT f) (Columnar f UTCTime) + deriving Generic + primaryKey (RoleT e _ s) = RoleId e s +instance Beamable (PrimaryKey RoleT) +deriving instance Show (TableSettings (PrimaryKey RoleT)) +deriving instance Eq (TableSettings (PrimaryKey RoleT)) + +roleTableSchema :: TableSettings RoleT +roleTableSchema = defTblFieldSettings + +-- automaticNestedFieldsAreUnset :: TestTree +-- automaticNestedFieldsAreUnset = +-- testCase "Automatic fields are unset when nesting" $ +-- do _roleForEmployee roleTableSchema @?= +-- EmployeeId (TableField "for_employee__first_name" (DummyField True False DummyFieldText)) +-- (TableField "for_employee__last_name" (DummyField True False DummyFieldText)) +-- (TableField "for_employee__created" (DummyField True False DummyFieldUTCTime)) + +-- * Ensure that fields of a nullable primary key are given the proper Maybe type + +data DepartmentT f + = DepartmentT + { _departmentName :: Columnar f Text + , _departmentHead :: PrimaryKey EmployeeT (Nullable f) -- ^ Departments may currently lack a department head + } deriving Generic +instance Beamable DepartmentT +instance Table DepartmentT where + data PrimaryKey DepartmentT f = DepartmentId (Columnar f Text) deriving Generic + primaryKey (DepartmentT name _) = DepartmentId name +instance Beamable (PrimaryKey DepartmentT) +deriving instance Show (TableSettings DepartmentT) +deriving instance Eq (TableSettings DepartmentT) + +departmentTableSchema :: TableSettings DepartmentT +departmentTableSchema = defTblFieldSettings + +-- nullableForeignKeysGivenMaybeType :: TestTree +-- nullableForeignKeysGivenMaybeType = +-- testCase "Nullable foreign keys are given maybe type" $ +-- do _departmentHead departmentTableSchema @?= +-- EmployeeId (TableField "head__first_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) +-- (TableField "head__last_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) +-- (TableField "head__created" (DummyField True False (DummyFieldMaybe DummyFieldUTCTime))) + +-- * Ensure that fields with underscores are handled properly + +data FunnyT f + = FunnyT + { funny_field1 :: Columnar f Text + , funny_field_2 :: Columnar f Text + , funny_first_name :: Columnar f Text + , _funny_lastName :: Columnar f Text + , _funny_middle_Name :: Columnar f Text + , ___ :: Columnar f Int } + deriving Generic +instance Beamable FunnyT +instance Table FunnyT where + data PrimaryKey FunnyT f = FunnyId (Columnar f Text) deriving Generic + primaryKey = FunnyId . funny_field1 +instance Beamable (PrimaryKey FunnyT) + +funnyTableSchema :: TableSettings FunnyT +funnyTableSchema = defTblFieldSettings + +underscoresAreHandledGracefully :: TestTree +underscoresAreHandledGracefully = + testCase "Underscores in field names are handled gracefully" $ + do let fieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) funnyTableSchema + fieldNames @?= [ "funny_field1" + , "funny_field_2" + , "funny_first_name" + , "funny_lastName" + , "funny_middle_Name" + , "___" ] + +ruleBasedRenaming :: TestTree +ruleBasedRenaming = + testCase "Rule based renaming works correctly" $ + do let (DatabaseEntity (DatabaseTable _ funny)) = _funny employeeDbSettingsRuleMods + (DatabaseEntity (DatabaseTable _ departments)) = _departments employeeDbSettingsRuleMods + + funnyFieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) funny + deptFieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) departments + + funnyFieldNames @?= [ "pfx_funny_field1" + , "pfx_funny_field_2" + , "pfx_funny_first_name" + , "pfx_funny_lastName" + , "pfx_funny_middle_Name" + , "___" ] + + deptFieldNames @?= [ "name", "head__first_name", "head__last_name", "head__created" ] + +-- * Database schema is derived correctly + +data EmployeeDb f + = EmployeeDb + { _employees :: f (TableEntity EmployeeT) + , _departments :: f (TableEntity DepartmentT) + , _roles :: f (TableEntity RoleT) + , _funny :: f (TableEntity FunnyT) } + deriving Generic +instance Database EmployeeDb + +employeeDbSettings :: DatabaseSettings be EmployeeDb +employeeDbSettings = defaultDbSettings + +employeeDbSettingsRuleMods :: DatabaseSettings be EmployeeDb +employeeDbSettingsRuleMods = defaultDbSettings `withDbModification` + renamingFields (\field -> + case T.stripPrefix "funny" field of + Nothing -> field + Just fieldNm -> "pfx_" <> field) + +-- employeeDbSettingsModified :: DatabaseSettings EmployeeDb +-- employeeDbSettingsModified = +-- defaultDbSettings `withDbModifications` +-- (modifyingDb { _employees = tableModification (\_ -> "emps") tableFieldsModification +-- , _departments = tableModification (\_ -> "depts") +-- (tableFieldsModification +-- { _departmentName = fieldModification (\_ -> "depts_name") id }) }) + +-- dbSchemaGeneration :: TestTree +-- dbSchemaGeneration = +-- testCase "Database schema generation" $ +-- do let names = allTables (\(DatabaseTable _ nm _) -> nm) employeeDbSettings +-- names @?= [ "employees" +-- , "departments" +-- , "roles" +-- , "funny" ] + +-- dbSchemaModification :: TestTree +-- dbSchemaModification = +-- testCase "Database schema modification" $ +-- do let names = allTables (\(DatabaseTable _ nm _ ) -> nm) employeeDbSettingsModified +-- names @?= [ "emps" +-- , "depts" +-- , "roles" +-- , "funny" ] + +-- let DatabaseTable _ _ departmentT = _departments employeeDbSettingsModified +-- departmentT @?= DepartmentT (TableField "depts_name" (DummyField False False DummyFieldText)) +-- (EmployeeId (TableField "head__first_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) +-- (TableField "head__last_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) +-- (TableField "head__created" (DummyField True False (DummyFieldMaybe DummyFieldUTCTime)))) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Test.Tasty + +import qualified Database.Beam.Test.Schema as Schema +import qualified Database.Beam.Test.SQL as SQL + +main :: IO () +main = defaultMain (testGroup "beam-core tests" + [ Schema.tests + , SQL.tests ])