mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-27 02:08:37 +03:00
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.
This commit is contained in:
parent
6ca25e57dd
commit
6d3959e9b0
@ -66,6 +66,8 @@ library
|
||||
Rel8.Kind.Labels
|
||||
Rel8.Kind.Necessity
|
||||
|
||||
Rel8.Generic.Record
|
||||
|
||||
Rel8.Order
|
||||
|
||||
Rel8.Query
|
||||
|
148
src/Rel8/Generic/Record.hs
Normal file
148
src/Rel8/Generic/Record.hs
Normal file
@ -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
|
@ -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 ::
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user