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)
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)