aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ISSUES.md1
-rw-r--r--client/client.cabal1
-rw-r--r--client/src/Component.hs1
-rw-r--r--client/src/Component/Pages.hs88
-rw-r--r--client/src/Component/Table.hs53
-rw-r--r--client/src/View/Income/Income.hs2
-rw-r--r--server/server.cabal1
-rw-r--r--server/src/Design/View/Pages.hs55
-rw-r--r--server/src/Design/Views.hs2
9 files changed, 189 insertions, 15 deletions
diff --git a/ISSUES.md b/ISSUES.md
index 6863b00..04fdf2f 100644
--- a/ISSUES.md
+++ b/ISSUES.md
@@ -29,6 +29,7 @@
- category,
- date.
- Show statistics.
+- Pages: 1 … 3 4 5 … 10
# Code
diff --git a/client/client.cabal b/client/client.cabal
index eeeb8be..8c25da7 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -50,6 +50,7 @@ Executable client
Component.Input
Component.Link
Component.Modal
+ Component.Pages
Component.Table
Component.Select
Icon
diff --git a/client/src/Component.hs b/client/src/Component.hs
index 97c250e..4c51750 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -5,5 +5,6 @@ import Component.Form as X
import Component.Input as X
import Component.Link as X
import Component.Modal as X
+import Component.Pages as X
import Component.Select as X
import Component.Table as X
diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs
new file mode 100644
index 0000000..5611cb7
--- /dev/null
+++ b/client/src/Component/Pages.hs
@@ -0,0 +1,88 @@
+module Component.Pages
+ ( widget
+ , PagesIn(..)
+ , PagesOut(..)
+ ) where
+
+import qualified Data.Text as T
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Component.Button (ButtonIn (..), ButtonOut (..))
+import qualified Component.Button as Button
+
+import qualified Icon
+import qualified Util.Reflex as ReflexUtil
+
+data PagesIn t = PagesIn
+ { _pagesIn_total :: Dynamic t Int
+ , _pagesIn_perPage :: Int
+ , _pagesIn_reset :: Event t ()
+ }
+
+data PagesOut t = PagesOut
+ { _pagesOut_currentPage :: Dynamic t Int
+ }
+
+widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
+widget pagesIn = do
+ currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
+
+ return $ PagesOut
+ { _pagesOut_currentPage = currentPage
+ }
+
+ where
+ total = _pagesIn_total pagesIn
+ perPage = _pagesIn_perPage pagesIn
+ reset = _pagesIn_reset pagesIn
+
+pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int)
+pageButtons total perPage reset = do
+ R.divClass "pages" $ do
+ rec
+ currentPage <- R.holdDyn 1 . R.leftmost $
+ [ firstPageClic
+ , previousPageClic
+ , pageClic
+ , nextPageClic
+ , lastPageClic
+ , 1 <$ reset
+ ]
+
+ firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
+
+ previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft
+
+ pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p ->
+ pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p))
+
+ nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight
+
+ lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
+
+ return currentPage
+
+ where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
+ pageEvent = R.switch . R.current . fmap R.leftmost
+ noCurrentPage = R.constDyn Nothing
+
+range :: Int -> Int -> [Int]
+range currentPage maxPage = [start..end]
+ where sidePages = 2
+ start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2))
+ end = min maxPage (start + sidePages * 2)
+
+pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int)
+pageButton currentPage page content = do
+ clic <- _buttonOut_clic <$> (Button.button $ ButtonIn
+ { _buttonIn_class = do
+ cp <- currentPage
+ p <- page
+ if cp == Just p then "page current" else "page"
+ , _buttonIn_content = content
+ , _buttonIn_waiting = R.never
+ , _buttonIn_tabIndex = Nothing
+ , _buttonIn_submit = False
+ })
+ return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index a77a18d..b431c14 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -4,35 +4,58 @@ module Component.Table
, TableOut(..)
) where
-import Data.Text (Text)
-import Reflex.Dom (Dynamic, MonadWidget)
-import qualified Reflex.Dom as R
+import Data.Text (Text)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Component.Pages (PagesIn (..), PagesOut (..))
+import qualified Component.Pages as Pages
data TableIn h r t = TableIn
{ _tableIn_headerLabel :: h -> Text
, _tableIn_rows :: Dynamic t [r]
, _tableIn_cell :: h -> r -> Text
+ , _tableIn_perPage :: Int
+ , _tableIn_resetPage :: Event t ()
}
data TableOut = TableOut
{}
table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut)
-table tableIn = do
+table tableIn =
R.divClass "table" $ do
+ rec
+ R.divClass "lines" $ do
+
+ R.divClass "header" $
+ flip mapM_ [minBound..] $ \header ->
+ R.divClass "cell" . R.text $
+ _tableIn_headerLabel tableIn header
+
+ let rows = getRange
+ (_tableIn_perPage tableIn)
+ <$> (_pagesOut_currentPage pages)
+ <*> (_tableIn_rows tableIn)
- R.divClass "lines" $ do
- R.divClass "header" $ do
- flip mapM_ [minBound..] $ \header ->
- R.divClass "cell" . R.text $
- _tableIn_headerLabel tableIn header
+ R.simpleList rows $ \r ->
+ R.divClass "row" $
+ flip mapM_ [minBound..] $ \h ->
+ R.divClass "cell name" $
+ R.dynText $
+ R.ffor r (_tableIn_cell tableIn h)
- R.simpleList (_tableIn_rows tableIn) $ \r ->
- R.divClass "row" $
- flip mapM_ [minBound..] $ \h ->
- R.divClass "cell name" $
- R.dynText $
- R.ffor r (_tableIn_cell tableIn h)
+ pages <- Pages.widget $ PagesIn
+ { _pagesIn_total = length <$> (_tableIn_rows tableIn)
+ , _pagesIn_perPage = _tableIn_perPage tableIn
+ , _pagesIn_reset = _tableIn_resetPage tableIn
+ }
+
+ return ()
return $ TableOut
{}
+
+getRange :: forall a. Int -> Int -> [a] -> [a]
+getRange perPage currentPage =
+ take perPage . drop ((currentPage - 1) * perPage)
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index d0c0a45..0fdd7d3 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -40,6 +40,8 @@ view incomeIn =
. _incomeIn_init
$ incomeIn
, _tableIn_cell = cell (_incomeIn_init incomeIn)
+ , _tableIn_perPage = 7
+ , _tableIn_resetPage = R.never
}
return ()
diff --git a/server/server.cabal b/server/server.cabal
index 75af442..426f521 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -74,6 +74,7 @@ Executable server
Design.Tooltip
Design.View.Header
Design.View.NotFound
+ Design.View.Pages
Design.View.Payment
Design.View.Payment.Add
Design.View.Payment.Delete
diff --git a/server/src/Design/View/Pages.hs b/server/src/Design/View/Pages.hs
new file mode 100644
index 0000000..1482ef4
--- /dev/null
+++ b/server/src/Design/View/Pages.hs
@@ -0,0 +1,55 @@
+module Design.View.Pages
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
+
+design :: Css
+design =
+ ".pages" ? do
+ display flex
+ justifyContent center
+
+ Media.desktop $ do
+ padding (px 40) (px 30) (px 30) (px 30)
+
+ Media.tablet $ do
+ padding (px 30) (px 30) (px 30) (px 30)
+
+ Media.mobile $ do
+ padding (px 20) (px 0) (px 20) (px 0)
+ lineHeight (px 40)
+
+ svg ? "path" ? ("fill" -: Color.toString Color.dustyGray)
+
+ ".page" ? do
+ display inlineBlock
+ fontWeight bold
+
+ Media.desktop $ do
+ Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken
+
+ Media.tabletDesktop $ do
+ border solid (px 2) Color.dustyGray
+ marginRight (px 10)
+
+ Media.tablet $ do
+ Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken
+ fontSize (px 15)
+
+ Media.mobile $ do
+ Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken
+ fontSize (px 12)
+ border solid (px 1) Color.dustyGray
+ marginRight (px 5)
+
+ ":not(.current)" & cursor pointer
+
+ ".current" & do
+ borderColor Color.chestnutRose
+ color Color.chestnutRose
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index bf39cff..73b7240 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -10,6 +10,7 @@ import qualified Design.Helper as Helper
import qualified Design.Media as Media
import qualified Design.View.Header as Header
import qualified Design.View.NotFound as NotFound
+import qualified Design.View.Pages as Pages
import qualified Design.View.Payment as Payment
import qualified Design.View.SignIn as SignIn
import qualified Design.View.Stat as Stat
@@ -23,6 +24,7 @@ design = do
".stat" ? Stat.design
".notfound" ? NotFound.design
Table.design
+ Pages.design
".withMargin" ? do
"margin" -: "0 2vw"
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 09:48:35 +0000