diff --git a/octopod-frontend/octopod-frontend.cabal b/octopod-frontend/octopod-frontend.cabal index c035b80..2bee95b 100644 --- a/octopod-frontend/octopod-frontend.cabal +++ b/octopod-frontend/octopod-frontend.cabal @@ -34,6 +34,7 @@ executable frontend , Page.Popup.NewDeployment , Servant.Reflex.Extra , Page.Elements.Links + , Reflex.MultiEventWriter.Class ghc-options: -Wall -Werror -Wno-missing-home-modules @@ -63,6 +64,8 @@ executable frontend , MultiParamTypeClasses , TypeFamilies , UndecidableInstances + , FunctionalDependencies + , AllowAmbiguousTypes -- other-extensions: build-depends: aeson , base >=4.12 && <4.13 @@ -84,5 +87,8 @@ executable frontend , text , time , transformers + , mtl + , semialign + , these hs-source-dirs: src default-language: Haskell2010 diff --git a/octopod-frontend/src/Main.hs b/octopod-frontend/src/Main.hs index 66d00b9..e1f8197 100644 --- a/octopod-frontend/src/Main.hs +++ b/octopod-frontend/src/Main.hs @@ -13,7 +13,7 @@ import Reflex.Dom import Servant.Reflex import Common.Types as CT -import Data.Monoid +import qualified Data.Semigroup as S import Frontend.API import Frontend.GHCJS import Frontend.Route @@ -26,13 +26,13 @@ main :: IO () main = mdo mainWidgetWithHead' (headWidget, \() -> do ((), projectNameEv) <- runEventWriterT initConfigWidget - return $ fmapMaybe getLast projectNameEv + return $ fmap S.getLast projectNameEv ) -- | Receives the config file. -- If request fails then an error message is displayed. initConfigWidget - :: (MonadWidget t m, Prerender js t m, EventWriter t (Last ProjectName) m) + :: (MonadWidget t m, Prerender js t m, EventWriter t (S.Last ProjectName) m) => m () initConfigWidget = do pb <- getPostBuild @@ -172,7 +172,7 @@ headWidget projectNameEv = do <> "name" =: "theme-color") blank -- | Common headers of all pages. Displays the project name. -headerWidget :: (MonadWidget t m, EventWriter t (Last ProjectName) m) => m () +headerWidget :: (MonadWidget t m, EventWriter t (S.Last ProjectName) m) => m () headerWidget = elClass "header" "header" $ divClass "header__wrap container" $ do @@ -181,7 +181,7 @@ headerWidget = elClass "div" "header__project" $ do pb <- getPostBuild respEv <- fmapMaybe reqSuccess <$> projectName pb - tellEvent $ Last . Just <$> respEv + tellEvent $ S.Last <$> respEv nameDyn <- holdDyn "" $ uProjectName <$> respEv dynText nameDyn diff --git a/octopod-frontend/src/Page/Deployments.hs b/octopod-frontend/src/Page/Deployments.hs index b0b1699..1b2d9f4 100644 --- a/octopod-frontend/src/Page/Deployments.hs +++ b/octopod-frontend/src/Page/Deployments.hs @@ -25,6 +25,11 @@ import Servant.Reflex import Common.Types as CT import Common.Utils +import Control.Monad.Reader +import Data.Align +import Data.Functor +import qualified Data.Semigroup as S +import Data.These import Frontend.API import Frontend.Route import Frontend.Utils @@ -32,6 +37,7 @@ import Page.ClassicPopup import Page.Elements.Links import Page.Popup.EditDeployment import Page.Popup.NewDeployment +import Reflex.MultiEventWriter.Class -- | The root widget of the deployments list page. @@ -357,20 +363,22 @@ archivedDeploymentWidget clickedEv dDyn' = do -- | Sort deployments by the supplied condition. sortDeployments :: [DeploymentFullInfo] - -> SortDir + -> Maybe SortDir -- ^ Sorting condition. -> [DeploymentFullInfo] sortDeployments items s = L.sortBy sortFunc items where sortFunc a b = case s of - SortAsc get -> compare (a ^. get) (b ^. get) - SortDesc get -> compare (b ^. get) (a ^. get) + Just (SortAsc get) -> compare (a ^. get) (b ^. get) + Just (SortDesc get) -> compare (b ^. get) (a ^. get) + Nothing -> EQ -- | Each constructor contains a getter -- that extracts the field that is used for sorting. data SortDir where SortAsc :: Ord a => Getter DeploymentFullInfo a -> SortDir SortDesc :: Ord a => Getter DeploymentFullInfo a -> SortDir + deriving Semigroup via (S.Last SortDir) -- | Sorting toggler. toggleSort :: SortDir -> SortDir @@ -380,52 +388,105 @@ toggleSort = \case -- | Header for a deployments table. -- \"Name\",\"created\" and \"udpated\" columns support sorting. -tableHeader :: MonadWidget t m => m (Dynamic t SortDir) +tableHeader :: (MonadWidget t m, SortableTableGroup t m) => m () tableHeader = do el "thead" $ el "tr" $ do - nameSortDyn <- sortHeader dfiName "Name" + sortHeader dfiName "Name" SortAsc el "th" $ text "Links" el "th" $ text "Tag" el "th" $ text "App overrides" el "th" $ text "Deployment overrides" - createSortDyn <- sortHeader (field @"createdAt") "Created" - updateSortDyn <- sortHeader (field @"updatedAt") "Changed" + sortHeader (field @"createdAt") "Created" SortDesc + sortHeaderInitially (field @"updatedAt") "Changed" SortDesc el "th" $ elClass "span" "visuallyhidden" $ text "Menu" - let - sortEv = - leftmost $ fmap updated [nameSortDyn, createSortDyn, updateSortDyn] - sortDyn <- holdDyn (SortAsc dfiName) sortEv - pure sortDyn + +data SortingChanged = SortingChanged + deriving Semigroup via (S.Last SortingChanged) + +type SortableTableGroup t m = + ( MonadReader (Event t SortingChanged) m + , MultiEventWriter t SortDir m + , MultiEventWriter t SortingChanged m + ) + +-- | Group all sortable headers ('sortHeader', 'sortHeaderInitially'). +-- Makes sure that only one can be active at a time. +runSortableTableGroup + :: (Reflex t, MonadFix m) + => ReaderT + (Event t SortingChanged) + (EventWriterT t SortDir (EventWriterT t SortingChanged m)) + x + -> m (x, Event t SortDir) +runSortableTableGroup m = mdo + ((x, sDyn), changed) <- + runEventWriterT . runEventWriterT . flip runReaderT changed $ m + return (x, sDyn) + +type SortingDirection a = Getter DeploymentFullInfo a -> SortDir -- | Special column header with a sort button. sortHeader - :: (MonadWidget t m, Ord a) + :: forall t m a. (MonadWidget t m, Ord a, SortableTableGroup t m) => Getter DeploymentFullInfo a -> Text - -> m (Dynamic t SortDir) -sortHeader f l = do + -> SortingDirection a -- ^ The direction to sort when clicked + -> m () +sortHeader f l defaultSorting = + sortHeaderWithInitial f l defaultSorting (Nothing @(SortingDirection a)) + +-- | Special column header with a sort button. +sortHeaderInitially + :: forall t m a. (MonadWidget t m, Ord a, SortableTableGroup t m) + => Getter DeploymentFullInfo a + -> Text + -> SortingDirection a -- ^ The direction to sort when clicked and when the page loads + -> m () +sortHeaderInitially f l defaultSorting = + sortHeaderWithInitial f l defaultSorting (Just @(SortingDirection a) defaultSorting) + +-- | Special column header with a sort button. +sortHeaderWithInitial + :: forall t m a. (MonadWidget t m, Ord a, SortableTableGroup t m) + => Getter DeploymentFullInfo a + -> Text + -> SortingDirection a -- ^ The direction to sort when clicked + -> Maybe (SortingDirection a) -- ^ The direction to sort when the page loads + -> m () +sortHeaderWithInitial f l defaultSorting initSortingM = do + let initSorting = case initSortingM of + Nothing -> Nothing + Just x -> Just $ x f el "th" $ mdo - dateSortDyn' <- foldDyn ($) (SortDesc f) - $ toggleSort <$ sortBtnEv + sortingChanged <- ask + sortDyn <- foldDyn ($) initSorting $ alignWith (curry $ \case + (That SortingChanged, _) -> Nothing -- Some other column has started sorting + (_, Nothing) -> Just $ defaultSorting f -- This column started sorting + (_, Just x) -> Just $ toggleSort x -- This column was sorting and was clicked + ) sortBtnEv sortingChanged + tellMultiEvent . fmapMaybe id $ updated sortDyn let - classDyn = dateSortDyn' <&> \case - SortDesc _ -> "sort sort--active sort--desc" - SortAsc _ -> "sort sort--active sort--asc" + classDyn = fmap ("sort " <>) $ sortDyn <&> \case + Just (SortDesc _) -> "sort--active sort--desc" + Just (SortAsc _) -> "sort--active sort--asc" + Nothing -> "" sortBtnEv <- buttonDynClass classDyn (pure l) - pure dateSortDyn' + tellMultiEvent $ sortBtnEv $> SortingChanged + pure () -- | A wrapper that adds a header to the table. tableWrapper - :: MonadWidget t m - => (Dynamic t SortDir -> m a) + :: (MonadWidget t m) + => (Dynamic t (Maybe SortDir) -> m a) -- ^ Sorting direction is obtained from the table header. -> m a tableWrapper ma = divClass "table table--deployments table--clickable table--double-click" $ - el "table" $ do - sDyn <- tableHeader + el "table" $ mdo + ((), sDyn') <- runSortableTableGroup tableHeader + sDyn <- holdDyn Nothing $ Just <$> sDyn' el "tbody" $ ma sDyn -- | Table wrapper for a table with an \"error\" or a \"loading\ placeholder. diff --git a/octopod-frontend/src/Reflex/MultiEventWriter/Class.hs b/octopod-frontend/src/Reflex/MultiEventWriter/Class.hs new file mode 100644 index 0000000..21b04c8 --- /dev/null +++ b/octopod-frontend/src/Reflex/MultiEventWriter/Class.hs @@ -0,0 +1,33 @@ +module Reflex.MultiEventWriter.Class + ( MultiEventWriter(..) + ) where + +import Control.Monad.Reader (ReaderT, lift) +import Data.Semigroup (Semigroup) +import Data.Type.Equality +import Reflex.Dom + + +-- | Same as 'EventWriter' but without a fundep and can only have a concrete implementation by EventWriterT. +class (Monad m, Semigroup w) => MultiEventWriter t w m | m -> t where + tellMultiEvent :: Event t w -> m () + +instance MultiEventWriter t w m => MultiEventWriter t w (ReaderT r m) where + tellMultiEvent = lift . tellMultiEvent + +instance (MultiEventWriter' t w u m, Monad m, Semigroup w) => MultiEventWriter t w (EventWriterT t u m) where + tellMultiEvent = tellMultiEvent' @t @w @u + +-- Horrible hacks incoming + +type MultiEventWriter' t w u m = MultiEventWriter'' t w u m (w == u) + +class (u == w) ~ f => MultiEventWriter'' t w u m f where + tellMultiEvent' :: Event t w -> EventWriterT t u m () + +instance ((w == w) ~ 'True, Reflex t, Monad m, Semigroup w) + => MultiEventWriter'' t w w m 'True where + tellMultiEvent' = tellEvent + +instance ((u == w) ~ 'False, MultiEventWriter t w m) => MultiEventWriter'' t w u m 'False where + tellMultiEvent' = lift . tellMultiEvent