wip

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_
 

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

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

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

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")

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

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
 

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