circuithub/rel8
1
1
Fork 0
mirror of https://github.com/circuithub/rel8.git synced 2024-08-17 20:00:23 +03:00
Code Issues Projects Releases Wiki Activity

Add generic default for Table class, and share its implementation with Rel8able

Browse Source
This commit is contained in:
Shane O'Brien 2021-04-16 15:36:35 +01:00
parent 47e7842c0f
commit 6ca25e57dd
No known key found for this signature in database
GPG Key ID: 35A00ED1B695C1A1
2 changed files with 93 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
src/Rel8/Schema/Generic.hs
View File

@ -1,17 +1,10 @@
{-# language AllowAmbiguousTypes #-}
{-# language DataKinds #-}
{-# language DisambiguateRecordFields #-}
{-# language DefaultSignatures #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language MultiParamTypeClasses #-}
{-# language QuantifiedConstraints #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
{-# options_ghc -fno-warn-orphans #-}
@ -24,28 +17,20 @@ where
-- base
import Data.Kind ( Constraint, Type )
import GHC.Generics
( Generic, Rep, from, to
, (:*:)( (:*:) ), K1( K1 ), M1( M1 )
, D, S
, Meta( MetaSel )
)
import qualified GHC.Generics as G ( C )
import GHC.TypeLits ( KnownSymbol )
import GHC.Generics ( Generic, Rep, from, to )
import Prelude
import Unsafe.Coerce ( unsafeCoerce )
-- rel8
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.HTable ( HTable )
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
import Rel8.Schema.HTable.Pair ( HPair(..) )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Table
( 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)
=> t (Reify context) -> GRep t (Col (Reify context))
default gfromColumns :: forall context.
default gfromColumns ::
( Generic (t (Reify context))
, 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)
gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context)))
gfromColumns = to . fromGColumns
default gtoColumns :: forall context.
default gtoColumns ::
( Generic (t (Reify context))
, 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))
gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from
gtoColumns = toGColumns . from
type GRep :: K.Table -> K.HTable
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 ::
(-- Rel8able t
--, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))

84
src/Rel8/Table.hs
View File

@ -1,11 +1,14 @@
{-# language DataKinds #-}
{-# language DefaultSignatures #-}
{-# language DisambiguateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
@ -14,6 +17,7 @@ module Rel8.Table
( Table (Columns, Context)
, toColumns, fromColumns
, Congruent
, GTable, GColumns, GContext, fromGColumns, toGColumns
)
where
@ -22,6 +26,13 @@ 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 Prelude hiding ( null )
-- rel8
@ -76,6 +87,79 @@ 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 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'.
instance HTable t => Table context (t (Col context)) where