Add dynamic pages

7 files changed, 105 insertions, 70 deletions

diff --git a/Makefile b/Makefile
index 16bf753..ac939fc 100644
--- a/Makefile
+++ b/Makefile
@@ -29,7 +29,7 @@ cp-client:
 	@cp dist-client/build/x86_64-linux/ghcjs-0.2.1/client-0.0.1/c/client/build/client/client.jsexe/all.js public/javascript/main.js
 
 watch-client:
-	@nix-shell -A shells.ghcjs --run "nodemon --delay 0.1 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'"
+	@nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'"
 
 # Server
 # ------
@@ -48,4 +48,4 @@ run-server:
 	@./dist-server/build/x86_64-linux/ghc-8.0.2/server-0.0.1/c/server/build/server/server
 
 watch-server:
-	@nix-shell -A shells.ghc --run "nodemon --delay 0.1 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'"
+	@nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'"
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
         }