aboutsummaryrefslogtreecommitdiff
path: root/client/src/View/Payment
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View/Payment')
-rw-r--r--client/src/View/Payment/Constants.hs6
-rw-r--r--client/src/View/Payment/Pages.hs71
-rw-r--r--client/src/View/Payment/Table.hs50
3 files changed, 78 insertions, 49 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 06:56:26 +0000