Add dynamic pages

5 files changed, 80 insertions, 51 deletions

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
         }