Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Initial Fix #66

Merged
merged 3 commits into from
Aug 5, 2019
Merged

Initial Fix #66

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
678b801
Initial Fix
Rizary Jul 29, 2019
648a954
Possible fix on changing between dropdown value but still lack on bac…
Rizary Jul 31, 2019
be95615
Fixed dyn and cleaning some warning
Rizary Aug 1, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions src-ui.v3/matrix-ui.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ executable matrix-ui
main-is: Main.hs
other-modules: API
, PkgId
, Router

mixins: base hiding (Prelude)

Expand Down
88 changes: 45 additions & 43 deletions src-ui.v3/src/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,8 @@ import qualified Data.Vector as V
import qualified Data.Version as Ver
import GHC.Generics (Rep)
import qualified GHCJS.DOM.Types as DOM
import qualified GHCJS.DOM.Window as Window
import qualified GHCJS.DOM as DOM
import Language.Javascript.JSaddle (jsNull)
import Network.URI
--import Reflex.Dom
Expand All @@ -63,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
Expand Down Expand Up @@ -107,15 +110,13 @@ 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
--dynLoc <- browserHistoryWith getLocationUri
--let dynFrag = decodeFrag . T.pack . uriFragment <$> dynLoc
_ <- runRouteViewT app

--(result, changeStateE) <- runSetRouteT $ app RouteHome
pure ()
-- ticker1 <- tickLossy 1 =<< liftIO getCurrentTime
-- ticker1cnt <- count ticker1

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)
=> Dynamic t FragRoute
=> FragRoute -- Dynamic t FragRoute
-> m ()
app dynFrag = do
-- top-level PB event
Expand Down Expand Up @@ -156,8 +157,8 @@ app dynFrag = do
_ <- searchBoxWidget dynPackages0
el "hr" blank

_ <- dyn $ dynFrag >>= \case
RouteHome -> pure $ do
_ <- case dynFrag of --dyn $ dynFrag >>= \case
RouteHome -> do
elAttr "div" (("id" =: "page-home") <> ("class" =: "page")) $ do
divClass "leftcol" $ do
elAttr "h2" ("class" =: "main-header") $ text "Welcome"
Expand Down Expand Up @@ -205,7 +206,7 @@ app dynFrag = do
text "Cookbook for common build failures"
pure ()

RouteQueue -> pure $ do
RouteQueue -> do
evPB <- getPostBuild

let dynUnixTime = utc2unix <$> dynUTCTime
Expand Down Expand Up @@ -320,7 +321,7 @@ app dynFrag = do
pure ()
pure ()

RoutePackages -> pure $ do
RoutePackages -> do
el "h1" $ text "Packages"
evPB <- getPostBuild
evTags<- getTags (constDyn $ QParamSome False) evPB
Expand All @@ -330,23 +331,24 @@ app dynFrag = do
let dynPkgTags = pkgTagList <$> dynTagPkgs
packagesPageWidget dynPackages0 dynTags dynPkgTags

RoutePackage (pn, idxSt) -> pure $ 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
Expand All @@ -364,29 +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 "
uniqReport <- holdUniqDyn dynReports
tmp <- routePkgIdxTs pn (PkgIdxTs 0) uniqReport 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
Expand Down Expand Up @@ -434,7 +432,7 @@ app dynFrag = do

pure ()

RouteUser u -> pure $ do
RouteUser u -> do
el "h1" (text u)

evPB <- getPostBuild
Expand All @@ -447,7 +445,7 @@ app dynFrag = do

pure ()

RouteUnknown frag -> pure $ do
RouteUnknown frag -> do
el "p" $ text ("No handler found for " <> T.pack (show frag))
pure ()

Expand All @@ -473,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])
Expand Down Expand Up @@ -517,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)
Expand All @@ -532,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)
Expand Down Expand Up @@ -604,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
Expand Down Expand Up @@ -702,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
Expand Down Expand Up @@ -779,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
Expand All @@ -795,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
Expand Down
18 changes: 8 additions & 10 deletions src-ui.v3/src/PkgId.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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))
Expand Down
Loading