{-# language DataKinds #-}
{-# language RankNTypes #-}
{-# language RecordWildCards #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}

module Rel8.Schema.HTable.Label
  ( HLabel, hlabel, hrelabel, hunlabel
  , hproject
  )
where

-- base
import Data.Kind ( Type )
import Data.Proxy ( Proxy( Proxy ) )
import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
import Prelude

-- rel8
import Rel8.Schema.HTable
  ( HTable, HConstrainTable, HField
  , htabulate, hfield, htraverse, hdicts, hspecs
  )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Spec ( Spec(..) )


type HLabel :: Symbol -> K.HTable -> K.HTable
newtype HLabel label table context = HLabel (table context)


type HLabelField :: Symbol -> K.HTable -> Type -> Type
newtype HLabelField label table a = HLabelField (HField table a)


instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
  type HField (HLabel label table) = HLabelField label table
  type HConstrainTable (HLabel label table) constraint =
    HConstrainTable table constraint

  hfield :: HLabel label table context
-> HField (HLabel label table) a -> context a
hfield (HLabel table context
a) (HLabelField field) = table context -> HField table a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield table context
a HField table a
field
  htabulate :: (forall a. HField (HLabel label table) a -> context a)
-> HLabel label table context
htabulate forall a. HField (HLabel label table) a -> context a
f = table context -> HLabel label table context
forall (label :: Symbol) (table :: HTable) (context :: Context).
table context -> HLabel label table context
HLabel ((forall a. HField table a -> context a) -> table context
forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate (HLabelField label table a -> context a
forall a. HField (HLabel label table) a -> context a
f (HLabelField label table a -> context a)
-> (HField table a -> HLabelField label table a)
-> HField table a
-> context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HField table a -> HLabelField label table a
forall (label :: Symbol) (table :: HTable) a.
HField table a -> HLabelField label table a
HLabelField))
  htraverse :: (forall a. f a -> m (g a))
-> HLabel label table f -> m (HLabel label table g)
htraverse forall a. f a -> m (g a)
f (HLabel table f
a) = table g -> HLabel label table g
forall (label :: Symbol) (table :: HTable) (context :: Context).
table context -> HLabel label table context
HLabel (table g -> HLabel label table g)
-> m (table g) -> m (HLabel label table g)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. f a -> m (g a)) -> table f -> m (table g)
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 table f
a
  hdicts :: HLabel label table (Dict c)
hdicts = table (Dict c) -> HLabel label table (Dict c)
forall (label :: Symbol) (table :: HTable) (context :: Context).
table context -> HLabel label table context
HLabel (forall (c :: * -> Constraint).
(HTable table, HConstrainTable table c) =>
table (Dict c)
forall (t :: HTable) (c :: * -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts @table)
  hspecs :: HLabel label table Spec
hspecs = table Spec -> HLabel label table Spec
forall (label :: Symbol) (table :: HTable) (context :: Context).
table context -> HLabel label table context
HLabel (table Spec -> HLabel label table Spec)
-> table Spec -> HLabel label table Spec
forall a b. (a -> b) -> a -> b
$ (forall a. HField table a -> Spec a) -> table Spec
forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate ((forall a. HField table a -> Spec a) -> table Spec)
-> (forall a. HField table a -> Spec a) -> table Spec
forall a b. (a -> b) -> a -> b
$ \HField table a
field -> case table Spec -> HField table a -> Spec a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (HTable table => table Spec
forall (t :: HTable). HTable t => t Spec
hspecs @table) HField table a
field of
    Spec {[String]
Nullity a
TypeInformation (Unnullify a)
nullity :: forall a. Spec a -> Nullity a
info :: forall a. Spec a -> TypeInformation (Unnullify a)
labels :: forall a. Spec a -> [String]
nullity :: Nullity a
info :: TypeInformation (Unnullify a)
labels :: [String]
..} -> Spec :: forall a.
[String] -> TypeInformation (Unnullify a) -> Nullity a -> Spec a
Spec {labels :: [String]
labels = Proxy label -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy label
forall k (t :: k). Proxy t
Proxy @label) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
labels, Nullity a
TypeInformation (Unnullify a)
nullity :: Nullity a
info :: TypeInformation (Unnullify a)
nullity :: Nullity a
info :: TypeInformation (Unnullify a)
..}
  {-# INLINABLE hspecs #-}


hlabel :: forall label t context. t context -> HLabel label t context
hlabel :: t context -> HLabel label t context
hlabel = t context -> HLabel label t context
forall (label :: Symbol) (table :: HTable) (context :: Context).
table context -> HLabel label table context
HLabel
{-# INLINABLE hlabel #-}


hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
hrelabel :: HLabel label t context -> HLabel label' t context
hrelabel = t context -> HLabel label' t context
forall (label :: Symbol) (table :: HTable) (context :: Context).
table context -> HLabel label table context
hlabel (t context -> HLabel label' t context)
-> (HLabel label t context -> t context)
-> HLabel label t context
-> HLabel label' t context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HLabel label t context -> t context
forall (label :: Symbol) (t :: HTable) (context :: Context).
HLabel label t context -> t context
hunlabel
{-# INLINABLE hrelabel #-}


hunlabel :: forall label t context. HLabel label t context -> t context
hunlabel :: HLabel label t context -> t context
hunlabel (HLabel t context
a) = t context
a
{-# INLINABLE hunlabel #-}


hproject :: ()
  => (forall ctx. t ctx -> t' ctx)
  -> HLabel label t context -> HLabel label t' context
hproject :: (forall (ctx :: Context). t ctx -> t' ctx)
-> HLabel label t context -> HLabel label t' context
hproject forall (ctx :: Context). t ctx -> t' ctx
f (HLabel t context
a) = t' context -> HLabel label t' context
forall (label :: Symbol) (table :: HTable) (context :: Context).
table context -> HLabel label table context
HLabel (t context -> t' context
forall (ctx :: Context). t ctx -> t' ctx
f t context
a)