Blueprint.hs

module Seihou.Core.Blueprint
  ( validateBlueprint,
    validateBlueprintWith,
    checkBlueprintNameFormat,
    checkBlueprintVersionPresent,
    checkBlueprintPromptNonEmpty,
    checkBlueprintUniqueVars,
    checkBlueprintPromptRefs,
    checkBlueprintBaseModules,
    checkBlueprintBaseModulesWith,
    checkBlueprintFiles,
    checkBlueprintTags,
    checkBlueprintAllowedTools,
    checkBlueprintMigrations,
    checkBlueprintLaunch,
  )
where

import Data.Generics.Labels ()
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Seihou.Core.Migration (BlueprintMigration (..))
import Seihou.Core.Module (defaultSearchPaths, discoverRunnable, isValidModuleName)
import Seihou.Core.Types
import Seihou.Core.Version (parseVersion)
import Seihou.Prelude
import System.Directory (doesFileExist)

-- | Validate a decoded 'Blueprint' against the documented rules.
-- The 'FilePath' is the blueprint's base directory (containing
-- @blueprint.dhall@).
--
-- Validation rules:
--
--   1. Name format: matches @[a-z][a-z0-9-]*@.
--   2. Version, when given, is non-empty (blueprints may legitimately
--      omit a version during early authoring; we only reject @Just ""@).
--   3. Prompt body is non-empty after trimming.
--   4. Variable names declared in @vars@ are unique.
--   5. Every interactive prompt references a declared variable.
--   6. Each @baseModules@ entry is well-formed (name format and var
--      binding names) and resolves to a module or recipe — not another
--      blueprint and not nothing.
--   7. Every @files@ entry exists at @baseDir/files/SRC@.
--   8. Every tag is non-empty.
--   9. Every @allowedTools@ entry, when set, is non-empty.
--  10. Every migration is a forward dotted-numeric edge with a non-empty
--      prompt, and each starting version occurs at most once.
--  11. Every field the @launch@ record does set is non-blank. The values
--      themselves are parsed by the CLI, which owns the provider and effort
--      vocabularies.
validateBlueprint :: FilePath -> Blueprint -> IO (Either ModuleLoadError Blueprint)
validateBlueprint baseDir b = do
  searchPaths <- defaultSearchPaths
  validateBlueprintWith searchPaths baseDir b

-- | Same as 'validateBlueprint' but takes the search paths used for
-- resolving base-module references explicitly. Useful for tests that
-- need to pin the lookup roots; production code should call
-- 'validateBlueprint' which pulls them from 'defaultSearchPaths'.
validateBlueprintWith ::
  [FilePath] ->
  FilePath ->
  Blueprint ->
  IO (Either ModuleLoadError Blueprint)
validateBlueprintWith searchPaths baseDir b = do
  fileErrs <- checkBlueprintFiles baseDir b
  baseErrs <- checkBlueprintBaseModulesWith searchPaths b
  let pureErrs =
        checkBlueprintNameFormat b
          <> checkBlueprintVersionPresent b
          <> checkBlueprintPromptNonEmpty b
          <> checkBlueprintUniqueVars b
          <> checkBlueprintPromptRefs b
          <> checkBlueprintTags b
          <> checkBlueprintAllowedTools b
          <> checkBlueprintMigrations b
          <> checkBlueprintLaunch b
      allErrs = pureErrs <> fileErrs <> baseErrs
  pure $
    if null allErrs
      then Right b
      else Left (ValidationError (b ^. #name) allErrs)

-- Rule 1: blueprint name must match [a-z][a-z0-9-]*
checkBlueprintNameFormat :: Blueprint -> [Text]
checkBlueprintNameFormat b =
  let n = (b ^. #name . #unModuleName)
   in if T.null n || not (isValidModuleName n)
        then ["blueprint name must match [a-z][a-z0-9-]*, got: " <> n]
        else []

-- Rule 2: if a version is given it must not be empty
checkBlueprintVersionPresent :: Blueprint -> [Text]
checkBlueprintVersionPresent b = case b ^. #version of
  Nothing -> []
  Just v
    | T.null (T.strip v) -> ["blueprint version, if specified, must not be empty"]
    | otherwise -> []

-- Rule 3: prompt body must not be empty after trimming
checkBlueprintPromptNonEmpty :: Blueprint -> [Text]
checkBlueprintPromptNonEmpty b
  | T.null (T.strip (b ^. #prompt)) = ["blueprint prompt must not be empty"]
  | otherwise = []

-- Rule 4: declared variable names must be unique
checkBlueprintUniqueVars :: Blueprint -> [Text]
checkBlueprintUniqueVars b =
  let names = map (\d -> d ^. #name . #unVarName) (b ^. #vars)
   in map (\n -> "duplicate variable name: " <> n) (findDupes Set.empty Set.empty names)

findDupes :: Set.Set Text -> Set.Set Text -> [Text] -> [Text]
findDupes _ _ [] = []
findDupes seen reported (x : xs)
  | Set.member x seen && not (Set.member x reported) = x : findDupes seen (Set.insert x reported) xs
  | otherwise = findDupes (Set.insert x seen) reported xs

-- Rule 5: every prompt references a declared variable
checkBlueprintPromptRefs :: Blueprint -> [Text]
checkBlueprintPromptRefs b =
  let varNames = Set.fromList (map (^. #name) (b ^. #vars))
   in concatMap
        ( \p ->
            if Set.member (p ^. #var) varNames
              then []
              else ["prompt references undeclared variable: " <> p ^. #var . #unVarName]
        )
        (b ^. #prompts)

-- Rule 6: base modules must be well-formed and resolve to a module or
-- recipe (not another blueprint). The check uses the same default
-- search paths as @seihou run@; tests can pass custom roots via
-- 'checkBlueprintBaseModulesWith'.
checkBlueprintBaseModules :: Blueprint -> IO [Text]
checkBlueprintBaseModules b = do
  searchPaths <- defaultSearchPaths
  checkBlueprintBaseModulesWith searchPaths b

checkBlueprintBaseModulesWith :: [FilePath] -> Blueprint -> IO [Text]
checkBlueprintBaseModulesWith searchPaths b =
  concat <$> mapM (checkOne searchPaths) (b ^. #baseModules)
  where
    checkOne :: [FilePath] -> Dependency -> IO [Text]
    checkOne paths dep = do
      let n = (dep ^. #module_ . #unModuleName)
          nameErrs =
            [ "invalid baseModule name: " <> n
            | not (isValidModuleName n)
            ]
          bindingErrs =
            [ "baseModule '" <> n <> "' has invalid var binding name: " <> vn
            | (VarName vn) <- Map.keys (dep ^. #vars),
              not (isValidVarBindingName vn)
            ]
      resolveErrs <-
        if not (isValidModuleName n)
          then pure []
          else do
            result <- discoverRunnable paths (dep ^. #module_)
            pure $ case result of
              Right (RunnableModule _ _) -> []
              Right (RunnableRecipe _ _) -> []
              Right (RunnableBlueprint _ _) ->
                [ "baseModule '"
                    <> n
                    <> "' resolves to a blueprint; baseModules must be modules or recipes"
                ]
              Left (ModuleNotFound _ _) ->
                ["baseModule '" <> n <> "' not found in any search path"]
              Left _ ->
                ["baseModule '" <> n <> "' failed to load"]
      pure (nameErrs <> bindingErrs <> resolveErrs)

    isValidVarBindingName :: Text -> Bool
    isValidVarBindingName 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 == '-' || ch == '.')
            rest

-- Rule 7: every @files@ entry's source must exist on disk relative to
-- @baseDir/files/@
checkBlueprintFiles :: FilePath -> Blueprint -> IO [Text]
checkBlueprintFiles baseDir b =
  concat
    <$> mapM
      ( \bf -> do
          let p = baseDir </> "files" </> (bf ^. #src)
          exists <- doesFileExist p
          pure $
            if exists
              then []
              else ["blueprint file not found: " <> T.pack (bf ^. #src)]
      )
      (b ^. #files)

-- Rule 8: tags must not be empty strings
checkBlueprintTags :: Blueprint -> [Text]
checkBlueprintTags b =
  [ "tag must not be empty"
  | t <- b ^. #tags,
    T.null (T.strip t)
  ]

-- Rule 9: @allowedTools@, when set, must contain only non-empty entries
checkBlueprintAllowedTools :: Blueprint -> [Text]
checkBlueprintAllowedTools b = case b ^. #allowedTools of
  Nothing -> []
  Just xs ->
    [ "allowedTools entry must not be empty"
    | t <- xs,
      T.null (T.strip t)
    ]

-- Rule 10: every migration is a forward dotted-numeric version edge with a
-- non-empty prompt, and each starting version occurs at most once.
checkBlueprintMigrations :: Blueprint -> [Text]
checkBlueprintMigrations b =
  concatMap checkOne (b ^. #migrations) <> duplicateErrors
  where
    checkOne :: BlueprintMigration -> [Text]
    checkOne migration =
      promptErrors migration
        <> versionErrors "from" (migration ^. #from)
        <> versionErrors "to" (migration ^. #to)
        <> orderErrors migration

    promptErrors :: BlueprintMigration -> [Text]
    promptErrors migration =
      [ "blueprint migration "
          <> migration ^. #from
          <> " -> "
          <> migration ^. #to
          <> " prompt must not be empty"
      | T.null (T.strip (migration ^. #prompt))
      ]

    versionErrors label versionText = case parseVersion versionText of
      Nothing -> ["blueprint migration " <> label <> " version is not dotted numeric: " <> versionText]
      Just _ -> []

    orderErrors :: BlueprintMigration -> [Text]
    orderErrors migration = case (parseVersion (migration ^. #from), parseVersion (migration ^. #to)) of
      (Just fromVersion, Just toVersion)
        | fromVersion >= toVersion ->
            [ "blueprint migration must advance versions: "
                <> migration ^. #from
                <> " -> "
                <> migration ^. #to
            ]
      _ -> []

    duplicateErrors =
      map
        ("duplicate blueprint migration from version: " <>)
        (findDupes Set.empty Set.empty (map (^. #from) (b ^. #migrations)))

-- Rule 11: every field the @launch@ record does set must be non-blank. The
-- declared values themselves (which provider, which effort) are parsed by the
-- CLI layer, which owns those vocabularies; core only rejects blanks.
checkBlueprintLaunch :: Blueprint -> [Text]
checkBlueprintLaunch b = case b ^. #launch of
  Nothing -> []
  Just l ->
    blankErr "provider" (l ^. #provider)
      <> blankErr "model" (l ^. #model)
      <> blankErr "effort" (l ^. #effort)
      <> blankErr "mode" (l ^. #mode)
  where
    blankErr key value =
      [ "launch." <> key <> ", if specified, must not be empty"
      | Just v <- [value],
        T.null (T.strip v)
      ]