mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-27 02:08:37 +03:00
Use FCF to decouple GTable from Table
This commit is contained in:
parent
3e8f632cd1
commit
1276bebbb0
@ -67,6 +67,7 @@ library
|
||||
Rel8.Kind.Necessity
|
||||
|
||||
Rel8.Generic.Record
|
||||
Rel8.Generic.Table
|
||||
|
||||
Rel8.Order
|
||||
|
||||
|
127
src/Rel8/Generic/Table.hs
Normal file
127
src/Rel8/Generic/Table.hs
Normal 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))
|
@ -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 ::
|
||||
|
@ -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'.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user