Setup stylish-haskell

2 files changed, 92 insertions, 67 deletions

diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index f9a2b4e..cf3e115 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
 
 module View.Payment.Pages
   ( widget
@@ -8,35 +7,45 @@ module View.Payment.Pages
   , PagesOut(..)
   ) where
 
-import qualified Data.Text as T
-import Reflex.Dom (MonadWidget)
-import qualified Reflex.Dom as R
+import qualified Data.Text    as T
+import           Reflex.Dom   (Event, Dynamic, 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 qualified Icon
 
 data PagesIn = PagesIn
   { _pagesIn_payments :: [Payment]
   }
 
-data PagesOut = PagesOut
-  {
+data PagesOut t = PagesOut
+  { _pagesOut_currentPage :: Dynamic t Int
   }
 
-widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut
+widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t)
 widget _ = do
-  R.divClass "pages" $ do
-    page Icon.doubleLeftBar
-    page Icon.doubleLeft
-    page (R.text . T.pack . show $ (1 :: Integer))
-    page (R.text . T.pack . show $ (2 :: Integer))
-    page (R.text . T.pack . show $ (3 :: Integer))
-    page (R.text . T.pack . show $ (4 :: Integer))
-    page (R.text . T.pack . show $ (5 :: Integer))
-    page Icon.doubleRight
-    page Icon.doubleRightBar
-  return $ PagesOut {}
-
-page :: forall t m. MonadWidget t m => m () -> m ()
-page content = R.elClass "button" "page" $ content
+  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"
+    , _buttonIn_content = content
+    , _buttonIn_waiting = R.never
+    })
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index f3eb9a7..734511d 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
 
 module View.Payment.Table
   ( widget
@@ -8,34 +7,40 @@ module View.Payment.Table
   , TableOut(..)
   ) where
 
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.List as L
-import qualified Data.Map as M
-import Prelude hiding (init)
-import Reflex.Dom (MonadWidget)
-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         (MonadWidget, Dynamic)
+import qualified Reflex.Dom         as R
 
-import qualified Common.Message as Message
+import qualified Common.Message     as Message
 import qualified Common.Message.Key as Key
-import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..))
-import qualified Common.Model as CM
-import qualified Common.Util.Text as T
+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
 
-data TableIn = TableIn
+data TableIn t = TableIn
   { _tableIn_init :: Init
+  , _tableIn_currentPage :: Dynamic t Int
   }
 
 data TableOut = TableOut
   {
   }
 
-widget :: forall t m. MonadWidget t m => TableIn -> m TableOut
+visiblePayments :: Int
+visiblePayments = 8
+
+widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut
 widget tableIn = do
-  R.divClass "table" $
+  R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn)
+  _ <- R.divClass "table" $
     R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
@@ -48,39 +53,50 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
       let init = _tableIn_init tableIn
           payments = _init_payments init
-      mapM_
-        (paymentRow init)
-        (take 8 . reverse . L.sortOn _payment_date $ payments)
+          paymentRange = fmap
+            (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments)
+            (_tableIn_currentPage tableIn)
+      R.simpleList paymentRange (paymentRow init)
   return $ TableOut {}
 
-paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m ()
+paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m ()
 paymentRow init payment =
   R.divClass "row" $ do
-    R.divClass "cell name" . R.text $ _payment_name payment
-    R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment
+    R.divClass "cell name" . R.dynText . fmap _payment_name $ payment
+    R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $  payment
+
+    let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init)
     R.divClass "cell user" $
-      case CM.findUser (_payment_user payment) (_init_users init) of
-        Just user -> R.text (_user_name user)
-        _ -> R.blank
-    R.divClass "cell category" $
-      case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of
-        Just category ->
-          R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $
-            R.text $ _category_name category
-        _ ->
-          R.blank
+      R.dynText $ flip fmap user $ \mbUser -> case mbUser of
+        Just u -> _user_name u
+        _         -> ""
+
+    let category = flip fmap payment $ \p -> findCategory
+          (_init_categories init)
+          (_init_paymentCategories init)
+          (_payment_name p)
+    R.divClass "cell category" $ do
+      let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of
+            Just c -> M.fromList
+              [ ("class", "tag")
+              , ("style", T.concat [ "background-color: ", _category_color c ])
+              ]
+            Nothing -> M.singleton "display" "none"
+      R.elDynAttr "span" attrs $
+        R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of
+          Just c -> _category_name c
+          _      -> ""
+
     R.divClass "cell date" $ do
-      R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment)
-      R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment)
+      R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment
+      R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment
     R.divClass "cell button" . R.el "button" $ Icon.clone
-    R.divClass "cell button" $
-      if _payment_user payment == (_init_currentUser init)
-        then R.el "button" $ Icon.edit
-        else R.blank
-    R.divClass "cell button" $
-      if _payment_user payment == (_init_currentUser init)
-        then R.el "button" $ Icon.delete
-        else R.blank
+    let modifyAttrs = flip fmap payment $ \p ->
+          M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")]
+    R.elDynAttr "div" modifyAttrs $
+      R.el "button" $ Icon.edit
+    R.elDynAttr "div" modifyAttrs $
+      R.el "button" $ Icon.delete
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do