Added support for (^.) and (?.) to aggregated entities. Allow grouping on Maybe Entity

src/Database/Esqueleto/Experimental/Aggregates.hs

@@ -1,42 +1,69 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings      #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes             #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE UndecidableInstances   #-}
 
 module Database.Esqueleto.Experimental.Aggregates
     where
 
-import Control.Monad.IO.Class
+import           Control.Monad.IO.Class
-import qualified Control.Monad.Trans.Writer as W
+import qualified Control.Monad.Trans.Writer                   as W
-import Data.Coerce (Coercible, coerce)
+import           Data.Coerce                                  (Coercible,
-import Database.Esqueleto.Internal.Internal
+                                                               coerce)
-       ( GroupByClause(..)
+import           Database.Esqueleto.Internal.Internal         (EntityTy,
-       , SideData(..)
+                                                               EntityTyToValueTy,
-       , SqlExpr(..)
+                                                               GroupByClause (..),
-       , SqlQuery(..)
+                                                               MaybeEntityTy,
-       , SqlSelect(..)
+                                                               MaybeEntityTyToMaybeValueTy,
-       , ToSomeValues(..)
+                                                               MaybeValueTy,
-       , Value(..)
+                                                               MaybeValueTyToMaybeEntityTy,
-       , select
+                                                               SideData (..),
-       , unsafeSqlFunction
+                                                               SqlExpr (..),
-       )
+                                                               SqlQuery (..),
-import Database.Esqueleto.Internal.PersistentImport (Entity, SqlReadT)
+                                                               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
+type instance EntityTy (Aggregate (Entity ent)) ent = Entity ent
-     => SqlExpr (Value a)
+type instance ValueTy (Aggregate (Value val)) val = Value val
-     -> SqlExpr (Value b)
+type instance EntityTyToValueTy (Aggregate (Entity ent)) val = Aggregate (Value val)
-     -> SqlExpr (Value c)
+type instance ValueTyToEntityTy (Aggregate (Value val)) ent = Aggregate (Entity ent)
-     -> 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 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

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.
+type family EntityTy entity ent
-(^.)
+type family ValueTy value val
-    :: forall typ val. (PersistEntity val, PersistField typ)
+type family EntityTyToValueTy entity val
-    => SqlExpr (Entity val)
+type family ValueTyToEntityTy value ent
-    -> EntityField val typ
+
-    -> SqlExpr (Value typ)
+type instance EntityTy (Entity ent) ent = Entity ent
-ERaw m f ^. field
+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)
+    :: forall ent typ entity mEntity value mValue.
-    => SqlExpr (Maybe (Entity val))
+       ( PersistEntity ent
-    -> EntityField val typ
+       , PersistField typ
-    -> SqlExpr (Value (Maybe typ))
+       , UnMaybeTy mEntity ~ entity
-ERaw m f ?. field = just (ERaw m f ^. field)
+       , 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
+instance (PersistEntity ent) => ToSomeValues (SqlExpr (Entity ent)) where
-    toSomeValues ent = [SomeValue $ ent ^. persistIdField]
+    toSomeValues ent = [SomeValue $ ent ^. persistIdField] 
+instance (PersistEntity ent) => ToSomeValues (SqlExpr (Maybe (Entity ent))) where
+    toSomeValues ent = [SomeValue $ ent ?. persistIdField] 
 
 instance
     ( ToSomeValues a