Restore precise verification diagnostics

2 files changed, 51 insertions, 4 deletions

diff --git a/source/Test/Unit/CommandLine.hs b/source/Test/Unit/CommandLine.hs
index 0a49fc4..6d00936 100644
--- a/source/Test/Unit/CommandLine.hs
+++ b/source/Test/Unit/CommandLine.hs
@@ -5,7 +5,9 @@ module Test.Unit.CommandLine (unitTests) where
 import Base
 import Api (VerificationReport(..), VerificationRoute(..))
 import CommandLine
+import Felix.Source (safeRelativePath)
 import Felix.Store qualified as Store
+import Render.Html.Output qualified as HtmlOutput
 import Report.Location (pattern Nowhere)
 
 import Control.Exception (bracket)
@@ -37,6 +39,8 @@ unitTests =
             for_ outcomeCases \(outcome, expectedExitCode) ->
                 commandOutcomeExitCode outcome
                     `shouldBe` expectedExitCode
+        , testCase "reports the committed HTML prefix"
+            reportsCommittedHtmlPrefix
         , testGroup "process boundary"
             [ testCase "version needs no input or store"
                 versionNeedsNoInputOrStore
@@ -206,7 +210,9 @@ malformedSourceHasStableFailure =
                 ["input.tex", "--parseonly"]
         exitCode `shouldBe` ExitFailure 1
         stdout `shouldBe` ""
-        stderr `shouldContain` "Parsing failed."
+        stderr `shouldContain` "Parsing failed: project:input.tex"
+        stderr `shouldContain` "input.tex 2:5"
+        stderr `shouldContain` "unconsumed word"
         assertBool "does not print an internal error constructor"
             (not ("SourceParseError" `List.isInfixOf` stderr))
         assertNoDefaultStore fixture
@@ -222,9 +228,37 @@ invalidOutputPrecedesStoreStartup =
                 ["input.tex", "--dump", "dump"]
         exitCode `shouldBe` ExitFailure 2
         stdout `shouldBe` ""
-        stderr `shouldContain` "Verification output preflight failed."
+        stderr `shouldContain` "Verification output preflight failed:"
+        stderr `shouldContain` (Text.pack (show dump))
+        stderr `shouldContain` "choose an absent or empty directory"
+        stderr `shouldContain` "stale.p"
         assertNoDefaultStore fixture
 
+reportsCommittedHtmlPrefix :: Assertion
+reportsCommittedHtmlPrefix = do
+    first <- checkedRelative "a.html"
+    second <- checkedRelative "nested/b.html"
+    failed <- checkedRelative "nested/c.html"
+    assertEqual
+        "deterministic committed prefix"
+        [ "HTML publication failed at \"nested/c.html\": disk full"
+        , "HTML files published before the failure: \"a.html\", \"nested/b.html\""
+        ]
+        (HtmlOutput.renderHtmlPublicationError
+            (HtmlOutput.IncompleteHtmlPublication
+                [first, second]
+                failed
+                "disk full"))
+  where
+    checkedRelative path =
+        case safeRelativePath path of
+            Left problem ->
+                assertFailure
+                    ("invalid test route " <> show path <> ": " <> show problem)
+                    >> fail "unreachable"
+            Right relative ->
+                pure relative
+
 dumpsExactExecutedRequest :: Assertion
 dumpsExactExecutedRequest =
     withCliFixture cliSource \fixture -> do
diff --git a/source/Test/Unit/Module.hs b/source/Test/Unit/Module.hs
index 7ebc317..1aea2bf 100644
--- a/source/Test/Unit/Module.hs
+++ b/source/Test/Unit/Module.hs
@@ -9,6 +9,7 @@ import Checking.Foundation qualified as Foundation
 import Checking.Identity qualified as Identity
 import Checking.Module qualified as Module
 import Checking.Semantic qualified as Semantic
+import CommandLine qualified
 import Felix.Module
 import Felix.Migration qualified as Migration
 import Felix.Parse qualified as Parse
@@ -23,6 +24,7 @@ import Syntax.Interface qualified as Syntax
 import Bound.Scope (fromScope)
 import Bound.Var (Var(..))
 import Data.ByteString qualified as ByteString
+import Data.Text qualified as StrictText
 import Data.Text.Encoding qualified as Text
 import Control.Monad.Logger (runNoLoggingT)
 import System.Directory (getCurrentDirectory)
@@ -305,11 +307,11 @@ rejectsUnsupportedTypedSource = do
                 "test/phase3/typed-unsupported.tex")
     case result of
         Left
-            (Api.VerificationTypedModuleError
+            (failure@(Api.VerificationTypedModuleError
                 source
                 (Module.TypedActionFailed
                     (Module.TypedUnsupportedBlock location))
-                prefix) -> do
+                prefix)) -> do
             assertEqual "failed source"
                 "test/phase3/typed-unsupported.tex"
                 (safeRelativePathFilePath
@@ -321,6 +323,17 @@ rejectsUnsupportedTypedSource = do
                 0
                 (length
                     (Declaration.pendingModulePrefixBatches prefix))
+            let diagnostic =
+                    CommandLine.verificationDriverFailureMessage failure
+            assertBool "diagnostic retains resolved source"
+                ("project:test/phase3/typed-unsupported.tex"
+                    `StrictText.isInfixOf` diagnostic)
+            assertBool "diagnostic retains best location"
+                ("typed-unsupported.tex 1:1"
+                    `StrictText.isInfixOf` diagnostic)
+            assertBool "diagnostic explains the typed failure"
+                ("not yet supported by the typed checker"
+                    `StrictText.isInfixOf` diagnostic)
         Left err ->
             assertFailure ("unexpected verification driver error: " <> show err)
         Right{} ->