From 42e94a45e26f40edc3ad71b1e77a4bf47c13fd3d Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 15 Nov 2017 23:50:44 +0100 Subject: Add dynamic pages --- client/src/Component/Button.hs | 40 +++++++++++--------- client/src/View/Header.hs | 2 +- client/src/View/Payment/Constants.hs | 6 +++ client/src/View/Payment/Pages.hs | 71 +++++++++++++++++++++++------------- client/src/View/Payment/Table.hs | 50 +++++++++++++------------ client/src/View/SignIn.hs | 2 +- 6 files changed, 103 insertions(+), 68 deletions(-) create mode 100644 client/src/View/Payment/Constants.hs (limited to 'client/src') diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 9499045..c31cdc6 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -7,24 +7,23 @@ module Component.Button , button ) where -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text + { _buttonIn_class :: Dynamic t Text , _buttonIn_content :: m () , _buttonIn_waiting :: Event t Bool } buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m buttonInDefault = ButtonIn - { _buttonIn_class = "" + { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.blank , _buttonIn_waiting = R.never } @@ -35,18 +34,25 @@ data ButtonOut t = ButtonOut button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do - attr <- R.holdDyn - (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) - (fmap - (\w -> M.fromList $ - [ ("type", "button") ] - <> if w - then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] - else [("class", _buttonIn_class buttonIn)]) - (_buttonIn_waiting buttonIn)) + dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn + + let attr = do + buttonClass <- _buttonIn_class buttonIn + waiting <- dynWaiting + return $ if waiting + then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])] + else M.fromList [("type", "button"), ("class", buttonClass)] + (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut { _buttonOut_clic = R.domEvent R.Click e } + +-- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text +-- mergeAttr = M.unionWithKey $ \k a b -> +-- if k == "class" +-- then T.intercalate " " [ a, b ] +-- else b diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 711ba80..7afd9bd 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -65,7 +65,7 @@ signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = "signOut item" + { Component._buttonIn_class = R.constDyn "signOut item" , Component._buttonIn_content = Icon.signOut , Component._buttonIn_waiting = waiting } diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs new file mode 100644 index 0000000..ac2320a --- /dev/null +++ b/client/src/View/Payment/Constants.hs @@ -0,0 +1,6 @@ +module View.Payment.Constants + ( paymentsPerPage + ) where + +paymentsPerPage :: Int +paymentsPerPage = 8 diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index cf3e115..f96cb8e 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -7,15 +7,17 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Event, Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment (..)) +import Common.Model (Payment (..)) + +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component import qualified Icon +import qualified View.Payment.Constants as Constants data PagesIn = PagesIn { _pagesIn_payments :: [Payment] @@ -26,26 +28,43 @@ data PagesOut t = PagesOut } widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) -widget _ = do - currentPage <- R.divClass "pages" $ do - a <- page 1 Icon.doubleLeftBar - b <- page 1 Icon.doubleLeft - c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) - d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) - e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) - f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) - g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) - h <- page 5 Icon.doubleRight - i <- page 5 Icon.doubleRightBar - R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] - return $ PagesOut - { _pagesOut_currentPage = currentPage - } - -page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) -page n content = - ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn - { _buttonIn_class = "page" +widget pagesIn = do + R.divClass "pages" $ do + rec + currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] + + firstPageClic <- pageButton (R.constDyn 0) (R.constDyn 1) Icon.doubleLeftBar + + previousPageClic <- pageButton (R.constDyn 0) (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + + pageClic <- pageEvent <$> (R.simpleList (fmap (range maxPage) currentPage) $ \p -> + pageButton currentPage p (R.dynText $ fmap (T.pack . show) p)) + + nextPageClic <- pageButton (R.constDyn 0) (fmap (\x -> min (x + 1) maxPage) currentPage) Icon.doubleRight + + lastPageClic <- pageButton (R.constDyn 0) (R.constDyn maxPage) Icon.doubleRightBar + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage + pageEvent = R.switchPromptlyDyn . fmap R.leftmost + +range :: Int -> Int -> [Int] +range maxPage currentPage = [start..end] + where sidePages = 2 + start = max 1 (currentPage - sidePages) + end = min maxPage (start + sidePages * 2) + +pageButton :: forall t m. MonadWidget t m => Dynamic t Int -> Dynamic t Int -> m () -> m (Event t Int) +pageButton currentPage page content = do + clic <- _buttonOut_clic <$> (Component.button $ ButtonIn + { _buttonIn_class = do + cp <- currentPage + p <- page + if cp == p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never }) + return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 734511d..5c0b709 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -7,26 +7,27 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (MonadWidget, Dynamic) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format import qualified Icon +import qualified View.Payment.Constants as Constants data TableIn t = TableIn - { _tableIn_init :: Init + { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int } @@ -34,12 +35,8 @@ data TableOut = TableOut { } -visiblePayments :: Int -visiblePayments = 8 - widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do @@ -52,13 +49,20 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank let init = _tableIn_init tableIn + currentPage = _tableIn_currentPage tableIn payments = _init_payments init - paymentRange = fmap - (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) - (_tableIn_currentPage tableIn) + paymentRange = fmap (getPaymentRange payments) currentPage R.simpleList paymentRange (paymentRow init) return $ TableOut {} +getPaymentRange :: [Payment] -> Int -> [Payment] +getPaymentRange payments currentPage = + take Constants.paymentsPerPage + . drop ((currentPage - 1) * Constants.paymentsPerPage) + . reverse + . L.sortOn _payment_date + $ payments + paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do @@ -69,7 +73,7 @@ paymentRow init payment = R.divClass "cell user" $ R.dynText $ flip fmap user $ \mbUser -> case mbUser of Just u -> _user_name u - _ -> "" + _ -> "" let category = flip fmap payment $ \p -> findCategory (_init_categories init) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 70c6b1f..1f5b900 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -49,7 +49,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = "" + { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.text (Message.get Key.SignIn_Button) , _buttonIn_waiting = waiting } -- cgit v1.2.3