{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds, TypeOperators, TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies, FlexibleContexts, MultiParamTypeClasses, Rank2Types #-} {-# LANGUAGE FunctionalDependencies, UndecidableInstances, UndecidableSuperClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, FlexibleInstances, AllowAmbiguousTypes #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE DefaultSignatures #-} {-# OPTIONS_GHC -Wno-missing-methods #-} module Internal.Data.Basic.Types ( module Internal.Data.Basic.Types , module Internal.Data.Basic.TypeLevel , Max(..), Min(..), Sum(..) ) where import Internal.Interlude hiding (TypeError) import Prelude (Show(..)) import Data.String (fromString) import Control.Lens (Lens') import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Database.PostgreSQL.Simple.FromField (FromField(..)) import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow) import Database.PostgreSQL.Simple.ToField (ToField) import Database.PostgreSQL.Simple.ToRow (ToRow) import qualified Database.PostgreSQL.Simple.Types as PSQL import Data.Aeson (toJSON, parseJSON, object, Value(Object)) import Data.Aeson.Types (Parser) import Data.Aeson.Lens (key) import Data.Monoid (Sum(..)) import Data.Semigroup (Min(..), Max(..)) import Internal.Data.Basic.TypeLevel import Internal.Data.Basic.Sql.Types (Comparison(..), SortDirection(..)) import qualified Internal.Data.Basic.Sql.Types as Sql import Internal.Composite data VarContext = Filtering | Updating | Sorting | Grouping | Folding | Mapping newtype Var (ctx :: VarContext) (a :: *) = Var Int deriving (Eq, Ord, Read, Show) newtype Key = Key Int deriving (Eq, Ord, Read, Show, Num, FromField, ToField) instance FromJSON Key where parseJSON = coerce (parseJSON @Int) instance ToJSON Key where toJSON = coerce (toJSON @Int) -- | Defines 'MissingField' kind. data MissingField = Required Symbol | DynamicDefault Symbol data Cached = Live | Cached data EntityKind = Fresh [MissingField] | FromDb Cached newtype Entity (entKind :: EntityKind) a = Entity { _getEntity :: a } makeLenses ''Entity toFreshEntity :: forall fs c a. Entity ('FromDb c) a -> Entity ('Fresh fs) a toFreshEntity = coerce reorderMissingFieldsTo :: forall fs2 fs1 a. SetEqual fs1 fs2 => Entity ('Fresh fs1) a -> Entity ('Fresh fs2) a reorderMissingFieldsTo = coerce instance FromRow a => FromRow (Entity l a) where fromRow = Entity <$> fromRow data FieldConstraint = Unique Symbol | ForeignKey Symbol type family MissingFields (entKind :: EntityKind) :: [MissingField] where MissingFields ('Fresh missing) = missing MissingFields ('FromDb c) = '[] type SetFields (missing :: [MissingField]) (table :: *) = TableFields table `Without` MissingFieldsNames missing type family TableFieldTypes (a :: *) (fs :: [Symbol]) :: [*] where TableFieldTypes a '[] = '[] TableFieldTypes a (f ': fs) = TableFieldType a f ': TableFieldTypes a fs class (KnownSymbol (CapsName t s)) => HasCapsFieldName t (s :: Symbol) where capsFieldName :: proxy s -> Text instance (KnownSymbol (CapsName t s)) => HasCapsFieldName t (s :: Symbol) where capsFieldName _ = toS $ symbolVal (Proxy @(CapsName t s)) class (AllSatisfy (TableField table) fields) => AllTypesSatisfy (c :: * -> Symbol -> Constraint) (table :: *) (fields :: [Symbol]) where mapFields :: (fields `IsSubset` SetFields (MissingFields entKind) table) => (forall proxy n x. c x n => proxy n -> x -> a) -> Entity entKind table -> [a] instance AllTypesSatisfy c table '[] where mapFields _ _ = [] instance ( TableField table x , c (TableFieldType table x) x , AllTypesSatisfy c table xs ) => AllTypesSatisfy (c :: * -> Symbol -> Constraint) table (x ': xs) where mapFields f e = f (Proxy @x) (e ^. getEntity . tableFieldLens @table @x) : mapFields @c @table @xs f e instance ( IsSubset (TableFields a) (TableFields a) , AllTypesSatisfy JSONableField a (TableFields a) ) => ToJSON (Entity ('FromDb 'Live) a) where toJSON = toJSON . toFreshEntity @'[] class (KnownSymbol n, ToJSON a) => JSONableField a (n :: Symbol) instance (KnownSymbol n, ToJSON a) => JSONableField a (n :: Symbol) instance ( IsSubset (SetFields fs a) (SetFields fs a) , AllTypesSatisfy JSONableField a (SetFields fs a) ) => ToJSON (Entity ('Fresh fs) a) where toJSON e = object (mapFields @JSONableField @a @(SetFields fs a) (\p a -> (toS (symbolVal p), toJSON a)) e) instance ToJSON (Entity entKind a) => Show (Entity entKind a) where show = toS . encode class GetEntityFromValue (fs :: [Symbol]) a where type MissingFieldsFromValue fs a :: [MissingField] getEntityFromObject :: Value -> Parser (Entity ('Fresh (MissingFieldsFromValue fs a)) a) instance Table a => GetEntityFromValue '[] a where type MissingFieldsFromValue '[] a = TableRequiredFields a getEntityFromObject (Object _) = return newEntity getEntityFromObject _ = fail "Cannot parse Entity from JSON that's not an object" instance ( GetEntityFromValue fs a , FromJSON (TableFieldType a f) , TableField a f ) => GetEntityFromValue (f ': fs) a where type MissingFieldsFromValue (f ': fs) a = WithoutMissingField f (MissingFieldsFromValue fs a) getEntityFromObject o = case o ^? key k of Nothing -> fail $ "Cannot parse Entity. JSON value doesn't have the key \"" <> toS k <> "\"" Just v -> do parsedField <- parseJSON v ent <- getEntityFromObject @fs @a o return (ent & getEntity . tableFieldLens @a @f .~ parsedField) where k = toS (symbolVal (Proxy :: Proxy f)) instance ( GetEntityFromValue (SetFields miss a) a , SetEqual (MissingFieldsFromValue (SetFields miss a) a) miss ) => FromJSON (Entity ('Fresh miss) a) where parseJSON = fmap (reorderMissingFieldsTo @miss) . getEntityFromObject @(SetFields miss a) @a class (TableField table field, Ord (TableFieldType table field)) => OrdableField table field instance (TableField table field, Ord (TableFieldType table field)) => OrdableField table field class (TableField table field, Eq (TableFieldType table field)) => EqableField table field instance (TableField table field, Eq (TableFieldType table field)) => EqableField table field instance ( AllSatisfy (OrdableField a) (SetFields (MissingFields entKind) a) , Eq (Entity entKind a) ) => Ord (Entity entKind a) where compare a b = mconcat $ mapTypeList (Proxy @(OrdableField a)) (\(_ :: proxy f) -> compare (a ^. getEntity . tableFieldLens @a @f) (b ^. getEntity . tableFieldLens @a @f)) (Proxy @(SetFields (MissingFields entKind) a)) instance ( AllSatisfy (EqableField a) (SetFields (MissingFields entKind) a) ) => Eq (Entity entKind a) where (==) a b = and $ mapTypeList (Proxy @(EqableField a)) (\(_ :: proxy f) -> (a ^. getEntity . tableFieldLens @a @f) == (b ^. getEntity . tableFieldLens @a @f)) (Proxy @(SetFields (MissingFields entKind) a)) class TableFieldTypes a fs ~ ts => FoldCompositeIntoEntity fs ts a where foldCompositeIntoEntity :: Entity entKind a -> Composite ts -> Entity ('Fresh '[]) a instance FoldCompositeIntoEntity '[] '[] a where foldCompositeIntoEntity e _ = coerce e instance ( TableField a f , TableFieldType a f ~ t , FoldCompositeIntoEntity fs ts a) => FoldCompositeIntoEntity (f ': fs) (t ': ts) a where foldCompositeIntoEntity ent (ConsComposite x xs) = foldCompositeIntoEntity @fs @ts (ent & getEntity . tableFieldLens @a @f .~ x) xs compositeToEntity :: forall a fs ts. ( fs ~ TableFields a , ts ~ TableFieldTypes a fs , FoldCompositeIntoEntity fs ts a , Table a ) => Composite ts -> Entity ('Fresh '[]) a compositeToEntity = foldCompositeIntoEntity @(TableFields a) newEntity instance ( fs ~ TableFields a , ts ~ TableFieldTypes a fs , FoldCompositeIntoEntity fs ts a , FieldParsers ts , Table a ) => FromField (Entity ('FromDb 'Live) a) where fromField f b = coerce @(Entity ('Fresh '[]) a) . compositeToEntity <$> fromField f b type family SameTypes toTable (toFields :: [Symbol]) fromTable (fromFields :: [Symbol]) :: Constraint where SameTypes toTable '[] fromTable '[] = () SameTypes toTable (x ': xs) fromTable (y ': ys) = (TableFieldType toTable x ~ TableFieldType fromTable y, SameTypes toTable xs fromTable ys) class ( KnownSymbol (TableName table) , AllSatisfy (TableField table) (TableFields table) , AllSatisfy KnownSymbol (TableFields table) , AllSatisfy (ValidConstraint table) (TableConstraints table) , AllTypesSatisfy (TypeSatisfies ToField) table (TableFields table) , OnMaybe (() :: Constraint) PrimaryKeyConstraint (TablePrimaryKey table) , FromRow table ) => Table table where type TableName table = (name :: Symbol) | name -> table type TableFields table :: [Symbol] type TableConstraints table :: [FieldConstraint] type TablePrimaryKey table :: Maybe Symbol type TableRequiredFields table :: [MissingField] newEntity :: Entity ('Fresh (TableRequiredFields table)) table class ValidConstraint (table :: *) (constr :: FieldConstraint) instance (UniqueConstraint name, table ~ UniqueTable name) => ValidConstraint table ('Unique name) instance (ForeignKeyConstraint name, table ~ ForeignKeyFrom name) => ValidConstraint table ('ForeignKey name) getDbFields :: forall table. Table table => [Text] getDbFields = mapTypeList (Proxy @KnownSymbol) (toS . symbolVal) (Proxy @(TableFields table)) type family IsDbExp a :: Bool where IsDbExp (DbExp k a) = 'True IsDbExp a = 'False type family KindOfDbExp a :: ExpressionKind where KindOfDbExp (DbExp k a) = k KindOfDbExp a = 'LiteralExp type family IsDbStatement (m :: k -> *) :: Bool where IsDbStatement (DbStatement r) = 'True IsDbStatement a = 'False class ValueAsDbExp' (IsDbExp a) a b => ValueAsDbExp a b where valueAsDbExp :: a -> DbExp (KindOfDbExp a) b instance ValueAsDbExp' (IsDbExp a) a b => ValueAsDbExp a b where valueAsDbExp = valueAsDbExp' @(IsDbExp a) class ValueAsDbExp' (isDbExp :: Bool) a b where valueAsDbExp' :: a -> DbExp (KindOfDbExp a) b instance (DbExp k b ~ a) => ValueAsDbExp' 'True a b where valueAsDbExp' = identity instance (a ~ b, ToField a, KindOfDbExp a ~ 'LiteralExp) => ValueAsDbExp' 'False a b where valueAsDbExp' = Literal type family CapsName table name where CapsName table name = CapsName' name (TableFieldCapsName table name) type family CapsName' name capsName where CapsName' name 'Nothing = name CapsName' name ('Just cName) = cName class ( KnownSymbol name, KnownSymbol (CapsName table name) , IsDbExp (TableFieldType table name) ~ 'False ) => TableField (table :: *) (name :: Symbol) where type TableFieldType table name :: * type TableFieldCapsName table name :: Maybe Symbol type TableFieldCapsName table name = 'Nothing tableFieldLens :: Lens' table (TableFieldType table name) class ( UniqueConstraint name , AllTypesSatisfy NotNull (UniqueTable name) (UniqueFields name) ) => PrimaryKeyConstraint (name :: Symbol) class ( AllSatisfy (TableField (UniqueTable name)) (UniqueFields name) , KnownSymbol name ) => UniqueConstraint (name :: Symbol) where type UniqueTable name :: * type UniqueFields name :: [Symbol] class ( KnownSymbol name , AllSatisfy (TableField (ForeignKeyFrom name)) (ForeignKeyFromFields name) , AllSatisfy (TableField (ForeignKeyTo name)) (ForeignKeyToFields name) , SameTypes (ForeignKeyTo name) (ForeignKeyToFields name) (ForeignKeyFrom name) (ForeignKeyFromFields name) ) => ForeignKeyConstraint (name :: Symbol) where type ForeignKeyFrom name :: * type ForeignKeyTo name :: * type ForeignKeyFromFields name :: [Symbol] type ForeignKeyToFields name :: [Symbol] type family MissingFieldName (f :: MissingField) :: Symbol where MissingFieldName ('Required s) = s MissingFieldName ('DynamicDefault s) = s type family MissingFieldsNames (fs :: [MissingField]) :: [Symbol] where MissingFieldsNames '[] = '[] MissingFieldsNames (f ': fs) = MissingFieldName f ': MissingFieldsNames fs type family WithFieldSet (field :: Symbol) (entKind :: EntityKind) :: EntityKind where WithFieldSet field ('FromDb c) = 'FromDb c WithFieldSet field ('Fresh missing) = 'Fresh (WithoutMissingField field missing) type family WithFieldsSet (fields :: [Symbol]) (entKind :: EntityKind) :: EntityKind where WithFieldsSet '[] entKind = entKind WithFieldsSet (f ': fs) entKind = WithFieldSet f (WithFieldsSet fs entKind) WithFieldsSet field ('FromDb c) = 'FromDb c type family WithoutMissingField (name :: Symbol) (fs :: [MissingField]) :: [MissingField] where WithoutMissingField name '[] = '[] WithoutMissingField name ('Required name ': fs) = fs WithoutMissingField name ('DynamicDefault name ': fs) = fs WithoutMissingField name (f ': fs) = f ': WithoutMissingField name fs type family WithoutMissingFields (fields :: [Symbol]) (fs :: [MissingField]) :: [MissingField] where WithoutMissingFields '[] ms = ms WithoutMissingFields (f ': fs) ms = WithoutMissingField f (WithoutMissingFields fs ms) type CanInsert entKind table = (Table table, CanInsertFresh (MissingFields entKind) table) type family CanInsert' (entKind :: EntityKind) (table :: *) :: Constraint where CanInsert' ('Fresh missing) table = CanInsertFresh missing table CanInsert' ('FromDb c) table = () type CanInsertFresh (missing :: [MissingField]) (table :: *) = ( CanInsertMissing missing , SetFields missing table `IsSubset` SetFields missing table -- needed for the compile function , AllSatisfy (HasCapsFieldName table) (SetFields missing table) , AllTypesSatisfy (TypeSatisfies ToField) table (SetFields missing table) ) type family CanInsertMissing (fs :: [MissingField]) :: Constraint where CanInsertMissing '[] = () CanInsertMissing ('DynamicDefault name ': fs) = CanInsertMissing fs CanInsertMissing (f ': fs) = TypeError ( ErrorText "Can't insert entity because the required field " ':<>: 'ShowType (MissingFieldName f) ':<>: ErrorText " is not set" ) type CanUpdate table pk = ( KnownSymbol pk , Table table , SetFields '[] table `IsSubset` SetFields '[] table -- needed for the compile function ) type DbResult list = ListToTuple (Entity ('FromDb 'Live)) list type Variables ctx list = ListToTuple (Var ctx) list class TableSetVars ctx (tables :: [*]) where makeVars :: Variables ctx tables instance TableSetVars ctx '[] where makeVars = () instance TableSetVars ctx '[a] where makeVars = Var 0 instance TableSetVars ctx '[a, b] where makeVars = (Var 0, Var 1) instance TableSetVars ctx '[a, b, c] where makeVars = (Var 0, Var 1, Var 2) data BoolOp = And | Or deriving (Eq, Ord, Read, Show) data ResultType = Filtered | Unfiltered | Inserted | Deleted | Updated | Sorted | Limited | Grouped | Mapped | Folded | RawQueried type family Selection (t :: ResultType) :: Constraint where Selection 'Filtered = () Selection 'Unfiltered = () type family CanTake (t :: ResultType) :: Constraint where CanTake 'Filtered = () CanTake 'Unfiltered = () CanTake 'Sorted = () CanTake 'Mapped = () type family CanAggregate (t :: ResultType) :: Constraint where CanAggregate 'Filtered = () CanAggregate 'Unfiltered = () CanAggregate 'Grouped = () type family CanMap (f :: ResultType) :: Constraint where CanMap 'Unfiltered = () CanMap 'Filtered = () CanMap 'Grouped = () CanMap 'Sorted = () type FieldIsGettableBool field missing = Not (field `Elem` MissingFieldsNames missing) type FieldIsGettable field missing = CheckWithError (FieldIsGettableBool field missing) (ErrorText "Field " ':<>: 'ShowType field ':<>: ErrorText " is not set") type FieldIsNotSet field setFields = CheckWithError (Not (Elem field setFields)) ( ErrorText "Cannot update the field " ':<>: 'ShowType field ':<>: ErrorText " because it's already updated in this expression") varFromUpdateExp :: UpdateExp fields t -> Var 'Updating t varFromUpdateExp (NoUpdate v) = v varFromUpdateExp (SetField _ v _) = varFromUpdateExp v type family ListToSimpleTuple (l :: [*]) :: * where ListToSimpleTuple '[] = () ListToSimpleTuple '[a] = PSQL.Only a ListToSimpleTuple '[a, b] = (a, b) ListToSimpleTuple '[a, b, c] = (a, b, c) ListToSimpleTuple '[a, b, c, d] = (a, b, c, d) ListToSimpleTuple '[a, b, c, d, e] = (a, b, c, d, e) type family TupleToList (map :: *) :: [*] where TupleToList () = '[] TupleToList (PSQL.Only a) = TupleToList a TupleToList (a, b) = TupleToList a ++ TupleToList b TupleToList (a, b, c) = TupleToList a ++ TupleToList b ++ TupleToList c TupleToList (a, b, c, d) = TupleToList a ++ TupleToList b ++ TupleToList c ++ TupleToList d TupleToList (a, b, c, d, e) = TupleToList a ++ TupleToList b ++ TupleToList c ++ TupleToList d ++ TupleToList e TupleToList a = '[a] type FlattenTuple t = ListToSimpleTuple (TupleToList t) instance (k ~ 'LiteralExp, Num a, ToField a) => Num (DbExp k a) where fromInteger = Literal . fromInteger instance k ~ 'LiteralExp => IsString (DbExp k Text) where fromString = Literal . toS data DbStatement (resultType :: ResultType) (ts :: [*]) where Table :: Table table => proxy (TableName table) -> DbStatement 'Unfiltered '[table] Filter :: (TableSetVars 'Filtering tables, Selection f) => (Variables 'Filtering tables -> ConditionExp) -> DbStatement f tables -> DbStatement 'Filtered tables Join :: DbStatement 'Unfiltered tables1 -> DbStatement 'Unfiltered tables2 -> DbStatement 'Unfiltered (tables1 ++ tables2) Raw :: ToRow r => Text -> r -> DbStatement 'RawQueried a Execute :: ToRow r => Text -> r -> DbStatement 'RawQueried '[] Insert :: CanInsert missing table => Entity missing table -> DbStatement 'Inserted '[table] Delete :: (Selection f, Table table) => DbStatement f '[table] -> DbStatement 'Deleted '[table] Update :: (Selection f) => (Var 'Updating table -> UpdateExp fields table) -> DbStatement f '[table] -> DbStatement 'Updated '[a] SortOn :: (Selection f, TableSetVars 'Sorting tables, Sortable ord) => (Variables 'Sorting tables -> ord) -> DbStatement f tables -> DbStatement 'Sorted tables Take :: CanTake f => Int -> DbStatement f tables -> DbStatement 'Limited tables Map :: (Mappable map, CanMap f, TableSetVars 'Mapping tables) => (Variables 'Mapping tables -> map) -> DbStatement f tables -> DbStatement 'Mapped '[MapResult map] AsGroup :: TableSetVars 'Grouping tables => DbStatement f tables -> DbStatement 'Grouped tables GroupMap :: GroupMappable map => ((AsAggregate group, DbStatement 'Grouped tables) -> map) -> GroupStatement group tables -> DbStatement 'Folded '[GroupMapResult map] data GroupStatement group tables where GroupOn :: (Selection f, TableSetVars 'Grouping tables, Groupable group) => (Variables 'Grouping tables -> group) -> DbStatement f tables -> GroupStatement group tables -- | A kind and type used so LiftAggregation can differentiate types like `m a` from -- `AggregateStatement` by their kind. data AM = AM data AggregateStatement aggr (marker :: AM) where Aggregate :: (Aggregatable aggr, CanAggregate f, TableSetVars 'Folding tables) => (Variables 'Folding tables -> aggr) -> DbStatement f tables -> AggregateStatement aggr 'AM data UpdateExp (fields :: [Symbol]) (table :: *) where NoUpdate :: Var 'Updating table -> UpdateExp '[] table SetField :: (TableField table fieldName, FieldIsNotSet fieldName fields) => proxy fieldName -> UpdateExp fields table -> DbExp k (TableFieldType table fieldName) -> UpdateExp (fieldName ': fields) table data ConditionExp where Compare :: Ord a => Comparison -> DbExp k1 a -> DbExp k2 a -> ConditionExp BoolOp :: BoolOp -> ConditionExp -> ConditionExp -> ConditionExp IsNull :: DbExp 'FieldExp (Maybe a) -> ConditionExp IsNotNull :: DbExp 'FieldExp (Maybe a) -> ConditionExp In :: LiteralCollection collection a => DbExp k a -> collection -> ConditionExp Like :: Bool -> DbExp 'FieldExp Text -> Text -> ConditionExp BoolLit :: Bool -> ConditionExp data ExpressionKind = FieldExp | LiteralExp data DbExp (kind :: ExpressionKind) a where Field :: TableField table fieldName => proxy1 table -> proxy2 fieldName -> Var anyCtx table -> DbExp 'FieldExp (TableFieldType table fieldName) Literal :: ToField a => a -> DbExp 'LiteralExp a data SomeDbExp where SomeDbExp :: DbExp k a -> SomeDbExp SomeVar :: Var k a -> SomeDbExp class Sortable ord where getOrdering :: ord -> [(SomeDbExp, SortDirection)] instance Ord a => Sortable (DbExp k a) where getOrdering e = [(SomeDbExp e, Ascending)] instance Sortable a => Sortable (Down a) where getOrdering (Down a) = fmap (second flipDirection) (getOrdering a) where flipDirection Ascending = Descending flipDirection Descending = Ascending instance (Sortable a, Sortable b) => Sortable (a, b) where getOrdering (a, b) = getOrdering a <> getOrdering b instance (Sortable a, Sortable b, Sortable c) => Sortable (a, b, c) where getOrdering (a, b, c) = getOrdering a <> getOrdering b <> getOrdering c class LiteralCollection collection a | collection -> a where getLiteralCollection :: collection -> [SomeDbExp] instance a ~ b => LiteralCollection (DbExp k a) b where getLiteralCollection e = [SomeDbExp e] instance (LiteralCollection a x, LiteralCollection b x) => LiteralCollection (a, b) x where getLiteralCollection (a, b) = getLiteralCollection a <> getLiteralCollection b instance (LiteralCollection a x, LiteralCollection b x, LiteralCollection c x) => LiteralCollection (a, b, c) x where getLiteralCollection (a, b, c) = getLiteralCollection a <> getLiteralCollection b <> getLiteralCollection c instance DbExp b x ~ a => LiteralCollection [a] x where getLiteralCollection as = as >>= getLiteralCollection class Groupable group where -- | Wrapps every DbExp in the tuple with the GroupMappableDbExp type AsAggregate group :: * getGrouping :: group -> [SomeDbExp] asAggregate :: group -> AsAggregate group instance Groupable (DbExp k a) where type AsAggregate (DbExp k a) = GroupMappableThing a 'AM getGrouping e = [SomeDbExp e] asAggregate = GroupMappableDbExp instance (Table a, TablePrimaryKey a ~ 'Just pk, AllSatisfy (TableField a) (UniqueFields pk)) => Groupable (Var 'Grouping a) where type AsAggregate (Var 'Grouping a) = GroupMappableThing (Entity ('FromDb 'Live) a) 'AM getGrouping v = mapTypeList (Proxy @(TableField a)) (\(_ :: proxy f) -> SomeDbExp (Field (Proxy @a) (Proxy @f) v)) (Proxy @(UniqueFields pk)) asAggregate = GroupMappableVar instance (Groupable a, Groupable b) => Groupable (a, b) where type AsAggregate (a, b) = (AsAggregate a, AsAggregate b) getGrouping (a, b) = getGrouping a <> getGrouping b asAggregate (a, b) = (asAggregate a, asAggregate b) instance (Groupable a, Groupable b, Groupable c) => Groupable (a, b, c) where type AsAggregate (a, b, c) = (AsAggregate a, AsAggregate b, AsAggregate c) getGrouping (a, b, c) = getGrouping a <> getGrouping b <> getGrouping c asAggregate (a, b, c) = (asAggregate a, asAggregate b, asAggregate c) instance (Groupable a, Groupable b, Groupable c, Groupable d) => Groupable (a, b, c, d) where type AsAggregate (a, b, c, d) = (AsAggregate a, AsAggregate b, AsAggregate c, AsAggregate d) getGrouping (a, b, c, d) = getGrouping a <> getGrouping b <> getGrouping c <> getGrouping d asAggregate (a, b, c, d) = (asAggregate a, asAggregate b, asAggregate c, asAggregate d) data GroupMappableThing res (am :: AM) where GroupMappableDbExp :: DbExp k a -> GroupMappableThing a 'AM GroupMappableVar :: Var k a -> GroupMappableThing (Entity ('FromDb 'Live) a) 'AM GroupMappableAggr :: Aggregatable aggr => AggregateStatement aggr 'AM -> GroupMappableThing (AggregationResult aggr) 'AM type family GroupMapResultBase a where GroupMapResultBase (GroupMappableThing res 'AM) = res class GroupMappableBase map where getGroupMappingBase :: map -> [(Sql.AggregateFunction, SomeDbExp)] instance GroupMappableThing res 'AM ~ a => GroupMappableBase a where getGroupMappingBase (GroupMappableDbExp d) = [(Sql.Only, SomeDbExp d)] getGroupMappingBase (GroupMappableVar v) = [(Sql.Only, SomeVar v)] getGroupMappingBase (GroupMappableAggr as) = getAggregating (getAggr as) type family GroupMapResult (map :: *) :: * where GroupMapResult (a, b) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b) GroupMapResult (a, b, c) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b, GroupMapResultBase c) GroupMapResult (a, b, c, d) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b, GroupMapResultBase c, GroupMapResultBase d) GroupMapResult (a, b, c, d, e) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b, GroupMapResultBase c, GroupMapResultBase d, GroupMapResultBase e) GroupMapResult a = FlattenTuple (PSQL.Only (GroupMapResultBase a)) class GroupMappable map where getGroupMapping :: map -> [(Sql.AggregateFunction, SomeDbExp)] instance (GroupMappableBase a, GroupMappableBase b) => GroupMappable (a, b) where getGroupMapping (a, b) = getGroupMappingBase a <> getGroupMappingBase b instance (GroupMappableBase a, GroupMappableBase b, GroupMappableBase c) => GroupMappable (a, b, c) where getGroupMapping (a, b, c) = getGroupMappingBase a <> getGroupMappingBase b <> getGroupMappingBase c instance (GroupMappableBase a, GroupMappableBase b, GroupMappableBase c, GroupMappableBase d) => GroupMappable (a, b, c, d) where getGroupMapping (a, b, c, d) = getGroupMappingBase a <> getGroupMappingBase b <> getGroupMappingBase c <> getGroupMappingBase d instance (GroupMappableBase a, GroupMappableBase b, GroupMappableBase c, GroupMappableBase d, GroupMappableBase e) => GroupMappable (a, b, c, d, e) where getGroupMapping (a, b, c, d, e) = getGroupMappingBase a <> getGroupMappingBase b <> getGroupMappingBase c <> getGroupMappingBase d <> getGroupMappingBase e instance {-# OVERLAPPABLE #-} GroupMappableBase (m a) => GroupMappable (m (a :: AM)) where getGroupMapping = getGroupMappingBase -- | So dfoldMap knows to behave like an expression when used inside of a dmap type family InterpretAsGroupMap (a :: *) :: Bool where InterpretAsGroupMap (a, b) = 'True InterpretAsGroupMap (a, b, c) = 'True InterpretAsGroupMap (a, b, c, d) = 'True InterpretAsGroupMap (a, b, c, d, e) = 'True InterpretAsGroupMap (a, b, c, d, e, f) = 'True InterpretAsGroupMap (m (a :: *)) = 'False InterpretAsGroupMap a = 'True class MappableBase map where type MapResultBase map :: * getMappingBase :: map -> [SomeDbExp] instance MappableBase (DbExp k a) where type MapResultBase (DbExp k a) = PSQL.Only a getMappingBase d = [SomeDbExp d] instance (Table t) => MappableBase (Var 'Mapping t) where type MapResultBase (Var 'Mapping t) = Entity ('FromDb 'Live) t getMappingBase v = mapTypeList (Proxy @(TableField t)) (\p -> SomeDbExp (Field (Proxy @t) p v)) (Proxy @(TableFields t)) type family MapResult (map :: *) :: * where MapResult (a, b) = FlattenTuple (MapResultBase a, MapResultBase b) MapResult (a, b, c) = FlattenTuple (MapResultBase a, MapResultBase b, MapResultBase c) MapResult (a, b, c, d) = FlattenTuple (MapResultBase a, MapResultBase b, MapResultBase c, MapResultBase d) MapResult (a, b, c, d, e) = FlattenTuple (MapResultBase a, MapResultBase b, MapResultBase c, MapResultBase d, MapResultBase e) MapResult a = MapResultBase a class Mappable map where getMapping :: map -> [SomeDbExp] instance (MappableBase a, MappableBase b) => Mappable (a, b) where getMapping (a, b) = getMappingBase a <> getMappingBase b instance (MappableBase a, MappableBase b, MappableBase c) => Mappable (a, b, c) where getMapping (a, b, c) = getMappingBase a <> getMappingBase b <> getMappingBase c instance (MappableBase a, MappableBase b, MappableBase c, MappableBase d) => Mappable (a, b, c, d) where getMapping (a, b, c, d) = getMappingBase a <> getMappingBase b <> getMappingBase c <> getMappingBase d instance (MappableBase a, MappableBase b, MappableBase c, MappableBase d, MappableBase e) => Mappable (a, b, c, d, e) where getMapping (a, b, c, d, e) = getMappingBase a <> getMappingBase b <> getMappingBase c <> getMappingBase d <> getMappingBase e instance {-# OVERLAPPABLE #-} MappableBase a => Mappable a where getMapping = getMappingBase getAggr :: AggregateStatement aggr 'AM -> aggr getAggr (Aggregate f (_ :: DbStatement f ts)) = f (makeVars @'Folding @ts) newtype Avg a = Avg a newtype Count a = Count a newtype Only a = Only a newtype List a = List a class AggregatableBase aggr where type AggregationBaseResult aggr :: * getAggregatingBase :: aggr -> (Sql.AggregateFunction, SomeDbExp) instance Ord a => AggregatableBase (Max (DbExp f a)) where type AggregationBaseResult (Max (DbExp f a)) = a getAggregatingBase (Max e) = (Sql.Max, SomeDbExp e) instance Ord a => AggregatableBase (Min (DbExp f a)) where type AggregationBaseResult (Min (DbExp f a)) = a getAggregatingBase (Min e) = (Sql.Min, SomeDbExp e) instance Num a => AggregatableBase (Avg (DbExp f a)) where type AggregationBaseResult (Avg (DbExp f a)) = a getAggregatingBase (Avg e) = (Sql.Avg, SomeDbExp e) instance AggregatableBase (Count (DbExp f a)) where type AggregationBaseResult (Count (DbExp f a)) = a getAggregatingBase (Count e) = (Sql.Count, SomeDbExp e) instance Num a => AggregatableBase (Sum (DbExp f a)) where type AggregationBaseResult (Sum (DbExp f a)) = a getAggregatingBase (Sum e) = (Sql.Sum, SomeDbExp e) instance AggregatableBase (Only (DbExp f a)) where type AggregationBaseResult (Only (DbExp f a)) = a getAggregatingBase (Only e) = (Sql.Only, SomeDbExp e) instance AggregatableBase (List (DbExp f a)) where type AggregationBaseResult (List (DbExp f a)) = PSQL.PGArray a getAggregatingBase (List e) = (Sql.ArrayAgg, SomeDbExp e) instance AggregatableBase (List (Var 'Folding a)) where type AggregationBaseResult (List (Var 'Folding a)) = PSQL.PGArray (Entity ('FromDb 'Live) a) getAggregatingBase (List v) = (Sql.ArrayAgg, SomeVar v) type family BadAggregateBaseError where BadAggregateBaseError = TypeError ( ErrorText "The only types that can exist in a fold expression are expressions \ \involving entity fields wrapped in one of the Monoid newtypes." ':$$: ErrorText "Along with the newtypes from Data.Monoid (Max, Min, Sum), there are \ \Avg, Count and List." ':$$: ErrorText "List can be applied to the whole entity, instead of just to it's fields." ':$$: ErrorText "Example: dfoldMap (\\e -> (Max (e ^. height), Avg (e ^. weigth))) t") instance {-# OVERLAPPABLE #-} BadAggregateBaseError => AggregatableBase a where type family AggregationResult (aggr :: *) where AggregationResult (a, b) = (AggregationBaseResult a, AggregationBaseResult b) AggregationResult (a, b, c) = (AggregationBaseResult a, AggregationBaseResult b, AggregationBaseResult c) AggregationResult a = PSQL.Only (AggregationBaseResult a) class Aggregatable aggr where getAggregating :: aggr -> [(Sql.AggregateFunction, SomeDbExp)] instance (AggregatableBase a, AggregatableBase b) => Aggregatable (a, b) where getAggregating (a, b) = [getAggregatingBase a, getAggregatingBase b] instance (AggregatableBase a, AggregatableBase b, AggregatableBase c) => Aggregatable (a, b, c) where getAggregating (a, b, c) = [getAggregatingBase a, getAggregatingBase b, getAggregatingBase c] instance {-# OVERLAPPABLE #-} AggregatableBase a => Aggregatable a where getAggregating a = [getAggregatingBase a] nameText :: forall name. KnownSymbol name => Text nameText = toS (symbolVal (Proxy @name))