{-# language AllowAmbiguousTypes #-}
{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}
{-# language ViewPatterns #-}

module Rel8.Type.Composite
  ( Composite( Composite )
  , DBComposite( compositeFields, compositeTypeName )
  , compose, decompose
  )
where

-- base
import Data.Functor.Const ( Const( Const ), getConst )
import Data.Kind ( Constraint, Type )
import Prelude

-- hasql
import qualified Hasql.Decoders as Hasql

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

-- rel8
import Rel8.Expr ( Col( E ), Expr )
import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA )
import Rel8.Schema.Name ( Col( N ), Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.Result ( Col( R ), Result )
import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
import Rel8.Table ( Table, fromColumns, toColumns )
import Rel8.Table.Eq ( EqTable )
import Rel8.Table.HKD ( HKD, HKDable, fromHKD, toHKD )
import Rel8.Table.Ord ( OrdTable )
import Rel8.Table.Rel8able ()
import Rel8.Table.Serialize ( lit )
import Rel8.Type ( DBType, typeInformation )
import Rel8.Type.Eq ( DBEq )
import Rel8.Type.Information ( TypeInformation(..) )
import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )

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


-- | A deriving-via helper type for column types that store a Haskell product
-- type in a single Postgres column using a Postgres composite type.
--
-- Note that this must map to a specific extant type in your database's schema
-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this
-- Postgres type and the names of the individual fields (for projecting with
-- 'decompose').
type Composite :: Type -> Type
newtype Composite a = Composite
  { Composite a -> a
unComposite :: a
  }


instance DBComposite a => DBType (Composite a) where
  typeInformation :: TypeInformation (Composite a)
typeInformation = TypeInformation :: forall a. (a -> PrimExpr) -> Value a -> String -> TypeInformation a
TypeInformation
    { decode :: Value (Composite a)
decode = Composite (Composite a) -> Value (Composite a)
forall a. Composite a -> Value a
Hasql.composite (a -> Composite a
forall a. a -> Composite a
Composite (a -> Composite a)
-> (HKD a Result -> a) -> HKD a Result -> Composite a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HKD a Result -> a
forall a. HKDable a => HKD a Result -> a
fromHKD (HKD a Result -> Composite a)
-> Composite (HKD a Result) -> Composite (Composite a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Composite (HKD a Result)
forall a. Table Result a => Composite a
decoder)
    , encode :: Composite a -> PrimExpr
encode = Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
  (Col Expr)
-> PrimExpr
forall a. Table Expr a => a -> PrimExpr
encoder (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
   (Col Expr)
 -> PrimExpr)
-> (Composite a
    -> Eval
         (GGColumns
            (GAlgebra (Rep a))
            TColumns
            (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
         (Col Expr))
-> Composite a
-> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
  (Col Result)
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
     (Col Expr)
forall exprs a. Serializable exprs a => a -> exprs
lit (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
   (Col Result)
 -> Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
      (Col Expr))
-> (Composite a
    -> Eval
         (GGColumns
            (GAlgebra (Rep a))
            TColumns
            (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
         (Col Result))
-> Composite a
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
     (Col Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HKD a Result
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
     (Col Result)
forall (context :: Context) a.
Table context a =>
a -> Columns a (Col context)
toColumns (HKD a Result
 -> Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
      (Col Result))
-> (Composite a -> HKD a Result)
-> Composite a
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
     (Col Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HKD a Result
forall a. HKDable a => a -> HKD a Result
toHKD (a -> HKD a Result)
-> (Composite a -> a) -> Composite a -> HKD a Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite a -> a
forall a. Composite a -> a
unComposite
    , typeName :: String
typeName = DBComposite a => String
forall a. DBComposite a => String
compositeTypeName @a
    }


instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)


instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)


instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)


instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)


type DBComposite :: Type -> Constraint
class (DBType a, HKDable a) => DBComposite a where
  compositeFields :: HKD a Name
  compositeTypeName :: String


compose :: DBComposite a => HKD a Expr -> Expr a
compose :: HKD a Expr -> Expr a
compose = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a)
-> (HKD a Expr -> Expr a) -> HKD a Expr -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a)
-> (HKD a Expr -> PrimExpr) -> HKD a Expr -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HKD a Expr -> PrimExpr
forall a. Table Expr a => a -> PrimExpr
encoder


decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
decompose :: Expr a -> HKD a Expr
decompose (Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr -> PrimExpr
a) = Columns (HKD a Expr) (Col Expr) -> HKD a Expr
forall (context :: Context) a.
Table context a =>
Columns a (Col context) -> a
fromColumns (Columns (HKD a Expr) (Col Expr) -> HKD a Expr)
-> Columns (HKD a Expr) (Col Expr) -> HKD a Expr
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec).
 HField
   (Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn (Reify Result)) (Rep a)))))
   spec
 -> Col Expr spec)
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
     (Col Expr)
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate \HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a)))))
  spec
field ->
  case Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
  (Col Name)
-> HField
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn (Reify Result)) (Rep a)))))
     spec
-> Col Name spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
  (Col Name)
Columns (HKD a Name) (Col Name)
names HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a)))))
  spec
field of
    N (Name name) -> case Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
  SSpec
-> HField
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn (Reify Result)) (Rep a)))))
     ('Spec labels necessity a)
-> SSpec ('Spec labels necessity a)
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
  SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a)))))
  spec
HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn (Reify Result)) (Rep a)))))
  ('Spec labels necessity a)
field of
      SSpec {} -> Expr a -> Col Expr ('Spec labels necessity a)
forall a (labels :: Labels) (necessity :: Necessity).
Expr a -> Col Expr ('Spec labels necessity a)
E (Expr a -> Col Expr ('Spec labels necessity a))
-> Expr a -> Col Expr ('Spec labels necessity a)
forall a b. (a -> b) -> a -> b
$ PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a) -> PrimExpr -> Expr a
forall a b. (a -> b) -> a -> b
$ PrimExpr -> String -> PrimExpr
Opaleye.CompositeExpr PrimExpr
a String
name
  where
    names :: Columns (HKD a Name) (Col Name)
names = HKD a Name -> Columns (HKD a Name) (Col Name)
forall (context :: Context) a.
Table context a =>
a -> Columns a (Col context)
toColumns (DBComposite a => HKD a Name
forall a. DBComposite a => HKD a Name
compositeFields @a)


decoder :: Table Result a => Hasql.Composite a
decoder :: Composite a
decoder = (Columns a (Col Result) -> a)
-> Composite (Columns a (Col Result)) -> Composite a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Columns a (Col Result) -> a
forall (context :: Context) a.
Table context a =>
Columns a (Col context) -> a
fromColumns (Composite (Columns a (Col Result)) -> Composite a)
-> Composite (Columns a (Col Result)) -> Composite a
forall a b. (a -> b) -> a -> b
$ WrappedApplicative Composite (Columns a (Col Result))
-> Composite (Columns a (Col Result))
forall (f :: * -> *) a. WrappedApplicative f a -> f a
unwrapApplicative (WrappedApplicative Composite (Columns a (Col Result))
 -> Composite (Columns a (Col Result)))
-> WrappedApplicative Composite (Columns a (Col Result))
-> Composite (Columns a (Col Result))
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec).
 HField (Columns a) spec
 -> WrappedApplicative Composite (Col Result spec))
-> WrappedApplicative Composite (Columns a (Col Result))
forall (t :: HTable) (m :: * -> *) (context :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). HField t spec -> m (context spec))
-> m (t context)
htabulateA \HField (Columns a) spec
field ->
  case Columns a SSpec -> HField (Columns a) spec -> SSpec spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield Columns a SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs HField (Columns a) spec
field of
    SSpec {Nullity a
nullity :: Nullity a
nullity :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> Nullity a
nullity, TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> TypeInformation (Unnullify a)
info} -> Composite (Col Result ('Spec labels necessity a))
-> WrappedApplicative
     Composite (Col Result ('Spec labels necessity a))
forall (f :: * -> *) a. f a -> WrappedApplicative f a
WrapApplicative (Composite (Col Result ('Spec labels necessity a))
 -> WrappedApplicative
      Composite (Col Result ('Spec labels necessity a)))
-> Composite (Col Result ('Spec labels necessity a))
-> WrappedApplicative
     Composite (Col Result ('Spec labels necessity a))
forall a b. (a -> b) -> a -> b
$ a -> Col Result ('Spec labels necessity a)
forall a (labels :: Labels) (necessity :: Necessity).
a -> Col Result ('Spec labels necessity a)
R (a -> Col Result ('Spec labels necessity a))
-> Composite a -> Composite (Col Result ('Spec labels necessity a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      case Nullity a
nullity of
        Nullity a
Null -> NullableOrNot Value (Maybe a) -> Composite (Maybe a)
forall a. NullableOrNot Value a -> Composite a
Hasql.field (NullableOrNot Value (Maybe a) -> Composite (Maybe a))
-> NullableOrNot Value (Maybe a) -> Composite (Maybe a)
forall a b. (a -> b) -> a -> b
$ Value a -> NullableOrNot Value (Maybe a)
forall (decoder :: * -> *) a.
decoder a -> NullableOrNot decoder (Maybe a)
Hasql.nullable (Value a -> NullableOrNot Value (Maybe a))
-> Value a -> NullableOrNot Value (Maybe a)
forall a b. (a -> b) -> a -> b
$ TypeInformation a -> Value a
forall a. TypeInformation a -> Value a
decode TypeInformation a
TypeInformation (Unnullify a)
info
        Nullity a
NotNull -> NullableOrNot Value a -> Composite a
forall a. NullableOrNot Value a -> Composite a
Hasql.field (NullableOrNot Value a -> Composite a)
-> NullableOrNot Value a -> Composite a
forall a b. (a -> b) -> a -> b
$ Value a -> NullableOrNot Value a
forall (decoder :: * -> *) a. decoder a -> NullableOrNot decoder a
Hasql.nonNullable (Value a -> NullableOrNot Value a)
-> Value a -> NullableOrNot Value a
forall a b. (a -> b) -> a -> b
$ TypeInformation a -> Value a
forall a. TypeInformation a -> Value a
decode TypeInformation a
TypeInformation (Unnullify a)
info


encoder :: Table Expr a => a -> Opaleye.PrimExpr
encoder :: a -> PrimExpr
encoder (a -> Columns a (Col Expr)
forall (context :: Context) a.
Table context a =>
a -> Columns a (Col context)
toColumns -> Columns a (Col Expr)
a) = String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr String
"ROW" [PrimExpr]
exprs
  where
    exprs :: [PrimExpr]
exprs = Const [PrimExpr] (Columns a Any) -> [PrimExpr]
forall a k (b :: k). Const a b -> a
getConst (Const [PrimExpr] (Columns a Any) -> [PrimExpr])
-> Const [PrimExpr] (Columns a Any) -> [PrimExpr]
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec).
 HField (Columns a) spec -> Const [PrimExpr] (Any spec))
-> Const [PrimExpr] (Columns a Any)
forall (t :: HTable) (m :: * -> *) (context :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). HField t spec -> m (context spec))
-> m (t context)
htabulateA \HField (Columns a) spec
field -> case Columns a (Col Expr) -> HField (Columns a) spec -> Col Expr spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield Columns a (Col Expr)
a HField (Columns a) spec
field of
      E (toPrimExpr -> expr) -> [PrimExpr] -> Const [PrimExpr] (Any spec)
forall k a (b :: k). a -> Const a b
Const [PrimExpr
expr]