Possible fix on changing between dropdown value but still lack on back button

Author: Andika Demas Riyandi

src-ui.v3/src/Main.hs

@@ -65,6 +65,7 @@ import           Reflex.Time
 import           Reflex.Class
 import           Servant.API
 import           Servant.Reflex
+import qualified Text.Read                    as R
 
 import           API
 import           PkgId
@@ -109,7 +110,7 @@ utc2unix x = ceiling (realToFrac (utcTimeToPOSIXSeconds x) :: Double)
 
 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 ()
 bodyElement4 = do
-  _ <- runRouteViewT app
+  _ <- runRouteViewT' app
 
   --(result, changeStateE) <- runSetRouteT $ app RouteHome 
   pure ()
@@ -330,23 +331,24 @@ app dynFrag = do
         let dynPkgTags = pkgTagList <$> dynTagPkgs
         packagesPageWidget dynPackages0 dynTags dynPkgTags
 
-    RoutePackage (pn, idxSt) -> do
-
+    RoutePackage (PkgN pkgUri) -> do
+        let pn = PkgN $ T.takeWhile (/='@') pkgUri
+            (intIdx  :: Maybe Int) = R.readMaybe (T.unpack (T.takeWhileEnd (/='@') pkgUri))
+            idxSt = PkgIdxTs $ fromMaybe 0 intIdx
         el "h2" $ text (pkgNToText pn)
         el "p" $ el "em" $ elAttr "a" ("href" =: ("https://hackage.haskell.org/package/" <> pkgNToText pn)) $
           do text "(view on Hackage)"
 
         evPB <- getPostBuild
         let 
-          dynIdxStLast' = fmap (\x -> M.fromMaybe x idxSt) dynIdxStLast
         -- single-shot requests
         evReports <- getPackageReports (constDyn $ Right pn) evPB
         dynReports <- holdDyn mempty evReports
 
         evInfo <- getInfo evPB
         dynInfo <- holdDyn (ControllerInfo mempty) evInfo
 
-        evHist <- getPackageHistory (constDyn $ Right pn) (leftmost [updated dynIdxStLast' $> (), evPB])
+        evHist <- getPackageHistory (constDyn $ Right pn) (leftmost [updated dynIdxStLast $> (), evPB])
         dynHist <- holdDyn mempty evHist
 
         evPkgTags <- getPackageTags (constDyn $ Right pn) evPB
@@ -364,28 +366,25 @@ app dynFrag = do
           text " for latest index-state "
           dynText (pkgIdxTsToText <$> dynIdxStLast)
 
-          putQueue (constDyn $ Right pn) (Right <$> dynIdxStLast') (constDyn $ Right (QEntryUpd (-1))) evQButton
-
-
-        let xs = Map.fromList . fmap (\x -> (x, pkgIdxTsToText x)) . Set.toList <$> dynReports
-            x0 = (\s -> if Set.null s then PkgIdxTs 0
-                                      else (findInitialDropDown idxSt s)) <$> dynReports
-            
-
-        let ddCfg = DropdownConfig (updated x0) (constDyn mempty)
+          putQueue (constDyn $ Right pn) (Right <$> dynIdxStLast) (constDyn $ Right (QEntryUpd (-1))) evQButton
 
         let inputAttr = ("class" =: "tag-name") <> ("placeholder" =: "insert tag")
             iCfg = TextInputConfig "tag-name" "" never (constDyn inputAttr)
+        let xs = Map.fromList . fmap (\x -> (x, pkgIdxTsToText x)) . Set.toList <$> dynReports
 
-        ddReports <- el "p" $ do
+        ddReports <- el "p" $ mdo
+          let maxId = findInitialDropDown idxSt <$> dynReports
+              ddCfg = (def :: DropdownConfig t PkgIdxTs)
+                    & dropdownConfig_setValue .~ (updated maxId)
+          initId <- sample $ current maxId
           evQButton <- button "Queue a build"
           text " for the index-state "
-          tmp <- routePkgIdxTs pn (PkgIdxTs 0) dynReports xs ddCfg
+          dd <- dropdown initId xs ddCfg
+          routePkgIdxTs pn dynReports (dd ^. dropdown_value)
           text " shown below"
+          _ <- putQueue (constDyn $ Right pn) (Right <$> _dropdown_value dd) (constDyn $ Right (QEntryUpd (-1))) evQButton
 
-          _ <- putQueue (constDyn $ Right pn) (Right <$> _dropdown_value tmp) (constDyn $ Right (QEntryUpd (-1))) evQButton
-
-          pure tmp
+          pure dd
 
         elClass "p" "tagging" $ mdo
           let evMapTags = Map.fromList . (fmap (\t -> (t,t))) . (fmap tagNToText) . V.toList <$> evPkgTags
@@ -472,7 +471,7 @@ app dynFrag = do
       pure $ (TagN tId) <$ delResult
 
 -- | Renders alpha-tabbed package index
-packagesPageWidget :: forall t m. (MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m) 
+packagesPageWidget :: forall t m. (SetRoute t FragRoute m, MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m) 
                    => Dynamic t (Vector PkgN) 
                    -> Dynamic t (Vector TagN) 
                    -> Dynamic t (Map.Map PkgN [TagN])
@@ -516,7 +515,7 @@ packagesPageWidget dynPackages dynTags dynPkgTags = do
                   pure $ do
 
                     el "ol" $ forM_ v' $ \(pn) -> do
-                      el "li" $ elAttr "a" ("href" =: ("#/package/" <> (pkgNToText pn))) $ do
+                      el "li" $ routeLink False ("#/package/" <> (pkgNToText pn)) $ do
                         text ((pkgNToText pn) <> " : ")
                         case Map.lookup pn dpt of
                           Just tags -> forM tags $ \(tag0) -> elAttr "a" (("class" =: "tag-item") <> ("data-tag-name" =: (tagNToText tag0))) $ text (tagNToText tag0)
@@ -531,7 +530,7 @@ packagesPageWidget dynPackages dynTags dynPkgTags = do
       V.filter (tagContained st dpt) pkg
 
 
-reportTableWidget :: forall t m . (MonadHold t m, PostBuild t m, DomBuilder t m, Reflex t)
+reportTableWidget :: forall t m . (SetRoute t FragRoute m, MonadHold t m, PostBuild t m, DomBuilder t m, Reflex t)
                   => Dynamic t PkgIdxTsReport
                   -> Dynamic t (Vector QEntryRow)
                   -> Dynamic t (Vector WorkerRow)
@@ -603,7 +602,7 @@ reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo = joinE =<< go
 
                 elAttr "th" ("style" =: "text-align:left;") (text (verToText pv))
                 el "td" $ text (pkgIdxTsToText t)
-                el "td" $ elAttr "a" ("href" =: ("#/user/" <> u)) (text u)
+                el "td" $ routeLink False ("#/user/" <> u) (text u)
 
                 pure (leftmost evsRow1)
             pure (leftmost evsRows) -- main "return" value
@@ -701,11 +700,14 @@ applyLR (L:xs)  (l:ls)    rs  = l : applyLR xs ls rs
 applyLR (R:xs)     ls  (r:rs) = r : applyLR xs ls rs
 applyLR _ _ _                 = error "applyLR"
 
-findInitialDropDown :: Maybe PkgIdxTs -> Set PkgIdxTs -> PkgIdxTs
-findInitialDropDown (Just idx) pkgSet = if Set.member idx pkgSet 
-                                        then Set.foldr (\a b -> if a == b then a else b) idx pkgSet
-                                        else Set.findMax pkgSet
-findInitialDropDown Nothing pkgSet    = Set.findMax pkgSet
+findInitialDropDown :: PkgIdxTs -> Set PkgIdxTs -> PkgIdxTs
+findInitialDropDown p s
+  | True <- Set.null s
+  = PkgIdxTs 0
+  | otherwise = if Set.member p s then p else Set.findMax s
+  {-if Set.null s 
+  then PkgIdxTs 0
+  else Set.findMax s-}
 
 toggleTagSet :: TagN -> Set.Set TagN -> Set.Set TagN
 toggleTagSet tn st = if Set.member tn st then Set.delete tn st else Set.insert tn st
@@ -778,7 +780,7 @@ calcMatches pkgs sJss
     textS                = JSS.textFromJSString sJss
     (exactMap,othersMap) = F.foldMap (calcMatch sJss) pkgs
 
-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)
+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)
                 => Dynamic t (Vector PkgN) 
                 -> m ()  
 searchBoxWidget dynPkgs0 = mdo
@@ -794,16 +796,17 @@ searchBoxWidget dynPkgs0 = mdo
   clickPkgE <- searchResultWidget matchesDyn
   pure ()
 
-searchResultWidget :: forall t m. (MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m) 
+searchResultWidget :: forall t m. (SetRoute t FragRoute m, MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m) 
                    => Dynamic t Matches 
                    -> m (Event t Text)
 searchResultWidget mDyn =
   el "ul" $ do
     exactE <- listViewWithKey (matchesExact <$> mDyn) $ \eId _ -> do
-                (e, _) <- element "li" def $ elAttr "a" ("href" =: ("#/package/" <> eId)) $ el "strong" $ text eId
+                (e, _) <- element "li" def $ 
+                  routeLink False ("#/package/" <> eId) $ el "strong" $ text eId
                 pure $ domEvent Click e
     otherE <- listViewWithKey (matchesInfix <$> mDyn) $ \pId txt -> do
-                (e, _) <- element "li" def $ elAttr "a" ("href" =: ("#/package/" <> pId)) $ do
+                (e, _) <- element "li" def $ routeLink False ("#/package/" <> pId) $ do
                             dynText . fmap (^. _1) $ txt
                             el "strong" $ dynText . fmap (^. _2) $ txt
                             dynText . fmap (^. _3) $ txt

src-ui.v3/src/PkgId.hs

@@ -50,7 +50,6 @@ import qualified Data.Version                 as Ver
 import           Servant.API                  (FromHttpApiData (..),
                                                ToHttpApiData (..))
 import           Text.ParserCombinators.ReadP (readP_to_S)
-import qualified Text.Read                    as R
 
 type UserName   = Text
 type PkgRev     = Word
@@ -66,22 +65,21 @@ instance Show PkgN where
       | otherwise  = (("PkgN "<>show x) <>)
 
 -- NB: this assumes the Hackage ascii-only policy
-pkgNFromText :: Text -> (Maybe PkgN, Maybe PkgIdxTs)
+pkgNFromText :: Text -> Maybe PkgN--(Maybe PkgN, Maybe PkgIdxTs)
 pkgNFromText t0
-  | Just (p0,ts0) <- parsingUrlText t0
-  , Just intTs <- R.readMaybe (T.unpack ts0) :: Maybe Int
-  , isValid p0 = (Just (PkgN p0), Just (PkgIdxTs intTs))--R.readMaybe (T.unpack ts0) :: Maybe PkgIdxTs)
-  | otherwise  = (Just (PkgN t0), Nothing)
+  | isValid t0 = Just (PkgN t0) --True <- T.any (=='@') t0 --Just (p0,ts0) <- parsingUrlText t0
+  --, isValid t0 = Just (PkgN t0) --, Just (PkgIdxTs intTs))--R.readMaybe (T.unpack ts0) :: Maybe PkgIdxTs)
+  | otherwise  = Nothing
   where
     isValid t
       | T.null t = False
-      | not (T.all (\c -> C.isAsciiLower c || C.isAsciiUpper c || C.isDigit c || c == '-') t) = False
+      | not (T.any (=='@') t0 || (T.all (\c -> C.isAsciiLower c || C.isAsciiUpper c || C.isDigit c || c == '-') t)) = False
       | otherwise = and [ T.any C.isAlpha x | x <- T.split (=='-') t ]
 
-parsingUrlText :: Text -> Maybe (Text, Text)
+{-parsingUrlText :: Text -> Maybe (Text, Text)
 parsingUrlText t0 = case T.any (=='@') t0 of
   True  -> Just (T.takeWhile (/='@') t0, T.takeWhileEnd (/='@') t0)
-  False -> Just (t0, T.empty)
+  False -> Just (t0, T.empty)-}
   -- | Just prefix <- T.stripSuffix "@" t0
   -- , Just suffix <- T.stripPrefix "@" t0 = Just (prefix,suffix)
   -- | otherwise                           = Just (t0,T.empty)
@@ -122,7 +120,7 @@ instance FromHttpApiData CompilerID where
 ----------------------------------------------------------------------------
 
 newtype PkgIdxTs = PkgIdxTs Int
-    deriving (Show,Ord,Eq,FromJSON,ToJSON,FromHttpApiData,ToHttpApiData,Read)
+    deriving (Show,Ord,Eq,FromJSON,ToJSON,FromHttpApiData,ToHttpApiData)
 
 pkgIdxTsToText :: PkgIdxTs -> Text
 pkgIdxTsToText (PkgIdxTs t) = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%TZ" (posixSecondsToUTCTime (fromIntegral t :: POSIXTime))