wip

hbs2-git-dashboard/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs

@@ -8,7 +8,7 @@ import Text.InterpolatedString.Perl6 (qc)
 import Lucid.Base
 
 version :: Int
-version = 7
+version = 8
 
 assetsDir :: [(FilePath, ByteString)]
 assetsDir = $(embedDir "hbs2-git-dashboard-assets/assets")

hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css

@@ -35,6 +35,11 @@ header>nav {
   display: flex;
 }
 
+
+.hidden{
+  display: none;
+}
+
 .sidebar {
   width: 20rem;
   flex-shrink: 0;

hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs

@@ -65,8 +65,10 @@ repoFixme q@(FromParams p') lww = do
          toHtml (H $ fixmeTitle fixme)
     tr_ [class_ "commit-brief-details"] $ do
       td_ [colspan_ "3"] do
-        let mco = fixmeGet "commit-time" fixme & pretty & show & readMay @Word64
+        let mco  = fixmeGet "commit-time" fixme & pretty & show & readMay @Word64
         let mw   = fixmeGet "workflow" fixme <&> coerce @_ @Text
+        let cla = fixmeGet  "class" fixme <&> coerce @_ @Text
+        let mn = liftA2 (-) (fixmeEnd fixme) (fixmeStart fixme)
 
         small_ do
           for_ mw $ \w -> do
@@ -76,6 +78,14 @@ repoFixme q@(FromParams p') lww = do
           for_ mco $ \co ->
             span_ [] $ toHtml $ show $ brackets ("commited" <+> pretty (agePure co now))
 
+          for_ cla $ \c ->
+            span_ [] $ toHtml $ show $ brackets (pretty c)
+
+          for_ mn $ \n -> do
+            when (n > 0) do
+              span_ [] $ toHtml $ show $ brackets ("text:" <+> pretty n)
+
+
   unless (List.null fme) do
     tr_ [ class_ "commit-brief-last"
         , hxGet_ (toURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx p (RepoLww lww))))

hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs

@@ -14,6 +14,7 @@ import HBS2.Git.Web.Html.Types
 import HBS2.Git.Web.Html.Root
 import HBS2.Git.Web.Html.Markdown
 import HBS2.Git.Web.Html.Fixme()
+import HBS2.Git.Web.Html.Parts.Blob
 
 import Data.Text qualified as Text
 import Lucid.Base
@@ -97,6 +98,9 @@ issuePage repo@(RepoLww lww) f = rootPage do
                 span_ [] $ toHtml (coerce @_ @Text $ fixmeTitle fxm)
 
             toHtml (issueOptionalArg fxm "workflow")
+            toHtml (issueOptionalArg fxm "class")
+            toHtml (issueOptionalArg fxm "assigned")
+            toHtml (issueOptionalArg fxm "scope")
             toHtml (issueOptionalArg fxm "committer-name")
             toHtml (issueOptionalArg fxm "commit")
 
@@ -111,7 +115,9 @@ issuePage repo@(RepoLww lww) f = rootPage do
                       toHtml $ show $ pretty file
                   Just (BlobInfo{}) -> do
                     td_ do
-                      a_ [ href_ "#" ] do
+                      a_ [ href_ "#"
+                         , hyper_ "on click toggle .hidden on #issue-blob"
+                         ] do
                         toHtml $ show $ pretty file
 
             -- toHtml (issueOptionalArg fxm "file")
@@ -119,6 +125,26 @@ issuePage repo@(RepoLww lww) f = rootPage do
         section_ [class_ "lim-text"] do
           toHtmlRaw $ renderMarkdown txt
 
-
+        let s0 = fixmeStart fxm
+        let e0 = fixmeEnd fxm
+        let n  = liftA2 (-) e0 s0 & fromMaybe 0
+
+        let hide = if n > 3 then "hidden" else ""
+
+        section_ [id_ "issue-blob", class_ hide ] $ void $ runMaybeT do
+          blob <- toMPlus mbBlob
+          s <- s0 & toMPlus <&> fromIntegral
+          e <- e0 & toMPlus <&> fromIntegral
+
+          let before = max 0 (s - 2)
+          let seize  = max 1 (e - s + 100)
+
+          debug $ "PREPROCESS BLOB" <+> pretty before <+> pretty seize
+
+          lift $ doRenderBlob' (pure mempty) (trim before seize) lww blob
+
+    where
+      trim before seize txt =
+        Text.lines txt & drop before & take seize & Text.unlines
 
 

hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs

@@ -0,0 +1,79 @@
+module HBS2.Git.Web.Html.Parts.Blob where
+
+import HBS2.Git.DashBoard.Prelude
+import HBS2.Git.DashBoard.State
+import HBS2.Git.DashBoard.Types
+
+import HBS2.Git.Web.Html.Markdown
+
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as Text
+import Lucid.Base
+import Lucid.Html5 hiding (for_)
+
+import Skylighting qualified as Sky
+import Skylighting.Tokenizer
+import Skylighting.Format.HTML.Lucid as Lucid
+
+import Control.Applicative
+
+{-HLINT ignore "Functor law"-}
+
+
+doRenderBlob :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
+             =>  (Text -> HtmlT m ())
+             -> LWWRefKey HBS2Basic
+             -> BlobInfo
+             -> HtmlT m ()
+
+doRenderBlob fallback = doRenderBlob' fallback id
+
+doRenderBlob' :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
+             =>  (Text -> HtmlT m ())
+             -> (Text -> Text)
+             -> LWWRefKey HBS2Basic
+             -> BlobInfo
+             -> HtmlT m ()
+
+doRenderBlob' fallback preprocess lww BlobInfo{..} = do
+  fromMaybe mempty <$> runMaybeT do
+
+    guard (blobSize < 10485760)
+
+    let fn = blobName & coerce
+    let syntaxMap = Sky.defaultSyntaxMap
+
+    syn <- ( Sky.syntaxesByFilename syntaxMap fn
+               & headMay
+           ) <|> Sky.syntaxByName syntaxMap "default"
+           & toMPlus
+
+    lift do
+
+      txt <- lift (readBlob lww blobHash)
+                <&> LBS.toStrict
+                <&> Text.decodeUtf8
+
+      case blobSyn of
+        BlobSyn (Just "markdown") -> do
+
+          div_ [class_ "lim-text"] do
+            toHtmlRaw (renderMarkdown' txt)
+
+        _ -> do
+
+          txt <- lift (readBlob lww blobHash)
+                    <&> LBS.toStrict
+                    <&> Text.decodeUtf8
+                    <&> preprocess
+
+          let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
+
+          case tokenize config syn txt of
+            Left _ -> fallback txt
+            Right tokens -> do
+              let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color  }
+              let code = renderText (Lucid.formatHtmlBlock fo tokens)
+              toHtmlRaw code
+
+

hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs

@@ -17,12 +17,11 @@ import HBS2.Git.Web.Html.Types
 import HBS2.Git.Web.Html.Root
 import HBS2.Git.Web.Html.Markdown
 import HBS2.Git.Web.Html.Parts.Issues.Sidebar
+import HBS2.Git.Web.Html.Parts.Blob
 
 
 import Data.Map qualified as Map
-import Data.ByteString.Lazy qualified as LBS
 import Data.Text qualified as Text
-import Data.Text.Encoding qualified as Text
 import Lucid.Base
 import Lucid.Html5 hiding (for_)
 import Lucid.Htmx
@@ -31,7 +30,6 @@ import Skylighting qualified as Sky
 import Skylighting.Tokenizer
 import Skylighting.Format.HTML.Lucid as Lucid
 
-import Control.Applicative
 import Data.Either
 import Data.List qualified as List
 import Data.List (sortOn)
@@ -594,45 +592,5 @@ repoBlob lww co tree bi@BlobInfo{..} = do
 
   doRenderBlob (pure mempty) lww bi
 
-doRenderBlob fallback lww BlobInfo{..} = do
-  fromMaybe mempty <$> runMaybeT do
-
-    guard (blobSize < 10485760)
-
-    let fn = blobName & coerce
-    let syntaxMap = Sky.defaultSyntaxMap
-
-    syn <- ( Sky.syntaxesByFilename syntaxMap fn
-               & headMay
-           ) <|> Sky.syntaxByName syntaxMap "default"
-           & toMPlus
-
-    lift do
-
-      txt <- lift (readBlob lww blobHash)
-                <&> LBS.toStrict
-                <&> Text.decodeUtf8
-
-      case blobSyn of
-        BlobSyn (Just "markdown") -> do
-
-          div_ [class_ "lim-text"] do
-            toHtmlRaw (renderMarkdown' txt)
-
-        _ -> do
-
-          txt <- lift (readBlob lww blobHash)
-                    <&> LBS.toStrict
-                    <&> Text.decodeUtf8
-
-          let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
-
-          case tokenize config syn txt of
-            Left _ -> fallback txt
-            Right tokens -> do
-              let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color  }
-              let code = renderText (Lucid.formatHtmlBlock fo tokens)
-              toHtmlRaw code
-
 
 

hbs2-git-dashboard/hbs2-git-dashboard.cabal

@@ -145,6 +145,7 @@ library hbs2-git-dashboard-core
       HBS2.Git.Web.Html.Types
       HBS2.Git.Web.Html.Parts.TopInfoBlock
       HBS2.Git.Web.Html.Parts.Issues.Sidebar
+      HBS2.Git.Web.Html.Parts.Blob
       HBS2.Git.Web.Html.Markdown
       HBS2.Git.Web.Html.Root
       HBS2.Git.Web.Html.Issue