{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language MultiParamTypeClasses #-}
{-# language QuantifiedConstraints #-}
{-# language RankNTypes #-}
{-# language RecordWildCards #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}

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

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

-- rel8
import Rel8.Kind.Labels ( SLabels( SCons ) )
import Rel8.Schema.HTable
  ( HTable
  , hfield, htabulate, hspecs
  )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
import Rel8.FCF
import Rel8.Schema.HTable.MapTable
import GHC.Generics (Generic)


type HLabel :: Symbol -> K.HTable -> K.HTable
newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
  deriving stock (forall x.
 HLabel label table context -> Rep (HLabel label table context) x)
-> (forall x.
    Rep (HLabel label table context) x -> HLabel label table context)
-> Generic (HLabel label table context)
forall x.
Rep (HLabel label table context) x -> HLabel label table context
forall x.
HLabel label table context -> Rep (HLabel label table context) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (label :: Symbol) (table :: HTable) (context :: HContext) x.
Rep (HLabel label table context) x -> HLabel label table context
forall (label :: Symbol) (table :: HTable) (context :: HContext) x.
HLabel label table context -> Rep (HLabel label table context) x
$cto :: forall (label :: Symbol) (table :: HTable) (context :: HContext) x.
Rep (HLabel label table context) x -> HLabel label table context
$cfrom :: forall (label :: Symbol) (table :: HTable) (context :: HContext) x.
HLabel label table context -> Rep (HLabel label table context) x
Generic
  deriving anyclass HLabel label table SSpec
(forall (context :: HContext) (spec :: Spec).
 HLabel label table context
 -> HField (HLabel label table) spec -> context spec)
-> (forall (context :: HContext).
    (forall (spec :: Spec).
     HField (HLabel label table) spec -> context spec)
    -> HLabel label table context)
-> (forall (m :: * -> *) (f :: HContext) (g :: HContext).
    Apply m =>
    (forall (spec :: Spec). f spec -> m (g spec))
    -> HLabel label table f -> m (HLabel label table g))
-> (forall (c :: Spec -> Constraint).
    HConstrainTable (HLabel label table) c =>
    HLabel label table (Dict c))
-> HLabel label table SSpec
-> HTable (HLabel label table)
forall (label :: Symbol) (table :: HTable).
(HTable table, KnownSymbol label) =>
HLabel label table SSpec
forall (label :: Symbol) (table :: HTable) (m :: * -> *)
       (f :: HContext) (g :: HContext).
(HTable table, KnownSymbol label, Apply m) =>
(forall (spec :: Spec). f spec -> m (g spec))
-> HLabel label table f -> m (HLabel label table g)
forall (label :: Symbol) (table :: HTable)
       (c :: Spec -> Constraint).
(HTable table, KnownSymbol label,
 HConstrainTable (HLabel label table) c) =>
HLabel label table (Dict c)
forall (label :: Symbol) (table :: HTable) (context :: HContext).
(HTable table, KnownSymbol label) =>
(forall (spec :: Spec).
 HField (HLabel label table) spec -> context spec)
-> HLabel label table context
forall (label :: Symbol) (table :: HTable) (context :: HContext)
       (spec :: Spec).
(HTable table, KnownSymbol label) =>
HLabel label table context
-> HField (HLabel label table) spec -> context spec
forall (m :: * -> *) (f :: HContext) (g :: HContext).
Apply m =>
(forall (spec :: Spec). f spec -> m (g spec))
-> HLabel label table f -> m (HLabel label table g)
forall (c :: Spec -> Constraint).
HConstrainTable (HLabel label table) c =>
HLabel label table (Dict c)
forall (context :: HContext).
(forall (spec :: Spec).
 HField (HLabel label table) spec -> context spec)
-> HLabel label table context
forall (context :: HContext) (spec :: Spec).
HLabel label table context
-> HField (HLabel label table) spec -> context spec
forall (t :: HTable).
(forall (context :: HContext) (spec :: Spec).
 t context -> HField t spec -> context spec)
-> (forall (context :: HContext).
    (forall (spec :: Spec). HField t spec -> context spec)
    -> t context)
-> (forall (m :: * -> *) (f :: HContext) (g :: HContext).
    Apply m =>
    (forall (spec :: Spec). f spec -> m (g spec)) -> t f -> m (t g))
-> (forall (c :: Spec -> Constraint).
    HConstrainTable t c =>
    t (Dict c))
-> t SSpec
-> HTable t
hspecs :: HLabel label table SSpec
$chspecs :: forall (label :: Symbol) (table :: HTable).
(HTable table, KnownSymbol label) =>
HLabel label table SSpec
hdicts :: HLabel label table (Dict c)
$chdicts :: forall (label :: Symbol) (table :: HTable)
       (c :: Spec -> Constraint).
(HTable table, KnownSymbol label,
 HConstrainTable (HLabel label table) c) =>
HLabel label table (Dict c)
htraverse :: (forall (spec :: Spec). f spec -> m (g spec))
-> HLabel label table f -> m (HLabel label table g)
$chtraverse :: forall (label :: Symbol) (table :: HTable) (m :: * -> *)
       (f :: HContext) (g :: HContext).
(HTable table, KnownSymbol label, Apply m) =>
(forall (spec :: Spec). f spec -> m (g spec))
-> HLabel label table f -> m (HLabel label table g)
htabulate :: (forall (spec :: Spec).
 HField (HLabel label table) spec -> context spec)
-> HLabel label table context
$chtabulate :: forall (label :: Symbol) (table :: HTable) (context :: HContext).
(HTable table, KnownSymbol label) =>
(forall (spec :: Spec).
 HField (HLabel label table) spec -> context spec)
-> HLabel label table context
hfield :: HLabel label table context
-> HField (HLabel label table) spec -> context spec
$chfield :: forall (label :: Symbol) (table :: HTable) (context :: HContext)
       (spec :: Spec).
(HTable table, KnownSymbol label) =>
HLabel label table context
-> HField (HLabel label table) spec -> context spec
HTable


data Label :: Symbol -> Spec -> Exp Spec


type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : labels) necessity a


instance KnownSymbol l => MapSpec (Label l) where
  mapInfo :: SSpec x -> SSpec (Eval (Label l x))
mapInfo = \case
    SSpec {SLabels labels
SNecessity necessity
Nullity a
TypeInformation (Unnullify a)
nullity :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> Nullity a
info :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> TypeInformation (Unnullify a)
necessity :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> SNecessity necessity
labels :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> SLabels labels
nullity :: Nullity a
info :: TypeInformation (Unnullify a)
necessity :: SNecessity necessity
labels :: SLabels labels
..} -> SSpec :: forall (labels :: Labels) (necessity :: Necessity) a.
SLabels labels
-> SNecessity necessity
-> TypeInformation (Unnullify a)
-> Nullity a
-> SSpec ('Spec labels necessity a)
SSpec {labels :: SLabels (l : labels)
labels = Proxy l -> SLabels labels -> SLabels (l : labels)
forall (label :: Symbol) (labels :: Labels).
KnownSymbol label =>
Proxy label -> SLabels labels -> SLabels (label : labels)
SCons Proxy l
forall k (t :: k). Proxy t
Proxy SLabels labels
labels, SNecessity necessity
Nullity a
TypeInformation (Unnullify a)
nullity :: Nullity a
info :: TypeInformation (Unnullify a)
necessity :: SNecessity necessity
nullity :: Nullity a
info :: TypeInformation (Unnullify a)
necessity :: SNecessity necessity
..}


hlabel :: (HTable t, KnownSymbol label)
  => (forall labels necessity a. ()
    => context ('Spec labels necessity a)
    -> context ('Spec (label ': labels) necessity a))
  -> t context
  -> HLabel label t context
hlabel :: (forall (labels :: Labels) (necessity :: Necessity) a.
 context ('Spec labels necessity a)
 -> context ('Spec (label : labels) necessity a))
-> t context -> HLabel label t context
hlabel forall (labels :: Labels) (necessity :: Necessity) a.
context ('Spec labels necessity a)
-> context ('Spec (label : labels) necessity a)
labeler t context
a = HMapTable (Label label) t context -> HLabel label t context
forall (label :: Symbol) (table :: HTable) (context :: HContext).
HMapTable (Label label) table context -> HLabel label table context
HLabel (HMapTable (Label label) t context -> HLabel label t context)
-> HMapTable (Label label) t context -> HLabel label t context
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec).
 HField (HMapTable (Label label) t) spec -> context spec)
-> HMapTable (Label label) t context
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate ((forall (spec :: Spec).
  HField (HMapTable (Label label) t) spec -> context spec)
 -> HMapTable (Label label) t context)
-> (forall (spec :: Spec).
    HField (HMapTable (Label label) t) spec -> context spec)
-> HMapTable (Label label) t context
forall a b. (a -> b) -> a -> b
$ \(HMapTableField field) ->
  case t SSpec -> HField t a -> SSpec a
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs HField t a
field of
    SSpec {} -> context ('Spec labels necessity a)
-> context ('Spec (label : labels) necessity a)
forall (labels :: Labels) (necessity :: Necessity) a.
context ('Spec labels necessity a)
-> context ('Spec (label : labels) necessity a)
labeler (t context
-> HField t ('Spec labels necessity a)
-> context ('Spec labels necessity a)
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t context
a HField t a
HField t ('Spec labels necessity a)
field)
{-# INLINABLE hlabel #-}


hunlabel :: (HTable t, KnownSymbol label)
  => (forall labels necessity a. ()
    => context ('Spec (label ': labels) necessity a)
    -> context ('Spec labels necessity a))
  -> HLabel label t context
  -> t context
hunlabel :: (forall (labels :: Labels) (necessity :: Necessity) a.
 context ('Spec (label : labels) necessity a)
 -> context ('Spec labels necessity a))
-> HLabel label t context -> t context
hunlabel forall (labels :: Labels) (necessity :: Necessity) a.
context ('Spec (label : labels) necessity a)
-> context ('Spec labels necessity a)
unlabler (HLabel HMapTable (Label label) t context
as) =
  (forall (spec :: Spec). HField t spec -> context spec) -> t context
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate ((forall (spec :: Spec). HField t spec -> context spec)
 -> t context)
-> (forall (spec :: Spec). HField t spec -> context spec)
-> t context
forall a b. (a -> b) -> a -> b
$ \HField t spec
field -> 
    case t SSpec -> HField t spec -> SSpec spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs HField t spec
field of
      SSpec {} -> case HMapTable (Label label) t context
-> HField
     (HMapTable (Label label) t) ('Spec (label : labels) necessity a)
-> context ('Spec (label : labels) necessity a)
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield HMapTable (Label label) t context
as (HField t ('Spec labels necessity a)
-> HMapTableField
     (Label label) t (Eval (Label label ('Spec labels necessity a)))
forall e (t :: HTable) (a :: Spec) (f :: Spec -> Exp e).
HField t a -> HMapTableField f t (Eval (f a))
HMapTableField HField t spec
HField t ('Spec labels necessity a)
field) of
        context ('Spec (label : labels) necessity a)
a -> context ('Spec (label : labels) necessity a)
-> context ('Spec labels necessity a)
forall (labels :: Labels) (necessity :: Necessity) a.
context ('Spec (label : labels) necessity a)
-> context ('Spec labels necessity a)
unlabler context ('Spec (label : labels) necessity a)
a
{-# INLINABLE hunlabel #-}