{-# language AllowAmbiguousTypes #-}
{-# language BlockArguments #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language InstanceSigs #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}

module Rel8.Schema.HTable.MapTable
  ( HMapTable(..)
  , MapSpec(..)
  , Precompose(..)
  , HMapTableField(..)
  )
where

-- base
import Data.Kind ( Constraint, Type )
import Prelude ( ($), (.), (<$>), fmap )

-- rel8
import Rel8.FCF
import Rel8.Schema.HTable
import Rel8.Schema.Spec ( Spec, SSpec )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Dict ( Dict( Dict ) )


type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
newtype HMapTable f t g = HMapTable
  { HMapTable f t g -> t (Precompose f g)
unHMapTable :: t (Precompose f g)
  }


type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
newtype Precompose f g x = Precompose
  { Precompose f g x -> g (Eval (f x))
precomposed :: g (Eval (f x))
  }


type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
data HMapTableField f t x where
  HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))


instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
  type HField (HMapTable f t) = 
    HMapTableField f t

  type HConstrainTable (HMapTable f t) c =
    HConstrainTable t (ComposeConstraint f c)

  hfield :: HMapTable f t context
-> HField (HMapTable f t) spec -> context spec
hfield (HMapTable t (Precompose f context)
x) (HMapTableField i) = 
    Precompose f context a -> context (Eval (f a))
forall b a (f :: a -> Exp b) (g :: Exp b) (x :: a).
Precompose f g x -> g (Eval (f x))
precomposed (t (Precompose f context) -> HField t a -> Precompose f context a
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t (Precompose f context)
x HField t a
i) 

  htabulate :: (forall (spec :: Spec).
 HField (HMapTable f t) spec -> context spec)
-> HMapTable f t context
htabulate forall (spec :: Spec). HField (HMapTable f t) spec -> context spec
f = 
    t (Precompose f context) -> HMapTable f t context
forall a b (f :: a -> Exp b) (t :: (a -> *) -> *) (g :: Exp b).
t (Precompose f g) -> HMapTable f t g
HMapTable (t (Precompose f context) -> HMapTable f t context)
-> t (Precompose f context) -> HMapTable f t context
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec). HField t spec -> Precompose f context spec)
-> t (Precompose f context)
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate (context (Eval (f spec)) -> Precompose f context spec
forall a b (f :: a -> Exp b) (g :: Exp b) (x :: a).
g (Eval (f x)) -> Precompose f g x
Precompose (context (Eval (f spec)) -> Precompose f context spec)
-> (HField t spec -> context (Eval (f spec)))
-> HField t spec
-> Precompose f context spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HMapTableField f t (Eval (f spec)) -> context (Eval (f spec))
forall (spec :: Spec). HField (HMapTable f t) spec -> context spec
f (HMapTableField f t (Eval (f spec)) -> context (Eval (f spec)))
-> (HField t spec -> HMapTableField f t (Eval (f spec)))
-> HField t spec
-> context (Eval (f spec))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HField t spec -> HMapTableField f t (Eval (f spec))
forall e (t :: HTable) (a :: Spec) (f :: Spec -> Exp e).
HField t a -> HMapTableField f t (Eval (f a))
HMapTableField)

  htraverse :: (forall (spec :: Spec). f spec -> m (g spec))
-> HMapTable f t f -> m (HMapTable f t g)
htraverse forall (spec :: Spec). f spec -> m (g spec)
f (HMapTable t (Precompose f f)
x) = 
    t (Precompose f g) -> HMapTable f t g
forall a b (f :: a -> Exp b) (t :: (a -> *) -> *) (g :: Exp b).
t (Precompose f g) -> HMapTable f t g
HMapTable (t (Precompose f g) -> HMapTable f t g)
-> m (t (Precompose f g)) -> m (HMapTable f t g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (spec :: Spec).
 Precompose f f spec -> m (Precompose f g spec))
-> t (Precompose f f) -> m (t (Precompose f g))
forall (t :: HTable) (m :: * -> *) (f :: HContext) (g :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). f spec -> m (g spec)) -> t f -> m (t g)
htraverse ((g (Eval (f spec)) -> Precompose f g spec)
-> m (g (Eval (f spec))) -> m (Precompose f g spec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g (Eval (f spec)) -> Precompose f g spec
forall a b (f :: a -> Exp b) (g :: Exp b) (x :: a).
g (Eval (f x)) -> Precompose f g x
Precompose (m (g (Eval (f spec))) -> m (Precompose f g spec))
-> (Precompose f f spec -> m (g (Eval (f spec))))
-> Precompose f f spec
-> m (Precompose f g spec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Eval (f spec)) -> m (g (Eval (f spec)))
forall (spec :: Spec). f spec -> m (g spec)
f (f (Eval (f spec)) -> m (g (Eval (f spec))))
-> (Precompose f f spec -> f (Eval (f spec)))
-> Precompose f f spec
-> m (g (Eval (f spec)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Precompose f f spec -> f (Eval (f spec))
forall b a (f :: a -> Exp b) (g :: Exp b) (x :: a).
Precompose f g x -> g (Eval (f x))
precomposed) t (Precompose f f)
x
  {-# INLINABLE htraverse #-}

  hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
  hdicts :: HMapTable f t (Dict c)
hdicts = 
    (forall (spec :: Spec). HField (HMapTable f t) spec -> Dict c spec)
-> HMapTable f t (Dict c)
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate \(HMapTableField j) ->
      case t (Dict (ComposeConstraint f c))
-> HField t a -> Dict (ComposeConstraint f c) a
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield (HConstrainTable t (ComposeConstraint f c) =>
t (Dict (ComposeConstraint f c))
forall (t :: HTable) (c :: Spec -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts @_ @(ComposeConstraint f c)) HField t a
j of
        Dict (ComposeConstraint f c) a
Dict -> Dict c spec
forall a (c :: a -> Constraint) (a :: a). c a => Dict c a
Dict

  hspecs :: HMapTable f t SSpec
hspecs = 
    t (Precompose f SSpec) -> HMapTable f t SSpec
forall a b (f :: a -> Exp b) (t :: (a -> *) -> *) (g :: Exp b).
t (Precompose f g) -> HMapTable f t g
HMapTable (t (Precompose f SSpec) -> HMapTable f t SSpec)
-> t (Precompose f SSpec) -> HMapTable f t SSpec
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec). HField t spec -> Precompose f SSpec spec)
-> t (Precompose f SSpec)
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate ((forall (spec :: Spec). HField t spec -> Precompose f SSpec spec)
 -> t (Precompose f SSpec))
-> (forall (spec :: Spec).
    HField t spec -> Precompose f SSpec spec)
-> t (Precompose f SSpec)
forall a b. (a -> b) -> a -> b
$ SSpec (Eval (f spec)) -> Precompose f SSpec spec
forall a b (f :: a -> Exp b) (g :: Exp b) (x :: a).
g (Eval (f x)) -> Precompose f g x
Precompose (SSpec (Eval (f spec)) -> Precompose f SSpec spec)
-> (HField t spec -> SSpec (Eval (f spec)))
-> HField t spec
-> Precompose f SSpec spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (x :: Spec). MapSpec f => SSpec x -> SSpec (Eval (f x))
forall (f :: Spec -> HContext) (x :: Spec).
MapSpec f =>
SSpec x -> SSpec (Eval (f x))
mapInfo @f (SSpec spec -> SSpec (Eval (f spec)))
-> (HField t spec -> SSpec spec)
-> HField t spec
-> SSpec (Eval (f spec))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  {-# INLINABLE hspecs #-}


type MapSpec :: (Spec -> Exp Spec) -> Constraint
class MapSpec f where
  mapInfo :: SSpec x -> SSpec (Eval (f x))


type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
class c (Eval (f a)) => ComposeConstraint f c a
instance c (Eval (f a)) => ComposeConstraint f c a