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

import Internal.Interlude

import Control.Lens
import GHC.TypeLits
import Overload

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

import Database.PostgreSQL.Simple.ToField (ToField)

class ForeignKeyConstraint fk
    => ForeignKeyFieldsMatch (fk :: Symbol) (fromFields :: [Symbol]) (toFields :: [Symbol]) where
    foreignKeyFieldsMatch :: Entity ('FromDb c) (ForeignKeyFrom fk)
                          -> Var 'Filtering (ForeignKeyTo fk) -> ConditionExp
    foreignKeyFieldsSet :: Entity entKind (ForeignKeyFrom fk)
                        -> Entity ('FromDb c) (ForeignKeyTo fk)
                        -> Entity (WithFieldsSet fromFields entKind) (ForeignKeyFrom fk)

instance ( ForeignKeyConstraint fk
         , from ~ ForeignKeyFrom fk
         , to   ~ ForeignKeyTo fk
         , TableField to toField
         , TableField from fromField
         , TableFieldType to toField ~ TableFieldType from fromField
         , ToField (TableFieldType from fromField)
         , Ord (TableFieldType to toField)
         , KindOfDbExp (TableFieldType from fromField) ~ 'LiteralExp )
    => ForeignKeyFieldsMatch fk '[fromField] '[toField] where
    foreignKeyFieldsMatch ent var = ent ^. fieldOptic @fromField ==. var ^. fieldOptic @toField
    foreignKeyFieldsSet ent1 ent2 =
        ent1 & fieldOpticEntitySet @fromField .~ (ent2 ^. fieldOptic @toField)

instance ( from ~ ForeignKeyFrom fk
         , to   ~ ForeignKeyTo fk
         , TableField to toField
         , TableField from fromField
         , TableFieldType to toField ~ TableFieldType from fromField
         , ToField (TableFieldType from fromField)
         , Ord (TableFieldType to toField)
         , ForeignKeyFieldsMatch fk (f1 ': f1s) (f2 ': f2s)
         , KindOfDbExp (TableFieldType from fromField) ~ 'LiteralExp )
    => ForeignKeyFieldsMatch fk (fromField ': (f1 ': f1s)) (toField ': (f2 ': f2s)) where
    foreignKeyFieldsMatch ent var =
            (ent ^. fieldOptic @fromField ==. var ^. fieldOptic @toField)
        &&. foreignKeyFieldsMatch @fk @(f1 ': f1s) @(f2 ': f2s) ent var
    foreignKeyFieldsSet ent1 ent2 =
        foreignKeyFieldsSet @fk @(f1 ': f1s) @(f2 ': f2s) ent1 ent2
            & fieldOpticEntitySet @fromField .~ (ent2 ^. fieldOptic @toField)

type ForeignKeyLensGet fk m =
    ( ForeignKeyConstraint fk
    , MonadEffect Basic m
    , Table (ForeignKeyFrom fk)
    , Table (ForeignKeyTo fk)
    , ForeignKeyFieldsMatch fk (ForeignKeyFromFields fk) (ForeignKeyToFields fk) )

foreignKeyLensGet :: forall fk m proxy. ForeignKeyLensGet fk m
                  => proxy fk
                  -> Getter' (Entity ('FromDb 'Live) (ForeignKeyFrom fk))
                             (m (Entity ('FromDb 'Live) (ForeignKeyTo fk)))
foreignKeyLensGet _ = to $ \ent -> do
    [e] <- dfilter (foreignKeyFieldsMatch @fk @(ForeignKeyFromFields fk) @(ForeignKeyToFields fk)
                                          ent)
                   (allRows @(TableName (ForeignKeyTo fk)))
    return e

type ForeignKeyLensSet fk =
    ( ForeignKeyConstraint fk
    , ForeignKeyFieldsMatch fk (ForeignKeyFromFields fk) (ForeignKeyToFields fk) )

foreignKeyLensSet :: forall fk entKind c proxy. ForeignKeyLensSet fk
                  => proxy fk
                  -> PolyOptic Identity
                               (Entity entKind (ForeignKeyFrom fk))
                               (Entity (WithFieldsSet (ForeignKeyFromFields fk) entKind)
                                       (ForeignKeyFrom fk))
                               ()
                               (Entity ('FromDb c) (ForeignKeyTo fk))
foreignKeyLensSet _ = \f e ->
    foreignKeyFieldsSet @fk @(ForeignKeyFromFields fk) @(ForeignKeyToFields fk) e <$> f ()

overload "foreignKeyLensProxy" ['foreignKeyLensGet, 'foreignKeyLensSet]

foreignKeyLens :: forall name o. ForeignKeyLensProxy (Proxy name -> o) => o
foreignKeyLens = foreignKeyLensProxy (Proxy :: Proxy name)