Migrate to `Felix` namespaceHEADhotg

1 files changed, 0 insertions, 602 deletions

diff --git a/source/Render/Html/Layout.hs b/source/Render/Html/Layout.hs
deleted file mode 100644
index c26b6b5..0000000
--- a/source/Render/Html/Layout.hs
+++ /dev/null
@@ -1,602 +0,0 @@
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | Pure browser and destination routing for a resolved source graph.
-module Render.Html.Layout
-    ( UrlSegment
-    , UrlSegmentError(..)
-    , urlSegment
-    , renderUrlSegment
-    , UrlPath
-    , urlPath
-    , renderUrlPath
-    , renderRelativeUrlPath
-    , renderUrlFragment
-    , HtmlRoute
-    , routeDestination
-    , routeUrlPath
-    , HtmlRouteOwner(..)
-    , HtmlUrlRouteCollision(..)
-    , HtmlDestinationRouteCollision(..)
-    , HtmlLayoutError(..)
-    , renderHtmlLayoutError
-    , HtmlLayout
-    , htmlPageRoutes
-    , htmlPageRoute
-    , htmlSupportScriptRoute
-    , htmlMountUrlPrefixes
-    , layoutHtmlSources
-    , layoutHtmlSourceGraph
-    ) where
-
-import Base
-import Felix.Source
-import Felix.Source.Graph
-
-import Control.Exception (Exception)
-import Data.Bifunctor (first)
-import Data.ByteString qualified as ByteString
-import Data.Char (chr)
-import Data.List qualified as List
-import Data.Map.Strict qualified as Map
-import Data.Set qualified as Set
-import Data.Text qualified as Text
-import Data.Text.Encoding qualified as TextEncoding
-import Data.Word (Word8)
-import System.FilePath.Posix qualified as Posix
-
-
--- | One canonical percent-encoded URL path segment.
-newtype UrlSegment = UrlSegment Text
-    deriving stock (Show, Eq, Ord)
-
-data UrlSegmentError
-    = EmptyUrlSegment
-    | DotUrlSegment !Text
-    | UrlSegmentContainsSeparator !Text
-    | UrlSegmentContainsNull !Text
-    deriving stock (Show, Eq)
-
-urlSegment :: Text -> Either UrlSegmentError UrlSegment
-urlSegment decoded
-    | Text.null decoded =
-        Left EmptyUrlSegment
-    | decoded == "." || decoded == ".." =
-        Left (DotUrlSegment decoded)
-    | "/" `Text.isInfixOf` decoded =
-        Left (UrlSegmentContainsSeparator decoded)
-    | "\0" `Text.isInfixOf` decoded =
-        Left (UrlSegmentContainsNull decoded)
-    | otherwise =
-        Right (UrlSegment (percentEncodeUtf8 decoded))
-
-renderUrlSegment :: UrlSegment -> Text
-renderUrlSegment (UrlSegment encoded) =
-    encoded
-
-
--- | A root-relative URL path. Its segments are already encoded.
-newtype UrlPath = UrlPath [UrlSegment]
-    deriving stock (Show, Eq, Ord)
-
-urlPath :: [Text] -> Either UrlSegmentError UrlPath
-urlPath =
-    fmap UrlPath . traverse urlSegment
-
-renderUrlPath :: UrlPath -> Text
-renderUrlPath (UrlPath segments) =
-    "/" <> Text.intercalate "/" (renderUrlSegment <$> segments)
-
--- | Render a target path relative to the directory of a current page.
-renderRelativeUrlPath :: UrlPath -> UrlPath -> Text
-renderRelativeUrlPath
-    (UrlPath currentPageSegments)
-    (UrlPath targetSegments) =
-        case relativeSegments of
-            [] ->
-                "."
-            _ ->
-                Text.intercalate "/" relativeSegments
-  where
-    currentDirectorySegments =
-        case reverse currentPageSegments of
-            [] ->
-                []
-            _page : directoryReversed ->
-                reverse directoryReversed
-    (remainingCurrent, remainingTarget) =
-        dropCommonPrefix currentDirectorySegments targetSegments
-    relativeSegments =
-        replicate (length remainingCurrent) ".."
-            <> (renderUrlSegment <$> remainingTarget)
-
--- | Render an exact source marker as an encoded URL fragment.
-renderUrlFragment :: Text -> Text
-renderUrlFragment marker =
-    "#" <> percentEncodeUtf8 marker
-
-
-data HtmlRoute = HtmlRoute
-    { routeDestination :: !SafeRelativePath
-    , routeUrlPath :: !UrlPath
-    }
-    deriving stock (Show, Eq)
-
-data HtmlRouteOwner
-    = HtmlPage !ResolvedSource
-    | HtmlSupportScript
-    deriving stock (Show, Eq, Ord)
-
-data HtmlUrlRouteCollision = HtmlUrlRouteCollision
-    !UrlPath
-    !(NonEmpty HtmlRouteOwner)
-    deriving stock (Show, Eq)
-
-data HtmlDestinationRouteCollision = HtmlDestinationRouteCollision
-        !SafeRelativePath
-        !(NonEmpty HtmlRouteOwner)
-    | NestedHtmlDestinationRouteCollision
-        !SafeRelativePath
-        !HtmlRouteOwner
-        !SafeRelativePath
-        !HtmlRouteOwner
-    deriving stock (Show, Eq)
-
-data HtmlLayoutError
-    = DuplicateHtmlMountId !SourceMountId
-    | InvalidHtmlMountPrefixSegment
-        !SourceMountId
-        !Text
-        !UrlSegmentError
-    | DuplicateHtmlMountPrefix
-        ![Text]
-        !(NonEmpty SourceMountId)
-    | MissingHtmlMountPrefix !SourceMountId
-    | InvalidHtmlRouteSegment
-        !HtmlRouteOwner
-        !Text
-        !UrlSegmentError
-    | InvalidHtmlRouteDestination
-        !HtmlRouteOwner
-        !FilePath
-        !RelativePathError
-    | CollidingHtmlRoutes
-        ![HtmlUrlRouteCollision]
-        ![HtmlDestinationRouteCollision]
-    deriving stock (Show, Eq)
-
-instance Exception HtmlLayoutError
-
-renderHtmlLayoutError :: HtmlLayoutError -> Text
-renderHtmlLayoutError = \case
-    DuplicateHtmlMountId mount ->
-        "HTML mount is configured more than once: "
-            <> quoteText (sourceMountIdText mount)
-    InvalidHtmlMountPrefixSegment mount segment _problem ->
-        "HTML mount " <> quoteText (sourceMountIdText mount)
-            <> " has invalid route segment " <> quoteText segment
-    DuplicateHtmlMountPrefix prefix mounts ->
-        "HTML route prefix " <> quoteText (Text.intercalate "/" prefix)
-            <> " is shared by mounts "
-            <> Text.intercalate ", "
-                (quoteText . sourceMountIdText <$> toList mounts)
-    MissingHtmlMountPrefix mount ->
-        "no HTML route prefix is configured for mount "
-            <> quoteText (sourceMountIdText mount)
-    InvalidHtmlRouteSegment owner segment _problem ->
-        renderOwner owner <> " has invalid route segment " <> quoteText segment
-    InvalidHtmlRouteDestination owner path _problem ->
-        renderOwner owner <> " has invalid HTML destination " <> quotePath path
-    CollidingHtmlRoutes urlCollisions destinationCollisions ->
-        "HTML routes collide: "
-            <> Text.intercalate "; "
-                ( (renderUrlCollision <$> urlCollisions)
-                    <> (renderDestinationCollision <$> destinationCollisions)
-                )
-  where
-    renderUrlCollision (HtmlUrlRouteCollision path owners) =
-        "URL " <> quoteText (renderUrlPath path)
-            <> " is owned by "
-            <> Text.intercalate ", " (renderOwner <$> toList owners)
-
-    renderDestinationCollision
-            (HtmlDestinationRouteCollision path owners) =
-        "destination "
-            <> quotePath (safeRelativePathFilePath path)
-            <> " is owned by "
-            <> Text.intercalate ", " (renderOwner <$> toList owners)
-    renderDestinationCollision
-            (NestedHtmlDestinationRouteCollision
-                ancestor ancestorOwner descendant descendantOwner) =
-        "destination " <> quotePath (safeRelativePathFilePath ancestor)
-            <> " for " <> renderOwner ancestorOwner
-            <> " is an ancestor of "
-            <> quotePath (safeRelativePathFilePath descendant)
-            <> " for " <> renderOwner descendantOwner
-
-renderOwner :: HtmlRouteOwner -> Text
-renderOwner = \case
-    HtmlPage source ->
-        "page "
-            <> quoteText
-                (sourceMountIdText (resolvedSourceMount source)
-                    <> ":"
-                    <> Text.pack
-                        (safeRelativePathFilePath
-                            (resolvedSourceRelativePath source)))
-    HtmlSupportScript ->
-        "support script"
-
-quotePath :: FilePath -> Text
-quotePath = Text.pack . show
-
-quoteText :: Text -> Text
-quoteText = Text.pack . show
-
-data HtmlLayout = HtmlLayout
-    !(Map ResolvedSource HtmlRoute)
-    !HtmlRoute
-    !(Map SourceMountId UrlPath)
-    deriving stock (Show, Eq)
-
-htmlPageRoutes :: HtmlLayout -> [(ResolvedSource, HtmlRoute)]
-htmlPageRoutes (HtmlLayout routes _supportScript _mountPrefixes) =
-    Map.toAscList routes
-
-htmlPageRoute :: HtmlLayout -> ResolvedSource -> Maybe HtmlRoute
-htmlPageRoute (HtmlLayout routes _supportScript _mountPrefixes) source =
-    Map.lookup source routes
-
-htmlSupportScriptRoute :: HtmlLayout -> HtmlRoute
-htmlSupportScriptRoute (HtmlLayout _routes supportScript _mountPrefixes) =
-    supportScript
-
-htmlMountUrlPrefixes :: HtmlLayout -> Map SourceMountId UrlPath
-htmlMountUrlPrefixes (HtmlLayout _routes _supportScript mountPrefixes) =
-    mountPrefixes
-
-
-data ValidatedMountPrefix = ValidatedMountPrefix
-    ![Text]
-    ![UrlSegment]
-
-layoutHtmlSourceGraph
-    :: [(SourceMountId, [Text])]
-    -> ResolvedSourceGraph
-    -> Either HtmlLayoutError HtmlLayout
-layoutHtmlSourceGraph specifications graph =
-    layoutHtmlSources
-        specifications
-        (sourceNodeResolved <$> sourceGraphNodes graph)
-
-layoutHtmlSources
-    :: [(SourceMountId, [Text])]
-    -> [ResolvedSource]
-    -> Either HtmlLayoutError HtmlLayout
-layoutHtmlSources specifications inputSources = do
-    prefixes <- validateMountPrefixes specifications
-    let sources =
-            List.sort
-                inputSources
-        usedMounts =
-            Set.fromList (resolvedSourceMount <$> sources)
-        missingMounts =
-            usedMounts `Set.difference` Map.keysSet prefixes
-    case Set.lookupMin missingMounts of
-        Just missing ->
-            Left (MissingHtmlMountPrefix missing)
-        Nothing -> do
-            pageEntries <-
-                traverse
-                    (makePageRoute prefixes)
-                    sources
-            encodedSupportScript <-
-                encodeRouteSegments
-                    HtmlSupportScript
-                    supportScriptAssetComponents
-            supportScript <-
-                makeRoute
-                    HtmlSupportScript
-                    supportScriptAssetComponents
-                    encodedSupportScript
-            let ownedRoutes =
-                    (HtmlSupportScript, supportScript)
-                        : [ (HtmlPage source, route)
-                          | (source, route) <- pageEntries
-                          ]
-                urlCollisions =
-                    collectUrlCollisions ownedRoutes
-                destinationCollisions =
-                    collectDestinationCollisions ownedRoutes
-                        <> collectNestedDestinationCollisions ownedRoutes
-            if null urlCollisions && null destinationCollisions
-                then
-                    Right
-                        (HtmlLayout
-                            (Map.fromList pageEntries)
-                            supportScript
-                            (Map.map
-                                (\(ValidatedMountPrefix _decoded encoded) ->
-                                    UrlPath encoded)
-                                prefixes))
-                else
-                    Left
-                        (CollidingHtmlRoutes
-                            urlCollisions
-                            destinationCollisions)
-
-validateMountPrefixes
-    :: [(SourceMountId, [Text])]
-    -> Either HtmlLayoutError (Map SourceMountId ValidatedMountPrefix)
-validateMountPrefixes specifications =
-    case duplicateValues (fst <$> specifications) of
-        duplicate : _ ->
-            Left (DuplicateHtmlMountId duplicate)
-        [] -> do
-            validated <- traverse validatePrefix (List.sort specifications)
-            case duplicatePrefixGroups validated of
-                duplicate : _ ->
-                    Left duplicate
-                [] ->
-                    Right
-                        (Map.fromList
-                            [ (mount, prefix)
-                            | (mount, _decoded, prefix) <- validated
-                            ])
-  where
-    validatePrefix (mount, decoded) = do
-        encoded <- traverse
-            (\segment ->
-                first
-                    (InvalidHtmlMountPrefixSegment mount segment)
-                    (urlSegment segment))
-            decoded
-        Right
-            ( mount
-            , decoded
-            , ValidatedMountPrefix decoded encoded
-            )
-
-duplicatePrefixGroups
-    :: [(SourceMountId, [Text], ValidatedMountPrefix)]
-    -> [HtmlLayoutError]
-duplicatePrefixGroups validated =
-    [ DuplicateHtmlMountPrefix prefix (firstMount :| otherMounts)
-    | (prefix, mounts) <-
-        Map.toAscList
-            (Map.fromListWith (<>)
-                [ (decoded, [mount])
-                | (mount, decoded, _prefix) <- validated
-                ])
-    , firstMount : secondMount : remainingMounts <-
-        [List.sort mounts]
-    , let otherMounts = secondMount : remainingMounts
-    ]
-
-duplicateValues :: Ord a => [a] -> [a]
-duplicateValues values =
-    [ value
-    | (value, multiplicity) <-
-        Map.toAscList
-            (Map.fromListWith (+)
-                [(value, 1 :: Int) | value <- values])
-    , multiplicity > 1
-    ]
-
-makePageRoute
-    :: Map SourceMountId ValidatedMountPrefix
-    -> ResolvedSource
-    -> Either HtmlLayoutError (ResolvedSource, HtmlRoute)
-makePageRoute prefixes source = do
-    prefix <- case Map.lookup (resolvedSourceMount source) prefixes of
-        Nothing ->
-            Left
-                (MissingHtmlMountPrefix
-                    (resolvedSourceMount source))
-        Just found ->
-            Right found
-    let sourceComponents =
-            Text.splitOn
-                "/"
-                (Text.pack
-                    (safeRelativePathFilePath
-                        (resolvedSourceRelativePath source)))
-        destinationComponents =
-            replaceFinalComponent
-                (\component ->
-                    dropFinalExtension component <> ".html")
-                sourceComponents
-        urlComponents =
-            replaceFinalComponent
-                dropFinalExtension
-                sourceComponents
-        ValidatedMountPrefix decodedPrefix encodedPrefix =
-            prefix
-        owner = HtmlPage source
-    encodedPageComponents <-
-        encodeRouteSegments owner urlComponents
-    route <-
-        makeRoute
-            owner
-            (decodedPrefix <> destinationComponents)
-            (encodedPrefix <> encodedPageComponents)
-    Right (source, route)
-
-replaceFinalComponent :: (a -> a) -> [a] -> [a]
-replaceFinalComponent transform components =
-    case reverse components of
-        [] ->
-            []
-        final : precedingReversed ->
-            reverse precedingReversed <> [transform final]
-
-dropFinalExtension :: Text -> Text
-dropFinalExtension component =
-    case Text.breakOnEnd "." component of
-        ("", _suffix) ->
-            component
-        (".", _suffix) ->
-            component
-        (prefix, _suffix) ->
-            Text.dropEnd 1 prefix
-
-makeRoute
-    :: HtmlRouteOwner
-    -> [Text]
-    -> [UrlSegment]
-    -> Either HtmlLayoutError HtmlRoute
-makeRoute owner destinationComponents encodedUrlComponents = do
-    let destinationSpelling =
-            List.intercalate
-                "/"
-                (Text.unpack <$> destinationComponents)
-    destination <-
-        first
-            (InvalidHtmlRouteDestination
-                owner
-                destinationSpelling)
-            (safeRelativePath destinationSpelling)
-    Right
-        HtmlRoute
-            { routeDestination = destination
-            , routeUrlPath = UrlPath encodedUrlComponents
-            }
-
-encodeRouteSegments
-    :: HtmlRouteOwner
-    -> [Text]
-    -> Either HtmlLayoutError [UrlSegment]
-encodeRouteSegments owner =
-    traverse
-        (\decoded ->
-            first
-                (InvalidHtmlRouteSegment owner decoded)
-                (urlSegment decoded))
-
-collectUrlCollisions
-    :: [(HtmlRouteOwner, HtmlRoute)]
-    -> [HtmlUrlRouteCollision]
-collectUrlCollisions ownedRoutes =
-    [ HtmlUrlRouteCollision path owners
-    | (path, collidingOwners) <-
-        Map.toAscList
-            (Map.fromListWith (<>)
-                [ (routeUrlPath route, [owner])
-                | (owner, route) <- ownedRoutes
-                ])
-    , owners <-
-        collisionOwners collidingOwners
-    ]
-
-collectDestinationCollisions
-    :: [(HtmlRouteOwner, HtmlRoute)]
-    -> [HtmlDestinationRouteCollision]
-collectDestinationCollisions ownedRoutes =
-    [ HtmlDestinationRouteCollision destination owners
-    | (destination, collidingOwners) <-
-        Map.toAscList
-            (Map.fromListWith (<>)
-                [ (routeDestination route, [owner])
-                | (owner, route) <- ownedRoutes
-                ])
-    , owners <-
-        collisionOwners collidingOwners
-    ]
-
-collectNestedDestinationCollisions
-    :: [(HtmlRouteOwner, HtmlRoute)]
-    -> [HtmlDestinationRouteCollision]
-collectNestedDestinationCollisions ownedRoutes =
-    take 1
-        [ NestedHtmlDestinationRouteCollision
-            ancestor
-            ancestorOwner
-            descendant
-            descendantOwner
-        | ( (ancestorComponents, ancestor, ancestorOwner)
-            , (descendantComponents, descendant, descendantOwner)
-            ) <- zip destinations (drop 1 destinations)
-        , strictComponentPrefix ancestorComponents descendantComponents
-        ]
-  where
-    destinations =
-        List.sort
-            [ ( relativePathComponents destination
-              , destination
-              , owner
-              )
-            | (owner, route) <- ownedRoutes
-            , let destination = routeDestination route
-            ]
-
-relativePathComponents :: SafeRelativePath -> [FilePath]
-relativePathComponents =
-    Posix.splitDirectories . safeRelativePathFilePath
-
-strictComponentPrefix :: [FilePath] -> [FilePath] -> Bool
-strictComponentPrefix possibleAncestor possibleDescendant =
-    length possibleAncestor < length possibleDescendant
-        && possibleAncestor `List.isPrefixOf` possibleDescendant
-
-collisionOwners :: [HtmlRouteOwner] -> [NonEmpty HtmlRouteOwner]
-collisionOwners owners =
-    case List.sort owners of
-        firstOwner : secondOwner : rest ->
-            [firstOwner :| (secondOwner : rest)]
-        _ ->
-            []
-
-dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a])
-dropCommonPrefix (left : lefts) (right : rights)
-    | left == right =
-        dropCommonPrefix lefts rights
-dropCommonPrefix left right =
-    (left, right)
-
-
-supportScriptAssetComponents :: [Text]
-supportScriptAssetComponents =
-    ["_static", "naproche-html.js"]
-
-percentEncodeUtf8 :: Text -> Text
-percentEncodeUtf8 =
-    Text.pack
-        . concatMap encodeByte
-        . ByteString.unpack
-        . TextEncoding.encodeUtf8
-
-encodeByte :: Word8 -> String
-encodeByte byte
-    | isUnreservedAscii byte =
-        [chr (fromIntegral byte)]
-    | otherwise =
-        [ '%'
-        , hexadecimalDigit (byte `div` 16)
-        , hexadecimalDigit (byte `mod` 16)
-        ]
-
-isUnreservedAscii :: Word8 -> Bool
-isUnreservedAscii byte =
-    isAsciiUpper byte
-        || isAsciiLower byte
-        || isAsciiDigit byte
-        || byte `elem` fmap (fromIntegral . fromEnum) ("-._~" :: String)
-
-isAsciiUpper :: Word8 -> Bool
-isAsciiUpper byte =
-    byte >= 65 && byte <= 90
-
-isAsciiLower :: Word8 -> Bool
-isAsciiLower byte =
-    byte >= 97 && byte <= 122
-
-isAsciiDigit :: Word8 -> Bool
-isAsciiDigit byte =
-    byte >= 48 && byte <= 57
-
-hexadecimalDigit :: Word8 -> Char
-hexadecimalDigit value
-    | value < 10 =
-        chr (fromIntegral value + fromEnum '0')
-    | otherwise =
-        chr (fromIntegral value - 10 + fromEnum 'A')