{-# 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 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
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)
data MissingField = Required Symbol | DynamicDefault Symbol
data Cached = Live | Cached
data EntityKind = Fresh [MissingField] | FromDb Cached
newtype Entity (entKind :: EntityKind) a = Entity { _getEntity :: a }
deriving (Eq, Ord, Read, Show)
makeLenses ''Entity
toFreshEntity :: forall fs c a. Entity ('FromDb c) a -> Entity ('Fresh fs) a
toFreshEntity (Entity a) = Entity a
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
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)
class GetEntityFromValue (fs :: [Symbol]) a (miss :: [MissingField]) where
getEntityFromObject :: Value -> Parser (Entity ('Fresh miss) a)
instance (Table a, miss ~ TableRequiredFields a) => GetEntityFromValue '[] a miss where
getEntityFromObject (Object _) = return newEntity
getEntityFromObject _ = fail "Cannot parse Entity from JSON that's not an object"
instance
( GetEntityFromValue fs a miss
, miss' ~ WithoutMissingField f miss
, FromJSON (TableFieldType a f)
, TableField a f )
=> GetEntityFromValue (f ': fs) a miss' where
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
Entity ent <- getEntityFromObject @fs @a @miss o
return (Entity (ent & tableFieldLens @a @f .~ parsedField))
where
k = toS (symbolVal (Proxy :: Proxy f))
instance
GetEntityFromValue (SetFields miss a) a miss
=> FromJSON (Entity ('Fresh miss) a) where
parseJSON = getEntityFromObject @(SetFields miss a) @a
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. (MappableList (TableFields 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
class (KnownSymbol name, IsDbExp (TableFieldType table name) ~ 'False)
=> TableField (table :: *) (name :: Symbol) where
type TableFieldType table name :: *
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 KnownSymbol (SetFields missing table), MappableList (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
, MappableList (TableFields table)
)
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
type family Selection (t :: ResultType) :: Constraint where
Selection 'Filtered = ()
Selection 'Unfiltered = ()
type family SelectionOrSortedSelection (t :: ResultType) :: Constraint where
SelectionOrSortedSelection 'Filtered = ()
SelectionOrSortedSelection 'Unfiltered = ()
SelectionOrSortedSelection 'Sorted = ()
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 = ()
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 (DbExp k Key) where
fromInteger = Literal . Key . 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 f a
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 :: SelectionOrSortedSelection 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
In :: LiteralCollection collection a => DbExp k a -> collection -> ConditionExp
data ExpressionKind = FieldExp | LiteralExp
data DbExp (kind :: ExpressionKind) a where
Field :: TableField table fieldName
=> proxy fieldName -> Var anyCtx table -> DbExp 'FieldExp (TableFieldType table fieldName)
Literal :: ToField a => a -> DbExp 'LiteralExp a
data SomeDbExp = forall k a. SomeDbExp (DbExp k a)
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) a 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 (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
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 (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) = a
getMappingBase d = [SomeDbExp d]
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 = FlattenTuple (PSQL.Only (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
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)
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 and Count."
':$$: 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))