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

module Rel8.Internal.Table.Name
  ( namesFromLabels
  , namesFromLabelsTagged
  , namesFromLabelsWith
  , namesFromLabelsWithA
  , showLabels
  , showNames
  , shortenName
  )
where

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

-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye

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

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

-- transformers
import Control.Monad.Trans.State.Strict (State, evalState)


-- | Construct a table in the 'Name' context containing the names of all
-- columns. Nested column names will be combined with @/@, the resulting
-- name will be truncated and a unique tag appended to the end of the name
-- so that the resulting name has 63 or less characters (Postgres' default
-- maximum column name length).
--
-- See also: 'namesFromLabelsTagged', 'namesFromLabelsWith'.
namesFromLabels :: Table Name a => a
namesFromLabels :: forall a. Table Name a => a
namesFromLabels = (NonEmpty [Char] -> StateT Tag Identity [Char])
-> StateT Tag Identity a
forall (f :: * -> *) a.
(Apply f, Table Name a) =>
(NonEmpty [Char] -> f [Char]) -> f a
namesFromLabelsWithA (Maybe Tag -> NonEmpty [Char] -> StateT Tag Identity [Char]
shortenName Maybe Tag
forall a. Maybe a
Nothing) StateT Tag Identity a -> Tag -> a
forall s a. State s a -> s -> a
`evalState` Tag
Opaleye.start


-- | Similar to 'namesFromLabels', but receives an additional 'Opaleye.Tag'
-- to distinguish between relations. Resulting names will also have 63 or
-- less characters.
namesFromLabelsTagged :: Table Name a => Opaleye.Tag -> a
namesFromLabelsTagged :: forall a. Table Name a => Tag -> a
namesFromLabelsTagged Tag
relationTag = (NonEmpty [Char] -> StateT Tag Identity [Char])
-> StateT Tag Identity a
forall (f :: * -> *) a.
(Apply f, Table Name a) =>
(NonEmpty [Char] -> f [Char]) -> f a
namesFromLabelsWithA (Maybe Tag -> NonEmpty [Char] -> StateT Tag Identity [Char]
shortenName (Tag -> Maybe Tag
forall a. a -> Maybe a
Just Tag
relationTag)) StateT Tag Identity a -> Tag -> a
forall s a. State s a -> s -> a
`evalState` Tag
Opaleye.start


-- | Map a non-empty list of labels to a short SQL identifier with an opaleye tag appended,
-- truncated if it would be too large.
shortenName :: Maybe Opaleye.Tag -> NonEmpty String -> State Opaleye.Tag String
shortenName :: Maybe Tag -> NonEmpty [Char] -> StateT Tag Identity [Char]
shortenName Maybe Tag
mtag NonEmpty [Char]
labels = do
  subtag <- State Tag Tag
Opaleye.fresh
  let
    addRelationTag = case Maybe Tag
mtag of
      Maybe Tag
Nothing -> [Char] -> [Char]
forall a. a -> a
id
      Just Tag
tag -> Tag -> [Char] -> [Char]
Opaleye.tagWith Tag
tag
    suffix = [Char] -> [Char]
addRelationTag (Tag -> [Char] -> [Char]
Opaleye.tagWith Tag
subtag [Char]
"")
  pure $ take (63 - length suffix) label ++ suffix
  where
    label :: [Char]
label = NonEmpty [Char] -> [Char]
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
intersperse [Char]
"/" NonEmpty [Char]
labels)


-- | 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 :: forall a. Table Name a => (NonEmpty [Char] -> [Char]) -> a
namesFromLabelsWith = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> ((NonEmpty [Char] -> [Char]) -> Identity a)
-> (NonEmpty [Char] -> [Char])
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty [Char] -> Identity [Char]) -> Identity a
forall (f :: * -> *) a.
(Apply f, Table Name a) =>
(NonEmpty [Char] -> f [Char]) -> f a
namesFromLabelsWithA ((NonEmpty [Char] -> Identity [Char]) -> Identity a)
-> ((NonEmpty [Char] -> [Char])
    -> NonEmpty [Char] -> Identity [Char])
-> (NonEmpty [Char] -> [Char])
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Identity [Char]
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Identity [Char])
-> (NonEmpty [Char] -> [Char])
-> NonEmpty [Char]
-> Identity [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)


namesFromLabelsWithA :: (Apply f, Table Name a)
  => (NonEmpty String -> f String) -> f a
namesFromLabelsWithA :: forall (f :: * -> *) a.
(Apply f, Table Name a) =>
(NonEmpty [Char] -> f [Char]) -> f a
namesFromLabelsWithA NonEmpty [Char] -> f [Char]
f = (Columns a Name -> a) -> f (Columns a Name) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Columns a Name -> a
forall (context :: * -> *) a.
Table context a =>
Columns a context -> a
fromColumns (f (Columns a Name) -> f a) -> f (Columns a Name) -> f a
forall a b. (a -> b) -> a -> b
$ (forall a. HField (Columns a) a -> f (Name a))
-> f (Columns a Name)
forall (t :: HTable) (m :: * -> *) (context :: * -> *).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA ((forall a. HField (Columns a) a -> f (Name a))
 -> f (Columns a Name))
-> (forall a. HField (Columns a) a -> f (Name a))
-> f (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 (context :: * -> *) a.
Columns a context -> HField (Columns a) a -> context 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 {[[Char]]
labels :: [[Char]]
labels :: forall a. Spec a -> [[Char]]
labels} -> [Char] -> Name a
forall a. [Char] -> Name a
Name ([Char] -> Name a) -> f [Char] -> f (Name a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Char] -> f [Char]
f ([[Char]] -> NonEmpty [Char]
renderLabels [[Char]]
labels)


showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
showLabels :: forall a. Table (Context a) a => a -> [NonEmpty [Char]]
showLabels a
_ = Const [NonEmpty [Char]] (Columns a (ZonkAny 1))
-> [NonEmpty [Char]]
forall {k} a (b :: k). Const a b -> a
getConst (Const [NonEmpty [Char]] (Columns a (ZonkAny 1))
 -> [NonEmpty [Char]])
-> Const [NonEmpty [Char]] (Columns a (ZonkAny 1))
-> [NonEmpty [Char]]
forall a b. (a -> b) -> a -> b
$
  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 [Char]] (ZonkAny 1 a))
 -> Const [NonEmpty [Char]] (Columns a (ZonkAny 1)))
-> (forall a.
    HField (Columns a) a -> Const [NonEmpty [Char]] (ZonkAny 1 a))
-> Const [NonEmpty [Char]] (Columns a (ZonkAny 1))
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field -> case Columns a Spec -> HField (Columns a) a -> Spec a
forall (context :: * -> *) a.
Columns a context -> HField (Columns a) a -> context 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 {[[Char]]
labels :: forall a. Spec a -> [[Char]]
labels :: [[Char]]
labels} -> [NonEmpty [Char]] -> Const [NonEmpty [Char]] (ZonkAny 1 a)
forall {k} a (b :: k). a -> Const a b
Const (NonEmpty [Char] -> [NonEmpty [Char]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> NonEmpty [Char]
renderLabels [[Char]]
labels))


showNames :: forall a. Table Name a => a -> NonEmpty String
showNames :: forall a. Table Name a => a -> NonEmpty [Char]
showNames (a -> Columns a Name
forall (context :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Name
names) = Const (NonEmpty [Char]) (Columns a (ZonkAny 0)) -> NonEmpty [Char]
forall {k} a (b :: k). Const a b -> a
getConst (Const (NonEmpty [Char]) (Columns a (ZonkAny 0))
 -> NonEmpty [Char])
-> Const (NonEmpty [Char]) (Columns a (ZonkAny 0))
-> NonEmpty [Char]
forall a b. (a -> b) -> a -> b
$
  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 [Char]) (ZonkAny 0 a))
 -> Const (NonEmpty [Char]) (Columns a (ZonkAny 0)))
-> (forall a.
    HField (Columns a) a -> Const (NonEmpty [Char]) (ZonkAny 0 a))
-> Const (NonEmpty [Char]) (Columns a (ZonkAny 0))
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field -> case Columns a Name -> HField (Columns a) a -> Name a
forall (context :: * -> *) a.
Columns a context -> HField (Columns a) a -> context 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 [Char]
name -> NonEmpty [Char] -> Const (NonEmpty [Char]) (ZonkAny 0 a)
forall {k} a (b :: k). a -> Const a b
Const ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
name)


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