{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language DeriveAnyClass #-}
{-# language DeriveGeneric #-}
{-# language DerivingStrategies #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language MultiParamTypeClasses #-}
{-# language RankNTypes #-}
{-# language RecordWildCards #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

module Rel8.Schema.HTable.Vectorize
  ( HVectorize
  , hvectorize, hunvectorize
  , happend, hempty
  , hproject
  , hcolumn
  )
where

-- base
import Data.Kind ( Constraint, Type )
import Data.List.NonEmpty ( NonEmpty )
import GHC.Generics (Generic)
import Prelude

-- rel8
import Rel8.FCF ( Eval, Exp )
import Rel8.Schema.Dict ( Dict( Dict ) )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
import Rel8.Schema.HTable.MapTable
  ( HMapTable( HMapTable ), HMapTableField( HMapTableField )
  , MapSpec, mapInfo
  , Precompose( Precompose )
  )
import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
import Rel8.Schema.Spec ( Spec(..) )
import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
import Rel8.Type.Information ( TypeInformation )

-- semialign
import Data.Zip ( Unzip, Zip, Zippy(..) )


type Vector :: (Type -> Type) -> Constraint
class Vector list where
  listNotNull :: proxy a -> Dict NotNull (list a)
  vectorTypeInformation :: ()
    => Nullity a
    -> TypeInformation (Unnullify a)
    -> TypeInformation (list a)


instance Vector [] where
  listNotNull :: proxy a -> Dict NotNull [a]
listNotNull proxy a
_ = Dict NotNull [a]
forall a (c :: a -> Constraint) (a :: a). c a => Dict c a
Dict
  vectorTypeInformation :: Nullity a -> TypeInformation (Unnullify a) -> TypeInformation [a]
vectorTypeInformation = Nullity a -> TypeInformation (Unnullify a) -> TypeInformation [a]
forall a.
Nullity a -> TypeInformation (Unnullify a) -> TypeInformation [a]
listTypeInformation


instance Vector NonEmpty where
  listNotNull :: proxy a -> Dict NotNull (NonEmpty a)
listNotNull proxy a
_ = Dict NotNull (NonEmpty a)
forall a (c :: a -> Constraint) (a :: a). c a => Dict c a
Dict
  vectorTypeInformation :: Nullity a
-> TypeInformation (Unnullify a) -> TypeInformation (NonEmpty a)
vectorTypeInformation = Nullity a
-> TypeInformation (Unnullify a) -> TypeInformation (NonEmpty a)
forall a.
Nullity a
-> TypeInformation (Unnullify a) -> TypeInformation (NonEmpty a)
nonEmptyTypeInformation


type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
  deriving stock (forall x.
 HVectorize list table context
 -> Rep (HVectorize list table context) x)
-> (forall x.
    Rep (HVectorize list table context) x
    -> HVectorize list table context)
-> Generic (HVectorize list table context)
forall x.
Rep (HVectorize list table context) x
-> HVectorize list table context
forall x.
HVectorize list table context
-> Rep (HVectorize list table context) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (list :: * -> *) (table :: HTable) (context :: * -> *) x.
Rep (HVectorize list table context) x
-> HVectorize list table context
forall (list :: * -> *) (table :: HTable) (context :: * -> *) x.
HVectorize list table context
-> Rep (HVectorize list table context) x
$cto :: forall (list :: * -> *) (table :: HTable) (context :: * -> *) x.
Rep (HVectorize list table context) x
-> HVectorize list table context
$cfrom :: forall (list :: * -> *) (table :: HTable) (context :: * -> *) x.
HVectorize list table context
-> Rep (HVectorize list table context) x
Generic
  deriving anyclass HVectorize list table Spec
(forall (context :: * -> *) a.
 HVectorize list table context
 -> HField (HVectorize list table) a -> context a)
-> (forall (context :: * -> *).
    (forall a. HField (HVectorize list table) a -> context a)
    -> HVectorize list table context)
-> (forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
    Apply m =>
    (forall a. f a -> m (g a))
    -> HVectorize list table f -> m (HVectorize list table g))
-> (forall (c :: * -> Constraint).
    HConstrainTable (HVectorize list table) c =>
    HVectorize list table (Dict c))
-> HVectorize list table Spec
-> HTable (HVectorize list table)
forall (c :: * -> Constraint).
HConstrainTable (HVectorize list table) c =>
HVectorize list table (Dict c)
forall (context :: * -> *).
(forall a. HField (HVectorize list table) a -> context a)
-> HVectorize list table context
forall (context :: * -> *) a.
HVectorize list table context
-> HField (HVectorize list table) a -> context a
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Apply m =>
(forall a. f a -> m (g a))
-> HVectorize list table f -> m (HVectorize list table g)
forall (list :: * -> *) (table :: HTable).
(HTable table, Vector list) =>
HVectorize list table Spec
forall (list :: * -> *) (table :: HTable) (c :: * -> Constraint).
(HTable table, Vector list,
 HConstrainTable (HVectorize list table) c) =>
HVectorize list table (Dict c)
forall (list :: * -> *) (table :: HTable) (context :: * -> *).
(HTable table, Vector list) =>
(forall a. HField (HVectorize list table) a -> context a)
-> HVectorize list table context
forall (list :: * -> *) (table :: HTable) (context :: * -> *) a.
(HTable table, Vector list) =>
HVectorize list table context
-> HField (HVectorize list table) a -> context a
forall (list :: * -> *) (table :: HTable) (m :: * -> *)
       (f :: * -> *) (g :: * -> *).
(HTable table, Vector list, Apply m) =>
(forall a. f a -> m (g a))
-> HVectorize list table f -> m (HVectorize list table g)
forall (t :: HTable).
(forall (context :: * -> *) a.
 t context -> HField t a -> context a)
-> (forall (context :: * -> *).
    (forall a. HField t a -> context a) -> t context)
-> (forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
    Apply m =>
    (forall a. f a -> m (g a)) -> t f -> m (t g))
-> (forall (c :: * -> Constraint).
    HConstrainTable t c =>
    t (Dict c))
-> t Spec
-> HTable t
hspecs :: HVectorize list table Spec
$chspecs :: forall (list :: * -> *) (table :: HTable).
(HTable table, Vector list) =>
HVectorize list table Spec
hdicts :: HVectorize list table (Dict c)
$chdicts :: forall (list :: * -> *) (table :: HTable) (c :: * -> Constraint).
(HTable table, Vector list,
 HConstrainTable (HVectorize list table) c) =>
HVectorize list table (Dict c)
htraverse :: (forall a. f a -> m (g a))
-> HVectorize list table f -> m (HVectorize list table g)
$chtraverse :: forall (list :: * -> *) (table :: HTable) (m :: * -> *)
       (f :: * -> *) (g :: * -> *).
(HTable table, Vector list, Apply m) =>
(forall a. f a -> m (g a))
-> HVectorize list table f -> m (HVectorize list table g)
htabulate :: (forall a. HField (HVectorize list table) a -> context a)
-> HVectorize list table context
$chtabulate :: forall (list :: * -> *) (table :: HTable) (context :: * -> *).
(HTable table, Vector list) =>
(forall a. HField (HVectorize list table) a -> context a)
-> HVectorize list table context
hfield :: HVectorize list table context
-> HField (HVectorize list table) a -> context a
$chfield :: forall (list :: * -> *) (table :: HTable) (context :: * -> *) a.
(HTable table, Vector list) =>
HVectorize list table context
-> HField (HVectorize list table) a -> context a
HTable


data Vectorize :: (Type -> Type) -> Type -> Exp Type


type instance Eval (Vectorize list a) = list a


instance Vector list => MapSpec (Vectorize list) where
  mapInfo :: Spec x -> Spec (Eval (Vectorize list x))
mapInfo = \case
    Spec {[String]
Nullity x
TypeInformation (Unnullify x)
nullity :: forall a. Spec a -> Nullity a
info :: forall a. Spec a -> TypeInformation (Unnullify a)
labels :: forall a. Spec a -> [String]
nullity :: Nullity x
info :: TypeInformation (Unnullify x)
labels :: [String]
..} -> case Nullity x -> Dict NotNull (list x)
forall (list :: * -> *) (proxy :: * -> *) a.
Vector list =>
proxy a -> Dict NotNull (list a)
listNotNull @list Nullity x
nullity of
      Dict NotNull (list x)
Dict -> Spec :: forall a.
[String] -> TypeInformation (Unnullify a) -> Nullity a -> Spec a
Spec
        { nullity :: Nullity (list x)
nullity = Nullity (list x)
forall a. NotNull a => Nullity a
NotNull
        , info :: TypeInformation (Unnullify (list x))
info = Nullity x
-> TypeInformation (Unnullify x) -> TypeInformation (list x)
forall (list :: * -> *) a.
Vector list =>
Nullity a
-> TypeInformation (Unnullify a) -> TypeInformation (list a)
vectorTypeInformation Nullity x
nullity TypeInformation (Unnullify x)
info
        , [String]
labels :: [String]
labels :: [String]
..
        }


hvectorize :: (HTable t, Unzip f, Vector list)
  => (forall a. Spec a -> f (context a) -> context' (list a))
  -> f (t context)
  -> HVectorize list t context'
hvectorize :: (forall a. Spec a -> f (context a) -> context' (list a))
-> f (t context) -> HVectorize list t context'
hvectorize forall a. Spec a -> f (context a) -> context' (list a)
vectorizer f (t context)
as = HMapTable (Vectorize list) t context' -> HVectorize list t context'
forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize (HMapTable (Vectorize list) t context'
 -> HVectorize list t context')
-> HMapTable (Vectorize list) t context'
-> HVectorize list t context'
forall a b. (a -> b) -> a -> b
$ (forall a. HField (HMapTable (Vectorize list) t) a -> context' a)
-> HMapTable (Vectorize list) t context'
forall (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate ((forall a. HField (HMapTable (Vectorize list) t) a -> context' a)
 -> HMapTable (Vectorize list) t context')
-> (forall a.
    HField (HMapTable (Vectorize list) t) a -> context' a)
-> HMapTable (Vectorize list) t context'
forall a b. (a -> b) -> a -> b
$ \(HMapTableField field) ->
  case t Spec -> HField t a -> Spec a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
    Spec a
spec -> Spec a -> f (context a) -> context' (list a)
forall a. Spec a -> f (context a) -> context' (list a)
vectorizer Spec a
spec ((t context -> context a) -> f (t context) -> f (context a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t context -> HField t a -> context a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
`hfield` HField t a
field) f (t context)
as)
{-# INLINABLE hvectorize #-}


hunvectorize :: (HTable t, Zip f, Vector list)
  => (forall a. Spec a -> context (list a) -> f (context' a))
  -> HVectorize list t context
  -> f (t context')
hunvectorize :: (forall a. Spec a -> context (list a) -> f (context' a))
-> HVectorize list t context -> f (t context')
hunvectorize forall a. Spec a -> context (list a) -> f (context' a)
unvectorizer (HVectorize HMapTable (Vectorize list) t context
table) =
  Zippy f (t context') -> f (t context')
forall (f :: * -> *) a. Zippy f a -> f a
getZippy (Zippy f (t context') -> f (t context'))
-> Zippy f (t context') -> f (t context')
forall a b. (a -> b) -> a -> b
$ (forall a. HField t a -> Zippy f (context' a))
-> Zippy f (t context')
forall (t :: HTable) (m :: * -> *) (context :: * -> *).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA ((forall a. HField t a -> Zippy f (context' a))
 -> Zippy f (t context'))
-> (forall a. HField t a -> Zippy f (context' a))
-> Zippy f (t context')
forall a b. (a -> b) -> a -> b
$ \HField t a
field -> case t Spec -> HField t a -> Spec a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
    Spec a
spec -> case HMapTable (Vectorize list) t context
-> HField (HMapTable (Vectorize list) t) (list a)
-> context (list a)
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield HMapTable (Vectorize list) t context
table (HField t a
-> HMapTableField (Vectorize list) t (Eval (Vectorize list a))
forall (t :: HTable) a (f :: * -> * -> *).
HField t a -> HMapTableField f t (Eval (f a))
HMapTableField HField t a
field) of
      context (list a)
a -> f (context' a) -> Zippy f (context' a)
forall (f :: * -> *) a. f a -> Zippy f a
Zippy (Spec a -> context (list a) -> f (context' a)
forall a. Spec a -> context (list a) -> f (context' a)
unvectorizer Spec a
spec context (list a)
a)
{-# INLINABLE hunvectorize #-}


happend :: (HTable t, Vector list)
  => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
  -> HVectorize list t context
  -> HVectorize list t context
  -> HVectorize list t context
happend :: (forall a.
 Spec a -> context (list a) -> context (list a) -> context (list a))
-> HVectorize list t context
-> HVectorize list t context
-> HVectorize list t context
happend forall a.
Spec a -> context (list a) -> context (list a) -> context (list a)
append (HVectorize HMapTable (Vectorize list) t context
as) (HVectorize HMapTable (Vectorize list) t context
bs) = HMapTable (Vectorize list) t context -> HVectorize list t context
forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize (HMapTable (Vectorize list) t context -> HVectorize list t context)
-> HMapTable (Vectorize list) t context
-> HVectorize list t context
forall a b. (a -> b) -> a -> b
$
  (forall a. HField (HMapTable (Vectorize list) t) a -> context a)
-> HMapTable (Vectorize list) t context
forall (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate ((forall a. HField (HMapTable (Vectorize list) t) a -> context a)
 -> HMapTable (Vectorize list) t context)
-> (forall a. HField (HMapTable (Vectorize list) t) a -> context a)
-> HMapTable (Vectorize list) t context
forall a b. (a -> b) -> a -> b
$ \field :: HField (HMapTable (Vectorize list) t) a
field@(HMapTableField j) -> case (HMapTable (Vectorize list) t context
-> HField (HMapTable (Vectorize list) t) (list a)
-> context (list a)
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield HMapTable (Vectorize list) t context
as HField (HMapTable (Vectorize list) t) a
HField (HMapTable (Vectorize list) t) (list a)
field, HMapTable (Vectorize list) t context
-> HField (HMapTable (Vectorize list) t) (list a)
-> context (list a)
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield HMapTable (Vectorize list) t context
bs HField (HMapTable (Vectorize list) t) a
HField (HMapTable (Vectorize list) t) (list a)
field) of
    (context (list a)
a, context (list a)
b) -> case t Spec -> HField t a -> Spec a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
j of
      Spec a
spec -> Spec a -> context (list a) -> context (list a) -> context (list a)
forall a.
Spec a -> context (list a) -> context (list a) -> context (list a)
append Spec a
spec context (list a)
a context (list a)
b


hempty :: HTable t
  => (forall a. Spec a -> context [a])
  -> HVectorize [] t context
hempty :: (forall a. Spec a -> context [a]) -> HVectorize [] t context
hempty forall a. Spec a -> context [a]
empty = HMapTable (Vectorize []) t context -> HVectorize [] t context
forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize (HMapTable (Vectorize []) t context -> HVectorize [] t context)
-> HMapTable (Vectorize []) t context -> HVectorize [] t context
forall a b. (a -> b) -> a -> b
$ (forall a. HField (HMapTable (Vectorize []) t) a -> context a)
-> HMapTable (Vectorize []) t context
forall (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate ((forall a. HField (HMapTable (Vectorize []) t) a -> context a)
 -> HMapTable (Vectorize []) t context)
-> (forall a. HField (HMapTable (Vectorize []) t) a -> context a)
-> HMapTable (Vectorize []) t context
forall a b. (a -> b) -> a -> b
$ \(HMapTableField field) ->
  Spec a -> context [a]
forall a. Spec a -> context [a]
empty (t Spec -> HField t a -> Spec a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field)


hproject :: ()
  => (forall ctx. t ctx -> t' ctx)
  -> HVectorize list t context -> HVectorize list t' context
hproject :: (forall (ctx :: * -> *). t ctx -> t' ctx)
-> HVectorize list t context -> HVectorize list t' context
hproject forall (ctx :: * -> *). t ctx -> t' ctx
f (HVectorize HMapTable (Vectorize list) t context
a) = HMapTable (Vectorize list) t' context -> HVectorize list t' context
forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize ((forall (ctx :: * -> *). t ctx -> t' ctx)
-> HMapTable (Vectorize list) t context
-> HMapTable (Vectorize list) t' context
forall (t :: HTable) (t' :: HTable) (f :: * -> * -> *)
       (context :: * -> *).
(forall (ctx :: * -> *). t ctx -> t' ctx)
-> HMapTable f t context -> HMapTable f t' context
HMapTable.hproject forall (ctx :: * -> *). t ctx -> t' ctx
f HMapTable (Vectorize list) t context
a)


hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
hcolumn (HVectorize (HMapTable (HIdentity (Precompose context (Eval (Vectorize list a))
a)))) = context (list a)
context (Eval (Vectorize list a))
a