From c3a90f70a0bbf0eb80cc146abf3b1ab498c8ecb1 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 29 Sep 2024 11:52:19 +0300 Subject: [PATCH] wip --- fixme-new/lib/Fixme/Run.hs | 9 +++ fixme-new/lib/Fixme/Run/Internal.hs | 2 +- fixme-new/lib/Fixme/State.hs | 77 +++++++++++++++---- fixme-new/lib/Fixme/Types.hs | 8 +- .../HBS2/Git/Web/Assets.hs | 2 +- .../assets/css/custom.css | 21 ++++- .../HBS2/Git/DashBoard/Fixme.hs | 20 ++++- .../HBS2/Git/Web/Html/Root.hs | 48 +++++++++++- 8 files changed, 164 insertions(+), 23 deletions(-) diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 52758393..a195ec49 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -383,6 +383,15 @@ runTop forms = do entry $ bindMatch "fixme:state:cleanup" $ nil_ $ const $ lift do cleanupDatabase + + entry $ bindMatch "fixme:state:count-by-attribute" $ nil_ $ \case + [StringLike s] -> lift do + rs <- countByAttribute (fromString s) + for_ rs $ \(n,v) -> do + liftIO $ print $ pretty n <+> pretty v + + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "fixme:git:import" $ nil_ $ const $ lift do import_ diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index d18955d2..49239352 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -298,7 +298,7 @@ scanFiles = do pure True -report :: (FixmePerks m, HasPredicate q) => Maybe FilePath -> q -> FixmeM m () +report :: (FixmePerks m, HasPredicate q, HasItemOrder q) => Maybe FilePath -> q -> FixmeM m () report t q = do tpl <- asks fixmeEnvTemplates >>= readTVarIO diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 6405c6b8..3b7d20a3 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -7,6 +7,7 @@ module Fixme.State , cleanupDatabase , listFixme , countFixme + , countByAttribute , insertFixme , insertFixmeExported , modifyFixme @@ -22,6 +23,9 @@ module Fixme.State , HasPredicate(..) , SelectPredicate(..) , HasLimit(..) + , HasItemOrder(..) + , ItemOrder(..) + , Reversed(..) , LocalNonce(..) , WithLimit(..) , QueryOffset(..) @@ -35,8 +39,6 @@ import Fixme.Config import HBS2.Base58 import HBS2.System.Dir -import Data.Config.Suckless hiding (key) -import Data.Config.Suckless.Syntax import DBPipe.SQLite hiding (field) import Data.HashSet (HashSet) @@ -44,23 +46,16 @@ import Data.HashSet qualified as HS import Data.Aeson as Aeson import Data.ByteString.Lazy qualified as LBS import Data.HashMap.Strict qualified as HM -import Text.InterpolatedString.Perl6 (q,qc) +import Text.InterpolatedString.Perl6 (qc) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Maybe import Data.List qualified as List -import Data.Either -import Data.List (sortBy,sortOn) -import Data.Ord -import Lens.Micro.Platform -import Data.Generics.Product.Fields (field) import Control.Monad.Trans.Maybe import Data.Coerce -import Data.Fixed import Data.Word (Word64) import System.Directory (getModificationTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import System.TimeIt -- TODO: runPipe-omitted -- runPipe нигде не запускается, значит, все изменения @@ -168,6 +163,17 @@ class HasPredicate a where class HasLimit a where limit :: a -> Maybe QueryLimitClause +data ItemOrder = Direct | Reverse + +class HasItemOrder a where + itemOrder :: a -> ItemOrder + itemOrder = const Direct + +newtype Reversed a = Reversed a + +instance HasItemOrder (Reversed a) where + itemOrder = const Reverse + -- TODO: move-to-db-pipe? newtype QueryOffset = QueryOffset Word64 deriving newtype (Show,Eq,Ord,Num,Enum,Integral,Real,ToField,FromField,Pretty) @@ -183,12 +189,27 @@ instance HasLimit () where data WithLimit q = WithLimit (Maybe QueryLimitClause) q +instance HasItemOrder q => HasItemOrder (WithLimit q) where + itemOrder (WithLimit _ q) = itemOrder q + +instance HasItemOrder [Syntax c] where + itemOrder = const Direct + +instance HasItemOrder () where + itemOrder = const Direct + instance HasPredicate q => HasPredicate (WithLimit q) where predicate (WithLimit _ query) = predicate query instance HasLimit (WithLimit a) where limit (WithLimit l _) = l +instance HasPredicate q => HasPredicate (Reversed q) where + predicate (Reversed q) = predicate q + +instance HasLimit q => HasLimit (Reversed q) where + limit (Reversed q) = limit q + data SelectPredicate = All | FixmeHashExactly Text @@ -371,10 +392,34 @@ countFixme = do withState $ select_ @_ @(Only Int) sql <&> maybe 0 fromOnly . headMay + +countByAttribute :: ( FixmePerks m + , MonadReader FixmeEnv m + ) + => FixmeAttrName + -> m [(FixmeAttrVal, Int)] +countByAttribute name = do + let sql = [qc| + + + select v, count(1) from object o + where not exists + ( select null from object o1 + where o1.o = o.o + and o1.k = 'deleted' and o1.v == 'true' + ) + and o.k = ? + group by v + + |] + + withState $ select sql (Only name) + listFixme :: ( FixmePerks m , MonadReader FixmeEnv m , HasPredicate q , HasLimit q + , HasItemOrder q ) => q -> m [Fixme] @@ -388,9 +433,13 @@ listFixme expr = do Just (o,l) -> ([qc|limit ? offset ?|] :: String, [Bound l, Bound o]) Nothing -> (mempty, []) + let o = case itemOrder expr of + Direct -> "asc" :: String + Reverse -> "desc" + let sql = [qc| with s1 as ( - select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob + select cast (json_insert(json_group_object(o.k, o.v), '$.fixme-timestamp', cast(max(o.w) as text)) as text) as blob from object o group by o.o ) @@ -399,8 +448,8 @@ listFixme expr = do {w} {present} order by - json_extract(s1.blob, '$.commit-time') asc nulls last, - json_extract(s1.blob, '$.w') asc nulls last + json_extract(s1.blob, '$.commit-time') {o} nulls last, + json_extract(s1.blob, '$.w') {o} nulls last {limitClause} |] @@ -414,7 +463,7 @@ getFixme :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeKey -> m (Maybe Fixme getFixme key = do let sql = [qc| - select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob + select cast (json_insert(json_group_object(o.k, o.v), '$.fixme-timestamp', cast(max(o.w) as text)) as text) as blob from object o where o.o = ? group by o.o diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index e8a0660f..a328a117 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -125,7 +125,7 @@ newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text } deriving stock (Data,Generic) newtype FixmeTimestamp = FixmeTimestamp Word64 - deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON) + deriving newtype (Eq,Ord,Show,Enum,Num,Integral,Real,ToField,FromField,ToJSON) deriving stock (Data,Generic) @@ -219,6 +219,7 @@ instance FromJSON Fixme where (FixmeAttrName (Aeson.toText k),) <$> case v of String x -> pure (FixmeAttrVal x) + Number x -> pure (FixmeAttrVal (Text.pack $ show x)) _ -> Nothing newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal) @@ -715,7 +716,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of (_,_) -> b fixmeDerivedFields :: Fixme -> Fixme -fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc +fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc <> fxTs where email = HM.lookup "commiter-email" (fixmeAttr fx) & maybe mempty (\x -> " <" <> x <> ">") @@ -741,6 +742,9 @@ fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc fxCo = maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter + fxTs = + maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "fixme-timestamp" (fromString (show c)) }) (fixmeTs fx) + fxMisc = fx & over (field @"fixmeAttr") (HM.insert "fixme-title" (FixmeAttrVal (coerce (fixmeTitle fx)))) 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 b2cd4339..1fba8801 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 = 3 +version = 6 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 049d23c4..ce2ef1ea 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 @@ -25,11 +25,11 @@ body>footer, body>header, body>main { padding-block: 0; -} +} header>nav { border-bottom: var(--pico-border-width) solid var(--pico-muted-border-color); -} +} .wrapper { display: flex; @@ -202,6 +202,23 @@ td.commit-hash { text-align: left; } +table.minimal { +} + +table.minimal tr td { + border: none; + padding: 0.15em; +} + +table.minimal tr { + border: none; +} + +table tr:hover { + background-color: #f1f1f1; +} + + pre > code.sourceCode { white-space: pre; position: relative; } pre > code.sourceCode > span { line-height: 1.25; } diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs index 03867e0d..fbe4c635 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs @@ -1,12 +1,16 @@ module HBS2.Git.DashBoard.Fixme ( F.HasPredicate(..) , F.HasLimit(..) + , HasItemOrder(..) + , ItemOrder(..) + , Reversed(..) , F.SelectPredicate(..) , WithLimit(..) , QueryOffset , QueryLimit , runInFixme , countFixme + , countFixmeByAttribute , listFixme , RunInFixmeError(..) , Fixme(..) @@ -27,7 +31,15 @@ import HBS2.Git.DashBoard.State import HBS2.OrDie import Fixme.State qualified as F -import Fixme.State (HasPredicate(..),HasLimit(..),WithLimit(..),QueryOffset,QueryLimit) +import Fixme.State ( HasPredicate(..) + , HasLimit(..) + , HasItemOrder(..) + , WithLimit(..) + , QueryOffset + , QueryLimit + , ItemOrder + , Reversed + ) import Fixme.Types import Fixme.Config @@ -94,6 +106,7 @@ listFixme :: ( DashBoardPerks m , MonadReader DashBoardEnv m , HasPredicate q , HasLimit q + , HasItemOrder q ) => RepoLww -> q -> m [Fixme] listFixme repo q = do runInFixme repo $ F.listFixme q @@ -108,4 +121,9 @@ countFixme repo = do & try @_ @SomeException <&> either (const Nothing) Just +countFixmeByAttribute :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> String -> m [(FixmeAttrVal, Int)] +countFixmeByAttribute repo name = do + runInFixme repo $ F.countByAttribute (fromString name) + & try @_ @SomeException + <&> fromRight mempty diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs index 151af197..726bb4cf 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs @@ -939,11 +939,13 @@ repoFixme :: ( MonadReader DashBoardEnv m repoFixme q lww = do + now <- liftIO $ getPOSIXTime <&> round + debug $ blue "repoFixme" <+> "LIMITS" <+> viaShow (limit q) let offset = maybe 0 fst (limit q) - fme <- lift $ listFixme (RepoLww lww) q + fme <- lift $ listFixme (RepoLww lww) (Reversed q) for_ fme $ \fixme -> do tr_ [class_ "commit-brief-title"] $ do @@ -955,7 +957,11 @@ repoFixme q lww = do toHtml (H $ fixmeTitle fixme) tr_ [class_ "commit-brief-details"] $ do td_ [colspan_ "3"] do - small_ "seconday shit" + mempty + + -- small_ do + -- for_ (fixmeTs fixme) $ \t0 -> do + -- toHtml ("updated " <> agePure (fromIntegral t0) now) unless (List.null fme) do tr_ [ class_ "commit-brief-last" @@ -1093,6 +1099,9 @@ repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m) repoPage IssuesTab lww _ = rootPage do topInfoBlock@TopInfoBlock{..} <- getTopInfoBlock lww + tot <- lift $ countFixme (RepoLww lww) + fmw <- lift $ countFixmeByAttribute (RepoLww lww) "workflow" + fmt <- lift $ countFixmeByAttribute (RepoLww lww) "fixme-tag" main_ [class_ "container-fluid"] do div_ [class_ "wrapper"] do @@ -1105,6 +1114,41 @@ repoPage IssuesTab lww _ = rootPage do repoTopInfoBlock lww topInfoBlock + div_ [class_ "info-block" ] do + + summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Tag" + + -- TODO: make-this-block-properly + + ul_ do + for_ fmt $ \(s,n) -> do + li_ [] $ small_ [] do + a_ [class_ "secondary"] do + span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $ + toHtml $ show $ pretty n + + span_ [] $ toHtml $ show $ pretty s + + summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Status" + + ul_ do + + li_ [] $ small_ [] do + a_ [class_ "secondary"] do + span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $ + toHtml $ show $ pretty (fromMaybe 0 tot) + + span_ [] $ toHtml $ show $ pretty "[all]" + + for_ fmw $ \(s,n) -> do + li_ [] $ small_ [] do + a_ [class_ "secondary"] do + span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $ + toHtml $ show $ pretty n + + span_ [] $ toHtml $ show $ pretty s + + div_ [class_ "content"] $ do section_ do