content: {-# language AllowAmbiguousTypes #-}
  {-# language ConstraintKinds #-}
  {-# language DataKinds #-}
  {-# language DeriveAnyClass #-}
  {-# language DeriveFunctor #-}
  {-# language DeriveGeneric #-}
  {-# language DerivingVia #-}
  {-# language FlexibleContexts #-}
  {-# language FlexibleInstances #-}
  {-# language GADTs #-}
  {-# language LambdaCase #-}
  {-# language MultiParamTypeClasses #-}
  {-# language NamedFieldPuns #-}
  {-# language RankNTypes #-}
  {-# language RecordWildCards #-}
  {-# language ScopedTypeVariables #-}
  {-# language StandaloneKindSignatures #-}
  {-# language TypeApplications #-}
  {-# language TypeFamilies #-}
  {-# language UndecidableInstances #-}
  
  module Rel8.Schema.HTable.Vectorize
    ( HVectorize
    , hvectorize, hvectorizeA, hunvectorize
    , hnullify
    , happend, hempty
    , hproject
    , htraverseVectorP
    , hcolumn
    , First (..)
    )
  where
  
  -- base
  import Data.Kind ( Constraint, Type )
  import Data.List.NonEmpty ( NonEmpty )
  import qualified Data.Semigroup as Base
  import GHC.Generics (Generic)
  import Prelude
  
  -- product-profunctors
  import Data.Profunctor.Product (ProductProfunctor)
  
  -- profunctors
  import Data.Profunctor (dimap)
  
  -- rel8
  import Rel8.FCF ( Eval, Exp )
  import Rel8.Schema.Dict ( Dict( Dict ) )
  import qualified Rel8.Schema.Kind as K
  import Rel8.Schema.HTable
    ( HField, HTable, hfield, htabulate, htabulateA, hspecs
    , htraversePWithField
    )
  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.HTable.Nullify (HNullify (HNullify))
  import Rel8.Schema.Null (Nullify, Unnullify, NotNull, Nullity (NotNull))
  import Rel8.Schema.Spec ( Spec(..) )
  import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
  import Rel8.Type.Information ( TypeInformation )
  
  -- semialign
  import Data.Align (Semialign, alignWith)
  import Data.Zip (Unzip, Zip, Zippy(..), zipWith)
  
  -- semigroupoids
  import Data.Functor.Apply (Apply)
  
  
  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 _ = Dict
    vectorTypeInformation = listTypeInformation
  
  
  instance Vector NonEmpty where
    listNotNull _ = Dict
    vectorTypeInformation = nonEmptyTypeInformation
  
  
  type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
  newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
    deriving stock Generic
    deriving anyclass HTable
  
  
  data Vectorize :: (Type -> Type) -> Type -> Exp Type
  
  
  type instance Eval (Vectorize list a) = list a
  
  
  instance Vector list => MapSpec (Vectorize list) where
    mapInfo = \case
      Spec {..} -> case listNotNull @list nullity of
        Dict -> Spec
          { nullity = NotNull
          , info = vectorTypeInformation nullity info
          , ..
          }
  
  
  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 vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
    case hfield hspecs field of
      spec -> vectorizer spec (fmap (`hfield` field) as)
  {-# INLINABLE hvectorize #-}
  
  
  hvectorizeA :: (HTable t, Apply f, Vector list)
    => (forall a. Spec a -> HField t a -> f (context' (list a)))
    -> f (HVectorize list t context')
  hvectorizeA vectorizer = fmap HVectorize $
    htabulateA $ \(HMapTableField field) ->
      case hfield hspecs field of
        spec -> vectorizer spec field
  {-# INLINABLE hvectorizeA #-}
  
  
  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 unvectorizer (HVectorize table) =
    getZippy $ htabulateA $ \field -> case hfield hspecs field of
      spec -> case hfield table (HMapTableField field) of
        a -> Zippy (unvectorizer spec 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 append (HVectorize as) (HVectorize bs) = HVectorize $
    htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
      (a, b) -> case hfield hspecs j of
        spec -> append spec a b
  
  
  hempty :: HTable t
    => (forall a. Spec a -> context [a])
    -> HVectorize [] t context
  hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
    empty (hfield hspecs field)
  
  
  hproject :: ()
    => (forall ctx. t ctx -> t' ctx)
    -> HVectorize list t context -> HVectorize list t' context
  hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)
  
  
  htraverseVectorP :: (HTable t, ProductProfunctor p)
    => (forall a. HField t a -> p (f (list a)) (g (list' a)))
    -> p (HVectorize list t f) (HVectorize list' t g)
  htraverseVectorP f =
    dimap (\(HVectorize (HMapTable a)) -> a) (HVectorize . HMapTable) $
      htraversePWithField $ \field ->
        dimap (\(Precompose a) -> a) Precompose (f field)
  
  
  hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
  hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
  
  
  hnullify :: forall t list context. (HTable t, Vector list)
    => (forall a. Spec a -> context (list a) -> context (Nullify a))
    -> HVectorize list t context
    -> HNullify t context
  hnullify f (HVectorize table) = HNullify $
    htabulate $ \(HMapTableField field) -> case hfield hspecs field of
      spec -> case hfield table (HMapTableField field) of
        a -> f spec a
  
  
  newtype First a b = First {getFirst :: a}
    deriving stock Functor
    deriving (Semigroup) via (Base.First a)
  
  
  instance Semialign (First a) where
    alignWith _ (First a) _ = First a
  
  
  instance Zip (First a) where
    zipWith _ (First a) _ = First a