{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Extensible.Envy
( recordFromEnvWith
, recordFromEnv
, FieldLabelToEnvName
, defaultFieldLabelToEnvName
, camelToUpperSnakeCase
) where
import qualified Data.Char as C
import Data.Extensible (Forall, Instance1)
import qualified Data.Extensible as Ex
import Data.Functor.Identity (Identity (Identity), runIdentity)
import Data.Kind (Type)
import Data.Proxy (Proxy (Proxy))
import GHC.TypeLits (KnownSymbol, Symbol)
import qualified System.Envy as Env
type FieldLabelToEnvName = String -> String
defaultFieldLabelToEnvName :: String -> FieldLabelToEnvName
defaultFieldLabelToEnvName "" s = camelToUpperSnakeCase s
defaultFieldLabelToEnvName prefix s = prefix ++ "_" ++ camelToUpperSnakeCase s
{-# INLINE defaultFieldLabelToEnvName #-}
camelToUpperSnakeCase :: FieldLabelToEnvName
camelToUpperSnakeCase =
foldMap (\c -> if C.isUpper c then '_' : [c] else [C.toUpper c])
{-# INLINE camelToUpperSnakeCase #-}
recordFromEnv
:: forall (xs :: [Ex.Assoc Symbol Type]) h
. Forall (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h)) xs
=> Env.Parser (Ex.RecordOf h xs)
recordFromEnv = recordFromEnvWith $ defaultFieldLabelToEnvName ""
{-# INLINE recordFromEnv #-}
recordFromEnvWith
:: forall (xs :: [Ex.Assoc Symbol Type]) h
. Forall (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h)) xs
=> FieldLabelToEnvName
-> Env.Parser (Ex.RecordOf h xs)
recordFromEnvWith fl2en =
Ex.hgenerateFor
(Proxy :: Proxy (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h))) f
where
f membership = Ex.Field <$> Env.env (fl2en $ Ex.stringKeyOf membership)
{-# INLINE recordFromEnvWith #-}
instance Forall (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h)) xs
=> Env.FromEnv (Ex.RecordOf (h :: Type -> Type) xs)
where
fromEnv (Just r) = pure r
fromEnv Nothing = recordFromEnv
{-# INLINE fromEnv #-}
instance Env.Var a => Env.Var (Identity a) where
toVar = Env.toVar . runIdentity
{-# INLINE toVar #-}
fromVar = fmap Identity . Env.fromVar
{-# INLINE fromVar #-}