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 ()
type ModifyableField table entKind field =
SupportedModifyAccess
(FieldIsGettableBool field (MissingFields entKind))
(TableFieldType table field)
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)
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)
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)
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)