From 82328890108bae64b372b8d58620ebc62699de76 Mon Sep 17 00:00:00 2001 From: adelon <22380201+adelon@users.noreply.github.com> Date: Thu, 6 Aug 2026 17:54:00 +0200 Subject: Migrate to `Felix` namespace --- source/Felix/Test/Unit/Html.hs | 225 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 225 insertions(+) create mode 100644 source/Felix/Test/Unit/Html.hs (limited to 'source/Felix/Test/Unit/Html.hs') diff --git a/source/Felix/Test/Unit/Html.hs b/source/Felix/Test/Unit/Html.hs new file mode 100644 index 0000000..c8395ec --- /dev/null +++ b/source/Felix/Test/Unit/Html.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Html (unitTests) where + +import Base +import Felix.Parse qualified as Parse +import Felix.Source +import Felix.Source.Graph +import Felix.Workspace qualified as Workspace +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Context +import Felix.Render.Html.Layout +import Felix.Report.Location (Location, pattern Nowhere) +import Felix.Syntax.Abstract + +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.List.NonEmpty qualified as NonEmpty +import System.Directory qualified as Directory +import Test.Tasty +import Test.Tasty.HUnit + +unitTests :: TestTree +unitTests = testGroup "HTML renderer" + [ testCase "one shared index resolves local and cross-page previews" referencePreviews + , testCase "missing reference preview data falls back to readable text" missingReferenceFallback + , testCase "datatype rendering omits unchecked derived facts" datatypeDerivedFactsAreOmitted + ] + +referencePreviews :: Assertion +referencePreviews = do + environment <- expectRight =<< Workspace.prepareDefaultWorkspaceEnvironment + graph <- + expectRight =<< + Workspace.prepareDefaultSourceGraph + "test/html-fixtures/root-preview.tex" + workspace <- + expectRight =<< Parse.parseResolvedSourceGraph graph + hints <- TextIO.readFile "library/lexicon.tsv" + layout <- + expectRight + (layoutHtmlSourceGraph + (Workspace.workspaceHtmlMountPrefixes environment) + graph) + let nodes = Parse.parsedWorkspaceImportedBeforeImporter workspace + sourceBlocks = + (\node -> + ( Parse.parsedModuleResolved node + , Parse.parsedModuleBlocks node + )) + <$> nodes + (renderIndex, pages) = + Html.buildRenderIndex sourceBlocks + rootPage = NonEmpty.last pages + context <- + expectRight + (htmlRenderContext + layout + (Html.htmlPagePresentationSource rootPage)) + html <- + expectRight + (Html.renderDocument + context + hints + renderIndex + rootPage) + let supportScript = Html.supportScriptAssetContents + assertContains "local references keep page anchors" "href=\"#local_prop\"" html + assertContains "local references point previews at the visible target block" "data-reference-label=\"local_prop\" data-preview-target-id=\"local_prop\"" html + assertNotContains "local references do not use hidden preview ids" "data-reference-label=\"local_prop\" data-preview-id=\"" html + assertContains "visible target blocks expose preview metadata" "id=\"local_prop\" data-preview-kind=\"Proposition\" data-preview-label=\"local_prop\"" html + assertContains "imported references get preview metadata" "data-reference-label=\"imported_prop\"" html + assertContains "imported references link to their relative encoded theory route" "href=\"imported-preview#imported_prop\"" html + assertContains "imported references still use hidden preview templates" "data-reference-label=\"imported_prop\" data-preview-id=\"reference-preview-" html + assertNotContains "imported references do not get broken page anchors" "href=\"#imported_prop\"" html + assertNotContains "imported references are not non-clickable spans" " div" html + assertContains "page heading uses the selected mounted source" "

project:test/html-fixtures/root-preview.tex

" html + assertContains "imported preview records its mounted source" "project:test/html-fixtures/imported-preview.tex" html + assertContains "imported preview source links to the same route" "href=\"imported-preview\">project:test/html-fixtures/imported-preview.tex" html + assertContains "imported source renders on its own line" "class=\"reference-preview-source\"" html + assertContains "multi-reference rendering preserves the comma separator" ", local_prop, " html + assertContains "preview popup cancels delayed hide on pointer entry" "popup.addEventListener('pointerenter', clearHideTimer);" supportScript + assertContains "preview popup schedules delayed hide on pointer exit" "popup.addEventListener('pointerleave', scheduleHide);" supportScript + assertContains "group click pins the preview popup" "showPreview(trigger, event, true);" supportScript + assertContains "group keyboard activation pins the preview popup" "showPreview(trigger, null, true);" supportScript + assertContains "preview statements use a full-width paragraph" "class=\"reference-preview-statement\"" html + assertContains "preview popup is emitted once" "id=\"reference-preview-popup\"" html + +missingReferenceFallback :: Assertion +missingReferenceFallback = do + let proof = Qed (Just Nowhere) (JustificationRef ("missing_ref" :| [])) + blocks = [BlockProof Nowhere proof Nowhere] + html <- renderSynthetic blocks + assertContains "missing references remain visible" "missing_ref" html + assertNotContains "missing references do not claim preview content" "data-preview-id=" html + +datatypeDerivedFactsAreOmitted :: Assertion +datatypeDerivedFactsAreOmitted = do + let blocks = + [ propformDatatypeBlock Nowhere + , referenceClaimBlock "uses_datatype_fact" + , referenceProofBlock "propform_induct" + ] + html <- renderSynthetic blocks + assertContains "datatype declarations remain visible" "Datatype of " html + assertContains "derived fact references remain readable" "propform_induct" html + assertNotContains "unchecked datatype facts are not rendered" "Derived facts" html + assertNotContains "unchecked datatype facts do not become preview targets" "data-preview-label=\"propform_induct\"" html + +renderSynthetic :: [Block] -> IO Text +renderSynthetic blocks = do + currentDirectory <- Directory.getCurrentDirectory + mounts <- + expectRight =<< + prepareSourceMounts + [(sourceMountId "project", currentDirectory)] + request <- + expectRight + (searchedRoot "test/html-fixtures/root-preview.tex") + graph <- + expectRight =<< + buildResolvedSourceGraph mounts request + layout <- + expectRight + (layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph) + context <- + expectRight + (htmlRenderContext + layout + (sourceGraphRootSource graph)) + let (renderIndex, page :| _remainingPages) = + Html.buildRenderIndex + ((sourceGraphRootSource graph, blocks) :| []) + expectRight + (Html.renderDocument + context + "" + renderIndex + page) + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +propformDatatypeBlock :: Location -> Block +propformDatatypeBlock blockLoc = + BlockData blockLoc Nothing "propform" propformDatatype + +propformDatatype :: Datatype +propformDatatype = + Datatype + { datatypeHeadExpr = ExprOp Nowhere (constSymbol "propform") [] + , datatypeClauses = + DatatypeClause (ExprOp Nowhere (constSymbol "propbot") []) (ExprOp Nowhere (constSymbol "propform") []) [] :| + [ DatatypeClause (ExprOp Nowhere (unarySymbol "propvar") [ExprVar "n"]) (ExprOp Nowhere (constSymbol "propform") []) [("n", ExprOp Nowhere (constSymbol "naturals") [])] + , DatatypeClause + (ExprOp Nowhere (infixSymbol "propto") [ExprVar "p", ExprVar "q"]) + (ExprOp Nowhere (constSymbol "propform") []) + [ ("p", ExprOp Nowhere (constSymbol "propform") []) + , ("q", ExprOp Nowhere (constSymbol "propform") []) + ] + ] + } + +referenceClaimBlock :: Marker -> Block +referenceClaimBlock marker = + BlockClaim Proposition Nowhere Nothing marker (Claim [] (StmtFormula (PropositionalConstant Nowhere IsTop))) + +referenceProofBlock :: Marker -> Block +referenceProofBlock marker = + BlockProof Nowhere (Qed (Just Nowhere) (JustificationRef (marker :| []))) Nowhere + +constSymbol :: Text -> FunctionSymbol +constSymbol name = + mkMixfixItem [Just (Command name)] (Marker name) NonAssoc + +unarySymbol :: Text -> FunctionSymbol +unarySymbol name = + mkMixfixItem [Just (Command name), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] (Marker name) NonAssoc + +infixSymbol :: Text -> FunctionSymbol +infixSymbol name = + mkMixfixItem [Nothing, Just (Command name), Nothing] (Marker name) NonAssoc + +assertContains :: HasCallStack => String -> Text -> Text -> Assertion +assertContains label needle haystack = + assertBool + (label <> "\nExpected to find: " <> Text.unpack needle) + (needle `Text.isInfixOf` haystack) + +assertNotContains :: HasCallStack => String -> Text -> Text -> Assertion +assertNotContains label needle haystack = + assertBool + (label <> "\nDid not expect to find: " <> Text.unpack needle) + (not (needle `Text.isInfixOf` haystack)) + +assertCount :: HasCallStack => String -> Int -> Text -> Text -> Assertion +assertCount label expected needle haystack = + assertEqual + (label <> "\nExpected count for: " <> Text.unpack needle) + expected + (Text.count needle haystack) -- cgit v1.2.3