{-# language AllowAmbiguousTypes #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

module Rel8.Table.Serialize
  ( Serializable, lit, litHTable, parse
  , ToExprs
  )
where

-- base
import Data.Functor.Identity ( Identity( Identity ) )
import Data.Kind ( Constraint, Type )
import Data.List.NonEmpty ( NonEmpty )
import Prelude

-- hasql
import qualified Hasql.Decoders as Hasql

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Expr.Serialize ( slitExpr, sparseValue )
import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
import Rel8.Schema.Null ( NotNull, Sql )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( Spec(..) )
import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
import Rel8.Type ( DBType )

-- semigroupoids
import Data.Functor.Apply ( WrappedApplicative(..) )


-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
-- a normal Haskell type.
type ToExprs :: Type -> Type -> Constraint
class Table Expr exprs => ToExprs exprs a


instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a


instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]


instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)


instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)


instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
  ToExprs x (a, b)


instance
  ( ToExprs exprs1 a
  , ToExprs exprs2 b
  , ToExprs exprs3 c
  , x ~ (exprs1, exprs2, exprs3)
  )
  => ToExprs x (a, b, c)


instance
  ( ToExprs exprs1 a
  , ToExprs exprs2 b
  , ToExprs exprs3 c
  , ToExprs exprs4 d
  , x ~ (exprs1, exprs2, exprs3, exprs4)
  )
  => ToExprs x (a, b, c, d)


instance
  ( ToExprs exprs1 a
  , ToExprs exprs2 b
  , ToExprs exprs3 c
  , ToExprs exprs4 d
  , ToExprs exprs5 e
  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
  )
  => ToExprs x (a, b, c, d, e)


instance
  ( ToExprs exprs1 a
  , ToExprs exprs2 b
  , ToExprs exprs3 c
  , ToExprs exprs4 d
  , ToExprs exprs5 e
  , ToExprs exprs6 f
  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
  )
  => ToExprs x (a, b, c, d, e, f)


instance
  ( ToExprs exprs1 a
  , ToExprs exprs2 b
  , ToExprs exprs3 c
  , ToExprs exprs4 d
  , ToExprs exprs5 e
  , ToExprs exprs6 f
  , ToExprs exprs7 g
  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
  )
  => ToExprs x (a, b, c, d, e, f, g)


-- | @Serializable@ witnesses the one-to-one correspondence between the type
-- @sql@, which contains SQL expressions, and the type @haskell@, which
-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
type Serializable :: Type -> Type -> Constraint
class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a


-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
-- capable of lifting single @Expr@s to full tables.
lit :: forall exprs a. Serializable exprs a => a -> exprs
lit :: a -> exprs
lit = Columns exprs Expr -> exprs
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns (Columns exprs Expr -> exprs)
-> (a -> Columns exprs Expr) -> a -> exprs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Columns exprs Result -> Columns exprs Expr
forall (t :: HTable). HTable t => t Result -> t Expr
litHTable (Columns exprs Result -> Columns exprs Expr)
-> (a -> Columns exprs Result) -> a -> Columns exprs Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table Expr exprs => FromExprs exprs -> Columns exprs Result
forall (context :: Context) a.
Table context a =>
FromExprs a -> Columns a Result
toResult @_ @exprs


parse :: forall exprs a. Serializable exprs a => Hasql.Row a
parse :: Row a
parse = Table Expr exprs => Columns exprs Result -> FromExprs exprs
forall (context :: Context) a.
Table context a =>
Columns a Result -> FromExprs a
fromResult @_ @exprs (Columns exprs Result -> a) -> Row (Columns exprs Result) -> Row a
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Row (Columns exprs Result)
forall (t :: HTable). HTable t => Row (t Result)
parseHTable


litHTable :: HTable t => t Result -> t Expr
litHTable :: t Result -> t Expr
litHTable t Result
as = (forall a. HField t a -> Expr a) -> t Expr
forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate ((forall a. HField t a -> Expr a) -> t Expr)
-> (forall a. HField t a -> Expr a) -> t Expr
forall a b. (a -> b) -> a -> b
$ \HField t a
field ->
  case t Spec -> HField t a -> Spec a
forall (t :: HTable) (context :: 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 {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity, TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> case t Result -> HField t a -> Result a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Result
as HField t a
field of
      Identity a
value -> Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a
forall a. Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a
slitExpr Nullity a
nullity TypeInformation (Unnullify a)
info a
value


parseHTable :: HTable t => Hasql.Row (t Result)
parseHTable :: Row (t Result)
parseHTable = WrappedApplicative Row (t Result) -> Row (t Result)
forall (f :: Context) a. WrappedApplicative f a -> f a
unwrapApplicative (WrappedApplicative Row (t Result) -> Row (t Result))
-> WrappedApplicative Row (t Result) -> Row (t Result)
forall a b. (a -> b) -> a -> b
$ (forall a. HField t a -> WrappedApplicative Row (Result a))
-> WrappedApplicative Row (t Result)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA ((forall a. HField t a -> WrappedApplicative Row (Result a))
 -> WrappedApplicative Row (t Result))
-> (forall a. HField t a -> WrappedApplicative Row (Result a))
-> WrappedApplicative Row (t Result)
forall a b. (a -> b) -> a -> b
$ \HField t a
field ->
  Row (Result a) -> WrappedApplicative Row (Result a)
forall (f :: Context) a. f a -> WrappedApplicative f a
WrapApplicative (Row (Result a) -> WrappedApplicative Row (Result a))
-> Row (Result a) -> WrappedApplicative Row (Result a)
forall a b. (a -> b) -> a -> b
$ case t Spec -> HField t a -> Spec a
forall (t :: HTable) (context :: 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 {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity, TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info} -> a -> Result a
forall a. a -> Identity a
Identity (a -> Result a) -> Row a -> Row (Result a)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Nullity a -> TypeInformation (Unnullify a) -> Row a
forall a. Nullity a -> TypeInformation (Unnullify a) -> Row a
sparseValue Nullity a
nullity TypeInformation (Unnullify a)
info