Implement envy

src/Envy.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Envy (Env, Required, Optional, load) where
+
+import Data.Bifunctor (first)
+import Data.Kind (Type)
+import Data.Proxy (Proxy (..))
+import Data.Ratio ((%))
+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)
+import System.Environment (getEnvironment)
+import Text.Printf (printf)
+import Text.Read (readEither)
+
+data ConfigVariant = Spec | Value
+
+data Required t
+data Optional t d
+
+type family Env v t :: Type where
+  Env Spec t = t
+  Env Value (Required t) = t
+  Env Value (Optional t d) = t
+
+load
+  :: forall (m :: ConfigVariant -> Type). (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value))) => IO (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)] -> 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 = case decodeEnvVar @s @t Proxy varName $ lookup varName env of
+    Left err -> error err
+    Right value -> M1 $ K1 value
+    where
+      varName = 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 "%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 "%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
+
+instance (KnownNat n) => ProvidesDefault Integer n where
+  getDefault Proxy = natVal (Proxy @n)
+
+instance ReadEnvVar String where
+  readEnvVar = Right
+
+instance (KnownSymbol s) => ProvidesDefault String s where
+  getDefault Proxy = symbolVal (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)