mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-27 02:08:37 +03:00
Add generic default for Table class, and share its implementation with Rel8able
This commit is contained in:
parent
47e7842c0f
commit
6ca25e57dd
@ -1,17 +1,10 @@
|
|||||||
{-# language AllowAmbiguousTypes #-}
|
|
||||||
{-# language DataKinds #-}
|
{-# language DataKinds #-}
|
||||||
{-# language DisambiguateRecordFields #-}
|
|
||||||
{-# language DefaultSignatures #-}
|
{-# language DefaultSignatures #-}
|
||||||
{-# language FlexibleContexts #-}
|
{-# language FlexibleContexts #-}
|
||||||
{-# language FlexibleInstances #-}
|
{-# language FlexibleInstances #-}
|
||||||
{-# language GADTs #-}
|
|
||||||
{-# language MultiParamTypeClasses #-}
|
{-# language MultiParamTypeClasses #-}
|
||||||
{-# language QuantifiedConstraints #-}
|
|
||||||
{-# language ScopedTypeVariables #-}
|
|
||||||
{-# language StandaloneKindSignatures #-}
|
{-# language StandaloneKindSignatures #-}
|
||||||
{-# language TypeApplications #-}
|
|
||||||
{-# language TypeFamilies #-}
|
{-# language TypeFamilies #-}
|
||||||
{-# language TypeOperators #-}
|
|
||||||
{-# language UndecidableInstances #-}
|
{-# language UndecidableInstances #-}
|
||||||
|
|
||||||
{-# options_ghc -fno-warn-orphans #-}
|
{-# options_ghc -fno-warn-orphans #-}
|
||||||
@ -24,28 +17,20 @@ where
|
|||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Data.Kind ( Constraint, Type )
|
import Data.Kind ( Constraint, Type )
|
||||||
import GHC.Generics
|
import GHC.Generics ( Generic, Rep, from, to )
|
||||||
( Generic, Rep, from, to
|
|
||||||
, (:*:)( (:*:) ), K1( K1 ), M1( M1 )
|
|
||||||
, D, S
|
|
||||||
, Meta( MetaSel )
|
|
||||||
)
|
|
||||||
import qualified GHC.Generics as G ( C )
|
|
||||||
import GHC.TypeLits ( KnownSymbol )
|
|
||||||
import Prelude
|
import Prelude
|
||||||
import Unsafe.Coerce ( unsafeCoerce )
|
import Unsafe.Coerce ( unsafeCoerce )
|
||||||
|
|
||||||
-- rel8
|
-- rel8
|
||||||
import Rel8.Schema.Context ( Col )
|
import Rel8.Schema.Context ( Col )
|
||||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
|
import Rel8.Schema.Context.Label ( Labelable )
|
||||||
import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
|
import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
|
||||||
import Rel8.Schema.HTable ( HTable )
|
import Rel8.Schema.HTable ( HTable )
|
||||||
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
|
|
||||||
import Rel8.Schema.HTable.Pair ( HPair(..) )
|
|
||||||
import qualified Rel8.Schema.Kind as K
|
import qualified Rel8.Schema.Kind as K
|
||||||
import Rel8.Schema.Name ( Name )
|
import Rel8.Schema.Name ( Name )
|
||||||
import Rel8.Table
|
import Rel8.Table
|
||||||
( Table, Columns, Context, fromColumns, toColumns
|
( Table, Columns, Context, fromColumns, toColumns
|
||||||
|
, GTable, GColumns, fromGColumns, toGColumns
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
@ -116,72 +101,25 @@ class HTable (GRep t) => Rel8able t where
|
|||||||
gtoColumns :: (Labelable context, Reifiable context)
|
gtoColumns :: (Labelable context, Reifiable context)
|
||||||
=> t (Reify context) -> GRep t (Col (Reify context))
|
=> t (Reify context) -> GRep t (Col (Reify context))
|
||||||
|
|
||||||
default gfromColumns :: forall context.
|
default gfromColumns ::
|
||||||
( Generic (t (Reify context))
|
( Generic (t (Reify context))
|
||||||
, GColumns (Rep (t (Reify context))) ~ GRep t
|
, GColumns (Rep (t (Reify context))) ~ GRep t
|
||||||
, GRel8able context (Rep (t (Reify context)))
|
, GTable (Reify context) (Rep (t (Reify context)))
|
||||||
) => GRep t (Col (Reify context)) -> t (Reify context)
|
) => GRep t (Col (Reify context)) -> t (Reify context)
|
||||||
gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context)))
|
gfromColumns = to . fromGColumns
|
||||||
|
|
||||||
default gtoColumns :: forall context.
|
default gtoColumns ::
|
||||||
( Generic (t (Reify context))
|
( Generic (t (Reify context))
|
||||||
, GColumns (Rep (t (Reify context))) ~ GRep t
|
, GColumns (Rep (t (Reify context))) ~ GRep t
|
||||||
, GRel8able context (Rep (t (Reify context)))
|
, GTable (Reify context) (Rep (t (Reify context)))
|
||||||
) => t (Reify context) -> GRep t (Col (Reify context))
|
) => t (Reify context) -> GRep t (Col (Reify context))
|
||||||
gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from
|
gtoColumns = toGColumns . from
|
||||||
|
|
||||||
|
|
||||||
type GRep :: K.Table -> K.HTable
|
type GRep :: K.Table -> K.HTable
|
||||||
type GRep t = GColumns (Rep (t (Reify Name)))
|
type GRep t = GColumns (Rep (t (Reify Name)))
|
||||||
|
|
||||||
|
|
||||||
type GColumns :: (Type -> Type) -> K.HTable
|
|
||||||
type family GColumns rep where
|
|
||||||
GColumns (M1 D _ rep) = GColumns rep
|
|
||||||
GColumns (M1 G.C _ rep) = GColumns rep
|
|
||||||
GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)
|
|
||||||
GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
|
|
||||||
HLabel label (Columns a)
|
|
||||||
|
|
||||||
|
|
||||||
type GRel8able :: K.Context -> (Type -> Type) -> Constraint
|
|
||||||
class GRel8able context rep where
|
|
||||||
fromGColumns :: GColumns rep (Col (Reify context)) -> rep x
|
|
||||||
toGColumns :: rep x -> GColumns rep (Col (Reify context))
|
|
||||||
|
|
||||||
|
|
||||||
instance GRel8able context rep => GRel8able context (M1 D c rep) where
|
|
||||||
fromGColumns = M1 . fromGColumns @context @rep
|
|
||||||
toGColumns (M1 a) = toGColumns @context @rep a
|
|
||||||
|
|
||||||
|
|
||||||
instance GRel8able context rep => GRel8able context (M1 G.C c rep) where
|
|
||||||
fromGColumns = M1 . fromGColumns @context @rep
|
|
||||||
toGColumns (M1 a) = toGColumns @context @rep a
|
|
||||||
|
|
||||||
|
|
||||||
instance (GRel8able context rep1, GRel8able context rep2) =>
|
|
||||||
GRel8able context (rep1 :*: rep2)
|
|
||||||
where
|
|
||||||
fromGColumns (HPair a b) =
|
|
||||||
fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b
|
|
||||||
toGColumns (a :*: b) =
|
|
||||||
HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)
|
|
||||||
|
|
||||||
|
|
||||||
instance
|
|
||||||
( Table (Reify 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
|
|
||||||
) => GRel8able context (M1 S meta k1)
|
|
||||||
where
|
|
||||||
fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler
|
|
||||||
toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)
|
|
||||||
|
|
||||||
|
|
||||||
reify ::
|
reify ::
|
||||||
(-- Rel8able t
|
(-- Rel8able t
|
||||||
--, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))
|
--, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))
|
||||||
|
@ -1,11 +1,14 @@
|
|||||||
{-# language DataKinds #-}
|
{-# language DataKinds #-}
|
||||||
|
{-# language DefaultSignatures #-}
|
||||||
{-# language DisambiguateRecordFields #-}
|
{-# language DisambiguateRecordFields #-}
|
||||||
{-# language FlexibleContexts #-}
|
{-# language FlexibleContexts #-}
|
||||||
{-# language FlexibleInstances #-}
|
{-# language FlexibleInstances #-}
|
||||||
{-# language FunctionalDependencies #-}
|
{-# language FunctionalDependencies #-}
|
||||||
{-# language LambdaCase #-}
|
{-# language LambdaCase #-}
|
||||||
{-# language NamedFieldPuns #-}
|
{-# language NamedFieldPuns #-}
|
||||||
|
{-# language ScopedTypeVariables #-}
|
||||||
{-# language StandaloneKindSignatures #-}
|
{-# language StandaloneKindSignatures #-}
|
||||||
|
{-# language TypeApplications #-}
|
||||||
{-# language TypeFamilies #-}
|
{-# language TypeFamilies #-}
|
||||||
{-# language TypeOperators #-}
|
{-# language TypeOperators #-}
|
||||||
{-# language UndecidableInstances #-}
|
{-# language UndecidableInstances #-}
|
||||||
@ -14,6 +17,7 @@ module Rel8.Table
|
|||||||
( Table (Columns, Context)
|
( Table (Columns, Context)
|
||||||
, toColumns, fromColumns
|
, toColumns, fromColumns
|
||||||
, Congruent
|
, Congruent
|
||||||
|
, GTable, GColumns, GContext, fromGColumns, toGColumns
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -22,6 +26,13 @@ import Data.Functor ( ($>) )
|
|||||||
import Data.Functor.Identity ( Identity( Identity ) )
|
import Data.Functor.Identity ( Identity( Identity ) )
|
||||||
import Data.Kind ( Constraint, Type )
|
import Data.Kind ( Constraint, Type )
|
||||||
import Data.List.NonEmpty ( NonEmpty )
|
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 Prelude hiding ( null )
|
import Prelude hiding ( null )
|
||||||
|
|
||||||
-- rel8
|
-- rel8
|
||||||
@ -76,6 +87,79 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex
|
|||||||
toColumns :: a -> Columns a (Col (Context a))
|
toColumns :: a -> Columns a (Col (Context a))
|
||||||
fromColumns :: Columns a (Col (Context a)) -> a
|
fromColumns :: Columns a (Col (Context a)) -> a
|
||||||
|
|
||||||
|
type Columns a = GColumns (Rep a)
|
||||||
|
type Context a = GContext (Rep a)
|
||||||
|
|
||||||
|
default toColumns ::
|
||||||
|
( Generic a, GTable (GContext (Rep a)) (Rep a)
|
||||||
|
, Columns a ~ GColumns (Rep a)
|
||||||
|
, Context a ~ GContext (Rep a)
|
||||||
|
)
|
||||||
|
=> a -> Columns a (Col (Context a))
|
||||||
|
toColumns = toGColumns . from
|
||||||
|
|
||||||
|
default fromColumns ::
|
||||||
|
( Generic a, GTable (GContext (Rep a)) (Rep a)
|
||||||
|
, Columns a ~ GColumns (Rep a)
|
||||||
|
, Context a ~ GContext (Rep a)
|
||||||
|
)
|
||||||
|
=> Columns a (Col (Context a)) -> a
|
||||||
|
fromColumns = to . fromGColumns
|
||||||
|
|
||||||
|
|
||||||
|
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) = HPair (GColumns rep1) (GColumns rep2)
|
||||||
|
GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
|
||||||
|
HLabel label (Columns 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
|
||||||
|
|
||||||
|
|
||||||
|
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 (HPair a b) =
|
||||||
|
fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b
|
||||||
|
toGColumns (a :*: b) =
|
||||||
|
HPair (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)
|
||||||
|
|
||||||
|
|
||||||
-- | Any 'HTable' is also a 'Table'.
|
-- | Any 'HTable' is also a 'Table'.
|
||||||
instance HTable t => Table context (t (Col context)) where
|
instance HTable t => Table context (t (Col context)) where
|
||||||
|
Loading…
Reference in New Issue
Block a user