{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses, AllowAmbiguousTypes #-}
module Internal.Data.Basic.Virtual where

import Internal.Interlude

import GHC.TypeLits
import Control.Lens

import Internal.Data.Basic.Types
import Internal.Data.Basic.Common
import Internal.Data.Basic.Lens
import Internal.Data.Basic.Compare

import Database.PostgreSQL.Simple.ToField (ToField)

fieldMatch :: forall (toField :: Symbol) (fromField :: Symbol) toTable fromTable c.
              ( TableField toTable toField, TableField fromTable fromField
              , TableFieldType toTable toField ~ TableFieldType fromTable fromField
              , Ord (TableFieldType toTable toField)
              , ToField (TableFieldType toTable toField) )
           => Entity ('FromDb c) toTable -> Var 'Filtering fromTable -> ConditionExp
fieldMatch toTable fromTable =
    Literal (toTable ^. fieldOptic @toField) ==. fromTable ^. fieldOptic @fromField

class ( Table fromTable, Table toTable
      , AllSatisfy (TableField fromTable) fromFields
      , AllSatisfy (TableField toTable)   toFields
      , SameTypes toTable toFields fromTable fromFields
      , AllTypesSatisfy (TypeSatisfies Ord) fromTable fromFields
      , AllTypesSatisfy (TypeSatisfies ToField) fromTable fromFields )
      => AllFieldsMatch (toFields :: [Symbol]) (fromFields :: [Symbol]) toTable fromTable where
    allFieldsMatch :: Entity ('FromDb c) toTable -> Var 'Filtering fromTable -> ConditionExp

instance ( Table fromTable, Table toTable
         , TableField fromTable fromField
         , TableField toTable   toField
         , TableFieldType fromTable fromField ~ TableFieldType toTable toField
         , Ord (TableFieldType toTable toField), ToField (TableFieldType fromTable fromField) )
         => AllFieldsMatch '[toField] '[fromField] toTable fromTable where
    allFieldsMatch = fieldMatch @toField @fromField

instance {-# OVERLAPPABLE #-}
         ( Table fromTable, Table toTable
         , TableField fromTable fromField
         , TableField toTable   toField
         , TableFieldType fromTable fromField ~ TableFieldType toTable toField
         , Ord (TableFieldType toTable toField), ToField (TableFieldType fromTable fromField)
         , AllFieldsMatch toFields fromFields toTable fromTable )
         => AllFieldsMatch (toField ': toFields) (fromField ': fromFields) toTable fromTable where
    allFieldsMatch toTable fromTable =
         fieldMatch @toField @fromField toTable fromTable
     &&. allFieldsMatch @toFields @fromFields toTable fromTable

virtualTableDbExpLens
    :: forall foreignKeyName c.
       ( ForeignKeyConstraint foreignKeyName
       , AllFieldsMatch (ForeignKeyToFields foreignKeyName) (ForeignKeyFromFields foreignKeyName)
                        (ForeignKeyTo foreignKeyName) (ForeignKeyFrom foreignKeyName) )
    => Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName))
               (DbStatement 'Filtered '[ForeignKeyFrom foreignKeyName])
virtualTableDbExpLens = to $ \u ->
    dfilter (allFieldsMatch @(ForeignKeyToFields foreignKeyName)
                            @(ForeignKeyFromFields foreignKeyName)
                            u)
            (allRows @(TableName (ForeignKeyFrom foreignKeyName)))

type VirtualTable foreignKeyName res =
    ( ForeignKeyConstraint foreignKeyName
    , AllFieldsMatch (ForeignKeyToFields foreignKeyName) (ForeignKeyFromFields foreignKeyName)
                     (ForeignKeyTo foreignKeyName) (ForeignKeyFrom foreignKeyName)
    , LiftedStatement 'Filtered '[(ForeignKeyFrom foreignKeyName)] res )

virtualTableLens :: forall foreignKeyName c res. VirtualTable foreignKeyName res
                 => Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName)) (res)
virtualTableLens = to (\u -> liftDbExp (u ^. expLens))
    where expLens = virtualTableDbExpLens @foreignKeyName

virtualTableLensProxy ::
    forall foreignKeyName res c proxy. VirtualTable foreignKeyName res
    => proxy foreignKeyName -> Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName)) (res)
virtualTableLensProxy _ = virtualTableLens @foreignKeyName