diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css index 19ef4481..9b7a8329 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -318,4 +318,11 @@ nav[role="tab-control"] li.active { font-weight: 600; } +td.tree-locator { + border-bottom: none; +} + +td.tree-locator span { + margin-right: .5rem; +} diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index ffad1f7b..99889cd5 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -477,7 +477,7 @@ newtype TreeTree = TreeTree GitHash deriving newtype (FromField,ToField,Pretty) newtype TreeLevel = TreeLevel Int - deriving newtype (FromField,ToField,Pretty,Num,Enum) + deriving newtype (FromField,ToField,Pretty,Num,Enum,Real,Integral,Ord,Eq) newtype TreePath = TreePath FilePath deriving newtype (FromField,ToField,Pretty) @@ -505,6 +505,34 @@ selectParentTree co me = withState do {- HLINT ignore "Functor law" -} + +selectTreeLocator :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => TreeCommit + -> TreeTree + -> m [(TreeParent, TreeTree, TreeLevel, TreePath)] + +selectTreeLocator kommit tree = withState do + + let sql = [qc| +WITH RECURSIVE ParentTree AS ( + SELECT parent, tree, kommit, level, path + FROM tree + WHERE tree = ? AND kommit = ? + + UNION ALL + + SELECT t.parent, t.tree, t.kommit, t.level, t.path + FROM tree t + JOIN ParentTree pt ON t.tree = pt.parent AND t.kommit = pt.kommit + WHERE t.kommit = ? +) +SELECT parent, tree, level, path FROM ParentTree +ORDER BY level +|] + + select sql (tree, kommit, kommit) + + pattern TreeHash :: GitHash -> LBS8.ByteString pattern TreeHash hash <- (LBS8.words -> (_ : (fromStringMay . LBS8.unpack -> Just hash) : _)) @@ -570,3 +598,5 @@ buildCommitTreeIndex dir = do insertProcessed hkey + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs index e09167ae..a88c252b 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs @@ -21,11 +21,13 @@ import Data.Word import Data.Either import Safe import Data.List (sortOn) +import Data.List qualified as List import Data.Ord (comparing, Down(..)) import Skylighting.Core qualified as Sky import Skylighting qualified as Sky +import Lens.Micro.Platform import Streaming.Prelude qualified as S rootPath :: [String] -> [String] @@ -215,6 +217,12 @@ repoRefs lww refs = do ] (toHtml $ show $ pretty h) +showRefsHtmxAttribs :: String -> [Attribute] +showRefsHtmxAttribs repo = + [ hxGet_ (path ["repo", repo, "refs"]) + , hxTarget_ "#repo-tab-data" + ] + repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> GitHash -- ^ this @@ -225,6 +233,8 @@ repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) repoTree lww co root tree back' = do + let repo = show $ pretty $ lww + let syntaxMap = Sky.defaultSyntaxMap let co_ = show $ pretty co @@ -235,7 +245,32 @@ repoTree lww co root tree back' = do tpOrder Blob = 1 tpOrder _ = 2 + locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root) + + let prefixSlash x = if fromIntegral x > 1 then span_ "/" else "" + let showRoot = + [ hxGet_ (path ["repo", repo, "tree", co_, co_]) + , hxTarget_ "#repo-tab-data" + , href_ "#" + ] + table_ [] do + + tr_ do + td_ [class_ "tree-locator", colspan_ "3"] do + span_ [] $ a_ (showRefsHtmxAttribs repo <> [href_ "#" ]) $ toHtml (take 10 repo <> "..") + span_ [] "/" + span_ [] $ a_ showRoot $ toHtml (take 10 co_ <> "..") + span_ [] "/" + for_ locator $ \(_,this,level,name) -> do + prefixSlash level + let uri = path [ "repo", show $ pretty lww, "tree", co_, show (pretty this) ] + span_ [] do + a_ [ href_ "#" + , hxGet_ uri + , hxTarget_ "#repo-tab-data" + ] (toHtml (show $ pretty name)) + tr_ mempty do for_ back' $ \root -> do @@ -347,9 +382,7 @@ repoPage it@RepoListItem{..} = rootPage do repoMenuItem [ ] "commits" - repoMenuItem [ hxGet_ (path ["repo", repo, "refs"]) - , hxTarget_ "#repo-tab-data" - ] "tree" + repoMenuItem (showRefsHtmxAttribs repo) "tree" section_ [id_ "repo-data"] do h1_ (toHtml $ rlRepoName)