{-# language AllowAmbiguousTypes #-}
{-# language BlockArguments #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language InstanceSigs #-}
{-# language MultiParamTypeClasses #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}
module Rel8.Schema.HTable.MapTable
( HMapTable(..)
, MapSpec(..)
, Precompose(..)
, HMapTableField(..)
, hproject
)
where
import Data.Kind ( Constraint, Type )
import Prelude
import Rel8.FCF ( Exp, Eval )
import Rel8.Schema.HTable
( HTable, HConstrainTable, HField
, hfield, htabulate, htraverse, hdicts, hspecs
)
import Rel8.Schema.Spec ( Spec )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Dict ( Dict( Dict ) )
type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable
newtype HMapTable f t context = HMapTable
{ forall (f :: * -> Exp (*)) (t :: HTable) (context :: Exp (*)).
HMapTable f t context -> t (Precompose f context)
unHMapTable :: t (Precompose f context)
}
type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
newtype Precompose f g x = Precompose
{ forall (f :: * -> Exp (*)) (g :: Exp (*)) x.
Precompose f g x -> g (Eval (f x))
precomposed :: g (Eval (f x))
}
type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
data HMapTableField f t x where
HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
type HField (HMapTable f t) =
HMapTableField f t
type HConstrainTable (HMapTable f t) c =
HConstrainTable t (ComposeConstraint f c)
hfield :: forall (context :: Exp (*)) a.
HMapTable f t context -> HField (HMapTable f t) a -> context a
hfield (HMapTable t (Precompose f context)
x) (HMapTableField HField t a
i) =
forall (f :: * -> Exp (*)) (g :: Exp (*)) x.
Precompose f g x -> g (Eval (f x))
precomposed (forall (t :: HTable) (context :: Exp (*)) a.
HTable t =>
t context -> HField t a -> context a
hfield t (Precompose f context)
x HField t a
i)
htabulate :: forall (context :: Exp (*)).
(forall a. HField (HMapTable f t) a -> context a)
-> HMapTable f t context
htabulate forall a. HField (HMapTable f t) a -> context a
f =
forall (f :: * -> Exp (*)) (t :: HTable) (context :: Exp (*)).
t (Precompose f context) -> HMapTable f t context
HMapTable forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (context :: Exp (*)).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate (forall (f :: * -> Exp (*)) (g :: Exp (*)) x.
g (Eval (f x)) -> Precompose f g x
Precompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HField (HMapTable f t) a -> context a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: HTable) a (f :: * -> Exp (*)).
HField t a -> HMapTableField f t (Eval (f a))
HMapTableField)
htraverse :: forall (m :: Exp (*)) (f :: Exp (*)) (g :: Exp (*)).
Apply m =>
(forall a. f a -> m (g a))
-> HMapTable f t f -> m (HMapTable f t g)
htraverse forall a. f a -> m (g a)
f (HMapTable t (Precompose f f)
x) =
forall (f :: * -> Exp (*)) (t :: HTable) (context :: Exp (*)).
t (Precompose f context) -> HMapTable f t context
HMapTable forall (f :: Exp (*)) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: HTable) (m :: Exp (*)) (f :: Exp (*)) (g :: Exp (*)).
(HTable t, Apply m) =>
(forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse (forall (f :: Exp (*)) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> Exp (*)) (g :: Exp (*)) x.
g (Eval (f x)) -> Precompose f g x
Precompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. f a -> m (g a)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> Exp (*)) (g :: Exp (*)) x.
Precompose f g x -> g (Eval (f x))
precomposed) t (Precompose f f)
x
{-# INLINABLE htraverse #-}
hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
hdicts :: forall (c :: * -> Constraint).
HConstrainTable (HMapTable f t) c =>
HMapTable f t (Dict c)
hdicts =
forall (t :: HTable) (context :: Exp (*)).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate \(HMapTableField HField t a
j) ->
case forall (t :: HTable) (context :: Exp (*)) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall (t :: HTable) (c :: * -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts @_ @(ComposeConstraint f c)) HField t a
j of
Dict (ComposeConstraint f c) a
Dict -> forall {a} (c :: a -> Constraint) (a :: a). c a => Dict c a
Dict
hspecs :: HMapTable f t Spec
hspecs =
forall (f :: * -> Exp (*)) (t :: HTable) (context :: Exp (*)).
t (Precompose f context) -> HMapTable f t context
HMapTable forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (context :: Exp (*)).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate forall a b. (a -> b) -> a -> b
$ forall (f :: * -> Exp (*)) (g :: Exp (*)) x.
g (Eval (f x)) -> Precompose f g x
Precompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> Exp (*)) x.
MapSpec f =>
Spec x -> Spec (Eval (f x))
mapInfo @f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: HTable) (context :: Exp (*)) a.
HTable t =>
t context -> HField t a -> context a
hfield forall (t :: HTable). HTable t => t Spec
hspecs
{-# INLINABLE hspecs #-}
type MapSpec :: (Type -> Exp Type) -> Constraint
class MapSpec f where
mapInfo :: Spec x -> Spec (Eval (f x))
type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
class c (Eval (f a)) => ComposeConstraint f c a
instance c (Eval (f a)) => ComposeConstraint f c a
hproject :: ()
=> (forall ctx. t ctx -> t' ctx)
-> HMapTable f t context -> HMapTable f t' context
hproject :: forall (t :: HTable) (t' :: HTable) (f :: * -> Exp (*))
(context :: Exp (*)).
(forall (ctx :: Exp (*)). t ctx -> t' ctx)
-> HMapTable f t context -> HMapTable f t' context
hproject forall (ctx :: Exp (*)). t ctx -> t' ctx
f (HMapTable t (Precompose f context)
a) = forall (f :: * -> Exp (*)) (t :: HTable) (context :: Exp (*)).
t (Precompose f context) -> HMapTable f t context
HMapTable (forall (ctx :: Exp (*)). t ctx -> t' ctx
f t (Precompose f context)
a)