{-# language AllowAmbiguousTypes #-}
{-# language DataKinds #-}
{-# language DefaultSignatures #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language LambdaCase #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilyDependencies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
module Rel8.Schema.HTable
( HTable (HField, HConstrainTable)
, hfield, htabulate, htraverse, hdicts, hspecs
, hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField
)
where
import Data.Functor.Const ( Const( Const ), getConst )
import Data.Kind ( Constraint, Type )
import Data.Functor.Compose ( Compose( Compose ), getCompose )
import Data.Proxy ( Proxy )
import GHC.Generics
( (:*:)( (:*:) )
, Generic (Rep, from, to)
, K1( K1 )
, M1( M1 )
)
import Prelude
import Data.Profunctor ( rmap, Profunctor (lmap) )
import Data.Profunctor.Product ( ProductProfunctor ((****)) )
import Rel8.Schema.Dict ( Dict )
import Rel8.Schema.Spec ( Spec )
import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
import qualified Rel8.Schema.Kind as K
import Data.Functor.Apply ( Apply, (<.>) )
type HTable :: K.HTable -> Constraint
class HTable t where
type HField t = (field :: Type -> Type) | field -> t
type HConstrainTable t (c :: Type -> Constraint) :: Constraint
hfield :: t context -> HField t a -> context a
htabulate :: (forall a. HField t a -> context a) -> t context
htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)
hdicts :: HConstrainTable t c => t (Dict c)
hspecs :: t Spec
type HField t = GHField t
type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
default hfield ::
( Generic (t context)
, HField t ~ GHField t
, HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
, GHTable context (Rep (t context))
)
=> t context -> HField t a -> context a
hfield t context
table (GHField HField (GHColumns (Rep (t Proxy))) a
field) = forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns (forall a x. Generic a => a -> Rep a x
from t context
table)) HField (GHColumns (Rep (t Proxy))) a
field
default htabulate ::
( Generic (t context)
, HField t ~ GHField t
, HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
, GHTable context (Rep (t context))
)
=> (forall a. HField t a -> context a) -> t context
htabulate forall a. HField t a -> context a
f = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate (forall a. HField t a -> context a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: HTable) a.
HField (GHColumns (Rep (t Proxy))) a -> GHField t a
GHField)
default htraverse
:: forall f g m
. ( Apply m
, Generic (t f), GHTable f (Rep (t f))
, Generic (t g), GHTable g (Rep (t g))
, GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
)
=> (forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse forall a. f a -> m (g a)
f = forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: HTable) (m :: Context) (f :: Context) (g :: Context).
(HTable t, Apply m) =>
(forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse forall a. f a -> m (g a)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from
default hdicts
:: forall c
. ( Generic (t (Dict c))
, GHTable (Dict c) (Rep (t (Dict c)))
, GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))
, HConstrainTable (GHColumns (Rep (t Proxy))) c
)
=> t (Dict c)
hdicts = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns (forall (t :: HTable) (c :: * -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts @(GHColumns (Rep (t Proxy))) @c)
default hspecs ::
( Generic (t Spec)
, GHTable Spec (Rep (t Spec))
)
=> t Spec
hspecs = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns forall (t :: HTable). HTable t => t Spec
hspecs
{-# INLINABLE hfield #-}
{-# INLINABLE htabulate #-}
{-# INLINABLE htraverse #-}
{-# INLINABLE hdicts #-}
{-# INLINABLE hspecs #-}
hfoldMap :: (HTable t, Semigroup s)
=> (forall a. context a -> s) -> t context -> s
hfoldMap :: forall (t :: HTable) s (context :: Context).
(HTable t, Semigroup s) =>
(forall a. context a -> s) -> t context -> s
hfoldMap forall a. context a -> s
f t context
a = forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (m :: Context) (f :: Context) (g :: Context).
(HTable t, Apply m) =>
(forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse (forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. context a -> s
f) t context
a
hmap :: HTable t
=> (forall a. context a -> context' a) -> t context -> t context'
hmap :: forall (t :: HTable) (context :: Context) (context' :: Context).
HTable t =>
(forall a. context a -> context' a) -> t context -> t context'
hmap forall a. context a -> context' a
f t context
a = forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate forall a b. (a -> b) -> a -> b
$ \HField t a
field -> forall a. context a -> context' a
f (forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t context
a HField t a
field)
htabulateA :: (HTable t, Apply m)
=> (forall a. HField t a -> m (context a)) -> m (t context)
htabulateA :: forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA forall a. HField t a -> m (context a)
f = forall (t :: HTable) (m :: Context) (f :: Context) (g :: Context).
(HTable t, Apply m) =>
(forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate forall a b. (a -> b) -> a -> b
$ forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HField t a -> m (context a)
f
{-# INLINABLE htabulateA #-}
newtype ApplyP p a b = ApplyP { forall (p :: * -> Context) a b. ApplyP p a b -> p a b
unApplyP :: p a b }
instance Profunctor p => Functor (ApplyP p a) where
fmap :: forall a b. (a -> b) -> ApplyP p a a -> ApplyP p a b
fmap a -> b
f = forall (p :: * -> Context) a b. p a b -> ApplyP p a b
ApplyP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> Context) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> Context) a b. ApplyP p a b -> p a b
unApplyP
instance ProductProfunctor p => Apply (ApplyP p a) where
ApplyP p a (a -> b)
f <.> :: forall a b. ApplyP p a (a -> b) -> ApplyP p a a -> ApplyP p a b
<.> ApplyP p a a
x = forall (p :: * -> Context) a b. p a b -> ApplyP p a b
ApplyP (forall (p :: * -> Context) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap forall a. a -> a
id p a (a -> b)
f forall (p :: * -> Context) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** p a a
x)
htraverseP :: (HTable t, ProductProfunctor p)
=> (forall a. p (f a) (g a)) -> p (t f) (t g)
htraverseP :: forall (t :: HTable) (p :: * -> Context) (f :: Context)
(g :: Context).
(HTable t, ProductProfunctor p) =>
(forall a. p (f a) (g a)) -> p (t f) (t g)
htraverseP forall a. p (f a) (g a)
f = forall (t :: HTable) (p :: * -> Context) (f :: Context)
(g :: Context).
(HTable t, ProductProfunctor p) =>
(forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
htraversePWithField (forall a b. a -> b -> a
const forall a. p (f a) (g a)
f)
htraversePWithField :: (HTable t, ProductProfunctor p)
=> (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
htraversePWithField :: forall (t :: HTable) (p :: * -> Context) (f :: Context)
(g :: Context).
(HTable t, ProductProfunctor p) =>
(forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
htraversePWithField forall a. HField t a -> p (f a) (g a)
f = forall (p :: * -> Context) a b. ApplyP p a b -> p a b
unApplyP forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA forall a b. (a -> b) -> a -> b
$ \HField t a
field -> forall (p :: * -> Context) a b. p a b -> ApplyP p a b
ApplyP forall a b. (a -> b) -> a -> b
$
forall (p :: * -> Context) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield HField t a
field) (forall a. HField t a -> p (f a) (g a)
f HField t a
field)
type GHField :: K.HTable -> Type -> Type
newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
type GHTable :: K.Context -> (Type -> Type) -> Constraint
class HTable (GHColumns rep) => GHTable context rep | rep -> context where
type GHColumns rep :: K.HTable
toGHColumns :: rep x -> GHColumns rep context
fromGHColumns :: GHColumns rep context -> rep x
instance GHTable context rep => GHTable context (M1 i c rep) where
type GHColumns (M1 i c rep) = GHColumns rep
toGHColumns :: forall x. M1 i c rep x -> GHColumns (M1 i c rep) context
toGHColumns (M1 rep x
a) = forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns rep x
a
fromGHColumns :: forall x. GHColumns (M1 i c rep) context -> M1 i c rep x
fromGHColumns = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns
instance HTable table => GHTable context (K1 i (table context)) where
type GHColumns (K1 i (table context)) = table
toGHColumns :: forall x.
K1 i (table context) x -> GHColumns (K1 i (table context)) context
toGHColumns (K1 table context
a) = table context
a
fromGHColumns :: forall x.
GHColumns (K1 i (table context)) context -> K1 i (table context) x
fromGHColumns = forall k i c (p :: k). c -> K1 i c p
K1
instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
toGHColumns :: forall x. (:*:) a b x -> GHColumns (a :*: b) context
toGHColumns (a x
a :*: b x
b) = forall (a :: HTable) (b :: HTable) (context :: Context).
a context -> b context -> HProduct a b context
HProduct (forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns a x
a) (forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns b x
b)
fromGHColumns :: forall x. GHColumns (a :*: b) context -> (:*:) a b x
fromGHColumns (HProduct GHColumns a context
a GHColumns b context
b) = forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns GHColumns a context
a forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns GHColumns b context
b
type HProductField :: K.HTable -> K.HTable -> Type -> Type
data HProductField x y a
= HFst (HField x a)
| HSnd (HField y a)
instance (HTable x, HTable y) => HTable (HProduct x y) where
type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
type HField (HProduct x y) = HProductField x y
hfield :: forall (context :: Context) a.
HProduct x y context -> HField (HProduct x y) a -> context a
hfield (HProduct x context
l y context
r) = \case
HFst HField x a
i -> forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield x context
l HField x a
i
HSnd HField y a
i -> forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield y context
r HField y a
i
htabulate :: forall (context :: Context).
(forall a. HField (HProduct x y) a -> context a)
-> HProduct x y context
htabulate forall a. HField (HProduct x y) a -> context a
f = forall (a :: HTable) (b :: HTable) (context :: Context).
a context -> b context -> HProduct a b context
HProduct (forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate (forall a. HField (HProduct x y) a -> context a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (x :: HTable) (y :: HTable) a.
HField x a -> HProductField x y a
HFst)) (forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate (forall a. HField (HProduct x y) a -> context a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (x :: HTable) (y :: HTable) a.
HField y a -> HProductField x y a
HSnd))
htraverse :: forall (m :: Context) (f :: Context) (g :: Context).
Apply m =>
(forall a. f a -> m (g a)) -> HProduct x y f -> m (HProduct x y g)
htraverse forall a. f a -> m (g a)
f (HProduct x f
x y f
y) = forall (a :: HTable) (b :: HTable) (context :: Context).
a context -> b context -> HProduct a b context
HProduct forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: HTable) (m :: Context) (f :: Context) (g :: Context).
(HTable t, Apply m) =>
(forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse forall a. f a -> m (g a)
f x f
x forall (f :: Context) a b. Apply f => f (a -> b) -> f a -> f b
<.> forall (t :: HTable) (m :: Context) (f :: Context) (g :: Context).
(HTable t, Apply m) =>
(forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse forall a. f a -> m (g a)
f y f
y
hdicts :: forall (c :: * -> Constraint).
HConstrainTable (HProduct x y) c =>
HProduct x y (Dict c)
hdicts = forall (a :: HTable) (b :: HTable) (context :: Context).
a context -> b context -> HProduct a b context
HProduct forall (t :: HTable) (c :: * -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts forall (t :: HTable) (c :: * -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts
hspecs :: HProduct x y Spec
hspecs = forall (a :: HTable) (b :: HTable) (context :: Context).
a context -> b context -> HProduct a b context
HProduct forall (t :: HTable). HTable t => t Spec
hspecs forall (t :: HTable). HTable t => t Spec
hspecs
{-# INLINABLE hfield #-}
{-# INLINABLE htabulate #-}
{-# INLINABLE htraverse #-}
{-# INLINABLE hdicts #-}
{-# INLINABLE hspecs #-}