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)
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
, 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
)
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
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
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 GroupMappableBase (m a) => GroupMappable (m (a :: AM)) where
getGroupMapping = getGroupMappingBase
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 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 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
AggregatableBase a
=> Aggregatable a where
getAggregating a = [getAggregatingBase a]
nameText :: forall name. KnownSymbol name => Text
nameText = toS (symbolVal (Proxy @name))