{-# LANGUAGE FunctionalDependencies, AllowAmbiguousTypes, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Internal.Data.Basic.Lens where

import Internal.Interlude
import Control.Lens
import Internal.Data.Basic.Types
import Overload

type PolyOptic fun inType outType inVal outVal = (inVal -> fun outVal) -> inType -> fun outType
type Getter' s a = PolyOptic (Const a) s s a a

fieldOpticVarExp :: forall name t anyCtx proxy. TableField t name
                 => proxy name
                 -> PolyOptic (Const (DbExp 'FieldExp (TableFieldType t name)))
                              (Var anyCtx t) (Var anyCtx t)
                              (DbExp 'FieldExp (TableFieldType t name))
                              (DbExp 'FieldExp (TableFieldType t name))
fieldOpticVarExp p = to (Field p)

fieldOpticEntityGet :: forall name t entKind proxy.
                     ( TableField t name
                     , FieldIsGettable name (MissingFields entKind) )
                    => proxy name
                    -> PolyOptic (Const (TableFieldType t name))
                                 (Entity entKind t) (Entity entKind t)
                                 (TableFieldType t name)
                                 (TableFieldType t name)
fieldOpticEntityGet _ = getEntity . tableFieldLens @_ @name


class SupportedModifyAccess isSet existingValue outVal | isSet outVal -> existingValue where
    transformModifyFunction :: (existingValue -> f outVal) -> outVal -> f outVal
instance SupportedModifyAccess 'True outVal outVal where
    transformModifyFunction = identity
instance SupportedModifyAccess 'False () outVal where
    transformModifyFunction f _ = f ()

fieldOpticEntityModify ::
       forall name t entKind existingValue proxy.
     ( TableField t name
     , SupportedModifyAccess (FieldIsGettableBool name (MissingFields entKind))
                             existingValue
                             (TableFieldType t name) )
    => proxy name
    -> PolyOptic Identity
                 (Entity entKind t) (Entity (WithFieldSet name entKind) t)
                 existingValue
                 (TableFieldType t name)
fieldOpticEntityModify _ = getEntity . transLens
    where transLens f e =
              tableFieldLens @_ @name
                             (transformModifyFunction @(FieldIsGettableBool name
                                                                            (MissingFields entKind))
                                                      f)
                             e

fieldOpticUpdateVarSet :: forall name t val proxy.
                        ( ValueAsDbExp val (TableFieldType t name)
                        , TableField t name )
                       => proxy name
                       -> PolyOptic Identity
                                    (Var 'Updating t) (UpdateExp '[name] t)
                                    (DbExp 'FieldExp (TableFieldType t name))
                                    val
fieldOpticUpdateVarSet p =
    \f v -> SetField p (NoUpdate v) . valueAsDbExp <$> f (Field p v)

fieldOpticUpdatedSet :: forall name t fields val proxy.
                      ( TableField t name
                      , FieldIsNotSet name fields
                      , ValueAsDbExp val (TableFieldType t name) )
                     => proxy name
                     -> PolyOptic Identity
                                  (UpdateExp fields t) (UpdateExp (name ': fields) t)
                                  (DbExp 'FieldExp (TableFieldType t name))
                                  val
fieldOpticUpdatedSet p =
    \f v -> SetField p v . valueAsDbExp <$> f (Field p (varFromUpdateExp v))

overload "fieldOpticProxy" [ 'fieldOpticVarExp
                           , 'fieldOpticEntityGet
                           , 'fieldOpticEntityModify
                           , 'fieldOpticUpdateVarSet
                           , 'fieldOpticUpdatedSet ]

fieldOptic :: forall name o. FieldOpticProxy (Proxy name -> o) => o
fieldOptic = fieldOpticProxy (Proxy :: Proxy name)



----------------
-- Helper lenses
----------------

fieldOpticEntitySet ::
       forall name t missing. TableField t name
    => PolyOptic Identity
                 (Entity missing t) (Entity (WithFieldSet name missing) t)
                 ()
                 (TableFieldType t name)
fieldOpticEntitySet = getEntity . (\f e -> tableFieldLens @_ @name (\_ -> f ()) e)