Use FCF to decouple GTable from Table

This commit is contained in:
Shane O'Brien 2021-04-26 22:24:52 +01:00
parent 3e8f632cd1
commit 1276bebbb0
No known key found for this signature in database
GPG Key ID: 35A00ED1B695C1A1
7 changed files with 217 additions and 163 deletions

View File

@ -67,6 +67,7 @@ library
Rel8.Kind.Necessity
Rel8.Generic.Record
Rel8.Generic.Table
Rel8.Order

127
src/Rel8/Generic/Table.hs Normal file
View File

@ -0,0 +1,127 @@
{-# language AllowAmbiguousTypes #-}
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
module Rel8.Generic.Table
( GTable, GColumns, GContext, fromGColumns, toGColumns, gtable
)
where
-- base
import Data.Kind ( Constraint, Type )
import Data.Proxy ( Proxy( Proxy ) )
import GHC.Generics
( (:*:)( (:*:) ), K1( K1 ), M1( M1 )
, C, D, S
, Meta( MetaSel )
)
import GHC.TypeLits ( KnownSymbol )
import Prelude hiding ( null )
-- rel8
import Rel8.FCF ( Eval, Exp )
import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
import Rel8.Schema.HTable.Product ( HProduct(..) )
import qualified Rel8.Schema.Kind as K
type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
type family GColumns _Columns rep where
GColumns _Columns (M1 D _ rep) = GColumns _Columns rep
GColumns _Columns (M1 C _ rep) = GColumns _Columns rep
GColumns _Columns (rep1 :*: rep2) =
HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)
GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
HLabel label (Eval (_Columns a))
type GContext :: (Type -> Exp a) -> (Type -> Type) -> a
type family GContext _Context rep where
GContext _Context (M1 _ _ rep) = GContext _Context rep
GContext _Context (rep1 :*: _rep2) = GContext _Context rep1
GContext _Context (K1 _ a) = Eval (_Context a)
type GTable
:: (Type -> Exp Constraint)
-> (Type -> Exp K.HTable)
-> K.HContext -> (Type -> Type) -> Constraint
class GTable _Table _Columns context rep
where
fromGColumns :: ()
=> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
-> GColumns _Columns rep context
-> rep x
toGColumns :: ()
=> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
-> rep x
-> GColumns _Columns rep context
gtable :: ()
=> (forall a. Eval (_Table a) => Proxy a -> Eval (_Columns a) context)
-> GColumns _Columns rep context
instance GTable _Table _Columns context rep =>
GTable _Table _Columns context (M1 D c rep)
where
fromGColumns fromColumns =
M1 . fromGColumns @_Table @_Columns @context @rep fromColumns
toGColumns toColumns (M1 a) =
toGColumns @_Table @_Columns @context @rep toColumns a
gtable = gtable @_Table @_Columns @context @rep
instance GTable _Table _Columns context rep =>
GTable _Table _Columns context (M1 C c rep)
where
fromGColumns fromColumns =
M1 . fromGColumns @_Table @_Columns @context @rep fromColumns
toGColumns toColumns (M1 a) =
toGColumns @_Table @_Columns @context @rep toColumns a
gtable = gtable @_Table @_Columns @context @rep
instance
( GTable _Table _Columns context rep1
, GTable _Table _Columns context rep2
)
=> GTable _Table _Columns context (rep1 :*: rep2)
where
fromGColumns fromColumns (HProduct a b) =
fromGColumns @_Table @_Columns @context @rep1 fromColumns a :*:
fromGColumns @_Table @_Columns @context @rep2 fromColumns b
toGColumns toColumns (a :*: b) = HProduct
(toGColumns @_Table @_Columns @context @rep1 toColumns a)
(toGColumns @_Table @_Columns @context @rep2 toColumns b)
gtable table = HProduct
(gtable @_Table @_Columns @context @rep1 table)
(gtable @_Table @_Columns @context @rep2 table)
instance
( HTable (Eval (_Columns a))
, Eval (_Table a)
, HLabelable context
, KnownSymbol label
, GColumns _Columns (M1 S meta k1) ~ HLabel label (Eval (_Columns a))
, meta ~ 'MetaSel ('Just label) _su _ss _ds
, k1 ~ K1 i a
)
=> GTable _Table _Columns context (M1 S meta k1)
where
fromGColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler
toGColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)
gtable table = hlabel hlabeler (table (Proxy @a))

View File

@ -3,7 +3,9 @@
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
@ -23,6 +25,9 @@ import Unsafe.Coerce ( unsafeCoerce )
-- rel8
import Rel8.Generic.Record ( Record(..) )
import Rel8.Generic.Table
( GTable, GColumns, fromGColumns, toGColumns
)
import Rel8.Schema.Context ( Col )
import Rel8.Schema.Context.Label ( Labelable )
import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
@ -31,7 +36,7 @@ import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, GTable, GColumns, fromGColumns, toGColumns
, TTable, TColumns
)
@ -96,29 +101,37 @@ type KRel8able = K.Table
-- @
type Rel8able :: KRel8able -> Constraint
class HTable (GRep t) => Rel8able t where
type GRep t :: K.HTable
gfromColumns :: (Labelable context, Reifiable context)
=> GRep t (Col (Reify context)) -> t (Reify context)
gtoColumns :: (Labelable context, Reifiable context)
=> t (Reify context) -> GRep t (Col (Reify context))
default gfromColumns ::
type GRep t = GColumns TColumns (Rep (Record (t (Reify Name))))
default gfromColumns :: forall context.
( Generic (Record (t (Reify context)))
, GColumns (Rep (Record (t (Reify context)))) ~ GRep t
, GTable (Reify context) (Rep (Record (t (Reify context))))
) => GRep t (Col (Reify context)) -> t (Reify context)
gfromColumns = unrecord . to . fromGColumns
, GColumns TColumns (Rep (Record (t (Reify context)))) ~ GRep t
, GTable (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context))))
)
=> GRep t (Col (Reify context)) -> t (Reify context)
gfromColumns =
unrecord .
to .
fromGColumns @(TTable (Reify context)) @TColumns fromColumns
default gtoColumns ::
default gtoColumns :: forall context.
( Generic (Record (t (Reify context)))
, GColumns (Rep (Record (t (Reify context)))) ~ GRep t
, GTable (Reify context) (Rep (Record (t (Reify context))))
) => t (Reify context) -> GRep t (Col (Reify context))
gtoColumns = toGColumns . from . Record
type GRep :: K.Table -> K.HTable
type GRep t = GColumns (Rep (Record (t (Reify Name))))
, GColumns TColumns (Rep (Record (t (Reify context)))) ~ GRep t
, GTable (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context))))
)
=> t (Reify context) -> GRep t (Col (Reify context))
gtoColumns =
toGColumns @(TTable (Reify context)) @TColumns toColumns .
from .
Record
reify ::

View File

@ -14,10 +14,9 @@
{-# language UndecidableInstances #-}
module Rel8.Table
( Table (Columns, Context)
, toColumns, fromColumns
( Table (Columns, Context, toColumns, fromColumns)
, Congruent
, GTable, GColumns, GContext, fromGColumns, toGColumns
, TTable, TColumns, TContext
)
where
@ -26,28 +25,25 @@ import Data.Functor ( ($>) )
import Data.Functor.Identity ( Identity( Identity ) )
import Data.Kind ( Constraint, Type )
import Data.List.NonEmpty ( NonEmpty )
import GHC.Generics
( Generic, Rep, from, to
, (:*:)( (:*:) ), K1( K1 ), M1( M1 )
, C, D, S
, Meta( MetaSel )
)
import GHC.TypeLits ( KnownSymbol )
import GHC.Generics ( Generic, Rep, from, to )
import Prelude hiding ( null )
-- rel8
import Rel8.FCF ( Eval, Exp )
import Rel8.Generic.Table
( GTable, GColumns, GContext, fromGColumns, toGColumns
)
import Rel8.Generic.Record ( Record(..) )
import Rel8.Schema.Context ( Col(..) )
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.HTable.Either ( HEitherTable(..) )
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
import Rel8.Schema.HTable.List ( HListTable )
import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
import Rel8.Schema.HTable.Product ( HProduct(..) )
import Rel8.Schema.HTable.These ( HTheseTable(..) )
import Rel8.Schema.HTable.Type ( HType( HType ) )
import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
@ -85,79 +81,42 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex
toColumns :: a -> Columns a (Col (Context a))
fromColumns :: Columns a (Col (Context a)) -> a
type Columns a = GColumns (Rep (Record a))
type Context a = GContext (Rep (Record a))
type Columns a = GColumns TColumns (Rep (Record a))
type Context a = GContext TContext (Rep (Record a))
default toColumns ::
( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
, Columns a ~ GColumns (Rep (Record a))
, Context a ~ GContext (Rep (Record a))
( Generic (Record a)
, GTable (TTable context) TColumns (Col (Context a)) (Rep (Record a))
, Columns a ~ GColumns TColumns (Rep (Record a))
)
=> a -> Columns a (Col (Context a))
toColumns = toGColumns . from . Record
toColumns =
toGColumns @(TTable context) @TColumns toColumns .
from .
Record
default fromColumns ::
( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
, Columns a ~ GColumns (Rep (Record a))
, Context a ~ GContext (Rep (Record a))
( Generic (Record a)
, GTable (TTable context) TColumns (Col (Context a)) (Rep (Record a))
, Columns a ~ GColumns TColumns (Rep (Record a))
)
=> Columns a (Col (Context a)) -> a
fromColumns = unrecord . to . fromGColumns
fromColumns =
unrecord .
to .
fromGColumns @(TTable context) @TColumns fromColumns
type GColumns :: (Type -> Type) -> K.HTable
type family GColumns rep where
GColumns (M1 D _ rep) = GColumns rep
GColumns (M1 C _ rep) = GColumns rep
GColumns (rep1 :*: rep2) = HProduct (GColumns rep1) (GColumns rep2)
GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
HLabel label (Columns a)
data TTable :: K.Context -> Type -> Exp Constraint
type instance Eval (TTable context a) = Table context a
type GContext :: (Type -> Type) -> K.Context
type family GContext rep where
GContext (M1 _ _ rep) = GContext rep
GContext (rep1 :*: _rep2) = GContext rep1
GContext (K1 _ a) = Context a
data TColumns :: Type -> Exp K.HTable
type instance Eval (TColumns a) = Columns a
type GTable :: K.Context -> (Type -> Type) -> Constraint
class context ~ GContext rep => GTable context rep | rep -> context where
fromGColumns :: GColumns rep (Col context) -> rep x
toGColumns :: rep x -> GColumns rep (Col context)
instance GTable context rep => GTable context (M1 D c rep) where
fromGColumns = M1 . fromGColumns @context @rep
toGColumns (M1 a) = toGColumns @context @rep a
instance GTable context rep => GTable context (M1 C c rep) where
fromGColumns = M1 . fromGColumns @context @rep
toGColumns (M1 a) = toGColumns @context @rep a
instance (GTable context rep1, GTable context rep2) =>
GTable context (rep1 :*: rep2)
where
fromGColumns (HProduct a b) =
fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b
toGColumns (a :*: b) =
HProduct (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)
instance
( Table context a
, Labelable context
, KnownSymbol label
, GColumns (M1 S meta k1) ~ HLabel label (Columns a)
, meta ~ 'MetaSel ('Just label) _su _ss _ds
, k1 ~ K1 i a
)
=> GTable context (M1 S meta k1)
where
fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler
toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)
data TContext :: Type -> Exp K.Context
type instance Eval (TContext a) = Context a
-- | Any 'HTable' is also a 'Table'.

View File

@ -24,28 +24,27 @@ import Data.Foldable ( foldl' )
import Data.Functor.Const ( Const( Const ), getConst )
import Data.Kind ( Constraint, Type )
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import GHC.Generics ( Rep, (:*:), K1, M1, Meta( MetaSel ), D, C, S )
import GHC.TypeLits ( KnownSymbol )
import Data.Proxy ( Proxy )
import GHC.Generics ( Rep )
import Prelude
-- rel8
import Rel8.Expr ( Expr, Col(..) )
import Rel8.Expr.Bool ( (||.), (&&.) )
import Rel8.Expr.Eq ( (==.), (/=.) )
import Rel8.FCF ( Eval, Exp )
import Rel8.Generic.Record ( Record )
import Rel8.Schema.Context.Label ( hlabeler )
import Rel8.Generic.Table ( GTable, GColumns, gtable )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.HTable
( HTable, HConstrainTable
, htabulateA, hfield, hdicts
)
import Rel8.Schema.HTable.Label ( HLabel, hlabel )
import Rel8.Schema.HTable.Product ( HProduct(..) )
import Rel8.Schema.HTable.Type ( HType(..) )
import Rel8.Schema.Kind ( Context )
import Rel8.Schema.Null ( Sql )
import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
import Rel8.Table ( Table, Columns, toColumns, GColumns )
import Rel8.Table ( Table, Columns, toColumns, TColumns )
import Rel8.Type.Eq ( DBEq )
@ -57,39 +56,17 @@ class Table Expr a => EqTable a where
eqTable :: Columns a (Dict (ConstrainDBType DBEq))
default eqTable ::
( GColumns (Rep (Record a)) ~ Columns a
, GEqTable (Rep (Record a))
( GTable TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a))
, Columns a ~ GColumns TColumns (Rep (Record a))
)
=> Columns a (Dict (ConstrainDBType DBEq))
eqTable = geqTable @(Rep (Record a))
eqTable = gtable @TEqTable @TColumns @_ @(Rep (Record a)) table
where
table (_ :: Proxy x) = eqTable @x
type GEqTable :: (Type -> Type) -> Constraint
class GEqTable rep where
geqTable :: GColumns rep (Dict (ConstrainDBType DBEq))
instance GEqTable rep => GEqTable (M1 D c rep) where
geqTable = geqTable @rep
instance GEqTable rep => GEqTable (M1 C c rep) where
geqTable = geqTable @rep
instance (GEqTable rep1, GEqTable rep2) => GEqTable (rep1 :*: rep2) where
geqTable = HProduct (geqTable @rep1) (geqTable @rep2)
instance
( EqTable a
, KnownSymbol label
, GColumns (M1 S meta k1) ~ HLabel label (Columns a)
, meta ~ 'MetaSel ('Just label) _su _ss _ds
, k1 ~ K1 i a
) => GEqTable (M1 S meta k1)
where
geqTable = hlabel hlabeler (eqTable @a)
data TEqTable :: Type -> Exp Constraint
type instance Eval (TEqTable a) = EqTable a
instance

View File

@ -21,8 +21,8 @@ where
-- base
import Data.Functor.Const ( Const( Const ), getConst )
import Data.Kind ( Constraint, Type )
import GHC.Generics ( Rep, (:*:), K1, M1, Meta( MetaSel ), D, C, S )
import GHC.TypeLits ( KnownSymbol )
import Data.Proxy ( Proxy )
import GHC.Generics ( Rep )
import Prelude hiding ( seq )
-- rel8
@ -30,20 +30,19 @@ import Rel8.Expr ( Expr, Col(..) )
import Rel8.Expr.Bool ( (||.), (&&.), false, true )
import Rel8.Expr.Eq ( (==.) )
import Rel8.Expr.Ord ( (<.), (>.) )
import Rel8.FCF ( Eval, Exp )
import Rel8.Generic.Record ( Record )
import Rel8.Schema.Context.Label ( hlabeler )
import Rel8.Generic.Table ( GTable, GColumns, gtable )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.HTable
( HTable, HConstrainTable
, htabulateA, hfield, hdicts
)
import Rel8.Schema.HTable.Label ( HLabel, hlabel )
import Rel8.Schema.HTable.Product ( HProduct(..) )
import Rel8.Schema.HTable.Type ( HType(..) )
import Rel8.Schema.Kind ( Context )
import Rel8.Schema.Null (Sql)
import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
import Rel8.Table ( Table, Columns, toColumns, GColumns )
import Rel8.Table ( Table, Columns, toColumns, TColumns )
import Rel8.Table.Bool ( bool )
import Rel8.Table.Eq ( EqTable )
import Rel8.Type.Eq ( DBEq )
@ -58,40 +57,17 @@ class EqTable a => OrdTable a where
ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
default ordTable ::
( GColumns (Rep (Record a)) ~ Columns a
, GOrdTable (Rep (Record a))
( GTable TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a))
, Columns a ~ GColumns TColumns (Rep (Record a))
)
=> Columns a (Dict (ConstrainDBType DBOrd))
ordTable = gordTable @(Rep (Record a))
ordTable = gtable @TOrdTable @TColumns @_ @(Rep (Record a)) table
where
table (_ :: Proxy x) = ordTable @x
type GOrdTable :: (Type -> Type) -> Constraint
class GOrdTable rep where
gordTable :: GColumns rep (Dict (ConstrainDBType DBOrd))
instance GOrdTable rep => GOrdTable (M1 D c rep) where
gordTable = gordTable @rep
instance GOrdTable rep => GOrdTable (M1 C c rep) where
gordTable = gordTable @rep
instance (GOrdTable rep1, GOrdTable rep2) => GOrdTable (rep1 :*: rep2) where
gordTable = HProduct (gordTable @rep1) (gordTable @rep2)
instance
( OrdTable a
, KnownSymbol label
, GColumns (M1 S meta k1) ~ HLabel label (Columns a)
, meta ~ 'MetaSel ('Just label) _su _ss _ds
, k1 ~ K1 i a
)
=> GOrdTable (M1 S meta k1)
where
gordTable = hlabel hlabeler (ordTable @a)
data TOrdTable :: Type -> Exp Constraint
type instance Eval (TOrdTable a) = OrdTable a
instance

View File

@ -39,6 +39,7 @@ import qualified Hasql.Decoders as Hasql
import Rel8.Expr ( Expr, Col(..) )
import Rel8.Expr.Serialize ( slitExpr, sparseValue )
import Rel8.Generic.Record ( Record(..) )
import Rel8.Generic.Table ( GColumns )
import Rel8.Schema.Context ( Col(..) )
import Rel8.Schema.Context.Label ( labeler, unlabeler )
import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
@ -48,7 +49,7 @@ import Rel8.Schema.HTable.Type ( HType(..) )
import Rel8.Schema.Null ( NotNull, Sql )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
import Rel8.Table ( Table, Columns, fromColumns, toColumns, GColumns )
import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
import Rel8.Table.Either ( EitherTable )
import Rel8.Table.List ( ListTable )
import Rel8.Table.Maybe ( MaybeTable )
@ -72,7 +73,7 @@ class Table Expr exprs => ToExprs exprs a where
default fromResult ::
( Generic (Record a)
, GToExprs (Rep (Record exprs)) (Rep (Record a))
, Columns exprs ~ GColumns (Rep (Record exprs))
, Columns exprs ~ GColumns TColumns (Rep (Record exprs))
)
=> Columns exprs (Col Result) -> a
fromResult = unrecord . to . gfromResult @(Rep (Record exprs))
@ -80,7 +81,7 @@ class Table Expr exprs => ToExprs exprs a where
default toResult ::
( Generic (Record a)
, GToExprs (Rep (Record exprs)) (Rep (Record a))
, Columns exprs ~ GColumns (Rep (Record exprs))
, Columns exprs ~ GColumns TColumns (Rep (Record exprs))
)
=> a -> Columns exprs (Col Result)
toResult = gtoResult @(Rep (Record exprs)) . from . Record
@ -88,8 +89,8 @@ class Table Expr exprs => ToExprs exprs a where
type GToExprs :: (Type -> Type) -> (Type -> Type) -> Constraint
class GToExprs exprs rep where
gfromResult :: GColumns exprs (Col Result) -> rep x
gtoResult :: rep x -> GColumns exprs (Col Result)
gfromResult :: GColumns TColumns exprs (Col Result) -> rep x
gtoResult :: rep x -> GColumns TColumns exprs (Col Result)
instance GToExprs exprs rep => GToExprs (M1 D c exprs) (M1 D c rep) where
@ -112,7 +113,7 @@ instance (GToExprs exprs1 rep1, GToExprs exprs2 rep2) =>
instance
( ToExprs exprs a
, KnownSymbol label
, GColumns (M1 S meta k1) ~ HLabel label (Columns exprs)
, GColumns TColumns (M1 S meta k1) ~ HLabel label (Columns exprs)
, meta ~ 'MetaSel ('Just label) _su _ss _ds
, k1 ~ K1 i exprs
, k1' ~ K1 i a