aboutsummaryrefslogtreecommitdiff
path: root/client/src/Component
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Component')
-rw-r--r--client/src/Component/Pages.hs88
-rw-r--r--client/src/Component/Table.hs53
2 files changed, 126 insertions, 15 deletions
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)