module Internal.Data.Basic.Virtual where
import Internal.Interlude
import GHC.TypeLits
import Control.Lens
import Internal.Data.Basic.Types
import Internal.Data.Basic.Common
import Internal.Data.Basic.Lens
import Internal.Data.Basic.Compare
import Database.PostgreSQL.Simple.ToField (ToField)
fieldMatch :: forall (toField :: Symbol) (fromField :: Symbol) toTable fromTable c.
( TableField toTable toField, TableField fromTable fromField
, TableFieldType toTable toField ~ TableFieldType fromTable fromField
, Ord (TableFieldType toTable toField)
, ToField (TableFieldType toTable toField) )
=> Entity ('FromDb c) toTable -> Var 'Filtering fromTable -> ConditionExp
fieldMatch toTable fromTable =
Literal (toTable ^. fieldOptic @toField) ==. fromTable ^. fieldOptic @fromField
class ( Table fromTable, Table toTable
, AllSatisfy (TableField fromTable) fromFields
, AllSatisfy (TableField toTable) toFields
, SameTypes toTable toFields fromTable fromFields
, AllTypesSatisfy (TypeSatisfies Ord) fromTable fromFields
, AllTypesSatisfy (TypeSatisfies ToField) fromTable fromFields )
=> AllFieldsMatch (toFields :: [Symbol]) (fromFields :: [Symbol]) toTable fromTable where
allFieldsMatch :: Entity ('FromDb c) toTable -> Var 'Filtering fromTable -> ConditionExp
instance ( Table fromTable, Table toTable
, TableField fromTable fromField
, TableField toTable toField
, TableFieldType fromTable fromField ~ TableFieldType toTable toField
, Ord (TableFieldType toTable toField), ToField (TableFieldType fromTable fromField) )
=> AllFieldsMatch '[toField] '[fromField] toTable fromTable where
allFieldsMatch = fieldMatch @toField @fromField
instance
( Table fromTable, Table toTable
, TableField fromTable fromField
, TableField toTable toField
, TableFieldType fromTable fromField ~ TableFieldType toTable toField
, Ord (TableFieldType toTable toField), ToField (TableFieldType fromTable fromField)
, AllFieldsMatch toFields fromFields toTable fromTable )
=> AllFieldsMatch (toField ': toFields) (fromField ': fromFields) toTable fromTable where
allFieldsMatch toTable fromTable =
fieldMatch @toField @fromField toTable fromTable
&&. allFieldsMatch @toFields @fromFields toTable fromTable
virtualTableDbExpLens
:: forall foreignKeyName c.
( ForeignKeyConstraint foreignKeyName
, AllFieldsMatch (ForeignKeyToFields foreignKeyName) (ForeignKeyFromFields foreignKeyName)
(ForeignKeyTo foreignKeyName) (ForeignKeyFrom foreignKeyName) )
=> Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName))
(DbStatement 'Filtered '[ForeignKeyFrom foreignKeyName])
virtualTableDbExpLens = to $ \u ->
dfilter (allFieldsMatch @(ForeignKeyToFields foreignKeyName)
@(ForeignKeyFromFields foreignKeyName)
u)
(allRows @(TableName (ForeignKeyFrom foreignKeyName)))
type VirtualTable foreignKeyName res =
( ForeignKeyConstraint foreignKeyName
, AllFieldsMatch (ForeignKeyToFields foreignKeyName) (ForeignKeyFromFields foreignKeyName)
(ForeignKeyTo foreignKeyName) (ForeignKeyFrom foreignKeyName)
, LiftedStatement 'Filtered '[(ForeignKeyFrom foreignKeyName)] res )
virtualTableLens :: forall foreignKeyName c res. VirtualTable foreignKeyName res
=> Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName)) (res)
virtualTableLens = to (\u -> liftDbExp (u ^. expLens))
where expLens = virtualTableDbExpLens @foreignKeyName
virtualTableLensProxy ::
forall foreignKeyName res c proxy. VirtualTable foreignKeyName res
=> proxy foreignKeyName -> Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName)) (res)
virtualTableLensProxy _ = virtualTableLens @foreignKeyName