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)