RecordParserW.hs

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

{- |
Module      : Data.Env.RecordParserW
Description : Schema-driven record parsing with value-level field parsers

Provides 'RecordParserW' for parsing environment-variable schemas whose
fields use the 'Col' column family.

== Design

A @schema 'Dec@ is a plain Haskell record whose fields are functions
@'String' -> 'Either' 'String' a@. An absent or empty env variable is
passed as @""@; the function decides what to do. A @schema 'Res@ is the
same record with each field replaced by its resolved value.

@
data DbConfig c = DbConfig
  { host :: Col c Text
  , port :: Col c Int
  }
  deriving (Generic)

instance RecordParserW (DbConfig \'Dec)

-- Default schema (both fields required — no default):
schema :: DbConfig \'Dec
schema = 'defaultSchema' \@DbConfig

-- Schema with runtime defaults, using infix 'orElse':
schema' :: DbConfig \'Dec
schema' = schema
  { host = 'typeParser' \@Text \`orElse\` \"localhost\"
  , port = 'typeParser' \@Int  \`orElse\` 5432
  }
@

== Helpers

* 'typeParser' — builds the standard parser for any 'TypeParser' type.
* 'orElse' — sets the fallback value when the env variable is absent or empty.
* 'fromTypeParserW' — bridges a 'TypeParserW' witness into a field function.
-}
module Data.Env.RecordParserW
  ( RecordParserW (..)
  , HasDefaultSchema (..)
  , ColumnType (..)
  , Col
  , typeParser
  , orElse
  , fromTypeParserW
  ) where

import Data.Env.Internal.Validation
import Data.Env.ParseError
import Data.Env.TypeParser (TypeParser)
import Data.Env.TypeParser qualified as TP
import Data.Env.TypeParserW (TypeParserW)
import Data.Env.TypeParserW qualified as TPW
import Data.Kind (Type)
import Data.Map (Map)
import Data.Map qualified as M
import Data.Proxy (Proxy (..))
import GHC.Generics

-- | Column type indicator.
--
-- * 'Dec' — schema column; each field holds a @'String' -> 'Either' 'String' a@ parser.
-- * 'Res' — result column; each field holds the resolved @a@.
data ColumnType = Dec | Res
  deriving stock (Eq, Show)

-- | Type family mapping a column kind to the field representation.
--
-- @'Col' ''Dec' a = 'String' -> 'Either' 'String' a@
-- @'Col' ''Res' a = a@
type family Col (c :: ColumnType) (a :: Type) :: Type where
  Col 'Dec a = String -> Either String a
  Col 'Res a = a

{- | Build the standard field parser for any 'TypeParser' type.

Passes non-empty strings to 'TP.parseType' and treats @""@ (absent or empty
env variable) as a missing value, delegating to 'TP.parseMissing'. Most
types treat absence as an error (required field); 'Maybe' returns
@'Right' 'Nothing'@.

Combine with 'orElse' to supply a fallback:

@
port = 'typeParser' \@Int \`orElse\` 5432
@
-}
typeParser :: forall a. TypeParser a => String -> Either String a
typeParser "" = TP.parseMissing @a
typeParser s = TP.parseType s
{-# INLINE typeParser #-}

{- | Set the fallback value when the env variable is absent or empty.

Designed for infix use with 'typeParser' or 'fromTypeParserW':

@
port  = 'typeParser' \@Int  \`orElse\` 5432
host  = 'typeParser' \@Text \`orElse\` \"localhost\"
model = 'typeParser' \@Text \`orElse\` \"claude-sonnet-4-6\"
@

@f \`orElse\` d@ returns @'Right' d@ when the variable is absent or empty,
and @f s@ for any non-empty string @s@.
-}
orElse :: (String -> Either String a) -> a -> String -> Either String a
orElse _ d "" = Right d
orElse f _ s = f s
{-# INLINE orElse #-}

{- | Build a field parser from a 'TypeParserW' witness.

Bridges existing witness types into the value-level field API. Also
composable with 'orElse':

@
fromTypeParserW \@MyCustomWitness \`orElse\` \"fallback\"
@
-}
fromTypeParserW :: forall p a. TypeParserW p a => String -> Either String a
fromTypeParserW "" = TPW.parseMissingW @p Proxy
fromTypeParserW s = TPW.parseTypeW @p Proxy s
{-# INLINE fromTypeParserW #-}

-- | Type class for schemas whose fields are 'Col' columns.
--
-- The method 'parseRecordW' takes the schema value (a @schema 'Dec@) and an
-- env map, returning all field failures collected rather than stopping at
-- the first.
class RecordParserW a where
  -- | The resolved type produced by parsing @a@.
  type RecordParsedType a

  -- | Parse all fields from the env map using the schema's field functions.
  parseRecordW :: a -> Map String String -> Either ParseError (RecordParsedType a)

instance
  ( Generic (a 'Dec)
  , GRecordParserW (Rep (a 'Dec))
  , Generic (a 'Res)
  , GRecordParsedType (Rep (a 'Dec)) () ~ Rep (a 'Res) ()
  ) =>
  RecordParserW (a 'Dec)
  where
  type RecordParsedType (a 'Dec) = a 'Res
  parseRecordW :: a 'Dec -> Map String String -> Either ParseError (a 'Res)
  parseRecordW schema env =
    validationToEither (to <$> gParseRecord (from schema) env)

{- | Generically derive a @schema 'Dec@ whose every field uses 'typeParser'.

Requires every field type to have a 'TypeParser' instance. Override
individual fields on the returned value to customise parsing:

@
mySchema :: MyConfig \'Dec
mySchema = ('defaultSchema' \@MyConfig)
  { host = 'typeParser' \@Text \`orElse\` \"localhost\" }
@
-}
class HasDefaultSchema a where
  defaultSchema :: a 'Dec

instance (Generic (a 'Dec), GDefaultSchema (Rep (a 'Dec))) => HasDefaultSchema a where
  defaultSchema :: a 'Dec
  defaultSchema = to gDefaultSchema

--------------------------------------------------------------------------------
-- Generic parsing
--------------------------------------------------------------------------------

class GRecordParserW f where
  type GRecordParsedType f :: Type -> Type
  gParseRecord :: f () -> Map String String -> Validation ParseError ((GRecordParsedType f) ())

instance GRecordParserW f => GRecordParserW (M1 D c f) where
  type GRecordParsedType (M1 D c f) = M1 D c (GRecordParsedType f)
  gParseRecord (M1 x) env = M1 <$> gParseRecord x env

instance GRecordParserW f => GRecordParserW (M1 C c f) where
  type GRecordParsedType (M1 C c f) = M1 C c (GRecordParsedType f)
  gParseRecord (M1 x) env = M1 <$> gParseRecord x env

instance (GRecordParserW f, GRecordParserW g) => GRecordParserW (f :*: g) where
  type GRecordParsedType (f :*: g) = GRecordParsedType f :*: GRecordParsedType g
  gParseRecord (x :*: y) env = (:*:) <$> gParseRecord x env <*> gParseRecord y env

instance Selector s => GRecordParserW (M1 S s (K1 i (String -> Either String a))) where
  type GRecordParsedType (M1 S s (K1 i (String -> Either String a))) = M1 S s (K1 i a)
  gParseRecord (M1 (K1 fn)) env =
    let key = selName (undefined :: M1 S s (K1 i a) p)
        result = case M.lookup key env of
          Nothing -> fn ""
          Just v  -> fn v
      in M1 . K1 <$> case result of
            Left msg  -> VFailure $ ParseError [FieldError{errField = key, errMessage = msg}]
            Right val -> VSuccess val


--------------------------------------------------------------------------------
-- Generic default schema
--------------------------------------------------------------------------------

class GDefaultSchema f where
  gDefaultSchema :: f ()

instance GDefaultSchema f => GDefaultSchema (M1 D c f) where
  gDefaultSchema :: M1 D c f ()
  gDefaultSchema = M1 gDefaultSchema

instance GDefaultSchema f => GDefaultSchema (M1 C c f) where
  gDefaultSchema :: M1 C c f ()
  gDefaultSchema = M1 gDefaultSchema

instance (GDefaultSchema f, GDefaultSchema g) => GDefaultSchema (f :*: g) where
  gDefaultSchema :: (f :*: g) ()
  gDefaultSchema = gDefaultSchema :*: gDefaultSchema

instance TypeParser a => GDefaultSchema (M1 S s (K1 i (String -> Either String a))) where
  gDefaultSchema :: M1 S s (K1 i (String -> Either String a)) ()
  gDefaultSchema = M1 (K1 (typeParser @a))