repo-tree-navigation

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;
+}
 

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
 
+
+

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)