Skip to content

Commit 48decfd

Browse files
hvrhvr
committed
Merge PR #67 (improve report buildmatrix view)
2 parents 22320bc + 87f9d13 commit 48decfd

File tree

2 files changed

+117
-80
lines changed

2 files changed

+117
-80
lines changed

‎src-ui.v3/src/Main.hs‎

Lines changed: 108 additions & 79 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@
1919
--
2020
module Main (main) where
2121

22+
import Control.Monad (sequence_)
2223
import Data.Aeson (FromJSON)
2324
import qualified Data.Aeson as J
2425
import qualified Data.Aeson.Types as J
@@ -420,9 +421,14 @@ app dynFrag = do
420421

421422
el "hr" blank
422423

423-
evCellClick <- reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo
424-
425-
dynCellClick <- holdDyn Nothing (Just <$> evCellClick)
424+
evCC <- dyn $ reportTableWidget <$> dynRepSum
425+
<*> dynQRows
426+
<*> dynWorkers
427+
<*> dynHist
428+
<*> dynInfo
429+
evCellClick <- switchHold never evCC
430+
431+
dynCellClick <- holdDyn Nothing (Just . _unCellTable <$> evCellClick) -- . _unCellTable
426432

427433
let dynCell' = mergeCellId pn <$> dynCellClick <*> dynIdxSt
428434

@@ -530,92 +536,121 @@ packagesPageWidget dynPackages dynTags dynPkgTags = do
530536
V.filter (tagContained st dpt) pkg
531537

532538

533-
reportTableWidget :: forall t m . (SetRoute t FragRoute m, MonadHold t m, PostBuild t m, DomBuilder t m, Reflex t)
534-
=> Dynamic t PkgIdxTsReport
535-
-> Dynamic t (Vector QEntryRow)
536-
-> Dynamic t (Vector WorkerRow)
537-
-> Dynamic t (Vector PkgHistoryEntry)
538-
-> Dynamic t ControllerInfo
539-
-> m (Event t (Ver,CompilerID))
540-
reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo = joinE =<< go
541-
where
542-
go = dyn $ do
543-
PkgIdxTsReport{..} <- dynRepSum
544-
qrowsAll <- dynQRows
545-
wrowsAll <- dynWorkers
546-
hrowsAll <- dynHist
547-
ControllerInfo{..} <- dynInfo
548-
let activeHcs = [ k | (k,CompilerInfo { ciActive = True }) <- Map.toDescList ciCompilers ]
539+
reportTableWidget :: forall t m. ( SetRoute t FragRoute m, MonadHold t m, PostBuild t m, DomBuilder t m, Reflex t)
540+
=> PkgIdxTsReport
541+
-> (Vector QEntryRow)
542+
-> (Vector WorkerRow)
543+
-> (Vector PkgHistoryEntry)
544+
-> ControllerInfo
545+
-> m (Event t CellTable)
546+
reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo = do
547+
let PkgIdxTsReport{..} = dynRepSum
548+
qrowsAll = dynQRows
549+
wrowsAll = dynWorkers
550+
hrowsAll = dynHist
551+
ControllerInfo{..} = dynInfo
552+
553+
let activeHcs = [ k | (k,CompilerInfo { ciActive = True }) <- Map.toDescList ciCompilers ]
549554

550555

551-
let hcvsLR = computeLR pitrHcversions activeHcs
552-
hcvs = applyLR hcvsLR pitrHcversions activeHcs
556+
let (Just defVer) = verFromText "0"
557+
hcvsLR = computeLR pitrHcversions activeHcs
558+
hcvs = applyLR hcvsLR pitrHcversions activeHcs
553559

554-
let vmap = Map.mergeWithKey (\_ (t,u) e -> Just (t,u,applyLR hcvsLR e emptyActive)) (fmap (\(t,u) -> (t,u,emptyHcvs))) (const mempty)
555-
vmap0 pitrPkgversions
560+
let emptyHcvs = hcvs $> emptyCellReportSummary
561+
emptyActive = activeHcs $> emptyCellReportSummary
556562

557-
emptyHcvs = hcvs $> emptyCellReportSummary
558-
emptyActive = activeHcs $> emptyCellReportSummary
563+
vmap = Map.mergeWithKey (\_ (t,u) e -> Just (t,u,applyLR hcvsLR e emptyActive)) (fmap (\(t,u) -> (t,u,emptyHcvs))) (const mempty)
564+
vmap0 pitrPkgversions
559565

560-
vmap0 = Map.fromList [ (v,(t,u)) | PkgHistoryEntry t v 0 u <- V.toList hrowsAll ]
566+
vmap0 = Map.fromList [ (v,(t,u)) | PkgHistoryEntry t v 0 u <- V.toList hrowsAll ]
561567

562-
let inQueue = not (null [ () | QEntryRow{..} <- V.toList qrowsAll, qrIdxstate == pitrIdxstate ])
568+
let inQueue = not (null [ () | QEntryRow{..} <- V.toList qrowsAll, qrIdxstate == pitrIdxstate ])
563569

564-
let wip = [ (pv,hcv) | WorkerRow{..} <- V.toList wrowsAll
570+
let wip = [ (pv,hcv) | WorkerRow{..} <- V.toList wrowsAll
565571
, wrIdxState == Just pitrIdxstate
566572
, Just pv <- [wrPkgversion]
567573
, Just hcv <- [wrHcversion]
568574
]
569575

570-
let pn' = pkgNToText pitrPkgname
576+
let pn' = pkgNToText pitrPkgname
571577

572578
-- TODO: push Dynamics into cells; the table dimensions are semi-static
573-
pure $ do
574-
el "table" $ do
575-
el "thead" $ do
576-
el "tr" $ do
577-
el "th" blank
578-
forM_ hcvs $ \cid -> el "th" (text (compilerIdToText cid))
579-
el "th" blank
580-
el "th" (text "released")
581-
el "th" (text "uploader")
582-
583-
el "tbody" $ do
584-
evsRows <- forM (Map.toDescList vmap) $ \(pv,(t,u,cs)) -> do
585-
let tooSoon = t > pitrIdxstate
586-
tooSoonAttr = if tooSoon then ("style" =: "opacity:0.5;") else mempty
587-
elAttr "tr" tooSoonAttr $ do
588-
elAttr "th" ("style" =: "text-align:left;") $
589-
elAttr "a" ("href" =: (mconcat [ "https://hackage.haskell.org/package/", pn',"-",verToText pv,"/",pn',".cabal/edit" ])) $
590-
text (verToText pv)
591-
evsRow1 <- forM (zip cs hcvs) $ \(x,hcv) -> do
592-
let (cellAttr,cellText) = case crsT x of
593-
Nothing
594-
| tooSoon -> ("class" =: "stat-unknown", el "b" (text ""))
595-
| (pv,hcv) `elem` wip -> ("class" =: "stat-wip", el "b" (text "WIP"))
596-
| inQueue -> ("class" =: "stat-queued", text "queued")
597-
_ -> ("class" =: (snd $ fmtCRS x), (text $ fst $ fmtCRS x))
598-
599-
(l,_) <- elAttr' "td" (("style" =: if tooSoon then "cursor: not-allowed;" else "cursor: cell;") <> cellAttr) cellText
600-
601-
pure $ ((pv,hcv) <$ (if tooSoon then never else domEvent Click l) :: Event t (Ver,CompilerID))
602-
603-
elAttr "th" ("style" =: "text-align:left;") (text (verToText pv))
604-
el "td" $ text (pkgIdxTsToText t)
605-
el "td" $ routeLink False ("#/user/" <> u) (text u)
606-
607-
pure (leftmost evsRow1)
608-
pure (leftmost evsRows) -- main "return" value
579+
el "table" $ do
580+
el "thead" $ do
581+
el "tr" $ do
582+
el "th" blank
583+
forM_ hcvs $ \cid -> el "th" (text (compilerIdToText cid))
584+
el "th" blank
585+
el "th" (text "released")
586+
el "th" (text "uploader")
587+
588+
el "tbody" $ do
589+
evrows <- sequence . List.reverse . snd $ List.mapAccumL (accumTableRow pn' hcvs pitrIdxstate wip inQueue) (defVer, ((PkgIdxTs 0), "", [])) (Map.toAscList vmap)
590+
pure (leftmost evrows)
591+
592+
accumTableRow :: forall t m. (SetRoute t FragRoute m, DomBuilder t m, Reflex t)
593+
=> Text
594+
-> [CompilerID]
595+
-> PkgIdxTs
596+
-> [(Ver,CompilerID)]
597+
-> Bool
598+
-> (Ver, (PkgIdxTs, UserName, [CellReportSummary]))
599+
-> (Ver, (PkgIdxTs, UserName, [CellReportSummary]))
600+
-> ((Ver, (PkgIdxTs, UserName, [CellReportSummary])), m (Event t CellTable))
601+
accumTableRow pn' hcvs pkgIdxTs wip inQ prevVer currVer =
602+
let pkgVer = const currVer prevVer
603+
(pcVer, (t, u, cs)) = pkgVer
604+
(ppVer, _) = prevVer
605+
in (pkgVer, (renderRow pn' hcvs pkgIdxTs wip inQ ppVer pcVer t u cs))
606+
607+
renderRow :: forall t m. (SetRoute t FragRoute m, DomBuilder t m, Reflex t)
608+
=> Text
609+
-> [CompilerID]
610+
-> PkgIdxTs
611+
-> [(Ver,CompilerID)]
612+
-> Bool
613+
-> (Ver)
614+
-> (Ver)
615+
-> PkgIdxTs
616+
-> UserName
617+
-> [CellReportSummary]
618+
-> m (Event t CellTable)
619+
renderRow pn' hcvs pitrIdxstate wip inQueue ppV pcV t u cs = do
620+
let tooSoon = t > pitrIdxstate
621+
tooSoonAttr = if tooSoon then ("style" =: "opacity:0.5;") else mempty
622+
elAttr "tr" tooSoonAttr $ do
623+
elAttr "th" ("style" =: "text-align:left;") $ do
624+
let id2Ver = if verToText ppV == "0" then "" else "&id2=" <> verToText ppV
625+
elAttr "a" ("href" =: (mconcat [ "http://hdiff.luite.com/cgit/", pn', "/diff?id=",verToText pcV, id2Ver ])) $
626+
text "Δ"
627+
elAttr "a" ("href" =: (mconcat [ "https://hackage.haskell.org/package/", pn',"-",verToText pcV,"/",pn',".cabal/edit" ])) $
628+
text (verToText pcV)
629+
evsRow1 <- forM (zip cs hcvs) $ \(x,hcv) -> do
630+
let (cellAttr,cellText) = case crsT x of
631+
Nothing
632+
| tooSoon -> ("class" =: "stat-unknown", el "b" (text ""))
633+
| (pcV,hcv) `elem` wip -> ("class" =: "stat-wip", el "b" (text "WIP"))
634+
| inQueue -> ("class" =: "stat-queued", text "queued")
635+
_ -> ("class" =: (snd $ fmtCRS x), (text $ fst $ fmtCRS x))
636+
637+
(l,_) <- elAttr' "td" (("style" =: if tooSoon then "cursor: not-allowed;" else "cursor: cell;") <> cellAttr) cellText
638+
639+
pure $ ((CellTable (pcV,hcv)) <$ (if tooSoon then never else domEvent Click l) :: Event t CellTable)
640+
641+
elAttr "th" ("style" =: "text-align:left;") (text (verToText pcV))
642+
el "td" $ text (pkgIdxTsToText t)
643+
el "td" $ routeLink False ("#/user/" <> u) (text u)
644+
pure (leftmost evsRow1)
609645

610646
reportDetailWidget :: (SupportsServantReflex t m, MonadFix m, PostBuild t m, DomBuilder t m, Reflex t, MonadHold t m, Adjustable t m) => Dynamic t (Maybe (PkgN,Ver,CompilerID,PkgIdxTs)) -> m ()
611647
reportDetailWidget dynCellId = do
612-
613648
evDetails <- getPackageReportDetail (maybe (Left "") (Right . (^. _1)) <$> dynCellId)
614649
(maybe (Left "") (Right . (^. _4)) <$> dynCellId)
615650
(maybe (Left "") (Right . (^. _2)) <$> dynCellId)
616651
(maybe (Left "") (Right . (^. _3)) <$> dynCellId)
617652
(updated dynCellId $> ())
618-
653+
619654
dynRepTy <- holdDyn CRTna (crdType <$> evDetails)
620655
dynSErr <- holdDyn "" ((fromMaybe "" . crdSolverErr) <$> evDetails)
621656
dynSols <- holdDyn [] ((fromMaybe [] . crdUnits) <$> evDetails)
@@ -633,23 +668,20 @@ reportDetailWidget dynCellId = do
633668
el "h3" (dynText $ (\xs -> tshow (length xs) <> " solution(s) found") <$> dynSols)
634669

635670
_ <- simpleList dynSols $ \dynYs -> elAttr "div" ("style" =: "border-style: solid") $ do
636-
simpleList (Map.toList <$> dynYs) $ \dynY -> elAttr "div" ("style" =: "border-style: dotted") $ do
637-
evUpd <- getPostBuild
638-
671+
listWithKey dynYs $ \uuid dynY -> elAttr "div" ("style" =: "border-style: dotted") $ do
672+
evPB0 <- getPostBuild
673+
evInfo <- getUnitInfo (Right <$> constDyn uuid) evPB0
639674
el "h4" $ do
640-
el "tt" $ display (fst <$> dynY)
675+
el "tt" $ display (constDyn uuid)
641676
text " "
642677
el "em" $ do
643678
text "["
644-
dynText (maybe "?" (T.drop 2 . tshow) . snd <$> dynY)
679+
dynText (maybe "?" (T.drop 2 . tshow) <$> dynY)
645680
text "]"
646681

647-
evInfo <- getUnitInfo (Right . fst <$> dynY) evUpd
648-
649682
dynLogmsg <- holdDyn "-" ((fromMaybe "" . uiiLogmsg) <$> evInfo)
650683

651-
elDynAttr "pre" (st2attr . snd <$> dynY) (dynText dynLogmsg)
652-
684+
elDynAttr "pre" (st2attr <$> dynY) (dynText dynLogmsg)
653685
pure ()
654686

655687
where
@@ -730,9 +762,6 @@ pkgTagList m = Map.fromListWith (List.++) $ do
730762
v <- (V.toList vs)
731763
pure $ (v, [k])
732764

733-
joinE :: forall t m a. (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a)
734-
joinE = fmap switch . hold never
735-
736765
clickElement_ :: forall t m. (DomBuilder t m, PostBuild t m) => Text -> Text -> m (Event t ())
737766
clickElement_ elm t = do
738767
let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

‎src-ui.v3/src/PkgId.hs‎

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE TemplateHaskell #-}
34

45
-- |
56
-- Copyright: © 2018 Herbert Valerio Riedel
@@ -24,7 +25,7 @@ module PkgId
2425

2526
-- , UnitID(..), unUnitID
2627
-- , unitIDFromUnitId
27-
28+
, CellTable(..) --, HasCellTable
2829
, CompilerID, compilerVer
2930
, compilerIdFromText
3031
, compilerIdToText
@@ -172,7 +173,14 @@ matchesEmpty :: Matches
172173
matchesEmpty = Matches { matchesInput = T.empty, matchesExact = Map.empty, matchesInfix = Map.empty}
173174

174175
---------------------------------
176+
data CellTable = CellTable { _unCellTable :: (Ver, CompilerID) }
177+
deriving (Eq, Ord)
178+
179+
instance Semigroup CellTable where
180+
_ <> (CellTable a2) = CellTable a2
181+
175182

183+
--makeClassy ''CellTable
176184

177185

178186

0 commit comments

Comments
 (0)