{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language DisambiguateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language NamedFieldPuns #-}
{-# language RankNTypes #-}
{-# language TypeFamilies #-}
{-# language ViewPatterns #-}

{-# options_ghc -Wno-deprecations #-}

module Rel8.Table.Opaleye
  ( aggregator
  , attributes
  , binaryspec
  , distinctspec
  , exprs
  , exprsWithNames
  , table
  , tableFields
  , unpackspec
  , valuesspec
  , view
  , castTable
  )
where

-- base
import Data.Functor.Const ( Const( Const ), getConst )
import Data.List.NonEmpty ( NonEmpty )
import Prelude

-- opaleye
import qualified Opaleye.Adaptors as Opaleye
import qualified Opaleye.Field as Opaleye ( Field_ )
import qualified Opaleye.Internal.Aggregate as Opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import qualified Opaleye.Internal.Values as Opaleye
import qualified Opaleye.Table as Opaleye

-- profunctors
import Data.Profunctor ( dimap, lmap )

-- rel8
import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
import Rel8.Expr ( Expr )
import Rel8.Expr.Opaleye
  ( fromPrimExpr, toPrimExpr
  , scastExpr, traverseFieldP
  )
import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
                            htraverseP, htraversePWithField )
import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
import Rel8.Schema.Spec ( Spec(..) )
import Rel8.Schema.Table ( TableSchema(..), ppTable )
import Rel8.Table ( Table, fromColumns, toColumns )
import Rel8.Type.Information ( typeName )

-- semigroupoids
import Data.Functor.Apply ( WrappedApplicative(..) )
import Data.Profunctor.Product ( ProductProfunctor )


aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
aggregator :: forall aggregates exprs.
Aggregates aggregates exprs =>
Aggregator aggregates exprs
aggregator = forall (p :: * -> Context) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns forall a b. (a -> b) -> a -> b
$
             forall (t :: HTable) (p :: * -> Context) (f :: Context)
       (g :: Context).
(HTable t, ProductProfunctor p) =>
(forall a. p (f a) (g a)) -> p (t f) (t g)
htraverseP forall a b. (a -> b) -> a -> b
$
             forall (p :: * -> Context) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (\(Aggregate Aggregator () (Expr a)
a) -> (Aggregator () (Expr a)
a, ())) forall a b. Aggregator (Aggregator a b, a) b
Opaleye.aggregatorApply


attributes :: Selects names exprs => TableSchema names -> exprs
attributes :: forall names exprs.
Selects names exprs =>
TableSchema names -> exprs
attributes schema :: TableSchema names
schema@TableSchema {names
columns :: forall names. TableSchema names -> names
columns :: names
columns} = 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 forall a b. (a -> b) -> a -> b
$ \HField (Columns exprs) a
field ->
  case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns names
columns) HField (Columns exprs) a
field of
    Name String
column -> forall a. PrimExpr -> Expr a
fromPrimExpr forall a b. (a -> b) -> a -> b
$ Literal -> PrimExpr
Opaleye.ConstExpr forall a b. (a -> b) -> a -> b
$
      String -> Literal
Opaleye.OtherLit forall a b. (a -> b) -> a -> b
$
        forall a. Show a => a -> String
show (forall a. TableSchema a -> Doc
ppTable TableSchema names
schema) forall a. Semigroup a => a -> a -> a
<> String
"." forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (String -> Doc
ppColumn String
column)


fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
  => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
  -> p a a
fromOpaleyespec :: forall (p :: * -> Context) a (n :: Nullability) x.
(ProductProfunctor p, Table Expr a) =>
p (Field_ n x) (Field_ n x) -> p a a
fromOpaleyespec p (Field_ n x) (Field_ n x)
x =
  forall (p :: * -> Context) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns (forall (t :: HTable) (p :: * -> Context) (f :: Context)
       (g :: Context).
(HTable t, ProductProfunctor p) =>
(forall a. p (f a) (g a)) -> p (t f) (t g)
htraverseP (forall (p :: * -> Context) (n :: Nullability) x (m :: Nullability)
       y a b.
Profunctor p =>
p (Field_ n x) (Field_ m y) -> p (Expr a) (Expr b)
traverseFieldP p (Field_ n x) (Field_ n x)
x))


binaryspec :: Table Expr a => Opaleye.Binaryspec a a
binaryspec :: forall a. Table Expr a => Binaryspec a a
binaryspec = forall (p :: * -> Context) a (n :: Nullability) x.
(ProductProfunctor p, Table Expr a) =>
p (Field_ n x) (Field_ n x) -> p a a
fromOpaleyespec forall (n :: Nullability) a. Binaryspec (Field_ n a) (Field_ n a)
Opaleye.binaryspecField


distinctspec :: Table Expr a => Opaleye.Distinctspec a a
distinctspec :: forall a. Table Expr a => Distinctspec a a
distinctspec = forall (p :: * -> Context) a (n :: Nullability) x.
(ProductProfunctor p, Table Expr a) =>
p (Field_ n x) (Field_ n x) -> p a a
fromOpaleyespec forall (n :: Nullability) a. Distinctspec (Field_ n a) (Field_ n a)
Opaleye.distinctspecField


exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
exprs :: forall a. Table Expr a => a -> NonEmpty PrimExpr
exprs (forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
as) = 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 forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field ->
  case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
as HField (Columns a) a
field of
    Expr a
expr -> forall {k} a (b :: k). a -> Const a b
Const (forall (f :: Context) a. Applicative f => a -> f a
pure (forall a. Expr a -> PrimExpr
toPrimExpr Expr a
expr))


exprsWithNames :: Selects names exprs
  => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)
exprsWithNames :: forall names exprs.
Selects names exprs =>
names -> exprs -> NonEmpty (String, PrimExpr)
exprsWithNames names
names exprs
as = 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 forall a b. (a -> b) -> a -> b
$ \HField (Columns exprs) a
field ->
  case (forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns names
names) HField (Columns exprs) a
field, forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns exprs
as) HField (Columns exprs) a
field) of
    (Name String
name, Expr a
expr) -> forall {k} a (b :: k). a -> Const a b
Const (forall (f :: Context) a. Applicative f => a -> f a
pure (String
name, forall a. Expr a -> PrimExpr
toPrimExpr Expr a
expr))


table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
table :: forall names exprs.
Selects names exprs =>
TableSchema names -> Table exprs exprs
table (TableSchema String
name Maybe String
schema names
columns) =
  case Maybe String
schema of
    Maybe String
Nothing -> forall writeFields viewFields.
String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
Opaleye.table String
name (forall names exprs.
Selects names exprs =>
names -> TableFields exprs exprs
tableFields names
columns)
    Just String
schemaName -> forall writeFields viewFields.
String
-> String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
Opaleye.tableWithSchema String
schemaName String
name (forall names exprs.
Selects names exprs =>
names -> TableFields exprs exprs
tableFields names
columns)


tableFields :: Selects names exprs
  => names -> Opaleye.TableFields exprs exprs
tableFields :: forall names exprs.
Selects names exprs =>
names -> TableFields exprs exprs
tableFields (forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns names Name
names) = forall (p :: * -> Context) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns forall a b. (a -> b) -> a -> b
$
  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 forall a b. (a -> b) -> a -> b
$ \HField (Columns exprs) a
field -> forall (f :: Context) a. f a -> WrappedApplicative f a
WrapApplicative forall a b. (a -> b) -> a -> b
$
    case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns names Name
names HField (Columns exprs) a
field of
      Name a
name -> forall (p :: * -> Context) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
`hfield` HField (Columns exprs) a
field) (forall a. Name a -> TableFields (Expr a) (Expr a)
go Name a
name)
  where
    go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
    go :: forall a. Name a -> TableFields (Expr a) (Expr a)
go (Name String
name) =
      forall (p :: * -> Context) (n :: Nullability) x (m :: Nullability)
       y a b.
Profunctor p =>
p (Field_ n x) (Field_ m y) -> p (Expr a) (Expr b)
traverseFieldP forall a b. (a -> b) -> a -> b
$
        forall (n :: Nullability) a.
String -> TableFields (Field_ n a) (Field_ n a)
Opaleye.requiredTableField String
name


unpackspec :: Table Expr a => Opaleye.Unpackspec a a
unpackspec :: forall a. Table Expr a => Unpackspec a a
unpackspec = forall (p :: * -> Context) a (n :: Nullability) x.
(ProductProfunctor p, Table Expr a) =>
p (Field_ n x) (Field_ n x) -> p a a
fromOpaleyespec forall (n :: Nullability) a. Unpackspec (Field_ n a) (Field_ n a)
Opaleye.unpackspecField
{-# INLINABLE unpackspec #-}


valuesspec :: Table Expr a => Opaleye.Valuesspec a a
valuesspec :: forall a. Table Expr a => Valuesspec a a
valuesspec = forall (p :: * -> Context) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns forall a b. (a -> b) -> a -> b
$
  forall (t :: HTable) (p :: * -> Context) (f :: Context)
       (g :: Context).
(HTable t, ProductProfunctor p) =>
(forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
htraversePWithField (forall (p :: * -> Context) (n :: Nullability) x (m :: Nullability)
       y a b.
Profunctor p =>
p (Field_ n x) (Field_ m y) -> p (Expr a) (Expr b)
traverseFieldP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nullability) a.
String -> Valuesspec (Field_ n a) (Field_ n a)
Opaleye.valuesspecFieldType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. HField (Columns a) a -> String
typeName)
  where typeName :: HField (Columns a) a -> String
typeName = forall a. TypeInformation a -> String
Rel8.Type.Information.typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Spec a -> TypeInformation (Unnullify a)
info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield forall (t :: HTable). HTable t => t Spec
hspecs


view :: Selects names exprs => names -> exprs
view :: forall names exprs. Selects names exprs => names -> exprs
view names
columns = 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 forall a b. (a -> b) -> a -> b
$ \HField (Columns exprs) a
field ->
  case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns names
columns) HField (Columns exprs) a
field of
    Name String
column -> forall a. PrimExpr -> Expr a
fromPrimExpr forall a b. (a -> b) -> a -> b
$ String -> PrimExpr
Opaleye.BaseTableAttrExpr String
column


-- | Transform a table by adding 'CAST' to all columns. This is most useful for
-- finalising a SELECT or RETURNING statement, guaranteed that the output
-- matches what is encoded in each columns TypeInformation.
castTable :: Table Expr a => a -> a
castTable :: forall a. Table Expr a => a -> a
castTable (forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
as) = 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 (Columns a) 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 (Columns a) a
field of
    Spec {TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info} -> case forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
as HField (Columns a) a
field of
        Expr a
expr -> forall a. TypeInformation (Unnullify a) -> Expr a -> Expr a
scastExpr TypeInformation (Unnullify a)
info Expr a
expr