Allow generic deriving of Table instances for non-record types

The is implemented using new machinery in `Rel8.Generic.Record`, which transforms the generic representation of any type to be as if that type was a record. Numeric labels are assigned to anonymous field selectors like `_1`, `_2`, `_3` and so on.

rel8.cabal

@@ -66,6 +66,8 @@ library
     Rel8.Kind.Labels
     Rel8.Kind.Necessity
 
+    Rel8.Generic.Record
+
     Rel8.Order
 
     Rel8.Query

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

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 ::

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

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