Migrate to `Felix` namespaceHEADhotg

1 files changed, 0 insertions, 478 deletions

diff --git a/source/Test/Unit/HtmlLayout.hs b/source/Test/Unit/HtmlLayout.hs
deleted file mode 100644
index a248f3b..0000000
--- a/source/Test/Unit/HtmlLayout.hs
+++ /dev/null
@@ -1,478 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.HtmlLayout (unitTests) where
-
-import Base
-import Felix.Source
-import Felix.Source.Graph
-import Render.Html.Layout
-
-import Control.Exception (bracket)
-import Data.List qualified as List
-import Data.List.NonEmpty qualified as NonEmpty
-import Data.Text qualified as Text
-import System.Directory qualified as Directory
-import System.FilePath.Posix qualified as Posix
-import Test.Tasty
-import Test.Tasty.HUnit
-
-
-unitTests :: TestTree
-unitTests =
-    testGroup "HTML layout"
-        [ testCase
-            "encodes URL segments canonically"
-            encodesUrlSegments
-        , testCase
-            "renders relative typed URLs"
-            rendersRelativeUrls
-        , testCase
-            "separates mounted route namespaces"
-            separatesMountedNamespaces
-        , testCase
-            "routes searched and exact roots identically"
-            routesRootFormsIdentically
-        , testCase
-            "requires an explicit mount for an external root"
-            requiresExternalMount
-        , testCase
-            "reports URL and destination collisions independently"
-            reportsRouteCollisions
-        , testCase
-            "rejects ancestor and descendant destinations"
-            rejectsNestedDestinations
-        , testCase
-            "is independent of graph and configuration traversal order"
-            isTraversalOrderIndependent
-        ]
-
-
-encodesUrlSegments :: Assertion
-encodesUrlSegments = do
-    let accepted =
-            [ ("AZaz09-._~", "AZaz09-._~")
-            , ("#?% \\", "%23%3F%25%20%5C")
-            , ("über", "%C3%BCber")
-            , ("%2f", "%252f")
-            ]
-    for_ accepted \(decoded, expected) ->
-        assertEqual
-            ("encoded segment " <> Text.unpack decoded)
-            (Right expected)
-            (renderUrlSegment <$> urlSegment decoded)
-    let rejected =
-            [ ("", EmptyUrlSegment)
-            , (".", DotUrlSegment ".")
-            , ("..", DotUrlSegment "..")
-            , ("a/b", UrlSegmentContainsSeparator "a/b")
-            ]
-    for_ rejected \(decoded, expected) ->
-        assertEqual
-            ("rejected segment " <> Text.unpack decoded)
-            (Left expected)
-            (urlSegment decoded)
-    assertEqual
-        "fragment encoding"
-        "#name%23%C3%BC"
-        (renderUrlFragment "name#ü")
-
-rendersRelativeUrls :: Assertion
-rendersRelativeUrls = do
-    let cases =
-            [ ( ["library", "nested", "über"]
-              , ["_static", "naproche-html.js"]
-              , "../../_static/naproche-html.js"
-              )
-            , ( ["first", "entry"]
-              , ["second", "entry"]
-              , "../second/entry"
-              )
-            , ( ["mount", "entry"]
-              , ["mount", "a?b"]
-              , "a%3Fb"
-              )
-            ]
-    for_ cases \(currentSegments, targetSegments, expected) -> do
-        current <- expectRight (urlPath currentSegments)
-        target <- expectRight (urlPath targetSegments)
-        assertEqual
-            "relative URL"
-            expected
-            (renderRelativeUrlPath current target)
-    current <- expectRight (urlPath ["mount", "entry"])
-    target <- expectRight (urlPath ["mount", "ü"])
-    assertEqual
-        "encoded path and fragment remain separate"
-        "%C3%BC#part%23%3F"
-        ( renderRelativeUrlPath current target
-            <> renderUrlFragment "part#?"
-        )
-
-separatesMountedNamespaces :: Assertion
-separatesMountedNamespaces =
-    withTemporaryDirectory "felix-html-layout-mounts" \temp -> do
-        let mountSpecifications =
-                [ ("project", [])
-                , ("library", ["library"])
-                , ("debug", ["debug"])
-                , ("external", ["external"])
-                ]
-        roots <- for mountSpecifications \(ident, _prefix) -> do
-            let root = temp Posix.</> Text.unpack ident
-            Directory.createDirectory root
-            writeTheory (root Posix.</> "entry.tex") []
-            pure (sourceMountId ident, root)
-        mounts <- expectRight =<< prepareSourceMounts roots
-        routes <- for mountSpecifications \(ident, prefix) -> do
-            let sourcePath =
-                    temp
-                        Posix.</> Text.unpack ident
-                        Posix.</> "entry.tex"
-            request <- expectRight =<< existingRoot sourcePath
-            graph <- expectRight =<< buildResolvedSourceGraph mounts request
-            layout <-
-                expectRight
-                    (layoutHtmlSourceGraph
-                        [ (sourceMountId configuredId, configuredPrefix)
-                        | (configuredId, configuredPrefix) <-
-                            mountSpecifications
-                        ]
-                        graph)
-            route <- requireRootRoute graph layout
-            pure
-                ( ident
-                , renderUrlPath (routeUrlPath route)
-                , safeRelativePathFilePath
-                    (routeDestination route)
-                , prefix
-                )
-        assertEqual
-            "mount URLs"
-            [ ("project", "/entry")
-            , ("library", "/library/entry")
-            , ("debug", "/debug/entry")
-            , ("external", "/external/entry")
-            ]
-            [ (ident, url) | (ident, url, _destination, _prefix) <- routes ]
-        assertEqual
-            "mount destinations"
-            [ ("project", "entry.html")
-            , ("library", "library/entry.html")
-            , ("debug", "debug/entry.html")
-            , ("external", "external/entry.html")
-            ]
-            [ (ident, destination)
-            | (ident, _url, destination, _prefix) <- routes
-            ]
-
-routesRootFormsIdentically :: Assertion
-routesRootFormsIdentically =
-    withTemporaryDirectory "felix-html-layout-root-forms" \temp -> do
-        let libraryRoot = temp Posix.</> "library"
-            entry = libraryRoot Posix.</> "entry.tex"
-        Directory.createDirectory libraryRoot
-        writeTheory entry []
-        mounts <- expectRight =<< prepareSourceMounts
-            [ (sourceMountId "project", temp)
-            , (sourceMountId "library", libraryRoot)
-            ]
-        searched <- expectRight (searchedRoot "library/entry.tex")
-        exact <- expectRight =<< existingRoot entry
-        searchedGraph <-
-            expectRight =<< buildResolvedSourceGraph mounts searched
-        exactGraph <-
-            expectRight =<< buildResolvedSourceGraph mounts exact
-        let configuration =
-                [ (sourceMountId "project", [])
-                , (sourceMountId "library", ["library"])
-                ]
-        searchedLayout <-
-            expectRight
-                (layoutHtmlSourceGraph configuration searchedGraph)
-        exactLayout <-
-            expectRight
-                (layoutHtmlSourceGraph configuration exactGraph)
-        searchedRoute <-
-            requireRootRoute searchedGraph searchedLayout
-        exactRoute <-
-            requireRootRoute exactGraph exactLayout
-        assertEqual "selected route" searchedRoute exactRoute
-        assertEqual
-            "most-specific URL"
-            "/library/entry"
-            (renderUrlPath (routeUrlPath searchedRoute))
-
-requiresExternalMount :: Assertion
-requiresExternalMount =
-    withTemporaryDirectory "felix-html-layout-external" \temp -> do
-        let projectRoot = temp Posix.</> "project"
-            externalRoot = temp Posix.</> "vendor"
-            externalEntry = externalRoot Posix.</> "entry.tex"
-        Directory.createDirectory projectRoot
-        Directory.createDirectory externalRoot
-        writeTheory externalEntry []
-        request <- expectRight =<< existingRoot externalEntry
-        projectMounts <- expectRight =<< prepareSourceMounts
-            [(sourceMountId "project", projectRoot)]
-        outsideResult <-
-            buildResolvedSourceGraph projectMounts request
-        case outsideResult of
-            Left RootOutsideConfiguredMount{} ->
-                pure ()
-            result ->
-                assertFailure
-                    ("expected external root rejection, got "
-                        <> show result)
-        mounted <- expectRight =<< prepareSourceMounts
-            [ (sourceMountId "project", projectRoot)
-            , (sourceMountId "external", externalRoot)
-            ]
-        graph <- expectRight =<< buildResolvedSourceGraph mounted request
-        layout <-
-            expectRight
-                (layoutHtmlSourceGraph
-                    [ (sourceMountId "project", [])
-                    , (sourceMountId "external", ["vendor"])
-                    ]
-                    graph)
-        route <- requireRootRoute graph layout
-        assertEqual
-            "external URL"
-            "/vendor/entry"
-            (renderUrlPath (routeUrlPath route))
-
-reportsRouteCollisions :: Assertion
-reportsRouteCollisions = do
-    reportsPageCollisions
-    reportsAssetUrlCollision
-
-reportsPageCollisions :: Assertion
-reportsPageCollisions =
-    withTemporaryDirectory "felix-html-layout-page-collision" \temp -> do
-        let firstRoot = temp Posix.</> "first"
-            secondRoot = temp Posix.</> "second"
-            firstEntry = firstRoot Posix.</> "two" Posix.</> "a.tex"
-        Directory.createDirectory firstRoot
-        Directory.createDirectory secondRoot
-        Directory.createDirectory (firstRoot Posix.</> "two")
-        writeTheory (secondRoot Posix.</> "a.tex") []
-        writeTheory firstEntry ["a.tex"]
-        mounts <- expectRight =<< prepareSourceMounts
-            [ (sourceMountId "first", firstRoot)
-            , (sourceMountId "second", secondRoot)
-            ]
-        request <- expectRight =<< existingRoot firstEntry
-        graph <- expectRight =<< buildResolvedSourceGraph mounts request
-        let configuration =
-                [ (sourceMountId "first", ["one"])
-                , (sourceMountId "second", ["one", "two"])
-                ]
-        case layoutHtmlSourceGraph configuration graph of
-            Left
-                (CollidingHtmlRoutes
-                    [HtmlUrlRouteCollision url owners]
-                    [HtmlDestinationRouteCollision destination
-                        destinationOwners]) -> do
-                            assertEqual
-                                "canonical URL collision"
-                                "/one/two/a"
-                                (renderUrlPath url)
-                            assertEqual
-                                "URL owners"
-                                (NonEmpty.toList owners)
-                                (NonEmpty.toList destinationOwners)
-                            assertEqual
-                                "destination collision"
-                                "one/two/a.html"
-                                (safeRelativePathFilePath destination)
-            result ->
-                assertFailure
-                    ("expected paired route collisions, got "
-                        <> show result)
-
-reportsAssetUrlCollision :: Assertion
-reportsAssetUrlCollision =
-    withTemporaryDirectory "felix-html-layout-asset-collision" \temp -> do
-        let entry =
-                temp
-                    Posix.</> "_static"
-                    Posix.</> "naproche-html.js.tex"
-        Directory.createDirectory (temp Posix.</> "_static")
-        writeTheory entry []
-        mounts <- expectRight =<< prepareSourceMounts
-            [(sourceMountId "project", temp)]
-        request <-
-            expectRight
-                (searchedRoot "_static/naproche-html.js.tex")
-        graph <- expectRight =<< buildResolvedSourceGraph mounts request
-        case
-            layoutHtmlSourceGraph
-                [(sourceMountId "project", [])]
-                graph of
-            Left
-                (CollidingHtmlRoutes
-                    [HtmlUrlRouteCollision url _owners]
-                    []) ->
-                        assertEqual
-                            "page/asset URL collision"
-                            "/_static/naproche-html.js"
-                            (renderUrlPath url)
-            result ->
-                assertFailure
-                    ("expected URL-only asset collision, got "
-                        <> show result)
-
-rejectsNestedDestinations :: Assertion
-rejectsNestedDestinations =
-    withTemporaryDirectory "felix-html-layout-nested" \temp -> do
-        let nestedDirectory = temp Posix.</> "a.html"
-        Directory.createDirectory nestedDirectory
-        writeTheory (temp Posix.</> "a.tex") []
-        writeTheory (nestedDirectory Posix.</> "b.tex") []
-        writeTheory
-            (temp Posix.</> "entry.tex")
-            ["a.tex", "a.html/b.tex"]
-        mounts <- expectRight =<< prepareSourceMounts
-            [(sourceMountId "project", temp)]
-        request <- expectRight (searchedRoot "entry.tex")
-        graph <- expectRight =<< buildResolvedSourceGraph mounts request
-        case layoutHtmlSourceGraph
-                [(sourceMountId "project", [])]
-                graph of
-            Left
-                (CollidingHtmlRoutes
-                    []
-                    [NestedHtmlDestinationRouteCollision
-                        ancestor
-                        ancestorOwner
-                        descendant
-                        descendantOwner]) -> do
-                            assertEqual
-                                "ancestor destination"
-                                "a.html"
-                                (safeRelativePathFilePath ancestor)
-                            assertEqual
-                                "ancestor owner"
-                                "a.tex"
-                                (pageOwnerPath ancestorOwner)
-                            assertEqual
-                                "descendant destination"
-                                "a.html/b.html"
-                                (safeRelativePathFilePath descendant)
-                            assertEqual
-                                "descendant owner"
-                                "a.html/b.tex"
-                                (pageOwnerPath descendantOwner)
-            result ->
-                assertFailure
-                    ("expected nested destination collision, got "
-                        <> show result)
-  where
-    pageOwnerPath = \case
-        HtmlPage source ->
-            safeRelativePathFilePath
-                (resolvedSourceRelativePath source)
-        HtmlSupportScript ->
-            "<support script>"
-
-isTraversalOrderIndependent :: Assertion
-isTraversalOrderIndependent =
-    withTemporaryDirectory "felix-html-layout-order" \temp -> do
-        writeTheory (temp Posix.</> "a.tex") []
-        writeTheory (temp Posix.</> "b.tex") []
-        let root = temp Posix.</> "entry.tex"
-        writeTheory root ["a.tex", "b.tex"]
-        mounts <- expectRight =<< prepareSourceMounts
-            [(sourceMountId "project", temp)]
-        request <- expectRight (searchedRoot "entry.tex")
-        firstGraph <-
-            expectRight =<< buildResolvedSourceGraph mounts request
-        writeTheory root ["b.tex", "a.tex"]
-        secondGraph <-
-            expectRight =<< buildResolvedSourceGraph mounts request
-        let firstConfiguration =
-                [ (sourceMountId "unused", ["unused"])
-                , (sourceMountId "project", [])
-                ]
-        firstLayout <-
-            expectRight
-                (layoutHtmlSourceGraph
-                    firstConfiguration
-                    firstGraph)
-        for_
-            (zip
-                (cycle [firstGraph, secondGraph])
-                (List.permutations firstConfiguration))
-            \(orderedGraph, configuration) -> do
-                layout <-
-                    expectRight
-                        (layoutHtmlSourceGraph
-                            configuration
-                            orderedGraph)
-                assertEqual
-                    "route table"
-                    firstLayout
-                    layout
-
-        let collidingConfiguration =
-                [ (sourceMountId "z", ["same"])
-                , (sourceMountId "a", ["same"])
-                , (sourceMountId "project", [])
-                ]
-            expectedCollision =
-                layoutHtmlSourceGraph
-                    collidingConfiguration
-                    firstGraph
-        for_
-            (zip
-                (cycle [firstGraph, secondGraph])
-                (List.permutations collidingConfiguration))
-            \(orderedGraph, configuration) ->
-                assertEqual
-                    "collision diagnostic"
-                    expectedCollision
-                    (layoutHtmlSourceGraph
-                        configuration
-                        orderedGraph)
-
-
-requireRootRoute
-    :: ResolvedSourceGraph
-    -> HtmlLayout
-    -> IO HtmlRoute
-requireRootRoute graph layout =
-    case htmlPageRoute layout (sourceGraphRootSource graph) of
-        Just route ->
-            pure route
-        Nothing -> do
-            assertFailure "layout omitted the root source"
-            pure (impossible "requireRootRoute: assertFailure returned")
-
-writeTheory :: FilePath -> [FilePath] -> IO ()
-writeTheory path imports =
-    writeFile path
-        (unlines
-            (["\\import{" <> imported <> "}" | imported <- imports]
-                <> [ "\\begin{axiom}\\label{route_fixture}"
-                   , "  $x = x$."
-                   , "\\end{axiom}"
-                   ]))
-
-expectRight :: (Show e, HasCallStack) => Either e a -> IO a
-expectRight = \case
-    Left err ->
-        assertFailure ("expected Right, got Left " <> show err)
-    Right value ->
-        pure value
-
-withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a
-withTemporaryDirectory template =
-    bracket create Directory.removePathForcibly
-  where
-    create = do
-        systemTemp <- Directory.getTemporaryDirectory
-        (path, handle) <- openTempFile systemTemp template
-        hClose handle
-        Directory.removeFile path
-        Directory.createDirectory path
-        pure path