diff --git a/src/Rel8/Schema/Generic.hs b/src/Rel8/Schema/Generic.hs index 0c7ad03..f4e388a 100644 --- a/src/Rel8/Schema/Generic.hs +++ b/src/Rel8/Schema/Generic.hs @@ -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)) diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs index a26b26a..19f7c3d 100644 --- a/src/Rel8/Table.hs +++ b/src/Rel8/Table.hs @@ -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