ConformanceBaseline.hs

module Keiro.Dsl.ConformanceBaseline (conformanceBaselineSpec) where

import Control.Monad (filterM, forM, forM_, unless)
import Data.Aeson (FromJSON (..), withObject, (.:), (.:?))
import Data.Aeson qualified as Aeson
import Data.List (isSuffixOf, nub, sort, (\\))
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Keiro.Dsl.FrontendCompatibility (SourceExpectation (..), observeSource, readRepoText)
import Keiro.Dsl.Grammar (Spec (..))
import Keiro.Dsl.LanguageVersion
  ( LanguageDefinition (..),
    LanguageMaturity (..),
    LanguageSupport (..),
    currentAuthoringLanguageVersion,
    currentStableLanguageVersion,
    languageVersion,
    languageVersionNumber,
    lookupLanguageDefinition,
  )
import Keiro.Dsl.Parser (parseSource, parseSourceDocument)
import Keiro.Dsl.RuntimePackage (RuntimePackageName (..))
import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), Placement (..), ScaffoldModule (..), defaultContext)
import Keiro.Dsl.ScaffoldRun (planIndexedServiceScaffold, planIndexedServiceScaffoldWithRuntimePackage, scaffoldServiceModules)
import Keiro.Dsl.SemanticContract (CheckedService, checkedSource, checkedSpec)
import Keiro.Dsl.Skeleton (skeletonFor)
import Keiro.Dsl.SourceIndex (ParsedSourceDocument (..), SemanticSourceIndex)
import Keiro.Dsl.Workspace (WorkspaceSpec (..), fileContentSource, loadWorkspace)
import Keiro.Dsl.WorkspaceScaffold (WorkspacePlan (..), planWorkspaceScaffold)
import Numeric.Natural (Natural)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.Environment (lookupEnv)
import System.FilePath (takeDirectory, takeExtension, (</>))
import Test.Hspec

data FixtureException = FixtureException
  { exceptionPath :: !FilePath,
    exceptionSourceForm :: !Text,
    exceptionEffectiveVersion :: !(Maybe Natural),
    exceptionRole :: !Text,
    exceptionReason :: !Text
  }
  deriving stock (Eq, Show)

instance FromJSON FixtureException where
  parseJSON = withObject "FixtureException" $ \fields ->
    FixtureException
      <$> fields .: "path"
      <*> fields .: "sourceForm"
      <*> fields .:? "effectiveVersion"
      <*> fields .: "role"
      <*> fields .: "reason"

data CompiledSuite = CompiledSuite
  { suiteComponent :: !Text,
    suiteDirectory :: !FilePath,
    suiteSource :: !(Maybe FilePath),
    suiteGeneration :: !Text,
    suiteRole :: !Text,
    suiteLanguageVersion :: !(Maybe Natural),
    suiteReason :: !Text
  }
  deriving stock (Eq, Show)

instance FromJSON CompiledSuite where
  parseJSON = withObject "CompiledSuite" $ \fields ->
    CompiledSuite
      <$> fields .: "component"
      <*> fields .: "directory"
      <*> fields .:? "source"
      <*> fields .: "generation"
      <*> fields .: "role"
      <*> fields .:? "languageVersion"
      <*> fields .: "reason"

data ConformanceBaseline = ConformanceBaseline
  { baselineSchema :: !Text,
    baselineStableLanguageVersion :: !Natural,
    baselineAuthoringLanguageVersion :: !Natural,
    baselinePrimaryLanguageVersions :: ![Natural],
    baselineFixtureExceptions :: ![FixtureException],
    baselineCompiledSuites :: ![CompiledSuite]
  }
  deriving stock (Eq, Show)

instance FromJSON ConformanceBaseline where
  parseJSON = withObject "ConformanceBaseline" $ \fields ->
    ConformanceBaseline
      <$> fields .: "schema"
      <*> fields .: "stableLanguageVersion"
      <*> fields .: "authoringLanguageVersion"
      <*> fields .: "primaryLanguageVersions"
      <*> fields .: "fixtureExceptions"
      <*> fields .: "compiledSuites"

conformanceBaselineSpec :: SpecWith ()
conformanceBaselineSpec = describe "conformance baseline" $ do
  it "uses the registered stable and authoring languages plus explicit compatibility rows" $ do
    baseline <- readBaseline
    (.baselineSchema) baseline `shouldBe` "keiro-dsl/conformance-baseline/2"
    (.baselineStableLanguageVersion) baseline
      `shouldBe` languageVersionNumber currentStableLanguageVersion
    (.baselineAuthoringLanguageVersion) baseline
      `shouldBe` languageVersionNumber currentAuthoringLanguageVersion
    paths <- fixturePaths
    observations <- forM paths $ \path -> (path,) <$> observeSource path
    (.baselinePrimaryLanguageVersions) baseline `shouldContain` [languageVersionNumber currentStableLanguageVersion]
    (.baselinePrimaryLanguageVersions) baseline `shouldContain` [languageVersionNumber currentAuthoringLanguageVersion]
    let primaryVersions = (.baselinePrimaryLanguageVersions) baseline
        nonStablePaths =
          sort
            [ path
            | (path, observation) <- observations,
              (.sourceForm) observation /= "declared"
                || maybe True (`notElem` primaryVersions) ((.sourceEffectiveVersion) observation)
            ]
        exceptionPaths = sort (map (.exceptionPath) ((.baselineFixtureExceptions) baseline))
    (nonStablePaths \\ exceptionPaths)
      `shouldBe` ([] :: [FilePath])
    (exceptionPaths \\ nonStablePaths)
      `shouldBe` ([] :: [FilePath])
    forM_ ((.baselineFixtureExceptions) baseline) $ \exception -> do
      observation <- observeSource ((.exceptionPath) exception)
      (.sourceForm) observation `shouldBe` (.exceptionSourceForm) exception
      (.sourceEffectiveVersion) observation `shouldBe` (.exceptionEffectiveVersion) exception
      (.exceptionRole) exception
        `shouldBe` "compatibility-proof"
      (.exceptionReason) exception `shouldSatisfy` (not . T.null . T.strip)

  it "accounts for every compiled conformance component and primary generated banner" $ do
    baseline <- readBaseline
    cabal <- readRepoText "keiro-dsl/keiro-dsl.cabal"
    let cabalComponents = conformanceComponents cabal
        manifestComponents = sort (map (.suiteComponent) ((.baselineCompiledSuites) baseline))
    (cabalComponents \\ manifestComponents)
      `shouldBe` ([] :: [Text])
    (manifestComponents \\ cabalComponents)
      `shouldBe` ([] :: [Text])
    forM_ ((.baselineCompiledSuites) baseline) $ \suite -> do
      (.suiteRole) suite
        `shouldSatisfy` (`elem` ["stable-primary", "published-compatibility", "compatibility-proof", "version-independent"])
      validateSuiteLanguageOwnership baseline suite
      (.suiteReason) suite `shouldSatisfy` (not . T.null . T.strip)
      directory <- resolveRepoDirectory ("keiro-dsl" </> (.suiteDirectory) suite)
      doesDirectoryExist directory `shouldReturn` True
      case (.suiteLanguageVersion) suite of
        Just primaryVersion -> do
          unless ((.suiteGeneration) suite `elem` ["workspace", "skeletons"]) $ do
            source <- requiredSuiteSource suite
            observation <- observeSource source
            (.sourceForm) observation `shouldBe` "declared"
            (.sourceResult) observation `shouldBe` "accept"
            (.sourceEffectiveVersion) observation `shouldBe` Just primaryVersion
          banners <- generatedBannerLines directory
          unless (not (null banners)) $
            expectationFailure (T.unpack ((.suiteComponent) suite <> " has no generated banners"))
          let expectedVersion = "language keiro-dsl " <> T.pack (show primaryVersion)
              primaryBanners = [(path, banner) | (path, banner) <- banners, expectedVersion `T.isInfixOf` banner]
              isVersionIndependentAuxiliary banner = "@generated by keiro-dsl codec comparison" `T.isInfixOf` banner
          unless (not (null primaryBanners)) $
            expectationFailure (T.unpack ((.suiteComponent) suite <> " has no " <> T.pack (show primaryVersion) <> " generated banners"))
          forM_ banners $ \(path, banner) ->
            unless (expectedVersion `T.isInfixOf` banner || isVersionIndependentAuxiliary banner) $
              expectationFailure (T.unpack (decorate path banner <> " (expected " <> expectedVersion <> ")"))
          expectedPaths <- expectedStableGeneratedPaths suite
          let actualPaths = sort (nub (map fst primaryBanners))
              -- Plan 218 refreshes focused compiled fixtures only. The final
              -- corpus-wide regeneration in plan 222 will remove this narrow
              -- inventory normalization after every mapped suite has adopted
              -- its new context module.
              deferredContextModule path =
                "/StructuralConformance.hs" `isSuffixOf` path
                  || "/BehaviorSourceMap.hs" `isSuffixOf` path
              comparedExpectedPaths = filter (not . deferredContextModule) expectedPaths
              comparedActualPaths = filter (not . deferredContextModule) actualPaths
          unless (comparedActualPaths == comparedExpectedPaths) $
            expectationFailure
              ( T.unpack
                  ( (.suiteComponent) suite
                      <> " generated module inventory differs\nexpected: "
                      <> T.pack (show comparedExpectedPaths)
                      <> "\n but got: "
                      <> T.pack (show comparedActualPaths)
                  )
              )
        Nothing -> pure ()

validateSuiteLanguageOwnership :: ConformanceBaseline -> CompiledSuite -> IO ()
validateSuiteLanguageOwnership baseline suite = case ((.suiteRole) suite, (.suiteLanguageVersion) suite) of
  ("stable-primary", Just rawVersion) -> do
    rawVersion `shouldBe` (.baselineStableLanguageVersion) baseline
    definition <- requireRegisteredDefinition suite rawVersion
    (.support) definition `shouldBe` Stable
    (.maturity) definition `shouldBe` PublishedLanguage
  ("published-compatibility", Just rawVersion) -> do
    rawVersion `shouldNotBe` (.baselineStableLanguageVersion) baseline
    definition <- requireRegisteredDefinition suite rawVersion
    (.support) definition `shouldBe` CompatibilityOnly
    (.maturity) definition `shouldBe` PublishedLanguage
  ("compatibility-proof", Nothing) -> pure ()
  ("version-independent", Nothing) -> pure ()
  (role, version) ->
    expectationFailure
      ( T.unpack
          ( (.suiteComponent) suite
              <> " has invalid language ownership for role "
              <> role
              <> ": "
              <> T.pack (show version)
          )
      )

requireRegisteredDefinition :: CompiledSuite -> Natural -> IO LanguageDefinition
requireRegisteredDefinition suite rawVersion =
  case languageVersion rawVersion >>= lookupLanguageDefinition of
    Just definition -> pure definition
    Nothing -> do
      expectationFailure
        ( T.unpack
            ( (.suiteComponent) suite
                <> " owns unregistered language "
                <> T.pack (show rawVersion)
            )
        )
      fail "unregistered conformance language owner"

expectedStableGeneratedPaths :: CompiledSuite -> IO [FilePath]
expectedStableGeneratedPaths suite = case (.suiteGeneration) suite of
  "source" -> do
    source <- requiredSuiteSource suite
    generatedPathsForSource source
  "source-with-conformance-facade" -> do
    source <- requiredSuiteSource suite
    sourceText <- readRepoText source
    (service, sourceIndex) <- parseCheckedDocument source sourceText
    scaffoldModules <- case planIndexedServiceScaffoldWithRuntimePackage (Just (RuntimePackageName "conformance-runtime")) sourceIndex (defaultContext ((checkedSpec service).context)) service of
      Left refusals -> expectationFailure (show refusals) >> fail "stable configured source scaffold refusal"
      Right value -> pure value
    pure (generatedPaths scaffoldModules)
  "workspace" -> do
    source <- requiredSuiteSource suite
    resolved <- resolveRepoFile ("keiro-dsl" </> source)
    loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved
    workspace <- case loaded of
      Left problem -> expectationFailure (show problem) >> fail "invalid stable workspace"
      Right value -> pure value
    plan <- case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of
      Left refusals -> expectationFailure (show refusals) >> fail "stable workspace scaffold refusal"
      Right value -> pure value
    pure (generatedPaths (map fst ((.modules) plan)))
  "skeletons" -> fmap (sort . nub . concat) . forM skeletonModuleRoots $ \(skeletonKind, root) -> do
    source <- case skeletonFor skeletonKind of
      Left problem -> expectationFailure (T.unpack problem) >> fail "invalid stable skeleton"
      Right value -> pure value
    service <- parseCheckedSource ("new:" <> T.unpack skeletonKind) source
    let baseContext = defaultContext (checkedSpec service).context
        scaffoldContext = Context {name = baseContext.name, moduleRoot = root, placement = baseContext.placement}
    pure (generatedPaths (scaffoldServiceModules scaffoldContext service))
  other -> expectationFailure (T.unpack ((.suiteComponent) suite <> " has invalid stable generation mode " <> other)) >> fail "invalid stable generation mode"

generatedPathsForSource :: FilePath -> IO [FilePath]
generatedPathsForSource path = do
  source <- readRepoText path
  (service, sourceIndex) <- parseCheckedDocument path source
  scaffoldModules <- case planIndexedServiceScaffold sourceIndex (defaultContext ((checkedSpec service).context)) service of
    Left refusals -> expectationFailure (show refusals) >> fail "stable source scaffold refusal"
    Right value -> pure value
  pure (generatedPaths scaffoldModules)

parseCheckedSource :: FilePath -> Text -> IO CheckedService
parseCheckedSource path source = case parseSource path source of
  Left problem -> expectationFailure (show problem) >> fail "invalid stable source"
  Right parsed -> pure (checkedSource parsed)

parseCheckedDocument :: FilePath -> Text -> IO (CheckedService, SemanticSourceIndex)
parseCheckedDocument path source = case parseSourceDocument path source of
  Left problem -> expectationFailure (show problem) >> fail "invalid stable source document"
  Right ParsedSourceDocument {parsedSource = parsed, sourceIndex = sourceIndex} ->
    pure (checkedSource parsed, sourceIndex)

generatedPaths :: [ScaffoldModule] -> [FilePath]
generatedPaths = sort . map (.path) . filter ((== Generated) . (.kind))

requiredSuiteSource :: CompiledSuite -> IO FilePath
requiredSuiteSource suite = case (.suiteSource) suite of
  Nothing -> expectationFailure (T.unpack ((.suiteComponent) suite <> " has no source")) >> fail "missing stable source"
  Just source -> pure source

workspaceContext :: WorkspaceSpec -> Context
workspaceContext workspace =
  Context
    { name = workspace.context,
      moduleRoot = maybe "" id ((.moduleRoot) workspace),
      placement = maybe GeneratedPrefix id ((.layout) workspace)
    }

skeletonModuleRoots :: [(Text, Text)]
skeletonModuleRoots =
  [ ("aggregate", "SkelAggregate"),
    ("process", "SkelProcess"),
    ("router", "SkelRouter"),
    ("contract", "SkelContract"),
    ("intake", "SkelIntake"),
    ("emit", "SkelEmit"),
    ("workqueue", "SkelQueue"),
    ("workflow", "SkelWorkflow")
  ]

readBaseline :: IO ConformanceBaseline
readBaseline = do
  path <- resolveRepoFile "keiro-dsl/test/conformance-baseline.json"
  decoded <- Aeson.eitherDecodeFileStrict' path
  case decoded of
    Left problem -> expectationFailure problem >> fail "invalid conformance baseline"
    Right baseline -> pure baseline

fixturePaths :: IO [FilePath]
fixturePaths = do
  root <- resolveRepoDirectory "keiro-dsl/test/fixtures"
  relative <- walk root ""
  pure . sort $ ["test/fixtures" </> path | path <- relative, takeExtension path == ".keiro"]

conformanceComponents :: Text -> [Text]
conformanceComponents =
  sort
    . mapMaybe (listToMaybe . T.words)
    . filter ("keiro-dsl-conformance" `T.isPrefixOf`)
    . mapMaybeTestSuite
    . T.lines
  where
    mapMaybeTestSuite = foldr collect []
    collect line rest = case T.stripPrefix "test-suite " (T.strip line) of
      Just component -> component : rest
      Nothing -> rest

generatedBannerLines :: FilePath -> IO [(FilePath, Text)]
generatedBannerLines root = do
  relative <- walk root ""
  fmap concat . forM [path | path <- relative, takeExtension path == ".hs"] $ \path -> do
    contents <- TIO.readFile (root </> path)
    pure
      [ (path, line)
      | line <- T.lines contents,
        "@generated" `T.isInfixOf` line
      ]

walk :: FilePath -> FilePath -> IO [FilePath]
walk root relative = do
  entries <- sort <$> listDirectory (root </> relative)
  fmap concat . forM entries $ \entry -> do
    let child = if null relative then entry else relative </> entry
    isDirectory <- doesDirectoryExist (root </> child)
    if isDirectory then walk root child else pure [child]

resolveRepoFile :: FilePath -> IO FilePath
resolveRepoFile path = do
  override <- lookupEnv "KEIRO_DSL_TEST_ROOT"
  let packageRelative = maybe path T.unpack (T.stripPrefix "keiro-dsl/" (T.pack path))
      candidates = nub ([packageRelative, path] <> maybe [] (\root -> [root </> packageRelative, root </> path]) override)
  existing <- filterM doesFileExist candidates
  case existing of
    candidate : _ -> pure candidate
    [] -> fail ("unable to locate conformance baseline file " <> show path)

resolveRepoDirectory :: FilePath -> IO FilePath
resolveRepoDirectory path = do
  override <- lookupEnv "KEIRO_DSL_TEST_ROOT"
  let packageRelative = maybe path T.unpack (T.stripPrefix "keiro-dsl/" (T.pack path))
      candidates = nub ([packageRelative, path] <> maybe [] (\root -> [root </> packageRelative, root </> path]) override)
  existing <- filterM doesDirectoryExist candidates
  case existing of
    candidate : _ -> pure candidate
    [] -> fail ("unable to locate conformance directory " <> show path)

decorate :: FilePath -> Text -> Text
decorate path banner = T.pack path <> ": " <> banner