From 2cc8fb5c6890d2308eb19e46dab925dc7f3b2b56 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 1 Oct 2024 12:56:43 +0300 Subject: [PATCH] wip --- .../HBS2/Git/Web/Assets.hs | 2 +- .../assets/css/custom.css | 5 ++ .../HBS2/Git/Web/Html/Fixme.hs | 12 ++- .../HBS2/Git/Web/Html/Issue.hs | 30 ++++++- .../HBS2/Git/Web/Html/Parts/Blob.hs | 79 +++++++++++++++++++ .../HBS2/Git/Web/Html/Repo.hs | 44 +---------- hbs2-git-dashboard/hbs2-git-dashboard.cabal | 1 + 7 files changed, 126 insertions(+), 47 deletions(-) create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs b/hbs2-git-dashboard/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs index ccd5df10..6fa86812 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs +++ b/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") diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css index 615261b4..b7d9278a 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/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; diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs index 2a5904d2..c503afca 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs +++ b/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)))) diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs index 24a39fe2..bff792e0 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs +++ b/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 diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs new file mode 100644 index 00000000..cd74ac3b --- /dev/null +++ b/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 + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs index 764765cb..af38636e 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs +++ b/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 - diff --git a/hbs2-git-dashboard/hbs2-git-dashboard.cabal b/hbs2-git-dashboard/hbs2-git-dashboard.cabal index 4141c31f..212f4492 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard.cabal +++ b/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