{-# 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 :: forall (proxy :: * -> *) a. proxy a -> Dict NotNull [a]
listNotNull proxy a
_ = forall {a} (c :: a -> Constraint) (a :: a). c a => Dict c a
Dict
  vectorTypeInformation :: forall a.
Nullity a -> TypeInformation (Unnullify a) -> TypeInformation [a]
vectorTypeInformation = forall a.
Nullity a -> TypeInformation (Unnullify a) -> TypeInformation [a]
listTypeInformation


instance Vector NonEmpty where
  listNotNull :: forall (proxy :: * -> *) a. proxy a -> Dict NotNull (NonEmpty a)
listNotNull proxy a
_ = forall {a} (c :: a -> Constraint) (a :: a). c a => Dict c a
Dict
  vectorTypeInformation :: forall a.
Nullity a
-> TypeInformation (Unnullify a) -> TypeInformation (NonEmpty a)
vectorTypeInformation = 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 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 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 :: forall (c :: * -> Constraint).
HConstrainTable (HVectorize list table) c =>
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 (m :: * -> *) (f :: * -> *) (g :: * -> *).
Apply m =>
(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 (context :: * -> *).
(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 :: forall (context :: * -> *) a.
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 :: forall x. 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 forall (list :: * -> *) (proxy :: * -> *) a.
Vector list =>
proxy a -> Dict NotNull (list a)
listNotNull @list Nullity x
nullity of
      Dict NotNull (list x)
Dict -> Spec
        { nullity :: Nullity (list x)
nullity = forall a. NotNull a => Nullity a
NotNull
        , info :: TypeInformation (Unnullify (list x))
info = 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 (t :: HTable) (f :: * -> *) (list :: * -> *)
       (context :: * -> *) (context' :: * -> *).
(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)
vectorizer f (t context)
as = forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate forall a b. (a -> b) -> a -> b
$ \(HMapTableField HField t a
field) ->
  case forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
    Spec a
spec -> forall a. Spec a -> f (context a) -> context' (list a)
vectorizer Spec a
spec (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (t :: HTable) (f :: * -> *) (list :: * -> *)
       (context :: * -> *) (context' :: * -> *).
(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)
unvectorizer (HVectorize HMapTable (Vectorize list) t context
table) =
  forall (f :: * -> *) a. Zippy f a -> f a
getZippy forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (m :: * -> *) (context :: * -> *).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA forall a b. (a -> b) -> a -> b
$ \HField t a
field -> case forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
    Spec a
spec -> case forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield HMapTable (Vectorize list) t context
table (forall (t :: HTable) a (f :: * -> * -> *).
HField t a -> HMapTableField f t (Eval (f a))
HMapTableField HField t a
field) of
      context (list a)
a -> forall (f :: * -> *) a. f a -> Zippy f a
Zippy (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 (t :: HTable) (list :: * -> *) (context :: * -> *).
(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)
append (HVectorize HMapTable (Vectorize list) t context
as) (HVectorize HMapTable (Vectorize list) t context
bs) = forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize forall a b. (a -> b) -> a -> b
$
  forall (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate forall a b. (a -> b) -> a -> b
$ \field :: HField (HMapTable (Vectorize list) t) a
field@(HMapTableField HField t a
j) -> case (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
field, 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
field) of
    (context (list a)
a, context (list a)
b) -> case forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield forall (t :: HTable). HTable t => t Spec
hspecs HField t a
j of
      Spec a
spec -> 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 (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. Spec a -> context [a]) -> HVectorize [] t context
hempty forall a. Spec a -> context [a]
empty = forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate forall a b. (a -> b) -> a -> b
$ \(HMapTableField HField t a
field) ->
  forall a. Spec a -> context [a]
empty (forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield 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 (t :: HTable) (t' :: HTable) (list :: * -> *)
       (context :: * -> *).
(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) = forall (list :: * -> *) (table :: HTable) (context :: * -> *).
HMapTable (Vectorize list) table context
-> HVectorize list table context
HVectorize (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 :: forall (list :: * -> *) a (context :: * -> *).
HVectorize list (HIdentity a) context -> context (list a)
hcolumn (HVectorize (HMapTable (HIdentity (Precompose context (Eval (Vectorize list a))
a)))) = context (Eval (Vectorize list a))
a