Skip to content

Commit 5b30ff8

Browse files
hvrhvr
authored
Merge PR #66 (refactor/remove away dyn use)
2 parents 5d2554f + be95615 commit 5b30ff8

File tree

4 files changed

+132
-101
lines changed

4 files changed

+132
-101
lines changed

‎src-ui.v3/matrix-ui.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ executable matrix-ui
1717
main-is: Main.hs
1818
other-modules: API
1919
, PkgId
20+
, Router
2021

2122
mixins: base hiding (Prelude)
2223

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

Lines changed: 45 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,8 @@ import qualified Data.Vector as V
4949
import qualified Data.Version as Ver
5050
import GHC.Generics (Rep)
5151
import qualified GHCJS.DOM.Types as DOM
52+
import qualified GHCJS.DOM.Window as Window
53+
import qualified GHCJS.DOM as DOM
5254
import Language.Javascript.JSaddle (jsNull)
5355
import Network.URI
5456
--import Reflex.Dom
@@ -63,6 +65,7 @@ import Reflex.Time
6365
import Reflex.Class
6466
import Servant.API
6567
import Servant.Reflex
68+
import qualified Text.Read as R
6669

6770
import API
6871
import PkgId
@@ -107,15 +110,13 @@ utc2unix x = ceiling (realToFrac (utcTimeToPOSIXSeconds x) :: Double)
107110

108111
bodyElement4 :: forall t m . (SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace) => m ()
109112
bodyElement4 = do
110-
--dynLoc <- browserHistoryWith getLocationUri
111-
--let dynFrag = decodeFrag . T.pack . uriFragment <$> dynLoc
112113
_ <- runRouteViewT app
114+
115+
--(result, changeStateE) <- runSetRouteT $ app RouteHome
113116
pure ()
114-
-- ticker1 <- tickLossy 1 =<< liftIO getCurrentTime
115-
-- ticker1cnt <- count ticker1
116117

117118
app :: forall t m. (SetRoute t FragRoute m, SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace)
118-
=> Dynamic t FragRoute
119+
=> FragRoute -- Dynamic t FragRoute
119120
-> m ()
120121
app dynFrag = do
121122
-- top-level PB event
@@ -156,8 +157,8 @@ app dynFrag = do
156157
_ <- searchBoxWidget dynPackages0
157158
el "hr" blank
158159

159-
_ <- dyn $ dynFrag >>= \case
160-
RouteHome -> pure $ do
160+
_ <- case dynFrag of --dyn $ dynFrag >>= \case
161+
RouteHome -> do
161162
elAttr "div" (("id" =: "page-home") <> ("class" =: "page")) $ do
162163
divClass "leftcol" $ do
163164
elAttr "h2" ("class" =: "main-header") $ text "Welcome"
@@ -205,7 +206,7 @@ app dynFrag = do
205206
text "Cookbook for common build failures"
206207
pure ()
207208

208-
RouteQueue -> pure $ do
209+
RouteQueue -> do
209210
evPB <- getPostBuild
210211

211212
let dynUnixTime = utc2unix <$> dynUTCTime
@@ -320,7 +321,7 @@ app dynFrag = do
320321
pure ()
321322
pure ()
322323

323-
RoutePackages -> pure $ do
324+
RoutePackages -> do
324325
el "h1" $ text "Packages"
325326
evPB <- getPostBuild
326327
evTags<- getTags (constDyn $ QParamSome False) evPB
@@ -330,23 +331,24 @@ app dynFrag = do
330331
let dynPkgTags = pkgTagList <$> dynTagPkgs
331332
packagesPageWidget dynPackages0 dynTags dynPkgTags
332333

333-
RoutePackage (pn, idxSt) -> pure $ do
334-
334+
RoutePackage (PkgN pkgUri) -> do
335+
let pn = PkgN $ T.takeWhile (/='@') pkgUri
336+
(intIdx :: Maybe Int) = R.readMaybe (T.unpack (T.takeWhileEnd (/='@') pkgUri))
337+
idxSt = PkgIdxTs $ fromMaybe 0 intIdx
335338
el "h2" $ text (pkgNToText pn)
336339
el "p" $ el "em" $ elAttr "a" ("href" =: ("https://hackage.haskell.org/package/" <> pkgNToText pn)) $
337340
do text "(view on Hackage)"
338341

339342
evPB <- getPostBuild
340343
let
341-
dynIdxStLast' = fmap (\x -> M.fromMaybe x idxSt) dynIdxStLast
342344
-- single-shot requests
343345
evReports <- getPackageReports (constDyn $ Right pn) evPB
344346
dynReports <- holdDyn mempty evReports
345347

346348
evInfo <- getInfo evPB
347349
dynInfo <- holdDyn (ControllerInfo mempty) evInfo
348350

349-
evHist <- getPackageHistory (constDyn $ Right pn) (leftmost [updated dynIdxStLast' $> (), evPB])
351+
evHist <- getPackageHistory (constDyn $ Right pn) (leftmost [updated dynIdxStLast $> (), evPB])
350352
dynHist <- holdDyn mempty evHist
351353

352354
evPkgTags <- getPackageTags (constDyn $ Right pn) evPB
@@ -364,29 +366,25 @@ app dynFrag = do
364366
text " for latest index-state "
365367
dynText (pkgIdxTsToText <$> dynIdxStLast)
366368

367-
putQueue (constDyn $ Right pn) (Right <$> dynIdxStLast') (constDyn $ Right (QEntryUpd (-1))) evQButton
368-
369-
370-
let xs = Map.fromList . fmap (\x -> (x, pkgIdxTsToText x)) . Set.toList <$> dynReports
371-
x0 = (\s -> if Set.null s then PkgIdxTs 0
372-
else (findInitialDropDown idxSt s)) <$> dynReports
373-
374-
375-
let ddCfg = DropdownConfig (updated x0) (constDyn mempty)
369+
putQueue (constDyn $ Right pn) (Right <$> dynIdxStLast) (constDyn $ Right (QEntryUpd (-1))) evQButton
376370

377371
let inputAttr = ("class" =: "tag-name") <> ("placeholder" =: "insert tag")
378372
iCfg = TextInputConfig "tag-name" "" never (constDyn inputAttr)
373+
let xs = Map.fromList . fmap (\x -> (x, pkgIdxTsToText x)) . Set.toList <$> dynReports
379374

380-
ddReports <- el "p" $ do
375+
ddReports <- el "p" $ mdo
376+
let maxId = findInitialDropDown idxSt <$> dynReports
377+
ddCfg = (def :: DropdownConfig t PkgIdxTs)
378+
& dropdownConfig_setValue .~ (updated maxId)
379+
initId <- sample $ current maxId
381380
evQButton <- button "Queue a build"
382381
text " for the index-state "
383-
uniqReport <- holdUniqDyn dynReports
384-
tmp <- routePkgIdxTs pn (PkgIdxTs 0) uniqReport xs ddCfg
382+
dd <- dropdown initId xs ddCfg
383+
routePkgIdxTs pn dynReports (dd ^. dropdown_value)
385384
text " shown below"
385+
_ <- putQueue (constDyn $ Right pn) (Right <$> _dropdown_value dd) (constDyn $ Right (QEntryUpd (-1))) evQButton
386386

387-
_ <- putQueue (constDyn $ Right pn) (Right <$> _dropdown_value tmp) (constDyn $ Right (QEntryUpd (-1))) evQButton
388-
389-
pure tmp
387+
pure dd
390388

391389
elClass "p" "tagging" $ mdo
392390
let evMapTags = Map.fromList . (fmap (\t -> (t,t))) . (fmap tagNToText) . V.toList <$> evPkgTags
@@ -434,7 +432,7 @@ app dynFrag = do
434432

435433
pure ()
436434

437-
RouteUser u -> pure $ do
435+
RouteUser u -> do
438436
el "h1" (text u)
439437

440438
evPB <- getPostBuild
@@ -447,7 +445,7 @@ app dynFrag = do
447445

448446
pure ()
449447

450-
RouteUnknown frag -> pure $ do
448+
RouteUnknown frag -> do
451449
el "p" $ text ("No handler found for " <> T.pack (show frag))
452450
pure ()
453451

@@ -473,7 +471,7 @@ app dynFrag = do
473471
pure $ (TagN tId) <$ delResult
474472

475473
-- | Renders alpha-tabbed package index
476-
packagesPageWidget :: forall t m. (MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m)
474+
packagesPageWidget :: forall t m. (SetRoute t FragRoute m, MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m)
477475
=> Dynamic t (Vector PkgN)
478476
-> Dynamic t (Vector TagN)
479477
-> Dynamic t (Map.Map PkgN [TagN])
@@ -517,7 +515,7 @@ packagesPageWidget dynPackages dynTags dynPkgTags = do
517515
pure $ do
518516

519517
el "ol" $ forM_ v' $ \(pn) -> do
520-
el "li" $ elAttr "a" ("href" =: ("#/package/" <> (pkgNToText pn))) $ do
518+
el "li" $ routeLink False ("#/package/" <> (pkgNToText pn)) $ do
521519
text ((pkgNToText pn) <> " : ")
522520
case Map.lookup pn dpt of
523521
Just tags -> forM tags $ \(tag0) -> elAttr "a" (("class" =: "tag-item") <> ("data-tag-name" =: (tagNToText tag0))) $ text (tagNToText tag0)
@@ -532,7 +530,7 @@ packagesPageWidget dynPackages dynTags dynPkgTags = do
532530
V.filter (tagContained st dpt) pkg
533531

534532

535-
reportTableWidget :: forall t m . (MonadHold t m, PostBuild t m, DomBuilder t m, Reflex t)
533+
reportTableWidget :: forall t m . (SetRoute t FragRoute m, MonadHold t m, PostBuild t m, DomBuilder t m, Reflex t)
536534
=> Dynamic t PkgIdxTsReport
537535
-> Dynamic t (Vector QEntryRow)
538536
-> Dynamic t (Vector WorkerRow)
@@ -604,7 +602,7 @@ reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo = joinE =<< go
604602

605603
elAttr "th" ("style" =: "text-align:left;") (text (verToText pv))
606604
el "td" $ text (pkgIdxTsToText t)
607-
el "td" $ elAttr "a" ("href" =: ("#/user/" <> u)) (text u)
605+
el "td" $ routeLink False ("#/user/" <> u) (text u)
608606

609607
pure (leftmost evsRow1)
610608
pure (leftmost evsRows) -- main "return" value
@@ -702,11 +700,14 @@ applyLR (L:xs) (l:ls) rs = l : applyLR xs ls rs
702700
applyLR (R:xs) ls (r:rs) = r : applyLR xs ls rs
703701
applyLR _ _ _ = error "applyLR"
704702

705-
findInitialDropDown :: Maybe PkgIdxTs -> Set PkgIdxTs -> PkgIdxTs
706-
findInitialDropDown (Just idx) pkgSet = if Set.member idx pkgSet
707-
then Set.foldr (\a b -> if a == b then a else b) idx pkgSet
708-
else Set.findMax pkgSet
709-
findInitialDropDown Nothing pkgSet = Set.findMax pkgSet
703+
findInitialDropDown :: PkgIdxTs -> Set PkgIdxTs -> PkgIdxTs
704+
findInitialDropDown p s
705+
| True <- Set.null s
706+
= PkgIdxTs 0
707+
| otherwise = if Set.member p s then p else Set.findMax s
708+
{-if Set.null s
709+
then PkgIdxTs 0
710+
else Set.findMax s-}
710711

711712
toggleTagSet :: TagN -> Set.Set TagN -> Set.Set TagN
712713
toggleTagSet tn st = if Set.member tn st then Set.delete tn st else Set.insert tn st
@@ -779,7 +780,7 @@ calcMatches pkgs sJss
779780
textS = JSS.textFromJSString sJss
780781
(exactMap,othersMap) = F.foldMap (calcMatch sJss) pkgs
781782

782-
searchBoxWidget :: forall t m. (SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace)
783+
searchBoxWidget :: forall t m. (SetRoute t FragRoute m, SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace)
783784
=> Dynamic t (Vector PkgN)
784785
-> m ()
785786
searchBoxWidget dynPkgs0 = mdo
@@ -795,16 +796,17 @@ searchBoxWidget dynPkgs0 = mdo
795796
clickPkgE <- searchResultWidget matchesDyn
796797
pure ()
797798

798-
searchResultWidget :: forall t m. (MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m)
799+
searchResultWidget :: forall t m. (SetRoute t FragRoute m, MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m)
799800
=> Dynamic t Matches
800801
-> m (Event t Text)
801802
searchResultWidget mDyn =
802803
el "ul" $ do
803804
exactE <- listViewWithKey (matchesExact <$> mDyn) $ \eId _ -> do
804-
(e, _) <- element "li" def $ elAttr "a" ("href" =: ("#/package/" <> eId)) $ el "strong" $ text eId
805+
(e, _) <- element "li" def $
806+
routeLink False ("#/package/" <> eId) $ el "strong" $ text eId
805807
pure $ domEvent Click e
806808
otherE <- listViewWithKey (matchesInfix <$> mDyn) $ \pId txt -> do
807-
(e, _) <- element "li" def $ elAttr "a" ("href" =: ("#/package/" <> pId)) $ do
809+
(e, _) <- element "li" def $ routeLink False ("#/package/" <> pId) $ do
808810
dynText . fmap (^. _1) $ txt
809811
el "strong" $ dynText . fmap (^. _2) $ txt
810812
dynText . fmap (^. _3) $ txt

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

Lines changed: 8 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,6 @@ import qualified Data.Version as Ver
5050
import Servant.API (FromHttpApiData (..),
5151
ToHttpApiData (..))
5252
import Text.ParserCombinators.ReadP (readP_to_S)
53-
import qualified Text.Read as R
5453

5554
type UserName = Text
5655
type PkgRev = Word
@@ -66,22 +65,21 @@ instance Show PkgN where
6665
| otherwise = (("PkgN "<>show x) <>)
6766

6867
-- NB: this assumes the Hackage ascii-only policy
69-
pkgNFromText :: Text -> (Maybe PkgN, Maybe PkgIdxTs)
68+
pkgNFromText :: Text -> Maybe PkgN--(Maybe PkgN, Maybe PkgIdxTs)
7069
pkgNFromText t0
71-
| Just (p0,ts0) <- parsingUrlText t0
72-
, Just intTs <- R.readMaybe (T.unpack ts0) :: Maybe Int
73-
, isValid p0 = (Just (PkgN p0), Just (PkgIdxTs intTs))--R.readMaybe (T.unpack ts0) :: Maybe PkgIdxTs)
74-
| otherwise = (Just (PkgN t0), Nothing)
70+
| isValid t0 = Just (PkgN t0) --True <- T.any (=='@') t0 --Just (p0,ts0) <- parsingUrlText t0
71+
--, isValid t0 = Just (PkgN t0) --, Just (PkgIdxTs intTs))--R.readMaybe (T.unpack ts0) :: Maybe PkgIdxTs)
72+
| otherwise = Nothing
7573
where
7674
isValid t
7775
| T.null t = False
78-
| not (T.all (\c -> C.isAsciiLower c || C.isAsciiUpper c || C.isDigit c || c == '-') t) = False
76+
| not (T.any (=='@') t0 || (T.all (\c -> C.isAsciiLower c || C.isAsciiUpper c || C.isDigit c || c == '-') t)) = False
7977
| otherwise = and [ T.any C.isAlpha x | x <- T.split (=='-') t ]
8078

81-
parsingUrlText :: Text -> Maybe (Text, Text)
79+
{-parsingUrlText :: Text -> Maybe (Text, Text)
8280
parsingUrlText t0 = case T.any (=='@') t0 of
8381
True -> Just (T.takeWhile (/='@') t0, T.takeWhileEnd (/='@') t0)
84-
False -> Just (t0, T.empty)
82+
False -> Just (t0, T.empty)-}
8583
-- | Just prefix <- T.stripSuffix "@" t0
8684
-- , Just suffix <- T.stripPrefix "@" t0 = Just (prefix,suffix)
8785
-- | otherwise = Just (t0,T.empty)
@@ -122,7 +120,7 @@ instance FromHttpApiData CompilerID where
122120
----------------------------------------------------------------------------
123121

124122
newtype PkgIdxTs = PkgIdxTs Int
125-
deriving (Show,Ord,Eq,FromJSON,ToJSON,FromHttpApiData,ToHttpApiData,Read)
123+
deriving (Show,Ord,Eq,FromJSON,ToJSON,FromHttpApiData,ToHttpApiData)
126124

127125
pkgIdxTsToText :: PkgIdxTs -> Text
128126
pkgIdxTsToText (PkgIdxTs t) = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%TZ" (posixSecondsToUTCTime (fromIntegral t :: POSIXTime))

0 commit comments

Comments
 (0)