yore/src/Envy.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Envy
  ( type (=@@)
  , type (=@!)
  , type (?)
  , type (=@?)
  , ReadEnvVar (..)
  , Required
  , Optional
  , load
  , ConfigVariant (..)
  , MyNothing
  , OptionalMaybe
  ) where

import Data.Bifunctor (first)
import Data.Char (isLower, isUpper, toUpper)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Ratio ((%))
import Data.Text (Text)
import Data.Typeable (Typeable, typeRep)
import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal, type (<=))
import System.Environment (getEnvironment)
import Text.Printf (printf)
import Text.Read (readEither)

import qualified Data.Text as Text

data ConfigVariant = Spec | Value

data Required t
data Optional t d

type family v =@@ t :: Type where
  Spec =@@ t = t
  Value =@@ (Required t) = t
  Value =@@ (Optional t d) = t

type OptionalMaybe t = Optional (Maybe t) MyNothing

-- No associativity - these are not supposed to be chained
infix 6 =@@
infix 7 ?

type v =@! t = v =@@ Required t
type v =@? t = v =@@ OptionalMaybe t
type t ? d = Optional t d

load
  :: forall (m :: ConfigVariant -> Type)
   . (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value)))
  => IO (Either String (m Value))
load = do
  env <- getEnvironment
  pure $ to <$> gFromEnv @(Rep (m Spec)) @(Rep (m Value)) Proxy env

class GFromEnv spec value where
  gFromEnv :: Proxy (spec c) -> [(String, String)] -> Either String (value c)

instance
  (GFromEnv i o)
  => GFromEnv (M1 D b i) (M1 D d o)
  where
  gFromEnv Proxy env = M1 <$> gFromEnv @i @o Proxy env

instance
  (GFromEnv i o)
  => GFromEnv (M1 C b i) (M1 C d o)
  where
  gFromEnv Proxy env = M1 <$> gFromEnv @i @o Proxy env

instance (GFromEnv i1 o1, GFromEnv i2 o2) => GFromEnv (i1 :*: i2) (o1 :*: o2) where
  gFromEnv Proxy env = (:*:) <$> gFromEnv @i1 @o1 Proxy env <*> gFromEnv @i2 @o2 Proxy env

instance
  (KnownSymbol sym, EnvVarSpec s t)
  => GFromEnv
      (M1 S (MetaSel (Just sym) su ss lz) (Rec0 s))
      (M1 S meta2 (Rec0 t))
  where
  gFromEnv Proxy env =
    M1 . K1 <$> decodeEnvVar @s @t Proxy varName (lookup varName env)
    where
      varName = selectorNameToEnvVarName $ symbolVal $ Proxy @sym

class EnvVarSpec specTy valueTy where
  decodeEnvVar :: Proxy specTy -> String -> Maybe String -> Either String valueTy

instance (Typeable t, ReadEnvVar t) => EnvVarSpec (Required t) t where
  decodeEnvVar Proxy varName = \case
    Nothing -> Left $ printf "env var %s is missing" varName
    Just str -> readEnvVarWithContext varName str

instance (Typeable t, ReadEnvVar t, ProvidesDefault t d) => EnvVarSpec (Optional t d) t where
  decodeEnvVar Proxy varName = \case
    Nothing -> Right $ getDefault (Proxy @d)
    Just str -> readEnvVarWithContext varName str

class ReadEnvVar t where
  readEnvVar :: String -> Either String t

readEnvVarWithContext :: forall t. (Typeable t, ReadEnvVar t) => String -> String -> Either String t
readEnvVarWithContext varName str =
  first (context ++) $ readEnvVar str
  where
    context = printf "env var %s='%s' is not a valid %s: " varName str (show $ typeRep $ Proxy @t)

class ProvidesDefault t d where
  getDefault :: Proxy d -> t

instance ReadEnvVar Integer where
  readEnvVar = readEither

-- TODO: Support negative integers (e.g. (Negate n))
instance (KnownNat n) => ProvidesDefault Integer n where
  getDefault Proxy = natVal (Proxy @n)

instance ReadEnvVar Int where
  readEnvVar = readEither

-- TODO: Support negative integers (e.g. (Negate n))
-- This instance assumes that @Int@ is a 64-bit integer and enforces its range on the type level.
instance (KnownNat n, n <= 9223372036854775807) => ProvidesDefault Int n where
  getDefault Proxy = fromInteger $ natVal (Proxy @n)

instance ReadEnvVar String where
  readEnvVar = Right

instance (KnownSymbol s) => ProvidesDefault String s where
  getDefault Proxy = symbolVal (Proxy @s)

instance ReadEnvVar Text where
  readEnvVar = fmap Text.pack . readEnvVar

instance (KnownSymbol s) => ProvidesDefault Text s where
  getDefault Proxy = Text.pack $ getDefault (Proxy @s)

instance ReadEnvVar Rational where
  readEnvVar = readEither

instance (KnownNat num, KnownNat denom) => ProvidesDefault Rational '(num, denom) where
  getDefault Proxy = natVal (Proxy @num) % natVal (Proxy @denom)

instance ReadEnvVar Double where
  readEnvVar = readEither

instance (KnownNat num, KnownNat denom) => ProvidesDefault Double '(num, denom) where
  getDefault Proxy = fromRational $ getDefault @Rational @'(num, denom) Proxy

instance (ReadEnvVar t) => ReadEnvVar (Maybe t) where
  readEnvVar = fmap Just . readEnvVar

instance (ProvidesDefault t d) => ProvidesDefault (Maybe t) (Just d) where
  getDefault Proxy = Just $ getDefault @t @d Proxy

data MyNothing

instance ProvidesDefault (Maybe t) MyNothing where
  getDefault Proxy = Nothing

-- Converts camelCase names to UPPER_SNAKE_CASE.
selectorNameToEnvVarName :: String -> String
selectorNameToEnvVarName = go
  where
    go [] =
      []
    go (c0 : c1 : rest)
      | isUpper c0 && isLower c1 = '_' : c0 : toUpper c1 : go rest
    go (c0 : rest) =
      toUpper c0 : go rest