Variable.hs

module Seihou.Core.Variable
  ( resolveVariables,
    resolveVariablesWithSaved,
    resolveVariablesWithSources,
    isValidVarBindingName,
    validateVarPattern,
    validateVarValueFrom,
    formatVarSource,
    coerceValue,
    coerceDefault,
    validateVarValue,
    formatExplain,
    formatDeclarations,
    envVarName,
    diagnoseResolution,
  )
where

import Data.Char (toUpper)
import Data.Generics.Labels ()
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes)
import Data.Set qualified as Set
import Data.Text qualified as T
import Seihou.Core.Types
import Seihou.Prelude
import Text.Regex.TDFA (CompOption (..), defaultCompOpt, defaultExecOpt)
import Text.Regex.TDFA.Text qualified as Regex

-- | Binding names follow the variable vocabulary, including camelCase segments.
isValidVarBindingName :: Text -> Bool
isValidVarBindingName t = case T.uncons t of
  Nothing -> False
  Just (c, rest) -> lower c && T.all (\x -> lower x || (x >= 'A' && x <= 'Z') || (x >= '0' && x <= '9') || x == '.' || x == '-') rest
  where
    lower c = c >= 'a' && c <= 'z'

-- | Derive the environment variable name for a given variable.
-- @VarName "project.name"@ becomes @"SEIHOU_VAR_PROJECT_NAME"@.
envVarName :: VarName -> Text
envVarName (VarName name) =
  "SEIHOU_VAR_" <> T.map (\c -> if c == '.' then '_' else toUpper c) name

-- | Attempt to coerce a text value to the declared variable type.
coerceValue :: VarName -> VarType -> Text -> Either VarError VarValue
coerceValue name VTText t = Right (VText t)
coerceValue name VTBool t =
  case T.toLower (T.strip t) of
    "true" -> Right (VBool True)
    "yes" -> Right (VBool True)
    "1" -> Right (VBool True)
    "false" -> Right (VBool False)
    "no" -> Right (VBool False)
    "0" -> Right (VBool False)
    _ -> Left (CoercionFailed name VTBool t)
coerceValue name VTInt t =
  case reads (T.unpack (T.strip t)) of
    [(n, "")] -> Right (VInt n)
    _ -> Left (CoercionFailed name VTInt t)
coerceValue name (VTList VTText) t =
  Right (VList (map (VText . T.strip) (T.splitOn "," t)))
coerceValue name (VTList elemTy) t =
  Left (CoercionFailed name (VTList elemTy) t)
coerceValue name (VTChoice options) t
  | T.strip t `elem` options = Right (VText (T.strip t))
  | otherwise = Left (CoercionFailed name (VTChoice options) t)

-- | Coerce a module *default* value to its declared type.
--
-- Defaults are decoded from Dhall as raw 'VText'; this routes them through the
-- same 'coerceValue' contract as every other resolution source so a defaulted
-- variable reaches evaluation with the correct runtime type (e.g. a @bool@
-- default of @"true"@ becomes 'VBool' 'True', not 'VText' @"true"@).
--
-- A value that is already typed (e.g. a default synthesized during
-- composition) passes through unchanged. An unconstrained choice
-- (@VTChoice []@ — the only form the Dhall decoder currently produces, since
-- options are not yet carried in the type string) keeps its text value, as
-- there are no options to validate membership against.
coerceDefault :: VarName -> VarType -> VarValue -> Either VarError VarValue
coerceDefault _ (VTChoice []) (VText raw) = Right (VText raw)
coerceDefault name ty (VText raw) = coerceValue name ty raw
coerceDefault _ _ v = Right v

-- | Validate a resolved value against its declaration's validation constraint.
validateVarValue :: VarDecl -> VarValue -> Either VarError ()
validateVarValue decl val =
  case decl ^. #validation of
    Nothing -> Right ()
    Just v -> checkValidation (decl ^. #name) v val

checkValidation :: VarName -> Validation -> VarValue -> Either VarError ()
checkValidation name (ValPattern pat) (VText t) =
  do
    regex <- compilePattern name pat
    case Regex.execute regex t of
      Left err -> Left (ValidationFailed name ("pattern execution failed: " <> T.pack err))
      Right Nothing -> Left (ValidationFailed name ("value does not match pattern: " <> pat))
      Right (Just _) -> Right ()
checkValidation name (ValPattern _) _ =
  Left (ValidationFailed name "pattern validation requires a text value")
checkValidation name (ValRange lo hi) (VInt n)
  | n >= lo && n <= hi = Right ()
  | otherwise =
      Left
        ( ValidationFailed
            name
            ( "value "
                <> T.pack (show n)
                <> " is not in range ["
                <> T.pack (show lo)
                <> ", "
                <> T.pack (show hi)
                <> "]"
            )
        )
checkValidation name (ValRange _ _) _ =
  Left (ValidationFailed name "range validation requires an integer value")
checkValidation name (ValMinLength n) (VText t)
  | T.length t >= n = Right ()
  | otherwise =
      Left
        ( ValidationFailed
            name
            ("value must be at least " <> T.pack (show n) <> " characters")
        )
checkValidation name (ValMinLength _) _ =
  Left (ValidationFailed name "min-length validation requires a text value")
checkValidation name (ValMaxLength n) (VText t)
  | T.length t <= n = Right ()
  | otherwise =
      Left
        ( ValidationFailed
            name
            ("value must be at most " <> T.pack (show n) <> " characters")
        )
checkValidation name (ValMaxLength _) _ =
  Left (ValidationFailed name "max-length validation requires a text value")

-- | Compile a whole-value POSIX extended pattern without throwing on bad syntax.
compilePattern :: VarName -> Text -> Either VarError Regex.Regex
compilePattern name pat = do
  -- Check the author's pattern separately: the surrounding group must not
  -- accidentally balance an unmatched parenthesis in the declaration.
  _ <- compile (if T.null pat then "()" else pat)
  compile ("^(" <> pat <> ")$")
  where
    -- regex-tdfa CompOption has no Generic instance; record update syntax is required.
    compile patternText = case Regex.compile (defaultCompOpt {multiline = False}) defaultExecOpt patternText of
      Left err -> Left (ValidationFailed name ("invalid pattern '" <> pat <> "'; correct the declaration's validation: " <> T.pack err))
      Right regex -> Right regex

-- | Check declarations even when an optional input has no selected value.
validateVarPattern :: VarDecl -> Either VarError ()
validateVarPattern decl = case decl ^. #validation of
  Just (ValPattern pat) -> () <$ compilePattern (decl ^. #name) pat
  _ -> Right ()

-- | Attach the selected source while it is still available, without displaying
-- potentially secret values. The suggested override is supported by run/update.
validateVarValueFrom :: VarSource -> VarDecl -> VarValue -> Either VarError ()
validateVarValueFrom source decl val = case validateVarValue decl val of
  Left (ValidationFailed name msg) ->
    Left (ValidationFailed name ("from " <> formatVarSource source <> ": " <> msg <> "; supply --var " <> name ^. #unVarName <> "=" <> correction <> " satisfying the constraint"))
  other -> other
  where
    correction = case decl ^. #default_ of
      Just (VText raw) | Right () <- validateVarValue decl (VText raw) -> raw
      _ -> "VALUE"

-- | Resolve all variables for a module given CLI overrides, environment variables,
-- four config file layers, and parent-supplied variable bindings.
--
-- Precedence chain (highest to lowest):
-- 1. CLI overrides (@--var@ flags)
-- 2. Saved application values (when supplied by the update resolver)
-- 3. Environment variables (@SEIHOU_VAR_@ prefix)
-- 4. Local project config (@.seihou\/config.dhall@)
-- 5. Namespace config (@~\/.config\/seihou\/namespaces\/\<ns\>\/config.dhall@)
-- 6. Context config (@~\/.config\/seihou\/contexts\/\<ctx\>\/config.dhall@)
-- 7. Global config (@~\/.config\/seihou\/config.dhall@)
-- 8. Parent-supplied vars (from parameterized dependencies)
-- 9. Module defaults
resolveVariables ::
  [VarDecl] ->
  Map VarName Text -> -- CLI overrides
  Map Text Text -> -- Environment variables
  Text -> -- Namespace name (used in provenance tagging)
  Text -> -- Context name (used in provenance tagging)
  Map VarName Text -> -- Local config
  Map VarName Text -> -- Namespace config
  Map VarName Text -> -- Context config
  Map VarName Text -> -- Global config
  Map VarName (Text, ModuleName) -> -- Parent-supplied vars
  Either [VarError] (Map VarName ResolvedVar)
resolveVariables decls cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig parentVars =
  resolveVariablesWithSaved decls cliOverrides Map.empty envVars namespace context localConfig nsConfig ctxConfig globalConfig parentVars

-- | Resolve variables with values saved from a previously accepted application.
-- Explicit CLI values remain authoritative; saved values are re-coerced through
-- the candidate declaration before any ambient environment or config layer is
-- considered.
resolveVariablesWithSaved ::
  [VarDecl] ->
  Map VarName Text -> -- CLI overrides
  Map VarName Text -> -- Saved application values
  Map Text Text -> -- Environment variables
  Text -> -- Namespace name (used in provenance tagging)
  Text -> -- Context name (used in provenance tagging)
  Map VarName Text -> -- Local config
  Map VarName Text -> -- Namespace config
  Map VarName Text -> -- Context config
  Map VarName Text -> -- Global config
  Map VarName (Text, ModuleName) -> -- Parent-supplied vars
  Either [VarError] (Map VarName ResolvedVar)
resolveVariablesWithSaved decls cliOverrides =
  resolveVariablesWithSources decls (Map.map (\raw -> (raw, FromCLI)) cliOverrides)

-- | Resolve explicit inputs carrying their actual source (recipe bindings and
-- already accepted recipe inputs use the same precedence as explicit values).
resolveVariablesWithSources ::
  [VarDecl] ->
  Map VarName (Text, VarSource) ->
  Map VarName Text ->
  Map Text Text ->
  Text ->
  Text ->
  Map VarName Text ->
  Map VarName Text ->
  Map VarName Text ->
  Map VarName Text ->
  Map VarName (Text, ModuleName) ->
  Either [VarError] (Map VarName ResolvedVar)
resolveVariablesWithSources decls explicitValues savedValues envVars namespace context localConfig nsConfig ctxConfig globalConfig parentVars =
  case partitionResults (map resolveOne decls) of
    ([], resolved) -> Right (Map.fromList (catMaybes resolved))
    (errs, _) -> Left errs
  where
    resolveOne :: VarDecl -> Either VarError (Maybe (VarName, ResolvedVar))
    resolveOne decl = do
      validateVarPattern decl
      let name = (decl ^. #name)
          ty = (decl ^. #type_)
      case lookupCLI name ty of
        Just result -> fmap Just (result >>= validateAndWrap decl)
        Nothing -> case lookupSaved name ty of
          Just result -> fmap Just (result >>= validateAndWrap decl)
          Nothing -> case lookupEnv name ty of
            Just result -> fmap Just (result >>= validateAndWrap decl)
            Nothing -> case lookupConfig name ty localConfig FromLocalConfig of
              Just result -> fmap Just (result >>= validateAndWrap decl)
              Nothing -> case lookupConfig name ty nsConfig (FromNamespaceConfig namespace) of
                Just result -> fmap Just (result >>= validateAndWrap decl)
                Nothing -> case lookupConfig name ty ctxConfig (FromContextConfig context) of
                  Just result -> fmap Just (result >>= validateAndWrap decl)
                  Nothing -> case lookupConfig name ty globalConfig FromGlobalConfig of
                    Just result -> fmap Just (result >>= validateAndWrap decl)
                    Nothing -> case lookupParent name ty of
                      Just result -> fmap Just (result >>= validateAndWrap decl)
                      Nothing -> case decl ^. #default_ of
                        Just defVal ->
                          case coerceDefault name ty defVal of
                            Left err -> Left err
                            Right val -> fmap Just (validateAndWrap decl (val, FromDefault))
                        Nothing
                          | decl ^. #required -> Left (MissingRequiredVar name)
                          | otherwise -> Right Nothing

    lookupSaved :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource))
    lookupSaved name ty =
      case Map.lookup name savedValues of
        Nothing -> Nothing
        Just rawText ->
          Just $ case coerceValue name ty rawText of
            Left err -> Left err
            Right val -> Right (val, FromApplication)

    lookupParent :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource))
    lookupParent name ty =
      case Map.lookup name parentVars of
        Nothing -> Nothing
        Just (rawText, parentName) ->
          Just $ case coerceValue name ty rawText of
            Left err -> Left err
            Right val -> Right (val, FromParent parentName)

    lookupCLI :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource))
    lookupCLI name ty =
      case Map.lookup name explicitValues of
        Nothing -> Nothing
        Just (rawText, source) ->
          Just $ case coerceValue name ty rawText of
            Left err -> Left err
            Right val -> Right (val, source)

    lookupEnv :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource))
    lookupEnv name ty =
      let envKey = envVarName name
       in case Map.lookup envKey envVars of
            Nothing -> Nothing
            Just rawText ->
              Just $ case coerceValue name ty rawText of
                Left err -> Left err
                Right val -> Right (val, FromEnv envKey)

    lookupConfig :: VarName -> VarType -> Map VarName Text -> VarSource -> Maybe (Either VarError (VarValue, VarSource))
    lookupConfig name ty configMap source =
      case Map.lookup name configMap of
        Nothing -> Nothing
        Just rawText ->
          Just $ case coerceValue name ty rawText of
            Left err -> Left err
            Right val -> Right (val, source)

    validateAndWrap :: VarDecl -> (VarValue, VarSource) -> Either VarError (VarName, ResolvedVar)
    validateAndWrap decl (val, source) =
      case validateVarValueFrom source decl val of
        Left err -> Left err
        Right () ->
          Right
            ( decl ^. #name,
              ResolvedVar
                { value = val,
                  source = source,
                  decl = decl
                }
            )

-- | Partition a list of Either into errors and successes.
partitionResults :: [Either e a] -> ([e], [a])
partitionResults = foldr go ([], [])
  where
    go (Left e) (errs, oks) = (e : errs, oks)
    go (Right a) (errs, oks) = (errs, a : oks)

-- | Format a human-readable provenance report for @--explain@ output.
-- Uses bracket notation for sources and column-aligned output with 2-space indent.
formatExplain :: Map VarName ResolvedVar -> Text
formatExplain resolved =
  T.unlines (map formatOne entries)
  where
    entries = Map.toAscList resolved

    -- Calculate column widths for alignment
    maxNameLen = maximum (0 : map (\(VarName n, _) -> T.length n) entries)
    maxValueLen = maximum (0 : map (\(_, rv) -> T.length (showValue (rv ^. #value))) entries)

    formatOne :: (VarName, ResolvedVar) -> Text
    formatOne (VarName n, rv) =
      let valText = showValue (rv ^. #value)
          namePad = T.replicate (maxNameLen - T.length n) " "
          valPad = T.replicate (maxValueLen - T.length valText) " "
       in "  " <> n <> namePad <> " = " <> valText <> valPad <> "  " <> showSource (rv ^. #source)

    showValue :: VarValue -> Text
    showValue (VText t) = "\"" <> t <> "\""
    showValue (VBool True) = "true"
    showValue (VBool False) = "false"
    showValue (VInt n) = T.pack (show n)
    showValue (VList vs) = "[" <> T.intercalate ", " (map showValue vs) <> "]"

    showSource (FromCommand cmd) = "[command: " <> cmd <> "]"
    showSource source = "[" <> formatVarSource source <> "]"

-- | Shared human-readable source vocabulary for diagnostics and --explain.
formatVarSource :: VarSource -> Text
formatVarSource FromCLI = "--var"
formatVarSource FromRecipeBinding = "literal recipe binding"
formatVarSource FromApplication = "application"
formatVarSource (FromEnv envKey) = "env " <> envKey
formatVarSource FromLocalConfig = "local config"
formatVarSource (FromNamespaceConfig ns) = "namespace: " <> ns
formatVarSource (FromContextConfig ctx) = "context: " <> ctx
formatVarSource FromGlobalConfig = "global config"
formatVarSource (FromParent mn) = "parent: " <> mn ^. #unModuleName
formatVarSource FromDefault = "default"
formatVarSource FromPrompt = "prompt"
formatVarSource (FromCommand _) = "command"

-- | Format variable declarations for default mode output.
-- Produces aligned output with @=@ signs and 2-space indent.
formatDeclarations :: [VarDecl] -> Text
formatDeclarations decls =
  T.unlines (map formatOne decls)
  where
    maxNameLen = maximum (0 : map (\d -> T.length (d ^. #name . #unVarName)) decls)

    formatOne :: VarDecl -> Text
    formatOne d =
      let VarName n = (d ^. #name)
          namePad = T.replicate (maxNameLen - T.length n) " "
          valText = case d ^. #default_ of
            Nothing
              | d ^. #required -> "(required, no default)"
              | otherwise -> "(optional, no default)"
            Just v -> showDeclValue v
       in "  " <> n <> namePad <> " = " <> valText

    showDeclValue :: VarValue -> Text
    showDeclValue (VText t) = "\"" <> t <> "\""
    showDeclValue (VBool True) = "true"
    showDeclValue (VBool False) = "false"
    showDeclValue (VInt n) = T.pack (show n)
    showDeclValue (VList vs) = "[" <> T.intercalate ", " (map showDeclValue vs) <> "]"

-- | Diagnose mismatches between config values and variable declarations.
--
-- Returns two lists:
-- 1. Unused config keys: keys present in any config layer that don't match
--    any declared variable name across the composition.
-- 2. Unresolved optional variables: declared non-required variables that
--    have no resolved value.
diagnoseResolution ::
  Map VarName ResolvedVar ->
  [VarDecl] ->
  Map VarName Text ->
  Map VarName Text ->
  Map VarName Text ->
  Map VarName Text ->
  ([VarName], [VarName])
diagnoseResolution resolved decls localConfig nsConfig ctxConfig globalConfig =
  (unusedConfigKeys, unresolvedOptional)
  where
    declaredNames = Set.fromList (map (^. #name) decls)
    allConfigKeys =
      Set.fromList $
        Map.keys localConfig ++ Map.keys nsConfig ++ Map.keys ctxConfig ++ Map.keys globalConfig
    unusedConfigKeys =
      Set.toAscList (allConfigKeys `Set.difference` declaredNames)
    unresolvedOptional =
      [ d ^. #name
      | d <- decls,
        not (d ^. #required),
        not (Map.member (d ^. #name) resolved)
      ]