{-# language FlexibleContexts #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language ViewPatterns #-}

module Rel8.Table.Name
  ( namesFromLabels
  , namesFromLabelsWith
  , showExprs
  , showLabels
  , showNames
  )
where

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

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

-- rel8
import Rel8.Expr ( Expr, Col( E ) )
import Rel8.Expr.Opaleye ( toPrimExpr )
import Rel8.Kind.Labels ( renderLabels )
import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
import Rel8.Schema.Name ( Name( Name ), Col( N ) )
import Rel8.Schema.Spec ( SSpec(..) )
import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )


-- | Construct a table in the 'Name' context containing the names of all
-- columns. Nested column names will be combined with @/@.
--
-- See also: 'namesFromLabelsWith'.
namesFromLabels :: Table Name a => a
namesFromLabels :: a
namesFromLabels = (NonEmpty String -> String) -> a
forall a. Table Name a => (NonEmpty String -> String) -> a
namesFromLabelsWith NonEmpty String -> String
go
  where
    go :: NonEmpty String -> String
go = NonEmpty String -> String
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (NonEmpty String -> String)
-> (NonEmpty String -> NonEmpty String)
-> NonEmpty String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NonEmpty String -> NonEmpty String
forall a. a -> NonEmpty a -> NonEmpty a
intersperse String
"/"


-- | Construct a table in the 'Name' context containing the names of all
-- columns. The supplied function can be used to transform column names.
--
-- This function can be used to generically derive the columns for a
-- 'TableSchema'. For example,
--
-- @
-- myTableSchema :: TableSchema (MyTable Name)
-- myTableSchema = TableSchema
--   { columns = namesFromLabelsWith last
--   }
-- @
--
-- will construct a 'TableSchema' where each columns names exactly corresponds
-- to the name of the Haskell field.
namesFromLabelsWith :: Table Name a
  => (NonEmpty String -> String) -> a
namesFromLabelsWith :: (NonEmpty String -> String) -> a
namesFromLabelsWith NonEmpty String -> String
f = Columns a (Col Name) -> a
forall (context :: Context) a.
Table context a =>
Columns a (Col context) -> a
fromColumns (Columns a (Col Name) -> a) -> Columns a (Col Name) -> a
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec). HField (Columns a) spec -> Col Name spec)
-> Columns a (Col Name)
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate ((forall (spec :: Spec). HField (Columns a) spec -> Col Name spec)
 -> Columns a (Col Name))
-> (forall (spec :: Spec).
    HField (Columns a) spec -> Col Name spec)
-> Columns a (Col Name)
forall a b. (a -> b) -> a -> b
$ \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 {SLabels labels
labels :: forall (labels :: Labels) a.
SSpec ('Spec labels a) -> SLabels labels
labels :: SLabels labels
labels} -> Name a -> Col Name ('Spec labels a)
forall a (labels :: Labels). Name a -> Col Name ('Spec labels a)
N (String -> Name a
forall k (a :: k). (k ~ *) => String -> Name a
Name (NonEmpty String -> String
f (SLabels labels -> NonEmpty String
forall (labels :: Labels). SLabels labels -> NonEmpty String
renderLabels SLabels labels
labels)))


showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]
showExprs :: a -> [(String, PrimExpr)]
showExprs a
as = case (Columns a (Col Name)
forall a. Table Name a => a
namesFromLabels, a -> Columns a (Col Expr)
forall (context :: Context) a.
Table context a =>
a -> Columns a (Col context)
toColumns a
as) of
  (Columns a (Col Name)
names, Columns a (Col Expr)
exprs) -> Const [(String, PrimExpr)] (Columns a Any) -> [(String, PrimExpr)]
forall a k (b :: k). Const a b -> a
getConst (Const [(String, PrimExpr)] (Columns a Any)
 -> [(String, PrimExpr)])
-> Const [(String, PrimExpr)] (Columns a Any)
-> [(String, PrimExpr)]
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec).
 HField (Columns a) spec -> Const [(String, PrimExpr)] (Any spec))
-> Const [(String, 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 ((forall (spec :: Spec).
  HField (Columns a) spec -> Const [(String, PrimExpr)] (Any spec))
 -> Const [(String, PrimExpr)] (Columns a Any))
-> (forall (spec :: Spec).
    HField (Columns a) spec -> Const [(String, PrimExpr)] (Any spec))
-> Const [(String, PrimExpr)] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) spec
field ->
    case (Columns a (Col Name) -> HField (Columns a) spec -> Col Name spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield Columns a (Col Name)
names HField (Columns a) spec
field, 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)
exprs HField (Columns a) spec
field) of
      (N (Name name), E expr) -> [(String, PrimExpr)] -> Const [(String, PrimExpr)] (Any spec)
forall k a (b :: k). a -> Const a b
Const [(String
name, Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr Expr a
expr)]


showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
showLabels :: a -> [NonEmpty String]
showLabels a
_ = Const [NonEmpty String] (Columns a Any) -> [NonEmpty String]
forall a k (b :: k). Const a b -> a
getConst (Const [NonEmpty String] (Columns a Any) -> [NonEmpty String])
-> Const [NonEmpty String] (Columns a Any) -> [NonEmpty String]
forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) (context :: HContext).
(HTable (Columns a), Apply m) =>
(forall (spec :: Spec).
 HField (Columns a) spec -> m (context spec))
-> m (Columns a context)
forall (t :: HTable) (m :: * -> *) (context :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). HField t spec -> m (context spec))
-> m (t context)
htabulateA @(Columns a) ((forall (spec :: Spec).
  HField (Columns a) spec -> Const [NonEmpty String] (Any spec))
 -> Const [NonEmpty String] (Columns a Any))
-> (forall (spec :: Spec).
    HField (Columns a) spec -> Const [NonEmpty String] (Any spec))
-> Const [NonEmpty String] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \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 {SLabels labels
labels :: SLabels labels
labels :: forall (labels :: Labels) a.
SSpec ('Spec labels a) -> SLabels labels
labels} -> [NonEmpty String] -> Const [NonEmpty String] (Any spec)
forall k a (b :: k). a -> Const a b
Const [SLabels labels -> NonEmpty String
forall (labels :: Labels). SLabels labels -> NonEmpty String
renderLabels SLabels labels
labels]


showNames :: forall a. Table Name a => a -> [String]
showNames :: a -> [String]
showNames (a -> Columns a (Col Name)
forall (context :: Context) a.
Table context a =>
a -> Columns a (Col context)
toColumns -> Columns a (Col Name)
names) = Const [String] (Columns a Any) -> [String]
forall a k (b :: k). Const a b -> a
getConst (Const [String] (Columns a Any) -> [String])
-> Const [String] (Columns a Any) -> [String]
forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) (context :: HContext).
(HTable (Columns a), Apply m) =>
(forall (spec :: Spec).
 HField (Columns a) spec -> m (context spec))
-> m (Columns a context)
forall (t :: HTable) (m :: * -> *) (context :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). HField t spec -> m (context spec))
-> m (t context)
htabulateA @(Columns a) ((forall (spec :: Spec).
  HField (Columns a) spec -> Const [String] (Any spec))
 -> Const [String] (Columns a Any))
-> (forall (spec :: Spec).
    HField (Columns a) spec -> Const [String] (Any spec))
-> Const [String] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) spec
field -> case Columns a (Col Name) -> HField (Columns a) spec -> Col Name spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield Columns a (Col Name)
names HField (Columns a) spec
field of
    N (Name name) -> [String] -> Const [String] (Any spec)
forall k a (b :: k). a -> Const a b
Const [String
name]