Setup stylish-haskell

6 files changed, 148 insertions, 126 deletions

diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 1466811..442fa3e 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -1,23 +1,22 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
 
 module View.App
   ( widget
   ) where
 
-import qualified Reflex.Dom as R
-import Prelude hiding (init, error)
+import           Prelude            hiding (error, init)
+import qualified Reflex.Dom         as R
 
-import Common.Model (InitResult(..))
-import qualified Common.Message as Message
+import qualified Common.Message     as Message
 import qualified Common.Message.Key as Key
+import           Common.Model       (InitResult (..))
 
-import View.Header (HeaderIn(..))
-import View.Payment (PaymentIn(..))
-import qualified View.Header as Header
-import qualified View.Payment as Payment
-import qualified View.SignIn as SignIn
+import           View.Header        (HeaderIn (..))
+import qualified View.Header        as Header
+import           View.Payment       (PaymentIn (..))
+import qualified View.Payment       as Payment
+import qualified View.SignIn        as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 705e054..711ba80 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
 
 module View.Header
   ( view
@@ -8,19 +7,19 @@ module View.Header
   , HeaderOut(..)
   ) where
 
-import qualified Data.Map as M
-import Data.Time (NominalDiffTime)
-import Reflex.Dom (MonadWidget, Event)
-import qualified Reflex.Dom as R
-import Prelude hiding (init, error)
+import qualified Data.Map           as M
+import           Data.Time          (NominalDiffTime)
+import           Prelude            hiding (error, init)
+import           Reflex.Dom         (Event, MonadWidget)
+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 (InitResult(..), Init(..), User(..))
-import qualified Common.Model as CM
+import           Common.Model       (Init (..), InitResult (..), User (..))
+import qualified Common.Model       as CM
 
-import Component.Button (ButtonIn(..))
-import qualified Component.Button as Component
+import           Component.Button   (ButtonIn (..))
+import qualified Component.Button   as Component
 import qualified Icon
 
 data HeaderIn = HeaderIn
@@ -55,7 +54,7 @@ nameSignOut initResult = case initResult of
       signOut <- R.elDynAttr "nameSignOut" attr $ do
         case CM.findUser (_init_currentUser init) (_init_users init) of
           Just user -> R.divClass "name" $ R.text (_user_name user)
-          Nothing -> R.blank
+          Nothing   -> R.blank
         signOutButton
 
     return signOut
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index d1430c9..f70c8cd 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
 
 module View.Payment
   ( widget
@@ -8,14 +7,14 @@ module View.Payment
   , PaymentOut(..)
   ) where
 
-import Reflex.Dom (MonadWidget)
-import qualified Reflex.Dom as R
+import           Reflex.Dom         (MonadWidget)
+import qualified Reflex.Dom         as R
 
-import Common.Model (Init(..))
+import           Common.Model       (Init (..))
 
-import View.Payment.Pages (PagesIn(..))
+import           View.Payment.Pages (PagesIn (..), PagesOut (..))
 import qualified View.Payment.Pages as Pages
-import View.Payment.Table (TableIn(..))
+import           View.Payment.Table (TableIn (..))
 import qualified View.Payment.Table as Table
 
 data PaymentIn = PaymentIn
@@ -29,10 +28,12 @@ data PaymentOut = PaymentOut
 widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
 widget paymentIn = do
   R.divClass "payment" $ do
-    _ <- Table.widget $ TableIn
-      { _tableIn_init = _paymentIn_init paymentIn
-      }
-    _ <- Pages.widget $ PagesIn
-      { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn
-      }
+    rec
+      _ <- Table.widget $ TableIn
+        { _tableIn_init = _paymentIn_init paymentIn
+        , _tableIn_currentPage = _pagesOut_currentPage pagesOut
+        }
+      pagesOut <- Pages.widget $ PagesIn
+        { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn
+        }
     return $ PaymentOut {}
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
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index e164ee7..70c6b1f 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,27 +1,25 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
 
 module View.SignIn
   ( view
   ) where
 
-import qualified Data.Either as Either
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import Data.Time (NominalDiffTime)
-import Prelude hiding (error)
-import Reflex.Dom (MonadWidget, Event)
-import qualified Reflex.Dom as R
+import qualified Data.Either        as Either
+import           Data.Monoid        ((<>))
+import           Data.Text          (Text)
+import           Data.Time          (NominalDiffTime)
+import           Prelude            hiding (error)
+import           Reflex.Dom         (Event, MonadWidget)
+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 (SignIn(SignIn))
+import           Common.Model       (SignIn (SignIn))
 
-import Component.Input (InputIn(..), InputOut(..))
-import Component.Button (ButtonIn(..), ButtonOut(..))
-import qualified Component.Button as Component
-import qualified Component.Input as Component
+import           Component          (ButtonIn (..), ButtonOut (..),
+                                     InputIn (..), InputOut (..))
+import qualified Component          as Component
 
 view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
 view result =
@@ -75,11 +73,11 @@ showSignInResult result signInResult = do
   _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
   R.blank
 
-  where showInitResult (Left error) = showError error
+  where showInitResult (Left error)           = showError error
         showInitResult (Right (Just success)) = showSuccess success
-        showInitResult (Right Nothing) = R.blank
+        showInitResult (Right Nothing)        = R.blank
 
-        showResult (Left error) = showError error
+        showResult (Left error)    = showError error
         showResult (Right success) = showSuccess success
 
         showError = R.divClass "error" . R.text