diff --git a/rel8.cabal b/rel8.cabal index f464735..46b719f 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -66,6 +66,8 @@ library Rel8.Kind.Labels Rel8.Kind.Necessity + Rel8.Generic.Record + Rel8.Order Rel8.Query diff --git a/src/Rel8/Generic/Record.hs b/src/Rel8/Generic/Record.hs new file mode 100644 index 0000000..eb4f608 --- /dev/null +++ b/src/Rel8/Generic/Record.hs @@ -0,0 +1,148 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Record + ( Record(..) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import GHC.Generics +import GHC.TypeLits +import Prelude hiding ( Show ) + + +type Recordize :: (Type -> Type) -> Type -> Type +type family Recordize rep where + Recordize (M1 D meta rep) = M1 D meta (Recordize rep) + Recordize (l :+: r) = Recordize l :+: Recordize r + Recordize (M1 C ('MetaCons name fixity 'False) rep) = + M1 C ('MetaCons name fixity 'True) (Snd (Count 0 rep)) + Recordize rep = rep + + +type Count :: Nat -> (Type -> Type) -> (Nat, Type -> Type) +type family Count n rep where + Count n (M1 S ('MetaSel _selector su ss ds) rep) = + '(n + 1, M1 S ('MetaSel ('Just (Show (n + 1))) su ss ds) rep) + Count n (a :*: b) = CountHelper1 (Count n a) b + Count n rep = '(n, rep) + + +type CountHelper1 :: (Nat, Type -> Type) -> (Type -> Type) -> (Nat, Type -> Type) +type family CountHelper1 tuple b where + CountHelper1 '(n, a) b = CountHelper2 a (Count n b) + + +type CountHelper2 :: (Type -> Type) -> (Nat, Type -> Type) -> (Nat, Type -> Type) +type family CountHelper2 a tuple where + CountHelper2 a '(n, b) = '(n, a :*: b) + + +type Show :: Nat -> Symbol +type Show n = + AppendSymbol "_" (AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10))) + + +type Show' :: Nat -> Symbol +type family Show' n where + Show' 0 = "" + Show' n = AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10)) + + +type ShowDigit :: Nat -> Symbol +type family ShowDigit n where + ShowDigit 0 = "0" + ShowDigit 1 = "1" + ShowDigit 2 = "2" + ShowDigit 3 = "3" + ShowDigit 4 = "4" + ShowDigit 5 = "5" + ShowDigit 6 = "6" + ShowDigit 7 = "7" + ShowDigit 8 = "8" + ShowDigit 9 = "9" + + +type Snd :: (a, b) -> b +type family Snd tuple where + Snd '(_a, b) = b + + +type Recordizable :: (Type -> Type) -> Constraint +class Recordizable rep where + recordize :: rep x -> Recordize rep x + unrecordize :: Recordize rep x -> rep x + + +instance Recordizable rep => Recordizable (M1 D meta rep) where + recordize (M1 a) = M1 (recordize a) + unrecordize (M1 a) = M1 (unrecordize a) + + +instance (Recordizable l, Recordizable r) => Recordizable (l :+: r) where + recordize (L1 a) = L1 (recordize a) + recordize (R1 a) = R1 (recordize a) + unrecordize (L1 a) = L1 (unrecordize a) + unrecordize (R1 a) = R1 (unrecordize a) + + +instance Countable 0 rep => + Recordizable (M1 C ('MetaCons name fixity 'False) rep) + where + recordize (M1 a) = M1 (count @0 a) + unrecordize (M1 a) = M1 (uncount @0 a) + + +instance {-# OVERLAPPABLE #-} Recordize rep ~ rep => Recordizable rep where + recordize = id + unrecordize = id + + +type Countable :: Nat -> (Type -> Type) -> Constraint +class Countable n rep where + count :: rep x -> Snd (Count n rep) x + uncount :: Snd (Count n rep) x -> rep x + + +instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where + count (M1 a) = M1 a + uncount (M1 a) = M1 a + + +instance + ( Countable n a, Countable n' b + , '(n', a') ~ Count n a + , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b)) + ) + => Countable n (a :*: b) + where + count (a :*: b) = count @n a :*: count @n' b + uncount (a :*: b) = uncount @n a :*: uncount @n' b + + +instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where + count = id + uncount = id + + +newtype Record a = Record + { unrecord :: a + } + + +instance (Generic a, Recordizable (Rep a)) => Generic (Record a) where + type Rep (Record a) = Recordize (Rep a) + + from (Record a) = recordize (from a) + to = Record . to . unrecordize diff --git a/src/Rel8/Schema/Generic.hs b/src/Rel8/Schema/Generic.hs index f4e388a..01e66e5 100644 --- a/src/Rel8/Schema/Generic.hs +++ b/src/Rel8/Schema/Generic.hs @@ -22,6 +22,7 @@ import Prelude import Unsafe.Coerce ( unsafeCoerce ) -- rel8 +import Rel8.Generic.Record ( Record(..) ) import Rel8.Schema.Context ( Col ) import Rel8.Schema.Context.Label ( Labelable ) import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify ) @@ -102,22 +103,22 @@ class HTable (GRep t) => Rel8able t where => t (Reify context) -> GRep t (Col (Reify context)) default gfromColumns :: - ( Generic (t (Reify context)) - , GColumns (Rep (t (Reify context))) ~ GRep t - , GTable (Reify context) (Rep (t (Reify 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 = to . fromGColumns + gfromColumns = unrecord . to . fromGColumns default gtoColumns :: - ( Generic (t (Reify context)) - , GColumns (Rep (t (Reify context))) ~ GRep t - , GTable (Reify context) (Rep (t (Reify 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 + gtoColumns = toGColumns . from . Record type GRep :: K.Table -> K.HTable -type GRep t = GColumns (Rep (t (Reify Name))) +type GRep t = GColumns (Rep (Record (t (Reify Name)))) reify :: diff --git a/src/Rel8/Schema/Generic/Test.hs b/src/Rel8/Schema/Generic/Test.hs index 073065b..69b35cf 100644 --- a/src/Rel8/Schema/Generic/Test.hs +++ b/src/Rel8/Schema/Generic/Test.hs @@ -98,3 +98,18 @@ data HKDTest f = HKDTest } deriving stock Generic deriving anyclass Rel8able + + +data NonRecord f = NonRecord + (Column f Bool) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + deriving stock Generic + deriving anyclass Rel8able diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs index 19f7c3d..0470993 100644 --- a/src/Rel8/Table.hs +++ b/src/Rel8/Table.hs @@ -36,6 +36,7 @@ import GHC.TypeLits ( KnownSymbol ) import Prelude hiding ( null ) -- rel8 +import Rel8.Generic.Record ( Record(..) ) import Rel8.Schema.Context ( Col(..) ) import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) import Rel8.Schema.HTable ( HTable ) @@ -87,24 +88,24 @@ 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) + type Columns a = GColumns (Rep (Record a)) + type Context a = GContext (Rep (Record a)) default toColumns :: - ( Generic a, GTable (GContext (Rep a)) (Rep a) - , Columns a ~ GColumns (Rep a) - , Context a ~ GContext (Rep a) + ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a)) + , Columns a ~ GColumns (Rep (Record a)) + , Context a ~ GContext (Rep (Record a)) ) => a -> Columns a (Col (Context a)) - toColumns = toGColumns . from + toColumns = toGColumns . from . Record default fromColumns :: - ( Generic a, GTable (GContext (Rep a)) (Rep a) - , Columns a ~ GColumns (Rep a) - , Context a ~ GContext (Rep a) + ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a)) + , Columns a ~ GColumns (Rep (Record a)) + , Context a ~ GContext (Rep (Record a)) ) => Columns a (Col (Context a)) -> a - fromColumns = to . fromGColumns + fromColumns = unrecord . to . fromGColumns type GColumns :: (Type -> Type) -> K.HTable