From b2a94c9e49434c108e33aa8aa695a5822d79d72f Mon Sep 17 00:00:00 2001 From: belevy Date: Thu, 21 Jan 2021 21:03:03 -0600 Subject: [PATCH 1/3] Demonstrate a simple case of Aggregation --- esqueleto.cabal | 1 + .../Esqueleto/Experimental/Aggregates.hs | 103 ++++++++++++++++++ src/Database/Esqueleto/Internal/Internal.hs | 3 + 3 files changed, 107 insertions(+) create mode 100644 src/Database/Esqueleto/Experimental/Aggregates.hs diff --git a/esqueleto.cabal b/esqueleto.cabal index 73ff0ed..6d09a85 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -30,6 +30,7 @@ library exposed-modules: Database.Esqueleto Database.Esqueleto.Experimental + Database.Esqueleto.Experimental.Aggregates Database.Esqueleto.Internal.Language Database.Esqueleto.Internal.Sql Database.Esqueleto.Internal.Internal diff --git a/src/Database/Esqueleto/Experimental/Aggregates.hs b/src/Database/Esqueleto/Experimental/Aggregates.hs new file mode 100644 index 0000000..8edcdf2 --- /dev/null +++ b/src/Database/Esqueleto/Experimental/Aggregates.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Esqueleto.Experimental.Aggregates + where + +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.Writer as W +import Data.Coerce (Coercible, coerce) +import Database.Esqueleto.Internal.Internal + ( GroupByClause(..) + , SideData(..) + , SqlExpr(..) + , SqlQuery(..) + , SqlSelect(..) + , ToSomeValues(..) + , Value(..) + , select + , unsafeSqlFunction + ) +import Database.Esqueleto.Internal.PersistentImport (Entity, SqlReadT) + +-- Phantom data type that doesn't admit a SqlSelect forcing the use of selectAggregate +data Aggregate a + +test :: Integral n + => SqlExpr (Value a) + -> SqlExpr (Value b) + -> SqlExpr (Value c) + -> SqlQuery (SqlExpr (Value a), SqlExpr (Value b), SqlExpr (Value n)) +test x y other = + groupBy (x, y) $ \(x', y') -> + pure (x', y', sum_ other) + + +-- Tuple magic, only SqlExprs are on the leaves. +-- The Coercible instance from the SqlExpr a -> SqlExpr b allows 0 cost casting +class Coercible a r => Aggregateable a r | a -> r, r -> a where + toAggregate :: a -> r + toAggregate = coerce + fromAggregate :: r -> a + fromAggregate = coerce +instance Aggregateable (SqlExpr (Value a)) (SqlExpr (Aggregate (Value a))) where +instance Aggregateable (SqlExpr (Entity a)) (SqlExpr (Aggregate (Entity a))) where +instance (Aggregateable a ra, Aggregateable b rb) => Aggregateable (a,b) (ra, rb) where +instance + ( Aggregateable a ra + , Aggregateable b rb + , Aggregateable c rc + ) => Aggregateable (a,b,c) (ra,rb,rc) where +instance + ( Aggregateable a ra + , Aggregateable b rb + , Aggregateable c rc + , Aggregateable d rd + ) => Aggregateable (a,b,c,d) (ra,rb,rc,rd) where +instance + ( Aggregateable a ra + , Aggregateable b rb + , Aggregateable c rc + , Aggregateable d rd + , Aggregateable e re + ) => Aggregateable (a,b,c,d,e) (ra,rb,rc,rd,re) where +instance + ( Aggregateable a ra + , Aggregateable b rb + , Aggregateable c rc + , Aggregateable d rd + , Aggregateable e re + , Aggregateable f rf + ) => Aggregateable (a,b,c,d,e,f) (ra,rb,rc,rd,re,rf) where +instance + ( Aggregateable a ra + , Aggregateable b rb + , Aggregateable c rc + , Aggregateable d rd + , Aggregateable e re + , Aggregateable f rf + , Aggregateable g rg + ) => Aggregateable (a,b,c,d,e,f,g) (ra,rb,rc,rd,re,rf,rg) where +instance + ( Aggregateable a ra + , Aggregateable b rb + , Aggregateable c rc + , Aggregateable d rd + , Aggregateable e re + , Aggregateable f rf + , Aggregateable g rg + , Aggregateable h rh + ) => Aggregateable (a,b,c,d,e,f,g,h) (ra,rb,rc,rd,re,rf,rg,rh) where + +sum_ :: Integral n => SqlExpr (Value a) -> SqlExpr (Aggregate (Value n)) +sum_ = coerce . unsafeSqlFunction "SUM" + +groupBy :: (ToSomeValues a, Aggregateable a a', Aggregateable b b') => a -> (a' -> SqlQuery b') -> SqlQuery b +groupBy a f = do + Q $ W.tell $ mempty{sdGroupByClause = GroupBy $ toSomeValues a } + fmap fromAggregate $ f $ toAggregate a diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 96c6bce..149c4a9 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1138,6 +1138,9 @@ data SomeValue where class ToSomeValues a where toSomeValues :: a -> [SomeValue] +instance PersistEntity ent => ToSomeValues (SqlExpr (Entity ent)) where + toSomeValues ent = [SomeValue $ ent ^. persistIdField] + instance ( ToSomeValues a , ToSomeValues b From 65ac3c7e5aceeb01690ad04c1ae18951f612406e Mon Sep 17 00:00:00 2001 From: belevy Date: Thu, 28 Jan 2021 16:03:24 -0600 Subject: [PATCH 2/3] Added support for (^.) and (?.) to aggregated entities. Allow grouping on Maybe Entity --- .../Esqueleto/Experimental/Aggregates.hs | 87 ++++++++++++------- src/Database/Esqueleto/Internal/Internal.hs | 79 +++++++++++++---- 2 files changed, 121 insertions(+), 45 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/Aggregates.hs b/src/Database/Esqueleto/Experimental/Aggregates.hs index 8edcdf2..b3759b3 100644 --- a/src/Database/Esqueleto/Experimental/Aggregates.hs +++ b/src/Database/Esqueleto/Experimental/Aggregates.hs @@ -1,42 +1,69 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Database.Esqueleto.Experimental.Aggregates where -import Control.Monad.IO.Class -import qualified Control.Monad.Trans.Writer as W -import Data.Coerce (Coercible, coerce) -import Database.Esqueleto.Internal.Internal - ( GroupByClause(..) - , SideData(..) - , SqlExpr(..) - , SqlQuery(..) - , SqlSelect(..) - , ToSomeValues(..) - , Value(..) - , select - , unsafeSqlFunction - ) -import Database.Esqueleto.Internal.PersistentImport (Entity, SqlReadT) +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.Writer as W +import Data.Coerce (Coercible, + coerce) +import Database.Esqueleto.Internal.Internal (EntityTy, + EntityTyToValueTy, + GroupByClause (..), + MaybeEntityTy, + MaybeEntityTyToMaybeValueTy, + MaybeValueTy, + MaybeValueTyToMaybeEntityTy, + SideData (..), + SqlExpr (..), + SqlQuery (..), + SqlSelect (..), + ToSomeValues (..), + UnMaybeTy, + Value (..), + ValueTy, + ValueTyToEntityTy, + noMeta, select, + unsafeSqlFunction, + (?.), (^.)) +import Database.Esqueleto.Internal.PersistentImport (Entity, + EntityField, + PersistEntity, + PersistField, + SqlReadT) -- Phantom data type that doesn't admit a SqlSelect forcing the use of selectAggregate data Aggregate a -test :: Integral n - => SqlExpr (Value a) - -> SqlExpr (Value b) - -> SqlExpr (Value c) - -> SqlQuery (SqlExpr (Value a), SqlExpr (Value b), SqlExpr (Value n)) -test x y other = - groupBy (x, y) $ \(x', y') -> - pure (x', y', sum_ other) +type instance EntityTy (Aggregate (Entity ent)) ent = Entity ent +type instance ValueTy (Aggregate (Value val)) val = Value val +type instance EntityTyToValueTy (Aggregate (Entity ent)) val = Aggregate (Value val) +type instance ValueTyToEntityTy (Aggregate (Value val)) ent = Aggregate (Entity ent) +type instance MaybeEntityTy (Aggregate (Maybe (Entity ent))) ent = Maybe (Entity ent) +type instance MaybeValueTy (Aggregate (Value (Maybe val))) val = Value (Maybe val) +type instance MaybeEntityTyToMaybeValueTy (Aggregate (Maybe (Entity ent))) val = Aggregate (Value (Maybe val)) +type instance MaybeValueTyToMaybeEntityTy (Aggregate (Value (Maybe val))) ent = Aggregate (Maybe (Entity ent)) +type instance UnMaybeTy (Aggregate (Value (Maybe val))) = Aggregate (Value val) +type instance UnMaybeTy (Aggregate (Maybe (Entity ent))) = Aggregate (Entity ent) + +test ent field y other = do + groupBy (ent, y) $ \(ent', y') -> + pure (ent' ?. field, y', sum_ other, countRows_) + +class CountRowsFn a where + countRows_ :: SqlExpr a + countRows_ = ERaw noMeta $ \_ _ -> ("COUNT(*)", []) +instance Integral n => CountRowsFn (Value n) +instance Integral n => CountRowsFn (Aggregate (Value n)) -- Tuple magic, only SqlExprs are on the leaves. -- The Coercible instance from the SqlExpr a -> SqlExpr b allows 0 cost casting @@ -45,8 +72,10 @@ class Coercible a r => Aggregateable a r | a -> r, r -> a where toAggregate = coerce fromAggregate :: r -> a fromAggregate = coerce +instance Aggregateable () () where instance Aggregateable (SqlExpr (Value a)) (SqlExpr (Aggregate (Value a))) where instance Aggregateable (SqlExpr (Entity a)) (SqlExpr (Aggregate (Entity a))) where +instance Aggregateable (SqlExpr (Maybe (Entity a))) (SqlExpr (Aggregate (Maybe (Entity a)))) where instance (Aggregateable a ra, Aggregateable b rb) => Aggregateable (a,b) (ra, rb) where instance ( Aggregateable a ra diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 149c4a9..d4bc19a 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# language DerivingStrategies, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,6 +15,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | This is an internal module, anything exported by this module -- may change without a major version bump. Please use only @@ -23,6 +25,7 @@ -- tracker so we can safely support it. module Database.Esqueleto.Internal.Internal where +import Data.Kind (Constraint) import Control.Applicative ((<|>)) import Data.Coerce (coerce) import Control.Arrow (first, (***)) @@ -532,15 +535,31 @@ subSelectForeign expr foreignKey k = subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) subSelectUnsafe = sub SELECT --- | Project a field of an entity. -(^.) - :: forall typ val. (PersistEntity val, PersistField typ) - => SqlExpr (Entity val) - -> EntityField val typ - -> SqlExpr (Value typ) -ERaw m f ^. field +type family EntityTy entity ent +type family ValueTy value val +type family EntityTyToValueTy entity val +type family ValueTyToEntityTy value ent + +type instance EntityTy (Entity ent) ent = Entity ent +type instance ValueTy (Value val) val = Value val +type instance EntityTyToValueTy (Entity ent) val = Value val +type instance ValueTyToEntityTy (Value val) ent = Entity ent + +type EntityValuePair entity ent value val = + ( EntityTyToValueTy entity val ~ value + , ValueTyToEntityTy value ent ~ entity + , EntityTy entity ent ~ Entity ent + , ValueTy value val ~ Value val + ) + +(^.) :: forall ent typ entity value. + (PersistEntity ent, PersistField typ, EntityValuePair entity ent value typ) + => SqlExpr entity + -> EntityField ent typ + -> SqlExpr value +(ERaw m f) ^. field | isIdField field = idFieldValue - | Just alias <- sqlExprMetaAlias m = + | Just alias <- sqlExprMetaAlias m = ERaw noMeta $ \_ info -> f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), []) | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) @@ -562,7 +581,7 @@ ERaw m f ^. field \p info -> (parensM p $ uncommas $ dot info <$> idFields, []) - ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) + ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity ent))) dot info fieldDef = sourceIdent info <> "." <> fieldIdent @@ -584,13 +603,39 @@ withNonNull field f = do where_ $ not_ $ isNothing field f $ veryUnsafeCoerceSqlExprValue field +type family MaybeEntityTy mEntity ent +type family MaybeValueTy mValue val +type family MaybeEntityTyToMaybeValueTy mEntity val +type family MaybeValueTyToMaybeEntityTy mValue ent +type family UnMaybeTy mValue +type MaybeEntityValuePair mEntity ent mValue val = + ( MaybeEntityTyToMaybeValueTy mEntity val ~ mValue + , MaybeValueTyToMaybeEntityTy mValue ent ~ mEntity + , MaybeEntityTy mEntity ent ~ Maybe (Entity ent) + , MaybeValueTy mValue val ~ Value (Maybe val) + ) + +type instance MaybeEntityTy (Maybe (Entity ent)) ent = Maybe (Entity ent) +type instance MaybeValueTy (Value (Maybe val)) val = Value (Maybe val) +type instance MaybeEntityTyToMaybeValueTy (Maybe (Entity ent)) val = Value (Maybe val) +type instance MaybeValueTyToMaybeEntityTy (Value (Maybe val)) ent = Maybe (Entity ent) +type instance UnMaybeTy (Value (Maybe val)) = Value val +type instance UnMaybeTy (Maybe (Entity ent)) = Entity ent + -- | Project a field of an entity that may be null. (?.) - :: (PersistEntity val, PersistField typ) - => SqlExpr (Maybe (Entity val)) - -> EntityField val typ - -> SqlExpr (Value (Maybe typ)) -ERaw m f ?. field = just (ERaw m f ^. field) + :: forall ent typ entity mEntity value mValue. + ( PersistEntity ent + , PersistField typ + , UnMaybeTy mEntity ~ entity + , UnMaybeTy mValue ~ value + , MaybeEntityValuePair mEntity ent mValue typ + , EntityValuePair entity ent value typ + ) + => SqlExpr mEntity + -> EntityField ent typ + -> SqlExpr mValue +e ?. field = coerce $ (coerce e :: SqlExpr entity) ^. field -- | Lift a constant value from Haskell-land to the query. val :: PersistField typ => typ -> SqlExpr (Value typ) @@ -1138,8 +1183,10 @@ data SomeValue where class ToSomeValues a where toSomeValues :: a -> [SomeValue] -instance PersistEntity ent => ToSomeValues (SqlExpr (Entity ent)) where - toSomeValues ent = [SomeValue $ ent ^. persistIdField] +instance (PersistEntity ent) => ToSomeValues (SqlExpr (Entity ent)) where + toSomeValues ent = [SomeValue $ ent ^. persistIdField] +instance (PersistEntity ent) => ToSomeValues (SqlExpr (Maybe (Entity ent))) where + toSomeValues ent = [SomeValue $ ent ?. persistIdField] instance ( ToSomeValues a From 6a420273c0cf5b916d46c2498a71b2c01c031b9e Mon Sep 17 00:00:00 2001 From: belevy Date: Sun, 31 Jan 2021 16:46:29 -0600 Subject: [PATCH 3/3] fixup subselectUnsafe test because inference engine doesnt work for it so good --- src/Database/Esqueleto/Experimental/Aggregates.hs | 6 ++++++ test/Common/Test.hs | 8 ++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/Aggregates.hs b/src/Database/Esqueleto/Experimental/Aggregates.hs index b3759b3..9ab8f96 100644 --- a/src/Database/Esqueleto/Experimental/Aggregates.hs +++ b/src/Database/Esqueleto/Experimental/Aggregates.hs @@ -55,6 +55,12 @@ type instance MaybeValueTyToMaybeEntityTy (Aggregate (Value (Maybe val))) ent = type instance UnMaybeTy (Aggregate (Value (Maybe val))) = Aggregate (Value val) type instance UnMaybeTy (Aggregate (Maybe (Entity ent))) = Aggregate (Entity ent) +test :: (PersistEntity ent, PersistField a, Integral n) + => SqlExpr (Maybe (Entity ent)) + -> EntityField ent a + -> SqlExpr (Value b) + -> SqlExpr (Value c) + -> SqlQuery (SqlExpr (Value (Maybe a)), SqlExpr (Value b), SqlExpr (Value n), SqlExpr (Value Int)) test ent field y other = do groupBy (ent, y) $ \(ent', y') -> pure (ent' ?. field, y', sum_ other, countRows_) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 8eb157b..2c07d02 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -454,10 +454,10 @@ testSubSelect run = do eres <- try $ run $ do setup bad <- select $ - from $ \n -> do + from $ \(n :: SqlExpr (Entity Numbers)) -> do pure $ (,) (n ^. NumbersInt) $ subSelectUnsafe $ - from $ \n' -> do + from $ \(n' :: SqlExpr (Entity Numbers)) -> do pure (just (n' ^. NumbersDouble)) good <- select $ from $ \n -> do @@ -480,10 +480,10 @@ testSubSelect run = do eres <- try $ run $ do setup select $ - from $ \n -> do + from $ \(n :: SqlExpr (Entity Numbers)) -> do pure $ (,) (n ^. NumbersInt) $ subSelectUnsafe $ - from $ \n' -> do + from $ \(n' :: SqlExpr (Entity Numbers)) -> do where_ $ val False pure (n' ^. NumbersDouble) case eres of