{-# 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 (Proxy @t) p)

type GettableField entKind field =
    FieldIsGettable field (MissingFields entKind)

fieldOpticEntityGet :: forall name t entKind proxy.
                     ( TableField t name
                     , GettableField entKind name )
                    => 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 outVal where
    type ExistingValue isSet outVal :: *
    transformModifyFunction :: (ExistingValue isSet outVal -> f outVal) -> outVal -> f outVal
instance SupportedModifyAccess 'True outVal where
    type ExistingValue 'True outVal = outVal
    transformModifyFunction = identity
instance SupportedModifyAccess 'False outVal where
    type ExistingValue 'False outVal = ()
    transformModifyFunction f _ = f ()

-- | A field that's settable, but also potentially gettable (if it's already set).
--   If it is gettable then you can modify it, otherwise you can just set it.
type ModifyableField table entKind field =
    SupportedModifyAccess
        (FieldIsGettableBool field (MissingFields entKind))
        (TableFieldType table field)

-- | A synonym for ModifyableField. It still checks if the field is already set.
type SettableField table entKind field = ModifyableField table entKind field

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

{-# ANN fieldOpticUpdateVarSet ("HLint: ignore Redundant lambda" :: Text) #-}
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 (Proxy @t) p v)

{-# ANN fieldOpticUpdatedSet ("HLint: ignore Redundant lambda" :: Text) #-}
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 (Proxy @t) 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)