{-# 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)

-- | 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 }
    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))