From c69a1114b8b6adb5621a5a06d24833227637ab34 Mon Sep 17 00:00:00 2001
From: Paul Brinkmeier <brinkmeier@meqo.de>
Date: Wed, 17 Sep 2025 18:20:26 +0200
Subject: [PATCH] Provide type operator based envy API

---
 src/Envy.hs | 68 ++++++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 60 insertions(+), 8 deletions(-)

diff --git a/src/Envy.hs b/src/Envy.hs
index 103d9b2..9edb41f 100644
--- a/src/Envy.hs
+++ b/src/Envy.hs
@@ -1,10 +1,24 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
-module Envy (Env, Required, Optional, load) where
+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 ((%))
@@ -20,10 +34,20 @@ 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
+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 (m Value)
@@ -59,14 +83,14 @@ instance
     Left err -> error err
     Right value -> M1 $ K1 value
     where
-      varName = symbolVal $ Proxy @sym
+      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 "%s is missing" varName
+    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
@@ -81,7 +105,7 @@ readEnvVarWithContext :: forall t. (Typeable t, ReadEnvVar t) => String -> Strin
 readEnvVarWithContext varName str =
   first (context ++) $ readEnvVar str
   where
-    context = printf "%s='%s' is not a valid %s: " varName str (show $ typeRep $ Proxy @t)
+    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
@@ -103,3 +127,31 @@ instance ReadEnvVar Rational where
 
 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