{-# 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.Functor.Identity ( Identity( Identity ) )
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 ( Expr )
import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
import Rel8.Table.Eq ( EqTable )
import Rel8.Table.HKD ( HKD, HKDable )
import Rel8.Table.Ord ( OrdTable )
import Rel8.Table.Rel8able ()
import Rel8.Table.Serialize ( litHTable )
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
  { forall a. Composite a -> a
unComposite :: a
  }


instance DBComposite a => DBType (Composite a) where
  typeInformation :: TypeInformation (Composite a)
typeInformation = TypeInformation
    { decode :: Value (Composite a)
decode = forall a. Composite a -> Value a
Hasql.composite (forall a. a -> Composite a
Composite forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) a.
Table context a =>
Columns a Result -> FromExprs a
fromResult @_ @(HKD a Expr) forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: HTable). HTable t => Composite (t Result)
decoder)
    , encode :: Composite a -> PrimExpr
encode = forall (t :: HTable). HTable t => t Expr -> PrimExpr
encoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: HTable). HTable t => t Result -> t Expr
litHTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) a.
Table context a =>
FromExprs a -> Columns a Result
toResult @_ @(HKD a Expr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Composite a -> a
unComposite
    , typeName :: String
typeName = 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)


-- | 'DBComposite' is used to associate composite type metadata with a Haskell
-- type.
type DBComposite :: Type -> Constraint
class (DBType a, HKDable a) => DBComposite a where
  -- | The names of all fields in the composite type that @a@ maps to.
  compositeFields :: HKD a Name

  -- | The name of the composite type that @a@ maps to.
  compositeTypeName :: String


-- | Collapse a 'HKD' into a PostgreSQL composite type.
--
-- 'HKD' values are represented in queries by having a column for each field in
-- the corresponding Haskell type. 'compose' collapses these columns into a
-- single column expression, by combining them into a PostgreSQL composite
-- type.
compose :: DBComposite a => HKD a Expr -> Expr a
compose :: forall a. DBComposite a => HKD a Expr -> Expr a
compose = forall a. Sql DBType a => Expr a -> Expr a
castExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrimExpr -> Expr a
fromPrimExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: HTable). HTable t => t Expr -> PrimExpr
encoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns


-- | Expand a composite type into a 'HKD'.
--
-- 'decompose' is the inverse of 'compose'.
decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
decompose (forall a. Expr a -> PrimExpr
toPrimExpr -> PrimExpr
a) = forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate \HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a)))))
  a
field ->
  case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns (HKD a Name) Name
names HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a)))))
  a
field of
    Name String
name -> case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield forall (t :: HTable). HTable t => t Spec
hspecs HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a)))))
  a
field of
      Spec {} -> forall a. PrimExpr -> Expr a
fromPrimExpr forall a b. (a -> b) -> a -> b
$ PrimExpr -> String -> PrimExpr
Opaleye.CompositeExpr PrimExpr
a String
name
  where
    names :: Columns (HKD a Name) Name
names = forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns (forall a. DBComposite a => HKD a Name
compositeFields @a)


decoder :: HTable t => Hasql.Composite (t Result)
decoder :: forall (t :: HTable). HTable t => Composite (t Result)
decoder = forall (f :: Context) a. WrappedApplicative f a -> f a
unwrapApplicative forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field ->
  case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield 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} -> forall (f :: Context) a. f a -> WrappedApplicative f a
WrapApplicative forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity a
Identity forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$>
      case Nullity a
nullity of
        Nullity a
Null -> forall a. NullableOrNot Value a -> Composite a
Hasql.field forall a b. (a -> b) -> a -> b
$ forall (decoder :: Context) a.
decoder a -> NullableOrNot decoder (Maybe a)
Hasql.nullable forall a b. (a -> b) -> a -> b
$ forall a. TypeInformation a -> Value a
decode TypeInformation (Unnullify a)
info
        Nullity a
NotNull -> forall a. NullableOrNot Value a -> Composite a
Hasql.field forall a b. (a -> b) -> a -> b
$ forall (decoder :: Context) a. decoder a -> NullableOrNot decoder a
Hasql.nonNullable forall a b. (a -> b) -> a -> b
$ forall a. TypeInformation a -> Value a
decode TypeInformation (Unnullify a)
info


encoder :: HTable t => t Expr -> Opaleye.PrimExpr
encoder :: forall (t :: HTable). HTable t => t Expr -> PrimExpr
encoder t Expr
a = String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr String
"ROW" [PrimExpr]
exprs
  where
    exprs :: [PrimExpr]
exprs = forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field -> case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Expr
a HField t a
field of
      Expr a
expr -> forall {k} a (b :: k). a -> Const a b
Const [forall a. Expr a -> PrimExpr
toPrimExpr Expr a
expr]