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