{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module: Data.Env.ExtractFields
-- Description: Type class for extracting fields from a record type.
--
-- This module provides a type class 'ExtractFields' that extracts field names
-- from a record type. It also provides functions to retrieve environment
-- variables based on these field names, with options for different naming
-- conventions.
module Data.Env.ExtractFields (
  ExtractFields,
  extractFields,
  getEnvRaw,
  getEnvRawLowerToUpperSnake,
  getEnvRawCamelCaseToUpperSnake,
) where

import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Char

import           Data.Maybe
import           Data.Map (Map)
import           Data.Proxy
import           GHC.Generics
import qualified Data.Map as M
import           System.Environment

-- | Type class for extracting field names from a record type.
class ExtractFields a where
  extractFields' :: Proxy a -> [String]

-- | Extract field names from a record type.
extractFields :: forall a. ExtractFields a => [String]
extractFields :: forall {k} (a :: k). ExtractFields a => [String]
extractFields = Proxy a -> [String]
forall {k} (a :: k). ExtractFields a => Proxy a -> [String]
extractFields' (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
{-# INLINE extractFields #-}

-- | Retrieve environment variables based on field names, applying a mapping
-- function to the field names.
getEnvRaw :: forall a m. (MonadIO m, ExtractFields a)
          => (String -> String)
          -> m (Map String String)
getEnvRaw :: forall {k} (a :: k) (m :: * -> *).
(MonadIO m, ExtractFields a) =>
(String -> String) -> m (Map String String)
getEnvRaw String -> String
mapper = IO (Map String String) -> m (Map String String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String String) -> m (Map String String))
-> IO (Map String String) -> m (Map String String)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, String)] -> Map String String)
-> IO [(String, String)] -> IO (Map String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> (String -> IO (String, String)) -> IO [(String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (a :: k). ExtractFields a => [String]
forall {k} (a :: k). ExtractFields a => [String]
extractFields @a) \String
field -> do
  Maybe String
value <- String -> IO (Maybe String)
lookupEnv (String -> String
mapper String
field)
  (String, String) -> IO (String, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
field, String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
value)
{-# INLINE getEnvRaw #-}

-- | Retrieve environment variables based on field names, converting them to
-- upper case.
getEnvRawLowerToUpperSnake :: forall a m. (MonadIO m, ExtractFields a)
                           => m (Map String String)
getEnvRawLowerToUpperSnake :: forall {k} (a :: k) (m :: * -> *).
(MonadIO m, ExtractFields a) =>
m (Map String String)
getEnvRawLowerToUpperSnake = forall (a :: k) (m :: * -> *).
(MonadIO m, ExtractFields a) =>
(String -> String) -> m (Map String String)
forall {k} (a :: k) (m :: * -> *).
(MonadIO m, ExtractFields a) =>
(String -> String) -> m (Map String String)
getEnvRaw @a ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper)
{-# INLINE getEnvRawLowerToUpperSnake #-}


--------------------------------------------------------------------------------
-- Generic instances
--------------------------------------------------------------------------------

-- | Retrieve environment variables based on field names, converting them from
-- camel case (record field naming) to upper snake case (environment variable
-- naming).
getEnvRawCamelCaseToUpperSnake :: forall a m. (MonadIO m, ExtractFields a)
                               => m (Map String String)
getEnvRawCamelCaseToUpperSnake :: forall {k} (a :: k) (m :: * -> *).
(MonadIO m, ExtractFields a) =>
m (Map String String)
getEnvRawCamelCaseToUpperSnake = forall (a :: k) (m :: * -> *).
(MonadIO m, ExtractFields a) =>
(String -> String) -> m (Map String String)
forall {k} (a :: k) (m :: * -> *).
(MonadIO m, ExtractFields a) =>
(String -> String) -> m (Map String String)
getEnvRaw @a String -> String
camelToUpperSnake
{-# INLINE getEnvRawCamelCaseToUpperSnake #-}

class GExtractFields f where
  gExtractFields :: Proxy f -> [String]

instance GExtractFields f => GExtractFields (M1 D c f) where
  gExtractFields :: Proxy (M1 D c f) -> [String]
  gExtractFields :: Proxy (M1 D c f) -> [String]
gExtractFields Proxy (M1 D c f)
_ = Proxy f -> [String]
forall {k} (f :: k). GExtractFields f => Proxy f -> [String]
gExtractFields (Proxy f
forall {k} (t :: k). Proxy t
Proxy :: Proxy f)
  {-# INLINE gExtractFields #-}

instance GExtractFields f => GExtractFields (M1 C c f) where
  gExtractFields :: Proxy (M1 C c f) -> [String]
  gExtractFields :: Proxy (M1 C c f) -> [String]
gExtractFields Proxy (M1 C c f)
_ = Proxy f -> [String]
forall {k} (f :: k). GExtractFields f => Proxy f -> [String]
gExtractFields (Proxy f
forall {k} (t :: k). Proxy t
Proxy :: Proxy f)
  {-# INLINE gExtractFields #-}

instance (GExtractFields f, GExtractFields g) => GExtractFields (f :*: g) where
  gExtractFields :: Proxy (f :*: g) -> [String]
  gExtractFields :: Proxy (f :*: g) -> [String]
gExtractFields Proxy (f :*: g)
_ = Proxy f -> [String]
forall {k} (f :: k). GExtractFields f => Proxy f -> [String]
gExtractFields (Proxy f
forall {k} (t :: k). Proxy t
Proxy :: Proxy f)
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Proxy g -> [String]
forall {k} (f :: k). GExtractFields f => Proxy f -> [String]
gExtractFields (Proxy g
forall {k} (t :: k). Proxy t
Proxy :: Proxy g)
  {-# INLINE gExtractFields #-}

instance (Selector s) => GExtractFields (M1 S s (K1 i a)) where
  gExtractFields :: Proxy (M1 S s (K1 i a)) -> [String]
  gExtractFields :: forall {k}. Proxy (M1 S s (K1 i a)) -> [String]
gExtractFields Proxy (M1 S s (K1 i a))
_ = [M1 S s (K1 i a) Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s (K1 i a) p
forall {k} {p :: k}. M1 S s (K1 i a) p
forall a. HasCallStack => a
undefined :: M1 S s (K1 i a) p)]
  {-# INLINE gExtractFields #-}

instance (Generic a, GExtractFields (Rep a)) => ExtractFields a where
  extractFields' :: Proxy a -> [String]
  extractFields' :: Proxy a -> [String]
extractFields' Proxy a
_ = Proxy (Rep a) -> [String]
forall {k} (f :: k). GExtractFields f => Proxy f -> [String]
gExtractFields (Proxy (Rep a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep a))
  {-# INLINE extractFields' #-}


--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

camelToUpperSnake :: String -> String
camelToUpperSnake :: String -> String
camelToUpperSnake = Bool -> String -> String
go Bool
False
  where
    go :: Bool -> String -> String
go Bool
_ [] = []
    go Bool
prevUpper (Char
x:String
xs)
      | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'  = Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
xs
      | Char -> Bool
isUpper Char
x =
          let rest :: String
rest = Bool -> String -> String
go Bool
True String
xs
          in  if Bool
prevUpper then Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest else Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
      | Bool
otherwise = Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
False String
xs