-- |
--  Module      : Cfg.Deriving.KeyModifier
--  Copyright   : © Jonathan Lorimer, 2023
--  License     : MIT
--  Maintainer  : jonathanlorimer@pm.me
--  Stability   : stable
--
-- @since 0.0.2.0
--
-- This module provides type level tags that can be used to configure string
-- transformations against configuration keys derived from things like record
-- fields.
module Cfg.Deriving.KeyModifier
  ( -- * Key Modifiers
    KeyModifier (..)
  , Identity
  , ToLower
  , ToUpper
  , LowerFirst
  , UpperFirst
  , StripPrefix
  , StripSuffix
  , CamelTo
  , CamelToSnake
  , CamelToKebab

    -- * Helper Functions
  , mapFirst
  , camelTo
  , camelToText
  )
where

import Cfg.Options (RootKey (..))
import Data.Char (isLower, isUpper, toLower, toUpper)
import Data.Data (Proxy (..))
import Data.Functor
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.TypeLits

-- | Identity transformation, corresponds to 'id', does not change the string.
--
-- @since 0.0.2.0
data Identity

-- | Lower cases all alphabetical characters, corresponds to 'Data.Text.toLower'.
--
-- @since 0.0.2.0
data ToLower

-- | Upper cases all alphabetical characters, corresponds to 'Data.Text.toUpper'.
--
-- @since 0.0.2.0
data ToUpper

-- | Lower cases the first character, corresponds to 'Data.Char.toLower'.
--
-- @since 0.0.2.0
data LowerFirst

-- | Upper cases the first character, corresponds to 'Data.Char.toUpper'.
--
-- @since 0.0.2.0
data UpperFirst

-- | Takes a type level string and removes that from the beginning of the text,
-- corresponds to 'Data.Text.stripPrefix'.
--
-- @since 0.0.2.0
data StripPrefix (prefix :: Symbol)

-- | Takes a type level string and removes that from the end of the text,
-- corresponds to 'Data.Text.stripSuffix.
--
-- @since 0.0.2.0
data StripSuffix (suffix :: Symbol)

-- | Takes a type level character known as the \"separator"\ and will break the
-- camel case string on its \"humps\" and then rejoin the string with the
-- separator.
--
-- @since 0.0.2.0
data CamelTo (separator :: Char)

-- | Specialized version of `CamelTo` where the separator is \"_\". Results in
-- snake cased strings.
--
-- @since 0.0.2.0
type CamelToSnake = CamelTo '_'

-- | Specialized version of `CamelTo` where the separator is \"-\". Results in
-- kebab cased strings.
--
-- @since 0.0.2.0
type CamelToKebab = CamelTo '-'

-- | This typeclass turns a type level \"tag\" into a function from @Text ->
-- Text@. In addition to the instances for the \"tags\", there are also
-- instances for type level lists and tuples up to an arity of 4.
--
-- __important__: For type level lists and tuples the modifiers are applied in
-- order from left to right.
--
-- >>> getKeyModifier @'[ToUpper, ToLower] "Hello World"
-- "hello world"
--
-- >>> getKeyModifier @(ToLower, ToUpper) "Hello World"
-- "HELLO WORLD"
--
-- >>> getKeyModifier @CamelToSnake "iLoveCFGProject"
-- "i_love_cfg_project"
--
-- @since 0.0.2.0
class KeyModifier t where
  getKeyModifier :: Text -> Text

instance (KeyModifier k) => KeyModifier ('TypeName k) where
  getKeyModifier :: Text -> Text
getKeyModifier = forall (k :: a). KeyModifier k => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @k

instance (KeyModifier k) => KeyModifier ('ConstructorName k) where
  getKeyModifier :: Text -> Text
getKeyModifier = forall (t :: a). KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @k

instance KeyModifier Identity where
  getKeyModifier :: Text -> Text
getKeyModifier = Text -> Text
forall a. a -> a
id

instance KeyModifier '() where
  getKeyModifier :: Text -> Text
getKeyModifier = Text -> Text
forall a. a -> a
id

instance KeyModifier '[] where
  getKeyModifier :: Text -> Text
getKeyModifier = Text -> Text
forall a. a -> a
id

instance (KeyModifier a, KeyModifier as) => KeyModifier (a ': as) where
  getKeyModifier :: Text -> Text
getKeyModifier = forall (t :: [a]). KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @as (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: a). KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @a

instance (KeyModifier a, KeyModifier b) => KeyModifier (a, b) where
  getKeyModifier :: Text -> Text
getKeyModifier = forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @b (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @a

instance (KeyModifier a, KeyModifier b, KeyModifier c) => KeyModifier (a, b, c) where
  getKeyModifier :: Text -> Text
getKeyModifier = forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @c (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @b (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @a

instance (KeyModifier a, KeyModifier b, KeyModifier c, KeyModifier d) => KeyModifier (a, b, c, d) where
  getKeyModifier :: Text -> Text
getKeyModifier = forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @d (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @c (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @b (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. KeyModifier t => Text -> Text
forall a (k :: a). KeyModifier k => Text -> Text
getKeyModifier @a

instance KeyModifier ToLower where
  getKeyModifier :: Text -> Text
getKeyModifier = Text -> Text
T.toLower

instance KeyModifier ToUpper where
  getKeyModifier :: Text -> Text
getKeyModifier = Text -> Text
T.toUpper

instance KeyModifier LowerFirst where
  getKeyModifier :: Text -> Text
getKeyModifier Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Text -> Maybe Text
mapFirst Char -> Char
toLower Text
t

instance KeyModifier UpperFirst where
  getKeyModifier :: Text -> Text
getKeyModifier Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Text -> Maybe Text
mapFirst Char -> Char
toUpper Text
t

instance (KnownSymbol prefix) => KeyModifier (StripPrefix prefix) where
  getKeyModifier :: Text -> Text
getKeyModifier Text
label =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
label (Maybe Text -> Text) -> (Text -> Maybe Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
T.stripPrefix (String -> Text
T.pack (String -> Text)
-> (Proxy prefix -> String) -> Proxy prefix -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy prefix -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy prefix -> Text) -> Proxy prefix -> Text
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @prefix) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
label

instance (KnownSymbol prefix) => KeyModifier (StripSuffix prefix) where
  getKeyModifier :: Text -> Text
getKeyModifier Text
label =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
label (Maybe Text -> Text) -> (Text -> Maybe Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
T.stripSuffix (String -> Text
T.pack (String -> Text)
-> (Proxy prefix -> String) -> Proxy prefix -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy prefix -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy prefix -> Text) -> Proxy prefix -> Text
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @prefix) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
label

instance (KnownChar separator) => KeyModifier (CamelTo separator) where
  getKeyModifier :: Text -> Text
getKeyModifier = Char -> Text -> Text
camelToText (Proxy separator -> Char
forall (n :: Char) (proxy :: Char -> *).
KnownChar n =>
proxy n -> Char
charVal (Proxy separator -> Char) -> Proxy separator -> Char
forall a b. (a -> b) -> a -> b
$ forall (t :: Char). Proxy t
forall {k} (t :: k). Proxy t
Proxy @separator)

-- | Map over the first character of a stream of 'Data.Text.Text'
--
-- @since 0.0.2.0
mapFirst :: (Char -> Char) -> Text -> Maybe Text
mapFirst :: (Char -> Char) -> Text -> Maybe Text
mapFirst Char -> Char
f Text
text = Text -> Maybe (Char, Text)
T.uncons Text
text Maybe (Char, Text) -> ((Char, Text) -> Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Char
first, Text
rest) -> Char -> Char
f Char
first Char -> Text -> Text
`T.cons` Text
rest

-- | Function for breaking a camel case string on its \"humps\" and re-joining
-- on a provided separator char.
--
-- @since 0.0.2.0
camelTo
  :: Char
  -- ^ Separator character
  -> String
  -- ^ Camel cased string
  -> String
camelTo :: Char -> String -> String
camelTo Char
c = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go2 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go1
 where
  go1 :: String -> String
go1 String
"" = String
""
  go1 (Char
x : Char
u : Char
l : String
xs) | Char -> Bool
isUpper Char
u Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
l = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go1 String
xs
  go1 (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go1 String
xs
  go2 :: String -> String
go2 String
"" = String
""
  go2 (Char
l : Char
u : String
xs) | Char -> Bool
isLower Char
l Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
u = Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go2 String
xs
  go2 (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go2 String
xs

-- | "Data.Text.Text" version of 'camelTo'
--
-- @since 0.0.2.0
camelToText :: Char -> Text -> Text
camelToText :: Char -> Text -> Text
camelToText Char
c = String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
camelTo Char
c (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack