Registry.hs

module Seihou.Core.Registry
  ( Registry (..),
    RegistryEntry (..),
    RepoContents (..),
    discoverRepoContents,
    validateRegistry,
    renderRegistryDhall,
    EntryKind (..),
    SyncStatus (..),
    SyncDiff (..),
    SyncReport (..),
    computeRegistrySync,
    formatDriftWarning,
    RegistryValidationIssue (..),
    RegistryValidationReport (..),
    reportHasIssues,
    validateRegistryFull,
    formatValidationIssue,
  )
where

import Data.Generics.Labels ()
import Data.Text qualified as T
import Seihou.Core.Types (ModuleLoadError, ModuleName (..))
import Seihou.Prelude
import System.Directory (doesFileExist)

-- | A single module listing within a registry.
data RegistryEntry = RegistryEntry
  { name :: !ModuleName,
    version :: !(Maybe Text),
    path :: !FilePath,
    description :: !(Maybe Text),
    tags :: ![Text]
  }
  deriving stock (Eq, Show, Generic)

-- | Registry metadata for a multi-module repository.
-- Declared in @seihou-registry.dhall@ at the repo root.
data Registry = Registry
  { repoName :: !Text,
    repoDescription :: !(Maybe Text),
    modules :: ![RegistryEntry],
    recipes :: ![RegistryEntry],
    blueprints :: ![RegistryEntry],
    prompts :: ![RegistryEntry]
  }
  deriving stock (Eq, Show, Generic)

-- | What a cloned repository contains.
data RepoContents
  = -- | Repo root has @module.dhall@ (single module)
    SingleModule FilePath
  | -- | Repo root has @recipe.dhall@ (single recipe)
    SingleRecipe FilePath
  | -- | Repo root has @blueprint.dhall@ (single blueprint)
    SingleBlueprint FilePath
  | -- | Repo root has @prompt.dhall@ (single prompt)
    SinglePrompt FilePath
  | -- | Repo root has @seihou-registry.dhall@
    MultiModule Registry
  | -- | Neither found
    EmptyRepo
  deriving stock (Show)

-- | Examine a cloned repo root and determine what it contains.
-- The first argument is a function that evaluates a registry Dhall file,
-- injected to avoid a circular module dependency with @Seihou.Dhall.Eval@.
discoverRepoContents ::
  (FilePath -> IO (Either ModuleLoadError Registry)) ->
  FilePath ->
  IO RepoContents
discoverRepoContents evalRegistry repoRoot = do
  let registryFile = repoRoot </> "seihou-registry.dhall"
  hasRegistry <- doesFileExist registryFile
  if hasRegistry
    then do
      result <- evalRegistry registryFile
      case result of
        Right reg -> pure (MultiModule reg)
        Left _ -> probeSingleArtifact repoRoot
    else probeSingleArtifact repoRoot

-- | Probe for a single-artifact repo at @repoRoot@. Precedence:
-- @module.dhall@ → @recipe.dhall@ → @blueprint.dhall@ → @prompt.dhall@ → 'EmptyRepo'.
-- A stray @module.dhall@ next to a @blueprint.dhall@ resolves as the
-- module: the more specific, deterministic artifact wins.
probeSingleArtifact :: FilePath -> IO RepoContents
probeSingleArtifact repoRoot = do
  let moduleFile = repoRoot </> "module.dhall"
      recipeFile = repoRoot </> "recipe.dhall"
      blueprintFile = repoRoot </> "blueprint.dhall"
      promptFile = repoRoot </> "prompt.dhall"
  hasModule <- doesFileExist moduleFile
  if hasModule
    then pure (SingleModule repoRoot)
    else do
      hasRecipe <- doesFileExist recipeFile
      if hasRecipe
        then pure (SingleRecipe repoRoot)
        else do
          hasBlueprint <- doesFileExist blueprintFile
          if hasBlueprint
            then pure (SingleBlueprint repoRoot)
            else do
              hasPrompt <- doesFileExist promptFile
              if hasPrompt
                then pure (SinglePrompt repoRoot)
                else pure EmptyRepo

-- | Validate a registry's entries against the filesystem.
-- Returns a list of error messages (empty means valid).
-- Checks: module name format, path safety, entry file existence,
-- and no name collisions between modules, recipes, blueprints, and prompts.
validateRegistry :: FilePath -> Registry -> IO [Text]
validateRegistry repoRoot reg = do
  modErrs <- concat <$> mapM (validateModuleEntry repoRoot) (reg ^. #modules)
  recErrs <- concat <$> mapM (validateRecipeEntry repoRoot) (reg ^. #recipes)
  bpErrs <- concat <$> mapM (validateBlueprintEntry repoRoot) (reg ^. #blueprints)
  promptErrs <- concat <$> mapM (validatePromptEntry repoRoot) (reg ^. #prompts)
  let collisionErrs = checkNameCollisions (reg ^. #modules) (reg ^. #recipes) (reg ^. #blueprints) (reg ^. #prompts)
  pure (modErrs <> recErrs <> bpErrs <> promptErrs <> collisionErrs)

validateModuleEntry :: FilePath -> RegistryEntry -> IO [Text]
validateModuleEntry repoRoot entry = do
  let nameText = (entry ^. #name . #unModuleName)
      nameErrors = checkName nameText
      pathText = T.pack (entry ^. #path)
      pathErrors = checkPath pathText
  let moduleDhall = repoRoot </> entry ^. #path </> "module.dhall"
  fileExists <- doesFileExist moduleDhall
  let fileErrors =
        if fileExists
          then []
          else ["registry entry '" <> nameText <> "' points to missing module.dhall at " <> pathText]
  pure (nameErrors <> pathErrors <> fileErrors)
  where
    checkName name
      | validModuleName name = []
      | otherwise = ["registry entry name must match [a-z][a-z0-9-]*, got: " <> name]

    checkPath path
      | T.isPrefixOf "/" path = ["registry entry path must be relative: " <> path]
      | ".." `T.isInfixOf` path = ["registry entry path must not contain '..': " <> path]
      | otherwise = []

validateRecipeEntry :: FilePath -> RegistryEntry -> IO [Text]
validateRecipeEntry repoRoot entry = do
  let nameText = (entry ^. #name . #unModuleName)
      nameErrors = checkRecipeName nameText
      pathText = T.pack (entry ^. #path)
      pathErrors = checkRecipePath pathText
  let recipeDhall = repoRoot </> entry ^. #path </> "recipe.dhall"
  fileExists <- doesFileExist recipeDhall
  let fileErrors =
        if fileExists
          then []
          else ["registry recipe entry '" <> nameText <> "' points to missing recipe.dhall at " <> pathText]
  pure (nameErrors <> pathErrors <> fileErrors)
  where
    checkRecipeName name
      | validModuleName name = []
      | otherwise = ["registry recipe name must match [a-z][a-z0-9-]*, got: " <> name]

    checkRecipePath path
      | T.isPrefixOf "/" path = ["registry recipe path must be relative: " <> path]
      | ".." `T.isInfixOf` path = ["registry recipe path must not contain '..': " <> path]
      | otherwise = []

validateBlueprintEntry :: FilePath -> RegistryEntry -> IO [Text]
validateBlueprintEntry repoRoot entry = do
  let nameText = (entry ^. #name . #unModuleName)
      nameErrors = checkBlueprintName nameText
      pathText = T.pack (entry ^. #path)
      pathErrors = checkBlueprintPath pathText
  let blueprintDhall = repoRoot </> entry ^. #path </> "blueprint.dhall"
  fileExists <- doesFileExist blueprintDhall
  let fileErrors =
        if fileExists
          then []
          else ["registry blueprint entry '" <> nameText <> "' points to missing blueprint.dhall at " <> pathText]
  pure (nameErrors <> pathErrors <> fileErrors)
  where
    checkBlueprintName name
      | validModuleName name = []
      | otherwise = ["registry blueprint name must match [a-z][a-z0-9-]*, got: " <> name]

    checkBlueprintPath path
      | T.isPrefixOf "/" path = ["registry blueprint path must be relative: " <> path]
      | ".." `T.isInfixOf` path = ["registry blueprint path must not contain '..': " <> path]
      | otherwise = []

validatePromptEntry :: FilePath -> RegistryEntry -> IO [Text]
validatePromptEntry repoRoot entry = do
  let nameText = (entry ^. #name . #unModuleName)
      nameErrors = checkPromptName nameText
      pathText = T.pack (entry ^. #path)
      pathErrors = checkPromptPath pathText
  let promptDhall = repoRoot </> entry ^. #path </> "prompt.dhall"
  fileExists <- doesFileExist promptDhall
  let fileErrors =
        if fileExists
          then []
          else ["registry prompt entry '" <> nameText <> "' points to missing prompt.dhall at " <> pathText]
  pure (nameErrors <> pathErrors <> fileErrors)
  where
    checkPromptName name
      | validModuleName name = []
      | otherwise = ["registry prompt name must match [a-z][a-z0-9-]*, got: " <> name]

    checkPromptPath path
      | T.isPrefixOf "/" path = ["registry prompt path must be relative: " <> path]
      | ".." `T.isInfixOf` path = ["registry prompt path must not contain '..': " <> path]
      | otherwise = []

-- | Detect name collisions across module, recipe, blueprint, and prompt entries.
-- Each cross-kind pair sharing a name produces one message; a name that
-- appears in all four kinds produces six messages (one per pair).
checkNameCollisions :: [RegistryEntry] -> [RegistryEntry] -> [RegistryEntry] -> [RegistryEntry] -> [Text]
checkNameCollisions mods recs bps prompts =
  let modNames = map (\e -> e ^. #name . #unModuleName) mods
      recNames = map (\e -> e ^. #name . #unModuleName) recs
      bpNames = map (\e -> e ^. #name . #unModuleName) bps
      promptNames = map (\e -> e ^. #name . #unModuleName) prompts
      modRec = [n | n <- modNames, n `elem` recNames]
      modBp = [n | n <- modNames, n `elem` bpNames]
      modPrompt = [n | n <- modNames, n `elem` promptNames]
      recBp = [n | n <- recNames, n `elem` bpNames]
      recPrompt = [n | n <- recNames, n `elem` promptNames]
      bpPrompt = [n | n <- bpNames, n `elem` promptNames]
   in map (\n -> "name collision: '" <> n <> "' appears as both a module and a recipe") modRec
        <> map (\n -> "name collision: '" <> n <> "' appears as both a module and a blueprint") modBp
        <> map (\n -> "name collision: '" <> n <> "' appears as both a module and a prompt") modPrompt
        <> map (\n -> "name collision: '" <> n <> "' appears as both a recipe and a blueprint") recBp
        <> map (\n -> "name collision: '" <> n <> "' appears as both a recipe and a prompt") recPrompt
        <> map (\n -> "name collision: '" <> n <> "' appears as both a blueprint and a prompt") bpPrompt

-- | Check that a text matches @[a-z][a-z0-9-]*@.
-- Duplicated from @Seihou.Core.Module.isValidModuleName@ to avoid
-- a circular module dependency through @Seihou.Dhall.Eval@.
validModuleName :: Text -> Bool
validModuleName t = case T.uncons t of
  Nothing -> False
  Just (c, rest) ->
    (c >= 'a' && c <= 'z')
      && T.all (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-') rest

-- | What a registry entry points at on disk.
data EntryKind = ModuleEntry | RecipeEntry | BlueprintEntry | PromptEntry
  deriving stock (Eq, Show, Generic)

-- | Classification of a single registry entry relative to the on-disk
-- @module.dhall@/@recipe.dhall@ version.
data SyncStatus
  = -- | Registry @version@ is 'Nothing', on-disk version is @Just _@.
    SyncMissing
  | -- | Registry @version@ and on-disk version both @Just@ but differ;
    --   carries the new on-disk version.
    SyncStale Text
  | -- | Registry and on-disk versions match (both 'Just' equal or both 'Nothing').
    SyncInSync
  | -- | On-disk @module.dhall@/@recipe.dhall@ absent or unreadable.
    SyncOrphan
  deriving stock (Eq, Show, Generic)

-- | One row of a sync diff, preserving registry order.
data SyncDiff = SyncDiff
  { kind :: !EntryKind,
    name :: !ModuleName,
    old :: !(Maybe Text),
    new :: !(Maybe Text),
    status :: !SyncStatus
  }
  deriving stock (Eq, Show, Generic)

-- | Output of 'computeRegistrySync': the classifications in registry order,
-- and a 'Registry' with each entry's @version@ field updated to the on-disk
-- value (except 'SyncOrphan' entries, which are preserved as-is).
data SyncReport = SyncReport
  { diffs :: ![SyncDiff],
    updated :: !Registry
  }
  deriving stock (Eq, Show, Generic)

-- | Pure core of the version-sync flow. The caller resolves each entry's
-- on-disk version ('Just v', or 'Nothing' for orphaned/unreadable entries)
-- and passes them in; this function classifies and rewrites the registry
-- without performing any IO.
--
-- The lookup list is keyed by @(kind, name)@; entries absent from the list
-- are classified as 'SyncOrphan'.
computeRegistrySync ::
  Registry ->
  [(EntryKind, ModuleName, Maybe Text)] ->
  SyncReport
computeRegistrySync reg lookups =
  SyncReport
    { diffs = moduleDiffs <> recipeDiffs <> blueprintDiffs <> promptDiffs,
      updated =
        reg
          & #modules
          %~ zipWith applyDiff moduleDiffs
          & #recipes
          %~ zipWith applyDiff recipeDiffs
          & #blueprints
          %~ zipWith applyDiff blueprintDiffs
          & #prompts
          %~ zipWith applyDiff promptDiffs
    }
  where
    moduleDiffs = map (classify ModuleEntry) (reg ^. #modules)
    recipeDiffs = map (classify RecipeEntry) (reg ^. #recipes)
    blueprintDiffs = map (classify BlueprintEntry) (reg ^. #blueprints)
    promptDiffs = map (classify PromptEntry) (reg ^. #prompts)

    classify :: EntryKind -> RegistryEntry -> SyncDiff
    classify kind entry =
      let onDisk = lookupOnDisk kind (entry ^. #name)
          status = case (entry ^. #version, onDisk) of
            (_, OnDiskMissing) -> SyncOrphan
            (Nothing, OnDiskValue Nothing) -> SyncInSync
            (Nothing, OnDiskValue (Just _)) -> SyncMissing
            (Just _, OnDiskValue Nothing) -> SyncInSync
            (Just old, OnDiskValue (Just new))
              | old == new -> SyncInSync
              | otherwise -> SyncStale new
          newVersion = case onDisk of
            OnDiskMissing -> (entry ^. #version)
            OnDiskValue v -> v
       in SyncDiff
            { kind = kind,
              name = entry ^. #name,
              old = entry ^. #version,
              new = newVersion,
              status = status
            }

    applyDiff :: SyncDiff -> RegistryEntry -> RegistryEntry
    applyDiff diff entry = case diff ^. #status of
      SyncOrphan -> entry
      _ -> entry & #version .~ diff ^. #new

    lookupOnDisk :: EntryKind -> ModuleName -> OnDiskVersion
    lookupOnDisk kind name =
      case [v | (k, n, v) <- lookups, k == kind, n == name] of
        [] -> OnDiskMissing
        (v : _) -> OnDiskValue v

-- | Three-way state used internally by 'computeRegistrySync' to distinguish
-- \"entry absent from the lookup list\" (orphan) from \"entry present, version
-- field is @Nothing@\" (in-sync with an unversioned module.dhall).
data OnDiskVersion = OnDiskMissing | OnDiskValue (Maybe Text)

-- | Format a single 'SyncDiff' as a human-readable drift warning, or
-- 'Nothing' if the entry is already in sync. Used by @seihou browse@ and
-- @seihou install@ to surface stale registry versions without blocking.
formatDriftWarning :: SyncDiff -> Maybe Text
formatDriftWarning diff = case diff ^. #status of
  SyncInSync -> Nothing
  SyncOrphan -> Nothing
  SyncMissing ->
    Just $
      kindWord (diff ^. #kind)
        <> " '"
        <> diff ^. #name . #unModuleName
        <> "' registry version is missing; "
        <> entryFile (diff ^. #kind)
        <> " declares "
        <> renderVersion (diff ^. #new)
        <> " — run `seihou registry sync-versions`"
  SyncStale newVer ->
    Just $
      kindWord (diff ^. #kind)
        <> " '"
        <> diff ^. #name . #unModuleName
        <> "' registry version "
        <> renderVersion (diff ^. #old)
        <> " differs from "
        <> entryFile (diff ^. #kind)
        <> " version "
        <> newVer
        <> " — run `seihou registry sync-versions`"
  where
    renderVersion Nothing = "(none)"
    renderVersion (Just v) = v
    kindWord ModuleEntry = "module"
    kindWord RecipeEntry = "recipe"
    kindWord BlueprintEntry = "blueprint"
    kindWord PromptEntry = "prompt"
    entryFile ModuleEntry = "module.dhall"
    entryFile RecipeEntry = "recipe.dhall"
    entryFile BlueprintEntry = "blueprint.dhall"
    entryFile PromptEntry = "prompt.dhall"

-- | One row of the unified validation report. Either reuses an existing
-- structural error message (path/name/file-existence/collisions) or
-- carries a version-mismatch row classified by 'SyncStatus'.
data RegistryValidationIssue
  = StructuralError Text
  | VersionMismatch SyncDiff
  deriving stock (Eq, Show, Generic)

-- | Whole-registry validation outcome, carrying every issue plus the
-- entry counts used by the human-readable summary line.
data RegistryValidationReport = RegistryValidationReport
  { issues :: ![RegistryValidationIssue],
    moduleCount :: !Int,
    recipeCount :: !Int,
    blueprintCount :: !Int,
    promptCount :: !Int
  }
  deriving stock (Eq, Show, Generic)

-- | True iff the report has at least one issue.
reportHasIssues :: RegistryValidationReport -> Bool
reportHasIssues r = not (null (r ^. #issues))

-- | Combine the existing structural checks with version classification.
-- The third argument is the same shape 'computeRegistrySync' takes —
-- the caller loads each entry's @module.dhall@/@recipe.dhall@ once and
-- passes a lookup list keyed by @(kind, name)@.
validateRegistryFull ::
  FilePath ->
  Registry ->
  [(EntryKind, ModuleName, Maybe Text)] ->
  IO RegistryValidationReport
validateRegistryFull repoRoot reg lookups = do
  structuralErrs <- validateRegistry repoRoot reg
  let report = computeRegistrySync reg lookups
      versionIssues =
        [ VersionMismatch d
        | d <- report ^. #diffs,
          isVersionDrift (d ^. #status)
        ]
  pure
    RegistryValidationReport
      { issues = map StructuralError structuralErrs <> versionIssues,
        moduleCount = length (reg ^. #modules),
        recipeCount = length (reg ^. #recipes),
        blueprintCount = length (reg ^. #blueprints),
        promptCount = length (reg ^. #prompts)
      }
  where
    isVersionDrift SyncMissing = True
    isVersionDrift (SyncStale _) = True
    isVersionDrift _ = False

-- | Render a single 'RegistryValidationIssue' as a one-line human-readable
-- string. 'VersionMismatch' rows reuse the @modules.foo@/@recipes.bar@
-- prefix used by @sync-versions@ but omit the trailing
-- "run @seihou registry sync-versions@" suggestion — the validate handler
-- prints a single aggregated suggestion at the bottom.
formatValidationIssue :: RegistryValidationIssue -> Text
formatValidationIssue (StructuralError msg) = msg
formatValidationIssue (VersionMismatch diff) =
  validationKindPrefix (diff ^. #kind)
    <> diff ^. #name . #unModuleName
    <> ": registry version "
    <> validationRenderVersion (diff ^. #old)
    <> " does not match "
    <> entryFile (diff ^. #kind)
    <> " version "
    <> validationRenderVersion (diff ^. #new)
  where
    entryFile ModuleEntry = "module.dhall"
    entryFile RecipeEntry = "recipe.dhall"
    entryFile BlueprintEntry = "blueprint.dhall"
    entryFile PromptEntry = "prompt.dhall"

validationKindPrefix :: EntryKind -> Text
validationKindPrefix ModuleEntry = "modules."
validationKindPrefix RecipeEntry = "recipes."
validationKindPrefix BlueprintEntry = "blueprints."
validationKindPrefix PromptEntry = "prompts."

validationRenderVersion :: Maybe Text -> Text
validationRenderVersion Nothing = "(none)"
validationRenderVersion (Just v) = v

-- | Serialize a 'Registry' as a Dhall record literal compatible with
-- 'Seihou.Dhall.Eval.registryDecoder'. Rewrites lose hand-written comments
-- and formatting; see @docs/plans/12-sync-registry-versions.md@ for rationale.
renderRegistryDhall :: Registry -> Text
renderRegistryDhall reg =
  T.unlines
    [ "{ repoName = " <> renderString (reg ^. #repoName),
      ", repoDescription = " <> renderOptionalText (reg ^. #repoDescription),
      ", modules =",
      renderEntryList (reg ^. #modules),
      ", recipes =",
      renderEntryList (reg ^. #recipes),
      ", blueprints =",
      renderEntryList (reg ^. #blueprints),
      ", prompts =",
      renderEntryList (reg ^. #prompts),
      "}"
    ]

renderEntryList :: [RegistryEntry] -> Text
renderEntryList [] =
  "  [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }"
renderEntryList entries =
  T.intercalate
    "\n"
    (zipWith renderEntry (True : repeat False) entries <> ["  ]"])

renderEntry :: Bool -> RegistryEntry -> Text
renderEntry isFirst entry =
  T.intercalate
    "\n"
    [ "  " <> opener <> " { name = " <> renderString (entry ^. #name . #unModuleName),
      "    , version = " <> renderOptionalText (entry ^. #version),
      "    , path = " <> renderString (T.pack (entry ^. #path)),
      "    , description = " <> renderOptionalText (entry ^. #description),
      "    , tags = " <> renderTextList (entry ^. #tags),
      "    }"
    ]
  where
    opener = if isFirst then "[" else ","

renderOptionalText :: Maybe Text -> Text
renderOptionalText Nothing = "None Text"
renderOptionalText (Just v) = "Some " <> renderString v

renderTextList :: [Text] -> Text
renderTextList [] = "[] : List Text"
renderTextList xs = "[ " <> T.intercalate ", " (map renderString xs) <> " ]"

-- | Render a Dhall double-quoted string literal.
-- Escapes backslashes, double quotes, dollar signs (for interpolation),
-- and common control characters per the Dhall spec.
renderString :: Text -> Text
renderString t = "\"" <> T.concatMap escape t <> "\""
  where
    escape '\\' = "\\\\"
    escape '"' = "\\\""
    escape '$' = "\\$"
    escape '\n' = "\\n"
    escape '\r' = "\\r"
    escape '\t' = "\\t"
    escape c = T.singleton c