{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language ViewPatterns #-}

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

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

-- rel8
import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Spec ( Spec(..) )
import Rel8.Table ( Table(..) )


-- | 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 Name -> a
forall (context :: * -> *) a.
Table context a =>
Columns a context -> a
fromColumns (Columns a Name -> a) -> Columns a Name -> a
forall a b. (a -> b) -> a -> b
$ (forall a. HField (Columns a) a -> Name a) -> Columns a Name
forall (t :: HTable) (context :: * -> *).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate ((forall a. HField (Columns a) a -> Name a) -> Columns a Name)
-> (forall a. HField (Columns a) a -> Name a) -> Columns a Name
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field ->
  case Columns a Spec -> HField (Columns a) a -> Spec a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField (Columns a) a
field of
    Spec {[String]
labels :: forall a. Spec a -> [String]
labels :: [String]
labels} -> String -> Name a
forall a. String -> Name a
Name (NonEmpty String -> String
f ([String] -> NonEmpty String
renderLabels [String]
labels))


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 :: * -> *).
(HTable (Columns a), Apply m) =>
(forall a. HField (Columns a) a -> m (context a))
-> m (Columns a context)
forall (t :: HTable) (m :: * -> *) (context :: * -> *).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA @(Columns a) ((forall a.
  HField (Columns a) a -> Const [NonEmpty String] (Any a))
 -> Const [NonEmpty String] (Columns a Any))
-> (forall a.
    HField (Columns a) a -> Const [NonEmpty String] (Any a))
-> Const [NonEmpty String] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field -> case Columns a Spec -> HField (Columns a) a -> Spec a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField (Columns a) a
field of
    Spec {[String]
labels :: [String]
labels :: forall a. Spec a -> [String]
labels} -> [NonEmpty String] -> Const [NonEmpty String] (Any a)
forall k a (b :: k). a -> Const a b
Const (NonEmpty String -> [NonEmpty String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> NonEmpty String
renderLabels [String]
labels))


showNames :: forall a. Table Name a => a -> NonEmpty String
showNames :: a -> NonEmpty String
showNames (a -> Columns a Name
forall (context :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Name
names) = 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 :: * -> *).
(HTable (Columns a), Apply m) =>
(forall a. HField (Columns a) a -> m (context a))
-> m (Columns a context)
forall (t :: HTable) (m :: * -> *) (context :: * -> *).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA @(Columns a) ((forall a.
  HField (Columns a) a -> Const (NonEmpty String) (Any a))
 -> Const (NonEmpty String) (Columns a Any))
-> (forall a.
    HField (Columns a) a -> Const (NonEmpty String) (Any a))
-> Const (NonEmpty String) (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field -> case Columns a Name -> HField (Columns a) a -> Name a
forall (t :: HTable) (context :: * -> *) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Name
names HField (Columns a) a
field of
    Name String
name -> NonEmpty String -> Const (NonEmpty String) (Any a)
forall k a (b :: k). a -> Const a b
Const (String -> NonEmpty String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
name)


renderLabels :: [String] -> NonEmpty String
renderLabels :: [String] -> NonEmpty String
renderLabels [String]
labels = NonEmpty String -> Maybe (NonEmpty String) -> NonEmpty String
forall a. a -> Maybe a -> a
fromMaybe (String -> NonEmpty String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"anon") ([String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [String]
labels )