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