{-# language AllowAmbiguousTypes #-}
{-# language DataKinds #-}
{-# language DefaultSignatures #-}
{-# language DisambiguateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}

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

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

-- hasql
import qualified Hasql.Decoders as Hasql

-- rel8
import Rel8.Expr ( Expr, Col( E ) )
import Rel8.Expr.Serialize ( slitExpr, sparseValue )
import Rel8.FCF ( Eval, Exp )
import Rel8.Generic.Record ( Record(..) )
import Rel8.Generic.Table
  ( GGToExprs, GGColumns, ggfromResult, ggtoResult
  , GAlgebra
  )
import Rel8.Kind.Algebra ( KnownAlgebra )
import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
import Rel8.Schema.Null ( NotNull, Sql )
import Rel8.Schema.Result ( Col( R ), Result )
import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
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
-- in the 'Result' context.
type ToExprs :: Type -> Type -> Constraint
class Table Expr exprs => ToExprs exprs a where
  fromResult :: Columns exprs (Col Result) -> a
  toResult :: a -> Columns exprs (Col Result)

  default fromResult ::
    ( Generic (Record a)
    , KnownAlgebra (GAlgebra (Rep (Record exprs)))
    , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
    , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
    )
    => Columns exprs (Col Result) -> a
  fromResult =
    Record a -> a
forall a. Record a -> a
unrecord (Record a -> a)
-> (Columns exprs (Col Result) -> Record a)
-> Columns exprs (Col Result)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    GRecord (Rep a) Any -> Record a
forall a x. Generic a => Rep a x -> a
to (GRecord (Rep a) Any -> Record a)
-> (Columns exprs (Col Result) -> GRecord (Rep a) Any)
-> Columns exprs (Col Result)
-> Record a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (forall expr a (proxy :: * -> *).
 Eval (TToExprs expr a) =>
 proxy expr -> Eval (TColumns expr) (Col Result) -> a)
-> Eval
     (GGColumns
        (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
     (Col Result)
-> GRecord (Rep a) Any
forall (algebra :: Algebra) (_ToExprs :: * -> * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (exprs :: * -> *) (rep :: * -> *) x.
(KnownAlgebra algebra,
 Eval (GGToExprs algebra _ToExprs _Columns exprs rep)) =>
(forall expr a (proxy :: * -> *).
 Eval (_ToExprs expr a) =>
 proxy expr -> Eval (_Columns expr) (Col Result) -> a)
-> Eval (GGColumns algebra _Columns exprs) (Col Result) -> rep x
ggfromResult
      @(GAlgebra (Rep (Record exprs)))
      @TToExprs
      @TColumns
      @(Rep (Record exprs))
      (\(proxy expr
_ :: proxy expr) -> forall a. ToExprs expr a => Columns expr (Col Result) -> a
forall exprs a. ToExprs exprs a => Columns exprs (Col Result) -> a
fromResult @expr)

  default toResult ::
    ( Generic (Record a)
    , KnownAlgebra (GAlgebra (Rep (Record exprs)))
    , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
    , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
    )
    => a -> Columns exprs (Col Result)
  toResult =
    (forall expr a (proxy :: * -> *).
 Eval (TToExprs expr a) =>
 proxy expr -> a -> Eval (TColumns expr) (Col Result))
-> GRecord (Rep a) Any
-> Eval
     (GGColumns
        (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
     (Col Result)
forall (algebra :: Algebra) (_ToExprs :: * -> * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (exprs :: * -> *) (rep :: * -> *) x.
(KnownAlgebra algebra,
 Eval (GGToExprs algebra _ToExprs _Columns exprs rep)) =>
(forall expr a (proxy :: * -> *).
 Eval (_ToExprs expr a) =>
 proxy expr -> a -> Eval (_Columns expr) (Col Result))
-> rep x -> Eval (GGColumns algebra _Columns exprs) (Col Result)
ggtoResult
      @(GAlgebra (Rep (Record exprs)))
      @TToExprs
      @TColumns
      @(Rep (Record exprs))
      (\(proxy expr
_ :: proxy expr) -> forall a. ToExprs expr a => a -> Columns expr (Col Result)
forall exprs a. ToExprs exprs a => a -> Columns exprs (Col Result)
toResult @expr) (GRecord (Rep a) Any -> Columns exprs (Col Result))
-> (a -> GRecord (Rep a) Any) -> a -> Columns exprs (Col Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Record a -> GRecord (Rep a) Any
forall a x. Generic a => a -> Rep a x
from (Record a -> GRecord (Rep a) Any)
-> (a -> Record a) -> a -> GRecord (Rep a) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    a -> Record a
forall a. a -> Record a
Record


data TToExprs :: Type -> Type -> Exp Constraint
type instance Eval (TToExprs exprs a) = ToExprs exprs a


instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
  fromResult :: Columns x (Col Result) -> a
fromResult (HType (R a)) = a
a
a
  toResult :: a -> Columns x (Col Result)
toResult = Col Result ('Spec '[] a) -> HType a (Col Result)
forall (context :: Spec -> *) a.
context ('Spec '[] a) -> HType a context
HType (Col Result ('Spec '[] a) -> HType a (Col Result))
-> (a -> Col Result ('Spec '[] a)) -> a -> HType a (Col Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Col Result ('Spec '[] a)
forall a (labels :: Labels). a -> Col Result ('Spec labels a)
R


instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
  fromResult :: Columns (Expr x) (Col Result) -> [a]
fromResult (HType (R a)) = a
[a]
a
  toResult :: [a] -> Columns (Expr x) (Col Result)
toResult = Col Result ('Spec '[] [a]) -> HType [a] (Col Result)
forall (context :: Spec -> *) a.
context ('Spec '[] a) -> HType a context
HType (Col Result ('Spec '[] [a]) -> HType [a] (Col Result))
-> ([a] -> Col Result ('Spec '[] [a]))
-> [a]
-> HType [a] (Col Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Col Result ('Spec '[] [a])
forall a (labels :: Labels). a -> Col Result ('Spec labels a)
R


instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
 where
  fromResult :: Columns (Expr x) (Col Result) -> Maybe a
fromResult (HType (R a)) = a
Maybe a
a
  toResult :: Maybe a -> Columns (Expr x) (Col Result)
toResult = Col Result ('Spec '[] (Maybe a)) -> HType (Maybe a) (Col Result)
forall (context :: Spec -> *) a.
context ('Spec '[] a) -> HType a context
HType (Col Result ('Spec '[] (Maybe a)) -> HType (Maybe a) (Col Result))
-> (Maybe a -> Col Result ('Spec '[] (Maybe a)))
-> Maybe a
-> HType (Maybe a) (Col Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Col Result ('Spec '[] (Maybe a))
forall a (labels :: Labels). a -> Col Result ('Spec labels a)
R


instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
 where
  fromResult :: Columns (Expr x) (Col Result) -> NonEmpty a
fromResult (HType (R a)) = a
NonEmpty a
a
  toResult :: NonEmpty a -> Columns (Expr x) (Col Result)
toResult = Col Result ('Spec '[] (NonEmpty a))
-> HType (NonEmpty a) (Col Result)
forall (context :: Spec -> *) a.
context ('Spec '[] a) -> HType a context
HType (Col Result ('Spec '[] (NonEmpty a))
 -> HType (NonEmpty a) (Col Result))
-> (NonEmpty a -> Col Result ('Spec '[] (NonEmpty a)))
-> NonEmpty a
-> HType (NonEmpty a) (Col Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> Col Result ('Spec '[] (NonEmpty a))
forall a (labels :: Labels). a -> Col Result ('Spec labels a)
R


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)


instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
  ToExprs x (t result)
 where
  fromResult :: Columns x (Col Result) -> t result
fromResult = Columns x (Col Result) -> t result
forall a. a -> a
id
  toResult :: t result -> Columns x (Col Result)
toResult = t result -> Columns x (Col Result)
forall a. a -> a
id


instance (KnownSpec spec, x ~ Col Expr spec) =>
  ToExprs x (Col Result spec)
 where
  fromResult :: Columns x (Col Result) -> Col Result spec
fromResult = Columns x (Col Result) -> Col Result spec
forall (context :: Context) a.
Table context a =>
Columns a (Col context) -> a
fromColumns
  toResult :: Col Result spec -> Columns x (Col Result)
toResult = Col Result spec -> Columns x (Col Result)
forall (context :: Context) a.
Table context a =>
a -> Columns a (Col context)
toColumns


-- | The @FromExprs@ type function maps a type in the @Expr@ context to the
-- corresponding type in the @Result@ context.
type FromExprs :: Type -> Type
type family FromExprs a
type instance FromExprs (Expr a) = a
type instance FromExprs (Col Expr spec) = Col Result spec
type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
type instance FromExprs (a, b, c, d) =
  (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
type instance FromExprs (a, b, c, d, e) =
  (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
type instance FromExprs (a, b, c, d, e, f) =
  ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
  , FromExprs f
  )
type instance FromExprs (a, b, c, d, e, f, g) =
  ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
  , FromExprs f, FromExprs g
  )
type instance FromExprs (t (Col Expr)) = t (Col Result)


-- | @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 (Col Expr) -> exprs
forall (context :: Context) a.
Table context a =>
Columns a (Col context) -> a
fromColumns (Columns exprs (Col Expr) -> exprs)
-> (a -> Columns exprs (Col Expr)) -> a -> exprs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Columns exprs (Col Result) -> Columns exprs (Col Expr)
forall (t :: HTable). HTable t => t (Col Result) -> t (Col Expr)
litHTable (Columns exprs (Col Result) -> Columns exprs (Col Expr))
-> (a -> Columns exprs (Col Result))
-> a
-> Columns exprs (Col Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExprs exprs a => a -> Columns exprs (Col Result)
forall exprs a. ToExprs exprs a => a -> Columns exprs (Col Result)
toResult @exprs


parse :: forall exprs a. Serializable exprs a => Hasql.Row a
parse :: Row a
parse = forall a. ToExprs exprs a => Columns exprs (Col Result) -> a
forall exprs a. ToExprs exprs a => Columns exprs (Col Result) -> a
fromResult @exprs (Columns exprs (Col Result) -> a)
-> Row (Columns exprs (Col Result)) -> Row a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Row (Columns exprs (Col Result))
forall (t :: HTable). HTable t => Row (t (Col Result))
parseHTable


litHTable :: HTable t => t (Col Result) -> t (Col Expr)
litHTable :: t (Col Result) -> t (Col Expr)
litHTable t (Col Result)
as = (forall (spec :: Spec). HField t spec -> Col Expr spec)
-> t (Col Expr)
forall (t :: HTable) (context :: Spec -> *).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate ((forall (spec :: Spec). HField t spec -> Col Expr spec)
 -> t (Col Expr))
-> (forall (spec :: Spec). HField t spec -> Col Expr spec)
-> t (Col Expr)
forall a b. (a -> b) -> a -> b
$ \HField t spec
field ->
  case t SSpec -> HField t spec -> SSpec spec
forall (t :: HTable) (context :: Spec -> *) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs HField t spec
field of
    SSpec {Nullity a
nullity :: forall (labels :: Labels) a. SSpec ('Spec labels a) -> Nullity a
nullity :: Nullity a
nullity, TypeInformation (Unnullify a)
info :: forall (labels :: Labels) a.
SSpec ('Spec labels a) -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> case t (Col Result)
-> HField t ('Spec labels a) -> Col Result ('Spec labels a)
forall (t :: HTable) (context :: Spec -> *) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t (Col Result)
as HField t spec
HField t ('Spec labels a)
field of
      R value -> Expr a -> Col Expr ('Spec labels a)
forall a (labels :: Labels). Expr a -> Col Expr ('Spec labels a)
E (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
a
value)


parseHTable :: HTable t => Hasql.Row (t (Col Result))
parseHTable :: Row (t (Col Result))
parseHTable = WrappedApplicative Row (t (Col Result)) -> Row (t (Col Result))
forall (f :: * -> *) a. WrappedApplicative f a -> f a
unwrapApplicative (WrappedApplicative Row (t (Col Result)) -> Row (t (Col Result)))
-> WrappedApplicative Row (t (Col Result)) -> Row (t (Col Result))
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec).
 HField t spec -> WrappedApplicative Row (Col Result spec))
-> WrappedApplicative Row (t (Col Result))
forall (t :: HTable) (m :: * -> *) (context :: Spec -> *).
(HTable t, Apply m) =>
(forall (spec :: Spec). HField t spec -> m (context spec))
-> m (t context)
htabulateA ((forall (spec :: Spec).
  HField t spec -> WrappedApplicative Row (Col Result spec))
 -> WrappedApplicative Row (t (Col Result)))
-> (forall (spec :: Spec).
    HField t spec -> WrappedApplicative Row (Col Result spec))
-> WrappedApplicative Row (t (Col Result))
forall a b. (a -> b) -> a -> b
$ \HField t spec
field ->
  Row (Col Result spec) -> WrappedApplicative Row (Col Result spec)
forall (f :: * -> *) a. f a -> WrappedApplicative f a
WrapApplicative (Row (Col Result spec) -> WrappedApplicative Row (Col Result spec))
-> Row (Col Result spec)
-> WrappedApplicative Row (Col Result spec)
forall a b. (a -> b) -> a -> b
$ case t SSpec -> HField t spec -> SSpec spec
forall (t :: HTable) (context :: Spec -> *) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs HField t spec
field of
    SSpec {Nullity a
nullity :: Nullity a
nullity :: forall (labels :: Labels) a. SSpec ('Spec labels a) -> Nullity a
nullity, TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall (labels :: Labels) a.
SSpec ('Spec labels a) -> TypeInformation (Unnullify a)
info} -> a -> Col Result ('Spec labels a)
forall a (labels :: Labels). a -> Col Result ('Spec labels a)
R (a -> Col Result ('Spec labels a))
-> Row a -> Row (Col Result ('Spec labels a))
forall (f :: * -> *) 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